Return to lex.c CVS log

Up to [Research Unix] / researchv10no / cmd / f2c

Annotation of researchv10no/cmd/f2c/lex.c, revision 1.1

1.1     ! root        1: /****************************************************************
        !             2: Copyright 1990, 1992 by AT&T Bell Laboratories and Bellcore.
        !             3: 
        !             4: Permission to use, copy, modify, and distribute this software
        !             5: and its documentation for any purpose and without fee is hereby
        !             6: granted, provided that the above copyright notice appear in all
        !             7: copies and that both that the copyright notice and this
        !             8: permission notice and warranty disclaimer appear in supporting
        !             9: documentation, and that the names of AT&T Bell Laboratories or
        !            10: Bellcore or any of their entities not be used in advertising or
        !            11: publicity pertaining to distribution of the software without
        !            12: specific, written prior permission.
        !            13: 
        !            14: AT&T and Bellcore disclaim all warranties with regard to this
        !            15: software, including all implied warranties of merchantability
        !            16: and fitness.  In no event shall AT&T or Bellcore be liable for
        !            17: any special, indirect or consequential damages or any damages
        !            18: whatsoever resulting from loss of use, data or profits, whether
        !            19: in an action of contract, negligence or other tortious action,
        !            20: arising out of or in connection with the use or performance of
        !            21: this software.
        !            22: ****************************************************************/
        !            23: 
        !            24: #include "defs.h"
        !            25: #include "tokdefs.h"
        !            26: #include "p1defs.h"
        !            27: 
        !            28: #ifdef NO_EOF_CHAR_CHECK
        !            29: #undef EOF_CHAR
        !            30: #else
        !            31: #ifndef EOF_CHAR
        !            32: #define EOF_CHAR 26    /* ASCII control-Z */
        !            33: #endif
        !            34: #endif
        !            35: 
        !            36: #define BLANK  ' '
        !            37: #define MYQUOTE (2)
        !            38: #define SEOF 0
        !            39: 
        !            40: /* card types */
        !            41: 
        !            42: #define STEOF 1
        !            43: #define STINITIAL 2
        !            44: #define STCONTINUE 3
        !            45: 
        !            46: /* lex states */
        !            47: 
        !            48: #define NEWSTMT        1
        !            49: #define FIRSTTOKEN     2
        !            50: #define OTHERTOKEN     3
        !            51: #define RETEOS 4
        !            52: 
        !            53: 
        !            54: LOCAL int stkey;       /* Type of the current statement (DO, END, IF, etc) */
        !            55: extern char token[];   /* holds the actual token text */
        !            56: static int needwkey;
        !            57: ftnint yystno;
        !            58: flag intonly;
        !            59: extern int new_dcl;
        !            60: LOCAL long int stno;
        !            61: LOCAL long int nxtstno;        /* Statement label */
        !            62: LOCAL int parlev;      /* Parentheses level */
        !            63: LOCAL int parseen;
        !            64: LOCAL int expcom;
        !            65: LOCAL int expeql;
        !            66: LOCAL char *nextch;
        !            67: LOCAL char *lastch;
        !            68: LOCAL char *nextcd     = NULL;
        !            69: LOCAL char *endcd;
        !            70: LOCAL long prevlin;
        !            71: LOCAL long thislin;
        !            72: LOCAL int code;                /* Card type; INITIAL, CONTINUE or EOF */
        !            73: LOCAL int lexstate     = NEWSTMT;
        !            74: LOCAL char *sbuf;      /* Main buffer for Fortran source input. */
        !            75: LOCAL char *send;      /* Was = sbuf+20*66 with sbuf[1390]. */
        !            76: LOCAL int maxcont;
        !            77: LOCAL int nincl        = 0;    /* Current number of include files */
        !            78: LOCAL long firstline;
        !            79: LOCAL char *laststb, *stb0;
        !            80: extern int addftnsrc;
        !            81: static char **linestart;
        !            82: LOCAL int ncont;
        !            83: LOCAL char comstart[Table_size];
        !            84: #define USC (unsigned char *)
        !            85: 
        !            86: static char anum_buf[Table_size];
        !            87: #define isalnum_(x) anum_buf[x]
        !            88: #define isalpha_(x) (anum_buf[x] == 1)
        !            89: 
        !            90: #define COMMENT_BUF_STORE 4088
        !            91: 
        !            92: typedef struct comment_buf {
        !            93:        struct comment_buf *next;
        !            94:        char *last;
        !            95:        char buf[COMMENT_BUF_STORE];
        !            96:        } comment_buf;
        !            97: static comment_buf *cbfirst, *cbcur;
        !            98: static char *cbinit, *cbnext, *cblast;
        !            99: static void flush_comments();
        !           100: extern flag use_bs;
        !           101: 
        !           102: 
        !           103: /* Comment buffering data
        !           104: 
        !           105:        Comments are kept in a list until the statement before them has
        !           106:    been parsed.  This list is implemented with the above comment_buf
        !           107:    structure and the pointers cbnext and cblast.
        !           108: 
        !           109:        The comments are stored with terminating NULL, and no other
        !           110:    intervening space.  The last few bytes of each block are likely to
        !           111:    remain unused.
        !           112: */
        !           113: 
        !           114: /* struct Inclfile   holds the state information for each include file */
        !           115: struct Inclfile
        !           116: {
        !           117:        struct Inclfile *inclnext;
        !           118:        FILEP inclfp;
        !           119:        char *inclname;
        !           120:        int incllno;
        !           121:        char *incllinp;
        !           122:        int incllen;
        !           123:        int inclcode;
        !           124:        ftnint inclstno;
        !           125: };
        !           126: 
        !           127: LOCAL struct Inclfile *inclp   =  NULL;
        !           128: struct Keylist {
        !           129:        char *keyname;
        !           130:        int keyval;
        !           131:        char notinf66;
        !           132: };
        !           133: struct Punctlist {
        !           134:        char punchar;
        !           135:        int punval;
        !           136: };
        !           137: struct Fmtlist {
        !           138:        char fmtchar;
        !           139:        int fmtval;
        !           140: };
        !           141: struct Dotlist {
        !           142:        char *dotname;
        !           143:        int dotval;
        !           144:        };
        !           145: LOCAL struct Keylist *keystart[26], *keyend[26];
        !           146: 
        !           147: /* KEYWORD AND SPECIAL CHARACTER TABLES
        !           148: */
        !           149: 
        !           150: static struct Punctlist puncts[ ] =
        !           151: {
        !           152:        '(', SLPAR,
        !           153:        ')', SRPAR,
        !           154:        '=', SEQUALS,
        !           155:        ',', SCOMMA,
        !           156:        '+', SPLUS,
        !           157:        '-', SMINUS,
        !           158:        '*', SSTAR,
        !           159:        '/', SSLASH,
        !           160:        '$', SCURRENCY,
        !           161:        ':', SCOLON,
        !           162:        '<', SLT,
        !           163:        '>', SGT,
        !           164:        0, 0 };
        !           165: 
        !           166: LOCAL struct Dotlist  dots[ ] =
        !           167: {
        !           168:        "and.", SAND,
        !           169:            "or.", SOR,
        !           170:            "not.", SNOT,
        !           171:            "true.", STRUE,
        !           172:            "false.", SFALSE,
        !           173:            "eq.", SEQ,
        !           174:            "ne.", SNE,
        !           175:            "lt.", SLT,
        !           176:            "le.", SLE,
        !           177:            "gt.", SGT,
        !           178:            "ge.", SGE,
        !           179:            "neqv.", SNEQV,
        !           180:            "eqv.", SEQV,
        !           181:            0, 0 };
        !           182: 
        !           183: LOCAL struct Keylist  keys[ ] =
        !           184: {
        !           185:        { "assign",  SASSIGN  },
        !           186:        { "automatic",  SAUTOMATIC, YES  },
        !           187:        { "backspace",  SBACKSPACE  },
        !           188:        { "blockdata",  SBLOCK  },
        !           189:        { "call",  SCALL  },
        !           190:        { "character",  SCHARACTER, YES  },
        !           191:        { "close",  SCLOSE, YES  },
        !           192:        { "common",  SCOMMON  },
        !           193:        { "complex",  SCOMPLEX  },
        !           194:        { "continue",  SCONTINUE  },
        !           195:        { "data",  SDATA  },
        !           196:        { "dimension",  SDIMENSION  },
        !           197:        { "doubleprecision",  SDOUBLE  },
        !           198:        { "doublecomplex", SDCOMPLEX, YES  },
        !           199:        { "elseif",  SELSEIF, YES  },
        !           200:        { "else",  SELSE, YES  },
        !           201:        { "endfile",  SENDFILE  },
        !           202:        { "endif",  SENDIF, YES  },
        !           203:        { "enddo", SENDDO, YES },
        !           204:        { "end",  SEND  },
        !           205:        { "entry",  SENTRY, YES  },
        !           206:        { "equivalence",  SEQUIV  },
        !           207:        { "external",  SEXTERNAL  },
        !           208:        { "format",  SFORMAT  },
        !           209:        { "function",  SFUNCTION  },
        !           210:        { "goto",  SGOTO  },
        !           211:        { "implicit",  SIMPLICIT, YES  },
        !           212:        { "include",  SINCLUDE, YES  },
        !           213:        { "inquire",  SINQUIRE, YES  },
        !           214:        { "intrinsic",  SINTRINSIC, YES  },
        !           215:        { "integer",  SINTEGER  },
        !           216:        { "logical",  SLOGICAL  },
        !           217:        { "namelist", SNAMELIST, YES },
        !           218:        { "none", SUNDEFINED, YES },
        !           219:        { "open",  SOPEN, YES  },
        !           220:        { "parameter",  SPARAM, YES  },
        !           221:        { "pause",  SPAUSE  },
        !           222:        { "print",  SPRINT  },
        !           223:        { "program",  SPROGRAM, YES  },
        !           224:        { "punch",  SPUNCH, YES  },
        !           225:        { "read",  SREAD  },
        !           226:        { "real",  SREAL  },
        !           227:        { "return",  SRETURN  },
        !           228:        { "rewind",  SREWIND  },
        !           229:        { "save",  SSAVE, YES  },
        !           230:        { "static",  SSTATIC, YES  },
        !           231:        { "stop",  SSTOP  },
        !           232:        { "subroutine",  SSUBROUTINE  },
        !           233:        { "then",  STHEN, YES  },
        !           234:        { "undefined", SUNDEFINED, YES  },
        !           235:        { "while", SWHILE, YES  },
        !           236:        { "write",  SWRITE  },
        !           237:        { 0, 0 }
        !           238: };
        !           239: 
        !           240: LOCAL void analyz(), crunch(), store_comment();
        !           241: LOCAL int getcd(), getcds(), getkwd(), gettok();
        !           242: LOCAL char *stbuf[3];
        !           243: 
        !           244: inilex(name)
        !           245: char *name;
        !           246: {
        !           247:        stbuf[0] = Alloc(3*P1_STMTBUFSIZE);
        !           248:        stbuf[1] = stbuf[0] + P1_STMTBUFSIZE;
        !           249:        stbuf[2] = stbuf[1] + P1_STMTBUFSIZE;
        !           250:        nincl = 0;
        !           251:        inclp = NULL;
        !           252:        doinclude(name);
        !           253:        lexstate = NEWSTMT;
        !           254:        return(NO);
        !           255: }
        !           256: 
        !           257: 
        !           258: 
        !           259: /* throw away the rest of the current line */
        !           260: flline()
        !           261: {
        !           262:        lexstate = RETEOS;
        !           263: }
        !           264: 
        !           265: 
        !           266: 
        !           267: char *lexline(n)
        !           268: int *n;
        !           269: {
        !           270:        *n = (lastch - nextch) + 1;
        !           271:        return(nextch);
        !           272: }
        !           273: 
        !           274: 
        !           275: 
        !           276: 
        !           277: 
        !           278: doinclude(name)
        !           279: char *name;
        !           280: {
        !           281:        FILEP fp;
        !           282:        struct Inclfile *t;
        !           283: 
        !           284:        if(inclp)
        !           285:        {
        !           286:                inclp->incllno = thislin;
        !           287:                inclp->inclcode = code;
        !           288:                inclp->inclstno = nxtstno;
        !           289:                if(nextcd)
        !           290:                        inclp->incllinp = copyn(inclp->incllen = endcd-nextcd , nextcd);
        !           291:                else
        !           292:                        inclp->incllinp = 0;
        !           293:        }
        !           294:        nextcd = NULL;
        !           295: 
        !           296:        if(++nincl >= MAXINCLUDES)
        !           297:                Fatal("includes nested too deep");
        !           298:        if(name[0] == '\0')
        !           299:                fp = stdin;
        !           300:        else
        !           301:                fp = fopen(name, textread);
        !           302:        if (fp)
        !           303:        {
        !           304:                t = inclp;
        !           305:                inclp = ALLOC(Inclfile);
        !           306:                inclp->inclnext = t;
        !           307:                prevlin = thislin = 0;
        !           308:                infname = inclp->inclname = name;
        !           309:                infile = inclp->inclfp = fp;
        !           310:        }
        !           311:        else
        !           312:        {
        !           313:                fprintf(diagfile, "Cannot open file %s\n", name);
        !           314:                done(1);
        !           315:        }
        !           316: }
        !           317: 
        !           318: 
        !           319: 
        !           320: 
        !           321: LOCAL popinclude()
        !           322: {
        !           323:        struct Inclfile *t;
        !           324:        register char *p;
        !           325:        register int k;
        !           326: 
        !           327:        if(infile != stdin)
        !           328:                clf(&infile, infname, 1);       /* Close the input file */
        !           329:        free(infname);
        !           330: 
        !           331:        --nincl;
        !           332:        t = inclp->inclnext;
        !           333:        free( (charptr) inclp);
        !           334:        inclp = t;
        !           335:        if(inclp == NULL) {
        !           336:                infname = 0;
        !           337:                return(NO);
        !           338:                }
        !           339: 
        !           340:        infile = inclp->inclfp;
        !           341:        infname = inclp->inclname;
        !           342:        prevlin = thislin = inclp->incllno;
        !           343:        code = inclp->inclcode;
        !           344:        stno = nxtstno = inclp->inclstno;
        !           345:        if(inclp->incllinp)
        !           346:        {
        !           347:                endcd = nextcd = sbuf;
        !           348:                k = inclp->incllen;
        !           349:                p = inclp->incllinp;
        !           350:                while(--k >= 0)
        !           351:                        *endcd++ = *p++;
        !           352:                free( (charptr) (inclp->incllinp) );
        !           353:        }
        !           354:        else
        !           355:                nextcd = NULL;
        !           356:        return(YES);
        !           357: }
        !           358: 
        !           359:  static void
        !           360: putlineno()
        !           361: {
        !           362:        static long lastline;
        !           363:        static char *lastfile = "??", *lastfile0 = "?";
        !           364:        static char fbuf[P1_FILENAME_MAX];
        !           365:        extern int gflag;
        !           366:        register char *s0, *s1;
        !           367: 
        !           368:        if (gflag) {
        !           369:                if (lastline) {
        !           370:                        if (lastfile != lastfile0) {
        !           371:                                p1puts(P1_FILENAME, fbuf);
        !           372:                                lastfile0 = lastfile;
        !           373:                                }
        !           374:                        p1_line_number(lastline);
        !           375:                        }
        !           376:                lastline = firstline;
        !           377:                if (lastfile != infname)
        !           378:                        if (lastfile = infname) {
        !           379:                                strncpy(fbuf, lastfile, sizeof(fbuf));
        !           380:                                fbuf[sizeof(fbuf)-1] = 0;
        !           381:                                }
        !           382:                        else
        !           383:                                fbuf[0] = 0;
        !           384:                }
        !           385:        if (addftnsrc) {
        !           386:                if (laststb && *laststb) {
        !           387:                        for(s1 = laststb; *s1; s1++) {
        !           388:                                for(s0 = s1; *s1 != '\n'; s1++)
        !           389:                                        if (*s1 == '*' && s1[1] == '/')
        !           390:                                                *s1 = '+';
        !           391:                                *s1 = 0;
        !           392:                                p1puts(P1_FORTRAN, s0);
        !           393:                                }
        !           394:                        *laststb = 0;   /* prevent trouble after EOF */
        !           395:                        }
        !           396:                laststb = stb0;
        !           397:                }
        !           398:        }
        !           399: 
        !           400: 
        !           401: yylex()
        !           402: {
        !           403:        static int  tokno;
        !           404:        int retval;
        !           405: 
        !           406:        switch(lexstate)
        !           407:        {
        !           408:        case NEWSTMT :  /* need a new statement */
        !           409:                retval = getcds();
        !           410:                putlineno();
        !           411:                if(retval == STEOF) {
        !           412:                        retval = SEOF;
        !           413:                        break;
        !           414:                } /* if getcds() == STEOF */
        !           415:                crunch();
        !           416:                tokno = 0;
        !           417:                lexstate = FIRSTTOKEN;
        !           418:                yystno = stno;
        !           419:                stno = nxtstno;
        !           420:                toklen = 0;
        !           421:                retval = SLABEL;
        !           422:                break;
        !           423: 
        !           424: first:
        !           425:        case FIRSTTOKEN :       /* first step on a statement */
        !           426:                analyz();
        !           427:                lexstate = OTHERTOKEN;
        !           428:                tokno = 1;
        !           429:                retval = stkey;
        !           430:                break;
        !           431: 
        !           432:        case OTHERTOKEN :       /* return next token */
        !           433:                if(nextch > lastch)
        !           434:                        goto reteos;
        !           435:                ++tokno;
        !           436:                if( (stkey==SLOGIF || stkey==SELSEIF) && parlev==0 && tokno>3)
        !           437:                        goto first;
        !           438: 
        !           439:                if(stkey==SASSIGN && tokno==3 && nextch<lastch &&
        !           440:                    nextch[0]=='t' && nextch[1]=='o')
        !           441:                {
        !           442:                        nextch+=2;
        !           443:                        retval = STO;
        !           444:                        break;
        !           445:                }
        !           446:                retval = gettok();
        !           447:                break;
        !           448: 
        !           449: reteos:
        !           450:        case RETEOS:
        !           451:                lexstate = NEWSTMT;
        !           452:                retval = SEOS;
        !           453:                break;
        !           454:        default:
        !           455:                fatali("impossible lexstate %d", lexstate);
        !           456:                break;
        !           457:        }
        !           458: 
        !           459:        if (retval == SEOF)
        !           460:            flush_comments ();
        !           461: 
        !           462:        return retval;
        !           463: }
        !           464: 
        !           465:  LOCAL void
        !           466: contmax()
        !           467: {
        !           468:        lineno = thislin;
        !           469:        many("continuation lines", 'C', maxcontin);
        !           470:        }
        !           471: 
        !           472: /* Get Cards.
        !           473: 
        !           474:    Returns STEOF or STINITIAL, never STCONTINUE.  Any continuation cards get
        !           475: merged into one long card (hence the size of the buffer named   sbuf)   */
        !           476: 
        !           477:  LOCAL int
        !           478: getcds()
        !           479: {
        !           480:        register char *p, *q;
        !           481: 
        !           482:        flush_comments ();
        !           483: top:
        !           484:        if(nextcd == NULL)
        !           485:        {
        !           486:                code = getcd( nextcd = sbuf, 1 );
        !           487:                stno = nxtstno;
        !           488:                prevlin = thislin;
        !           489:        }
        !           490:        if(code == STEOF)
        !           491:                if( popinclude() )
        !           492:                        goto top;
        !           493:                else
        !           494:                        return(STEOF);
        !           495: 
        !           496:        if(code == STCONTINUE)
        !           497:        {
        !           498:                lineno = thislin;
        !           499:                nextcd = NULL;
        !           500:                goto top;
        !           501:        }
        !           502: 
        !           503: /* Get rid of unused space at the head of the buffer */
        !           504: 
        !           505:        if(nextcd > sbuf)
        !           506:        {
        !           507:                q = nextcd;
        !           508:                p = sbuf;
        !           509:                while(q < endcd)
        !           510:                        *p++ = *q++;
        !           511:                endcd = p;
        !           512:        }
        !           513: 
        !           514: /* Be aware that the input (i.e. the string at the address   nextcd)   is NOT
        !           515:    NULL-terminated */
        !           516: 
        !           517: /* This loop merges all continuations into one long statement, AND puts the next
        !           518:    card to be read at the end of the buffer (i.e. it stores the look-ahead card
        !           519:    when there's room) */
        !           520: 
        !           521:        ncont = 0;
        !           522:        for(;;) {
        !           523:                nextcd = endcd;
        !           524:                if (ncont >= maxcont || nextcd+66 > send)
        !           525:                        contmax();
        !           526:                linestart[ncont++] = nextcd;
        !           527:                if ((code = getcd(nextcd,0)) != STCONTINUE)
        !           528:                        break;
        !           529:                if (ncont == 20 && noextflag) {
        !           530:                        lineno = thislin;
        !           531:                        errext("more than 19 continuation lines");
        !           532:                        }
        !           533:                }
        !           534:        nextch = sbuf;
        !           535:        lastch = nextcd - 1;
        !           536: 
        !           537:        lineno = prevlin;
        !           538:        prevlin = thislin;
        !           539:        return(STINITIAL);
        !           540: }
        !           541: 
        !           542:  static void
        !           543: bang(a,b,c,d,e)                /* save ! comments */
        !           544:  char *a, *b, *c;
        !           545:  register char *d, *e;
        !           546: {
        !           547:        char buf[COMMENT_BUFFER_SIZE + 1];
        !           548:        register char *p, *pe;
        !           549: 
        !           550:        p = buf;
        !           551:        pe = buf + COMMENT_BUFFER_SIZE;
        !           552:        *pe = 0;
        !           553:        while(a < b)
        !           554:                if (!(*p++ = *a++))
        !           555:                        p[-1] = 0;
        !           556:        if (b < c)
        !           557:                *p++ = '\t';
        !           558:        while(d < e) {
        !           559:                if (!(*p++ = *d++))
        !           560:                        p[-1] = ' ';
        !           561:                if (p == pe) {
        !           562:                        store_comment(buf);
        !           563:                        p = buf;
        !           564:                        }
        !           565:                }
        !           566:        if (p > buf) {
        !           567:                while(--p >= buf && *p == ' ');
        !           568:                p[1] = 0;
        !           569:                store_comment(buf);
        !           570:                }
        !           571:        }
        !           572: 
        !           573: 
        !           574: /* getcd - Get next input card
        !           575: 
        !           576:        This function reads the next input card from global file pointer   infile.
        !           577: It assumes that   b   points to currently empty storage somewhere in  sbuf  */
        !           578: 
        !           579:  LOCAL int
        !           580: getcd(b, nocont)
        !           581:  register char *b;
        !           582: {
        !           583:        register int c;
        !           584:        register char *p, *bend;
        !           585:        int speclin;            /* Special line - true when the line is allowed
        !           586:                                   to have more than 66 characters (e.g. the
        !           587:                                   "&" shorthand for continuation, use of a "\t"
        !           588:                                   to skip part of the label columns) */
        !           589:        static char a[6];       /* Statement label buffer */
        !           590:        static char *aend       = a+6;
        !           591:        static char *stb, *stbend;
        !           592:        static int nst;
        !           593:        char *atend, *endcd0;
        !           594:        extern int warn72;
        !           595:        char buf72[24];
        !           596:        int amp, i;
        !           597:        char storage[COMMENT_BUFFER_SIZE + 1];
        !           598:        char *pointer;
        !           599: 
        !           600: top:
        !           601:        endcd = b;
        !           602:        bend = b+66;
        !           603:        amp = speclin = NO;
        !           604:        atend = aend;
        !           605: 
        !           606: /* Handle the continuation shorthand of "&" in the first column, which stands
        !           607:    for "     x" */
        !           608: 
        !           609:        if( (c = getc(infile)) == '&')
        !           610:        {
        !           611:                a[0] = c;
        !           612:                a[1] = 0;
        !           613:                a[5] = 'x';
        !           614:                amp = speclin = YES;
        !           615:                bend = send;
        !           616:                p = aend;
        !           617:        }
        !           618: 
        !           619: /* Handle the Comment cards (a 'C', 'c', '*', or '!' in the first column). */
        !           620: 
        !           621:        else if(comstart[c & 0xfff])
        !           622:        {
        !           623:                if (feof (infile)
        !           624: #ifdef EOF_CHAR
        !           625:                         || c == EOF_CHAR
        !           626: #endif
        !           627:                                        )
        !           628:                    return STEOF;
        !           629: 
        !           630:                storage[COMMENT_BUFFER_SIZE] = c = '\0';
        !           631:                pointer = storage;
        !           632:                while( !feof (infile) && (*pointer++ = c = getc(infile)) != '\n') {
        !           633: 
        !           634: /* Handle obscure end of file conditions on many machines */
        !           635: 
        !           636:                        if (feof (infile) && (c == '\377' || c == EOF)) {
        !           637:                            pointer--;
        !           638:                            break;
        !           639:                        } /* if (feof (infile)) */
        !           640: 
        !           641:                        if (c == '\0')
        !           642:                                *(pointer - 1) = ' ';
        !           643: 
        !           644:                        if (pointer == &storage[COMMENT_BUFFER_SIZE]) {
        !           645:                                store_comment (storage);
        !           646:                                pointer = storage;
        !           647:                        } /* if (pointer == BUFFER_SIZE) */
        !           648:                } /* while */
        !           649: 
        !           650:                if (pointer > storage) {
        !           651:                    if (c == '\n')
        !           652: 
        !           653: /* Get rid of the newline */
        !           654: 
        !           655:                        pointer[-1] = 0;
        !           656:                    else
        !           657:                        *pointer = 0;
        !           658: 
        !           659:                    store_comment (storage);
        !           660:                } /* if */
        !           661: 
        !           662:                if (feof (infile))
        !           663:                    if (c != '\n')      /* To allow the line index to
        !           664:                                           increment correctly */
        !           665:                        return STEOF;
        !           666: 
        !           667:                ++thislin;
        !           668:                goto top;
        !           669:        }
        !           670: 
        !           671:        else if(c != EOF)
        !           672:        {
        !           673: 
        !           674: /* Load buffer   a   with the statement label */
        !           675: 
        !           676:                /* a tab in columns 1-6 skips to column 7 */
        !           677:                ungetc(c, infile);
        !           678:                for(p=a; p<aend && (c=getc(infile)) != '\n' && c!=EOF; )
        !           679:                        if(c == '\t')
        !           680: 
        !           681: /* The tab character translates into blank characters in the statement label */
        !           682: 
        !           683:                        {
        !           684:                                atend = p;
        !           685:                                while(p < aend)
        !           686:                                        *p++ = BLANK;
        !           687:                                speclin = YES;
        !           688:                                bend = send;
        !           689:                        }
        !           690:                        else
        !           691:                                *p++ = c;
        !           692:        }
        !           693: 
        !           694: /* By now we've read either a continuation character or the statement label
        !           695:    field */
        !           696: 
        !           697:        if(c == EOF)
        !           698:                return(STEOF);
        !           699: 
        !           700: /* The next 'if' block handles lines that have fewer than 7 characters */
        !           701: 
        !           702:        if(c == '\n')
        !           703:        {
        !           704:                while(p < aend)
        !           705:                        *p++ = BLANK;
        !           706: 
        !           707: /* Blank out the buffer on lines which are not longer than 66 characters */
        !           708: 
        !           709:                endcd0 = endcd;
        !           710:                if( ! speclin )
        !           711:                        while(endcd < bend)
        !           712:                                *endcd++ = BLANK;
        !           713:        }
        !           714:        else    {       /* read body of line */
        !           715:                if (warn72 & 2) {
        !           716:                        speclin = YES;
        !           717:                        bend = send;
        !           718:                        }
        !           719:                while( endcd<bend && (c=getc(infile)) != '\n' && c!=EOF )
        !           720:                        *endcd++ = c;
        !           721:                if(c == EOF)
        !           722:                        return(STEOF);
        !           723: 
        !           724: /* Drop any extra characters on the input card; this usually means those after
        !           725:    column 72 */
        !           726: 
        !           727:                if(c != '\n')
        !           728:                {
        !           729:                        i = 0;
        !           730:                        while( (c=getc(infile)) != '\n' && c != EOF)
        !           731:                                if (i < 23)
        !           732:                                        buf72[i++] = c;
        !           733:                        if (warn72 && i && !speclin) {
        !           734:                                buf72[i] = 0;
        !           735:                                if (i >= 23)
        !           736:                                        strcpy(buf72+20, "...");
        !           737:                                lineno = thislin + 1;
        !           738:                                errstr("text after column 72: %s", buf72);
        !           739:                                }
        !           740:                        if(c == EOF)
        !           741:                                return(STEOF);
        !           742:                }
        !           743: 
        !           744:                endcd0 = endcd;
        !           745:                if( ! speclin )
        !           746:                        while(endcd < bend)
        !           747:                                *endcd++ = BLANK;
        !           748:        }
        !           749: 
        !           750: /* The flow of control usually gets to this line (unless an earlier RETURN has
        !           751:    been taken) */
        !           752: 
        !           753:        ++thislin;
        !           754: 
        !           755:        /* Fortran 77 specifies that a 0 in column 6 */
        !           756:        /* does not signify continuation */
        !           757: 
        !           758:        if( !isspace(a[5]) && a[5]!='0') {
        !           759:                if (!amp)
        !           760:                        for(p = a; p < aend;)
        !           761:                                if (*p++ == '!' && p != aend)
        !           762:                                        goto initcheck;
        !           763:                if (addftnsrc && stb) {
        !           764:                        if (stbend > stb + 7) { /* otherwise forget col 1-6 */
        !           765:                                /* kludge around funny p1gets behavior */
        !           766:                                *stb++ = '$';
        !           767:                                if (amp)
        !           768:                                        *stb++ = '&';
        !           769:                                else
        !           770:                                        for(p = a; p < atend;)
        !           771:                                                *stb++ = *p++;
        !           772:                                }
        !           773:                        if (endcd0 - b > stbend - stb) {
        !           774:                                if (stb > stbend)
        !           775:                                        stb = stbend;
        !           776:                                endcd0 = b + (stbend - stb);
        !           777:                                }
        !           778:                        for(p = b; p < endcd0;)
        !           779:                                *stb++ = *p++;
        !           780:                        *stb++ = '\n';
        !           781:                        *stb = 0;
        !           782:                        }
        !           783:                if (nocont) {
        !           784:                        lineno = thislin;
        !           785:                        errstr("illegal continuation card (starts \"%.6s\")",a);
        !           786:                        }
        !           787:                else if (!amp && strncmp(a,"     ",5)) {
        !           788:                        lineno = thislin;
        !           789:                        errstr("labeled continuation line (starts \"%.6s\")",a);
        !           790:                        }
        !           791:                return(STCONTINUE);
        !           792:                }
        !           793: initcheck:
        !           794:        for(p=a; p<atend; ++p)
        !           795:                if( !isspace(*p) ) {
        !           796:                        if (*p++ != '!')
        !           797:                                goto initline;
        !           798:                        bang(p, atend, aend, b, endcd);
        !           799:                        goto top;
        !           800:                        }
        !           801:        for(p = b ; p<endcd ; ++p)
        !           802:                if( !isspace(*p) ) {
        !           803:                        if (*p++ != '!')
        !           804:                                goto initline;
        !           805:                        bang(a, a, a, p, endcd);
        !           806:                        goto top;
        !           807:                        }
        !           808: 
        !           809: /* Skip over blank cards by reading the next one right away */
        !           810: 
        !           811:        goto top;
        !           812: 
        !           813: initline:
        !           814:        if (addftnsrc) {
        !           815:                nst = (nst+1)%3;
        !           816:                if (!laststb && stb0)
        !           817:                        laststb = stb0;
        !           818:                stb0 = stb = stbuf[nst];
        !           819:                *stb++ = '$';   /* kludge around funny p1gets behavior */
        !           820:                stbend = stb + sizeof(stbuf[0])-2;
        !           821:                for(p = a; p < atend;)
        !           822:                        *stb++ = *p++;
        !           823:                if (atend < aend)
        !           824:                        *stb++ = '\t';
        !           825:                for(p = b; p < endcd0;)
        !           826:                        *stb++ = *p++;
        !           827:                *stb++ = '\n';
        !           828:                *stb = 0;
        !           829:                }
        !           830: 
        !           831: /* Set   nxtstno   equal to the integer value of the statement label */
        !           832: 
        !           833:        nxtstno = 0;
        !           834:        bend = a + 5;
        !           835:        for(p = a ; p < bend ; ++p)
        !           836:                if( !isspace(*p) )
        !           837:                        if(isdigit(*p))
        !           838:                                nxtstno = 10*nxtstno + (*p - '0');
        !           839:                        else if (*p == '!') {
        !           840:                                if (!addftnsrc)
        !           841:                                        bang(p+1,atend,aend,b,endcd);
        !           842:                                endcd = b;
        !           843:                                break;
        !           844:                                }
        !           845:                        else    {
        !           846:                                lineno = thislin;
        !           847:                                errstr(
        !           848:                                "nondigit in statement label field \"%.5s\"", a);
        !           849:                                nxtstno = 0;
        !           850:                                break;
        !           851:                        }
        !           852:        firstline = thislin;
        !           853:        return(STINITIAL);
        !           854: }
        !           855: 
        !           856: 
        !           857: /* crunch -- deletes all space characters, folds the backslash chars and
        !           858:    Hollerith strings, quotes the Fortran strings */
        !           859: 
        !           860:  LOCAL void
        !           861: crunch()
        !           862: {
        !           863:        register char *i, *j, *j0, *j1, *prvstr;
        !           864:        int k, ten, nh, nh0, quote;
        !           865: 
        !           866:        /* i is the next input character to be looked at
        !           867:           j is the next output character */
        !           868: 
        !           869:        new_dcl = needwkey = parlev = parseen = 0;
        !           870:        expcom = 0;     /* exposed ','s */
        !           871:        expeql = 0;     /* exposed equal signs */
        !           872:        j = sbuf;
        !           873:        prvstr = sbuf;
        !           874:        k = 0;
        !           875:        for(i=sbuf ; i<=lastch ; ++i)
        !           876:        {
        !           877:                if(isspace(*i) )
        !           878:                        continue;
        !           879:                if (*i == '!') {
        !           880:                        while(i >= linestart[k])
        !           881:                                if (++k >= maxcont)
        !           882:                                        contmax();
        !           883:                        j0 = linestart[k];
        !           884:                        if (!addftnsrc)
        !           885:                                bang(sbuf,sbuf,sbuf,i+1,j0);
        !           886:                        i = j0-1;
        !           887:                        continue;
        !           888:                        }
        !           889: 
        !           890: /* Keep everything in a quoted string */
        !           891: 
        !           892:                if(*i=='\'' ||  *i=='"')
        !           893:                {
        !           894:                        int len = 0;
        !           895: 
        !           896:                        quote = *i;
        !           897:                        *j = MYQUOTE; /* special marker */
        !           898:                        for(;;)
        !           899:                        {
        !           900:                                if(++i > lastch)
        !           901:                                {
        !           902:                                        err("unbalanced quotes; closing quote supplied");
        !           903:                                        if (j >= lastch)
        !           904:                                                j = lastch - 1;
        !           905:                                        break;
        !           906:                                }
        !           907:                                if(*i == quote)
        !           908:                                        if(i<lastch && i[1]==quote) ++i;
        !           909:                                        else break;
        !           910:                                else if(*i=='\\' && i<lastch && use_bs) {
        !           911:                                        ++i;
        !           912:                                        *i = escapes[*(unsigned char *)i];
        !           913:                                        }
        !           914:                                if (len + 2 < MAXTOKENLEN)
        !           915:                                    *++j = *i;
        !           916:                                else if (len + 2 == MAXTOKENLEN)
        !           917:                                    erri
        !           918:            ("String too long, truncating to %d chars", MAXTOKENLEN - 2);
        !           919:                                len++;
        !           920:                        } /* for (;;) */
        !           921: 
        !           922:                        j[1] = MYQUOTE;
        !           923:                        j += 2;
        !           924:                        prvstr = j;
        !           925:                }
        !           926:                else if( (*i=='h' || *i=='H')  && j>prvstr)     /* test for Hollerith strings */
        !           927:                {
        !           928:                        j0 = j - 1;
        !           929:                        if( ! isdigit(*j0)) goto copychar;
        !           930:                        nh = *j0 - '0';
        !           931:                        ten = 10;
        !           932:                        j1 = prvstr;
        !           933:                        if (j1+4 < j)
        !           934:                                j1 = j-4;
        !           935:                        for(;;) {
        !           936:                                if (j0-- <= j1)
        !           937:                                        goto copychar;
        !           938:                                if( ! isdigit(*j0 ) ) break;
        !           939:                                nh += ten * (*j0-'0');
        !           940:                                ten*=10;
        !           941:                                }
        !           942:                        /* a hollerith must be preceded by a punctuation mark.
        !           943:    '*' is possible only as repetition factor in a data statement
        !           944:    not, in particular, in character*2h
        !           945: */
        !           946: 
        !           947:                        if( !(*j0=='*'&&sbuf[0]=='d') && *j0!='/'
        !           948:                        && *j0!='(' && *j0!=',' && *j0!='=' && *j0!='.')
        !           949:                                goto copychar;
        !           950:                        nh0 = nh;
        !           951:                        if(i+nh > lastch || nh + 2 > MAXTOKENLEN)
        !           952:                        {
        !           953:                                erri("%dH too big", nh);
        !           954:                                nh = lastch - i;
        !           955:                                if (nh > MAXTOKENLEN - 2)
        !           956:                                        nh = MAXTOKENLEN - 2;
        !           957:                                nh0 = -1;
        !           958:                        }
        !           959:                        j0[1] = MYQUOTE; /* special marker */
        !           960:                        j = j0 + 1;
        !           961:                        while(nh-- > 0)
        !           962:                        {
        !           963:                                if (++i > lastch) {
        !           964:  hol_overflow:
        !           965:                                        if (nh0 >= 0)
        !           966:                                          erri("escapes make %dH too big",
        !           967:                                                nh0);
        !           968:                                        break;
        !           969:                                        }
        !           970:                                if(*i == '\\' && use_bs) {
        !           971:                                        if (++i > lastch)
        !           972:                                                goto hol_overflow;
        !           973:                                        *i = escapes[*(unsigned char *)i];
        !           974:                                        }
        !           975:                                *++j = *i;
        !           976:                        }
        !           977:                        j[1] = MYQUOTE;
        !           978:                        j+=2;
        !           979:                        prvstr = j;
        !           980:                }
        !           981:                else    {
        !           982:                        if(*i == '(') parseen = ++parlev;
        !           983:                        else if(*i == ')') --parlev;
        !           984:                        else if(parlev == 0)
        !           985:                                if(*i == '=') expeql = 1;
        !           986:                                else if(*i == ',') expcom = 1;
        !           987: copychar:              /*not a string or space -- copy, shifting case if necessary */
        !           988:                        if(shiftcase && isupper(*i))
        !           989:                                *j++ = tolower(*i);
        !           990:                        else    *j++ = *i;
        !           991:                }
        !           992:        }
        !           993:        lastch = j - 1;
        !           994:        nextch = sbuf;
        !           995: }
        !           996: 
        !           997:  LOCAL void
        !           998: analyz()
        !           999: {
        !          1000:        register char *i;
        !          1001: 
        !          1002:        if(parlev != 0)
        !          1003:        {
        !          1004:                err("unbalanced parentheses, statement skipped");
        !          1005:                stkey = SUNKNOWN;
        !          1006:                lastch = sbuf - 1; /* prevent double error msg */
        !          1007:                return;
        !          1008:        }
        !          1009:        if(nextch+2<=lastch && nextch[0]=='i' && nextch[1]=='f' && nextch[2]=='(')
        !          1010:        {
        !          1011:                /* assignment or if statement -- look at character after balancing paren */
        !          1012:                parlev = 1;
        !          1013:                for(i=nextch+3 ; i<=lastch; ++i)
        !          1014:                        if(*i == (MYQUOTE))
        !          1015:                        {
        !          1016:                                while(*++i != MYQUOTE)
        !          1017:                                        ;
        !          1018:                        }
        !          1019:                        else if(*i == '(')
        !          1020:                                ++parlev;
        !          1021:                        else if(*i == ')')
        !          1022:                        {
        !          1023:                                if(--parlev == 0)
        !          1024:                                        break;
        !          1025:                        }
        !          1026:                if(i >= lastch)
        !          1027:                        stkey = SLOGIF;
        !          1028:                else if(i[1] == '=')
        !          1029:                        stkey = SLET;
        !          1030:                else if( isdigit(i[1]) )
        !          1031:                        stkey = SARITHIF;
        !          1032:                else    stkey = SLOGIF;
        !          1033:                if(stkey != SLET)
        !          1034:                        nextch += 2;
        !          1035:        }
        !          1036:        else if(expeql) /* may be an assignment */
        !          1037:        {
        !          1038:                if(expcom && nextch<lastch &&
        !          1039:                    nextch[0]=='d' && nextch[1]=='o')
        !          1040:                {
        !          1041:                        stkey = SDO;
        !          1042:                        nextch += 2;
        !          1043:                }
        !          1044:                else    stkey = SLET;
        !          1045:        }
        !          1046:        else if (parseen && nextch + 7 < lastch
        !          1047:                        && nextch[2] != 'u' /* screen out "double..." early */
        !          1048:                        && nextch[0] == 'd' && nextch[1] == 'o'
        !          1049:                        && ((nextch[2] >= '0' && nextch[2] <= '9')
        !          1050:                                || nextch[2] == ','
        !          1051:                                || nextch[2] == 'w'))
        !          1052:                {
        !          1053:                stkey = SDO;
        !          1054:                nextch += 2;
        !          1055:                needwkey = 1;
        !          1056:                }
        !          1057:        /* otherwise search for keyword */
        !          1058:        else    {
        !          1059:                stkey = getkwd();
        !          1060:                if(stkey==SGOTO && lastch>=nextch)
        !          1061:                        if(nextch[0]=='(')
        !          1062:                                stkey = SCOMPGOTO;
        !          1063:                        else if(isalpha_(* USC nextch))
        !          1064:                                stkey = SASGOTO;
        !          1065:        }
        !          1066:        parlev = 0;
        !          1067: }
        !          1068: 
        !          1069: 
        !          1070: 
        !          1071:  LOCAL int
        !          1072: getkwd()
        !          1073: {
        !          1074:        register char *i, *j;
        !          1075:        register struct Keylist *pk, *pend;
        !          1076:        int k;
        !          1077: 
        !          1078:        if(! isalpha_(* USC nextch) )
        !          1079:                return(SUNKNOWN);
        !          1080:        k = letter(nextch[0]);
        !          1081:        if(pk = keystart[k])
        !          1082:                for(pend = keyend[k] ; pk<=pend ; ++pk )
        !          1083:                {
        !          1084:                        i = pk->keyname;
        !          1085:                        j = nextch;
        !          1086:                        while(*++i==*++j && *i!='\0')
        !          1087:                                ;
        !          1088:                        if(*i=='\0' && j<=lastch+1)
        !          1089:                        {
        !          1090:                                nextch = j;
        !          1091:                                if(no66flag && pk->notinf66)
        !          1092:                                        errstr("Not a Fortran 66 keyword: %s",
        !          1093:                                            pk->keyname);
        !          1094:                                return(pk->keyval);
        !          1095:                        }
        !          1096:                }
        !          1097:        return(SUNKNOWN);
        !          1098: }
        !          1099: 
        !          1100: initkey()
        !          1101: {
        !          1102:        register struct Keylist *p;
        !          1103:        register int i,j;
        !          1104:        register char *s;
        !          1105: 
        !          1106:        for(i = 0 ; i<26 ; ++i)
        !          1107:                keystart[i] = NULL;
        !          1108: 
        !          1109:        for(p = keys ; p->keyname ; ++p) {
        !          1110:                j = letter(p->keyname[0]);
        !          1111:                if(keystart[j] == NULL)
        !          1112:                        keystart[j] = p;
        !          1113:                keyend[j] = p;
        !          1114:                }
        !          1115:        i = (maxcontin + 2) * 66;
        !          1116:        sbuf = (char *)ckalloc(i + 70);
        !          1117:        send = sbuf + i;
        !          1118:        maxcont = maxcontin + 1;
        !          1119:        linestart = (char **)ckalloc(maxcont*sizeof(char*));
        !          1120:        comstart['c'] = comstart['C'] = comstart['*'] = comstart['!'] = 1;
        !          1121: #ifdef EOF_CHAR
        !          1122:        comstart[EOF_CHAR] = 1;
        !          1123: #endif
        !          1124:        s = "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ_";
        !          1125:        while(i = *s++)
        !          1126:                anum_buf[i] = 1;
        !          1127:        s = "0123456789";
        !          1128:        while(i = *s++)
        !          1129:                anum_buf[i] = 2;
        !          1130:        }
        !          1131: 
        !          1132:  LOCAL int
        !          1133: hexcheck(key)
        !          1134:  int key;
        !          1135: {
        !          1136:        register int radix;
        !          1137:        register char *p;
        !          1138:        char *kind;
        !          1139: 
        !          1140:        switch(key) {
        !          1141:                case 'z':
        !          1142:                case 'Z':
        !          1143:                case 'x':
        !          1144:                case 'X':
        !          1145:                        radix = 16;
        !          1146:                        key = SHEXCON;
        !          1147:                        kind = "hexadecimal";
        !          1148:                        break;
        !          1149:                case 'o':
        !          1150:                case 'O':
        !          1151:                        radix = 8;
        !          1152:                        key = SOCTCON;
        !          1153:                        kind = "octal";
        !          1154:                        break;
        !          1155:                case 'b':
        !          1156:                case 'B':
        !          1157:                        radix = 2;
        !          1158:                        key = SBITCON;
        !          1159:                        kind = "binary";
        !          1160:                        break;
        !          1161:                default:
        !          1162:                        err("bad bit identifier");
        !          1163:                        return(SNAME);
        !          1164:                }
        !          1165:        for(p = token; *p; p++)
        !          1166:                if (hextoi(*p) >= radix) {
        !          1167:                        errstr("invalid %s character", kind);
        !          1168:                        break;
        !          1169:                        }
        !          1170:        return key;
        !          1171:        }
        !          1172: 
        !          1173: /* gettok -- moves the right amount of text from   nextch   into the   token
        !          1174:    buffer.   token   initially contains garbage (leftovers from the prev token) */
        !          1175: 
        !          1176:  LOCAL int
        !          1177: gettok()
        !          1178: {
        !          1179: int havdot, havexp, havdbl;
        !          1180:        int radix, val;
        !          1181:        struct Punctlist *pp;
        !          1182:        struct Dotlist *pd;
        !          1183:        register int ch;
        !          1184: 
        !          1185:        char *i, *j, *n1, *p;
        !          1186: 
        !          1187:        ch = * USC nextch;
        !          1188:        if(ch == (MYQUOTE))
        !          1189:        {
        !          1190:                ++nextch;
        !          1191:                p = token;
        !          1192:                while(*nextch != MYQUOTE)
        !          1193:                        *p++ = *nextch++;
        !          1194:                toklen = p - token;
        !          1195:                *p = 0;
        !          1196:                /* allow octal, binary, hex constants of the form 'abc'x (etc.) */
        !          1197:                if (++nextch <= lastch && isalpha_(val = * USC nextch)) {
        !          1198:                        ++nextch;
        !          1199:                        return hexcheck(val);
        !          1200:                        }
        !          1201:                return (SHOLLERITH);
        !          1202:        }
        !          1203: 
        !          1204:        if(needkwd)
        !          1205:        {
        !          1206:                needkwd = 0;
        !          1207:                return( getkwd() );
        !          1208:        }
        !          1209: 
        !          1210:        for(pp=puncts; pp->punchar; ++pp)
        !          1211:                if(ch == pp->punchar) {
        !          1212:                        val = pp->punval;
        !          1213:                        if (++nextch <= lastch)
        !          1214:                            switch(ch) {
        !          1215:                                case '/':
        !          1216:                                        if (*nextch == '/') {
        !          1217:                                                nextch++;
        !          1218:                                                val = SCONCAT;
        !          1219:                                                }
        !          1220:                                        else if (new_dcl && parlev == 0)
        !          1221:                                                val = SSLASHD;
        !          1222:                                        return val;
        !          1223:                                case '*':
        !          1224:                                        if (*nextch == '*') {
        !          1225:                                                nextch++;
        !          1226:                                                return SPOWER;
        !          1227:                                                }
        !          1228:                                        break;
        !          1229:                                case '<':
        !          1230:                                        if (*nextch == '=') {
        !          1231:                                                nextch++;
        !          1232:                                                val = SLE;
        !          1233:                                                }
        !          1234:                                        if (*nextch == '>') {
        !          1235:                                                nextch++;
        !          1236:                                                val = SNE;
        !          1237:                                                }
        !          1238:                                        goto extchk;
        !          1239:                                case '=':
        !          1240:                                        if (*nextch == '=') {
        !          1241:                                                nextch++;
        !          1242:                                                val = SEQ;
        !          1243:                                                goto extchk;
        !          1244:                                                }
        !          1245:                                        break;
        !          1246:                                case '>':
        !          1247:                                        if (*nextch == '=') {
        !          1248:                                                nextch++;
        !          1249:                                                val = SGE;
        !          1250:                                                }
        !          1251:  extchk:
        !          1252:                                        NOEXT("Fortran 8x comparison operator");
        !          1253:                                        return val;
        !          1254:                                }
        !          1255:                        else if (ch == '/' && new_dcl && parlev == 0)
        !          1256:                                return SSLASHD;
        !          1257:                        switch(val) {
        !          1258:                                case SLPAR:
        !          1259:                                        ++parlev;
        !          1260:                                        break;
        !          1261:                                case SRPAR:
        !          1262:                                        --parlev;
        !          1263:                                }
        !          1264:                        return(val);
        !          1265:                        }
        !          1266:        if(ch == '.')
        !          1267:                if(nextch >= lastch) goto badchar;
        !          1268:                else if(isdigit(nextch[1])) goto numconst;
        !          1269:                else    {
        !          1270:                        for(pd=dots ; (j=pd->dotname) ; ++pd)
        !          1271:                        {
        !          1272:                                for(i=nextch+1 ; i<=lastch ; ++i)
        !          1273:                                        if(*i != *j) break;
        !          1274:                                        else if(*i != '.') ++j;
        !          1275:                                        else    {
        !          1276:                                                nextch = i+1;
        !          1277:                                                return(pd->dotval);
        !          1278:                                        }
        !          1279:                        }
        !          1280:                        goto badchar;
        !          1281:                }
        !          1282:        if( isalpha_(ch) )
        !          1283:        {
        !          1284:                p = token;
        !          1285:                *p++ = *nextch++;
        !          1286:                while(nextch<=lastch)
        !          1287:                        if( isalnum_(* USC nextch) )
        !          1288:                                *p++ = *nextch++;
        !          1289:                        else break;
        !          1290:                toklen = p - token;
        !          1291:                *p = 0;
        !          1292:                if (needwkey) {
        !          1293:                        needwkey = 0;
        !          1294:                        if (toklen == 5
        !          1295:                                && nextch <= lastch && *nextch == '(' /*)*/
        !          1296:                                && !strcmp(token,"while"))
        !          1297:                        return(SWHILE);
        !          1298:                        }
        !          1299:                if(inioctl && nextch<=lastch && *nextch=='=')
        !          1300:                {
        !          1301:                        ++nextch;
        !          1302:                        return(SNAMEEQ);
        !          1303:                }
        !          1304:                if(toklen>8 && eqn(8,token,"function")
        !          1305:                && isalpha_(* USC (token+8)) &&
        !          1306:                    nextch<lastch && nextch[0]=='(' &&
        !          1307:                    (nextch[1]==')' || isalpha_(* USC (nextch+1))) )
        !          1308:                {
        !          1309:                        nextch -= (toklen - 8);
        !          1310:                        return(SFUNCTION);
        !          1311:                }
        !          1312: 
        !          1313:                if(toklen > 50)
        !          1314:                {
        !          1315:                        char buff[100];
        !          1316:                        sprintf(buff, toklen >= 60
        !          1317:                                ? "name %.56s... too long, truncated to %.*s"
        !          1318:                                : "name %s too long, truncated to %.*s",
        !          1319:                            token, 50, token);
        !          1320:                        err(buff);
        !          1321:                        toklen = 50;
        !          1322:                        token[50] = '\0';
        !          1323:                }
        !          1324:                if(toklen==1 && *nextch==MYQUOTE) {
        !          1325:                        val = token[0];
        !          1326:                        ++nextch;
        !          1327:                        for(p = token ; *nextch!=MYQUOTE ; )
        !          1328:                                *p++ = *nextch++;
        !          1329:                        ++nextch;
        !          1330:                        toklen = p - token;
        !          1331:                        *p = 0;
        !          1332:                        return hexcheck(val);
        !          1333:                }
        !          1334:                return(SNAME);
        !          1335:        }
        !          1336: 
        !          1337:        if (isdigit(ch)) {
        !          1338: 
        !          1339:                /* Check for NAG's special hex constant */
        !          1340: 
        !          1341:                if (nextch[1] == '#'
        !          1342:                ||  nextch[2] == '#' && isdigit(nextch[1])) {
        !          1343: 
        !          1344:                    radix = atoi (nextch);
        !          1345:                    if (*++nextch != '#')
        !          1346:                        nextch++;
        !          1347:                    if (radix != 2 && radix != 8 && radix != 16) {
        !          1348:                        erri("invalid base %d for constant, defaulting to hex",
        !          1349:                                radix);
        !          1350:                        radix = 16;
        !          1351:                    } /* if */
        !          1352:                    if (++nextch > lastch)
        !          1353:                        goto badchar;
        !          1354:                    for (p = token; hextoi(*nextch) < radix;) {
        !          1355:                        *p++ = *nextch++;
        !          1356:                        if (nextch > lastch)
        !          1357:                                break;
        !          1358:                        }
        !          1359:                    toklen = p - token;
        !          1360:                    *p = 0;
        !          1361:                    return (radix == 16) ? SHEXCON : ((radix == 8) ? SOCTCON :
        !          1362:                            SBITCON);
        !          1363:                    }
        !          1364:                }
        !          1365:        else
        !          1366:                goto badchar;
        !          1367: numconst:
        !          1368:        havdot = NO;
        !          1369:        havexp = NO;
        !          1370:        havdbl = NO;
        !          1371:        for(n1 = nextch ; nextch<=lastch ; ++nextch)
        !          1372:        {
        !          1373:                if(*nextch == '.')
        !          1374:                        if(havdot) break;
        !          1375:                        else if(nextch+2<=lastch && isalpha_(* USC (nextch+1))
        !          1376:                            && isalpha_(* USC (nextch+2)))
        !          1377:                                break;
        !          1378:                        else    havdot = YES;
        !          1379:                else if( !intonly && (*nextch=='d' || *nextch=='e') )
        !          1380:                {
        !          1381:                        p = nextch;
        !          1382:                        havexp = YES;
        !          1383:                        if(*nextch == 'd')
        !          1384:                                havdbl = YES;
        !          1385:                        if(nextch<lastch)
        !          1386:                                if(nextch[1]=='+' || nextch[1]=='-')
        !          1387:                                        ++nextch;
        !          1388:                        if( ! isdigit(*++nextch) )
        !          1389:                        {
        !          1390:                                nextch = p;
        !          1391:                                havdbl = havexp = NO;
        !          1392:                                break;
        !          1393:                        }
        !          1394:                        for(++nextch ;
        !          1395:                            nextch<=lastch && isdigit(* USC nextch);
        !          1396:                            ++nextch);
        !          1397:                        break;
        !          1398:                }
        !          1399:                else if( ! isdigit(* USC nextch) )
        !          1400:                        break;
        !          1401:        }
        !          1402:        p = token;
        !          1403:        i = n1;
        !          1404:        while(i < nextch)
        !          1405:                *p++ = *i++;
        !          1406:        toklen = p - token;
        !          1407:        *p = 0;
        !          1408:        if(havdbl) return(SDCON);
        !          1409:        if(havdot || havexp) return(SRCON);
        !          1410:        return(SICON);
        !          1411: badchar:
        !          1412:        sbuf[0] = *nextch++;
        !          1413:        return(SUNKNOWN);
        !          1414: }
        !          1415: 
        !          1416: /* Comment buffering code */
        !          1417: 
        !          1418:  static void
        !          1419: store_comment(str)
        !          1420:  char *str;
        !          1421: {
        !          1422:        int len;
        !          1423:        comment_buf *ncb;
        !          1424: 
        !          1425:        if (nextcd == sbuf) {
        !          1426:                flush_comments();
        !          1427:                p1_comment(str);
        !          1428:                return;
        !          1429:                }
        !          1430:        len = strlen(str) + 1;
        !          1431:        if (cbnext + len > cblast) {
        !          1432:                if (!cbcur || !(ncb = cbcur->next)) {
        !          1433:                        ncb = (comment_buf *) Alloc(sizeof(comment_buf));
        !          1434:                        if (cbcur) {
        !          1435:                                cbcur->last = cbnext;
        !          1436:                                cbcur->next = ncb;
        !          1437:                                }
        !          1438:                        else {
        !          1439:                                cbfirst = ncb;
        !          1440:                                cbinit = ncb->buf;
        !          1441:                                }
        !          1442:                        ncb->next = 0;
        !          1443:                        }
        !          1444:                cbcur = ncb;
        !          1445:                cbnext = ncb->buf;
        !          1446:                cblast = cbnext + COMMENT_BUF_STORE;
        !          1447:                }
        !          1448:        strcpy(cbnext, str);
        !          1449:        cbnext += len;
        !          1450:        }
        !          1451: 
        !          1452:  static void
        !          1453: flush_comments()
        !          1454: {
        !          1455:        register char *s, *s1;
        !          1456:        register comment_buf *cb;
        !          1457:        if (cbnext == cbinit)
        !          1458:                return;
        !          1459:        cbcur->last = cbnext;
        !          1460:        for(cb = cbfirst;; cb = cb->next) {
        !          1461:                for(s = cb->buf; s < cb->last; s = s1) {
        !          1462:                        /* compute s1 = new s value first, since */
        !          1463:                        /* p1_comment may insert nulls into s */
        !          1464:                        s1 = s + strlen(s) + 1;
        !          1465:                        p1_comment(s);
        !          1466:                        }
        !          1467:                if (cb == cbcur)
        !          1468:                        break;
        !          1469:                }
        !          1470:        cbcur = cbfirst;
        !          1471:        cbnext = cbinit;
        !          1472:        cblast = cbnext + COMMENT_BUF_STORE;
        !          1473:        }
        !          1474: 
        !          1475:  void
        !          1476: unclassifiable()
        !          1477: {
        !          1478:        register char *s, *se;
        !          1479: 
        !          1480:        s = sbuf;
        !          1481:        se = lastch;
        !          1482:        if (se < sbuf)
        !          1483:                return;
        !          1484:        lastch = s - 1;
        !          1485:        if (se - s > 10)
        !          1486:                se = s + 10;
        !          1487:        for(; s < se; s++)
        !          1488:                if (*s == MYQUOTE) {
        !          1489:                        se = s;
        !          1490:                        break;
        !          1491:                        }
        !          1492:        *se = 0;
        !          1493:        errstr("unclassifiable statement (starts \"%s\")", sbuf);
        !          1494:        }

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