summaryrefslogtreecommitdiff
path: root/lisp/compile.c
diff options
context:
space:
mode:
Diffstat (limited to 'lisp/compile.c')
-rw-r--r--lisp/compile.c2225
1 files changed, 2225 insertions, 0 deletions
diff --git a/lisp/compile.c b/lisp/compile.c
new file mode 100644
index 0000000..f699f39
--- /dev/null
+++ b/lisp/compile.c
@@ -0,0 +1,2225 @@
+/*
+ * 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.14 2003/01/30 02:46:25 paulo 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, 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, **plambda;
+ 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 */
+ plambda = &lambda;
+ *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 cgit v1.2.3 (git 2.25.1) at 2024-11-22 03:42:59 +0000