Logo Search packages:      
Sourcecode: xbase-clients version File versions  Download package

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

Generated by  Doxygen 1.6.0   Back to index