/*	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);
}