/* 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) {