/* Stuff needed to implement Lisp and Scheme.  This is -*- C++ -*-.
   Copyright (C) 1992 Per Bothner.

This file is part of Q.

Q is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2, or (at your option)
any later version.

Q is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.

You should have received a copy of the GNU General Public License
along with GNU CC; see the file COPYING.  If not, write to
the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.  */

#include <strstream.h>
#include "symbol.h"
#include "gfunc.h"
#include "genmap.h"
#include "genfiles.h"
#include "gassign.h"
#include "tempbuf.h"
#include "exceptions.h"
#include "expression.h"
#include "gfiles.h"
#include <ctype.h>
#include "builtin-syms.h"
#include "reader.h"
#include "gvars.h"
#include "modules.h"
#include "parsefile.h"
#include "traverse.h"
#include "debug.h"
#include <std.h>
#include "Qcompile.h"
#include "prop-list.h"
//#include "lispread.h"
extern "C" {
#include <gmp.h>
#include <gmp-impl.h>
}

extern Expr *ExpandLispForm(Root *form, struct TraverseData*);
extern "C" int encode_string_to_label(char *str, int length, char *buf);

class LispExpr : public Expression {
  public:
    Root *form;
    int lisp_kind; // 0: Common Lisp; 1: Scheme
    LispExpr(Root *f, int kind = 0);
    virtual void eval(void*, Type*, DisplayEnv *env);
//    virtual void eval(void*, Type*, struct DisplayEnv *env);
    virtual Expression * traverse(struct TraverseData *data);
    virtual void printon(ostream&) const;
};

LispExpr::LispExpr(Root *f, int kind = 0)
{
    clear_std_fields(LispExpr_code);
    form = f;
    lisp_kind = kind;
}
void LispExpr::eval(void* dst, Type* dstType, DisplayEnv *env) { abort(); }
void LispExpr::printon(ostream& outs) const
{
    switch (lisp_kind) {
      case 0:
      default:
	outs << "Lisp ";
	break;
      case 1:
	outs << "Scheme ";
	break;
    }
    long save_print_lisp = print_lisp;
    print_lisp = 1;
    outs << *form;
    print_lisp = save_print_lisp;
}

Expression * LispExpr::traverse(struct TraverseData *data)
{
    short save_flags = data->flags;
    if (lisp_kind > 0) data->flags |= TraverseScheme;
    else data->flags |= TraverseLisp;
    Expression *exp = ExpandLispForm(form, data);
    data->flags = save_flags;
    return exp;
}

class LispIfExpr : public ElseExpr {
  public:
    LispIfExpr(Expr *a, Expr *b, Expr *c);
    virtual void printon(ostream&) const;
    virtual void eval(void*, Type*, struct DisplayEnv *env);
};
LispIfExpr::LispIfExpr(Expr *a, Expr *b, Expr *c)
{
    clear_std_fields(LispIf_code);
    e1 = a;
    then = b;
    e2 = c;
    kind = 0;
}
void LispIfExpr::printon(ostream& outs) const
{
    outs << "(if " << *e1.E << " " << *then.E << " " << *e2.E << ")";
}

inline int LispTrue(Root *val) { return val != &NilSymbol; }

void LispIfExpr::eval(void* dst, Type * dstType, DisplayEnv *env)
{
    if (LispTrue(e1->eval(env)))
	then->eval(dst, dstType, env);
    else
	e2->eval(dst, dstType, env);
}

class DefunExpr : public Expression {
public:
  Symbol *fname;
  Expr* proc;
  DefunExpr(Symbol* fn, Expr* p) { fname = fn; proc = p; }
  virtual void eval(void*, Type*, DisplayEnv *env);
  virtual Expression * traverse(struct TraverseData *data);
  virtual void printon(ostream&) const;
};

void DefunExpr::eval(void* dst, Type* dstType, struct DisplayEnv *env)
{
  Root *value = proc->eval(env);
  fname->sym_function(value);
  dstType->coerceFromRoot(dst, value);
}

Expr * DefunExpr::traverse(TraverseData* data)
{
  proc = proc->traverse(data);
  return this;
}

void DefunExpr::printon(ostream& outs) const
{
  outs << "(DEFUN " << fname << " " << proc << ")";
}

ExprQuoteOp SingleExpr("single", "single", 0, 0);
ExprQuote NilExpr(&NilSymbol);


typedef Root * (*LispMacroFunction)(AList *form, TraverseData *data);

class LispMacro : public Functional {
//    DECLARE_MEMBERS(LispMacro)
  public:
    LispMacroFunction expander;
    LispMacro(Symbol& sym, LispMacroFunction exp);
};

LispMacro::LispMacro(Symbol& sym, LispMacroFunction exp)
{
    expander = exp;
    sym.sym_function(this);
    sym._flags |= Symbol::is_macro;
}


long print_lisp = 0;
char LispPrintCase = 'P'; // One of 'U' 'D' 'C'

void LispPrintSymbol(register char *str, int len, ostream& outs)
{
    int print_escape = print_readable;
    char ch;
#if 0
    int escape_next = 0;
    if (len == 0)
	return;
    char ch = *str;
    if (print_escape == 0) ;
    else if (isletter(ch) && LispReadBase > 10) ;
    else escape_next = 1;
#endif

    for (int i = 0; i < len; i++) {
	ch = *str++;
//	if (LispReadTableCase == 'P') {
//	    if (!isletter(ch)) {
//	    }
//	}
	outs.put(ch);
    }
}


int IsPair(Root *ob)
{
    const RecordType *ob_type = ob->isA();
    return ob_type == AList::desc() || ob_type == ConsPair::desc();
}

Root* DoLispRead(Root* arg)
{
    GenFile* f = arg->file();
    if (f == NULL) RaiseDomainError(NULL);
    return LispRead((InStream*)f, 0);
}

#if 0
class CarCdrOp : public BinOp {
  public:
    CarCdrOp *next;
    int count;
};

class CarOp : public CarCdrOp {
  public:
    CarOp(char *n, int c = 0, CarCdrOp *nxt = NULL)
	{ name = n; next = nxt; count = c; }
    virtual Root*prefix(Root *arg) const;
};

class CdrOp : public CarCdrOp {
  public:
    CdrOp(char *n, int c = 1, CarCdrOp *nxt = NULL)
	{ name = n; next = nxt; count = c; }
    virtual Root*prefix(Root *arg) const;
};
#endif

Root *DoCar(Root *arg)
{
    if (arg == &NilSymbol) return &NilSymbol;
    GenSeq * seq = arg->sequence();
    if (seq == NULL)
	Signal(new CoercionFail(arg, GenSeq::desc()));
    Root *result = seq->index(0);
    if (seq == Missing) return &NilSymbol;
    return result;
}

Root *DoCdr(Root *arg)
{
    if (arg == &NilSymbol) return &NilSymbol;
    AList *v = PTR_CAST(AList, arg);
    if (v == NULL) {
	GenSeq * seq = arg->sequence();
	if (seq == NULL)
	    Signal(new CoercionFail(arg, AList::desc()));
	if (seq->null()) return &NullSequence;
	return seq->subseq(1, -1);
    }
    return v->cdr;
}

#if 0
CarOp Car("car", 0);
CdrOp Cdr("cdr", 1);
CdrOp Cddr("cddr", 2);
CarOp Cadr("cadr", 1);
//CarCdrOp Caar("caar", ?);
//CarCdrOp Cdar("cdar", ?);
#endif

static Predefined pre_nil(NilSymbol, NilSymbol);
static Predefined pre_t(TSymbol, TSymbol);

Root * Cons2(Root *arg1, Root *arg2) { return new ConsPair(arg1, arg2); }

GenArray *Coerce2GenArray(Root *val)
{
    LVariable *lvar = val->lvariable();
    if (lvar)
	val = lvar->value();
    GenArray *v = PTR_CAST(GenArray, val);
    if (!v)
	RaiseDomainError(0);
    return v;
}

const StringC * Coerce2String(Root *arg)
{
    if (arg->isKindOf(*Symbol::desc()))
	return (Symbol::castdown(arg))->Str();
    if (!arg->isKindOf(*StringC::desc()))
	Signal(new CoercionFail(arg, StringC::desc()));
    return (const StringC*)arg;
}

Symbol *Coerce2Symbol(Root *val)
{
    for (;;) {
	Symbol *s = PTR_CAST(Symbol, val);
	if (s) 
	    return s;
	LVariable *lvar = val->lvariable();
	if (lvar) {
	    val = lvar->value();
	    if (val)
		continue;
	}
	Signal(new CoercionFail(val, Symbol::desc()));
    }
}

GenSeq *Coerce2Sequence(Root *arg)
{
  GenSeq *seq = arg->sequence();
  if (seq == NULL)
    Signal(new CoercionFail(arg, GenSeq::desc()));
  return seq;
}

Root *MakeVector2(Root *count, register Root *fill)
{
    long size;
    const Numeric *n_count = count->numeric();
    if (n_count == NULL || !n_count->getlong(&size))
	RaiseDomainError(0);
    return Copy2Vector(NULL, size, fill);
}

VectorV *NewVectorV(register size_t count, register Root **vals)
{
    register int i = count;
    VectorV *vec = NewVectorV(count);
    register Root **ptr = vec->start_addr();
    while (--i >= 0) *ptr++ = *vals++;
    return vec;
}

void ReplaceSequence(Root *arg1, Root *arg2,
		     index_t start1 = 0, index_t end1 = -1,
		     index_t start2 = 0, index_t end2 = -1)
{
    GenSeq *seq1 = arg1->sequence();
    GenSeq *seq2 = arg2->sequence();
    if (seq1 == NULL || seq2 == NULL)
	SignalBadAssignment(arg1, arg2);
    if (start1 < 0)
	start1 += seq1->length() + 1;
    if (start2 < 0)
	start2 += seq2->length() + 1;
    if (end1 < 0)
	end1 += seq1->length() + 1;
    if (end2 < 0)
	end2 += seq2->length() + 1;
    if (seq1 == seq2) {
	// FIXME: handle overlap???
    }
    for (;;) {
	if (start1 >= end1 || start2 >= end2)
	    return;
	Root *v = seq2->index(start2);
	if (v == NULL)
	    return;
	seq1->set_at(start1, v);
	start1++;
	start2++;
    }
	
}

Root *ReplaceSequence(Root *seq1, Root *seq2,
		      Root *start1, Root *end1,
		      Root *start2, Root *end2)
{
    index_t start_1 = start1 == &NilSymbol ? 0 : Coerce2Fix(start1);
    index_t start_2 = start2 == &NilSymbol ? 0 : Coerce2Fix(start2);
    index_t end_1 = end1 == &NilSymbol ? -1 : Coerce2Fix(end1);
    index_t end_2 = end2 == &NilSymbol ? -1 : Coerce2Fix(end2);
    ReplaceSequence(seq1, seq2, start_1, end_1, start_2, end_2);
    return seq1;
}

Root *MakeArray(Root *dims,
		Root *initial_element, Root *initial_contents,
		Root *adjustable, Root *fill_pointer,
		Root *displaced_to, Root *displaced_index_offset)
{
    Vector *vec;
    size_t total_size;
    MArray *arr;
    int i, adjust;
    GenSeq *dim_seq = dims->sequence();
    int rank = dim_seq ? dim_seq->length() : 1;
    DimInfo dim_info[rank];
    if (dim_seq) {
	for (i = 0; i < rank; i++) {
	    long tmp;
	    const Numeric *num_i = dim_seq->index(i)->numeric();
	    if (num_i == NULL || !num_i->getlong(&tmp) || tmp < 0)
		goto bad_array;
	    dim_info[i].length = tmp;
	}
    }
    else {
	long tmp;
	const Numeric *num_i = dims->numeric();
	if (num_i == NULL || !num_i->getlong(&tmp) || tmp < 0)
	    goto bad_array;
	dim_info[0].length = tmp;
    }
    total_size = CalculateSize(rank, dim_info);
    if (displaced_to != &NilSymbol) {
	fix_int offset = displaced_index_offset == &NilSymbol ? 0
	    : Coerce2Fix(displaced_index_offset);
	return MArray::New(rank, Coerce2GenArray(displaced_to),
			   offset, dim_info);
    }
    if (total_size > 0) {
	vec = NewVectorV(total_size);
	Root **start_vec = vec->start_addr();
	for (i = 0; i < total_size; i++)
	    *start_vec++ = initial_element;
    }
    else {
	vec = &NullSequence;
    }
    adjust =- LispTrue(adjustable);
    if (rank == 1 && !adjust) {
	if (initial_contents)
	    ReplaceSequence(vec, initial_contents);
	return vec;
    }
    arr = MArray::New(rank, vec, 0, dim_info);
    if (initial_contents)
	AssignArray(arr, 0, 0, initial_contents, 1);
    if (adjust)
	arr->misc_flags |= ArrayIsAdjustable;
    return arr;
  bad_array:
    fprintf(stderr, "Bad args to MAKE-ARRAY!\n");
    RaiseDomainError(NULL);
}

Root *AdjustArray(Root *old_array, Root *dims,
		Root *initial_element, Root *initial_contents,
		Root *fill_pointer,
		Root *displaced_to, Root *displaced_index_offset)
{
#if 1
    Signal(new UnimplementedOp("adjust-array"));
#else
    MArray *arr = ...;
    if (arr == NULL || !(arr->misc_flags & ArrayIsAdjustable)) {
	if (initial_contents == &NilSymbol)
	    initial_contents = old_array;
	return MakeArray(dims, initial_element, initial_contents,
			 fill_pointer,
			 displaced_to, displaced_index_offset);
    }
    GenSeq *dim_seq = dims->sequence();
    int rank = dim_seq ? dim_seq->length() : 1;
    if (rank != arr->_rank) {
	RaiseDomainError(NULL);
    }
    return arr;
#endif
}

Root *VectorFill2(Root *arg, Root* fill)
{
    if (!arg->isKindOf(*VectorV::desc()))
	RaiseDomainError(NULL);
    VectorV *vec = VectorV::castdown(arg);
    register Root **ptr = vec->start_addr();
    for (register int count = vec->len ; --count >= 0; ) *ptr++ = fill;
    return vec;
}

Root *Values1(Vector *args)
{
    int count = args->leng();
    Root **vals = args->start_addr();
    if (count > 1)
	return new Tuple(count, vals);
    else if (count == 1)
	return vals[0];
    else
	return &EmptyTuple;
}

Root * Symbol2String(Root *arg)
{
    if (!arg->isKindOf(*Symbol::desc())) {
	if (arg->isKindOf(*StringC::desc()))
	    return arg;
	RaiseDomainError(NULL);
    }
    Symbol *sym = Symbol::castdown(arg);
    return (Root*)sym->Str();
}

Root * String2Symbol(Root *arg)
{
    if (arg->isKindOf(*StringC::desc())) {
	StringC *str = StringC::castdown(arg);
	return CurrentPackage->intern(str);
    }
    else if (arg->isKindOf(*String::desc())) {
	StringV *str = StringV::castdown(arg);
	// Writable string - force a copy.
	return CurrentPackage->intern(str->chars(), str->leng());
    }
    else if (arg->isKindOf(*Symbol::desc()))
	return arg;
    else {
	RaiseDomainError(NULL);
	return NULL;
    }
}

Package * Coerce2Package(Root *package)
{
    if (package == NULL || package == &NilSymbol)
	return CurrentPackage;
    if (!package->isKindOf(*Package::desc()))
	RaiseDomainError(NULL);
    return (Package*)package;
}

static Symbol *(InternCode[4]) = {
    &NilSymbol, &INTERNAL_key, &EXTERNAL_key, &INHERITED_key};

Root *DoIntern(Root *name, Root *package = NULL)
{
    int code;
    const StringC *str = Coerce2String(name);
    Symbol *sym = Coerce2Package(package)->intern(str, &code);
    Symbol *return_code = InternCode[code];
    return new Tuple(sym, return_code);
}

Root *DoFindSymbol(Root *name, Root *package = NULL)
{
    int code;
    const StringC *str = Coerce2String(name);
    Symbol *sym = Coerce2Package(package)->find_interned(str->chars(),
							 str->leng(),
							 &code);
    Symbol *return_code = InternCode[code];
    return new Tuple(sym == NULL ? &NilSymbol : sym, return_code);
}

Root *PackageUseList(Root *p) { return Coerce2Package(p)->use_list; }
Root *PackageUsedByList(Root *p) { return Coerce2Package(p)->used_by_list; }

Root *RenamePackage(Root *pack, Root *new_name, Root *nicknames)
{
    Package *package = Coerce2Package(pack);
    package->set_name(Coerce2String(new_name));
    Root *nickname_list;
    Root **nickname_ptr = &nickname_list;
    GenSeq *nickname_seq = nicknames->sequence();
    if (nickname_seq == NULL)
	RaiseDomainError(NULL);
    ITERATOR(nickname_iterator, nickname_seq);
    for (;;) {
	Root *nickname = nickname_iterator.next();
	if (nickname == Missing)
	    break;
	AList *pair = new AList((Root*)Coerce2String(nickname), NULL);
	*nickname_ptr = pair;
	nickname_ptr = &pair->cdr;
    }
    *nickname_ptr = &NilSymbol;
    package->set_nicknames(nickname_list);
    return package;
}

Root *UsePackage(Root *packs_to_use, Root *package) // CL: use-package
{
    Package *pack = Coerce2Package(package);
    GenSeq *plist = packs_to_use->sequence();
    if (plist == NULL) {
	Package *p = Coerce2Package(packs_to_use);
	pack->use(p);
	return &TSymbol;
    }
    else {
	ITERATOR(piter, plist);
	for (;;) {
	    Root *pel = piter.next();
	    if (pel == Missing)
		return &TSymbol;
	    pack->use(Coerce2Package(pel));
	}
    }
}

Root *UnUsePackage(Root *packs_to_use, Root *package) // CL: unuse-package
{
    Package *pack = Coerce2Package(package);
    GenSeq *plist = packs_to_use->sequence();
    if (plist == NULL) {
	Package *p = Coerce2Package(packs_to_use);
	pack->unuse(p);
	return &TSymbol;
    }
    else {
	ITERATOR(piter, plist);
	for (;;) {
	    Root *pel = piter.next();
	    if (pel == Missing)
		return &TSymbol;
	    pack->unuse(Coerce2Package(pel));
	}
    }
}

Root *MakePackage(Root *name, Root *nicknames, Root *uselist)
{
    Package *package = new Package((const StringC*)0, 32);
    RenamePackage(package, name, nicknames);
    if (uselist == NULL || uselist == &NilSymbol)
	package->use(&CLispPackage);
    else
	UsePackage(uselist, package);
    return package;
}

Root* DeletePackage(Root *pack)
{
    Package *package = Coerce2Package(pack);
    if (package->is_deleted())
	return &NilSymbol;
    if (package->used_by_list != &NilSymbol) {
	//ERROR! (correctible)
    }
    while (package->used_by_list != &NilSymbol) {
	Package *p = (Package*)((AList*)package->used_by_list)->car;
	p->unuse(package);
    }
    while (package->use_list != &NilSymbol) {
	Package *p = (Package*)((AList*)package->use_list)->car;
	package->unuse(p);
    }
    package->set_name(NULL);
    package->set_nicknames(&NilSymbol);
    Package **ptr = &PackageList;
    for (;;) {
	Package *p = *ptr;
	if (p == package) {
	    *ptr = package->next;
	    break;
	}
	if (p == NULL) break; // Should never happen!
	ptr = &p->next;
    }
    return &TSymbol;
}

Root *ListAllPackages()
{
    Root *list = &NilSymbol;
    for (Package *pack = PackageList; pack != NULL; pack = pack->next)
	list = new AList(pack, list);
    return list;
}

Root* ImportSymbol(Root *sym, Root *pack)
{
    Package *package = Coerce2Package(pack);
    GenSeq *seq = sym->sequence();
    if (seq != NULL) {
	ITERATOR(sym_iter, seq);
	for (;;) {
	    Root *el = sym_iter.next();
	    if (el == Missing) break;
	    package->import(Coerce2Symbol(el));
	}
    }
    else
	package->import(Coerce2Symbol(sym));
    return &TSymbol;
}
Root* UnInternSymbol(Root *sym, Root *pack)
{
    Package *package = Coerce2Package(pack);
    Symbol *symbol = Coerce2Symbol(sym);
    int code;
    Symbol *s =
	package->find_interned(symbol->string(), symbol->length(), &code);
    if (s != symbol || code == InternInherited)
	return &NilSymbol;
    if (code == InternInternal)
	package->int_hash.remove(symbol);
    else
	package->int_hash.remove(symbol);
    if (package->unmake_shadowed(symbol)) {
	// FIXME: if was shadowed, check for name conflicts.
    }
    if (symbol->_package == package)
	symbol->_package = NULL;
    return &TSymbol;
}

Root *PackageName(Root *p) { return (Root*)Coerce2Package(p)->name(); }
Root *PackageNicknames(Root *p) { return (Root*)Coerce2Package(p)->nick_names;}

Root* ExportSymbol(Root *sym, Root *pack) { abort(); }
Root* UnExportSymbol(Root *sym, Root *pack) { abort(); }
Root* ShadowingImportSymbol(Root *sym, Root *pack) { abort(); }
Root* ShadowSymbol(Root *sym, Root *pack) { abort(); }
Root* PackageShadowingSymbols(Root *pack) { abort(); }

// Return the cdr of the conscell whose car==key

ConsPair * FindProp(Root* prop_list, Root *key)
{
    for (;;) {
	if (prop_list == &NilSymbol)
	    return NULL;
	ConsPair *cons = CheckCons(prop_list);
	Root *prop_next = cons->cdr;
	ConsPair *cons_next = CheckCons(prop_next);
	if (cons->car == key)
	    return cons_next;
	prop_list = cons_next->cdr;
    }
}

Root * GetProp3(Root *symbol, Root *key, Root *default_val)
{
    Symbol *sym = Coerce2Symbol(symbol);
    ConsPair *cons = FindProp(sym->_property_list, key);
    if (cons == NULL)
	return default_val;
    else
	return cons->car;
}

Root * PutProp3(Root *symbol, Root *key, Root *val)
{
    Symbol *sym = Coerce2Symbol(symbol);
    ConsPair *cons = FindProp(sym->_property_list, key);
    if (cons == NULL) {
	sym->_property_list =
	    new ConsPair(key, new ConsPair(val, sym->_property_list));
    }
    else
	cons->car = val;
    return symbol;
}

Root *SymbolPlist(Root *arg)
{
    return Coerce2Symbol(arg)->_property_list;
}

Root *SymbolPackage(Root *arg)
{
    return Coerce2Symbol(arg)->package();
}

Root *FindPackage(Root *arg)
{
    if (arg->isKindOf(*Package::desc()))
	return arg;
    const StringC *str = Coerce2String(arg);
    Package *pack = LookupPackage(str->chars(), str->leng());
    if (pack == NULL) return &NilSymbol;
    else return pack;
}

extern CoercedAssignable package_lsym;
static void CoercePackage(CoercedAssignable *var, Root *new_val)
{
    Root *pack = FindPackage(new_val);
    if (pack == &NilSymbol)
	SignalBadAssignment(var, new_val);
    *(Package**)var->pointer = (Package*)pack;
}
CoercedAssignable package_lsym(&PACKAGE_var_str, &CLispPackage,
			      &CurrentPackage,
			      CoercePackage,
			      &UserPackage);

Root * MakeSymbol(Root *print_name) // CLtL:2. p. 244
{
    const StringC *str = Coerce2String(print_name);
    Symbol *sym = new Symbol(str);
    sym->_package = 0;
    return sym;
}

Root * RemF(Root** prop_list_ptr, Root *key) // CLtL:2, p. 242.
{
    for (;;) {
	register Root *prop_list = *prop_list_ptr;
	if (prop_list == &NilSymbol)
	    return &NilSymbol;
	ConsPair *cons = CheckCons(prop_list);
	Root *prop_next = cons->cdr;
	ConsPair *cons_next = CheckCons(prop_next);
	if (cons->car == key) {
	    Root *result = cons_next->car;
	    *prop_list_ptr = cons_next->cdr;
	    return result == &NilSymbol ? &TSymbol : result;
	}
	prop_list_ptr = &cons_next->cdr;
    }
}

Root * RemProp(Root* symbol, Root *key) // CLtL:2, p. 241.
{
    Symbol *sym = Coerce2Symbol(symbol);
    return RemF(&sym->_property_list, key);
}

Root *MacroFunctionSet(Root *symbol, Root *macro)
{
    Symbol *sym = Coerce2Symbol(symbol);
    sym->sym_function(macro);
    sym->_flags |= Symbol::is_macro;
    return sym;
}
Root *MacroFunction(Root *symbol, Root* env)
{
    Symbol *sym = Coerce2Symbol(symbol);
    Root *macro = sym->sym_function();
    if (macro == NULL || !(sym->_flags & Symbol::is_macro))
	return &NilSymbol;
    return macro;
}

Root *SymbolFunctionSet(Root *symbol, Root *function)
{
    Symbol *sym = Coerce2Symbol(symbol);
    sym->sym_function(function);
    sym->_flags &= ~Symbol::is_macro;
    return sym;
}
Root *SymbolFunction1(Root *symbol)
{
    Symbol *sym = Coerce2Symbol(symbol);
    Root *fun = sym->sym_function();
    if (fun == NULL) {
	RaiseDomainError(0);	// ERROR!
    }
    return fun;
}
Root *SetfSymbolFunction(Root *new_value, Root *symbol)
{
    Symbol *sym = Coerce2Symbol(symbol);
    sym->sym_function(new_value);
    return new_value;
}

Root *SetSymbol(Root *symbol, Root *value)
{
    Symbol *sym = Coerce2Symbol(symbol);
    sym->sym_value(value);
    return value;
}

Root *SymbolValue1(Root *symbol)
{
    Symbol *sym = Coerce2Symbol(symbol);
    Root *val = sym->sym_value();
    if (val == NULL)
	Signal(new UnboundVariable(sym));
    return val;
}

Root *Boundp(Root *symbol)
{
    Root *val = Coerce2Symbol(symbol)->sym_value();
    return val == NULL ? &NilSymbol : &TSymbol;
}

Root *FBoundp(Root *symbol)
{
    Root *fval = Coerce2Symbol(symbol)->sym_function();
    return fval == NULL ? &NilSymbol : &TSymbol;
}

Root *MakeUnbound(Root *symbol)
{
    Symbol *sym = Coerce2Symbol(symbol);
    sym->sym_value(NULL);
    return sym;
}

Root *FMakeUnbound(Root *symbol)
{
    Symbol *sym = Coerce2Symbol(symbol);
    sym->sym_function(NULL);
    return sym;
}

void LoadLisp(InStream *instream, int print_results, Language lang)
{
    int flags = 0;
    Package *save_package = CurrentPackage;
    TraverseData data(DefaultModule);
    if (lang == SchemeLanguage) {
	data.flags |= TraverseScheme;
	flags |= LispReadScheme;
    }
    else {
	data.flags |= TraverseLisp;
    }
    data.curBlock = DefaultModule->block;
    for (;;) {
#if 0
	block->first = NULL;
	block->last = &block->first;
	/* should save old decls (if any) into module */
	block->decls.first = NULL;
	block->decls.last = &block->decls.first;
#endif

	Root *form = LispRead(instream, flags&LispReadScheme);
	if (form == EOF_mark)
	    break;
	Expr *exp = ExpandLispForm(form, &data);
	PopPendingProcs(&data);
//	AppendStatement(block, exp);
	if (data.errors <= WrnMessage) {
	    struct DisplayEnv *env = (struct DisplayEnv*)
		alloca(sizeof(struct DisplayEnv)+(data.displayMax+1)*2*sizeof(void *));
	    env->minLevel = 0; env->maxLevel = data.displayMax;
	    env->env[0] = NULL;
	    env->tryNext = MAKE_ANY(0, 0);
	    if (print_results == 0)
		(void)exp->eval(env);
	    else
		exp->eval(&cout, &Text, env);
	}
    }
    CurrentPackage = save_package;
}

void LispEvalString(char *str, int len)
{
    strstreambuf file(str, len);
    InStream instream(&file);
    LoadLisp(&instream, 0, LispLanguage);
}
void SchemeEvalString(char *str, int len)
{
    strstreambuf file(str, len);
    InStream instream(&file);
    LoadLisp(&instream, 0, SchemeLanguage);
}

struct LanguageExtensions {
    char ext[10];
    char ext_len;
    Language lang;
};

LanguageExtensions LispExtensions[4] = {
    { ".lisp", 5, LispLanguage },
    { ".scheme", 7, SchemeLanguage },
    { ".scm", 4, SchemeLanguage },
    { "", 0, DefaultLanguage }
};

void
LispCompileFile(char* input_filename, Language lang = LispLanguage)
{
    Package *save_package = CurrentPackage;
    filebuf file;
    if (!file.open(input_filename, ios::in)) {
	fprintf(stderr, "Load failed on %s!\n", input_filename);
	RaiseDomainError(0);
    }
    InStream instream(&file);
    Module *module = DefaultModule;
    TraverseData data(module);

    // Remove directory path and extension from filename.
    int dir_len = GetDirectoryPrefixLength(input_filename);
    input_filename += dir_len;
    char *module_name = input_filename;
    int name_len = strlen(module_name);
    for (int i = 0; ; i++) {
	int ext_len = LispExtensions[i].ext_len;
	if (ext_len == 0)
	    break;
	if (name_len > ext_len
	    && !strcmp(module_name+name_len-ext_len, LispExtensions[i].ext)) {
	    module_name = (char*)alloca(name_len-ext_len+1);
	    memcpy(module_name, input_filename, name_len-ext_len);
	    module_name[name_len-ext_len] = 0;
	    break;	    
	}
    }

    CFile cf(module_name, module, 1);
    data.compile_to = &cf;
    data.curBlock = module->block;
    for (;;) {
#if 0
	block->first = NULL;
	block->last = &block->first;
	/* should save old decls (if any) into module */
	block->decls.first = NULL;
	block->decls.last = &block->decls.first;
#endif

	Root *form = LispRead(&instream, 0);
	if (form == EOF_mark)
	    break;
	Expr *exp = ExpandLispForm(form, &data);
//	AppendStatement(block, exp);
	if (data.errors <= WrnMessage) {
	    struct DisplayEnv *env = (struct DisplayEnv*)
		alloca(sizeof(struct DisplayEnv)+(data.displayMax+1)*2*sizeof(void *));
	    env->minLevel = 0; env->maxLevel = data.displayMax;
	    env->env[0] = NULL;
	    env->tryNext = MAKE_ANY(0, 0);
	    if (exp != &NilExpr) {
		cf.asm_stream() << "// Expr:\n";
		exp->compile(&cf);
	    }
//	    if (print_results == 0)
//		(void)exp->eval(env);
//	    else exp->eval(&cout, &Text, env);
	}
    }
    DumpPending(cf);
    file.close();
    CurrentPackage = save_package;
}
Root *
LispCompileFile(Root *filename)
{
    const StringC *str = Coerce2String(filename);
    LispCompileFile(str->chars());
    return &NilSymbol;
}

Root *LispLoad(Root *filename)
{
    const StringC *str = Coerce2String(filename);
    filebuf file;
    if (!file.open(str->chars(), ios::in)) {
	fprintf(stderr, "load failed on %s!\n", str->chars());
	RaiseDomainError(0);
    }
    InStream instream(&file);
    LoadLisp(&instream, 0, LispLanguage);
    file.close();
    return &NilSymbol; // Return 3 values
}

void LispPrintCharacter(ostream& outs, int c)
{
    register char **ptr;
    outs << "#\\";
    if (c >= 128) {
	outs << "Meta-";
	c -= 128;
    }
    if (c > ' ' && c < 127)
	goto graphic;
    for (ptr = LispCharNames; *ptr; ptr++)
	if ((*ptr)[0] == c) {
	    outs << (*ptr)+1;
	    return;
	}
    outs << "Control-";
    c += 64;
    goto graphic;
    return;
  graphic:
    if (Alphameric(c)) outs << (char)c;
    else {
	char buf[6];
	sprintf(buf, "\\%c", c);
	outs << buf;
    }
}


Root* LispEval(Root* form)
{
    Module *module = DefaultModule;
    TraverseData data(module);
    data.curBlock = module->block;
    data.flags |= TraverseLisp;
     Expr* exp = ExpandLispForm(form, &data);
    return exp->eval(NULL);
}



#if 0
class Array : public GenSeq {
  public:
    Type *ElemType;
    short rank;
    unsigned int has_fillpointer : 1;
    size_t *dimensions;
    size_t fillpointer;
    union {
	<ElemType> *start;
	struct {
	    Array *base;
	    size_t offset;
	} _displaced;
    };
    size_t& displaced_index_offset() { return _displaced.offset; }
    Array *&displaced_to() { return _dispplaced.base; }
    <ElemType>& aref(size_t *indexes);
};

size_t row_major_index(int rank, size_t *dimensions, size_t *subscripts)
{
    size_t offset = 0;
    size_t size = 1;
    if (rank <= 0)
	return 0;
    for (int i = rank; ; ) {
	if (indexes[i] >= lengths[i])
	    return ERROR;
	offset += indexes[i] * size;
	if (i == 0) break;
	size *= lengths[i];
	--i;
    }
    return offset;
}

<ElemType>& Array::aref(size_t *indexes)
{
    size_t offset = row_major_index(rank, dimensions, indexes);
    Array *a = this;
    while (a->displaced()) {
	offset += a->displaced_index_offset;
	a = a->displaced_to();
    }
    if (offset > a->total_size()) ERROR;
    return start[offset];
}
#endif

Expr *ForceSingle(Expr *exp)
{
    if (exp->code() == ExprQuote_code)
	return exp;
    if (exp->code() == Identifier_code)
	return exp;
    ExprList *list = new ExprList(2);
    list->arg[0].E = SingleExpr.traverse((TraverseData*)0);
    list->arg[1].E = exp;
    return list;
}

Root *QuoteMacro(AList *form, TraverseData *data)
{
    if (IsPair(form->cdr)) {
	AList * args = (AList*)form->cdr;
	if (args->cdr == &NilSymbol)
	    return DoQuote(args->car);
    }
    fprintf(stderr, "Wrong number of args to 'quote' macro.\n");
    return &NilSymbol;
}
static LispMacro _QuoteMacro(QUOTE_sym, QuoteMacro);

Expr *AsFunction(Root *arg, TraverseData *data)
{
    if (arg->isA() != Symbol::desc())
	return ExpandLispForm(arg, data);
    Symbol *sym = (Symbol*)arg;
    Identifier *id = NewIdentifier(sym, NULL);
    if (data->flags & TraverseLisp)
	id->flags |= IdentFuncOnly;
    return id->traverse(data);
}

Root *ExpandFunction(AList *mform, TraverseData *data)
{
    if (IsPair(mform->cdr)) {
	AList * args = (AList*)mform->cdr;
	if (args->cdr == &NilSymbol)
	    return AsFunction(args->car, data);
    }
    fprintf(stderr, "Wrong number of args to 'FUNCTION' macro.\n");
    return &NilSymbol;
}
static LispMacro FunctionMacro(FUNCTION_sym, ExpandFunction);

Root *MultipleValueCall(AList *mform, TraverseData *data)
{
    Root *form = mform->cdr;
    TempPtrBuf arg_buf;
    while (IsPair(form)) {
	AList *pair = (AList*)form;
	arg_buf.putp(ExpandLispForm(pair->car, data)); // Note: no ForceSingle
	form = pair->cdr;
    }
    if (arg_buf.count() == 0) { // ERROR!
    }
    if (form != &NullSequence && form != &NilSymbol) { // ERROR!
	arg_buf.putp(new MakeTupleExpr(ExpandLispForm(form, data)));
    }
    arg_buf.putp((Expr*)NULL);
    return new ExprList(arg_buf.count()-1, (Expr_Ptr*)arg_buf.copy(0));
}
static LispMacro _MultVCallMacro(MULTIPLE_VALUE_CALL_sym, MultipleValueCall);

ParamExpr *ConvertLambdaList(Root *lambda_list, ProcExpr *fnc,
			     TraverseData *data)
{
    ParamExpr *params;
    const Symbol *current_lambda_key = &REQUIRED_lambda_sym;
    Declaration *param_decls;
    Declaration **param_decls_tail = &param_decls;
    ParamExpr **next_param = &params;
    AList *pair;
    for (; IsPair(lambda_list); lambda_list = pair->cdr) {
	Expr *default_expr = &NilExpr;
	pair = (AList*)lambda_list;
	ParamExpr *param = new ParamExpr;
	Root *param_desc = pair->car;
	Symbol *param_name;
	if (param_desc->isA() == Symbol::desc()) {
	    param_name = (Symbol*)param_desc;
	    char *param_string = param_name->string();
	    int param_len = param_name->length();
	    if (param_string[0] == '&'){// Lambda-list keyword.
#if 1
		current_lambda_key = param_name;
#else	    
		if (param_len == 9 &&
		  strcmp(param_string, REQUIRED_lambda_str.chars())==0)
		    current_lambda_key = &REQUIRED_lambda_str;
		else if (param_len == 9 &&
		  strcmp(param_string, OPTIONAL_lambda_str.chars())==0)
		    current_lambda_key = &OPTIONAL_lambda_str;
		else if (param_len == 4 &&
		  strcmp(param_string, REST_lambda_str.chars())==0)
		    current_lambda_key = &REST_lambda_str;
		else if (param_len == 3 &&
		  strcmp(param_string, KEY_lambda_str.chars())==0)
		    current_lambda_key = &KEY_lambda_str;
		else if (param_len == 3 &&
		  strcmp(param_string, AUX_lambda_str.chars())==0)
		    current_lambda_key = &AUX_lambda_str;
		else {
		    fprintf(stderr, "Unrecognized lambda keyword: %s.\n",
			    param_string);
		}
#endif
		continue;
	    }
	}
	else if (IsPair(param_desc)
		 && ((AList*)param_desc)->car->isA() == Symbol::desc()) {
	    param_name = (Symbol*)((AList*)param_desc)->car;
	    Root *rest_form = ((AList*)param_desc)->cdr;
	    if (rest_form == &NilSymbol) { }
	    else if (IsPair(rest_form)) {
		default_expr = ExpandLispForm(((AList*)rest_form)->car, data);
	    }
	    else { } // ERROR!
	}
	else {
	    fprintf(stderr, "Lambda parameter must be plain identifier!\n");
	    param_name = NULL;
	}
	Identifier *id = NewIdentifier(param_name, NULL);
	param->arg_expr.E = id;
	ChainDeclaration(param_decls_tail, Symbol2Declaration(param_name));
	param->flags = 0;
	param->name = NULL;
	param->arg_type = NULL;
	if (current_lambda_key == &OPTIONAL_lambda_sym) {
	    param->default_expr = default_expr;
	    fnc->pn[1].optional++;
	}
	else if (current_lambda_key == &KEY_lambda_sym) {
	    param->default_expr = default_expr;
	    fnc->pn[2].optional++;
	    fnc->flags |= ProcHasNamedParams;
	    param->flags |= FormalKeyword;
	    param->name = KeywordPackage.intern(param_name->string(),
					       param_name->length());
	}
	else if (current_lambda_key == &REST_lambda_sym) {
	    param->default_expr = NULL;
	    if (fnc->pn[1].tuple) {
		fprintf(stderr, "Only one &REST parameter allowed!\n");
	    }
	    param->flags |= FormalMultipleList;
	    fnc->pn[1].tuple = 1;
	}
	else if (current_lambda_key == &REST_VECTOR_lambda_sym) {
	    param->default_expr = NULL;
	    if (fnc->pn[1].tuple) {
		fprintf(stderr, "Only one &REST parameter allowed!\n");
	    }
	    param->flags |= FormalMultipleVector;
	    fnc->pn[1].tuple = 1;
	}
	else {
	    param->default_expr = NULL;
	    fnc->pn[1].required++;
	}
	fnc->nParams++;
	*next_param = param;
	next_param = &param->next;
    }
    if (lambda_list == &NilSymbol) {  } // done
    else if (lambda_list->isA() == Symbol::desc()) { // Rest param
	AList *pair = (AList*)lambda_list;
	ParamExpr *param = new ParamExpr;
	param->arg_expr.E = NewIdentifier((Symbol*)lambda_list, NULL);
	param->flags = FormalMultiple;
	param->name = NULL;
	param->default_expr = NULL;
	param->arg_type = NULL;
	fnc->pn[1].tuple = 1;
	*next_param = param;
	next_param = &param->next;
    }
    else
	fprintf(stderr, "Bad lambda list!\n");
    *next_param = NULL;
    *param_decls_tail = NULL;
    fnc->paramDecls = param_decls;
    return params;
}

Root *SchemeDefine(AList *mform, TraverseData *data)
{
    Root *form = mform->cdr;
    Root *lambda_list;
    Root *lambda_body;
    Symbol *sym = NULL;
    if (!IsPair(form)) goto bad_define;
    lambda_list = ((AList*)form)->car;
    lambda_body = ((AList*)form)->cdr;
    if (IsPair(lambda_list)) {
	AList *lambda_pair = (AList*)lambda_list;
	Root *formals = lambda_pair->cdr;
	if (lambda_pair->car->isA() == Symbol::desc()) {
	    sym = (Symbol*)lambda_pair->car;
	    Block *body_block = new Block(data->curBlock);
	    ProcExpr *proc = GC_NEW ProcExpr(body_block);
	    proc->argList = ConvertLambdaList(formals, proc, data);
	    BindClause(proc);
	    proc->_function->fname = sym;
	    proc->lisp_body = lambda_body;

	    ExprList *list = new ExprList(3);
	    list->arg[0].E = DoQuote(&SetSymbol);
	    list->arg[1].E = DoQuote(sym);
	    list->arg[2].E = proc->traverse(data);
	    return list;
	}
    }
    else if (lambda_list->isA() == Symbol::desc()) {
	Symbol *sym = (Symbol*)lambda_list;
	ExprList *list = new ExprList(3);
	list->arg[0].E = DoQuote(&SetSymbol);
	list->arg[1].E = DoQuote(sym);
	list->arg[2].E = ExpandForms(lambda_body, data);
	return list;
    }
  bad_define:
    cerr << "Bad define syntax for ";
    if (sym)
	cerr << *sym;
    else
	cerr << "<unknown name>";
    cerr << '\n';
    return &NilSymbol;
}
static LispMacro _DefineMacro(DEFINE_sym, SchemeDefine);

Root *ExpandDefun(AList *mform, TraverseData *data)
{
    Root *form = mform->cdr;
    Root* lambda_name = NULL;
    if (IsPair(form)) {
	lambda_name = ((AList*)form)->car;
	Root* lambda_name_cdr = ((AList*)form)->cdr;
	if (lambda_name->isA() == Symbol::desc()) {
	    Symbol *sym = (Symbol*)lambda_name;
	    if (IsPair(lambda_name_cdr)) {
		Root* lambda_list = ((AList*)lambda_name_cdr)->car;
		Root* lambda_body = ((AList*)lambda_name_cdr)->cdr;
		
		Block *body_block = new Block(data->curBlock);
		ProcExpr *proc = GC_NEW ProcExpr(body_block);
		proc->argList = ConvertLambdaList(lambda_list, proc, data);
		BindClause(proc);
		proc->function()->fname = sym;
		proc->lisp_body = lambda_body;
		
		if (data->compile_to && data->topLevel()) {
		    char encoded_name[2 * sym->length() + 10];
		    encode_string_to_label(sym->string(), sym->length(),
					   encoded_name);
		    // FIXME: Need -fdollars-in-identifiers or asm
		    // for g++ to allow $ in identifiers.
		    // Change them to _ for now.
		    for (char *p = encoded_name; *p; p++)
			if (*p == '$') *p = '_';
		    CFile *cf = data->compile_to;
		    ProcDescCPut(proc->function(),
				 data->compile_to,
				 encoded_name);
		    cf->asm_stream() << "GFunction __" << encoded_name << "(";
		    DumpPointerTo(sym, cf);
		    cf->asm_stream() << ", " << encoded_name << ");\n";
		    return &NilExpr;
		}

#if 1
		if (data->topLevel()) {
		    sym->sym_function(new GFunction(proc->function()));
		    return DoQuote(sym);
		}
#endif

		return new DefunExpr(sym, proc->traverse (data));
	    }
	}
    }
    cerr << "Bad defun syntax for ";
    if (lambda_name)
	cerr << *lambda_name;
    else
	cerr << "<unknown name>";
    cerr << '\n';
    return &NilSymbol;
}
static LispMacro DefunMacro(DEFUN_sym, ExpandDefun);

Root *ExpandDefVar(AList *mform, TraverseData *data)
{
    Root *form = mform->cdr;
    if (IsPair(form)) {
	Root* var_name = ((AList*)form)->car;
	Root* var_name_cdr = ((AList*)form)->cdr;
	if (var_name->isA() == Symbol::desc()) {
	    Symbol *sym = (Symbol*)var_name;
	    // Proclaim to be special.  FIXME
	    if (var_name_cdr == &NilSymbol)
		return sym;
	    AList *var_init =PTR_CAST(AList, var_name_cdr);
	    if (var_init != NULL && var_init->cdr == &NilSymbol) {
		sym->sym_value(var_init->car);
		return sym;
	    }
	}
    }
    fprintf(stderr, "Bad defvar syntax!\n");
    return &NilSymbol;
}
static LispMacro DefVarMacro(DEFVAR_sym, ExpandDefVar);

Root *ExpandDefConstant(AList *mform, TraverseData *data)
{
    Root *form = mform->cdr;
    if (IsPair(form)) {
	Root* var_name = ((AList*)form)->car;
	Root* var_name_cdr = ((AList*)form)->cdr;
	if (var_name->isA() == Symbol::desc() && IsPair(var_name_cdr)) {
	    Symbol *sym = (Symbol*)var_name;
	    Expr *init_form =
		ExpandLispForm(((AList*)var_name_cdr)->car, data);
	    if (!data->topLevel()) {
		abort(); // FIXME: ERROR!
	    }
	    Root *init_val = init_form->eval(NULL);
	    if (data->compile_to) {
		CFile *cf = data->compile_to;
		char label[20];
		cf->generate_label(label);
		cf->asm_stream() << "static DefineConstant " << label << "(";
		DumpPointerTo(sym, cf);
		cf->asm_stream() << ", ";
		DumpPointerTo(init_val, cf);
		cf->asm_stream() << ");\n";
	    }
	    else
		sym->sym_value(init_val);
	    return &NilExpr;

	}
    }
    fprintf(stderr, "Bad defconstant syntax!\n");
    return &NilSymbol;
}
static LispMacro DefConstMacro(DEFCONSTANT_sym, ExpandDefConstant);

Root *ExpandLambda(AList *mform, TraverseData *data)
{
    Root *formals; Root *body; Block *body_block; ProcExpr *proc;
    if (!IsPair(mform->cdr)) goto bad_lambda;
    formals = ((AList*)mform->cdr)->car;
    body = ((AList*)mform->cdr)->cdr;
    body_block = new Block(data->curBlock);
    proc = GC_NEW ProcExpr(body_block);
    proc->argList = ConvertLambdaList(formals, proc, data);
    BindClause(proc);
    proc->lisp_body = body;
    return proc->traverse(data);
  bad_lambda:
    fprintf(stderr, "Bad lambda syntax!\n");
    return &NilSymbol;
}
static LispMacro _LambdaMacro(LAMBDA_sym, ExpandLambda);

Root *ExpandInPackage(AList *mform, TraverseData *data)
{
    // FIXME: Only works if top-level
    if (IsPair(mform->cdr)) {
	AList * args = (AList*)mform->cdr;
	if (args->cdr == &NilSymbol) {
	    const StringC * name = Coerce2String(args->car);
	    Package *pack = LookupPackage(name->chars(), name->leng());
	    if (pack == NULL) {
		fprintf(stderr,
			"Bad package name %s to in-package!\n",
			name->chars());
		return &NilExpr;
	    }
	    CurrentPackage = pack;
	    return &NilExpr;
	}
    }
    fprintf(stderr, "Wrong number of args to 'in-package' macro.\n");
    return &NilSymbol;
}
static LispMacro InPackage(IN_PACKAGE_sym, ExpandInPackage);

Expr *ExpandForms(Root *forms, TraverseData *data, Block *block /*=NULL*/)
{
    AList *pair;
    Root *cur_form;
    if (forms == &NilSymbol) {
	if (block == NULL)
	    return &NilExpr;
	cur_form = &NilExpr;
	forms = &NilSymbol;
    }
    else {
	if (!IsPair(forms)) goto bad_progn;
	pair = (AList*)forms;
	cur_form = pair->car;
	forms = pair->cdr;
    }
    if (block == NULL) {
	if (forms == &NilSymbol)
	    return ExpandLispForm(cur_form, data);
	block = new Block(data->curBlock);
    }
    BlockScan(block, data);
    block->combiner = 1;
    for (;;) {
	AppendStatement(block, ExpandLispForm(cur_form, data));
	if (forms == &NilSymbol)
	    break;
	if (!IsPair(forms))
	    goto  bad_progn;
	pair = (AList*)forms;
	cur_form = pair->car;
	forms = pair->cdr;
    }
    BlockPopDecls(data, block);
    BlockAssignFields(block, data);
    return block;
  bad_progn:
    TrError(data, "E Bad syntax for progn or similar!\n");
    return &NilExpr;
}
Root *ProgNMacro(AList *mform, TraverseData *data)
{
    Root *form = mform->cdr;
    return ExpandForms(form, data);
}
static LispMacro _PrognMacro(PROGN_sym, ProgNMacro); // Common Lisp
static LispMacro _BeginMacro(BEGIN_sym, ProgNMacro); // Scheme

Root* ExpandLispIf(AList *mform, TraverseData *data)
{
    Root *form = mform->cdr;
    if (IsPair(form)) {
	AList *pair1 = (AList*)form;
	if (IsPair(pair1->cdr)) {
	    AList *pair2 = (AList*)pair1->cdr;
	    return new LispIfExpr(ExpandLispForm(pair1->car, data),
				  ExpandLispForm(pair2->car, data),
				  ExpandForms(pair2->cdr, data));
	}
    }
    fprintf(stderr, "Bad if syntax!\n");
    return &NilExpr;
}
static LispMacro IfMacro(IF_sym, ExpandLispIf);

#if 0
void HandleDeclSpec(AList *decl_spec, TraverseData *data)
{
}
#endif

Type* CheckLispTypeSpec(Root* spec, TraverseData *data)
{
    if (spec == &INTEGER_sym)
	return &RefInteger;
    if (spec == &NUMBER_sym)
	return &RefNumeric;
    return NULL;
}

void LispHandleDeclareType(const Type* type, Root* vars, TraverseData *data)
{
    ProcExpr* proc = data->curProc;
    AList* pair;
    for (;vars != &NilSymbol; vars = pair->cdr) {
	if (!IsPair(vars)) {
	    cerr << "Type declaration variables not a list: " << *vars;
	    return;
	}
	pair = (AList*)vars;
	if (pair->car->isA() != Symbol::desc()) {
	    cerr << "Type declaration variable not a symbol: " << *vars;
	    return;
	}
	Symbol* var_name = (Symbol*)pair->car;
	for (ParamExpr* arg = proc->argList; ; arg = arg->next) {
	    if (arg == NULL) {
		cerr << "Implementation restriction: declare type ... ";
		cerr << *var_name << " -- must be a parameter name!\n";
		return;
	    }
	    if (arg->arg_expr.code() != Identifier_code) continue;
	    Identifier* id = arg->arg_expr.ident();
	    if (id->symbol() != var_name) continue;
	    id->type = (Type*)type;
	    id->v.decl->type = id->type;
	    break;
	}
    }
}

void ExpandLispBody(ProcExpr *proc, TraverseData *data)
{
    Root *body = proc->lisp_body;
  restart:
    if (IsPair(body)) {
	AList *pair = (AList*)body;
	if (IsPair(pair->car) && ((AList*)pair->car)->car == &DECLARE_sym) {
	    // Handle (declare ...)
	    Root *decl_body = ((AList*)pair->car)->cdr;
	    body = pair->cdr;
	    while (IsPair(decl_body)) {
		if (IsPair(((AList*)decl_body)->car)) {
		    AList *decl_spec = (AList*)((AList*)decl_body)->car;
		    if (decl_spec->car == &EXTERNAL_sym) {
			if (IsPair(decl_spec->cdr))
			    proc->code_label = ((AList*)decl_spec->cdr)->car;
			if (body == &NilSymbol)
			    proc->flags |= ProcIsExternal;
		    }
		    else if (decl_spec->car == &TYPE_sym
			     && IsPair(decl_spec->cdr)) {
			decl_spec = (AList*)decl_spec->cdr;
			Type* type = CheckLispTypeSpec(decl_spec->car, data);
			if (type == NULL)
			    cout << "Unimplemented declare type: "
				<< *decl_spec->car
				<< ' ' << *decl_spec->cdr << "\n";
			else
			    LispHandleDeclareType(type, decl_spec->cdr, data);
		    }
		    else {
			Type* type = CheckLispTypeSpec(decl_spec->car, data);
			if (type == NULL)
			    cout << "Unimplemented declare: "<< *decl_spec->car
				<< ' ' << *decl_spec->cdr << "\n";
			else
			    LispHandleDeclareType(type, decl_spec->cdr, data);
		    }
		}
		else { // ERROR!
		}
		decl_body = ((AList*)decl_body)->cdr;
	    }
	    if (decl_body != &NilSymbol) { // ERROR!
	    }
	    goto restart;
	}
    }
    // FIXME: Check for documentation string!
    ExpandForms(body, data, proc->expr);
}

Expr *ExpandLispForm(Root *form, TraverseData *data)
{
  restart:
    if (IsPair(form)) {
	AList *pair = (AList*)form;
	if (pair->car->isA() == Symbol::desc()) {
	    Symbol *sym = (Symbol*)pair->car;
#if 0
	    Root *macro = sym->sym_function();
    if (macro == NULL || !(sym->_flags & Symbol::is_macro))
	return &NilSymbol;
    return macro;
#endif
	    if (sym->_flags & Symbol::is_macro) {
		LispMacro *macro = (LispMacro*)sym->sym_function();
		form = (*macro->expander)(pair, data);
		goto restart;
	    }
	}
	TempPtrBuf arg_buf;
	arg_buf.putp(ForceSingle(AsFunction(pair->car, data)));
	form = pair->cdr;
	while (IsPair(form)) {
	    AList *pair = (AList*)form;
	    arg_buf.putp(ForceSingle(ExpandLispForm(pair->car, data)));
	    form = pair->cdr;
	}
	if (form != &NilSymbol) {
	    arg_buf.putp(new MakeTupleExpr(ExpandLispForm(form, data)));
	}
	arg_buf.putp((Expr*)NULL);
	return new ExprList(arg_buf.count()-1, (Expr_Ptr*)arg_buf.copy(0));
    }
    if (form->isA() == Symbol::desc()) {
	Symbol *sym = (Symbol*)form;
	if (sym->_package == &KeywordPackage)
	    return DoQuote(sym);
	Identifier *id = NewIdentifier(sym, NULL);
	if (data->flags & TraverseLisp)
	    id->flags |= IdentValueOnly;
	return id->traverse(data);
    }
    if (form->isKindOf(*Expression::desc()))
	return (Expr*)form;
    return DoQuote(form);
}

Expr * SchemeReadExpr(InStream *stream)
{
#if 0
    if (CurrentPackage == &UserPackage) {
	UserPackage.unuse(&BuiltinPackage);
	UserPackage.use(&CLispPackage);
	UserPackage.use(&SchemePackage);
    }
#endif
    Root *form = LispRead(stream, LispReadPreservingWhitespace+LispReadScheme);
#if 0
    if (CurrentPackage == &UserPackage) {
	UserPackage.unuse(&CLispPackage);
	UserPackage.unuse(&SchemePackage);
	UserPackage.use(&BuiltinPackage);
    }
#endif
    return new LispExpr(form, 1);
}

Expr * LispReadExpr(InStream *stream)
{
#if 0
    if (CurrentPackage == &UserPackage) {
	UserPackage.unuse(&BuiltinPackage);
	UserPackage.use(&CLispPackage);
    }
#endif
    Root *form = LispRead(stream, LispReadPreservingWhitespace);
#if 0
    if (CurrentPackage == &UserPackage) {
	UserPackage.unuse(&CLispPackage);
	UserPackage.use(&BuiltinPackage);
    }
#endif
    return new LispExpr(form, 0);
}

// CLtL:2, section 12.2

Root* ZeroP(Root *arg1)
{
    const Numeric *num = arg1->numeric();
    if (num == NULL)
	Signal(new ParameterFail(arg1, &RefNumeric, &ARG1_str));
    if (num->sign() == 0)
	return &TSymbol;
    else
	return &NilSymbol;
}

Root* PlusP(Root *arg1)
{
    const Numeric *num = arg1->numeric();
    if (num == NULL)
	Signal(new ParameterFail(arg1, &RefNumeric, &ARG1_str));
    if (num->sign() > 0)
	return &TSymbol;
    else
	return &NilSymbol;
}
Root* MinusP(Root *arg1)
{
    const Numeric *num = arg1->numeric();
    if (num == NULL)
	Signal(new ParameterFail(arg1, &RefNumeric, &ARG1_str));
    if (num->sign() < 0)
	return &TSymbol;
    else
	return &NilSymbol;
}

Root* OddP(Root *arg1)
{
    const Integer *n = ConvertInteger(arg1);
    if (n == NULL)
	Signal(new ParameterFail(arg1, &RefInteger, &ARG1_str));
    if (n->odd())
	return &TSymbol;
    else
	return &NilSymbol;
}

Root* EvenP(Root *arg1)
{
    const Integer *n = ConvertInteger(arg1);
    if (n == NULL)
	Signal(new ParameterFail(arg1, &RefInteger, &ARG1_str));
    if (n->odd())
	return &NilSymbol;
    else
	return &TSymbol;
}

// CTtL:2, section 6.3:  Equality predicates

Root* LispEq(Root *x, Root *y)
{
    if (x == y)
	return &TSymbol;
    else
	return &NilSymbol;
}

#define NUMBER_EQL(x, y) \
    const Numeric *xn = (x)->numeric();\
    if (xn) {\
	if (xn->compare(*(y)) == 0) return &TSymbol;\
	else return &NilSymbol;\
    }

Root* LispEql(Root *x, Root *y)
{
    if (x == y)
	return &TSymbol;
    NUMBER_EQL(x, y);
    return &NilSymbol;
}

#define STRING_EQUAL(x, y) \
    StringC *x_str = PTR_CAST(StringC, x);\
    if (x_str) {\
	StringC *y_str = PTR_CAST(StringC, y);\
	if (y_str == NULL) return &NilSymbol;\
	    return x_str->equal(*y_str) ? &TSymbol : &NilSymbol;\
    }
#define BITVECTOR_EQUAL(x, y) { } /* Not implemented --FIXME */
#define PATHNAME_EQUAL(x, y) { } /* Not implemented --FIXME */
#define CONS_EQUAL(x, y, EQUAL) \
    AList *x_cons = PTR_CAST(AList, x);\
    if (x_cons) {\
	AList *y_cons = PTR_CAST(AList, y);\
	if (y_cons == NULL) return &NilSymbol;\
	    if (EQUAL(x_cons->car, y_cons->car) == &NilSymbol)\
		return &NilSymbol;\
	    if (EQUAL(x_cons->cdr, y_cons->cdr) == &NilSymbol)\
		return &NilSymbol;\
	    return &TSymbol;\
    }

Root* LispEqual(Root *x, Root *y)
{
    if (x == y)
	return &TSymbol;
    NUMBER_EQL(x, y);
    STRING_EQUAL(x, y);
    CONS_EQUAL(x, y, LispEqual);
    BITVECTOR_EQUAL(x, y);
    PATHNAME_EQUAL(x, y);
    return &NilSymbol;
}

Root* LispEqualp(Root *x, Root *y)
{
    if (x == y)
	return &TSymbol;
    NUMBER_EQL(x, y);
    STRING_EQUAL(x, y); // Should ignore case --FIXME
    CONS_EQUAL(x, y, LispEqualp);
    BITVECTOR_EQUAL(x, y);
    Signal(new UnimplementedOp("equalp"));
}

// CLtL:2, section 12.3: Comparisons on Numbers

#define LISP_COMPARE(NAME, TEST) \
Root* NAME(Numeric* number, Vector* more_numbers)\
{\
    Root** arg_ptr = more_numbers->start_addr();\
    for (int i = 0; i < more_numbers->leng(); i++) {\
	Root* arg = *arg_ptr++;\
	const Numeric* num = arg->numeric();\
	if (num == NULL) \
	    Signal(new CoercionFail(arg, &RefNumeric));\
	int diff = number->compare(*num);\
	if (!(TEST))\
	    return &NilSymbol;\
	number = (Numeric*)num;\
    }\
    return &TSymbol;\
}

LISP_COMPARE(LispEqu, diff==0)
LISP_COMPARE(LispNeq, diff!=0)
LISP_COMPARE(LispLss, diff<0)
LISP_COMPARE(LispGrt, diff>0)
LISP_COMPARE(LispLeq, diff<=0)
LISP_COMPARE(LispGeq, diff>=0)

#if 0
Root* LispMax(Vector* args)
{
    int i = args->leng();
    Root** arg_ptr = args->start_addr();
    if (i == 0)
	return (Root*)&NegInfinity;
    i--;
    Root* arg = *arg_ptr++;
    Numeric* number = arg->numeric();
    if (number == NULL)
	Signal(new CoerceFail(arg, &RefNumeric));
    for (;;) {
	arg = *arg_ptr++;
	Numeric* arg_num = arg->numeric();
	if (arg_num == NULL)
	    Signal(new CoerceFail(arg, &RefNumeric));
	if (number->compare(*arg_num)
    }
    return number;
}
#endif

// CLtL:2, section 12.4  Arithmetic

Root *MinusOne1(Root *val)
{
    const Numeric *num = val->numeric();
    if (num == NULL) RaiseDomainError(NULL);
    return (Root*)num->sub(*One);
}

void SignalBadArg(Root* arg, int argno, Type* expected)
{
    char buf[20];
    sprintf(buf, "ARG%d", argno);
    Signal(new ParameterFail(arg, expected,
			     NewString(strlen(buf), buf)));
}

Root *LispPlus(Vector *args)
{
    int count = args->leng();
    if (count == 0) return Zero;
    Root** ptr = args->start_addr();
    Numeric *result = NULL;
    while (--count >= 0) {
	Root *arg = *ptr++;
	Numeric *num = arg->numeric();
	if (num == NULL)
	    SignalBadArg(arg, args->leng() - count, &RefNumeric);
	if (result == NULL)
	    result = num;
	else
	    result = result->add(*num);
    }
    return result;
}

Root *LispMinus(Root* arg1, Vector *args)
{
    Numeric *result = arg1->numeric();
    if (result == NULL)
	SignalBadArg(arg1, 1, &RefNumeric);
    int count = args->leng();
    if (count == 0) { // Negate
	return Zero->sub(*result);
    }
    Root** ptr = args->start_addr();
    while (--count >= 0) {
	Root *arg = *ptr++;
	Numeric *num = arg->numeric();
	if (num == NULL)
	    SignalBadArg(arg, args->leng() - count + 1, &RefNumeric);
	result = result->sub(*num);
    }
    return result;
}

Root *LispTimes(Vector *args)
{
    int count = args->leng();
    if (count == 0) return One;
    Root** ptr = args->start_addr();
    Numeric *result = NULL;
    while (--count >= 0) {
	Root *arg = *ptr++;
	Numeric *num = arg->numeric();
	if (num == NULL)
	    SignalBadArg(arg, args->leng() - count, &RefNumeric);
	if (result == NULL)
	    result = num;
	else
	    result = result->mul(*num);
    }
    return result;
}

Root *LispDivide(Root* arg1, Vector *args)
{
    Numeric *result = arg1->numeric();
    if (result == NULL)
	SignalBadArg(arg1, 1, &RefNumeric);
    int count = args->leng();
    if (count == 0) { // Negate
	return One->div(*result);
    }
    Root** ptr = args->start_addr();
    while (--count >= 0) {
	Root *arg = *ptr++;
	Numeric *num = arg->numeric();
	if (num == NULL)
	    SignalBadArg(arg, args->leng() - count + 1, &RefNumeric);
	result = result->div(*num);
    }
    return result;
}

// CLtL:2, section 12.7

const Integer *LogMany(int op, const Vector* args, const Integer* identity)
{
    int count = args->leng();
    if (count == 0) return identity;
    const Integer* result = NULL;
    Root** ptr = args->start_addr();
    while (--count >= 0) {
	const Integer* argi = ConvertInteger(*ptr++);
	if (argi == NULL)
	    SignalBadArg(ptr[-1], args->leng() - count, &RefInteger);
	if (result == NULL) result = argi; 
	else result = &result->boolean(*argi, op);
    }
    return result;
}

Root* LogIor(Vector* args) { return (Root*)LogMany(7, args, Zero); }
Root* LogXor(Vector* args) { return (Root*)LogMany(6, args, Zero); }
Root* LogAnd(Vector* args) { return (Root*)LogMany(1, args, MinusOne); }
Root* LogEqv(Vector* args) { return (Root*)LogMany(9, args, MinusOne); }

Root* LogNand(Integer* arg1, Integer* arg2)
{return (Root*)&arg1->boolean(*arg2, 14);}
Root* LogNor(Integer* arg1, Integer* arg2)
{return (Root*)&arg1->boolean(*arg2, 8);}
Root* LogAndC1(Integer*arg1, Integer* arg2)
{return (Root*)&arg1->boolean(*arg2, 12);}
Root* LogAndC2(Integer*arg1, Integer* arg2)
{return (Root*)&arg1->boolean(*arg2, 10);}
Root* LogOrC1(Integer* arg1, Integer* arg2)
{return (Root*)&arg1->boolean(*arg2, 13);}
Root* LogOrC2(Integer* arg1, Integer* arg2)
{return (Root*)&arg1->boolean(*arg2, 11);}
Root* LogNot(Integer* arg1)
{return (Root*)&arg1->boolean(*Zero, 12);}

Root* BooleOp(Integer* op, Integer* int1, Integer* int2)
{
    return (Root*)&int1->boolean(*int2, op->val & 15);
}

Root * IntegerLength(Integer *arg)
{
    int len = arg->integer_length();
    return (Root*)MakeFixInt(len);
}

Root* LogTest(Integer* arg1, Integer* arg2)
     // (logtest xy) == (not (zerop (logand x y)))
{
    return bit_test(*arg1, *arg2) ? &TSymbol : &NilSymbol;
}

Root* LogBitP(Integer* index, Integer* integer)
{
    if (index->len > 1)
	return integer->is_negative() ? &TSymbol : &NilSymbol;
    index_t i = index->val;
    if (i < 0)
	return &NilSymbol;
    if (integer->bit(i))
	return &TSymbol;
    else
	return &NilSymbol;
}
Root* LogCount(Integer* arg1)
{
    return (Root*)MakeFixInt(bit_count(*arg1));
}

// CLtL2: 12.8.  Byte Manipulation Functions

ByteSpec& Coerce2ByteSpec(Root* arg)
{
    ByteSpec* bs = PTR_CAST(ByteSpec, arg);
    if (bs == NULL)
	Signal(new CoercionFail(arg, ByteSpec::desc()));
    return *bs;
}

Root *
ByteSpecSize(Root* byte_spec)
{
    ByteSpec& bs = Coerce2ByteSpec(byte_spec);
    return (Root*)MakeFixInt(bs.size());
}

Root *
ByteSpecPosition(Root* byte_spec)
{
    ByteSpec& bs = Coerce2ByteSpec(byte_spec);
    return (Root*)MakeFixInt(bs.position());
}

Root* LoadByte(Root* byte_spec, Integer* val)
{
    ByteSpec& bs = Coerce2ByteSpec(byte_spec);
    return (Root*)&val->byte(bs.size(), bs.position());
}
Root* LoadByteTest(Root* byte_spec, Integer* val)
{
    ByteSpec& bs = Coerce2ByteSpec(byte_spec);
    Signal(new UnimplementedOp("ldb-test"));
}
Root* MaskField(Root* byte_spec, Integer* val)
{
    ByteSpec& bs = Coerce2ByteSpec(byte_spec);
    return (Root*)&val->byte(bs.size(), bs.position(), 0, bs.position());
}
Root* DepositByte(Integer* new_byte, Root* byte_spec, Integer* val)
{
    ByteSpec& bs = Coerce2ByteSpec(byte_spec);
    return (Root*)&val->deposit_byte(*new_byte, bs.size(), bs.position(), 0);
}
Root* DepositField(Integer* new_byte, Root* byte_spec, Integer* val)
{
    ByteSpec& bs = Coerce2ByteSpec(byte_spec);
    return (Root*)&val->deposit_byte(*new_byte, bs.size(), bs.position(),
				     bs.position());
}
