Usenet 1994 October/usenetsourcesnewsgroupsinfomagicoctober1994disk2.iso/unix/volume20/perl3.0/part12

Internet Message Format | 1989-11-01 | 49.3 KB

Path: bbn.com!rsalz
From: [e-mail] (Rich Salz)
Newsgroups: comp.sources.unix
Subject: v20i095:  Perl, a language with features of C/sed/awk/shell/etc, Part12/24
Message-ID: <[e-mail]>
Date: 31 Oct 89 20:13:02 GMT
Lines: 2066
Approved: [e-mail]

Submitted-by: Larry Wall <[e-mail]>
Posting-number: Volume 20, Issue 95
Archive-name: perl3.0/part12

#! /bin/sh

# Make a new directory for the perl sources, cd to it, and run kits 1
# thru 24 through sh.  When all 24 kits have been run, read README.

echo "This is perl 3.0 kit 12 (of 24).  If kit 12 is complete, the line"
echo '"'"End of kit 12 (of 24)"'" will echo at the end.'
echo ""
export PATH || (echo "You didn't use sh, you clunch." ; kill $$)
mkdir t 2>/dev/null
echo Extracting regcomp.c
sed >regcomp.c <<'!STUFFY!FUNK!' -e 's/X//'
X/* NOTE: this is derived from Henry Spencer's regexp code, and should not
X * confused with the original package (see point 3 below).  Thanks, Henry!
X */
X
X/* Additional note: this code is very heavily munged from Henry's version
X * in places.  In some spots I've traded clarity for efficiency, so don't
X * blame Henry for some of the lack of readability.
X */
X
X/* $Header: regcomp.c,v 3.0 89/10/18 15:22:29 lwall Locked $
X *
X * $Log:    regcomp.c,v $
X * Revision 3.0  89/10/18  15:22:29  lwall
X * 3.0 baseline
X *
X */
X
X/*
X * regcomp and regexec -- regsub and regerror are not used in perl
X *
X *    Copyright (c) 1986 by University of Toronto.
X *    Written by Henry Spencer.  Not derived from licensed software.
X *
X *    Permission is granted to anyone to use this software for any
X *    purpose on any computer system, and to redistribute it freely,
X *    subject to the following restrictions:
X *
X *    1. The author is not responsible for the consequences of use of
X *        this software, no matter how awful, even if they arise
X *        from defects in it.
X *
X *    2. The origin of this software must not be misrepresented, either
X *        by explicit claim or by omission.
X *
X *    3. Altered versions must be plainly marked as such, and must not
X *        be misrepresented as being the original software.
X *
X *
X ****    Alterations to Henry's code are...
X ****
X ****    Copyright (c) 1989, Larry Wall
X ****
X ****    You may distribute under the terms of the GNU General Public License
X ****    as specified in the README file that comes with the perl 3.0 kit.
X *
X * Beware that some of this code is subtly aware of the way operator
X * precedence is structured in regular expressions.  Serious changes in
X * regular-expression syntax might require a total rethink.
X */
X#include "EXTERN.h"
X#include "perl.h"
X#include "INTERN.h"
X#include "regcomp.h"
X
X#ifndef STATIC
X#define    STATIC    static
X#endif
X
X#define    ISMULT1(c)    ((c) == '*' || (c) == '+' || (c) == '?')
X#define    ISMULT2(s)    ((*s) == '*' || (*s) == '+' || (*s) == '?' || \
X    ((*s) == '{' && regcurly(s)))
X#define    META    "^$.[()|?+*\\"
X
X/*
X * Flags to be passed up and down.
X */
X#define    HASWIDTH    01    /* Known never to match null string. */
X#define    SIMPLE        02    /* Simple enough to be STAR/PLUS operand. */
X#define    SPSTART        04    /* Starts with * or +. */
X#define    WORST        0    /* Worst case. */
X
X/*
X * Global work variables for regcomp().
X */
Xstatic char *regprecomp;        /* uncompiled string. */
Xstatic char *regparse;        /* Input-scan pointer. */
Xstatic char *regxend;        /* End of input for compile */
Xstatic int regnpar;        /* () count. */
Xstatic char *regcode;        /* Code-emit pointer; ®dummy = don't. */
Xstatic long regsize;        /* Code size. */
Xstatic int regfold;
Xstatic int regsawbracket;    /* Did we do {d,d} trick? */
X
X/*
X * Forward declarations for regcomp()'s friends.
X */
XSTATIC int regcurly();
XSTATIC char *reg();
XSTATIC char *regbranch();
XSTATIC char *regpiece();
XSTATIC char *regatom();
XSTATIC char *regclass();
XSTATIC char *regnode();
XSTATIC void regc();
XSTATIC void reginsert();
XSTATIC void regtail();
XSTATIC void regoptail();
X
X/*
X - regcomp - compile a regular expression into internal code
X *
X * We can't allocate space until we know how big the compiled form will be,
X * but we can't compile it (and thus know how big it is) until we've got a
X * place to put the code.  So we cheat:  we compile it twice, once with code
X * generation turned off and size counting turned on, and once "for real".
X * This also means that we don't allocate space until we are sure that the
X * thing really will compile successfully, and we never have to move the
X * code and thus invalidate pointers into it.  (Note that it has to be in
X * one piece because free() must be able to free it all.) [NB: not true in perl]
X *
X * Beware that the optimization-preparation code in here knows about some
X * of the structure of the compiled regexp.  [I'll say.]
X */
Xregexp *
Xregcomp(exp,xend,fold,rare)
Xchar *exp;
Xchar *xend;
Xint fold;
Xint rare;
X{
X    register regexp *r;
X    register char *scan;
X    register STR *longest;
X    register int len;
X    register char *first;
X    int flags;
X    int back;
X    int curback;
X    extern char *safemalloc();
X    extern char *savestr();
X
X    if (exp == NULL)
X        fatal("NULL regexp argument");
X
X    /* First pass: determine size, legality. */
X    regfold = fold;
X    regparse = exp;
X    regxend = xend;
X    regprecomp = nsavestr(exp,xend-exp);
X    regsawbracket = 0;
X    regnpar = 1;
X    regsize = 0L;
X    regcode = ®dummy;
X    regc(MAGIC);
X    if (reg(0, &flags) == NULL) {
X        Safefree(regprecomp);
X        return(NULL);
X    }
X
X    /* Small enough for pointer-storage convention? */
X    if (regsize >= 32767L)        /* Probably could be 65535L. */
X        FAIL("regexp too big");
X
X    /* Allocate space. */
X    Newc(1001, r, sizeof(regexp) + (unsigned)regsize, char, regexp);
X    if (r == NULL)
X        FAIL("regexp out of space");
X
X    /* Second pass: emit code. */
X    if (regsawbracket)
X        bcopy(regprecomp,exp,xend-exp);
X    r->precomp = regprecomp;
X    r->subbase = NULL;
X    regparse = exp;
X    regnpar = 1;
X    regcode = r->program;
X    regc(MAGIC);
X    if (reg(0, &flags) == NULL)
X        return(NULL);
X
X    /* Dig out information for optimizations. */
X    r->regstart = Nullstr;    /* Worst-case defaults. */
X    r->reganch = 0;
X    r->regmust = Nullstr;
X    r->regback = -1;
X    r->regstclass = Nullch;
X    scan = r->program+1;            /* First BRANCH. */
X    if (OP(regnext(scan)) == END) {/* Only one top-level choice. */
X        scan = NEXTOPER(scan);
X
X        first = scan;
X        while ((OP(first) > OPEN && OP(first) < CLOSE) ||
X            (OP(first) == BRANCH && OP(regnext(first)) != BRANCH) ||
X            (OP(first) == PLUS) )
X            first = NEXTOPER(first);
X
X        /* Starting-point info. */
X        if (OP(first) == EXACTLY) {
X            r->regstart =
X                str_make(OPERAND(first)+1,*OPERAND(first));
X            if (r->regstart->str_cur > !(sawstudy|fold))
X                fbmcompile(r->regstart,fold);
X        }
X        else if ((exp = index(simple,OP(first))) && exp > simple)
X            r->regstclass = first;
X        else if (OP(first) == BOUND || OP(first) == NBOUND)
X            r->regstclass = first;
X        else if (OP(first) == BOL)
X            r->reganch++;
X
X#ifdef DEBUGGING
X        if (debug & 512)
X            fprintf(stderr,"first %d next %d offset %d\n",
X              OP(first), OP(NEXTOPER(first)), first - scan);
X#endif
X        /*
X         * If there's something expensive in the r.e., find the
X         * longest literal string that must appear and make it the
X         * regmust.  Resolve ties in favor of later strings, since
X         * the regstart check works with the beginning of the r.e.
X         * and avoiding duplication strengthens checking.  Not a
X         * strong reason, but sufficient in the absence of others.
X         * [Now we resolve ties in favor of the earlier string if
X         * it happens that curback has been invalidated, since the
X         * earlier string may buy us something the later one won't.]
X         */
X        longest = str_make("",0);
X        len = 0;
X        curback = 0;
X        back = 0;
X        while (scan != NULL) {
X            if (OP(scan) == BRANCH) {
X                if (OP(regnext(scan)) == BRANCH) {
X                curback = -30000;
X                while (OP(scan) == BRANCH)
X                    scan = regnext(scan);
X                }
X                else    /* single branch is ok */
X                scan = NEXTOPER(scan);
X            }
X            if (OP(scan) == EXACTLY) {
X                first = scan;
X                while (OP(regnext(scan)) >= CLOSE)
X                scan = regnext(scan);
X                if (curback - back == len) {
X                str_ncat(longest, OPERAND(first)+1,
X                    *OPERAND(first));
X                len += *OPERAND(first);
X                curback += *OPERAND(first);
X                first = regnext(scan);
X                }
X                else if (*OPERAND(first) >= len + (curback >= 0)) {
X                len = *OPERAND(first);
X                str_nset(longest, OPERAND(first)+1,len);
X                back = curback;
X                curback += len;
X                first = regnext(scan);
X                }
X                else
X                curback += *OPERAND(first);
X            }
X            else if (index(varies,OP(scan)))
X                curback = -30000;
X            else if (index(simple,OP(scan)))
X                curback++;
X            scan = regnext(scan);
X        }
X        if (len) {
X            r->regmust = longest;
X            if (back < 0)
X                back = -1;
X            r->regback = back;
X            if (len > !(sawstudy||fold||OP(first)==EOL))
X                fbmcompile(r->regmust,fold);
X            r->regmust->str_u.str_useful = 100;
X            if (OP(first) == EOL) /* is match anchored to EOL? */
X                r->regmust->str_pok |= SP_TAIL;
X        }
X        else
X            str_free(longest);
X    }
X
X    r->do_folding = fold;
X    r->nparens = regnpar - 1;
X#ifdef DEBUGGING
X    if (debug & 512)
X        regdump(r);
X#endif
X    return(r);
X}
X
X/*
X - reg - regular expression, i.e. main body or parenthesized thing
X *
X * Caller must absorb opening parenthesis.
X *
X * Combining parenthesis handling with the base level of regular expression
X * is a trifle forced, but the need to tie the tails of the branches to what
X * follows makes it hard to avoid.
X */
Xstatic char *
Xreg(paren, flagp)
Xint paren;            /* Parenthesized? */
Xint *flagp;
X{
X    register char *ret;
X    register char *br;
X    register char *ender;
X    register int parno;
X    int flags;
X
X    *flagp = HASWIDTH;    /* Tentatively. */
X
X    /* Make an OPEN node, if parenthesized. */
X    if (paren) {
X        if (regnpar >= NSUBEXP)
X            FAIL("too many () in regexp");
X        parno = regnpar;
X        regnpar++;
X        ret = regnode(OPEN+parno);
X    } else
X        ret = NULL;
X
X    /* Pick up the branches, linking them together. */
X    br = regbranch(&flags);
X    if (br == NULL)
X        return(NULL);
X    if (ret != NULL)
X        regtail(ret, br);    /* OPEN -> first. */
X    else
X        ret = br;
X    if (!(flags&HASWIDTH))
X        *flagp &= ~HASWIDTH;
X    *flagp |= flags&SPSTART;
X    while (*regparse == '|') {
X        regparse++;
X        br = regbranch(&flags);
X        if (br == NULL)
X            return(NULL);
X        regtail(ret, br);    /* BRANCH -> BRANCH. */
X        if (!(flags&HASWIDTH))
X            *flagp &= ~HASWIDTH;
X        *flagp |= flags&SPSTART;
X    }
X
X    /* Make a closing node, and hook it on the end. */
X    ender = regnode((paren) ? CLOSE+parno : END);
X    regtail(ret, ender);
X
X    /* Hook the tails of the branches to the closing node. */
X    for (br = ret; br != NULL; br = regnext(br))
X        regoptail(br, ender);
X
X    /* Check for proper termination. */
X    if (paren && *regparse++ != ')') {
X        FAIL("unmatched () in regexp");
X    } else if (!paren && regparse < regxend) {
X        if (*regparse == ')') {
X            FAIL("unmatched () in regexp");
X        } else
X            FAIL("junk on end of regexp");    /* "Can't happen". */
X        /* NOTREACHED */
X    }
X
X    return(ret);
X}
X
X/*
X - regbranch - one alternative of an | operator
X *
X * Implements the concatenation operator.
X */
Xstatic char *
Xregbranch(flagp)
Xint *flagp;
X{
X    register char *ret;
X    register char *chain;
X    register char *latest;
X    int flags;
X
X    *flagp = WORST;        /* Tentatively. */
X
X    ret = regnode(BRANCH);
X    chain = NULL;
X    while (regparse < regxend && *regparse != '|' && *regparse != ')') {
X        latest = regpiece(&flags);
X        if (latest == NULL)
X            return(NULL);
X        *flagp |= flags&HASWIDTH;
X        if (chain == NULL)    /* First piece. */
X            *flagp |= flags&SPSTART;
X        else
X            regtail(chain, latest);
X        chain = latest;
X    }
X    if (chain == NULL)    /* Loop ran zero times. */
X        (void) regnode(NOTHING);
X
X    return(ret);
X}
X
X/*
X - regpiece - something followed by possible [*+?]
X *
X * Note that the branching code sequences used for ? and the general cases
X * of * and + are somewhat optimized:  they use the same NOTHING node as
X * both the endmarker for their branch list and the body of the last branch.
X * It might seem that this node could be dispensed with entirely, but the
X * endmarker role is not redundant.
X */
Xstatic char *
Xregpiece(flagp)
Xint *flagp;
X{
X    register char *ret;
X    register char op;
X    register char *next;
X    int flags;
X    char *origparse = regparse;
X    int orignpar = regnpar;
X    char *max;
X    int iter;
X    char ch;
X
X    ret = regatom(&flags);
X    if (ret == NULL)
X        return(NULL);
X
X    op = *regparse;
X
X    /* Here's a total kludge: if after the atom there's a {\d+,?\d*}
X     * then we decrement the first number by one and reset our
X     * parsing back to the beginning of the same atom.  If the first number
X     * is down to 0, decrement the second number instead and fake up
X     * a ? after it.  Given the way this compiler doesn't keep track
X     * of offsets on the first pass, this is the only way to replicate
X     * a piece of code.  Sigh.
X     */
X    if (op == '{' && regcurly(regparse)) {
X        next = regparse + 1;
X        max = Nullch;
X        while (isdigit(*next) || *next == ',') {
X        if (*next == ',') {
X            if (max)
X            break;
X            else
X            max = next;
X        }
X        next++;
X        }
X        if (*next == '}') {        /* got one */
X        regsawbracket++;    /* remember we clobbered exp */
X        if (!max)
X            max = next;
X        regparse++;
X        iter = atoi(regparse);
X        if (iter > 0) {
X            ch = *max;
X            sprintf(regparse,"%.*d", max-regparse, iter - 1);
X            *max = ch;
X            if (*max == ',' && atoi(max+1) > 0) {
X            ch = *next;
X            sprintf(max+1,"%.*d", next-(max+1), atoi(max+1) - 1);
X            *next = ch;
X            }
X            if (iter != 1 || (*max == ',' || atoi(max+1))) {
X            regparse = origparse;    /* back up input pointer */
X            regnpar = orignpar;    /* don't make more parens */
X            }
X            else {
X            regparse = next;
X            goto nest_check;
X            }
X            *flagp = flags;
X            return ret;
X        }
X        if (*max == ',') {
X            max++;
X            iter = atoi(max);
X            if (max == next) {        /* any number more? */
X            regparse = next;
X            op = '*';        /* fake up one with a star */
X            }
X            else if (iter > 0) {
X            op = '?';        /* fake up optional atom */
X            ch = *next;
X            sprintf(max,"%.*d", next-max, iter - 1);
X            *next = ch;
X            if (iter == 1)
X                regparse = next;
X            else {
X                regparse = origparse - 1; /* offset ++ below */
X                regnpar = orignpar;
X            }
X            }
X            else
X            fatal("Can't do {n,0}");
X        }
X        else
X            fatal("Can't do {0}");
X        }
X    }
X
X    if (!ISMULT1(op)) {
X        *flagp = flags;
X        return(ret);
X    }
X
X    if (!(flags&HASWIDTH) && op != '?')
X        FAIL("regexp *+ operand could be empty");
X    *flagp = (op != '+') ? (WORST|SPSTART) : (WORST|HASWIDTH);
X
X    if (op == '*' && (flags&SIMPLE))
X        reginsert(STAR, ret);
X    else if (op == '*') {
X        /* Emit x* as (x&|), where & means "self". */
X        reginsert(BRANCH, ret);            /* Either x */
X        regoptail(ret, regnode(BACK));        /* and loop */
X        regoptail(ret, ret);            /* back */
X        regtail(ret, regnode(BRANCH));        /* or */
X        regtail(ret, regnode(NOTHING));        /* null. */
X    } else if (op == '+' && (flags&SIMPLE))
X        reginsert(PLUS, ret);
X    else if (op == '+') {
X        /* Emit x+ as x(&|), where & means "self". */
X        next = regnode(BRANCH);            /* Either */
X        regtail(ret, next);
X        regtail(regnode(BACK), ret);        /* loop back */
X        regtail(next, regnode(BRANCH));        /* or */
X        regtail(ret, regnode(NOTHING));        /* null. */
X    } else if (op == '?') {
X        /* Emit x? as (x|) */
X        reginsert(BRANCH, ret);            /* Either x */
X        regtail(ret, regnode(BRANCH));        /* or */
X        next = regnode(NOTHING);        /* null. */
X        regtail(ret, next);
X        regoptail(ret, next);
X    }
X      nest_check:
X    regparse++;
X    if (ISMULT2(regparse))
X        FAIL("nested *?+ in regexp");
X
X    return(ret);
X}
X
X/*
X - regatom - the lowest level
X *
X * Optimization:  gobbles an entire sequence of ordinary characters so that
X * it can turn them into a single node, which is smaller to store and
X * faster to run.  Backslashed characters are exceptions, each becoming a
X * separate node; the code is simpler that way and it's not worth fixing.
X *
X * [Yes, it is worth fixing, some scripts can run twice the speed.]
X */
Xstatic char *
Xregatom(flagp)
Xint *flagp;
X{
X    register char *ret;
X    int flags;
X
X    *flagp = WORST;        /* Tentatively. */
X
X    switch (*regparse++) {
X    case '^':
X        ret = regnode(BOL);
X        break;
X    case '$':
X        ret = regnode(EOL);
X        break;
X    case '.':
X        ret = regnode(ANY);
X        *flagp |= HASWIDTH|SIMPLE;
X        break;
X    case '[':
X        ret = regclass();
X        *flagp |= HASWIDTH|SIMPLE;
X        break;
X    case '(':
X        ret = reg(1, &flags);
X        if (ret == NULL)
X            return(NULL);
X        *flagp |= flags&(HASWIDTH|SPSTART);
X        break;
X    case '|':
X    case ')':
X        FAIL("internal urp in regexp");    /* Supposed to be caught earlier. */
X        break;
X    case '?':
X    case '+':
X    case '*':
X        FAIL("?+* follows nothing in regexp");
X        break;
X    case '\\':
X        switch (*regparse) {
X        case 'w':
X            ret = regnode(ALNUM);
X            *flagp |= HASWIDTH|SIMPLE;
X            regparse++;
X            break;
X        case 'W':
X            ret = regnode(NALNUM);
X            *flagp |= HASWIDTH|SIMPLE;
X            regparse++;
X            break;
X        case 'b':
X            ret = regnode(BOUND);
X            *flagp |= SIMPLE;
X            regparse++;
X            break;
X        case 'B':
X            ret = regnode(NBOUND);
X            *flagp |= SIMPLE;
X            regparse++;
X            break;
X        case 's':
X            ret = regnode(SPACE);
X            *flagp |= HASWIDTH|SIMPLE;
X            regparse++;
X            break;
X        case 'S':
X            ret = regnode(NSPACE);
X            *flagp |= HASWIDTH|SIMPLE;
X            regparse++;
X            break;
X        case 'd':
X            ret = regnode(DIGIT);
X            *flagp |= HASWIDTH|SIMPLE;
X            regparse++;
X            break;
X        case 'D':
X            ret = regnode(NDIGIT);
X            *flagp |= HASWIDTH|SIMPLE;
X            regparse++;
X            break;
X        case 'n':
X        case 'r':
X        case 't':
X        case 'f':
X            goto defchar;
X        case '0': case '1': case '2': case '3': case '4':
X        case '5': case '6': case '7': case '8': case '9':
X            if (isdigit(regparse[1]))
X                goto defchar;
X            else {
X                ret = regnode(REF + *regparse++ - '0');
X                *flagp |= SIMPLE;
X            }
X            break;
X        case '\0':
X            if (regparse >= regxend)
X                FAIL("trailing \\ in regexp");
X            /* FALL THROUGH */
X        default:
X            goto defchar;
X        }
X        break;
X    default: {
X            register int len;
X            register char ender;
X            register char *p;
X            char *oldp;
X            int foo;
X
X            defchar:
X            ret = regnode(EXACTLY);
X            regc(0);        /* save spot for len */
X            for (len=0, p=regparse-1;
X              len < 127 && p < regxend;
X              len++)
X            {
X                oldp = p;
X                switch (*p) {
X                case '^':
X                case '$':
X                case '.':
X                case '[':
X                case '(':
X                case ')':
X                case '|':
X                goto loopdone;
X                case '\\':
X                switch (*++p) {
X                case 'w':
X                case 'W':
X                case 'b':
X                case 'B':
X                case 's':
X                case 'S':
X                case 'd':
X                case 'D':
X                    --p;
X                    goto loopdone;
X                case 'n':
X                    ender = '\n';
X                    p++;
X                    break;
X                case 'r':
X                    ender = '\r';
X                    p++;
X                    break;
X                case 't':
X                    ender = '\t';
X                    p++;
X                    break;
X                case 'f':
X                    ender = '\f';
X                    p++;
X                    break;
X                case '0': case '1': case '2': case '3':case '4':
X                case '5': case '6': case '7': case '8':case '9':
X                    if (isdigit(p[1])) {
X                    foo = *p++ - '0';
X                    foo <<= 3;
X                    foo += *p - '0';
X                    if (isdigit(p[1]))
X                        foo = (foo<<3) + *++p - '0';
X                    ender = foo;
X                    p++;
X                    }
X                    else {
X                    --p;
X                    goto loopdone;
X                    }
X                    break;
X                case '\0':
X                    if (p >= regxend)
X                    FAIL("trailing \\ in regexp");
X                    /* FALL THROUGH */
X                default:
X                    ender = *p++;
X                    break;
X                }
X                break;
X                default:
X                ender = *p++;
X                break;
X                }
X                if (regfold && isupper(ender))
X                    ender = tolower(ender);
X                if (ISMULT2(p)) { /* Back off on ?+*. */
X                if (len)
X                    p = oldp;
X                else {
X                    len++;
X                    regc(ender);
X                }
X                break;
X                }
X                regc(ender);
X            }
X            loopdone:
X            regparse = p;
X            if (len <= 0)
X                FAIL("internal disaster in regexp");
X            *flagp |= HASWIDTH;
X            if (len == 1)
X                *flagp |= SIMPLE;
X            if (regcode != ®dummy)
X                *OPERAND(ret) = len;
X            regc('\0');
X        }
X        break;
X    }
X
X    return(ret);
X}
X
Xstatic void
Xregset(bits,def,c)
Xchar *bits;
Xint def;
Xregister int c;
X{
X    if (regcode == ®dummy)
X        return;
X    if (def)
X        bits[c >> 3] &= ~(1 << (c & 7));
X    else
X        bits[c >> 3] |=  (1 << (c & 7));
X}
X
Xstatic char *
Xregclass()
X{
X    register char *bits;
X    register int class;
X    register int lastclass;
X    register int range = 0;
X    register char *ret;
X    register int def;
X
X    if (*regparse == '^') {    /* Complement of range. */
X        ret = regnode(ANYBUT);
X        regparse++;
X        def = 0;
X    } else {
X        ret = regnode(ANYOF);
X        def = 255;
X    }
X    bits = regcode;
X    for (class = 0; class < 32; class++)
X        regc(def);
X    if (*regparse == ']' || *regparse == '-')
X        regset(bits,def,lastclass = *regparse++);
X    while (regparse < regxend && *regparse != ']') {
X        class = UCHARAT(regparse++);
X        if (class == '\\') {
X            class = UCHARAT(regparse++);
X            switch (class) {
X            case 'w':
X                for (class = 'a'; class <= 'z'; class++)
X                    regset(bits,def,class);
X                for (class = 'A'; class <= 'Z'; class++)
X                    regset(bits,def,class);
X                for (class = '0'; class <= '9'; class++)
X                    regset(bits,def,class);
X                regset(bits,def,'_');
X                lastclass = 1234;
X                continue;
X            case 's':
X                regset(bits,def,' ');
X                regset(bits,def,'\t');
X                regset(bits,def,'\r');
X                regset(bits,def,'\f');
X                regset(bits,def,'\n');
X                lastclass = 1234;
X                continue;
X            case 'd':
X                for (class = '0'; class <= '9'; class++)
X                    regset(bits,def,class);
X                lastclass = 1234;
X                continue;
X            case 'n':
X                class = '\n';
X                break;
X            case 'r':
X                class = '\r';
X                break;
X            case 't':
X                class = '\t';
X                break;
X            case 'f':
X                class = '\f';
X                break;
X            case 'b':
X                class = '\b';
X                break;
X            case '0': case '1': case '2': case '3': case '4':
X            case '5': case '6': case '7': case '8': case '9':
X                class -= '0';
X                if (isdigit(*regparse)) {
X                    class <<= 3;
X                    class += *regparse++ - '0';
X                }
X                if (isdigit(*regparse)) {
X                    class <<= 3;
X                    class += *regparse++ - '0';
X                }
X                break;
X            }
X        }
X        if (!range && class == '-' && regparse < regxend &&
X            *regparse != ']') {
X            range = 1;
X            continue;
X        }
X        if (range) {
X            if (lastclass > class)
X                FAIL("invalid [] range in regexp");
X        }
X        else
X            lastclass = class - 1;
X        range = 0;
X        for (lastclass++; lastclass <= class; lastclass++) {
X            regset(bits,def,lastclass);
X            if (regfold && isupper(lastclass))
X                regset(bits,def,tolower(lastclass));
X        }
X        lastclass = class;
X    }
X    if (*regparse != ']')
X        FAIL("unmatched [] in regexp");
X    regset(bits,0,0);        /* always bomb out on null */
X    regparse++;
X    return ret;
X}
X
X/*
X - regnode - emit a node
X */
Xstatic char *            /* Location. */
Xregnode(op)
Xchar op;
X{
X    register char *ret;
X    register char *ptr;
X
X    ret = regcode;
X    if (ret == ®dummy) {
X#ifdef REGALIGN
X        if (!(regsize & 1))
X            regsize++;
X#endif
X        regsize += 3;
X        return(ret);
X    }
X
X#ifdef REGALIGN
X#ifndef lint
X    if (!((long)ret & 1))
X        *ret++ = 127;
X#endif
X#endif
X    ptr = ret;
X    *ptr++ = op;
X    *ptr++ = '\0';        /* Null "next" pointer. */
X    *ptr++ = '\0';
X    regcode = ptr;
X
X    return(ret);
X}
X
X/*
X - regc - emit (if appropriate) a byte of code
X */
Xstatic void
Xregc(b)
Xchar b;
X{
X    if (regcode != ®dummy)
X        *regcode++ = b;
X    else
X        regsize++;
X}
X
X/*
X - reginsert - insert an operator in front of already-emitted operand
X *
X * Means relocating the operand.
X */
Xstatic void
Xreginsert(op, opnd)
Xchar op;
Xchar *opnd;
X{
X    register char *src;
X    register char *dst;
X    register char *place;
X
X    if (regcode == ®dummy) {
X#ifdef REGALIGN
X        regsize += 4;
X#else
X        regsize += 3;
X#endif
X        return;
X    }
X
X    src = regcode;
X#ifdef REGALIGN
X    regcode += 4;
X#else
X    regcode += 3;
X#endif
X    dst = regcode;
X    while (src > opnd)
X        *--dst = *--src;
X
X    place = opnd;        /* Op node, where operand used to be. */
X    *place++ = op;
X    *place++ = '\0';
X    *place++ = '\0';
X}
X
X/*
X - regtail - set the next-pointer at the end of a node chain
X */
Xstatic void
Xregtail(p, val)
Xchar *p;
Xchar *val;
X{
X    register char *scan;
X    register char *temp;
X    register int offset;
X
X    if (p == ®dummy)
X        return;
X
X    /* Find last node. */
X    scan = p;
X    for (;;) {
X        temp = regnext(scan);
X        if (temp == NULL)
X            break;
X        scan = temp;
X    }
X
X#ifdef REGALIGN
X    offset = val - scan;
X#ifndef lint
X    *(short*)(scan+1) = offset;
X#else
X    offset = offset;
X#endif
X#else
X    if (OP(scan) == BACK)
X        offset = scan - val;
X    else
X        offset = val - scan;
X    *(scan+1) = (offset>>8)&0377;
X    *(scan+2) = offset&0377;
X#endif
X}
X
X/*
X - regoptail - regtail on operand of first argument; nop if operandless
X */
Xstatic void
Xregoptail(p, val)
Xchar *p;
Xchar *val;
X{
X    /* "Operandless" and "op != BRANCH" are synonymous in practice. */
X    if (p == NULL || p == ®dummy || OP(p) != BRANCH)
X        return;
X    regtail(NEXTOPER(p), val);
X}
X
X/*
X - regcurly - a little FSA that accepts {\d+,?\d*}
X */
XSTATIC int
Xregcurly(s)
Xregister char *s;
X{
X    if (*s++ != '{')
X    return FALSE;
X    if (!isdigit(*s))
X    return FALSE;
X    while (isdigit(*s))
X    s++;
X    if (*s == ',')
X    s++;
X    while (isdigit(*s))
X    s++;
X    if (*s != '}')
X    return FALSE;
X    return TRUE;
X}
X
X#ifdef DEBUGGING
X
X/*
X - regdump - dump a regexp onto stderr in vaguely comprehensible form
X */
Xvoid
Xregdump(r)
Xregexp *r;
X{
X    register char *s;
X    register char op = EXACTLY;    /* Arbitrary non-END op. */
X    register char *next;
X    extern char *index();
X
X
X    s = r->program + 1;
X    while (op != END) {    /* While that wasn't END last time... */
X#ifdef REGALIGN
X        if (!((long)s & 1))
X            s++;
X#endif
X        op = OP(s);
X        fprintf(stderr,"%2d%s", s-r->program, regprop(s));    /* Where, what. */
X        next = regnext(s);
X        if (next == NULL)        /* Next ptr. */
X            fprintf(stderr,"(0)");
X        else
X            fprintf(stderr,"(%d)", (s-r->program)+(next-s));
X        s += 3;
X        if (op == ANYOF || op == ANYBUT) {
X            s += 32;
X        }
X        if (op == EXACTLY) {
X            /* Literal string, where present. */
X            s++;
X            while (*s != '\0') {
X                (void)putchar(*s);
X                s++;
X            }
X            s++;
X        }
X        (void)putchar('\n');
X    }
X
X    /* Header fields of interest. */
X    if (r->regstart)
X        fprintf(stderr,"start `%s' ", r->regstart->str_ptr);
X    if (r->regstclass)
X        fprintf(stderr,"stclass `%s' ", regprop(r->regstclass));
X    if (r->reganch)
X        fprintf(stderr,"anchored ");
X    if (r->regmust != NULL)
X        fprintf(stderr,"must have \"%s\" back %d ", r->regmust->str_ptr,
X          r->regback);
X    fprintf(stderr,"\n");
X}
X
X/*
X - regprop - printable representation of opcode
X */
Xchar *
Xregprop(op)
Xchar *op;
X{
X    register char *p;
X
X    (void) strcpy(buf, ":");
X
X    switch (OP(op)) {
X    case BOL:
X        p = "BOL";
X        break;
X    case EOL:
X        p = "EOL";
X        break;
X    case ANY:
X        p = "ANY";
X        break;
X    case ANYOF:
X        p = "ANYOF";
X        break;
X    case ANYBUT:
X        p = "ANYBUT";
X        break;
X    case BRANCH:
X        p = "BRANCH";
X        break;
X    case EXACTLY:
X        p = "EXACTLY";
X        break;
X    case NOTHING:
X        p = "NOTHING";
X        break;
X    case BACK:
X        p = "BACK";
X        break;
X    case END:
X        p = "END";
X        break;
X    case ALNUM:
X        p = "ALNUM";
X        break;
X    case NALNUM:
X        p = "NALNUM";
X        break;
X    case BOUND:
X        p = "BOUND";
X        break;
X    case NBOUND:
X        p = "NBOUND";
X        break;
X    case SPACE:
X        p = "SPACE";
X        break;
X    case NSPACE:
X        p = "NSPACE";
X        break;
X    case DIGIT:
X        p = "DIGIT";
X        break;
X    case NDIGIT:
X        p = "NDIGIT";
X        break;
X    case REF:
X    case REF+1:
X    case REF+2:
X    case REF+3:
X    case REF+4:
X    case REF+5:
X    case REF+6:
X    case REF+7:
X    case REF+8:
X    case REF+9:
X        (void)sprintf(buf+strlen(buf), "REF%d", OP(op)-REF);
X        p = NULL;
X        break;
X    case OPEN+1:
X    case OPEN+2:
X    case OPEN+3:
X    case OPEN+4:
X    case OPEN+5:
X    case OPEN+6:
X    case OPEN+7:
X    case OPEN+8:
X    case OPEN+9:
X        (void)sprintf(buf+strlen(buf), "OPEN%d", OP(op)-OPEN);
X        p = NULL;
X        break;
X    case CLOSE+1:
X    case CLOSE+2:
X    case CLOSE+3:
X    case CLOSE+4:
X    case CLOSE+5:
X    case CLOSE+6:
X    case CLOSE+7:
X    case CLOSE+8:
X    case CLOSE+9:
X        (void)sprintf(buf+strlen(buf), "CLOSE%d", OP(op)-CLOSE);
X        p = NULL;
X        break;
X    case STAR:
X        p = "STAR";
X        break;
X    case PLUS:
X        p = "PLUS";
X        break;
X    default:
X        FAIL("corrupted regexp opcode");
X    }
X    if (p != NULL)
X        (void) strcat(buf, p);
X    return(buf);
X}
X#endif /* DEBUGGING */
X
Xregfree(r)
Xstruct regexp *r;
X{
X    if (r->precomp)
X        Safefree(r->precomp);
X    if (r->subbase)
X        Safefree(r->subbase);
X    if (r->regmust)
X        str_free(r->regmust);
X    if (r->regstart)
X        str_free(r->regstart);
X    Safefree(r);
X}
!STUFFY!FUNK!
echo Extracting perl.y
sed >perl.y <<'!STUFFY!FUNK!' -e 's/X//'
X/* $Header: perl.y,v 3.0 89/10/18 15:22:04 lwall Locked $
X *
X *    Copyright (c) 1989, Larry Wall
X *
X *    You may distribute under the terms of the GNU General Public License
X *    as specified in the README file that comes with the perl 3.0 kit.
X *
X * $Log:    perl.y,v $
X * Revision 3.0  89/10/18  15:22:04  lwall
X * 3.0 baseline
X *
X */
X
X%{
X#include "INTERN.h"
X#include "perl.h"
X
XSTAB *scrstab;
XARG *arg4;    /* rarely used arguments to make_op() */
XARG *arg5;
X
X%}
X
X%start prog
X
X%union {
X    int    ival;
X    char *cval;
X    ARG *arg;
X    CMD *cmdval;
X    struct compcmd compval;
X    STAB *stabval;
X    FCMD *formval;
X}
X
X%token <cval> WORD
X%token <ival> APPEND OPEN SELECT LOOPEX
X%token <ival> USING FORMAT DO SHIFT PUSH POP LVALFUN
X%token <ival> WHILE UNTIL IF UNLESS ELSE ELSIF CONTINUE SPLIT FLIST
X%token <ival> FOR FILOP FILOP2 FILOP3 FILOP4 FILOP22 FILOP25
X%token <ival> FUNC0 FUNC1 FUNC2 FUNC3 HSHFUN HSHFUN3
X%token <ival> FLIST2 SUB FILETEST LOCAL DELETE
X%token <ival> RELOP EQOP MULOP ADDOP PACKAGE AMPER LFUNC4
X%token <formval> FORMLIST
X%token <stabval> REG ARYLEN ARY HSH STAR
X%token <arg> SUBST PATTERN
X%token <arg> RSTRING TRANS
X
X%type <ival> prog decl format remember
X%type <stabval>
X%type <cmdval> block lineseq line loop cond sideff nexpr else
X%type <arg> expr sexpr cexpr csexpr term handle aryword hshword
X%type <arg> texpr listop
X%type <cval> label
X%type <compval> compblock
X
X%nonassoc <ival> LISTOP
X%left ','
X%right '='
X%right '?' ':'
X%nonassoc DOTDOT
X%left OROR
X%left ANDAND
X%left '|' '^'
X%left '&'
X%nonassoc EQOP
X%nonassoc RELOP
X%nonassoc <ival> UNIOP
X%nonassoc FILETEST
X%left LS RS
X%left ADDOP
X%left MULOP
X%left MATCH NMATCH
X%right '!' '~' UMINUS
X%right POW
X%nonassoc INC DEC
X%left '('
X
X%% /* RULES */
X
Xprog    :    lineseq
X            { if (in_eval)
X                eval_root = block_head($1);
X                else
X                main_root = block_head($1); }
X    ;
X
Xcompblock:    block CONTINUE block
X            { $$.comp_true = $1; $$.comp_alt = $3; }
X    |    block else
X            { $$.comp_true = $1; $$.comp_alt = $2; }
X    ;
X
Xelse    :    /* NULL */
X            { $$ = Nullcmd; }
X    |    ELSE block
X            { $$ = $2; }
X    |    ELSIF '(' expr ')' compblock
X            { cmdline = $1;
X                $$ = make_ccmd(C_ELSIF,$3,$5); }
X    ;
X
Xblock    :    '{' remember lineseq '}'
X            { $$ = block_head($3);
X              if (savestack->ary_fill > $2)
X                restorelist($2); }
X    ;
X
Xremember:    /* NULL */    /* in case they push a package name */
X            { $$ = savestack->ary_fill; }
X    ;
X
Xlineseq    :    /* NULL */
X            { $$ = Nullcmd; }
X    |    lineseq line
X            { $$ = append_line($1,$2); }
X    ;
X
Xline    :    decl
X            { $$ = Nullcmd; }
X    |    label cond
X            { $$ = add_label($1,$2); }
X    |    loop    /* loops add their own labels */
X    |    label ';'
X            { if ($1 != Nullch) {
X                  $$ = add_label($1, make_acmd(C_EXPR, Nullstab,
X                  Nullarg, Nullarg) );
X                } else
X                  $$ = Nullcmd; }
X    |    label sideff ';'
X            { $$ = add_label($1,$2); }
X    ;
X
Xsideff    :    error
X            { $$ = Nullcmd; }
X    |    expr
X            { $$ = make_acmd(C_EXPR, Nullstab, $1, Nullarg); }
X    |    expr IF expr
X            { $$ = addcond(
X                   make_acmd(C_EXPR, Nullstab, Nullarg, $1), $3); }
X    |    expr UNLESS expr
X            { $$ = addcond(invert(
X                   make_acmd(C_EXPR, Nullstab, Nullarg, $1)), $3); }
X    |    expr WHILE expr
X            { $$ = addloop(
X                   make_acmd(C_EXPR, Nullstab, Nullarg, $1), $3); }
X    |    expr UNTIL expr
X            { $$ = addloop(invert(
X                   make_acmd(C_EXPR, Nullstab, Nullarg, $1)), $3); }
X    ;
X
Xcond    :    IF '(' expr ')' compblock
X            { cmdline = $1;
X                $$ = make_icmd(C_IF,$3,$5); }
X    |    UNLESS '(' expr ')' compblock
X            { cmdline = $1;
X                $$ = invert(make_icmd(C_IF,$3,$5)); }
X    |    IF block compblock
X            { cmdline = $1;
X                $$ = make_ccmd(C_IF,cmd_to_arg($2),$3); }
X    |    UNLESS block compblock
X            { cmdline = $1;
X                $$ = invert(make_ccmd(C_IF,cmd_to_arg($2),$3)); }
X    ;
X
Xloop    :    label WHILE '(' texpr ')' compblock
X            { cmdline = $2;
X                $$ = wopt(add_label($1,
X                make_ccmd(C_WHILE,$4,$6) )); }
X    |    label UNTIL '(' expr ')' compblock
X            { cmdline = $2;
X                $$ = wopt(add_label($1,
X                invert(make_ccmd(C_WHILE,$4,$6)) )); }
X    |    label WHILE block compblock
X            { cmdline = $2;
X                $$ = wopt(add_label($1,
X                make_ccmd(C_WHILE, cmd_to_arg($3),$4) )); }
X    |    label UNTIL block compblock
X            { cmdline = $2;
X                $$ = wopt(add_label($1,
X                invert(make_ccmd(C_WHILE, cmd_to_arg($3),$4)) )); }
X    |    label FOR REG '(' expr ')' compblock
X            { cmdline = $2;
X                /*
X                 * The following gobbledygook catches EXPRs that
X                 * aren't explicit array refs and translates
X                 *        foreach VAR (EXPR) {
X                 * into
X                 *        @ary = EXPR;
X                 *        foreach VAR (@ary) {
X                 * where @ary is a hidden array made by genstab().
X                 * (Note that @ary may become a local array if
X                 * it is determined that it might be called
X                 * recursively.  See cmd_tosave().)
X                 */
X                if ($5->arg_type != O_ARRAY) {
X                scrstab = aadd(genstab());
X                $$ = append_line(
X                    make_acmd(C_EXPR, Nullstab,
X                      l(make_op(O_ASSIGN,2,
X                    listish(make_op(O_ARRAY, 1,
X                      stab2arg(A_STAB,scrstab),
X                      Nullarg,Nullarg, 1)),
X                    listish(make_list($5)),
X                    Nullarg)),
X                      Nullarg),
X                    wopt(over($3,add_label($1,
X                      make_ccmd(C_WHILE,
X                    make_op(O_ARRAY, 1,
X                      stab2arg(A_STAB,scrstab),
X                      Nullarg,Nullarg ),
X                    $7)))));
X                }
X                else {
X                $$ = wopt(over($3,add_label($1,
X                make_ccmd(C_WHILE,$5,$7) )));
X                }
X            }
X    |    label FOR '(' expr ')' compblock
X            { cmdline = $2;
X                if ($4->arg_type != O_ARRAY) {
X                scrstab = aadd(genstab());
X                $$ = append_line(
X                    make_acmd(C_EXPR, Nullstab,
X                      l(make_op(O_ASSIGN,2,
X                    listish(make_op(O_ARRAY, 1,
X                      stab2arg(A_STAB,scrstab),
X                      Nullarg,Nullarg, 1 )),
X                    listish(make_list($4)),
X                    Nullarg)),
X                      Nullarg),
X                    wopt(over(defstab,add_label($1,
X                      make_ccmd(C_WHILE,
X                    make_op(O_ARRAY, 1,
X                      stab2arg(A_STAB,scrstab),
X                      Nullarg,Nullarg ),
X                    $6)))));
X                }
X                else {    /* lisp, anyone? */
X                $$ = wopt(over(defstab,add_label($1,
X                make_ccmd(C_WHILE,$4,$6) )));
X                }
X            }
X    |    label FOR '(' nexpr ';' texpr ';' nexpr ')' block
X            /* basically fake up an initialize-while lineseq */
X            {   yyval.compval.comp_true = $10;
X                yyval.compval.comp_alt = $8;
X                cmdline = $2;
X                $$ = append_line($4,wopt(add_label($1,
X                make_ccmd(C_WHILE,$6,yyval.compval) ))); }
X    |    label compblock    /* a block is a loop that happens once */
X            { $$ = add_label($1,make_ccmd(C_BLOCK,Nullarg,$2)); }
X    ;
X
Xnexpr    :    /* NULL */
X            { $$ = Nullcmd; }
X    |    sideff
X    ;
X
Xtexpr    :    /* NULL means true */
X            { (void)scanstr("1"); $$ = yylval.arg; }
X    |    expr
X    ;
X
Xlabel    :    /* empty */
X            { $$ = Nullch; }
X    |    WORD ':'
X    ;
X
Xdecl    :    format
X            { $$ = 0; }
X    |    subrout
X            { $$ = 0; }
X    |    package
X            { $$ = 0; }
X    ;
X
Xformat    :    FORMAT WORD '=' FORMLIST
X            { stab_form(stabent($2,TRUE)) = $4; Safefree($2);}
X    |    FORMAT '=' FORMLIST
X            { stab_form(stabent("STDOUT",TRUE)) = $3; }
X    ;
X
Xsubrout    :    SUB WORD block
X            { make_sub($2,$3); }
X    ;
X
Xpackage :    PACKAGE WORD ';'
X            { char tmpbuf[256];
X
X              savehptr(&curstash);
X              saveitem(curstname);
X              str_set(curstname,$2);
X              sprintf(tmpbuf,"'_%s",$2);
X              curstash = stab_xhash(hadd(stabent(tmpbuf,TRUE)));
X              curstash->tbl_coeffsize = 0;
X              Safefree($2);
X            }
X    ;
X
Xcexpr    :    ',' expr
X            { $$ = $2; }
X    ;
X
Xexpr    :    expr ',' sexpr
X            { $$ = make_op(O_COMMA, 2, $1, $3, Nullarg); }
X    |    sexpr
X    ;
X
Xcsexpr    :    ',' sexpr
X            { $$ = $2; }
X    ;
X
Xsexpr    :    sexpr '=' sexpr
X            {   $1 = listish($1);
X                if ($1->arg_type == O_ASSIGN && $1->arg_len == 1)
X                $1->arg_type = O_ITEM;    /* a local() */
X                if ($1->arg_type == O_LIST)
X                $3 = listish($3);
X                $$ = l(make_op(O_ASSIGN, 2, $1, $3, Nullarg)); }
X    |    sexpr POW '=' sexpr
X            { $$ = l(make_op(O_POW, 2, $1, $4, Nullarg)); }
X    |    sexpr MULOP '=' sexpr
X            { $$ = l(make_op($2, 2, $1, $4, Nullarg)); }
X    |    sexpr ADDOP '=' sexpr
X            { $$ = rcatmaybe(l(make_op($2, 2, $1, $4, Nullarg)));}
X    |    sexpr LS '=' sexpr
X            { $$ = l(make_op(O_LEFT_SHIFT, 2, $1, $4, Nullarg)); }
X    |    sexpr RS '=' sexpr
X            { $$ = l(make_op(O_RIGHT_SHIFT, 2, $1, $4, Nullarg)); }
X    |    sexpr '&' '=' sexpr
X            { $$ = l(make_op(O_BIT_AND, 2, $1, $4, Nullarg)); }
X    |    sexpr '^' '=' sexpr
X            { $$ = l(make_op(O_XOR, 2, $1, $4, Nullarg)); }
X    |    sexpr '|' '=' sexpr
X            { $$ = l(make_op(O_BIT_OR, 2, $1, $4, Nullarg)); }
X
X
X    |    sexpr POW sexpr
X            { $$ = make_op(O_POW, 2, $1, $3, Nullarg); }
X    |    sexpr MULOP sexpr
X            { $$ = make_op($2, 2, $1, $3, Nullarg); }
X    |    sexpr ADDOP sexpr
X            { $$ = make_op($2, 2, $1, $3, Nullarg); }
X    |    sexpr LS sexpr
X            { $$ = make_op(O_LEFT_SHIFT, 2, $1, $3, Nullarg); }
X    |    sexpr RS sexpr
X            { $$ = make_op(O_RIGHT_SHIFT, 2, $1, $3, Nullarg); }
X    |    sexpr RELOP sexpr
X            { $$ = make_op($2, 2, $1, $3, Nullarg); }
X    |    sexpr EQOP sexpr
X            { $$ = make_op($2, 2, $1, $3, Nullarg); }
X    |    sexpr '&' sexpr
X            { $$ = make_op(O_BIT_AND, 2, $1, $3, Nullarg); }
X    |    sexpr '^' sexpr
X            { $$ = make_op(O_XOR, 2, $1, $3, Nullarg); }
X    |    sexpr '|' sexpr
X            { $$ = make_op(O_BIT_OR, 2, $1, $3, Nullarg); }
X    |    sexpr DOTDOT sexpr
X            { arg4 = Nullarg;
X              $$ = make_op(O_F_OR_R, 4, $1, $3, Nullarg); }
X    |    sexpr ANDAND sexpr
X            { $$ = make_op(O_AND, 2, $1, $3, Nullarg); }
X    |    sexpr OROR sexpr
X            { $$ = make_op(O_OR, 2, $1, $3, Nullarg); }
X    |    sexpr '?' sexpr ':' sexpr
X            { $$ = make_op(O_COND_EXPR, 3, $1, $3, $5); }
X    |    sexpr MATCH sexpr
X            { $$ = mod_match(O_MATCH, $1, $3); }
X    |    sexpr NMATCH sexpr
X            { $$ = mod_match(O_NMATCH, $1, $3); }
X    |    term INC
X            { $$ = addflags(1, AF_POST|AF_UP,
X                l(make_op(O_ITEM,1,$1,Nullarg,Nullarg))); }
X    |    term DEC
X            { $$ = addflags(1, AF_POST,
X                l(make_op(O_ITEM,1,$1,Nullarg,Nullarg))); }
X    |    INC term
X            { $$ = addflags(1, AF_PRE|AF_UP,
X                l(make_op(O_ITEM,1,$2,Nullarg,Nullarg))); }
X    |    DEC term
X            { $$ = addflags(1, AF_PRE,
X                l(make_op(O_ITEM,1,$2,Nullarg,Nullarg))); }
X    |    term
X            { $$ = $1; }
X    ;
X
Xterm    :    '-' term %prec UMINUS
X            { $$ = make_op(O_NEGATE, 1, $2, Nullarg, Nullarg); }
X    |    '+' term %prec UMINUS
X            { $$ = $2; }
X    |    '!' term
X            { $$ = make_op(O_NOT, 1, $2, Nullarg, Nullarg); }
X    |    '~' term
X            { $$ = make_op(O_COMPLEMENT, 1, $2, Nullarg, Nullarg);}
X    |    FILETEST WORD
X            { opargs[$1] = 0;    /* force it special */
X                $$ = make_op($1, 1,
X                stab2arg(A_STAB,stabent($2,TRUE)),
X                Nullarg, Nullarg);
X            }
X    |    FILETEST sexpr
X            { opargs[$1] = 1;
X                $$ = make_op($1, 1, $2, Nullarg, Nullarg); }
X    |    FILETEST
X            { opargs[$1] = ($1 != O_FTTTY);
X                $$ = make_op($1, 1,
X                stab2arg(A_STAB,
X                  $1 == O_FTTTY?stabent("STDIN",TRUE):defstab),
X                Nullarg, Nullarg); }
X    |    LOCAL '(' expr ')'
X            { $$ = l(make_op(O_ITEM, 1,
X                localize(listish(make_list($3))),
X                Nullarg,Nullarg)); }
X    |    '(' expr ')'
X            { $$ = make_list(hide_ary($2)); }
X    |    '(' ')'
X            { $$ = make_list(Nullarg); }
X    |    DO sexpr    %prec FILETEST
X            { $$ = fixeval(
X                make_op(O_DOFILE,2,$2,Nullarg,Nullarg) );
X              allstabs = TRUE;}
X    |    DO block    %prec '('
X            { $$ = cmd_to_arg($2); }
X    |    REG    %prec '('
X            { $$ = stab2arg(A_STAB,$1); }
X    |    STAR    %prec '('
X            { $$ = stab2arg(A_STAR,$1); }
X    |    REG '[' expr ']'    %prec '('
X            { $$ = make_op(O_AELEM, 2,
X                stab2arg(A_STAB,aadd($1)), $3, Nullarg); }
X    |    HSH     %prec '('
X            { $$ = make_op(O_HASH, 1,
X                stab2arg(A_STAB,$1),
X                Nullarg, Nullarg); }
X    |    ARY     %prec '('
X            { $$ = make_op(O_ARRAY, 1,
X                stab2arg(A_STAB,$1),
X                Nullarg, Nullarg); }
X    |    REG '{' expr '}'    %prec '('
X            { $$ = make_op(O_HELEM, 2,
X                stab2arg(A_STAB,hadd($1)),
X                jmaybe($3),
X                Nullarg); }
X    |    ARY '[' expr ']'    %prec '('
X            { $$ = make_op(O_ASLICE, 2,
X                stab2arg(A_STAB,aadd($1)),
X                listish(make_list($3)),
X                Nullarg); }
X    |    ARY '{' expr '}'    %prec '('
X            { $$ = make_op(O_HSLICE, 2,
X                stab2arg(A_STAB,hadd($1)),
X                listish(make_list($3)),
X                Nullarg); }
X    |    DELETE REG '{' expr '}'    %prec '('
X            { $$ = make_op(O_DELETE, 2,
X                stab2arg(A_STAB,hadd($2)),
X                jmaybe($4),
X                Nullarg); }
X    |    ARYLEN    %prec '('
X            { $$ = stab2arg(A_ARYLEN,$1); }
X    |    RSTRING    %prec '('
X            { $$ = $1; }
X    |    PATTERN    %prec '('
X            { $$ = $1; }
X    |    SUBST    %prec '('
X            { $$ = $1; }
X    |    TRANS    %prec '('
X            { $$ = $1; }
X    |    DO WORD '(' expr ')'
X            { $$ = make_op((perldb ? O_DBSUBR : O_SUBR), 2,
X                stab2arg(A_WORD,stabent($2,TRUE)),
X                make_list($4),
X                Nullarg); Safefree($2); }
X    |    AMPER WORD '(' expr ')'
X            { $$ = make_op((perldb ? O_DBSUBR : O_SUBR), 2,
X                stab2arg(A_WORD,stabent($2,TRUE)),
X                make_list($4),
X                Nullarg); Safefree($2); }
X    |    DO WORD '(' ')'
X            { $$ = make_op((perldb ? O_DBSUBR : O_SUBR), 2,
X                stab2arg(A_WORD,stabent($2,TRUE)),
X                make_list(Nullarg),
X                Nullarg); }
X    |    AMPER WORD '(' ')'
X            { $$ = make_op((perldb ? O_DBSUBR : O_SUBR), 2,
X                stab2arg(A_WORD,stabent($2,TRUE)),
X                make_list(Nullarg),
X                Nullarg); }
X    |    AMPER WORD
X            { $$ = make_op((perldb ? O_DBSUBR : O_SUBR), 2,
X                stab2arg(A_WORD,stabent($2,TRUE)),
X                Nullarg,
X                Nullarg); }
X    |    DO REG '(' expr ')'
X            { $$ = make_op((perldb ? O_DBSUBR : O_SUBR), 2,
X                stab2arg(A_STAB,$2),
X                make_list($4),
X                Nullarg); }
X    |    AMPER REG '(' expr ')'
X            { $$ = make_op((perldb ? O_DBSUBR : O_SUBR), 2,
X                stab2arg(A_STAB,$2),
X                make_list($4),
X                Nullarg); }
X    |    DO REG '(' ')'
X            { $$ = make_op((perldb ? O_DBSUBR : O_SUBR), 2,
X                stab2arg(A_STAB,$2),
X                make_list(Nullarg),
X                Nullarg); }
X    |    AMPER REG '(' ')'
X            { $$ = make_op((perldb ? O_DBSUBR : O_SUBR), 2,
X                stab2arg(A_STAB,$2),
X                make_list(Nullarg),
X                Nullarg); }
X    |    AMPER REG
X            { $$ = make_op((perldb ? O_DBSUBR : O_SUBR), 2,
X                stab2arg(A_STAB,$2),
X                Nullarg,
X                Nullarg); }
X    |    LOOPEX
X            { $$ = make_op($1,0,Nullarg,Nullarg,Nullarg); }
X    |    LOOPEX WORD
X            { $$ = make_op($1,1,cval_to_arg($2),
X                Nullarg,Nullarg); }
X    |    UNIOP
X            { $$ = make_op($1,1,Nullarg,Nullarg,Nullarg);
X              if ($1 == O_EVAL || $1 == O_RESET)
X                $$ = fixeval($$); }
X    |    UNIOP sexpr
X            { $$ = make_op($1,1,$2,Nullarg,Nullarg);
X              if ($1 == O_EVAL || $1 == O_RESET)
X                $$ = fixeval($$); }
X    |    SELECT
X            { $$ = make_op(O_SELECT, 0, Nullarg, Nullarg, Nullarg);}
X    |    SELECT '(' handle ')'
X            { $$ = make_op(O_SELECT, 1, $3, Nullarg, Nullarg); }
X    |    SELECT '(' sexpr csexpr csexpr csexpr ')'
X            { arg4 = $6;
X              $$ = make_op(O_SSELECT, 4, $3, $4, $5); }
X    |    OPEN WORD    %prec '('
X            { $$ = make_op(O_OPEN, 2,
X                stab2arg(A_WORD,stabent($2,TRUE)),
X                stab2arg(A_STAB,stabent($2,TRUE)),
X                Nullarg); }
X    |    OPEN '(' WORD ')'
X            { $$ = make_op(O_OPEN, 2,
X                stab2arg(A_WORD,stabent($3,TRUE)),
X                stab2arg(A_STAB,stabent($3,TRUE)),
X                Nullarg); }
X    |    OPEN '(' handle cexpr ')'
X            { $$ = make_op(O_OPEN, 2,
X                $3,
X                $4, Nullarg); }
X    |    FILOP '(' handle ')'
X            { $$ = make_op($1, 1,
X                $3,
X                Nullarg, Nullarg); }
X    |    FILOP WORD
X            { $$ = make_op($1, 1,
X                stab2arg(A_WORD,stabent($2,TRUE)),
X                Nullarg, Nullarg);
X              Safefree($2); }
X    |    FILOP REG
X            { $$ = make_op($1, 1,
X                stab2arg(A_STAB,$2),
X                Nullarg, Nullarg); }
X    |    FILOP '(' ')'
X            { $$ = make_op($1, 1,
X                stab2arg(A_WORD,Nullstab),
X                Nullarg, Nullarg); }
X    |    FILOP    %prec '('
X            { $$ = make_op($1, 0,
X                Nullarg, Nullarg, Nullarg); }
X    |    FILOP2 '(' handle cexpr ')'
X            { $$ = make_op($1, 2, $3, $4, Nullarg); }
X    |    FILOP3 '(' handle csexpr cexpr ')'
X            { $$ = make_op($1, 3, $3, $4, $5); }
X    |    FILOP22 '(' handle ',' handle ')'
X            { $$ = make_op($1, 2, $3, $5, Nullarg); }
X    |    FILOP4 '(' handle csexpr csexpr cexpr ')'
X            { arg4 = $6; $$ = make_op($1, 4, $3, $4, $5); }
X    |    FILOP25 '(' handle ',' handle csexpr csexpr cexpr ')'
X            { arg4 = $7; arg5 = $8;
X              $$ = make_op($1, 5, $3, $5, $6); }
X    |    PUSH '(' aryword cexpr ')'
X            { $$ = make_op($1, 2,
X                $3,
X                make_list($4),
X                Nullarg); }
X    |    POP aryword    %prec '('
X            { $$ = make_op(O_POP, 1, $2, Nullarg, Nullarg); }
X    |    POP '(' aryword ')'
X            { $$ = make_op(O_POP, 1, $3, Nullarg, Nullarg); }
X    |    SHIFT aryword    %prec '('
X            { $$ = make_op(O_SHIFT, 1, $2, Nullarg, Nullarg); }
X    |    SHIFT '(' aryword ')'
X            { $$ = make_op(O_SHIFT, 1, $3, Nullarg, Nullarg); }
X    |    SHIFT    %prec '('
X            { $$ = make_op(O_SHIFT, 1,
X                stab2arg(A_STAB,
X                  aadd(stabent(subline ? "_" : "ARGV", TRUE))),
X                Nullarg, Nullarg); }
X    |    SPLIT    %prec '('
X            { (void)scanpat("/\\s+/");
X                $$ = make_split(defstab,yylval.arg,Nullarg); }
X    |    SPLIT '(' sexpr csexpr csexpr ')'
X            { $$ = mod_match(O_MATCH, $4,
X              make_split(defstab,$3,$5));}
X    |    SPLIT '(' sexpr csexpr ')'
X            { $$ = mod_match(O_MATCH, $4,
X              make_split(defstab,$3,Nullarg) ); }
X    |    SPLIT '(' sexpr ')'
X            { $$ = mod_match(O_MATCH,
X                stab2arg(A_STAB,defstab),
X                make_split(defstab,$3,Nullarg) ); }
X    |    FLIST2 '(' sexpr cexpr ')'
X            { $$ = make_op($1, 2,
X                $3,
X                listish(make_list($4)),
X                Nullarg); }
X    |    FLIST '(' expr ')'
X            { $$ = make_op($1, 1,
X                make_list($3),
X                Nullarg,
X                Nullarg); }
X    |    LVALFUN sexpr    %prec '('
X            { $$ = l(make_op($1, 1, fixl($1,$2),
X                Nullarg, Nullarg)); }
X    |    LVALFUN
X            { $$ = l(make_op($1, 1,
X                stab2arg(A_STAB,defstab),
X                Nullarg, Nullarg)); }
X    |    FUNC0
X            { $$ = make_op($1, 0, Nullarg, Nullarg, Nullarg); }
X    |    FUNC1 '(' expr ')'
X            { $$ = make_op($1, 1, $3, Nullarg, Nullarg);
X              if ($1 == O_EVAL || $1 == O_RESET)
X                $$ = fixeval($$); }
X    |    FUNC2 '(' sexpr cexpr ')'
X            { $$ = make_op($1, 2, $3, $4, Nullarg);
X                if ($1 == O_INDEX && $$[2].arg_type == A_SINGLE)
X                fbmcompile($$[2].arg_ptr.arg_str,0); }
X    |    FUNC3 '(' sexpr csexpr cexpr ')'
X            { $$ = make_op($1, 3, $3, $4, $5); }
X    |    LFUNC4 '(' sexpr csexpr csexpr cexpr ')'
X            { arg4 = $6; $$ = make_op($1, 4, l($3), $4, $5); }
X    |    HSHFUN '(' hshword ')'
X            { $$ = make_op($1, 1,
X                $3,
X                Nullarg,
X                Nullarg); }
X    |    HSHFUN hshword
X            { $$ = make_op($1, 1,
X                $2,
X                Nullarg,
X                Nullarg); }
X    |    HSHFUN3 '(' hshword csexpr cexpr ')'
X            { $$ = make_op($1, 3, $3, $4, $5); }
X    |    listop
X    ;
X
Xlistop    :    LISTOP
X            { $$ = make_op($1,2,
X                stab2arg(A_WORD,Nullstab),
X                stab2arg(A_STAB,defstab),
X                Nullarg); }
X    |    LISTOP expr
X            { $$ = make_op($1,2,
X                stab2arg(A_WORD,Nullstab),
X                maybelistish($1,make_list($2)),
X                Nullarg); }
X    |    LISTOP WORD
X            { $$ = make_op($1,2,
X                stab2arg(A_WORD,stabent($2,TRUE)),
X                stab2arg(A_STAB,defstab),
X                Nullarg); }
X    |    LISTOP WORD expr
X            { $$ = make_op($1,2,
X                stab2arg(A_WORD,stabent($2,TRUE)),
X                maybelistish($1,make_list($3)),
X                Nullarg); Safefree($2); }
X    |    LISTOP REG expr
X            { $$ = make_op($1,2,
X                stab2arg(A_STAB,$2),
X                maybelistish($1,make_list($3)),
X                Nullarg); }
X    ;
X
Xhandle    :    WORD
X            { $$ = stab2arg(A_WORD,stabent($1,TRUE)); Safefree($1);}
X    |    sexpr
X    ;
X
Xaryword    :    WORD
X            { $$ = stab2arg(A_WORD,aadd(stabent($1,TRUE)));
X                Safefree($1); }
X    |    ARY
X            { $$ = stab2arg(A_STAB,$1); }
X    ;
X
Xhshword    :    WORD
X            { $$ = stab2arg(A_WORD,hadd(stabent($1,TRUE)));
X                Safefree($1); }
X    |    HSH
X            { $$ = stab2arg(A_STAB,$1); }
X    ;
X
X%% /* PROGRAM */
!STUFFY!FUNK!
echo Extracting t/cmd.switch
sed >t/cmd.switch <<'!STUFFY!FUNK!' -e 's/X//'
X#!./perl
X
X# $Header: cmd.switch,v 3.0 89/10/18 15:25:00 lwall Locked $
X
Xprint "1..18\n";
X
Xsub foo1 {
X    $_ = shift(@_);
X    $a = 0;
X    until ($a++) {
X    next if $_ eq 1;
X    next if $_ eq 2;
X    next if $_ eq 3;
X    next if $_ eq 4;
X    return 20;
X    }
X    continue {
X    return $_;
X    }
X}
X
Xprint do foo1(0) == 20 ? "ok 1\n" : "not ok 1\n";
Xprint do foo1(1) == 1 ? "ok 2\n" : "not ok 2\n";
Xprint do foo1(2) == 2 ? "ok 3\n" : "not ok 3\n";
Xprint do foo1(3) == 3 ? "ok 4\n" : "not ok 4\n";
Xprint do foo1(4) == 4 ? "ok 5\n" : "not ok 5\n";
Xprint do foo1(5) == 20 ? "ok 6\n" : "not ok 6\n";
X
Xsub foo2 {
X    $_ = shift(@_);
X    {
X    last if $_ == 1;
X    last if $_ == 2;
X    last if $_ == 3;
X    last if $_ == 4;
X    }
X    continue {
X    return 20;
X    }
X    return $_;
X}
X
Xprint do foo2(0) == 20 ? "ok 7\n" : "not ok 1\n";
Xprint do foo2(1) == 1 ? "ok 8\n" : "not ok 8\n";
Xprint do foo2(2) == 2 ? "ok 9\n" : "not ok 9\n";
Xprint do foo2(3) == 3 ? "ok 10\n" : "not ok 10\n";
Xprint do foo2(4) == 4 ? "ok 11\n" : "not ok 11\n";
Xprint do foo2(5) == 20 ? "ok 12\n" : "not ok 12\n";
X
Xsub foo3 {
X    $_ = shift(@_);
X    if (/^1/) {
X    return 1;
X    }
X    elsif (/^2/) {
X    return 2;
X    }
X    elsif (/^3/) {
X    return 3;
X    }
X    elsif (/^4/) {
X    return 4;
X    }
X    else {
X    return 20;
X    }
X    return 40;
X}
X
Xprint do foo3(0) == 20 ? "ok 13\n" : "not ok 13\n";
Xprint do foo3(1) == 1 ? "ok 14\n" : "not ok 14\n";
Xprint do foo3(2) == 2 ? "ok 15\n" : "not ok 15\n";
Xprint do foo3(3) == 3 ? "ok 16\n" : "not ok 16\n";
Xprint do foo3(4) == 4 ? "ok 17\n" : "not ok 17\n";
Xprint do foo3(5) == 20 ? "ok 18\n" : "not ok 18\n";
!STUFFY!FUNK!
echo ""
echo "End of kit 12 (of 24)"
cat /dev/null >kit12isdone
run=''
config=''
for iskit in 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24; do
    if test -f kit${iskit}isdone; then
    run="$run $iskit"
    else
    todo="$todo $iskit"
    fi
done
case $todo in
    '')
    echo "You have run all your kits.  Please read README and then type Configure."
    chmod 755 Configure
    ;;
    *)  echo "You have run$run."
    echo "You still need to run$todo."
    ;;
esac
: Someone might mail this, so...
exit

--
Please send comp.sources.unix-related mail to [e-mail].
Use a domain-based address or give alternate paths, or you may lose out.