xref: /xsrc/external/mit/xedit/dist/lisp/compile.c

/*
 * Copyright (c) 2002 by The XFree86 Project, Inc.
 *
 * Permission is hereby granted, free of charge, to any person obtaining a
 * copy of this software and associated documentation files (the "Software"),
 * to deal in the Software without restriction, including without limitation
 * the rights to use, copy, modify, merge, publish, distribute, sublicense,
 * and/or sell copies of the Software, and to permit persons to whom the
 * Software is furnished to do so, subject to the following conditions:
 *
 * The above copyright notice and this permission notice shall be included in
 * all copies or substantial portions of the Software.
 *
 * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
 * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
 * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.  IN NO EVENT SHALL
 * THE XFREE86 PROJECT BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
 * WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF
 * OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
 * SOFTWARE.
 *
 * Except as contained in this notice, the name of the XFree86 Project shall
 * not be used in advertising or otherwise to promote the sale, use or other
 * dealings in this Software without prior written authorization from the
 * XFree86 Project.
 *
 * Author: Paulo César Pereira de Andrade
 */

/* $XFree86: xc/programs/xedit/lisp/compile.c,v 1.15tsi Exp $ */

#define VARIABLE_USED		0x0001
#define VARIABLE_ARGUMENT	0x0002

/*
 * Prototypes
 */
static void ComPredicate(LispCom*, LispBuiltin*, LispBytePredicate);
static void ComReturnFrom(LispCom*, LispBuiltin*, int);

static int ComConstantp(LispCom*, LispObj*);
static void ComAddVariable(LispCom*, LispObj*, LispObj*);
static int ComGetVariable(LispCom*, LispObj*);
static void ComVariableSetFlag(LispCom*, LispAtom*, int);
#define COM_VARIABLE_USED(atom)				\
    ComVariableSetFlag(com, atom, VARIABLE_USED)
#define COM_VARIABLE_ARGUMENT(atom)			\
	ComVariableSetFlag(com, atom, VARIABLE_ARGUMENT)

static int FindIndex(void*, void**, int);
static int compare(const void*, const void*);
static int BuildTablePointer(void*, void***, int*);

static void ComLabel(LispCom*, LispObj*);
static void ComPush(LispCom*, LispObj*, LispObj*, int, int, int);
static int ComCall(LispCom*, LispArgList*, LispObj*, LispObj*, int, int, int);
static void ComFuncall(LispCom*, LispObj*, LispObj*, int);
static void ComProgn(LispCom*, LispObj*);
static void ComEval(LispCom*, LispObj*);

static void ComRecursiveCall(LispCom*, LispArgList*, LispObj*, LispObj*);
static void ComInlineCall(LispCom*, LispArgList*, LispObj*, LispObj*, LispObj*);

static void ComMacroBackquote(LispCom*, LispObj*);
static void ComMacroCall(LispCom*, LispArgList*, LispObj*, LispObj*, LispObj*);
static LispObj *ComMacroExpandBackquote(LispCom*, LispObj*);
static LispObj *ComMacroExpand(LispCom*, LispObj*);
static LispObj *ComMacroExpandFuncall(LispCom*, LispObj*, LispObj*);
static LispObj *ComMacroExpandEval(LispCom*, LispObj*);

/*
 * Implementation
 */
void
Com_And(LispCom *com, LispBuiltin *builtin)
/*
 and &rest args
 */
{
    LispObj *args;

    args = ARGUMENT(0);

    if (CONSP(args)) {
	/* Evaluate first argument */
	ComEval(com, CAR(args));
	args = CDR(args);

	/* If more than one argument, create jump list */
	if (CONSP(args)) {
	    CodeTree *tree = NULL, *group;

	    group = NEW_TREE(CodeTreeJumpIf);
	    group->code = XBC_JUMPNIL;

	    for (; CONSP(args); args = CDR(args)) {
		ComEval(com, CAR(args));
		tree = NEW_TREE(CodeTreeJumpIf);
		tree->code = XBC_JUMPNIL;
		group->group = tree;
		group = tree;
	    }
	    /*  Finish form the last CodeTree code is changed to sign the
	     * end of the AND list */
	    group->code = XBC_NOOP;
	    if (group)
		group->group = tree;
	}
    }
    else
	/* Identity of AND is T */
	com_Bytecode(com, XBC_T);
}

void
Com_Block(LispCom *com, LispBuiltin *builtin)
/*
 block name &rest body
 */
{

    LispObj *name, *body;

    body = ARGUMENT(1);
    name = ARGUMENT(0);

    if (name != NIL && name != T && !SYMBOLP(name))
	LispDestroy("%s: %s cannot name a block",
		    STRFUN(builtin), STROBJ(name));
    if (CONSP(body)) {
	CompileIniBlock(com, LispBlockTag, name);
	ComProgn(com, body);
	CompileFiniBlock(com);
    }
    else
	/* Just load NIL without starting an empty block */
	com_Bytecode(com, XBC_NIL);
}

void
Com_C_r(LispCom *com, LispBuiltin *builtin)
/*
 c[ad]{1,4}r list
 */
{
    LispObj *list;
    char *desc;

    list = ARGUMENT(0);

    desc = STRFUN(builtin);
    if (*desc == 'F')		/* FIRST */
	desc = "CAR";
    else if (*desc == 'R')	/* REST */
	desc = "CDR";

    /* Check if it is a list of constants */
    while (desc[1] != 'R')
	desc++;
    ComEval(com, list);
    while (*desc != 'C') {
	com_Bytecode(com, *desc == 'A' ? XBC_CAR : XBC_CDR);
	--desc;
    }
}

void
Com_Cond(LispCom *com, LispBuiltin *builtin)
/*
 cond &rest body
 */
{
    int count;
    LispObj *code, *body;
    CodeTree *group, *tree;

    body = ARGUMENT(0);

    count = 0;
    group = NULL;
    if (CONSP(body)) {
	for (; CONSP(body); body = CDR(body)) {
	    code = CAR(body);
	    CHECK_CONS(code);
	    ++count;
	    ComEval(com, CAR(code));
	    tree = NEW_TREE(CodeTreeCond);
	    if (group)
		group->group = tree;
	    tree->code = XBC_JUMPNIL;
	    group = tree;
	    /* The code to execute if the test is true */
	    ComProgn(com, CDR(code));
	    /* Add a node signaling the end of the PROGN code */
	    tree = NEW_TREE(CodeTreeCond);
	    tree->code = XBC_JUMPT;
	    if (group)
		group->group = tree;
	    group = tree;
	}
    }
    if (!count)
	com_Bytecode(com, XBC_NIL);
    else
	/* Where to jump after T progn */
	group->code = XBC_NOOP;
}

void
Com_Cons(LispCom *com, LispBuiltin *builtin)
/*
 cons car cdr
 */
{
    LispObj *car, *cdr;

    cdr = ARGUMENT(1);
    car = ARGUMENT(0);

    if (ComConstantp(com, car) && ComConstantp(com, cdr))
	com_BytecodeCons(com, XBC_CCONS, car, cdr);
    else {
	++com->stack.cpstack;
	if (com->stack.pstack < com->stack.cpstack)
	    com->stack.pstack = com->stack.cpstack;
	ComEval(com, car);
	com_Bytecode(com, XBC_CSTAR);
	ComEval(com, cdr);
	com_Bytecode(com, XBC_CFINI);
	--com->stack.cpstack;
    }
}

void
Com_Consp(LispCom *com, LispBuiltin *builtin)
/*
 consp object
 */
{
    ComPredicate(com, builtin, XBP_CONSP);
}

void
Com_Dolist(LispCom *com, LispBuiltin *builtin)
/*
 dolist init &rest body
 */
{
    int unbound, item;
    LispObj *symbol, *list, *result;
    LispObj *init, *body;
    CodeTree *group, *tree;

    body = ARGUMENT(1);
    init = ARGUMENT(0);

    CHECK_CONS(init);
    symbol = CAR(init);
    CHECK_SYMBOL(symbol);
    CHECK_CONSTANT(symbol);
    init = CDR(init);
    if (CONSP(init)) {
	list = CAR(init);
	init = CDR(init);
    }
    else
	list = NIL;
    if (CONSP(init)) {
	result = CAR(init);
	if (CONSP(CDR(init)))
	    LispDestroy("%s: too many arguments %s",
			STRFUN(builtin), STROBJ(CDR(init)));
    }
    else
	result = NIL;

    /*	Generate code for the body of the form.
     *	The generated code uses two objects unavailable to user code,
     * in the format:
     *	(block NIL
     *	    (let ((? list) (item NIL))
     *		(tagbody
     *		    .			    ; the DOT object as a label
     *		    (when (consp list)
     *			(setq item (car ?))
     *			@body		    ; code to be executed
     *			(setq ? (cdr ?))
     *			(go .)
     *		    )
     *		)
     *		(setq item nil)
     *		result
     *	    )
     *	)
     */

    /* XXX All of the logic below should be simplified at some time
     * by adding more opcodes for compound operations ... */

    /* Relative offsets the locally added variables will have at run time */
    unbound = lisp__data.env.length - lisp__data.env.lex;
    item = unbound + 1;

    /* Start BLOCK NIL */
    FORM_ENTER();
    CompileIniBlock(com, LispBlockTag, NIL);

    /* Add the <?> variable */
    ComPush(com, UNBOUND, list, 1, 0, 0);
    /* Add the <item> variable */
    ComPush(com, symbol, NIL, 0, 0, 0);
    /* Stack length is increased */
    CompileStackEnter(com, 2, 0);
    /* Bind variables */
    com_Bind(com, 2);
    com->block->bind += 2;
    lisp__data.env.head += 2;

    /* Remember that iteration variable is used even if it not referenced */
    COM_VARIABLE_USED(symbol->data.atom);

    /* Initialize the TAGBODY */
    FORM_ENTER();
    CompileIniBlock(com, LispBlockBody, NIL);

    /* Create the <.> label */
    ComLabel(com, DOT);

    /* Load <?> variable */
    com_BytecodeShort(com, XBC_LOAD, unbound);
    /* Check if <?> is a list */
    com_BytecodeChar(com, XBC_PRED, XBP_CONSP);

    /* Start WHEN block */
    group = NEW_TREE(CodeTreeJumpIf);
    group->code = XBC_JUMPNIL;
    /* Load <?> again */
    com_BytecodeShort(com, XBC_LOAD, unbound);
    /* Get CAR of <?> */
    com_Bytecode(com, XBC_CAR);
    /* Store it in <item> */
    com_BytecodeShort(com, XBC_SET, item);
    /* Execute @BODY */
    ComProgn(com, body);

    /* Load <?> again */
    com_BytecodeShort(com, XBC_LOAD, unbound);
    /* Get CDR of <?> */
    com_Bytecode(com, XBC_CDR);
    /* Change value of <?> */
    com_BytecodeShort(com, XBC_SET, unbound);

    /* GO back to <.> */
    tree = NEW_TREE(CodeTreeGo);
    tree->data.object = DOT;

    /* Finish WHEN block */
    tree = NEW_TREE(CodeTreeJumpIf);
    tree->code = XBC_NOOP;
    group->group = tree;

    /* Finish the TAGBODY */
    CompileFiniBlock(com);
    FORM_LEAVE();

    /* Set <item> to NIL, in case result references it...
     * Loaded value is NIL as the CONSP predicate */
    com_BytecodeShort(com, XBC_SET, item);

    /* Evaluate <result> */
    ComEval(com, result);

    /* Unbind variables */
    lisp__data.env.head -= 2;
    lisp__data.env.length -= 2;
    com->block->bind -= 2;
    com_Unbind(com, 2);
    /* Stack length is reduced. */
    CompileStackLeave(com, 2, 0);

    /* Finish BLOCK NIL */
    CompileFiniBlock(com);
    FORM_LEAVE();
}

void
Com_Eq(LispCom *com, LispBuiltin *builtin)
/*
 eq left right
 eql left right
 equal left right
 equalp left right
 */
{
    LispObj *left, *right;
    LispByteOpcode code;
    char *name;

    right = ARGUMENT(1);
    left = ARGUMENT(0);

    CompileStackEnter(com, 1, 1);
    /* Just like preparing to call a builtin function */
    ComEval(com, left);
    com_Bytecode(com, XBC_PUSH);
    /* The second argument is now loaded */
    ComEval(com, right);

    /* Compare arguments and restore builtin stack */
    name = STRFUN(builtin);
    switch (name[3]) {
	case 'L':
	    code = XBC_EQL;
	    break;
	case 'U':
	    code = name[5] == 'P' ? XBC_EQUALP : XBC_EQUAL;
	    break;
	default:
	    code = XBC_EQ;
	    break;
    }
    com_Bytecode(com, code);

    CompileStackLeave(com, 1, 1);
}

void
Com_Go(LispCom *com, LispBuiltin *builtin)
/*
 go tag
 */
{
    int bind;
    LispObj *tag;
    CodeTree *tree;
    CodeBlock *block;

    tag = ARGUMENT(0);

    block = com->block;
    bind = block->bind;

    while (block) {
	if (block->type == LispBlockClosure || block->type == LispBlockBody)
	    break;
	block = block->prev;
	if (block)
	    bind += block->bind;
    }

    if (!block || block->type != LispBlockBody)
	LispDestroy("%s called not within a block", STRFUN(builtin));

    /* Unbind any local variables */
    com_Unbind(com, bind);
    tree = NEW_TREE(CodeTreeGo);
    tree->data.object = tag;
}

void
Com_If(LispCom *com, LispBuiltin *builtin)
/*
 if test then &optional else
 */
{
    CodeTree *group, *tree;
    LispObj *test, *then, *oelse;

    oelse = ARGUMENT(2);
    then = ARGUMENT(1);
    test = ARGUMENT(0);

    /* Build code to execute test */
    ComEval(com, test);

    /* Add jump node to use if test is NIL */
    group = NEW_TREE(CodeTreeJumpIf);
    group->code = XBC_JUMPNIL;

    /* Build T code */
    ComEval(com, then);

    if (oelse != UNSPEC) {
	/* Remember start of NIL code */
	tree = NEW_TREE(CodeTreeJump);
	tree->code = XBC_JUMP;
	group->group = tree;
	group = tree;
	/* Build NIL code */
	ComEval(com, oelse);
    }

    /* Remember jump of T code */
    tree = NEW_TREE(CodeTreeJumpIf);
    tree->code = XBC_NOOP;
    group->group = tree;
}

void
Com_Last(LispCom *com, LispBuiltin *builtin)
/*
 last list &optional count
 */
{
    LispObj *list, *count;

    count = ARGUMENT(1);
    list = ARGUMENT(0);

    ComEval(com, list);
    CompileStackEnter(com, 1, 1);
    com_Bytecode(com, XBC_PUSH);
    if (count == UNSPEC)
	count = FIXNUM(1);
    ComEval(com, count);
    CompileStackLeave(com, 1, 1);
    com_Bytecode(com, XBC_LAST);
}

void
Com_Length(LispCom *com, LispBuiltin *builtin)
/*
 length sequence
 */
{
    LispObj *sequence;

    sequence = ARGUMENT(0);

    ComEval(com, sequence);
    com_Bytecode(com, XBC_LENGTH);
}

void
Com_Let(LispCom *com, LispBuiltin *builtin)
/*
 let init &rest body
 */
{
    int count;
    LispObj *symbol, *value, *pair;

    LispObj *init, *body;

    body = ARGUMENT(1);
    init = ARGUMENT(0);

    if (init == NIL) {
	/* If no local variables */
	ComProgn(com, body);
	return;
    }
    CHECK_CONS(init);

    /* Could optimize if the body is empty and the
     * init form is known to have no side effects */

    for (count = 0; CONSP(init); init = CDR(init), count++) {
	pair = CAR(init);
	if (CONSP(pair)) {
	    symbol = CAR(pair);
	    pair = CDR(pair);
	    if (CONSP(pair)) {
		value = CAR(pair);
		if (CDR(pair) != NIL)
		    LispDestroy("%s: too much arguments to initialize %s",
				STRFUN(builtin), STROBJ(symbol));
	    }
	    else
		value = NIL;
	}
	else {
	    symbol = pair;
	    value = NIL;
	}
	CHECK_SYMBOL(symbol);
	CHECK_CONSTANT(symbol);

	/* Add the variable */
	ComPush(com, symbol, value, 1, 0, 0);
    }

    /* Stack length is increased */
    CompileStackEnter(com, count, 0);
    /* Bind the added variables */
    com_Bind(com, count);
    com->block->bind += count;
    lisp__data.env.head += count;
    /* Generate code for the body of the form */
    ComProgn(com, body);
    /* Unbind the added variables */
    lisp__data.env.head -= count;
    lisp__data.env.length -= count;
    com->block->bind -= count;
    com_Unbind(com, count);
    /* Stack length is reduced. */
    CompileStackLeave(com, count, 0);
}

void
Com_Letx(LispCom *com, LispBuiltin *builtin)
/*
 let* init &rest body
 */
{
    int count;
    LispObj *symbol, *value, *pair;

    LispObj *init, *body;

    body = ARGUMENT(1);
    init = ARGUMENT(0);

    if (init == NIL) {
	/* If no local variables */
	ComProgn(com, body);
	return;
    }
    CHECK_CONS(body);

    /* Could optimize if the body is empty and the
     * init form is known to have no side effects */

    for (count = 0; CONSP(init); init = CDR(init), count++) {
	pair = CAR(init);
	if (CONSP(pair)) {
	    symbol = CAR(pair);
	    pair = CDR(pair);
	    if (CONSP(pair)) {
		value = CAR(pair);
		if (CDR(pair) != NIL)
		    LispDestroy("%s: too much arguments to initialize %s",
				STRFUN(builtin), STROBJ(symbol));
	    }
	    else
		value = NIL;
	}
	else {
	    symbol = pair;
	    value = NIL;
	}
	CHECK_SYMBOL(symbol);
	CHECK_CONSTANT(symbol);

	/* LET* is identical to &AUX arguments, just bind the symbol */
	ComPush(com, symbol, value, 1, 0, 0);
	/* Every added variable is binded */
	com_Bind(com, 1);
	/* Must be binded at compile time also */
	++lisp__data.env.head;
	++com->block->bind;
    }

    /* Generate code for the body of the form */
    CompileStackEnter(com, count, 0);
    ComProgn(com, body);
    com_Unbind(com, count);
    com->block->bind -= count;
    lisp__data.env.head -= count;
    lisp__data.env.length -= count;
    CompileStackLeave(com, count, 0);
}

void
Com_Listp(LispCom *com, LispBuiltin *builtin)
/*
 listp object
 */
{
    ComPredicate(com, builtin, XBP_LISTP);
}

void
Com_Loop(LispCom *com, LispBuiltin *builtin)
/*
 loop &rest body
 */
{
    CodeTree *tree, *group;
    LispObj *body;

    body = ARGUMENT(0);

    /* Start NIL block */
    CompileIniBlock(com, LispBlockTag, NIL);

    /* Insert node to mark LOOP start */
    tree = NEW_TREE(CodeTreeJump);
    tree->code = XBC_NOOP;

    /* Execute @BODY */
    if (CONSP(body))
	ComProgn(com, body);
    else
	/* XXX bytecode.c code require that blocks have at least one opcode */
	com_Bytecode(com, XBC_NIL);

    /* Insert node to jump of start of LOOP */
    group = NEW_TREE(CodeTreeJump);
    group->code = XBC_JUMP;
    group->group = tree;

    /* Finish NIL block */
    CompileFiniBlock(com);
}

void
Com_Nthcdr(LispCom *com, LispBuiltin *builtin)
/*
 nthcdr index list
 */
{
    LispObj *oindex, *list;

    list = ARGUMENT(1);
    oindex = ARGUMENT(0);

    ComEval(com, oindex);
    CompileStackEnter(com, 1, 1);
    com_Bytecode(com, XBC_PUSH);
    ComEval(com, list);
    CompileStackLeave(com, 1, 1);
    com_Bytecode(com, XBC_NTHCDR);
}

void
Com_Null(LispCom *com, LispBuiltin *builtin)
/*
 null list
 */
{
    LispObj *list;

    list = ARGUMENT(0);

    if (list == NIL)
	com_Bytecode(com, XBC_T);
    else if (ComConstantp(com, list))
	com_Bytecode(com, XBC_NIL);
    else {
	ComEval(com, list);
	com_Bytecode(com, XBC_INV);
    }
}

void
Com_Numberp(LispCom *com, LispBuiltin *builtin)
/*
 numberp object
 */
{
    ComPredicate(com, builtin, XBP_NUMBERP);
}

void
Com_Or(LispCom *com, LispBuiltin *builtin)
/*
 or &rest args
 */
{
    LispObj *args;

    args = ARGUMENT(0);

    if (CONSP(args)) {
	/* Evaluate first argument */
	ComEval(com, CAR(args));
	args = CDR(args);

	/* If more than one argument, create jump list */
	if (CONSP(args)) {
	    CodeTree *tree = NULL, *group;

	    group = NEW_TREE(CodeTreeJumpIf);
	    group->code = XBC_JUMPT;

	    for (; CONSP(args); args = CDR(args)) {
		ComEval(com, CAR(args));
		tree = NEW_TREE(CodeTreeJumpIf);
		tree->code = XBC_JUMPT;
		group->group = tree;
		group = tree;
	    }
	    /*  Finish form the last CodeTree code is changed to sign the
	     * end of the AND list */
	    group->code = XBC_NOOP;
	    group->group = tree;
	}
    }
    else
	/* Identity of OR is NIL */
	com_Bytecode(com, XBC_NIL);
}

void
Com_Progn(LispCom *com, LispBuiltin *builtin)
/*
 progn &rest body
 */
{
    LispObj *body;

    body = ARGUMENT(0);

    ComProgn(com, body);
}

void
Com_Return(LispCom *com, LispBuiltin *builtin)
/*
 return &optional result
 */
{
    ComReturnFrom(com, builtin, 0);
}

void
Com_ReturnFrom(LispCom *com, LispBuiltin *builtin)
/*
 return-from name &optional result
 */
{
    ComReturnFrom(com, builtin, 1);
}

void
Com_Rplac_(LispCom *com, LispBuiltin *builtin)
/*
 rplac[ad] place value
 */
{
    LispObj *place, *value;

    value = ARGUMENT(1);
    place = ARGUMENT(0);

    CompileStackEnter(com, 1, 1);
    ComEval(com, place);
    com_Bytecode(com, XBC_PUSH);
    ComEval(com, value);
    com_Bytecode(com, STRFUN(builtin)[5] == 'A' ? XBC_RPLACA : XBC_RPLACD);
    CompileStackLeave(com, 1, 1);
}

void
Com_Setq(LispCom *com, LispBuiltin *builtin)
/*
 setq &rest form
 */
{
    int offset;
    LispObj *form, *symbol, *value;

    form = ARGUMENT(0);

    for (; CONSP(form); form = CDR(form)) {
	symbol = CAR(form);
	CHECK_SYMBOL(symbol);
	CHECK_CONSTANT(symbol);
	form = CDR(form);
	if (!CONSP(form))
	    LispDestroy("%s: odd number of arguments", STRFUN(builtin));
	value = CAR(form);
	/* Generate code to load value */
	ComEval(com, value);
	offset = ComGetVariable(com, symbol);
	if (offset >= 0)
	    com_Set(com, offset);
	else
	    com_SetSym(com, symbol->data.atom);
    }
}

void
Com_Tagbody(LispCom *com, LispBuiltin *builtin)
/*
 tagbody &rest body
 */
{
    LispObj *body;

    body = ARGUMENT(0);

    if (CONSP(body)) {
	CompileIniBlock(com, LispBlockBody, NIL);
	ComProgn(com, body);
	/* Tagbody returns NIL */
	com_Bytecode(com, XBC_NIL);
	CompileFiniBlock(com);
    }
    else
	/* Tagbody always returns NIL */
	com_Bytecode(com, XBC_NIL);
}

void
Com_Unless(LispCom *com, LispBuiltin *builtin)
/*
 unless test &rest body
 */
{
    CodeTree *group, *tree;
    LispObj *test, *body;

    body = ARGUMENT(1);
    test = ARGUMENT(0);

    /* Generate code to evaluate test */
    ComEval(com, test);
    /* Add node after test */
    group = NEW_TREE(CodeTreeJumpIf);
    group->code = XBC_JUMPT;
    /* Generate NIL code */
    ComProgn(com, body);
    /* Insert node to know where to jump if test is T */
    tree = NEW_TREE(CodeTreeJumpIf);
    tree->code = XBC_NOOP;
    group->group = tree;
}

void
Com_Until(LispCom *com, LispBuiltin *builtin)
/*
 until test &rest body
 */
{
    CodeTree *tree, *group, *ltree, *lgroup;
    LispObj *test, *body;

    body = ARGUMENT(1);
    test = ARGUMENT(0);

    /* Insert node to mark LOOP start */
    ltree = NEW_TREE(CodeTreeJump);
    ltree->code = XBC_NOOP;

    /* Build code for test */
    ComEval(com, test);
    group = NEW_TREE(CodeTreeJumpIf);
    group->code = XBC_JUMPT;

    /* Execute @BODY */
    ComProgn(com, body);

    /* Insert node to jump to test again */
    lgroup = NEW_TREE(CodeTreeJump);
    lgroup->code = XBC_JUMP;
    lgroup->group = ltree;

    /* Insert node to know where to jump if test is T */
    tree = NEW_TREE(CodeTreeJumpIf);
    tree->code = XBC_NOOP;
    group->group = tree;
}

void
Com_When(LispCom *com, LispBuiltin *builtin)
/*
 when test &rest body
 */
{
    CodeTree *group, *tree;
    LispObj *test, *body;

    body = ARGUMENT(1);
    test = ARGUMENT(0);

    /* Generate code to evaluate test */
    ComEval(com, test);
    /* Add node after test */
    group = NEW_TREE(CodeTreeJumpIf);
    group->code = XBC_JUMPNIL;
    /* Generate T code */
    ComProgn(com, body);
    /* Insert node to know where to jump if test is NIL */
    tree = NEW_TREE(CodeTreeJumpIf);
    tree->code = XBC_NOOP;
    group->group = tree;
}

void
Com_While(LispCom *com, LispBuiltin *builtin)
/*
 while test &rest body
 */
{
    CodeTree *tree, *group, *ltree, *lgroup;
    LispObj *test, *body;

    body = ARGUMENT(1);
    test = ARGUMENT(0);

    /* Insert node to mark LOOP start */
    ltree = NEW_TREE(CodeTreeJump);
    ltree->code = XBC_NOOP;

    /* Build code for test */
    ComEval(com, test);
    group = NEW_TREE(CodeTreeJumpIf);
    group->code = XBC_JUMPNIL;

    /* Execute @BODY */
    ComProgn(com, body);

    /* Insert node to jump to test again */
    lgroup = NEW_TREE(CodeTreeJump);
    lgroup->code = XBC_JUMP;
    lgroup->group = ltree;

    /* Insert node to know where to jump if test is NIL */
    tree = NEW_TREE(CodeTreeJumpIf);
    tree->code = XBC_NOOP;
    group->group = tree;
}


/***********************************************************************
 * Com_XXX helper functions
 ***********************************************************************/
static void
ComPredicate(LispCom *com, LispBuiltin *builtin, LispBytePredicate predicate)
{
    LispObj *object;

    object = ARGUMENT(0);

    if (ComConstantp(com, object)) {
	switch (predicate) {
	    case XBP_CONSP:
		com_Bytecode(com, CONSP(object) ? XBC_T : XBC_NIL);
		break;
	    case XBP_LISTP:
		com_Bytecode(com, CONSP(object) || object == NIL ?
			     XBC_T : XBC_NIL);
		break;
	    case XBP_NUMBERP:
		com_Bytecode(com, NUMBERP(object) ? XBC_T : XBC_NIL);
		break;
	}
    }
    else {
	ComEval(com, object);
	com_BytecodeChar(com, XBC_PRED, predicate);
    }
}

/* XXX Could receive an argument telling if is the last statement in the
 * block(s), i.e. if a jump opcode should be generated or just the
 * evaluation of the returned value. Probably this is better done in
 * an optimization step. */
static void
ComReturnFrom(LispCom *com, LispBuiltin *builtin, int from)
{
    int bind;
    CodeTree *tree;
    LispObj *name, *result;
    CodeBlock *block = com->block;

    if (from) {
	result = ARGUMENT(1);
	name = ARGUMENT(0);
    }
    else {
	result = ARGUMENT(0);
	name = NIL;
    }
    if (result == UNSPEC)
	result = NIL;

    bind = block->bind;
    while (block) {
	if (block->type == LispBlockClosure)
	    /* A function call */
	    break;
	else if (block->type == LispBlockTag && block->tag == name)
	    break;
	block = block->prev;
	if (block)
	    bind += block->bind;
    }

    if (!block || block->tag != name)
	LispDestroy("%s: no visible %s block", STRFUN(builtin), STROBJ(name));

    /* Generate code to load result */
    ComEval(com, result);

    /* Check for added variables that the jump is skiping the unbind opcode */
    com_Unbind(com, bind);

    tree = NEW_TREE(CodeTreeReturn);
    tree->data.block = block;
}

/***********************************************************************
 * Helper functions
 ***********************************************************************/
static int
ComConstantp(LispCom *com, LispObj *object)
{
    switch (OBJECT_TYPE(object)) {
	case LispAtom_t:
	    /* Keywords are guaranteed to evaluate to itself */
	    if (object->data.atom->package == lisp__data.keyword)
		break;
	    return (0);

	    /* Function call */
	case LispCons_t:

	    /* Need macro expansion, these are special abstract objects */
	case LispQuote_t:
	case LispBackquote_t:
	case LispComma_t:
	case LispFunctionQuote_t:
	    return (0);

	    /* Anything else is a literal constant */
	default:
	    break;
    }

    return (1);
}

static int
FindIndex(void *item, void **table, int length)
{
    long cmp;
    int left, right, i;

    left = 0;
    right = length - 1;
    while (left <= right) {
	i = (left + right) >> 1;
	cmp = (char*)item - (char*)table[i];
	if (cmp == 0)
	    return (i);
	else if (cmp < 0)
	    right = i - 1;
	else
	    left = i + 1;
    }

    return (-1);
}

static int
compare(const void *left, const void *right)
{
    long cmp = *(char**)left - *(char**)right;

    return (cmp < 0 ? -1 : 1);
}

static int
BuildTablePointer(void *pointer, void ***pointers, int *num_pointers)
{
    int i;

    if ((i = FindIndex(pointer, *pointers, *num_pointers)) < 0) {
	*pointers = LispRealloc(*pointers,
				sizeof(void*) * (*num_pointers + 1));
	(*pointers)[*num_pointers] = pointer;
	if (++*num_pointers > 1)
	    qsort(*pointers, *num_pointers, sizeof(void*), compare);
	i = FindIndex(pointer, *pointers, *num_pointers);
    }

    return (i);
}

static void
ComAddVariable(LispCom *com, LispObj *symbol, LispObj *value)
{
    LispAtom *atom = symbol->data.atom;

    if (atom && atom->string && !com->macro) {
	int i, length = com->block->variables.length;

	i = BuildTablePointer(atom, (void***)&com->block->variables.symbols,
			      &com->block->variables.length);

	if (com->block->variables.length != length) {
	    com->block->variables.flags =
		LispRealloc(com->block->variables.flags,
			    com->block->variables.length * sizeof(int));

	    /* Variable was inserted in the middle of the list */
	    if (i < length)
		memmove(com->block->variables.flags + i + 1,
			com->block->variables.flags + i,
			(length - i) * sizeof(int));

	    com->block->variables.flags[i] = 0;
	}
    }

    LispAddVar(symbol, value);
}

static int
ComGetVariable(LispCom *com, LispObj *symbol)
{
    LispAtom *name;
    int i, base, offset;
    Atom_id id;

    name = symbol->data.atom;
    if (name->constant) {
	if (name->package == lisp__data.keyword)
	    /*	Just load <symbol> from the byte stream, keywords are
	     * guaranteed to evaluate to itself. */
	    return (SYMBOL_KEYWORD);
	return (SYMBOL_CONSTANT);
    }

    offset = name->offset;
    id = name->string;
    base = lisp__data.env.lex;
    i = lisp__data.env.head - 1;

    /* If variable is local */
    if (offset <= i && offset >= com->lex && lisp__data.env.names[offset] == id) {
	COM_VARIABLE_USED(name);
	/* Relative offset */
	return (offset - base);
    }

    /* name->offset may have been changed in a macro expansion */
    for (; i >= com->lex; i--)
	if (lisp__data.env.names[i] == id) {
	    name->offset = i;
	    COM_VARIABLE_USED(name);
	    return (i - base);
	}

    if (!name->a_object) {
	++com->warnings;
	LispWarning("variable %s is neither declared nor bound",
		    name->string);
    }

    /* Not found, resolve <symbol> at run time */
    return (SYMBOL_UNBOUND);
}

static void
ComVariableSetFlag(LispCom *com, LispAtom *atom, int flag)
{
    int i;
    CodeBlock *block = com->block;

    while (block) {
	i = FindIndex(atom, (void**)block->variables.symbols,
		      block->variables.length);
	if (i >= 0) {
	    block->variables.flags[i] |= flag;
	    /*  Descend block list if an argument to function being called
	     * has the same name as a bound variable in the current function.
	     */
	    if ((flag & VARIABLE_ARGUMENT) ||
		!(block->variables.flags[i] & VARIABLE_ARGUMENT))
		break;
	}
	block = block->prev;
    }
}

/***********************************************************************
 * Bytecode compiler functions
 ***********************************************************************/
static void
ComLabel(LispCom *com, LispObj *label)
{
    int i;
    CodeTree *tree;

    for (i = 0; i < com->block->tagbody.length; i++)
	if (label == com->block->tagbody.labels[i])
	    LispDestroy("TAGBODY: tag %s specified more than once",
			STROBJ(label));

    if (com->block->tagbody.length >= com->block->tagbody.space) {
	com->block->tagbody.labels =
	    LispRealloc(com->block->tagbody.labels,
			sizeof(LispObj*) * (com->block->tagbody.space + 8));
	/*  Reserve space, will be used at link time when
	 * resolving GO jumps. */
	com->block->tagbody.codes =
	    LispRealloc(com->block->tagbody.codes,
			sizeof(CodeTree*) * (com->block->tagbody.space + 8));
	com->block->tagbody.space += 8;
    }

    com->block->tagbody.labels[com->block->tagbody.length++] = label;
    tree = NEW_TREE(CodeTreeLabel);
    tree->data.object = label;
}

static void
ComPush(LispCom *com, LispObj *symbol, LispObj *value,
	int eval, int builtin, int compile)
{
    /*  If <compile> is set, it is pushing an argument to one of
     * Com_XXX functions. */
    if (compile) {
	if (builtin)
	    lisp__data.stack.values[lisp__data.stack.length++] = value;
	else
	    ComAddVariable(com, symbol, value);
	return;
    }

    /*  If <com->macro> is set, it is expanding a macro, just add the local
     * variable <symbol> bounded to <value>, so that it will be available
     * when calling the interpreter to expand the macro. */
    else if (com->macro) {
	ComAddVariable(com, symbol, value);
	return;
    }

    /*  If <eval> is set, it must generate the opcodes to evaluate <value>.
     * If <value> is a constant, just generate the opcodes to load it. */
    else if (eval && !ComConstantp(com, value)) {
	switch (OBJECT_TYPE(value)) {
	    case LispAtom_t: {
		int offset = ComGetVariable(com, value);

		if (offset >= 0) {
		    /* Load <value> from user stack at the relative offset */
		    if (builtin)
			com_LoadPush(com, offset);
		    else
			com_LoadLet(com, offset, symbol->data.atom);
		}
		/* ComConstantp() does not return true for this, as the
		 * current value must be computed. */
		else if (offset == SYMBOL_CONSTANT) {
		    value = value->data.atom->property->value;
		    if (builtin)
			com_LoadConPush(com, value);
		    else
			com_LoadConLet(com, value, symbol->data.atom);
		}
		else {
		    /* Load value bound to <value> at run time */
		    if (builtin)
			com_LoadSymPush(com, value->data.atom);
		    else
			com_LoadSymLet(com, value->data.atom,
				       symbol->data.atom);
		}
	    }	break;

	    default:
		/* Generate code to evaluate <value> */
		ComEval(com, value);
		if (builtin)
		    com_Bytecode(com, XBC_PUSH);
		else
		    com_Let(com, symbol->data.atom);
		break;
	}

	/*  Remember <symbol> will be bound, <value> only matters for
	 * the Com_XXX  functions */
	if (builtin)
	    lisp__data.stack.values[lisp__data.stack.length++] = value;
	else
	    ComAddVariable(com, symbol, value);
	return;
    }

    if (builtin) {
	/* Load <value> as a constant in builtin stack */
	com_LoadConPush(com, value);
	lisp__data.stack.values[lisp__data.stack.length++] = value;
    }
    else {
	/* Load <value> as a constant in stack */
	com_LoadConLet(com, value, symbol->data.atom);
	/* Remember <symbol> will be bound */
	ComAddVariable(com, symbol, value);
    }
}

/*  This function does almost the same job as LispMakeEnvironment, but
 * it is not optimized for speed, as it is not building argument lists
 * to user code, but to Com_XXX functions, or helping in generating the
 * opcodes to load arguments at bytecode run time. */
static int
ComCall(LispCom *com, LispArgList *alist,
	LispObj *name, LispObj *values,
	int eval, int builtin, int compile)
{
    char *desc;
    int i, count, base;
    LispObj **symbols, **defaults, **sforms;

    if (builtin) {
	base = lisp__data.stack.length;
	/* This should never be executed, but make the check for safety */
	if (base + alist->num_arguments > lisp__data.stack.space) {
	    do
		LispMoreStack();
	    while (base + alist->num_arguments > lisp__data.stack.space);
	}
    }
    else
	base = lisp__data.env.length;

    desc = alist->description;
    switch (*desc++) {
	case '.':
	    goto normal_label;
	case 'o':
	    goto optional_label;
	case 'k':
	    goto key_label;
	case 'r':
	    goto rest_label;
	case 'a':
	    goto aux_label;
	default:
	    goto done_label;
    }


    /* Normal arguments */
normal_label:
    i = 0;
    symbols = alist->normals.symbols;
    count = alist->normals.num_symbols;
    for (; i < count && CONSP(values); i++, values = CDR(values)) {
	ComPush(com, symbols[i], CAR(values), eval, builtin, compile);
	if (!builtin && !com->macro)
	    COM_VARIABLE_ARGUMENT(symbols[i]->data.atom);
    }
    if (i < count)
	LispDestroy("%s: too few arguments", STROBJ(name));

    switch (*desc++) {
	case 'o':
	    goto optional_label;
	case 'k':
	    goto key_label;
	case 'r':
	    goto rest_label;
	case 'a':
	    goto aux_label;
	default:
	    goto done_label;
    }


    /* &OPTIONAL */
optional_label:
    i = 0;
    count = alist->optionals.num_symbols;
    symbols = alist->optionals.symbols;
    defaults = alist->optionals.defaults;
    sforms = alist->optionals.sforms;
    for (; i < count && CONSP(values); i++, values = CDR(values)) {
	ComPush(com, symbols[i], CAR(values), eval, builtin, compile);
	if (!builtin && !com->macro)
	    COM_VARIABLE_ARGUMENT(symbols[i]->data.atom);
	if (sforms[i]) {
	    ComPush(com, sforms[i], T, 0, builtin, compile);
	    if (!builtin && !com->macro)
		COM_VARIABLE_ARGUMENT(sforms[i]->data.atom);
	}
    }
    for (; i < count; i++) {
	if (!builtin) {
	    int lex = com->lex;
	    int head = lisp__data.env.head;

	    com->lex = base;
	    lisp__data.env.head = lisp__data.env.length;
	    /* default arguments are evaluated for macros */
	    ComPush(com, symbols[i], defaults[i], 1, 0, compile);
	    if (!com->macro)
		COM_VARIABLE_ARGUMENT(symbols[i]->data.atom);
	    lisp__data.env.head = head;
	    com->lex = lex;
	}
	else
	    ComPush(com, symbols[i], defaults[i], eval, 1, compile);
	if (sforms[i]) {
	    ComPush(com, sforms[i], NIL, 0, builtin, compile);
	    if (!builtin && !com->macro)
		COM_VARIABLE_ARGUMENT(sforms[i]->data.atom);
	}
    }

    switch (*desc++) {
	case 'k':
	    goto key_label;
	case 'r':
	    goto rest_label;
	case 'a':
	    goto aux_label;
	default:
	    goto done_label;
    }


    /* &KEY */
key_label:
    {
	int varset;
	LispObj *val, *karg, **keys;

	count = alist->keys.num_symbols;
	symbols = alist->keys.symbols;
	defaults = alist->keys.defaults;
	sforms = alist->keys.sforms;
	keys = alist->keys.keys;

	/* Check if arguments are correctly specified */
	for (karg = values; CONSP(karg); karg = CDR(karg)) {
	    val = CAR(karg);
	    if (KEYWORDP(val)) {
		for (i = 0; i < alist->keys.num_symbols; i++)
		    if (!keys[i] && symbols[i] == val)
			break;
	    }

	    else if (!builtin &&
		     QUOTEP(val) && SYMBOLP(val->data.quote)) {
		for (i = 0; i < alist->keys.num_symbols; i++)
		    if (keys[i] && ATOMID(keys[i]) == ATOMID(val->data.quote))
			break;
	    }

	    else
		/* Just make the error test true */
		i = alist->keys.num_symbols;

	    if (i == alist->keys.num_symbols) {
		/* If not in argument specification list... */
		char function_name[36];

		strcpy(function_name, STROBJ(name));
		LispDestroy("%s: invalid keyword %s",
			    function_name, STROBJ(val));
	    }

	    karg = CDR(karg);
	    if (!CONSP(karg))
		LispDestroy("%s: &KEY needs arguments as pairs",
			    STROBJ(name));
	}

	/* Add variables */
	for (i = 0; i < alist->keys.num_symbols; i++) {
	    val = defaults[i];
	    varset = 0;
	    if (!builtin && keys[i]) {
		Atom_id atom = ATOMID(keys[i]);

		/* Special keyword specification, need to compare ATOMID
		 * and keyword specification must be a quoted object */
		for (karg = values; CONSP(karg); karg = CDR(karg)) {
		    val = CAR(karg);
		    if (QUOTEP(val) && atom == ATOMID(val->data.quote)) {
			val = CADR(karg);
			varset = 1;
			break;
		    }
		    karg = CDR(karg);
		}
	    }

	    else {
		/* Normal keyword specification, can compare object pointers,
		 * as they point to the same object in the keyword package */
		for (karg = values; CONSP(karg); karg = CDR(karg)) {
		    /* Don't check if argument is a valid keyword or
		     * special quoted keyword */
		    if (symbols[i] == CAR(karg)) {
			val = CADR(karg);
			varset = 1;
			break;
		    }
		    karg = CDR(karg);
		}
	    }

	    /* Add the variable to environment */
	    if (varset) {
		ComPush(com, symbols[i], val, eval, builtin, compile);
		if (sforms[i])
		    ComPush(com, sforms[i], T, 0, builtin, compile);
	    }
	    else {
		/* default arguments are evaluated for macros */
		if (!builtin) {
		    int lex = com->lex;
		    int head = lisp__data.env.head;

		    com->lex = base;
		    lisp__data.env.head = lisp__data.env.length;
		    ComPush(com, symbols[i], val, eval, 0, compile);
		    lisp__data.env.head = head;
		    com->lex = lex;
		}
		else
		    ComPush(com, symbols[i], val, eval, builtin, compile);
		if (sforms[i])
		    ComPush(com, sforms[i], NIL, 0, builtin, compile);
	    }
	    if (!builtin && !com->macro) {
		COM_VARIABLE_ARGUMENT(symbols[i]->data.atom);
		if (sforms[i])
		    COM_VARIABLE_ARGUMENT(sforms[i]->data.atom);
	    }
	}
    }

    if (*desc == 'a') {
	/* &KEY uses all remaining arguments */
	values = NIL;
	goto aux_label;
    }
    goto finished_label;


    /* &REST */
rest_label:
    if (!eval || !CONSP(values) || (compile && !builtin))
	ComPush(com, alist->rest, values, eval, builtin, compile);
    else {
	char *string;
	LispObj *list, *car = NIL;
	int count, constantp;

	/* Count number of arguments and check if it is a list of constants */
	for (count = 0, constantp = 1, list = values;
	     CONSP(list);
	     list = CDR(list), count++) {
	    car = CAR(list);
	    if (!ComConstantp(com, car))
		constantp = 0;
	}

	string = builtin ? ATOMID(name) : NULL;
	/* XXX FIXME should have a flag indicating if function call
	 * change the &REST arguments even if it is a constant list
	 * (or if the returned value may be changed). */
	if (string && (count < MAX_BCONS || constantp) &&
	    strcmp(string, "LIST") &&
	    strcmp(string, "APPLY") &&	/* XXX depends on function argument */
	    strcmp(string, "VECTOR") &&
	    /* Append does not copy the last/single list */
	    (strcmp(string, "APPEND") || !CONSP(car))) {
	    if (constantp) {
		/* If the builtin function changes the &REST parameters, must
		 * define a Com_XXX function for it. */
		ComPush(com, alist->rest, values, 0, builtin, compile);
	    }
	    else {
		CompileStackEnter(com, count - 1, 1);
		for (; CONSP(CDR(values)); values = CDR(values)) {
		    /* Evaluate this argument */
		    ComEval(com, CAR(values));
		    /* Save result in builtin stack */
		    com_Bytecode(com, XBC_PUSH);
		}
		CompileStackLeave(com, count - 1, 1);
		/* The last argument is not saved in the stack */
		ComEval(com, CAR(values));
		values = NIL;
		com_Bytecode(com, (LispByteOpcode)(XBC_BCONS + (count - 1)));
	    }
	}
	else {
	    /* Allocate a fresh list of cons */

	    /* Generate code to load object */
	    ComEval(com, CAR(values));

	    com->stack.cpstack += 2;
	    if (com->stack.pstack < com->stack.cpstack)
		com->stack.pstack = com->stack.cpstack;
	    /* Start building a gc protected list, with the loaded value */
	    com_Bytecode(com, XBC_LSTAR);

	    for (values = CDR(values); CONSP(values); values = CDR(values)) {
		/* Generate code to load object */
		ComEval(com, CAR(values));

		/* Add loaded value to gc protected list */
		com_Bytecode(com, XBC_LCONS);
	    }

	    /* Finish gc protected list */
	    com_Bytecode(com, XBC_LFINI);

	    /* Push loaded value */
	    if (builtin)
		com_Bytecode(com, XBC_PUSH);
	    else {
		com_Let(com, alist->rest->data.atom);

		/* Remember this symbol will be bound */
		ComAddVariable(com, alist->rest, values);
	    }
	    com->stack.cpstack -= 2;
	}
    }
    if (!builtin && !com->macro)
	COM_VARIABLE_ARGUMENT(alist->rest->data.atom);
    if (*desc != 'a')
	goto finished_label;


    /* &AUX */
aux_label:
    i = 0;
    count = alist->auxs.num_symbols;
    symbols = alist->auxs.symbols;
    defaults = alist->auxs.initials;
    if (!builtin && !compile) {
	int lex = com->lex;

	com->lex = base;
	lisp__data.env.head = lisp__data.env.length;
	for (; i < count; i++) {
	    ComPush(com, symbols[i], defaults[i], 1, 0, 0);
	    if (!com->macro)
		COM_VARIABLE_ARGUMENT(symbols[i]->data.atom);
	    ++lisp__data.env.head;
	}
	com->lex = lex;
    }
    else {
	for (; i < count; i++) {
	    ComPush(com, symbols[i], defaults[i], eval, builtin, compile);
	    if (!builtin && !com->macro)
		COM_VARIABLE_ARGUMENT(symbols[i]->data.atom);
	}
    }

done_label:
    if (CONSP(values))
	LispDestroy("%s: too many arguments", STROBJ(name));

finished_label:
    if (builtin)
	lisp__data.stack.base = base;
    else
	lisp__data.env.head = lisp__data.env.length;

    return (base);
}

static void
ComFuncall(LispCom *com, LispObj *function, LispObj *arguments, int eval)
{
    int base, compile;
    LispAtom *atom;
    LispArgList *alist;
    LispBuiltin *builtin;
    LispObj *lambda;

    switch (OBJECT_TYPE(function)) {
	case LispFunction_t:
	    function = function->data.atom->object;
	case LispAtom_t:
	    atom = function->data.atom;
	    alist = atom->property->alist;

	    if (atom->a_builtin) {
		builtin = atom->property->fun.builtin;
		compile = builtin->compile != NULL;

		/*  If one of:
		 * 	o expanding a macro
		 *	o calling a builtin special form
		 *	o builtin function is a macro
		 * don't evaluate arguments. */
		if (com->macro || compile || builtin->type == LispMacro)
		    eval = 0;

		if (!com->macro && builtin->type == LispMacro) {
		    /* Set flag of variable used, in case variable is only
		     * used as a builtin macro argument. */
		    LispObj *obj;

		    for (obj = arguments; CONSP(obj); obj = CDR(obj)) {
			if (SYMBOLP(CAR(obj)))
			    COM_VARIABLE_USED(CAR(obj)->data.atom);
		    }
		}

		FORM_ENTER();
		if (!compile && !com->macro)
		    CompileStackEnter(com, alist->num_arguments, 1);

		/* Build argument list in the interpreter stacks */
		base = ComCall(com, alist, function, arguments,
			       eval, 1, compile);

		/* If <compile> is set, it is a special form */
		if (compile)
		    builtin->compile(com, builtin);

		/* Else, generate opcodes to call builtin function */
		else {
		    com_Call(com, alist->num_arguments, builtin);
		    CompileStackLeave(com, alist->num_arguments, 1);
		}
		lisp__data.stack.base = lisp__data.stack.length = base;
		FORM_LEAVE();
	    }
	    else if (atom->a_function) {
		int macro;

		lambda = atom->property->fun.function;
		macro = lambda->funtype == LispMacro;

		/* If <macro> is set, expand macro */
		if (macro)
		    ComMacroCall(com, alist, function, lambda, arguments);

		else {
		    if (com->toplevel->type == LispBlockClosure &&
			com->toplevel->tag == function)
			ComRecursiveCall(com, alist, function, arguments);
		    else {
#if 0
			ComInlineCall(com, alist, function, arguments,
				      lambda->data.lambda.code);
#else
			com_Funcall(com, function, arguments);
#endif
		    }
		}
	    }
	    else if (atom->a_defstruct &&
		     atom->property->structure.function != STRUCT_NAME &&
		     atom->property->structure.function != STRUCT_CONSTRUCTOR) {
		LispObj *definition = atom->property->structure.definition;

		if (!CONSP(arguments) || CONSP(CDR(arguments)))
		    LispDestroy("%s: too %s arguments", atom->string,
				CONSP(arguments) ? "many" : "few");

		ComEval(com, CAR(arguments));
		if (atom->property->structure.function == STRUCT_CHECK)
		    com_Structp(com, definition);
		else
		    com_Struct(com,
			       atom->property->structure.function, definition);
	    }
	    else if (atom->a_compiled) {
		FORM_ENTER();
		CompileStackEnter(com, alist->num_arguments, 0);

		/* Build argument list in the interpreter stacks */
		base = ComCall(com, alist, function, arguments, 1, 0, 0);
		com_Bytecall(com, alist->num_arguments,
			     atom->property->fun.function);
		CompileStackLeave(com, alist->num_arguments, 0);
		lisp__data.env.head = lisp__data.env.length = base;
		FORM_LEAVE();
	    }
	    else {
		/* Not yet defined function/macro. */
		++com->warnings;
		LispWarning("call to undefined function %s", atom->string);
		com_Funcall(com, function, arguments);
	    }
	    break;

	case LispLambda_t:
	    lambda = function->data.lambda.code;
	    alist = (LispArgList*)function->data.lambda.name->data.opaque.data;
	    ComInlineCall(com, alist, NIL, arguments, lambda->data.lambda.code);
	    break;

	case LispCons_t:
	    if (CAR(function) == Olambda) {
		function = EVAL(function);
		if (LAMBDAP(function)) {
		    GC_ENTER();

		    GC_PROTECT(function);
		    lambda = function->data.lambda.code;
		    alist = (LispArgList*)function->data.lambda.name->data.opaque.data;
		    ComInlineCall(com, alist, NIL, arguments, lambda->data.lambda.code);
		    GC_LEAVE();
		    break;
		}
	    }

	default:
	    /*  XXX If bytecode objects are made available, should
	     * handle it here. */
	    LispDestroy("EVAL: %s is invalid as a function",
			STROBJ(function));
	    /*NOTREACHED*/
	    break;
    }
}

/* Generate opcodes for an implicit PROGN */
static void
ComProgn(LispCom *com, LispObj *code)
{
    if (CONSP(code)) {
	for (; CONSP(code); code = CDR(code))
	    ComEval(com, CAR(code));
    }
    else
	/* If no code to execute, empty PROGN returns NIL */
	com_Bytecode(com, XBC_NIL);
}

/* Generate opcodes to evaluate <object>. */
static void
ComEval(LispCom *com, LispObj *object)
{
    int offset;
    LispObj *form;

    switch (OBJECT_TYPE(object)) {
	case LispAtom_t:
	    if (IN_TAGBODY())
		ComLabel(com, object);
	    else {
		offset = ComGetVariable(com, object);
		if (offset >= 0)
		    /* Load from user stack at relative offset */
		    com_Load(com, offset);
		else if (offset == SYMBOL_KEYWORD)
		    com_LoadCon(com, object);
		else if (offset == SYMBOL_CONSTANT)
		    /* Symbol defined as constant, just load it's value */
		    com_LoadCon(com, LispGetVar(object));
		else
		    /* Load value bound to symbol at run time */
		    com_LoadSym(com, object->data.atom);
	    }
	    break;

	case LispCons_t: {
	    /* Macro expansion may be done in the object form */
	    form = com->form;
	    com->form = object;
	    ComFuncall(com, CAR(object), CDR(object), 1);
	    com->form = form;
	}   break;

	case LispQuote_t:
	    com_LoadCon(com, object->data.quote);
	    break;

	case LispBackquote_t:
	    /* Macro expansion is stored in the current value of com->form */
	    ComMacroBackquote(com, object);
	    break;

	case LispComma_t:
	    LispDestroy("EVAL: comma outside of backquote");
	    break;

	case LispFunctionQuote_t:
	    object = object->data.quote;
	    if (SYMBOLP(object))
		object = LispSymbolFunction(object);
	    else if (CONSP(object) && CAR(object) == Olambda) {
		/* object will only be associated with bytecode later,
		 * so, make sure it is protected until compilation finishes */
		object = EVAL(object);
		RPLACD(com->plist, CONS(CAR(com->plist), CDR(com->plist)));
		RPLACA(com->plist, object);
	    }
	    else
		LispDestroy("FUNCTION: %s is not a function", STROBJ(object));
	    com_LoadCon(com, object);
	    break;

	case LispFixnum_t:
	    if (IN_TAGBODY()) {
		ComLabel(com, object);
		break;
	    }
	    /*FALLTROUGH*/

	default:
	    /* Constant object */
	    com_LoadCon(com, object);
	    break;
    }
}

/***********************************************************************
 * Lambda expansion helper functions
 ***********************************************************************/
static void
ComRecursiveCall(LispCom *com, LispArgList *alist,
		 LispObj *name, LispObj *arguments)
{
    int base, lex;

    /* Save state */
    lex = lisp__data.env.lex;

    FORM_ENTER();

    /* Generate code to push function arguments in the stack */
    base = ComCall(com, alist, name, arguments, 1, 0, 0);

    /* Stack will grow this amount */
    CompileStackEnter(com, alist->num_arguments, 0);

#if 0
    /* Make the variables available at run time */
    com_Bind(com, alist->num_arguments);
    com->block->bind += alist->num_arguments;
#endif

    com_BytecodeChar(com, XBC_LETREC, alist->num_arguments);

#if 0
    /* The variables are now unbound */
    com_Unbind(com, alist->num_arguments);
    com->block->bind -= alist->num_arguments;
#endif

    /* Stack length is reduced */
    CompileStackLeave(com, alist->num_arguments, 0);
    FORM_LEAVE();

    /* Restore state */
    lisp__data.env.lex = lex;
    lisp__data.env.head = lisp__data.env.length = base;
}

static void
ComInlineCall(LispCom *com, LispArgList *alist,
	      LispObj *name, LispObj *arguments, LispObj *lambda)
{
    int base, lex;

    /* Save state */
    lex = lisp__data.env.lex;

    FORM_ENTER();
    /* Start the inline function block */
    CompileIniBlock(com, LispBlockClosure, name);

    /* Generate code to push function arguments in the stack */
    base = ComCall(com, alist, name, arguments, 1, 0, 0);

    /* Stack will grow this amount */
    CompileStackEnter(com, alist->num_arguments, 0);

    /* Make the variables available at run time */
    com_Bind(com, alist->num_arguments);
    com->block->bind += alist->num_arguments;

    /* Expand the lambda list */
    ComProgn(com, lambda);

    /* The variables are now unbound */
    com_Unbind(com, alist->num_arguments);
    com->block->bind -= alist->num_arguments;

    /* Stack length is reduced */
    CompileStackLeave(com, alist->num_arguments, 0);

    /* Finish the inline function block */
    CompileFiniBlock(com);
    FORM_LEAVE();

    /* Restore state */
    lisp__data.env.lex = lex;
    lisp__data.env.head = lisp__data.env.length = base;
}

/***********************************************************************
 * Macro expansion helper functions.
 ***********************************************************************/
static LispObj *
ComMacroExpandBackquote(LispCom *com, LispObj *object)
{
    return (LispEvalBackquote(object->data.quote, 1));
}

static LispObj *
ComMacroExpandFuncall(LispCom *com, LispObj *function, LispObj *arguments)
{
    return (LispFuncall(function, arguments, 1));
}

static LispObj *
ComMacroExpandEval(LispCom *com, LispObj *object)
{
    LispObj *result;

    switch (OBJECT_TYPE(object)) {
	case LispAtom_t:
	    result = LispGetVar(object);

	    /* Macro expansion requires bounded symbols */
	    if (result == NULL)
		LispDestroy("EVAL: the variable %s is unbound",
			    STROBJ(object));
	    break;

	case LispCons_t:
	    result = ComMacroExpandFuncall(com, CAR(object), CDR(object));
	    break;

	case LispQuote_t:
	    result = object->data.quote;
	    break;

	case LispBackquote_t:
	    result = ComMacroExpandBackquote(com, object);
	    break;

	case LispComma_t:
	    LispDestroy("EVAL: comma outside of backquote");

	case LispFunctionQuote_t:
	    result = EVAL(object);
	    break;

	default:
	    result = object;
	    break;
    }

    return (result);
}

static LispObj *
ComMacroExpand(LispCom *com, LispObj *lambda)
{
    LispObj *result, **presult = &result;
    int jumped, *pjumped = &jumped, backquote, *pbackquote = &backquote;
    LispBlock *block;

    int interpreter_lex, interpreter_head, interpreter_base;

    /* Save interpreter state */
    interpreter_base = lisp__data.stack.length;
    interpreter_head = lisp__data.env.length;
    interpreter_lex = lisp__data.env.lex;

    /* Use the variables */
    *presult = NIL;
    *pjumped = 1;
    *pbackquote = !CONSP(lambda);

    block = LispBeginBlock(NIL, LispBlockProtect);
    if (setjmp(block->jmp) == 0) {
	if (!backquote) {
	    for (; CONSP(lambda); lambda = CDR(lambda))
		result = ComMacroExpandEval(com, CAR(lambda));
	}
	else
	    result = ComMacroExpandBackquote(com, lambda);

	*pjumped = 0;
    }
    LispEndBlock(block);

    /* If tried to jump out of the macro expansion block */
    if (!lisp__data.destroyed && jumped)
	LispDestroy("*** EVAL: bad jump in macro expansion");

    /* Macro expansion did something wrong */
    if (lisp__data.destroyed) {
	LispMessage("*** EVAL: aborting macro expansion");
	LispDestroy(".");
    }

    /* Restore interpreter state */
    lisp__data.env.lex = interpreter_lex;
    lisp__data.stack.length = interpreter_base;
    lisp__data.env.head = lisp__data.env.length = interpreter_head;

    return (result);
}

static void
ComMacroCall(LispCom *com, LispArgList *alist,
	     LispObj *name, LispObj *lambda, LispObj *arguments)
{
    int base;
    LispObj *body;

    ++com->macro;
    base = ComCall(com, alist, name, arguments, 0, 0, 0);
    body = lambda->data.lambda.code;
    body = ComMacroExpand(com, body);
    --com->macro;
    lisp__data.env.head = lisp__data.env.length = base;

    /* Macro is expanded, store the result */
    CAR(com->form) = body;
    ComEval(com, body);
}

static void
ComMacroBackquote(LispCom *com, LispObj *lambda)
{
    LispObj *body;

    ++com->macro;
    body = ComMacroExpand(com, lambda);
    --com->macro;

    /* Macro is expanded, store the result */
    CAR(com->form) = body;

    com_LoadCon(com, body);
}