acd.c

Go to the documentation of this file.

/*      acd 1.10 - A compiler driver                    Author: Kees J. Bot
 *                                                              7 Jan 1993
 * Needs about 25kw heap + stack.
 */
char version[] = "1.9";

#define nil 0
#define _POSIX_SOURCE   1
#include <sys/types.h>
#include <stdio.h>
#include <stddef.h>
#include <stdlib.h>
#include <unistd.h>
#include <fcntl.h>
#include <string.h>
#include <signal.h>
#include <errno.h>
#include <ctype.h>
#include <assert.h>
#include <sys/stat.h>
#include <sys/wait.h>

#ifndef LIB
#define LIB     "/usr/lib"      /* Default library directory. */
#endif

#define arraysize(a)    (sizeof(a) / sizeof((a)[0]))
#define arraylimit(a)   ((a) + arraysize(a))

char *program;          /* Call name. */

int verbose= 0;         /* -v0: Silent.
                         * -v1: Show abbreviated pass names.
                         * -v2: Show executed UNIX commands.
                         * -v3: Show executed ACD commands.
                         * -v4: Show descr file as it is read.
                         */

int action= 2;          /*   0: An error occured, don't do anything anymore.
                         *   1: (-vn) Do not execute, play-act.
                         *   2: Execute UNIX commands.
                         */

void report(char *label)
{
        if (label == nil || label[0] == 0) {
                fprintf(stderr, "%s: %s\n", program, strerror(errno));
        } else {
                fprintf(stderr, "%s: %s: %s\n",
                                        program, label, strerror(errno));
        }
        action= 0;
}

void quit(int exit_code);

void fatal(char *label)
{
        report(label);
        quit(-1);
}

size_t heap_chunks= 0;

void *allocate(void *mem, size_t size)
/* Safe malloc/realloc.  (I have heard that one can call realloc with a
 * null first argument with the effect below, but that is of course to
 * ridiculous to believe.)
 */
{
        assert(size > 0);

        if (mem != nil) {
                mem= realloc(mem, size);
        } else {
                mem= malloc(size);
                heap_chunks++;
        }
        if (mem == nil) fatal(nil);
        return mem;
}

void deallocate(void *mem)
{
        if (mem != nil) {
                free(mem);
                heap_chunks--;
        }
}

char *copystr(const char *s)
{
        char *c;
        c= allocate(nil, (strlen(s)+1) * sizeof(*c));
        strcpy(c, s);
        return c;
}

/* Every object, list, letter, or variable, is made with cells. */
typedef struct cell {
        unsigned short  refc;           /* Reference count. */
        char            type;           /* Type of object. */
        unsigned char   letter;         /* Simply a letter. */
        char            *name;          /* Name of a word. */
        struct cell     *hash;          /* Hash chain. */
        struct cell     *car, *cdr;     /* To form lists. */

/* For a word: */
#       define  value   car             /* Value of a variable. */
#       define  base    cdr             /* Base-name in transformations. */
#       define  suffix  cdr             /* Suffix in a treat-as. */
#       define  flags   letter          /* Special flags. */

/* A substitution: */
#       define  subst   car

} cell_t;

typedef enum type {
        CELL,           /* A list cell. */
        STRING,         /* To make a list of characters and substs. */
        SUBST,          /* Variable to substitute. */
        /* Unique objects. */
        LETTER,         /* A letter. */
        WORD,           /* A string collapses to a word. */
        EQUALS,         /* = operator, etc. */
        OPEN,
        CLOSE,
        PLUS,
        MINUS,
        STAR,
        INPUT,
        OUTPUT,
        WHITE,
        COMMENT,
        SEMI,
        EOLN,
        N_TYPES         /* number of different types */
} type_t;

#define is_unique(type) ((type) >= LETTER)

/* Flags on a word. */
#define W_SET           0x01    /* Not undefined, e.g. assigned to. */
#define W_RDONLY        0x02    /* Read only. */
#define W_LOCAL         0x04    /* Local variable, immediate substitution. */
#define W_TEMP          0x08    /* Name of a temporary file, delete on quit. */
#define W_SUFF          0x10    /* Has a suffix set on it. */

void princhar(int c)
/* Print a character, escaped if important to the shell *within* quotes. */
{
        if (strchr("\\'\"<>();~$^&*|{}[]?", c) != nil) fputc('\\', stdout);
        putchar(c);
}

void prinstr(char *s)
/* Print a string, in quotes if the shell might not like it. */
{
        int q= 0;
        char *s2= s;

        while (*s2 != 0)
                if (strchr("~`$^&*()=\\|[]{};'\"<>?", *s2++) != nil) q= 1;

        if (q) fputc('"', stdout);
        while (*s != 0) princhar(*s++);
        if (q) fputc('"', stdout);
}

void prin2(cell_t *p);

void prin1(cell_t *p)
/* Print a cell structure for debugging purposes. */
{
        if (p == nil) {
                printf("(\b(\b()\b)\b)");
                return;
        }

        switch (p->type) {
        case CELL:
                printf("(\b(\b(");
                prin2(p);
                printf(")\b)\b)");
                break;
        case STRING:
                printf("\"\b\"\b\"");
                prin2(p);
                printf("\"\b\"\b\"");
                break;
        case SUBST:
                printf("$\b$\b${%s}", p->subst->name);
                break;
        case LETTER:
                princhar(p->letter);
                break;
        case WORD:
                prinstr(p->name);
                break;
        case EQUALS:
                printf("=\b=\b=");
                break;
        case PLUS:
                printf("+\b+\b+");
                break;
        case MINUS:
                printf("-\b-\b-");
                break;
        case STAR:
                printf("*\b*\b*");
                break;
        case INPUT:
                printf(verbose >= 3 ? "<\b<\b<" : "<");
                break;
        case OUTPUT:
                printf(verbose >= 3 ? ">\b>\b>" : ">");
                break;
        default:
                assert(0);
        }
}

void prin2(cell_t *p)
/* Print a list for debugging purposes. */
{
        while (p != nil && p->type <= STRING) {
                prin1(p->car);

                if (p->type == CELL && p->cdr != nil) fputc(' ', stdout);

                p= p->cdr;
        }
        if (p != nil) prin1(p);         /* Dotted pair? */
}

void prin1n(cell_t *p) { prin1(p); fputc('\n', stdout); }

void prin2n(cell_t *p) { prin2(p); fputc('\n', stdout); }

/* A program is consists of a series of lists at a certain indentation level. */
typedef struct program {
        struct program  *next;
        cell_t          *file;          /* Associated description file. */
        unsigned        indent;         /* Line indentation level. */
        unsigned        lineno;         /* Line number where this is found. */
        cell_t          *line;          /* One line of tokens. */
} program_t;

program_t *pc;          /* Program Counter (what else?) */
program_t *nextpc;      /* Next line to execute. */

cell_t *oldcells;       /* Keep a list of old cells, don't deallocate. */

cell_t *newcell(void)
/* Make a new empty cell. */
{
        cell_t *p;

        if (oldcells != nil) {
                p= oldcells;
                oldcells= p->cdr;
                heap_chunks++;
        } else {
                p= allocate(nil, sizeof(*p));
        }

        p->refc= 0;
        p->type= CELL;
        p->letter= 0;
        p->name= nil;
        p->car= nil;
        p->cdr= nil;
        return p;
}

#define N_CHARS         (1 + (unsigned char) -1)
#define HASHDENSE       0x400

cell_t *oblist[HASHDENSE + N_CHARS + N_TYPES];

unsigned hashfun(cell_t *p)
/* Use a blender on a cell. */
{
        unsigned h;
        char *name;

        switch (p->type) {
        case WORD:
                h= 0;
                name= p->name;
                while (*name != 0) h= (h * 0x1111) + *name++;
                return h % HASHDENSE;
        case LETTER:
                return HASHDENSE + p->letter;
        default:
                return HASHDENSE + N_CHARS + p->type;
        }
}

cell_t *search(cell_t *p, cell_t ***hook)
/* Search for *p, return the one found.  *hook may be used to insert or
 * delete.
 */
{
        cell_t *sp;

        sp= *(*hook= &oblist[hashfun(p)]);

        if (p->type == WORD) {
                /* More than one name per hash slot. */
                int cmp= 0;

                while (sp != nil && (cmp= strcmp(p->name, sp->name)) > 0)
                        sp= *(*hook= &sp->hash);

                if (cmp != 0) sp= nil;
        }
        return sp;
}

void dec(cell_t *p)
/* Decrease the number of references to p, if zero delete and recurse. */
{
        if (p == nil || --p->refc > 0) return;

        if (is_unique(p->type)) {
                /* Remove p from the oblist. */
                cell_t *o, **hook;

                o= search(p, &hook);

                if (o == p) {
                        /* It's there, remove it. */
                        *hook= p->hash;
                        p->hash= nil;
                }

                if (p->type == WORD && (p->flags & W_TEMP)) {
                        /* A filename to remove. */
                        if (verbose >= 2) {
                                printf("rm -f ");
                                prinstr(p->name);
                                fputc('\n', stdout);
                        }
                        if (unlink(p->name) < 0 && errno != ENOENT)
                                report(p->name);
                }
        }
        deallocate(p->name);
        dec(p->car);
        dec(p->cdr);
        p->cdr= oldcells;
        oldcells= p;
        heap_chunks--;
}

cell_t *inc(cell_t *p)
/* Increase the number of references to p. */
{
        cell_t *o, **hook;

        if (p == nil) return nil;

        if (++p->refc > 1 || !is_unique(p->type)) return p;

        /* First appearance, put p on the oblist. */
        o= search(p, &hook);

        if (o == nil) {
                /* Not there yet, add it. */
                p->hash= *hook;
                *hook= p;
        } else {
                /* There is another object already there with the same info. */
                o->refc++;
                dec(p);
                p= o;
        }
        return p;
}

cell_t *go(cell_t *p, cell_t *field)
/* Often happening: You've got p, you want p->field. */
{
        field= inc(field);
        dec(p);
        return field;
}

cell_t *cons(type_t type, cell_t *p)
/* P is to be added to a list (or a string). */
{
        cell_t *l= newcell();
        l->type= type;
        l->refc++;
        l->car= p;
        return l;
}

cell_t *append(type_t type, cell_t *p)
/* P is to be appended to a list (or a string). */
{
        return p == nil || p->type == type ? p : cons(type, p);
}

cell_t *findnword(char *name, size_t n)
/* Find the word with the given name of length n. */
{
        cell_t *w= newcell();
        w->type= WORD;
        w->name= allocate(nil, (n+1) * sizeof(*w->name));
        memcpy(w->name, name, n);
        w->name[n]= 0;
        return inc(w);
}

cell_t *findword(char *name)
/* Find the word with the given null-terminated name. */
{
        return findnword(name, strlen(name));
}

void quit(int exstat)
/* Remove all temporary names, then exit. */
{
        cell_t **op, *p, *v, *b;
        size_t chunks;

        /* Remove cycles, like X = X. */
        for (op= oblist; op < oblist + HASHDENSE; op++) {
                p= *op;
                while (p != nil) {
                        if (p->value != nil || p->base != nil) {
                                v= p->value;
                                b= p->base;
                                p->value= nil;
                                p->base= nil;
                                p= *op;
                                dec(v);
                                dec(b);
                        } else {
                                p= p->hash;
                        }
                }
        }
        chunks= heap_chunks;

        /* Something may remain on an early quit: tempfiles. */
        for (op= oblist; op < oblist + HASHDENSE; op++) {

                while (*op != nil) { (*op)->refc= 1; dec(*op); }
        }

        if (exstat != -1 && chunks > 0) {
                fprintf(stderr,
                        "%s: internal fault: %d chunks still on the heap\n",
                                                program, chunks);
        }
        exit(exstat);
}

void interrupt(int sig)
{
        signal(sig, interrupt);
        if (verbose >= 2) write(1, "# interrupt\n", 12);
        action= 0;
}

int extalnum(int c)
/* Uppercase, lowercase, digit, underscore or anything non-American. */
{
        return isalnum(c) || c == '_' || c >= 0200;
}

char *descr;            /* Name of current description file. */
FILE *dfp;              /* Open description file. */
int dch;                /* Input character. */
unsigned lineno;        /* Line number in file. */
unsigned indent;        /* Indentation level. */

void getdesc(void)
{
        if (dch == EOF) return;

        if (dch == '\n') { lineno++; indent= 0; }

        if ((dch = getc(dfp)) == EOF && ferror(dfp)) fatal(descr);

        if (dch == 0) {
                fprintf(stderr, "%s: %s is a binary file.\n", program, descr);
                quit(-1);
        }
}

#define E_BASH          0x01    /* Escaped by backslash. */
#define E_QUOTE         0x02    /* Escaped by double quote. */
#define E_SIMPLE        0x04    /* More simple characters? */

cell_t *get_token(void)
/* Read one token from the description file. */
{
        int whitetype= 0;
        static int escape= 0;
        cell_t *tok;
        char *name;
        int n, i;

        if (escape & E_SIMPLE) {
                /* More simple characters?  (Note: performance hack.) */
                if (isalnum(dch)) {
                        tok= newcell();
                        tok->type= LETTER;
                        tok->letter= dch;
                        getdesc();
                        return inc(tok);
                }
                escape&= ~E_SIMPLE;
        }

        /* Gather whitespace. */
        for (;;) {
                if (dch == '\\' && whitetype == 0) {
                        getdesc();
                        if (isspace(dch)) {
                                /* \ whitespace: remove. */
                                do {
                                        getdesc();
                                        if (dch == '#' && !(escape & E_QUOTE)) {
                                                /* \ # comment */
                                                do
                                                        getdesc();
                                                while (dch != '\n'
                                                                && dch != EOF);
                                        }
                                } while (isspace(dch));
                                continue;
                        }
                        escape|= E_BASH;        /* Escaped character. */
                }

                if (escape != 0) break;

                if (dch == '#' && (indent == 0 || whitetype != 0)) {
                        /* # Comment. */
                        do getdesc(); while (dch != '\n' && dch != EOF);
                        whitetype= COMMENT;
                        break;
                }

                if (!isspace(dch) || dch == '\n' || dch == EOF) break;

                whitetype= WHITE;

                indent++;
                if (dch == '\t') indent= (indent + 7) & ~7;

                getdesc();
        }

        if (dch == EOF) return nil;

        /* Make a token. */
        tok= newcell();

        if (whitetype != 0) {
                tok->type= whitetype;
                return inc(tok);
        }

        if (!(escape & E_BASH) && dch == '"') {
                getdesc();
                if (!(escape & E_QUOTE)) {
                        /* Start of a string, signal this with a string cell. */
                        escape|= E_QUOTE;
                        tok->type= STRING;
                        return inc(tok);
                } else {
                        /* End of a string, back to normal mode. */
                        escape&= ~E_QUOTE;
                        deallocate(tok);
                        return get_token();
                }
        }

        if (escape & E_BASH
                || strchr(escape & E_QUOTE ? "$" : "$=()+-*<>;\n", dch) == nil
        ) {
                if (dch == '\n') {
                        fprintf(stderr,
                                "\"%s\", line %u: missing closing quote\n",
                                descr, lineno);
                        escape&= ~E_QUOTE;
                        action= 0;
                }
                if (escape & E_BASH && dch == 'n') dch= '\n';
                escape&= ~E_BASH;

                /* A simple character. */
                tok->type= LETTER;
                tok->letter= dch;
                getdesc();
                escape|= E_SIMPLE;
                return inc(tok);
        }

        if (dch != '$') {
                /* Single character token. */
                switch (dch) {
                case '=':       tok->type= EQUALS;      break;
                case '(':       tok->type= OPEN;        break;
                case ')':       tok->type= CLOSE;       break;
                case '+':       tok->type= PLUS;        break;
                case '-':       tok->type= MINUS;       break;
                case '*':       tok->type= STAR;        break;
                case '<':       tok->type= INPUT;       break;
                case '>':       tok->type= OUTPUT;      break;
                case ';':       tok->type= SEMI;        break;
                case '\n':      tok->type= EOLN;        break;
                }
                getdesc();
                return inc(tok);
        }

        /* Substitution. */
        getdesc();
        if (dch == EOF || isspace(dch)) {
                fprintf(stderr, "\"%s\", line %u: Word expected after '$'\n",
                        descr, lineno);
                action= 0;
                deallocate(tok);
                return get_token();
        }

        name= allocate(nil, (n= 16) * sizeof(*name));
        i= 0;

        if (dch == '{' || dch == '('  /* )} */ ) {
                /* $(X), ${X} */
                int lpar= dch;          /* ( */
                int rpar= lpar == '{' ? '}' : ')';

                for (;;) {
                        getdesc();
                        if (dch == rpar) { getdesc(); break; }
                        if (isspace(dch) || dch == EOF) {
                                fprintf(stderr,
                                "\"%s\", line %u: $%c unmatched, no '%c'\n",
                                        descr, lineno, lpar, rpar);
                                action= 0;
                                break;
                        }
                        name[i++]= dch;
                        if (i == n)
                                name= allocate(name, (n*= 2) * sizeof(char));
                }
        } else
        if (extalnum(dch)) {
                /* $X */
                do {
                        name[i++]= dch;
                        if (i == n)
                                name= allocate(name, (n*= 2) * sizeof(char));
                        getdesc();
                } while (extalnum(dch));
        } else {
                /* $* */
                name[i++]= dch;
                getdesc();
        }
        name[i++]= 0;
        name= allocate(name, i * sizeof(char));
        tok->type= SUBST;
        tok->subst= newcell();
        tok->subst->type= WORD;
        tok->subst->name= name;
        tok->subst= inc(tok->subst);
        return inc(tok);
}

typedef enum how { SUPERFICIAL, PARTIAL, FULL, EXPLODE, IMPLODE } how_t;

cell_t *explode(cell_t *p, how_t how);

cell_t *get_string(cell_t **pp)
/* Get a string: A series of letters and substs.  Special tokens '=', '+', '-'
 * and '*' are also recognized if on their own.  A finished string is "exploded"
 * to a word if it consists of letters only.
 */
{
        cell_t *p= *pp, *s= nil, **ps= &s;
        int quoted= 0;

        while (p != nil) {
                switch (p->type) {
                case STRING:
                        quoted= 1;
                        dec(p);
                        break;
                case EQUALS:
                case PLUS:
                case MINUS:
                case STAR:
                case SUBST:
                case LETTER:
                        *ps= cons(STRING, p);
                        ps= &(*ps)->cdr;
                        break;
                default:
                        goto got_string;
                }
                p= get_token();
        }
    got_string:
        *pp= p;

        /* A single special token must be folded up. */
        if (!quoted && s != nil && s->cdr == nil) {
                switch (s->car->type) {
                case EQUALS:
                case PLUS:
                case MINUS:
                case STAR:
                case SUBST:
                        return go(s, s->car);
                }
        }

        /* Go over the string changing '=', '+', '-', '*' to letters. */
        for (p= s; p != nil; p= p->cdr) {
                int c= 0;

                switch (p->car->type) {
                case EQUALS:
                        c= '='; break;
                case PLUS:
                        c= '+'; break;
                case MINUS:
                        c= '-'; break;
                case STAR:
                        c= '*'; break;
                }
                if (c != 0) {
                        dec(p->car);
                        p->car= newcell();
                        p->car->type= LETTER;
                        p->car->letter= c;
                        p->car= inc(p->car);
                }
        }
        return explode(s, SUPERFICIAL);
}

cell_t *get_list(cell_t **pp, type_t stop)
/* Read a series of tokens upto a token of type "stop". */
{
        cell_t *p= *pp, *l= nil, **pl= &l;

        while (p != nil && p->type != stop
                                && !(stop == EOLN && p->type == SEMI)) {
                switch (p->type) {
                case WHITE:
                case COMMENT:
                case SEMI:
                case EOLN:
                        dec(p);
                        p= get_token();
                        break;
                case OPEN:
                        /* '(' words ')'. */
                        dec(p);
                        p= get_token();
                        *pl= cons(CELL, get_list(&p, CLOSE));
                        pl= &(*pl)->cdr;
                        dec(p);
                        p= get_token();
                        break;
                case CLOSE:
                        /* Unexpected closing parenthesis. (*/
                        fprintf(stderr, "\"%s\", line %u: unmatched ')'\n",
                                descr, lineno);
                        action= 0;
                        dec(p);
                        p= get_token();
                        break;
                case INPUT:
                case OUTPUT:
                        *pl= cons(CELL, p);
                        pl= &(*pl)->cdr;
                        p= get_token();
                        break;
                case STRING:
                case EQUALS:
                case PLUS:
                case MINUS:
                case STAR:
                case LETTER:
                case SUBST:
                        *pl= cons(CELL, get_string(&p));
                        pl= &(*pl)->cdr;
                        break;
                default:
                        assert(0);
                }
        }

        if (p == nil && stop == CLOSE) {
                /* Couldn't get the closing parenthesis. */
                fprintf(stderr, "\"%s\", lines %u-%u: unmatched '('\n", /*)*/
                        descr, pc->lineno, lineno);
                action= 0;
        }
        *pp= p;
        return l;
}

program_t *get_line(cell_t *file)
{
        program_t *l;
        cell_t *p;
        static keep_indent= 0;
        static unsigned old_indent= 0;

        /* Skip leading whitespace to determine the indentation level. */
        indent= 0;
        while ((p= get_token()) != nil && p->type == WHITE) dec(p);

        if (p == nil) return nil;               /* EOF */

        if (p->type == EOLN) indent= old_indent;        /* Empty line. */

        /* Make a program line. */
        pc= l= allocate(nil, sizeof(*l));

        l->next= nil;
        l->file= inc(file);
        l->indent= keep_indent ? old_indent : indent;
        l->lineno= lineno;

        l->line= get_list(&p, EOLN);

        /* If the line ended in a semicolon then keep the indentation level. */
        keep_indent= (p != nil && p->type == SEMI);
        old_indent= l->indent;

        dec(p);

        if (verbose >= 4) {
                if (l->line == nil)
                        fputc('\n', stdout);
                else {
                        printf("%*s", (int) l->indent, "");
                        prin2n(l->line);
                }
        }
        return l;
}

program_t *get_prog(void)
/* Read the description file into core. */
{
        cell_t *file;
        program_t *prog, **ppg= &prog;

        descr= copystr(descr);

        if (descr[0] == '-' && descr[1] == 0) {
                /* -descr -: Read from standard input. */
                deallocate(descr);
                descr= copystr("stdin");
                dfp= stdin;
        } else {
                char *d= descr;

                if (*d == '.' && *++d == '.') d++;
                if (*d != '/') {
                        /* -descr name: Read /usr/lib/<name>/descr. */

                        d= allocate(nil, sizeof(LIB) +
                                        (strlen(descr) + 7) * sizeof(*d));
                        sprintf(d, "%s/%s/descr", LIB, descr);
                        deallocate(descr);
                        descr= d;
                }
                if ((dfp= fopen(descr, "r")) == nil) fatal(descr);
        }
        file= findword(descr);
        deallocate(descr);
        descr= file->name;

        /* Preread the first character. */
        dch= 0;
        lineno= 1;
        indent= 0;
        getdesc();

        while ((*ppg= get_line(file)) != nil) ppg= &(*ppg)->next;

        if (dfp != stdin) (void) fclose(dfp);
        dec(file);

        return prog;
}

void makenames(cell_t ***ppr, cell_t *s, char **name, size_t i, size_t *n)
/* Turn a string of letters and lists into words.  A list denotes a choice
 * between several paths, like a search on $PATH.
 */
{
        cell_t *p, *q;
        size_t len;

        /* Simply add letters, skip empty lists. */
        while (s != nil && (s->car == nil || s->car->type == LETTER)) {
                if (s->car != nil) {
                        if (i == *n) *name= allocate(*name,
                                                (*n *= 2) * sizeof(**name));
                        (*name)[i++]= s->car->letter;
                }
                s= s->cdr;
        }

        /* If the end is reached then make a word out of the result. */
        if (s == nil) {
                **ppr= cons(CELL, findnword(*name, i));
                *ppr= &(**ppr)->cdr;
                return;
        }

        /* Elements of a list must be tried one by one. */
        p= s->car;
        s= s->cdr;

        while (p != nil) {
                if (p->type == WORD) {
                        q= p; p= nil;
                } else {
                        assert(p->type == CELL);
                        q= p->car; p= p->cdr;
                        assert(q != nil);
                        assert(q->type == WORD);
                }
                len= strlen(q->name);
                if (i + len > *n) *name= allocate(*name,
                                        (*n += i + len) * sizeof(**name));
                memcpy(*name + i, q->name, len);

                makenames(ppr, s, name, i+len, n);
        }
}

int constant(cell_t *p)
/* See if a string has been partially evaluated to a constant so that it
 * can be imploded to a word.
 */
{
        while (p != nil) {
                switch (p->type) {
                case CELL:
                case STRING:
                        if (!constant(p->car)) return 0;
                        p= p->cdr;
                        break;
                case SUBST:
                        return 0;
                default:
                        return 1;
                }
        }
        return 1;
}

cell_t *evaluate(cell_t *p, how_t how);

cell_t *explode(cell_t *s, how_t how)
/* Explode a string with several choices to just one list of choices. */
{
        cell_t *t, *r= nil, **pr= &r;
        size_t i, n;
        char *name;
        struct stat st;

        if (how >= PARTIAL) {
                /* Evaluate the string, expanding substitutions. */
                while (s != nil) {
                        assert(s->type == STRING);
                        t= inc(s->car);
                        s= go(s, s->cdr);

                        t= evaluate(t, how == IMPLODE ? EXPLODE : how);

                        /* A list of one element becomes that element. */
                        if (t != nil && t->type == CELL && t->cdr == nil)
                                t= go(t, t->car);

                        /* Append the result, trying to flatten it. */
                        *pr= t;

                        /* Find the end of what has just been added. */
                        while ((*pr) != nil) {
                                *pr= append(STRING, *pr);
                                pr= &(*pr)->cdr;
                        }
                }
                s= r;
        }

        /* Is the result a simple string of constants? */
        if (how <= PARTIAL && !constant(s)) return s;

        /* Explode the string to all possible choices, by now the string is
         * a series of characters, words and lists of words.
         */
        r= nil; pr= &r;
        name= allocate(nil, (n= 16) * sizeof(char));
        i= 0;

        makenames(&pr, s, &name, i, &n);
        deallocate(name);
        assert(r != nil);
        dec(s);
        s= r;

        /* "How" may specify that a choice must be made. */
        if (how == IMPLODE) {
                if (s->cdr != nil) {
                        /* More than one choice, find the file. */
                        do {
                                assert(s->car->type == WORD);
                                if (stat(s->car->name, &st) >= 0)
                                        return go(r, s->car);   /* Found. */
                        } while ((s= s->cdr) != nil);
                }
                /* The first name is the default if nothing is found. */
                return go(r, r->car);
        }

        /* If the result is a list of one word then return that word, otherwise
         * turn it into a string again unless this explode has been called
         * by another explode.  (Exploding a string inside a string, the joys
         * of recursion.)
         */
        if (s->cdr == nil) return go(s, s->car);

        return how >= EXPLODE ? s : cons(STRING, s);
}

void modify(cell_t **pp, cell_t *p, type_t mode)
/* Add or remove the element p from the list *pp. */
{
        while (*pp != nil) {
                *pp= append(CELL, *pp);

                if ((*pp)->car == p) {
                        /* Found it, if adding then exit, else remove. */
                        if (mode == PLUS) break;
                        *pp= go(*pp, (*pp)->cdr);
                } else
                        pp= &(*pp)->cdr;
        }

        if (*pp == nil && mode == PLUS) {
                /* Not found, add it. */
                *pp= cons(CELL, p);
        } else
                dec(p);
}

int tainted(cell_t *p)
/* A variable is tainted (must be substituted) if either it is marked as a
 * local variable, or some subst in its value is.
 */
{
        if (p == nil) return 0;

        switch (p->type) {
        case CELL:
        case STRING:
                return tainted(p->car) || tainted(p->cdr);
        case SUBST:
                return p->subst->flags & W_LOCAL || tainted(p->subst->value);
        default:
                return 0;
        }
}

cell_t *evaluate(cell_t *p, how_t how)
/* Evaluate an expression, usually the right hand side of an assignment. */
{
        cell_t *q, *t, *r= nil, **pr= &r;
        type_t mode;

        if (p == nil) return nil;

        switch (p->type) {
        case CELL:
                break;  /* see below */
        case STRING:
                return explode(p, how);
        case SUBST:
                if (how >= FULL || tainted(p))
                        p= evaluate(go(p, p->subst->value), how);
                return p;
        case EQUALS:
                fprintf(stderr,
                        "\"%s\", line %u: Can't do nested assignments\n",
                        descr, pc->lineno);
                action= 0;
                dec(p);
                return nil;
        case LETTER:
        case WORD:
        case INPUT:
        case OUTPUT:
        case PLUS:
        case MINUS:
                return p;
        default:
                assert(0);
        }

        /* It's a list, see if there is a '*' there forcing a full expansion,
         * or a '+' or '-' forcing an implosive expansion.  (Yeah, right.)
         * Otherwise evaluate each element.
         */
        q = inc(p);
        while (p != nil) {
                if ((t= p->car) != nil) {
                        if (t->type == STAR) {
                                if (how < FULL) how= FULL;
                                dec(q);
                                *pr= evaluate(go(p, p->cdr), how);
                                return r;
                        }
                        if (how>=FULL && (t->type == PLUS || t->type == MINUS))
                                break;
                }

                t= evaluate(inc(t), how);
                assert(p->type == CELL);
                p= go(p, p->cdr);

                if (how >= FULL) {
                        /* Flatten the list. */
                        *pr= t;
                } else {
                        /* Keep the nested list structure. */
                        *pr= cons(CELL, t);
                }

                /* Find the end of what has just been added. */
                while ((*pr) != nil) {
                        *pr= append(CELL, *pr);
                        pr= &(*pr)->cdr;
                }
        }

        if (p == nil) {
                /* No PLUS or MINUS: done. */
                dec(q);
                return r;
        }

        /* A PLUS or MINUS, reevaluate the original list implosively. */
        if (how < IMPLODE) {
                dec(r);
                dec(p);
                return evaluate(q, IMPLODE);
        }
        dec(q);

        /* Execute the PLUSes and MINUSes. */
        while (p != nil) {
                t= inc(p->car);
                p= go(p, p->cdr);

                if (t != nil && (t->type == PLUS || t->type == MINUS)) {
                        /* Change the add/subtract mode. */
                        mode= t->type;
                        dec(t);
                        continue;
                }

                t= evaluate(t, IMPLODE);

                /* Add or remove all elements of t to/from r. */
                while (t != nil) {
                        if (t->type == CELL) {
                                modify(&r, inc(t->car), mode);
                        } else {
                                modify(&r, t, mode);
                                break;
                        }
                        t= go(t, t->cdr);
                }
        }
        return r;
}

/* An ACD program can be in three phases: Initialization (the first run
 * of the program), argument scanning, and compilation.
 */
typedef enum phase { INIT, SCAN, COMPILE } phase_t;

phase_t phase;

typedef struct rule {           /* Transformation rule. */
        struct rule     *next;
        char            type;           /* arg, transform, combine */
        char            flags;
        unsigned short  npaths;         /* Number of paths running through. */
#       define  match   from            /* Arg matching strings. */
        cell_t          *from;          /* Transformation source suffixe(s) */
        cell_t          *to;            /* Destination suffix. */
        cell_t          *wait;          /* Files waiting to be transformed. */
        program_t       *prog;          /* Program to execute. */
        struct rule     *path;          /* Transformation path. */
} rule_t;

typedef enum ruletype { ARG, PREFER, TRANSFORM, COMBINE } ruletype_t;

#define R_PREFER        0x01            /* A preferred transformation. */

rule_t *rules= nil;

void newrule(ruletype_t type, cell_t *from, cell_t *to)
/* Make a new rule cell. */
{
        rule_t *r= nil, **pr= &rules;

        /* See if there is a rule with the same suffixes, probably a matching
         * transform and prefer, or a re-execution of the same arg command.
         */
        while ((r= *pr) != nil) {
                if (r->from == from && r->to == to) break;
                pr= &r->next;
        }

        if (*pr == nil) {
                /* Add a new rule. */
                *pr= r= allocate(nil, sizeof(*r));

                r->next= nil;
                r->type= type;
                r->flags= 0;
                r->from= r->to= r->wait= nil;
                r->path= nil;
        }
        if (type == TRANSFORM) r->type= TRANSFORM;
        if (type == PREFER) r->flags|= R_PREFER;
        if (type != PREFER) r->prog= pc;
        dec(r->from); r->from= from;
        dec(r->to); r->to= to;
}

int talk(void)
/* True if verbose and if so indent what is to come. */
{
        if (verbose < 3) return 0;
        printf("%*s", (int) pc->indent, "");
        return 1;
}

void unix_exec(cell_t *c)
/* Execute the list of words p as a UNIX command. */
{
        cell_t *v, *a;
        int fd[2];
        int *pf;
        char **argv;
        int i, n;
        int r, pid, status;

        if (action == 0) return;        /* Error mode. */

        if (talk() || verbose >= 2) prin2n(c);

        fd[0]= fd[1]= -1;

        argv= allocate(nil, (n= 16) * sizeof(*argv));
        i= 0;

        /* Gather argv[] and scan for I/O redirection. */
        for (v= c; v != nil; v= v->cdr) {
                a= v->car;
                pf= nil;
                if (a->type == INPUT) pf= &fd[0];
                if (a->type == OUTPUT) pf= &fd[1];

                if (pf == nil) {
                        /* An argument. */
                        argv[i++]= a->name;
                        if (i==n) argv= allocate(argv, (n*= 2) * sizeof(*argv));
                        continue;
                }
                /* I/O redirection. */
                if ((v= v->cdr) == nil || (a= v->car)->type != WORD) {
                        fprintf(stderr,
                        "\"%s\", line %u: I/O redirection without a file\n",
                                descr, pc->lineno);
                        action= 0;
                        if (v == nil) break;
                }
                if (*pf >= 0) close(*pf);

                if (action >= 2
                        && (*pf= open(a->name, pf == &fd[0] ? O_RDONLY
                                : O_WRONLY | O_CREAT | O_TRUNC, 0666)) < 0
                ) {
                        report(a->name);
                        action= 0;
                }
        }
        argv[i]= nil;

        if (i >= 0 && action > 0 && verbose == 1) {
                char *name= strrchr(argv[0], '/');

                if (name == nil) name= argv[0]; else name++;

                printf("%s\n", name);
        }
        if (i >= 0 && action >= 2) {
                /* Really execute the command. */
                fflush(stdout);
                switch (pid= fork()) {
                case -1:
                        fatal("fork()");
                case 0:
                        if (fd[0] >= 0) { dup2(fd[0], 0); close(fd[0]); }
                        if (fd[1] >= 0) { dup2(fd[1], 1); close(fd[1]); }
                        execvp(argv[0], argv);
                        report(argv[0]);
                        exit(-1);
                }
        }
        if (fd[0] >= 0) close(fd[0]);
        if (fd[1] >= 0) close(fd[1]);

        if (i >= 0 && action >= 2) {
                /* Wait for the command to terminate. */
                while ((r= wait(&status)) != pid && (r >= 0 || errno == EINTR));

                if (status != 0) {
                        int sig= WTERMSIG(status);

                        if (!WIFEXITED(status)
                                        && sig != SIGINT && sig != SIGPIPE) {
                                fprintf(stderr, "%s: %s: Signal %d%s\n",
                                        program, argv[0], sig,
                                        status & 0x80 ? " - core dumped" : "");
                        }
                        action= 0;
                }
        }
        deallocate(argv);
}

/* Special read-only variables ($*) and lists. */
cell_t *V_star, **pV_star;
cell_t *L_files, **pL_files= &L_files;
cell_t *V_in, *V_out, *V_stop, *L_args, *L_predef;

typedef enum exec { DOIT, DONT } exec_t;

void execute(exec_t how, unsigned indent);

int equal(cell_t *p, cell_t *q)
/* Two lists are equal if they contain each others elements. */
{
        cell_t *t, *m1, *m2;

        t= inc(newcell());
        t->cdr= inc(newcell());
        t->cdr->cdr= inc(newcell());
        t->cdr->car= newcell();
        t->cdr->car->type= MINUS;
        t->cdr->car= inc(t->cdr->car);

        /* Compute p - q. */
        t->car= inc(p);
        t->cdr->cdr->car= inc(q);
        m1= evaluate(inc(t), IMPLODE);
        dec(m1);

        /* Compute q - p. */
        t->car= q;
        t->cdr->cdr->car= p;
        m2= evaluate(t, IMPLODE);
        dec(m2);

        /* Both results must be empty. */
        return m1 == nil && m2 == nil;
}

int wordlist(cell_t **pw, int atom)
/* Check if p is a list of words, typically an imploded list.  Return
 * the number of words seen, -1 if they are not words (INPUT/OUTPUT?).
 * If atom is true than a list of one word is turned into a word.
 */
{
        int n= 0;
        cell_t *p, **pp= pw;

        while (*pp != nil) {
                *pp= append(CELL, *pp);
                p= (*pp)->car;
                n= n >= 0 && p != nil && p->type == WORD ? n+1 : -1;
                pp= &(*pp)->cdr;
        }
        if (atom && n == 1) *pw= go(*pw, (*pw)->car);
        return n;
}

char *template;         /* Current name of a temporary file. */
static char *tp;        /* Current place withing the tempfile. */

char *maketemp(void)
/* Return a name that can be used as a temporary filename. */
{
        int i= 0;

        if (tp == nil) {
                size_t len= strlen(template);

                template= allocate(template, (len+20) * sizeof(*template));
                sprintf(template+len, "/acd%d", getpid());
                tp= template + strlen(template);
        }

        for (;;) {
                switch (tp[i]) {
                case 0:         tp[i]= 'a';
                                tp[i+1]= 0;     return template;
                case 'z':       tp[i++]= 'a';   break;
                default:        tp[i]++;        return template;
                }
        }
}

void inittemp(char *tmpdir)
/* Initialize the temporary filename generator. */
{
        template= allocate(nil, (strlen(tmpdir)+20) * sizeof(*template));
        sprintf(template, "%s/acd%d", tmpdir, getpid());
        tp= template + strlen(template);

        /* Create a directory within tempdir that we can safely play in. */
        while (action != 1 && mkdir(template, 0700) < 0) {
                if (errno == EEXIST) {
                        (void) maketemp();
                } else {
                        report(template);
                        action= 0;
                }
        }
        if (verbose >= 2) printf("mkdir %s\n", template);
        while (*tp != 0) tp++;
        *tp++= '/';
        *tp= 0;
}

void deltemp(void)
/* Remove our temporary temporaries directory. */
{
        while (*--tp != '/') {}
        *tp = 0;
        if (rmdir(template) < 0 && errno != ENOENT) report(template);
        if (verbose >= 2) printf("rmdir %s\n", template);
        deallocate(template);
}

cell_t *splitenv(char *env)
/* Split a string from the environment into several words at whitespace
 * and colons.  Two colons (::) become a dot.
 */
{
        cell_t *r= nil, **pr= &r;
        char *p;

        do {
                while (*env != 0 && isspace(*env)) env++;

                if (*env == 0) break;

                p= env;
                while (*p != 0 && !isspace(*p) && *p != ':') p++;

                *pr= cons(CELL,
                        p == env ? findword(".") : findnword(env, p-env));
                pr= &(*pr)->cdr;
                env= p;
        } while (*env++ != 0);
        return r;
}

void key_usage(char *how)
{
        fprintf(stderr, "\"%s\", line %u: Usage: %s %s\n",
                descr, pc->lineno, pc->line->car->name, how);
        action= 0;
}

void inappropriate(void)
{
        fprintf(stderr, "\"%s\", line %u: wrong execution phase for '%s'\n",
                descr, pc->lineno, pc->line->car->name);
        action= 0;
}

int readonly(cell_t *v)
{
        if (v->flags & W_RDONLY) {
                fprintf(stderr, "\"%s\", line %u: %s is read-only\n",
                        descr, pc->lineno, v->name);
                action= 0;
                return 1;
        }
        return 0;
}

void complain(cell_t *err)
/* acd: err ... */
{
        cell_t *w;

        fprintf(stderr, "%s:", program);

        while (err != nil) {
                if (err->type == CELL) {
                        w= err->car; err= err->cdr;
                } else {
                        w= err; err= nil;
                }
                fprintf(stderr, " %s", w->name);
        }
        action= 0;
}

int keyword(char *name)
/* True if the current line is headed by the given keyword. */
{
        cell_t *t;

        return (t= pc->line) != nil && t->type == CELL
                && (t= t->car) != nil && t->type == WORD
                && strcmp(t->name, name) == 0;
}

cell_t *getvar(cell_t *v)
/* Return a word or the word referenced by a subst. */
{
        if (v == nil) return nil;
        if (v->type == WORD) return v;
        if (v->type == SUBST) return v->subst;
        return nil;
}

void argscan(void), compile(void);
void transform(rule_t *);

void exec_one(void)
/* Execute one line of the program. */
{
        cell_t *v, *p, *q, *r, *t;
        unsigned n= 0;
        static int last_if= 1;

        /* Description file this line came from. */
        descr= pc->file->name;

        for (p= pc->line; p != nil; p= p->cdr) n++;

        if (n == 0) return;     /* Null statement. */

        p= pc->line;
        q= p->cdr;
        r= q == nil ? nil : q->cdr;

        /* Try one by one all the different commands. */

        if (n >= 2 && q->car != nil && q->car->type == EQUALS) {
                /* An assignment. */
                int flags;

                if ((v= getvar(p->car)) == nil) {
                        fprintf(stderr,
                                "\"%s\", line %u: Usage: <var> = expr ...\n",
                                descr, pc->lineno);
                        action= 0;
                        return;
                }

                if (readonly(v)) return;

                flags= v->flags;
                v->flags|= W_LOCAL|W_RDONLY;
                t= evaluate(inc(r), PARTIAL);
                dec(v->value);
                v->value= t;
                v->flags= flags | W_SET;
                if (talk()) {
                        printf("%s =\b=\b= ", v->name);
                        prin2n(t);
                }
        } else
        if (keyword("unset")) {
                /* Set a variable to "undefined". */

                if (n != 2 || (v= getvar(q->car)) == nil) {
                        key_usage("<var>");
                        return;
                }
                if (readonly(v)) return;

                if (talk()) prin2n(p);

                dec(v->value);
                v->value= nil;
                v->flags&= ~W_SET;
        } else
        if (keyword("import")) {
                /* Import a variable from the UNIX environment. */
                char *env;

                if (n != 2 || (v= getvar(q->car)) == nil) {
                        key_usage("<var>");
                        return;
                }
                if (readonly(v)) return;

                if ((env= getenv(v->name)) == nil) return;

                if (talk()) printf("import %s=%s\n", v->name, env);

                t= splitenv(env);
                dec(v->value);
                v->value= t;
                v->flags|= W_SET;
        } else
        if (keyword("mktemp")) {
                /* Assign a variable the name of a temporary file. */
                char *tmp, *suff;

                r= evaluate(inc(r), IMPLODE);
                if (n == 3 && wordlist(&r, 1) != 1) n= 0;

                if ((n != 2 && n != 3) || (v= getvar(q->car)) == nil) {
                        dec(r);
                        key_usage("<var> [<suffix>]");
                        return;
                }
                if (readonly(v)) { dec(r); return; }

                tmp= maketemp();
                suff= r == nil ? "" : r->name;

                t= newcell();
                t->type= WORD;
                t->name= allocate(nil,
                        (strlen(tmp) + strlen(suff) + 1) * sizeof(*t->name));
                strcpy(t->name, tmp);
                strcat(t->name, suff);
                t= inc(t);
                dec(r);
                dec(v->value);
                v->value= t;
                v->flags|= W_SET;
                t->flags|= W_TEMP;
                if (talk()) printf("mktemp %s=%s\n", v->name, t->name);
        } else
        if (keyword("temporary")) {
                /* Mark a word as a temporary file. */
                cell_t *tmp;

                tmp= evaluate(inc(q), IMPLODE);

                if (wordlist(&tmp, 1) < 0) {
                        dec(tmp);
                        key_usage("<word>");
                        return;
                }
                if (talk()) printf("temporary %s\n", tmp->name);

                tmp->flags|= W_TEMP;
                dec(tmp);
        } else
        if (keyword("stop")) {
                /* Set the suffix to stop the transformation on. */
                cell_t *suff;

                if (phase > SCAN) { inappropriate(); return; }

                suff= evaluate(inc(q), IMPLODE);

                if (wordlist(&suff, 1) != 1) {
                        dec(suff);
                        key_usage("<suffix>");
                        return;
                }
                dec(V_stop);
                V_stop= suff;
                if (talk()) printf("stop %s\n", suff->name);
        } else
        if (keyword("numeric")) {
                /* Check if a string denotes a number, like $n in -O$n. */
                cell_t *num;
                char *pn;

                num= evaluate(inc(q), IMPLODE);

                if (wordlist(&num, 1) != 1) {
                        dec(num);
                        key_usage("<arg>");
                        return;
                }
                if (talk()) printf("numeric %s\n", num->name);

                (void) strtoul(num->name, &pn, 10);
                if (*pn != 0) {
                        complain(phase == SCAN ? V_star->value : nil);
                        if (phase == SCAN) fputc(':', stderr);
                        fprintf(stderr, " '%s' is not a number\n", num->name);
                }
                dec(num);
        } else
        if (keyword("error")) {
                /* Signal an error. */
                cell_t *err;

                err= evaluate(inc(q), IMPLODE);

                if (wordlist(&err, 0) < 1) {
                        dec(err);
                        key_usage("expr ...");
                        return;
                }

                if (talk()) { printf("error "); prin2n(err); }

                complain(err);
                fputc('\n', stderr);
                dec(err);
        } else
        if (keyword("if")) {
                /* if (list) = (list) using set comparison. */
                int eq;

                if (n != 4 || r->car == nil || r->car->type != EQUALS) {
                        key_usage("<expr> = <expr>");
                        execute(DONT, pc->indent+1);
                        last_if= 1;
                        return;
                }
                q= q->car;
                r= r->cdr->car;
                if (talk()) {
                        printf("if ");
                        prin1(t= evaluate(inc(q), IMPLODE));
                        dec(t);
                        printf(" = ");
                        prin1n(t= evaluate(inc(r), IMPLODE));
                        dec(t);
                }
                eq= equal(q, r);
                execute(eq ? DOIT : DONT, pc->indent+1);
                last_if= eq;
        } else
        if (keyword("ifdef") || keyword("ifndef")) {
                /* Is a variable defined or undefined? */
                int doit;

                if (n != 2 || (v= getvar(q->car)) == nil) {
                        key_usage("<var>");
                        execute(DONT, pc->indent+1);
                        last_if= 1;
                        return;
                }
                if (talk()) prin2n(p);

                doit= ((v->flags & W_SET) != 0) ^ (p->car->name[2] == 'n');
                execute(doit ? DOIT : DONT, pc->indent+1);
                last_if= doit;
        } else
        if (keyword("iftemp") || keyword("ifhash")) {
                /* Is a file a temporary file? */
                /* Does a file need preprocessing? */
                cell_t *file;
                int doit= 0;

                file= evaluate(inc(q), IMPLODE);

                if (wordlist(&file, 1) != 1) {
                        dec(file);
                        key_usage("<arg>");
                        return;
                }
                if (talk()) printf("%s %s\n", p->car->name, file->name);

                if (p->car->name[2] == 't') {
                        /* iftemp file */
                        if (file->flags & W_TEMP) doit= 1;
                } else {
                        /* ifhash file */
                        int fd;
                        char hash;

                        if ((fd= open(file->name, O_RDONLY)) >= 0) {
                                if (read(fd, &hash, 1) == 1 && hash == '#')
                                        doit= 1;
                                close(fd);
                        }
                }
                dec(file);

                execute(doit ? DOIT : DONT, pc->indent+1);
                last_if= doit;
        } else
        if (keyword("else")) {
                /* Else clause for an if, ifdef, or ifndef. */
                if (n != 1) {
                        key_usage("");
                        execute(DONT, pc->indent+1);
                        return;
                }
                if (talk()) prin2n(p);

                execute(!last_if ? DOIT : DONT, pc->indent+1);
        } else
        if (keyword("treat")) {
                /* Treat a file as having a certain suffix. */

                if (phase > SCAN) { inappropriate(); return; }

                if (n == 3) {
                        q= evaluate(inc(q->car), IMPLODE);
                        r= evaluate(inc(r->car), IMPLODE);
                }
                if (n != 3 || wordlist(&q, 1) != 1 || wordlist(&r, 1) != 1) {
                        if (n == 3) { dec(q); dec(r); }
                        key_usage("<file> <suffix>");
                        return;
                }
                if (talk()) printf("treat %s %s\n", q->name, r->name);

                dec(q->suffix);
                q->suffix= r;
                q->flags|= W_SUFF;
                dec(q);
        } else
        if (keyword("apply")) {
                /* Apply a transformation rule to the current input file. */
                rule_t *rule, *sav_path;
                cell_t *sav_wait, *sav_in, *sav_out;
                program_t *sav_next;

                if (phase != COMPILE) { inappropriate(); return; }

                if (V_star->value->cdr != nil) {
                        fprintf(stderr, "\"%s\", line %u: $* is not one file\n",
                                descr, pc->lineno);
                        action= 0;
                        return;
                }
                if (n == 3) {
                        q= evaluate(inc(q->car), IMPLODE);
                        r= evaluate(inc(r->car), IMPLODE);
                }
                if (n != 3 || wordlist(&q, 1) != 1 || wordlist(&r, 1) != 1) {
                        if (n == 3) { dec(q); dec(r); }
                        key_usage("<file> <suffix>");
                        return;
                }
                if (talk()) printf("apply %s %s\n", q->name, r->name);

                /* Find a rule */
                for (rule= rules; rule != nil; rule= rule->next) {
                        if (rule->type == TRANSFORM
                                && rule->from == q && rule->to == r) break;
                }
                if (rule == nil) {
                        fprintf(stderr,
                                "\"%s\", line %u: no %s %s transformation\n",
                                descr, pc->lineno, q->name, r->name);
                        action= 0;
                }
                dec(q);
                dec(r);
                if (rule == nil) return;

                /* Save the world. */
                sav_path= rule->path;
                sav_wait= rule->wait;
                sav_in= V_in->value;
                sav_out= V_out->value;
                sav_next= nextpc;

                /* Isolate the rule and give it new input. */
                rule->path= rule;
                rule->wait= V_star->value;
                V_star->value= nil;
                V_in->value= nil;
                V_out->value= nil;

                transform(rule);

                /* Retrieve the new $* and repair. */
                V_star->value= rule->wait;
                rule->path= sav_path;
                rule->wait= sav_wait;
                V_in->value= sav_in;
                V_out->value= sav_out;
                V_out->flags= W_SET|W_LOCAL;
                nextpc= sav_next;
        } else
        if (keyword("include")) {
                /* Include another description file into this program. */
                cell_t *file;
                program_t *incl, *prog, **ppg= &prog;

                file= evaluate(inc(q), IMPLODE);

                if (wordlist(&file, 1) != 1) {
                        dec(file);
                        key_usage("<file>");
                        return;
                }
                if (talk()) printf("include %s\n", file->name);
                descr= file->name;
                incl= pc;
                prog= get_prog();
                dec(file);

                /* Raise the program to the include's indent level. */
                while (*ppg != nil) {
                        (*ppg)->indent += incl->indent;
                        ppg= &(*ppg)->next;
                }

                /* Kill the include and splice the included program in. */
                dec(incl->line);
                incl->line= nil;
                *ppg= incl->next;
                incl->next= prog;
                pc= incl;
                nextpc= prog;
        } else
        if (keyword("arg")) {
                /* An argument scanning rule. */

                if (phase > SCAN) { inappropriate(); return; }

                if (n < 2) {
                        key_usage("<string> ...");
                        execute(DONT, pc->indent+1);
                        return;
                }
                if (talk()) prin2n(p);

                newrule(ARG, inc(q), nil);

                /* Always skip the body, it comes later. */
                execute(DONT, pc->indent+1);
        } else
        if (keyword("transform")) {
                /* A file transformation rule. */

                if (phase > SCAN) { inappropriate(); return; }

                if (n == 3) {
                        q= evaluate(inc(q->car), IMPLODE);
                        r= evaluate(inc(r->car), IMPLODE);
                }
                if (n != 3 || wordlist(&q, 1) != 1 || wordlist(&r, 1) != 1) {
                        if (n == 3) { dec(q); dec(r); }
                        key_usage("<suffix1> <suffix2>");
                        execute(DONT, pc->indent+1);
                        return;
                }
                if (talk()) printf("transform %s %s\n", q->name, r->name);

                newrule(TRANSFORM, q, r);

                /* Body comes later. */
                execute(DONT, pc->indent+1);
        } else
        if (keyword("prefer")) {
                /* Prefer a transformation over others. */

                if (phase > SCAN) { inappropriate(); return; }

                if (n == 3) {
                        q= evaluate(inc(q->car), IMPLODE);
                        r= evaluate(inc(r->car), IMPLODE);
                }
                if (n != 3 || wordlist(&q, 1) != 1 || wordlist(&r, 1) != 1) {
                        if (n == 3) { dec(q); dec(r); }
                        key_usage("<suffix1> <suffix2>");
                        return;
                }
                if (talk()) printf("prefer %s %s\n", q->name, r->name);

                newrule(PREFER, q, r);
        } else
        if (keyword("combine")) {
                /* A file combination (loader) rule. */

                if (phase > SCAN) { inappropriate(); return; }

                if (n == 3) {
                        q= evaluate(inc(q->car), IMPLODE);
                        r= evaluate(inc(r->car), IMPLODE);
                }
                if (n != 3 || wordlist(&q, 0) < 1 || wordlist(&r, 1) != 1) {
                        if (n == 3) { dec(q); dec(r); }
                        key_usage("<suffix-list> <suffix>");
                        execute(DONT, pc->indent+1);
                        return;
                }
                if (talk()) {
                        printf("combine ");
                        prin1(q);
                        printf(" %s\n", r->name);
                }

                newrule(COMBINE, q, r);

                /* Body comes later. */
                execute(DONT, pc->indent+1);
        } else
        if (keyword("scan") || keyword("compile")) {
                program_t *next= nextpc;

                if (n != 1) { key_usage(""); return; }
                if (phase != INIT) { inappropriate(); return; }

                if (talk()) prin2n(p);

                argscan();
                if (p->car->name[0] == 'c') compile();
                nextpc= next;
        } else {
                /* A UNIX command. */
                t= evaluate(inc(pc->line), IMPLODE);
                unix_exec(t);
                dec(t);
        }
}

void execute(exec_t how, unsigned indent)
/* Execute (or skip) all lines with at least the given indent. */
{
        int work= 0;    /* Need to execute at least one line. */
        unsigned firstline;
        unsigned nice_indent= 0;        /* 0 = Don't know what's nice yet. */

        if (pc == nil) return;  /* End of program. */

        firstline= pc->lineno;

        if (how == DONT) {
                /* Skipping a body, but is there another guard? */
                pc= pc->next;
                if (pc != nil && pc->indent < indent && pc->line != nil) {
                        /* There is one!  Bail out, then it get's executed. */
                        return;
                }
        } else {
                /* Skip lines with a lesser indentation, they are guards for
                 * the same substatements.  Don't go past empty lines.
                 */
                while (pc != nil && pc->indent < indent && pc->line != nil)
                        pc= pc->next;
        }

        /* Execute all lines with an indentation of at least "indent". */
        while (pc != nil && pc->indent >= indent) {
                if (pc->indent != nice_indent && how == DOIT) {
                        if (nice_indent != 0) {
                                fprintf(stderr,
                        "\"%s\", line %u: (warning) sudden indentation shift\n",
                                        descr, pc->lineno);
                        }
                        nice_indent= pc->indent;
                }
                nextpc= pc->next;
                if (how == DOIT) exec_one();
                pc= nextpc;
                work= 1;
        }

        if (indent > 0 && !work) {
                fprintf(stderr, "\"%s\", line %u: empty body, no statements\n",
                        descr, firstline);
                action= 0;
        }
}

int argmatch(int shift, cell_t *match, cell_t *match1, char *arg1)
/* Try to match an arg rule to the input file list L_args.  Execute the arg
 * body (pc is set to it) on success.
 */
{
        cell_t *oldval, *v;
        int m, oldflags;
        size_t i, len;
        int minus= 0;

        if (shift) {
                /* An argument has been accepted and may be shifted to $*. */
                cell_t **oldpstar= pV_star;
                *pV_star= L_args;
                L_args= *(pV_star= &L_args->cdr);
                *pV_star= nil;

                if (argmatch(0, match->cdr, nil, nil)) return 1;

                /* Undo the damage. */
                *pV_star= L_args;
                L_args= *(pV_star= oldpstar);
                *pV_star= nil;
                return 0;
        }

        if (match == nil) {
                /* A full match, execute the arg body. */

                /* Enable $>. */
                V_out->flags= W_SET|W_LOCAL;

                if (verbose >= 3) {
                        prin2(pc->line);
                        printf(" =\b=\b= ");
                        prin2n(V_star->value);
                }
                execute(DOIT, pc->indent+1);

                /* Append $> to the file list. */
                if (V_out->value != nil) {
                        *pL_files= cons(CELL, V_out->value);
                        pL_files= &(*pL_files)->cdr;
                }

                /* Disable $>. */
                V_out->value= nil;
                V_out->flags= W_SET|W_LOCAL|W_RDONLY;

                return 1;
        }

        if (L_args == nil) return 0;    /* Out of arguments to match. */

        /* Match is a list of words, substs and strings containing letters and
         * substs.  Match1 is the current element of the first element of match.
         * Arg1 is the current character of the first element of L_args.
         */
        if (match1 == nil) {
                /* match1 is at the end of a string, then arg1 must also. */
                if (arg1 != nil) {
                        if (*arg1 != 0) return 0;
                        return argmatch(1, match, nil, nil);
                }
                /* If both are nil: Initialize. */
                match1= match->car;
                arg1= L_args->car->name;

                /* A subst may not match a leading '-'. */
                if (arg1[0] == '-') minus= 1;
        }

        if (match1->type == WORD && strcmp(match1->name, arg1) == 0) {
                /* A simple match of an argument. */

                return argmatch(1, match, nil, nil);
        }

        if (match1->type == SUBST && !minus) {
                /* A simple match of a subst. */

                /* The variable gets the first of the arguments as its value. */
                v= match1->subst;
                if (v->flags & W_RDONLY) return 0;      /* ouch */
                oldflags= v->flags;
                v->flags= W_SET|W_LOCAL|W_RDONLY;
                oldval= v->value;
                v->value= inc(L_args->car);

                m= argmatch(1, match, nil, nil);

                /* Recover the value of the variable. */
                dec(v->value);
                v->flags= oldflags;
                v->value= oldval;
                return m;
        }
        if (match1->type != STRING) return 0;

        /* Match the first item in the string. */
        if (match1->car == nil) return 0;

        if (match1->car->type == LETTER
                        && match1->car->letter == (unsigned char) *arg1) {
                /* A letter matches, try the rest of the string. */

                return argmatch(0, match, match1->cdr, arg1+1);
        }

        /* It can only be a subst in a string now. */
        len= strlen(arg1);
        if (match1->car->type != SUBST || minus || len == 0) return 0;

        /* The variable can match from 1 character to all of the argument.
         * Matching as few characters as possible happens to be the Right Thing.
         */
        v= match1->car->subst;
        if (v->flags & W_RDONLY) return 0;      /* ouch */
        oldflags= v->flags;
        v->flags= W_SET|W_LOCAL|W_RDONLY;
        oldval= v->value;

        m= 0;
        for (i= match1->cdr == nil ? len : 1; !m && i <= len; i++) {
                v->value= findnword(arg1, i);

                m= argmatch(0, match, match1->cdr, arg1+i);

                dec(v->value);
        }
        /* Recover the value of the variable. */
        v->flags= oldflags;
        v->value= oldval;
        return m;
}

void argscan(void)
/* Match all the arguments to the arg rules, those that don't match are
 * used as files for transformation.
 */
{
        rule_t *rule;
        int m;

        phase= SCAN;

        /* Process all the arguments. */
        while (L_args != nil) {
                pV_star= &V_star->value;

                /* Try all the arg rules. */
                m= 0;
                for (rule= rules; !m && rule != nil; rule= rule->next) {
                        if (rule->type != ARG) continue;

                        pc= rule->prog;

                        m= argmatch(0, rule->match, nil, nil);
                }
                dec(V_star->value);
                V_star->value= nil;

                /* On failure, add the first argument to the list of files. */
                if (!m) {
                        *pL_files= L_args;
                        L_args= *(pL_files= &L_args->cdr);
                        *pL_files= nil;
                }
        }
        phase= INIT;
}

int member(cell_t *p, cell_t *l)
/* True if p is a member of list l. */
{
        while (l != nil && l->type == CELL) {
                if (p == l->car) return 1;
                l= l->cdr;
        }
        return p == l;
}

long basefind(cell_t *f, cell_t *l)
/* See if f has a suffix in list l + set the base name of f.
 * -1 if not found, preference number for a short basename otherwise. */
{
        cell_t *suff;
        size_t blen, slen;
        char *base;

        /* Determine base name of f, with suffix. */
        if ((base= strrchr(f->name, '/')) == nil) base= f->name; else base++;
        blen= strlen(base);

        /* Try suffixes. */
        while (l != nil) {
                if (l->type == CELL) {
                        suff= l->car; l= l->cdr;
                } else {
                        suff= l; l= nil;
                }
                if (f->flags & W_SUFF) {
                        /* F has a suffix imposed on it. */
                        if (f->suffix == suff) return 0;
                        continue;
                }
                slen= strlen(suff->name);
                if (slen < blen && strcmp(base+blen-slen, suff->name) == 0) {
                        /* Got it! */
                        dec(f->base);
                        f->base= findnword(base, blen-slen);
                        return 10000L * (blen - slen);
                }
        }
        return -1;
}

#define NO_PATH         2000000000      /* No path found yet. */

long shortest;          /* Length of the shortest path as yet. */

rule_t *findpath(long depth, int seek, cell_t *file, rule_t *start)
/* Find the path of the shortest transformation to the stop suffix. */
{
        rule_t *rule;

        if (action == 0) return nil;

        if (start == nil) {
                /* No starting point defined, find one using "file". */

                for (rule= rules; rule != nil; rule= rule->next) {
                        if (rule->type < TRANSFORM) continue;

                        if ((depth= basefind(file, rule->from)) >= 0) {
                                if (findpath(depth, seek, nil, rule) != nil)
                                        return rule;
                        }
                }
                return nil;
        }

        /* Cycle? */
        if (start->path != nil) {
                /* We can't have cycles through combines. */
                if (start->type == COMBINE) {
                        fprintf(stderr,
                                "\"%s\": contains a combine-combine cycle\n",
                                descr);
                        action= 0;
                }
                return nil;
        }

        /* Preferred transformations are cheap. */
        if (start->flags & R_PREFER) depth-= 100;

        /* Try to go from start closer to the stop suffix. */
        for (rule= rules; rule != nil; rule= rule->next) {
                if (rule->type < TRANSFORM) continue;

                if (member(start->to, rule->from)) {
                        start->path= rule;
                        rule->npaths++;
                        if (findpath(depth+1, seek, nil, rule) != nil)
                                return start;
                        start->path= nil;
                        rule->npaths--;
                }
        }

        if (V_stop == nil) {
                fprintf(stderr, "\"%s\": no stop suffix has been defined\n",
                        descr);
                action= 0;
                return nil;
        }

        /* End of the line? */
        if (start->to == V_stop) {
                /* Got it. */
                if (seek) {
                        /* Second hunt, do we find the shortest? */
                        if (depth == shortest) return start;
                } else {
                        /* Is this path shorter than the last one? */
                        if (depth < shortest) shortest= depth;
                }
        }
        return nil;     /* Fail. */
}

void transform(rule_t *rule)
/* Transform the file(s) connected to the rule according to the rule. */
{
        cell_t *file, *in, *out;
        char *base;

        /* Let $* be the list of input files. */
        while (rule->wait != nil) {
                file= rule->wait;
                rule->wait= file->cdr;
                file->cdr= V_star->value;
                V_star->value= file;
        }

        /* Set $< to the basename of the first input file. */
        file= file->car;
        V_in->value= in= inc(file->flags & W_SUFF ? file : file->base);
        file->flags&= ~W_SUFF;

        /* Set $> to the output file name of the transformation. */
        out= newcell();
        out->type= WORD;
        base= rule->path == nil ? in->name : maketemp();
        out->name= allocate(nil,
                (strlen(base)+strlen(rule->to->name)+1) * sizeof(*out->name));
        strcpy(out->name, base);
        if (rule->path == nil || strchr(rule->to->name, '/') == nil)
                strcat(out->name, rule->to->name);
        out= inc(out);
        if (rule->path != nil) out->flags|= W_TEMP;

        V_out->value= out;
        V_out->flags= W_SET|W_LOCAL;

        /* Do a transformation.  (Finally) */
        if (verbose >= 3) {
                printf("%s ", rule->type==TRANSFORM ? "transform" : "combine");
                prin2(V_star->value);
                printf(" %s\n", out->name);
        }
        pc= rule->prog;
        execute(DOIT, pc->indent+1);

        /* Hand $> over to the next rule, it must be a single word. */
        out= evaluate(V_out->value, IMPLODE);
        if (wordlist(&out, 1) != 1) {
                fprintf(stderr,
                "\"%s\", line %u: $> should be returned as a single word\n",
                        descr, rule->prog->lineno);
                action= 0;
        }

        if ((rule= rule->path) != nil) {
                /* There is a next rule. */
                dec(out->base);
                out->base= in;          /* Basename of input file. */
                file= inc(newcell());
                file->car= out;
                file->cdr= rule->wait;
                rule->wait= file;
        } else {
                dec(in);
                dec(out);
        }

        /* Undo the damage to $*, $<, and $>. */
        dec(V_star->value);
        V_star->value= nil;
        V_in->value= nil;
        V_out->value= nil;
        V_out->flags= W_SET|W_LOCAL|W_RDONLY;
}

void compile(void)
{
        rule_t *rule;
        cell_t *file, *t;

        phase= COMPILE;

        /* Implode the files list. */
        L_files= evaluate(L_files, IMPLODE);
        if (wordlist(&L_files, 0) < 0) {
                fprintf(stderr, "\"%s\": An assignment to $> contained junk\n",
                        descr);
                action= 0;
        }

        while (action != 0 && L_files != nil) {
                file= L_files->car;

                /* Initialize. */
                shortest= NO_PATH;
                for (rule= rules; rule != nil; rule= rule->next)
                        rule->path= nil;

                /* Try all possible transformation paths. */
                (void) findpath(0L, 0, file, nil);

                if (shortest == NO_PATH) {      /* Can't match the file. */
                        fprintf(stderr,
                        "%s: %s: can't compile, no transformation applies\n",
                                program, file->name);
                        action= 0;
                        return;
                }

                /* Find the first short path. */
                if ((rule= findpath(0L, 1, file, nil)) == nil) return;

                /* Transform the file until you hit a combine. */
                t= inc(newcell());
                t->car= inc(file);
                L_files= go(L_files, L_files->cdr);
                t->cdr= rule->wait;
                rule->wait= t;
                while (action != 0 && rule != nil && rule->type != COMBINE) {
                        transform(rule);
                        rule= rule->path;
                }
        }

        /* All input files have been transformed to combine rule(s).  Now
         * we need to find the combine rule with the least number of paths
         * running through it (this combine may be followed by another) and
         * transform from there.
         */
        while (action != 0) {
                int least;
                rule_t *comb= nil;

                for (rule= rules; rule != nil; rule= rule->next) {
                        rule->path= nil;

                        if (rule->type != COMBINE || rule->wait == nil)
                                continue;

                        if (comb == nil || rule->npaths < least) {
                                least= rule->npaths;
                                comb= rule;
                        }
                }

                /* No combine?  Then we're done. */
                if (comb == nil) break;

                /* Initialize. */
                shortest= NO_PATH;

                /* Try all possible transformation paths. */
                (void) findpath(0L, 0, nil, comb);

                if (shortest == NO_PATH) break;

                /* Find the first short path. */
                if ((rule= findpath(0L, 1, nil, comb)) == nil) return;

                /* Transform until you hit another combine. */
                do {
                        transform(rule);
                        rule= rule->path;
                } while (action != 0 && rule != nil && rule->type != COMBINE);
        }
        phase= INIT;
}

cell_t *predef(char *var, char *val)
/* A predefined variable var with value val, or a special variable. */
{
        cell_t *p, *t;

        p= findword(var);
        if (val != nil) {       /* Predefined. */
                t= findword(val);
                dec(p->value);
                p->value= t;
                p->flags|= W_SET;
                if (verbose >= 3) {
                        prin1(p);
                        printf(" =\b=\b= ");
                        prin2n(t);
                }
        } else {                /* Special: $* and such. */
                p->flags= W_SET|W_LOCAL|W_RDONLY;
        }
        t= inc(newcell());
        t->car= p;
        t->cdr= L_predef;
        L_predef= t;
        return p;
}

void usage(void)
{
        fprintf(stderr,
        "Usage: %s -v<n> -vn<n> -name <name> -descr <descr> -T <dir> ...\n",
                program);
        exit(-1);
}

int main(int argc, char **argv)
{
        char *tmpdir;
        program_t *prog;
        cell_t **pa;
        int i;

        /* Call name of the program, decides which description to use. */
        if ((program= strrchr(argv[0], '/')) == nil)
                program= argv[0];
        else
                program++;

        /* Directory for temporary files. */
        if ((tmpdir= getenv("TMPDIR")) == nil || *tmpdir == 0)
                tmpdir= "/tmp";

        /* Transform arguments to a list, processing the few ACD options. */
        pa= &L_args;
        for (i= 1; i < argc; i++) {
                if (argv[i][0] == '-' && argv[i][1] == 'v') {
                        char *a= argv[i]+2;

                        if (*a == 'n') { a++; action= 1; }
                        verbose= 2;

                        if (*a != 0) {
                                verbose= strtoul(a, &a, 10);
                                if (*a != 0) usage();
                        }
                } else
                if (strcmp(argv[i], "-name") == 0) {
                        if (++i == argc) usage();
                        program= argv[i];
                } else
                if (strcmp(argv[i], "-descr") == 0) {
                        if (++i == argc) usage();
                        descr= argv[i];
                } else
                if (argv[i][0] == '-' && argv[i][1] == 'T') {
                        if (argv[i][2] == 0) {
                                if (++i == argc) usage();
                                tmpdir= argv[i];
                        } else
                                tmpdir= argv[i]+2;
                } else {
                        /* Any other argument must be processed. */
                        *pa= cons(CELL, findword(argv[i]));
                        pa= &(*pa)->cdr;
                }
        }
#ifndef DESCR
        /* Default description file is based on the program name. */
        if (descr == nil) descr= program;
#else
        /* Default description file is predefined. */
        if (descr == nil) descr= DESCR;
#endif

        inittemp(tmpdir);

        /* Catch user signals. */
        if (signal(SIGHUP, SIG_IGN) != SIG_IGN) signal(SIGHUP, interrupt);
        if (signal(SIGINT, SIG_IGN) != SIG_IGN) signal(SIGINT, interrupt);
        if (signal(SIGTERM, SIG_IGN) != SIG_IGN) signal(SIGTERM, interrupt);

        /* Predefined or special variables. */
        predef("PROGRAM", program);
        predef("VERSION", version);
#ifdef ARCH
        predef("ARCH", ARCH);           /* Cross-compilers like this. */
#endif
        V_star= predef("*", nil);
        V_in= predef("<", nil);
        V_out= predef(">", nil);

        /* Read the description file. */
        if (verbose >= 3) printf("include %s\n", descr);
        prog= get_prog();

        phase= INIT;
        pc= prog;
        execute(DOIT, 0);

        argscan();
        compile();

        /* Delete all allocated data to test inc/dec balance. */
        while (prog != nil) {
                program_t *junk= prog;
                prog= junk->next;
                dec(junk->file);
                dec(junk->line);
                deallocate(junk);
        }
        while (rules != nil) {
                rule_t *junk= rules;
                rules= junk->next;
                dec(junk->from);
                dec(junk->to);
                dec(junk->wait);
                deallocate(junk);
        }
        deltemp();
        dec(V_stop);
        dec(L_args);
        dec(L_files);
        dec(L_predef);

        quit(action == 0 ? 1 : 0);
}

---