Edit
IABSD.fr/xenocara/app/xedit/lisp/compile.c
matthieu
- app/xedit/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); }