summaryrefslogtreecommitdiff
path: root/lisp/bytecode.c
diff options
context:
space:
mode:
authorKaleb Keithley <kaleb@freedesktop.org>2003-11-14 16:49:22 +0000
committerKaleb Keithley <kaleb@freedesktop.org>2003-11-14 16:49:22 +0000
commit0a193e032ba1ecf3f003e027e833dc9d274cb740 (patch)
treea1dcc00cb7f5d26e437e05e658c38fc323fe919d /lisp/bytecode.c
Initial revision
Diffstat (limited to 'lisp/bytecode.c')
-rw-r--r--lisp/bytecode.c3707
1 files changed, 3707 insertions, 0 deletions
diff --git a/lisp/bytecode.c b/lisp/bytecode.c
new file mode 100644
index 0000000..39667b0
--- /dev/null
+++ b/lisp/bytecode.c
@@ -0,0 +1,3707 @@
+/*
+ * 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/bytecode.c,v 1.15 2003/01/29 03:05:53 paulo Exp $ */
+
+
+/*
+somethings TODO:
+
+ o Write code for allowing storing the bytecode on disk. Basically
+ write a section of the bytecode with the package name of the symbol
+ pointers, and after that, the symbols used. At load time just put
+ the pointers in the bytecode. Constants can be stored as the string
+ representation. Probably just storing the gc protected code as a
+ string is enough to rebuild it.
+
+ o Write code to store tags of BLOCK/CATCH and setjump buffer stacks,
+ and, only keep track of this if non byte-compiled code is called,
+ as after byte-compilation RETURN and THROW are just jumps.
+
+ o Remove not reliable "optmization code" code from Com_XXX functions
+ and do it later, removing dead code, tests with a constant argument,
+ etc, in the "link time". Frequently joining sequential opcodes to a
+ compound version.
+
+ o Write an optimizer to do code transformation.
+
+ o Write code to know when variables can be changed in place, this
+ can save a huge time in loop counters.
+
+ o Write code for fast garbage collection of objects that can be
+ safely collected.
+
+ o Cleanup of interpreted code. Having bytecode mean that the interpreter
+ now is better having a clean and small code. If speed is important,
+ it should be byte compiled.
+
+ o Limit the stacks length. So that instead of using an index, use the
+ pointer where an object value should be read/stored as the stack address
+ would not change during the program execution.
+
+ o Optimize jump to jump. Common in code like:
+ (IF test
+ (GO somewhere)
+ (GO elsewhere)
+ )
+ (GO there)
+ that generates a bytecode like:
+ <code to evaluate test>
+ JUMPNIL :NIL-RESULT
+ :T-RESULT
+ JUMP :SOMEWHERE
+ JUMP :END-OF-IF ;; <- this is not required, or even
+ :NIL-RESULT ;; better, notice the jump after
+ JUMP :ELSEWHERE ;; the if and transform it into
+ :END-OF-IF ;; a JUMP :THERE (assuming there
+ JUMP :THERE ;; (was no jump in the T code).
+
+ o Optimize variables that are known to not change it's value, i.e. pseudo
+ constants. Loading the value of a constant should be faster than loading
+ the current value of a variable; the constant table could fit in the
+ processor cache line and needs less calculation to find the object address.
+
+ o Fix some known problems, like when calling return or return-from while
+ building the argument list to a builtin function, or inline of recursive
+ functions.
+ */
+
+
+#include "bytecode.h"
+#include "write.h"
+
+#define SYMBOL_KEYWORD -1 /* A keyword, load as constant */
+#define SYMBOL_CONSTANT -2 /* Defined as constant at compile time */
+#define SYMBOL_UNBOUND -3 /* Not a local variable */
+
+#define NEW_TREE(type) CompileNewTree(com, type)
+
+/* If in tagbody, ignore anything that is not code */
+#define IN_TAGBODY() (com->block->type == LispBlockBody && \
+ com->level == com->tagbody)
+#define FORM_ENTER() ++com->level
+#define FORM_LEAVE() --com->level
+
+#define COMPILE_FAILURE(message) \
+ LispMessage("COMPILE: %s", message); \
+ longjmp(com->jmp, 1)
+
+/*
+ * Types
+ */
+typedef struct _CodeTree CodeTree;
+typedef struct _CodeBlock CodeBlock;
+
+typedef enum {
+ CodeTreeBytecode,
+ CodeTreeLabel,
+ CodeTreeGo,
+ CodeTreeJump,
+ CodeTreeJumpIf,
+ CodeTreeCond,
+ CodeTreeBlock,
+ CodeTreeReturn
+} CodeTreeType;
+
+struct _CodeTree {
+ CodeTreeType type;
+
+ /* Resolved when linking, may be adjusted while optimizing */
+ long offset;
+
+ LispByteOpcode code;
+
+ union {
+ signed char signed_char;
+ signed short signed_short;
+ signed int signed_int;
+ LispAtom *atom;
+ LispObj *object;
+ CodeTree *tree;
+ CodeBlock *block;
+ struct {
+ unsigned char num_arguments;
+ LispBuiltin *builtin;
+ signed short offset; /* Used if opcode is XBC_CALL_SET */
+ } builtin;
+ struct {
+ unsigned char num_arguments;
+ LispObj *name;
+ LispObj *lambda;
+ } call;
+ struct {
+ unsigned char num_arguments;
+ LispObj *code;
+ } bytecall;
+ struct {
+ short offset;
+ LispAtom *name;
+ } let;
+ struct {
+ LispAtom *symbol;
+ LispAtom *name;
+ } let_sym;
+ struct {
+ LispObj *object;
+ LispAtom *name;
+ } let_con;
+ struct {
+ signed short load;
+ signed short set;
+ } load_set;
+ struct {
+ LispObj *object;
+ signed short offset;
+ } load_con_set;
+ struct {
+ LispObj *car;
+ LispObj *cdr;
+ } cons;
+ struct {
+ short offset;
+ LispObj *definition;
+ } struc;
+ } data;
+
+ CodeTree *next;
+ CodeTree *group;
+ CodeBlock *block;
+};
+
+struct _CodeBlock {
+ LispBlockType type;
+ LispObj *tag;
+
+ struct {
+ LispObj **labels;
+ CodeTree **codes; /* Filled at link time */
+ int length;
+ int space;
+ } tagbody;
+
+ struct {
+ LispAtom **symbols; /* Identifiers of variables in a block */
+ int *flags; /* Information about usage of the variable */
+ int length;
+ } variables;
+
+ int bind; /* Used in case of RETURN from LET */
+ int level; /* Nesting level block was created */
+
+ CodeTree *tree, *tail;
+ CodeBlock *prev; /* Linked list as a stack */
+ CodeTree *parent; /* Back reference */
+};
+
+struct _LispCom {
+ unsigned char *bytecode; /* Bytecode generated so far */
+ long length;
+
+ CodeBlock *block, *toplevel;
+
+ int tagbody; /* Inside a tagbody block? */
+ int level; /* Nesting level */
+ int macro; /* Expanding a macro? */
+
+ int lex;
+
+ int warnings;
+
+ LispObj *form, *plist;
+
+ jmp_buf jmp; /* Used if compilation cannot be finished */
+
+ struct {
+ int cstack; /* Current number of objects in forms evaluation */
+ int cbstack;
+ int cpstack;
+ int stack; /* max number of objects will be loaded in stack */
+ int bstack;
+ int pstack;
+ } stack;
+
+ struct {
+ /* Constant table */
+ LispObj **constants;
+ int num_constants;
+ /* Symbol table */
+ LispAtom **symbols;
+ int num_symbols;
+ /* Builtin table */
+ LispBuiltin **builtins;
+ int num_builtins;
+ /* Bytecode table */
+ LispObj **bytecodes;
+ int num_bytecodes;
+ } table;
+};
+
+/*
+ * Prototypes
+ */
+static LispObj *MakeBytecodeObject(LispCom*, LispObj*, LispObj*);
+
+static CodeTree *CompileNewTree(LispCom*, CodeTreeType);
+static void CompileFreeState(LispCom*);
+static void CompileFreeBlock(CodeBlock*);
+static void CompileFreeTree(CodeTree*);
+
+static void CompileIniBlock(LispCom*, LispBlockType, LispObj*);
+static void CompileFiniBlock(LispCom*);
+
+static void com_BytecodeChar(LispCom*, LispByteOpcode, char);
+static void com_BytecodeShort(LispCom*, LispByteOpcode, short);
+static void com_BytecodeObject(LispCom*, LispByteOpcode, LispObj*);
+static void com_BytecodeCons(LispCom*, LispByteOpcode, LispObj*, LispObj*);
+
+static void com_BytecodeAtom(LispCom*, LispByteOpcode, LispAtom*);
+
+static void com_Bytecode(LispCom*, LispByteOpcode);
+
+static void com_Load(LispCom*, short);
+static void com_LoadLet(LispCom*, short, LispAtom*);
+static void com_LoadPush(LispCom*, short);
+
+static void com_Let(LispCom*, LispAtom*);
+
+static void com_Bind(LispCom*, short);
+static void com_Unbind(LispCom*, short);
+
+static void com_LoadSym(LispCom*, LispAtom*);
+static void com_LoadSymLet(LispCom*, LispAtom*, LispAtom*);
+static void com_LoadSymPush(LispCom*, LispAtom*);
+
+static void com_LoadCon(LispCom*, LispObj*);
+static void com_LoadConLet(LispCom*, LispObj*, LispAtom*);
+static void com_LoadConPush(LispCom*, LispObj*);
+
+static void com_Set(LispCom*, short);
+static void com_SetSym(LispCom*, LispAtom*);
+
+static void com_Struct(LispCom*, short, LispObj*);
+static void com_Structp(LispCom*, LispObj*);
+
+static void com_Call(LispCom*, unsigned char, LispBuiltin*);
+static void com_Bytecall(LispCom*, unsigned char, LispObj*);
+static void com_Funcall(LispCom*, LispObj*, LispObj*);
+
+static void CompileStackEnter(LispCom*, int, int);
+static void CompileStackLeave(LispCom*, int, int);
+
+static void LinkBytecode(LispCom*);
+
+static LispObj *ExecuteBytecode(unsigned char*);
+
+
+/* Defined in lisp.c */
+void LispMoreStack(void);
+void LispMoreEnvironment(void);
+void LispMoreGlobals(LispPackage*);
+LispObj *LispEvalBackquote(LispObj*, int);
+void LispSetAtomObjectProperty(LispAtom*, LispObj*);
+
+/*
+ * Initialization
+ */
+extern int pagesize;
+
+LispObj x_cons[8];
+static LispObj *cons, *cons1, *cons2, *cons3, *cons4, *cons5, *cons6, *cons7;
+
+/*
+ * Implementation
+ */
+#include "compile.c"
+
+void
+LispBytecodeInit(void)
+{
+ cons = &x_cons[7];
+ cons->type = LispCons_t;
+ CDR(cons) = NIL;
+ cons1 = &x_cons[6];
+ cons1->type = LispCons_t;
+ CDR(cons1) = cons;
+ cons2 = &x_cons[5];
+ cons2->type = LispCons_t;
+ CDR(cons2) = cons1;
+ cons3 = &x_cons[4];
+ cons3->type = LispCons_t;
+ CDR(cons3) = cons2;
+ cons4 = &x_cons[3];
+ cons4->type = LispCons_t;
+ CDR(cons4) = cons3;
+ cons5 = &x_cons[2];
+ cons5->type = LispCons_t;
+ CDR(cons5) = cons4;
+ cons6 = &x_cons[1];
+ cons6->type = LispCons_t;
+ CDR(cons6) = cons5;
+ cons7 = &x_cons[0];
+ cons7->type = LispCons_t;
+ CDR(cons7) = cons6;
+}
+
+LispObj *
+Lisp_Compile(LispBuiltin *builtin)
+/*
+ compile name &optional definition
+ */
+{
+ GC_ENTER();
+ LispObj *result, *warnings_p, *failure_p;
+
+ LispObj *name, *definition;
+
+ definition = ARGUMENT(1);
+ name = ARGUMENT(0);
+
+ result = name;
+ warnings_p = NIL;
+ failure_p = T;
+
+ if (name != NIL) {
+ LispAtom *atom;
+
+ CHECK_SYMBOL(name);
+ atom = name->data.atom;
+ if (atom->a_builtin || atom->a_compiled)
+ goto finished_compilation;
+ else if (atom->a_function) {
+ LispCom com;
+ int failed, *pfailed;
+ int lex, base, *plex, *pbase;
+ LispArgList *alist;
+ LispObj *lambda, *form, *arguments, **parguments;
+ LispObj **presult, **pwarnings_p, **pfailure_p, **pform;
+
+ lambda = atom->property->fun.function;
+ if (definition != UNSPEC || lambda->funtype != LispFunction)
+ /* XXX TODO replace definition etc. */
+ goto finished_compilation;
+ alist = atom->property->alist;
+
+ memset(&com, 0, sizeof(LispCom));
+ com.toplevel = com.block = LispCalloc(1, sizeof(CodeBlock));
+ com.block->type = LispBlockClosure;
+ com.block->tag = name;
+
+ /* Create a fake argument list to avoid yet another flag
+ * for ComCall. The value does not matter, just the fact
+ * that the symbol will be bound or not in the implicit
+ * PROGN of the function body. */
+ base = alist->num_arguments - alist->auxs.num_symbols;
+ if (base) {
+ LispObj *argument;
+ int i, sforms;
+
+ for (i = sforms = 0; i < alist->optionals.num_symbols; i++)
+ if (alist->optionals.sforms[i])
+ ++sforms;
+
+ arguments = form = NIL;
+ i = sforms +
+ alist->normals.num_symbols + alist->optionals.num_symbols;
+
+ if (i) {
+ arguments = form = CONS(NIL, NIL);
+ GC_PROTECT(arguments);
+ for (--i; i > 0; i--) {
+ RPLACD(form, CONS(NIL, NIL));
+ form = CDR(form);
+ }
+ }
+
+ for (i = 0; i < alist->keys.num_symbols; i++) {
+ /* key symbol */
+ if (alist->keys.keys[i])
+ argument = QUOTE(alist->keys.keys[i]);
+ else
+ argument = alist->keys.symbols[i];
+
+ /* add key */
+ if (arguments == NIL) {
+ arguments = form = CONS(argument, NIL);
+ GC_PROTECT(arguments);
+ }
+ else {
+ RPLACD(form, CONS(argument, NIL));
+ form = CDR(form);
+ }
+
+ /* add value */
+ RPLACD(form, CONS(NIL, NIL));
+ form = CDR(form);
+
+ if (alist->keys.sforms[i]) {
+ RPLACD(form, CONS(NIL, NIL));
+ form = CDR(form);
+ }
+ }
+
+ if (alist->rest) {
+ if (arguments == NIL) {
+ arguments = form = CONS(NIL, NIL);
+ GC_PROTECT(arguments);
+ }
+ else {
+ RPLACD(form, CONS(NIL, NIL));
+ form = CDR(form);
+ }
+ }
+ }
+ else
+ arguments = NIL;
+
+ form = CONS(lambda->data.lambda.code, NIL);
+ GC_PROTECT(form);
+ com.form = form;
+ com.plist = CONS(NIL, NIL);
+ GC_PROTECT(com.plist);
+
+ pfailed = &failed;
+ plex = &lex;
+ pbase = &base;
+ pform = &form;
+ presult = &result;
+ pwarnings_p = &warnings_p;
+ pfailure_p = &failure_p;
+ parguments = &arguments;
+ failed = 1;
+ if (setjmp(com.jmp) == 0) {
+ /* Save interpreter state */
+ lex = com.lex = lisp__data.env.lex;
+ base = ComCall(&com, alist, name, arguments, 1, 0, 1);
+
+ /* Generate code tree */
+ lisp__data.env.lex = base;
+ ComProgn(&com, CAR(form));
+ failed = 0;
+ }
+
+ /* Restore interpreter state */
+ lisp__data.env.lex = lex;
+ lisp__data.env.head = lisp__data.env.length = base;
+
+ if (!failed) {
+ failure_p = NIL;
+ result = MakeBytecodeObject(&com, name,
+ lambda->data.lambda.data);
+ LispSetAtomCompiledProperty(atom, result);
+ result = name;
+ }
+ if (com.warnings)
+ warnings_p = FIXNUM(com.warnings);
+ goto finished_compilation;
+ }
+ else
+ goto undefined_function;
+ }
+
+undefined_function:
+ LispDestroy("%s: the function %s is undefined",
+ STRFUN(builtin), STROBJ(name));
+
+finished_compilation:
+ RETURN(0) = warnings_p;
+ RETURN(1) = failure_p;
+ RETURN_COUNT = 2;
+ GC_LEAVE();
+
+ return (result);
+}
+
+LispObj *
+Lisp_Disassemble(LispBuiltin *builtin)
+/*
+ disassemble function
+ */
+{
+ int macro;
+ char buffer[128];
+ LispAtom *atom;
+ LispArgList *alist;
+ LispBuiltin *xbuiltin;
+ LispObj *name, *lambda, *bytecode;
+
+ LispObj *function;
+
+ function = ARGUMENT(0);
+
+ macro = 0;
+ alist = NULL;
+ xbuiltin = NULL;
+ name = bytecode = NULL;
+
+ switch (OBJECT_TYPE(function)) {
+ case LispAtom_t:
+ name = function;
+ atom = function->data.atom;
+ alist = atom->property->alist;
+ if (atom->a_builtin) {
+ xbuiltin = atom->property->fun.builtin;
+ macro = xbuiltin->type == LispMacro;
+ }
+ else if (atom->a_compiled)
+ bytecode = atom->property->fun.function;
+ else if (atom->a_function) {
+ lambda = atom->property->fun.function;
+ macro = lambda->funtype == LispMacro;
+ }
+ else if (atom->a_defstruct &&
+ atom->property->structure.function != STRUCT_NAME) {
+ if (atom->property->structure.function == STRUCT_CONSTRUCTOR)
+ atom = Omake_struct->data.atom;
+ else if (atom->property->structure.function == STRUCT_CHECK)
+ atom = Ostruct_type->data.atom;
+ else
+ atom = Ostruct_access->data.atom;
+ xbuiltin = atom->property->fun.builtin;
+ }
+ else
+ LispDestroy("%s: the function %s is not defined",
+ STRFUN(builtin), STROBJ(function));
+ break;
+ case LispBytecode_t:
+ name = Olambda;
+ bytecode = function;
+ break;
+ case LispLambda_t:
+ name = Olambda;
+ alist = (LispArgList*)function->data.lambda.name->data.opaque.data;
+ break;
+ case LispCons_t:
+ if (CAR(function) == Olambda) {
+ function = EVAL(function);
+ if (OBJECT_TYPE(function) == LispLambda_t) {
+ name = Olambda;
+ alist = (LispArgList*)
+ function->data.lambda.name->data.opaque.data;
+ break;
+ }
+ }
+ default:
+ LispDestroy("%s: %s is not a function",
+ STRFUN(builtin), STROBJ(function));
+ break;
+ }
+
+ if (xbuiltin) {
+ LispWriteStr(NIL, "Builtin ", 8);
+ if (macro)
+ LispWriteStr(NIL, "macro ", 6);
+ else
+ LispWriteStr(NIL, "function ", 9);
+ }
+ else if (macro)
+ LispWriteStr(NIL, "Macro ", 6);
+ else
+ LispWriteStr(NIL, "Function ", 9);
+ LispWriteObject(NIL, name);
+ LispWriteStr(NIL, ":\n", 2);
+
+ if (alist) {
+ int i;
+
+ sprintf(buffer, "%d required argument%s",
+ alist->normals.num_symbols,
+ alist->normals.num_symbols != 1 ? "s" : "");
+ LispWriteStr(NIL, buffer, strlen(buffer));
+ for (i = 0; i < alist->normals.num_symbols; i++) {
+ LispWriteChar(NIL, i ? ',' : ':');
+ LispWriteChar(NIL, ' ');
+ LispWriteStr(NIL, ATOMID(alist->normals.symbols[i]),
+ strlen(ATOMID(alist->normals.symbols[i])));
+ }
+ LispWriteChar(NIL, '\n');
+
+ sprintf(buffer, "%d optional argument%s",
+ alist->optionals.num_symbols,
+ alist->optionals.num_symbols != 1 ? "s" : "");
+ LispWriteStr(NIL, buffer, strlen(buffer));
+ for (i = 0; i < alist->optionals.num_symbols; i++) {
+ LispWriteChar(NIL, i ? ',' : ':');
+ LispWriteChar(NIL, ' ');
+ LispWriteStr(NIL, ATOMID(alist->optionals.symbols[i]),
+ strlen(ATOMID(alist->optionals.symbols[i])));
+ }
+ LispWriteChar(NIL, '\n');
+
+ sprintf(buffer, "%d keyword parameter%s",
+ alist->keys.num_symbols,
+ alist->keys.num_symbols != 1 ? "s" : "");
+ LispWriteStr(NIL, buffer, strlen(buffer));
+ for (i = 0; i < alist->keys.num_symbols; i++) {
+ LispWriteChar(NIL, i ? ',' : ':');
+ LispWriteChar(NIL, ' ');
+ LispWriteObject(NIL, alist->keys.symbols[i]);
+ }
+ LispWriteChar(NIL, '\n');
+
+ if (alist->rest) {
+ LispWriteStr(NIL, "Rest argument: ", 15);
+ LispWriteStr(NIL, ATOMID(alist->rest),
+ strlen(ATOMID(alist->rest)));
+ LispWriteChar(NIL, '\n');
+ }
+ else
+ LispWriteStr(NIL, "No rest argument\n", 17);
+ }
+
+ if (bytecode) {
+ char *ptr;
+ int *offsets[4];
+ int i, done, j, sym0, sym1, con0, con1, bui0, byt0, strd, strf;
+ LispObj **constants;
+ LispAtom **symbols;
+ LispBuiltin **builtins;
+ unsigned char **codes;
+ LispObj **names;
+ short stack, num_constants, num_symbols, num_builtins, num_bytecodes;
+ unsigned char *base, *stream = bytecode->data.bytecode.bytecode->code;
+
+ LispWriteStr(NIL, "\nBytecode header:\n", 18);
+
+ /* Header information */
+ stack = *(short*)stream;
+ stream += sizeof(short);
+ sprintf(buffer, "%d element%s used in the stack\n",
+ stack, stack != 1 ? "s" : "");
+ LispWriteStr(NIL, buffer, strlen(buffer));
+ stack = *(short*)stream;
+ stream += sizeof(short);
+ sprintf(buffer, "%d element%s used in the builtin stack\n",
+ stack, stack != 1 ? "s" : "");
+ LispWriteStr(NIL, buffer, strlen(buffer));
+ stack = *(short*)stream;
+ stream += sizeof(short);
+ sprintf(buffer, "%d element%s used in the protected stack\n",
+ stack, stack != 1 ? "s" : "");
+ LispWriteStr(NIL, buffer, strlen(buffer));
+
+ num_constants = *(short*)stream;
+ stream += sizeof(short);
+ num_symbols = *(short*)stream;
+ stream += sizeof(short);
+ num_builtins = *(short*)stream;
+ stream += sizeof(short);
+ num_bytecodes = *(short*)stream;
+ stream += sizeof(short);
+
+ constants = (LispObj**)stream;
+ stream += num_constants * sizeof(LispObj*);
+ symbols = (LispAtom**)stream;
+ stream += num_symbols * sizeof(LispAtom*);
+ builtins = (LispBuiltin**)stream;
+ stream += num_builtins * sizeof(LispBuiltin*);
+ codes = (unsigned char**)stream;
+ stream += num_bytecodes * sizeof(unsigned char*);
+ names = (LispObj**)stream;
+ stream += num_bytecodes * sizeof(LispObj*);
+
+ for (i = 0; i < num_constants; i++) {
+ sprintf(buffer, "Constant %d = %s\n", i, STROBJ(constants[i]));
+ LispWriteStr(NIL, buffer, strlen(buffer));
+ }
+
+/* Macro XSTRING avoids some noisy in the output, if it were defined as
+ * #define XSTRING(object) object ? STROBJ(object) : #<UNBOUND>
+ * and called as XSTRING(atom->object)
+ * it would also print the package name were the symbol was first defined,
+ * but for local variables, only the symbol string is important. */
+#define XSTRING(string) string ? string : "#<UNBOUND>"
+
+ for (i = 0; i < num_symbols; i++) {
+ sprintf(buffer, "Symbol %d = %s\n",
+ i, XSTRING(symbols[i]->string));
+ LispWriteStr(NIL, buffer, strlen(buffer));
+ }
+ for (i = 0; i < num_builtins; i++) {
+ sprintf(buffer, "Builtin %d = %s\n",
+ i, STROBJ(builtins[i]->symbol));
+ LispWriteStr(NIL, buffer, strlen(buffer));
+ }
+ for (i = 0; i < num_bytecodes; i++) {
+ sprintf(buffer, "Bytecode %d = %s\n",
+ i, STROBJ(names[i]));
+ LispWriteStr(NIL, buffer, strlen(buffer));
+ }
+
+ /* Make readability slightly easier printing the names of local
+ * variables where it's offset is known, i.e. function arguments. */
+ if (alist) {
+ if (alist->num_arguments == 0)
+ LispWriteStr(NIL, "\nNo initial stack\n", 18);
+ else {
+ int len1, len2;
+
+ j = 0;
+ LispWriteStr(NIL, "\nInitial stack:\n", 16);
+
+ for (i = 0; i < alist->normals.num_symbols; i++, j++) {
+ sprintf(buffer, "%d = ", j);
+ LispWriteStr(NIL, buffer, strlen(buffer));
+ ptr = alist->normals.symbols[i]->data.atom->string;
+ LispWriteStr(NIL, ptr, strlen(ptr));
+ LispWriteChar(NIL, '\n');
+ }
+
+ for (i = 0; i < alist->optionals.num_symbols; i++, j++) {
+ sprintf(buffer, "%d = ", j);
+ LispWriteStr(NIL, buffer, strlen(buffer));
+ ptr = alist->optionals.symbols[i]->data.atom->string;
+ LispWriteStr(NIL, ptr, strlen(ptr));
+ LispWriteChar(NIL, '\n');
+ if (alist->optionals.sforms[i]) {
+ sprintf(buffer, "%d = ", j);
+ len1 = strlen(buffer);
+ LispWriteStr(NIL, buffer, len1);
+ ptr = alist->optionals.sforms[i]->data.atom->string;
+ len2 = strlen(ptr);
+ LispWriteStr(NIL, ptr, len2);
+ LispWriteChars(NIL, ' ', 28 - (len1 + len2));
+ LispWriteStr(NIL, "; sform\n", 9);
+ j++;
+ }
+ }
+
+ for (i = 0; i < alist->keys.num_symbols; i++, j++) {
+ sprintf(buffer, "%d = ", j);
+ len1 = strlen(buffer);
+ LispWriteStr(NIL, buffer, len1);
+ if (alist->keys.keys[i]) {
+ ptr = alist->keys.keys[i]->data.atom->string;
+ len2 = strlen(ptr);
+ LispWriteStr(NIL, ptr, strlen(ptr));
+ LispWriteChars(NIL, ' ', 28 - (len1 + len2));
+ LispWriteStr(NIL, "; special key", 14);
+ }
+ else {
+ ptr = alist->keys.symbols[i]->data.atom->string;
+ LispWriteStr(NIL, ptr, strlen(ptr));
+ }
+ LispWriteChar(NIL, '\n');
+ if (alist->keys.sforms[i]) {
+ sprintf(buffer, "%d = ", j);
+ len1 = strlen(buffer);
+ LispWriteStr(NIL, buffer, len1);
+ ptr = alist->keys.sforms[i]->data.atom->string;
+ len2 = strlen(ptr);
+ LispWriteStr(NIL, ptr, len2);
+ LispWriteChars(NIL, ' ', 28 - (len1 + len2));
+ LispWriteStr(NIL, "; sform\n", 9);
+ j++;
+ }
+ }
+
+ if (alist->rest) {
+ sprintf(buffer, "%d = ", j);
+ len1 = strlen(buffer);
+ LispWriteStr(NIL, buffer, len1);
+ ptr = alist->rest->data.atom->string;
+ len2 = strlen(ptr);
+ LispWriteStr(NIL, ptr, len2);
+ LispWriteChar(NIL, '\n');
+ j++;
+ }
+
+ for (i = 0; i < alist->auxs.num_symbols; i++, j++) {
+ sprintf(buffer, "%d = ", j);
+ len1 = strlen(buffer);
+ LispWriteStr(NIL, buffer, len1);
+ ptr = alist->auxs.symbols[i]->data.atom->string;
+ len2 = strlen(ptr);
+ LispWriteStr(NIL, ptr, len2);
+ LispWriteChars(NIL, ' ', 28 - (len1 + len2));
+ LispWriteStr(NIL, "; aux\n", 7);
+ }
+ }
+ }
+
+ LispWriteStr(NIL, "\nBytecode stream:\n", 18);
+
+ base = stream;
+ for (done = j = 0; !done; j = 0) {
+ sym0 = sym1 = con0 = con1 = bui0 = byt0 = strd = strf = -1;
+ sprintf(buffer, "%4ld ", (long)(stream - base));
+ ptr = buffer + strlen(buffer);
+ switch (*stream++) {
+ case XBC_NOOP: strcpy(ptr, "NOOP"); break;
+ case XBC_PRED:
+ strcpy(ptr, "PRED:");
+ ptr += strlen(ptr);
+ goto predicate;
+ case XBC_INV: strcpy(ptr, "INV"); break;
+ case XBC_NIL: strcpy(ptr, "NIL"); break;
+ case XBC_T: strcpy(ptr, "T"); break;
+ case XBC_CAR: strcpy(ptr, "CAR"); break;
+ case XBC_CDR: strcpy(ptr, "CDR"); break;
+ case XBC_RPLACA:strcpy(ptr, "RPLACA"); break;
+ case XBC_RPLACD:strcpy(ptr, "RPLACD"); break;
+ case XBC_EQ: strcpy(ptr, "EQ"); break;
+ case XBC_EQL: strcpy(ptr, "EQL"); break;
+ case XBC_EQUAL: strcpy(ptr, "EQUAL"); break;
+ case XBC_EQUALP:strcpy(ptr, "EQUALP"); break;
+ case XBC_LENGTH:strcpy(ptr, "LENGTH"); break;
+ case XBC_LAST: strcpy(ptr, "LAST"); break;
+ case XBC_NTHCDR:strcpy(ptr, "NTHCDR"); break;
+ case XBC_PUSH: strcpy(ptr, "PUSH"); break;
+ case XBC_CAR_PUSH:
+ strcpy(ptr, "CAR&PUSH");
+ break;
+ case XBC_CDR_PUSH:
+ strcpy(ptr, "CDR&PUSH");
+ break;
+ case XBC_PUSH_NIL:
+ strcpy(ptr, "PUSH NIL");
+ break;
+ case XBC_PUSH_UNSPEC:
+ strcpy(ptr, "PUSH #<UNSPEC>");
+ break;
+ case XBC_PUSH_T:
+ strcpy(ptr, "PUSH T");
+ break;
+ case XBC_PUSH_NIL_N:
+ strcpy(ptr, "PUSH NIL ");
+ ptr += strlen(ptr);
+ sprintf(ptr, "%d", (int)(*stream++));
+ break;
+ case XBC_PUSH_UNSPEC_N:
+ strcpy(ptr, "PUSH #<UNSPEC> ");
+ ptr += strlen(ptr);
+ sprintf(ptr, "%d", (int)(*stream++));
+ break;
+ case XBC_LET:
+ strcpy(ptr, "LET");
+/* update sym0 */
+symbol:
+ offsets[j++] = &sym0;
+/* update <offsets> - print [byte] */
+offset:
+ ptr += strlen(ptr);
+ i = *stream++;
+ *(offsets[j - 1]) = i;
+ sprintf(ptr, " [%d]", i);
+ break;
+ case XBC_LETX:
+ strcpy(ptr, "LET*");
+ goto symbol;
+ case XBC_LET_NIL:
+ strcpy(ptr, "LET NIL");
+ goto symbol;
+ case XBC_LETX_NIL:
+ strcpy(ptr, "LET* NIL");
+ goto symbol;
+ case XBC_LETBIND:
+ strcpy(ptr, "LETBIND");
+/* print byte */
+value:
+ ptr += strlen(ptr);
+ sprintf(ptr, " %d", (int)(*stream++));
+ break;
+ case XBC_UNLET:strcpy(ptr, "UNLET"); goto value;
+ case XBC_LOAD:
+ strcpy(ptr, "LOAD");
+/* print (byte) */
+reference:
+ ptr += strlen(ptr);
+ i = *stream++;
+ sprintf(ptr, " (%d)", i);
+ break;
+ case XBC_LOAD_CAR:
+ strcpy(ptr, "LOAD&CAR");
+ goto reference;
+ case XBC_LOAD_CDR:
+ strcpy(ptr, "LOAD&CDR");
+ goto reference;
+ case XBC_LOAD_CAR_STORE:
+ strcpy(ptr, "LOAD&CAR&STORE");
+ goto reference;
+ case XBC_LOAD_CDR_STORE:
+ strcpy(ptr, "LOAD&CDR&STORE");
+ goto reference;
+ case XBC_LOAD_LET:
+ strcpy(ptr, "LOAD&LET");
+load_let:
+ offsets[j++] = &sym0;
+ i = *stream++;
+ ptr += strlen(ptr);
+ sprintf(ptr, " (%d)", i);
+ goto offset;
+ case XBC_LOAD_LETX:
+ strcpy(ptr, "LOAD&LET*");
+ goto load_let;
+ case XBC_STRUCT:
+ strcpy(ptr, "STRUCT");
+ offsets[j++] = &strf;
+ offsets[j++] = &strd;
+/* update <offsets> - print [byte] - update <offsets> - print [byte] */
+offset_offset:
+ ptr += strlen(ptr);
+ i = *stream++;
+ *(offsets[j - 2]) = i;
+ sprintf(ptr, " [%d]", i);
+ goto offset;
+ case XBC_LOAD_PUSH:
+ strcpy(ptr, "LOAD&PUSH");
+ goto reference;
+ case XBC_LOADCON:
+ strcpy(ptr, "LOADCON");
+constant:
+ offsets[j++] = &con0;
+ goto offset;
+ case XBC_LOADCON_SET:
+ strcpy(ptr, "LOADCON&SET");
+ offsets[j++] = &con0;
+/* update <offsets> - print [byte] - print (byte) */
+offset_reference:
+ i = *stream++;
+ *(offsets[j - 1]) = i;
+ ptr += strlen(ptr);
+ sprintf(ptr, " [%d]", i);
+ goto reference;
+ case XBC_STRUCTP:
+ strcpy(ptr, "STRUCTP");
+ offsets[j++] = &strd;
+ goto offset;
+ case XBC_LOADCON_LET:
+ strcpy(ptr, "LOADCON&LET");
+loadcon_let:
+ offsets[j++] = &con0;
+ offsets[j++] = &sym0;
+ goto offset_offset;
+ case XBC_LOADCON_LETX:
+ strcpy(ptr, "LOADCON&LET*");
+ goto loadcon_let;
+ case XBC_LOADCON_PUSH:
+ strcpy(ptr, "LOADCON&PUSH");
+ goto constant;
+ case XBC_LOADSYM:
+ strcpy(ptr, "LOADSYM");
+ goto symbol;
+ case XBC_LOADSYM_LET:
+ strcpy(ptr, "LOADSYM&LET");
+loadsym_let:
+ offsets[j++] = &sym0;
+ offsets[j++] = &sym1;
+ goto offset_offset;
+ case XBC_LOADSYM_LETX:
+ strcpy(ptr, "LOADSYM&LET*");
+ goto loadsym_let;
+ case XBC_LOADSYM_PUSH:
+ strcpy(ptr, "LOADSYM&PUSH");
+ goto symbol;
+ case XBC_LOAD_SET:
+ strcpy(ptr, "LOAD&SET");
+/* print (byte) - print (byte) */
+reference_reference:
+ ptr += strlen(ptr);
+ i = *stream++;
+ sprintf(ptr, " (%d)", i);
+ goto reference;
+ case XBC_LOAD_CAR_SET:
+ strcpy(ptr, "LOAD&CAR&SET");
+ goto reference_reference;
+ case XBC_LOAD_CDR_SET:
+ strcpy(ptr, "LOAD&CDR&SET");
+ goto reference_reference;
+ case XBC_CAR_SET:
+ strcpy(ptr, "CAR&SET");
+ goto reference;
+ case XBC_CDR_SET:
+ strcpy(ptr, "CDR&SET");
+ goto reference;
+ case XBC_SET:
+ strcpy(ptr, "SET");
+ goto reference;
+ case XBC_SETSYM:
+ strcpy(ptr, "SETSYM");
+ goto symbol;
+ case XBC_SET_NIL:
+ strcpy(ptr, "SET NIL");
+ goto reference;
+ case XBC_CALL:
+ strcpy(ptr, "CALL");
+ ptr += strlen(ptr);
+ sprintf(ptr, " %d", (int)(*stream++));
+ offsets[j++] = &bui0;
+ goto offset;
+ case XBC_CALL_SET:
+ strcpy(ptr, "CALL&SET");
+ ptr += strlen(ptr);
+ sprintf(ptr, " %d", (int)(*stream++));
+ offsets[j++] = &bui0;
+ goto offset_reference;
+ case XBC_BYTECALL:
+ strcpy(ptr, "BYTECALL");
+ ptr += strlen(ptr);
+ sprintf(ptr, " %d", (int)(*stream++));
+ offsets[j++] = &byt0;
+ goto offset;
+ case XBC_FUNCALL:
+ strcpy(ptr, "FUNCALL");
+constant_constant:
+ offsets[j++] = &con0;
+ offsets[j++] = &con1;
+ goto offset_offset;
+ case XBC_CCONS:
+ strcpy(ptr, "CCONS");
+ goto constant_constant;
+ case XBC_CSTAR: strcpy(ptr, "CSTAR"); break;
+ case XBC_CFINI: strcpy(ptr, "CFINI"); break;
+ case XBC_LSTAR: strcpy(ptr, "LSTAR"); break;
+ case XBC_LCONS: strcpy(ptr, "LCONS"); break;
+ case XBC_LFINI: strcpy(ptr, "LFINI"); break;
+ case XBC_BCONS: strcpy(ptr, "BCONS"); break;
+ case XBC_BCONS1: case XBC_BCONS2: case XBC_BCONS3:
+ case XBC_BCONS4: case XBC_BCONS5: case XBC_BCONS6:
+ case XBC_BCONS7:
+ strcpy(ptr, "BCONS");
+ ptr += strlen(ptr);
+ sprintf(ptr, "%d", (int)(stream[-1] - XBC_BCONS));
+ break;
+ case XBC_JUMP:
+ strcpy(ptr, "JUMP");
+integer:
+ ptr += strlen(ptr);
+ sprintf(ptr, " %d", *(signed short*)stream);
+ stream += sizeof(short);
+ break;
+ case XBC_JUMPT:
+ strcpy(ptr, "JUMPT");
+ goto integer;
+ case XBC_JUMPNIL:
+ strcpy(ptr, "JUMPNIL");
+ goto integer;
+ case XBC_LETREC:
+ strcpy(ptr, "LETREC");
+ ptr += strlen(ptr);
+ sprintf(ptr, " %d", (int)*stream++);
+ break;
+ case XBC_RETURN:
+ strcpy(ptr, "RETURN");
+ done = 1;
+ break;
+ }
+ i = ptr - buffer + strlen(ptr);
+ LispWriteStr(NIL, buffer, i);
+ if (j) {
+
+ /* Pad */
+ LispWriteChars(NIL, ' ', 28 - i);
+ LispWriteChar(NIL, ';');
+
+ ptr = buffer;
+
+ /* Structure */
+ if (strf >= 0) {
+ /* strd is valid if strf set */
+ LispObj *fields = constants[strd];
+
+ for (; strf >= 0; strf--)
+ fields = CDR(fields);
+ strcpy(ptr, " "); ptr += 2;
+ strcpy(ptr, CAR(fields)->data.atom->string);
+ ptr += strlen(ptr);
+ }
+ if (strd >= 0) {
+ strcpy(ptr, " "); ptr += 2;
+ strcpy(ptr, STROBJ(CAR(constants[strd])));
+ ptr += strlen(ptr);
+ }
+
+ /* Constants */
+ if (con0 >= 0) {
+ strcpy(ptr, " "); ptr += 2;
+ strcpy(ptr, STROBJ(constants[con0]));
+ ptr += strlen(ptr);
+ if (con1 >= 0) {
+ strcpy(ptr, " "); ptr += 2;
+ strcpy(ptr, STROBJ(constants[con1]));
+ ptr += strlen(ptr);
+ }
+ }
+
+ /* Builtin */
+ if (bui0 >= 0) {
+ strcpy(ptr, " "); ptr += 2;
+ strcpy(ptr, STROBJ(builtins[bui0]->symbol));
+ ptr += strlen(ptr);
+ }
+
+ /* Bytecode */
+ if (byt0 >= 0) {
+ strcpy(ptr, " "); ptr += 2;
+ strcpy(ptr, STROBJ(names[byt0]));
+ ptr += strlen(ptr);
+ }
+
+ /* Symbols */
+ if (sym0 >= 0) {
+ strcpy(ptr, " "); ptr += 2;
+ strcpy(ptr, XSTRING(symbols[sym0]->string));
+ ptr += strlen(ptr);
+ if (sym1 >= 0) {
+ strcpy(ptr, " "); ptr += 2;
+ strcpy(ptr, XSTRING(symbols[sym1]->string));
+ ptr += strlen(ptr);
+ }
+ }
+
+ i = ptr - buffer;
+ LispWriteStr(NIL, buffer, i);
+ }
+ LispWriteChar(NIL, '\n');
+ continue;
+predicate:
+ switch (*stream++) {
+ case XBP_CONSP: strcpy(ptr, "CONSP"); break;
+ case XBP_LISTP: strcpy(ptr, "LISTP"); break;
+ case XBP_NUMBERP: strcpy(ptr, "NUMBERP"); break;
+ }
+ LispWriteStr(NIL, buffer, ptr - buffer + strlen(ptr));
+ LispWriteChar(NIL, '\n');
+ }
+#undef XSTRING
+ }
+
+ return (function);
+}
+
+
+
+LispObj *
+LispCompileForm(LispObj *form)
+{
+ GC_ENTER();
+ int failed, *pfailed;
+ LispCom com;
+ LispObj *code, **pform;
+
+ if (!CONSP(form))
+ /* Incorrect call or NIL */
+ return (form);
+
+ memset(&com, 0, sizeof(LispCom));
+
+ com.toplevel = com.block = LispCalloc(1, sizeof(CodeBlock));
+ com.block->type = LispBlockNone;
+ com.lex = lisp__data.env.lex;
+
+ com.plist = CONS(NIL, NIL);
+ GC_PROTECT(com.plist);
+
+ pfailed = &failed;
+ pform = &form;
+ failed = 1;
+ if (setjmp(com.jmp) == 0) {
+ for (code = form; CONSP(form); form = CDR(form)) {
+ com.form = form;
+ ComEval(&com, CAR(form));
+ }
+ failed = 0;
+ }
+ GC_LEAVE();
+
+ return (failed ? NIL : MakeBytecodeObject(&com, NIL, NIL));
+}
+
+LispObj *
+LispExecuteBytecode(LispObj *object)
+{
+ if (!BYTECODEP(object))
+ return (EVAL(object));
+
+ return (ExecuteBytecode(object->data.bytecode.bytecode->code));
+}
+
+static LispObj *
+MakeBytecodeObject(LispCom *com, LispObj *name, LispObj *plist)
+{
+ LispObj *object;
+ LispBytecode *bytecode;
+
+ GC_ENTER();
+ unsigned char *stream;
+ short i, num_constants;
+ LispObj **constants, *code, *cons, *prev;
+
+ /* Resolve dependencies, optimize and create byte stream */
+ LinkBytecode(com);
+
+ object = LispNew(NIL, NIL);
+ GC_PROTECT(object);
+ bytecode = LispMalloc(sizeof(LispBytecode));
+ bytecode->code = com->bytecode;
+ bytecode->length = com->length;
+
+
+ stream = bytecode->code;
+
+ /* Skip stack information */
+ stream += sizeof(short) * 3;
+
+ /* Get information */
+ num_constants = *(short*)stream;
+ stream += sizeof(short) * 4;
+ constants = (LispObj**)stream;
+
+ GC_PROTECT(plist);
+ code = cons = prev = NIL;
+ for (i = 0; i < num_constants; i++) {
+ if (POINTERP(constants[i]) && !XSYMBOLP(constants[i])) {
+ if (code == NIL) {
+ code = cons = prev = CONS(constants[i], NIL);
+ GC_PROTECT(code);
+ }
+ else {
+ RPLACD(cons, CONS(constants[i], NIL));
+ prev = cons;
+ cons = CDR(cons);
+ }
+ }
+ }
+
+ /* Protect this in case the function is redefined */
+ for (i = 0; i < com->table.num_bytecodes; i++) {
+ if (code == NIL) {
+ code = cons = prev = CONS(com->table.bytecodes[i], NIL);
+ GC_PROTECT(code);
+ }
+ else {
+ RPLACD(cons, CONS(com->table.bytecodes[i], NIL));
+ prev = cons;
+ cons = CDR(cons);
+ }
+ }
+
+ /* Free everything, but the LispCom structure and the generated bytecode */
+ CompileFreeState(com);
+
+ /* Allocate the minimum required number of cons cells to protect objects */
+ if (!CONSP(code))
+ code = plist;
+ else if (CONSP(plist)) {
+ if (code == cons)
+ RPLACD(code, plist);
+ else
+ RPLACD(cons, plist);
+ }
+ else {
+ if (code == cons)
+ code = CAR(code);
+ else
+ CDR(prev) = CAR(cons);
+ }
+
+ object->data.bytecode.bytecode = bytecode;
+ /* Byte code references this object, so it cannot be garbage collected */
+ object->data.bytecode.code = code;
+ object->data.bytecode.name = name;
+ object->type = LispBytecode_t;
+
+ LispMused(bytecode);
+ LispMused(bytecode->code);
+ GC_LEAVE();
+
+ return (object);
+}
+
+static void
+CompileFreeTree(CodeTree *tree)
+{
+ if (tree->type == CodeTreeBlock)
+ CompileFreeBlock(tree->data.block);
+ LispFree(tree);
+}
+
+static void
+CompileFreeBlock(CodeBlock *block)
+{
+ CodeTree *tree = block->tree, *next;
+
+ while (tree) {
+ next = tree->next;
+ CompileFreeTree(tree);
+ tree = next;
+ }
+ if (block->type == LispBlockBody) {
+ LispFree(block->tagbody.labels);
+ LispFree(block->tagbody.codes);
+ }
+ LispFree(block->variables.symbols);
+ LispFree(block->variables.flags);
+ LispFree(block);
+}
+
+static void
+CompileFreeState(LispCom *com)
+{
+ CompileFreeBlock(com->block);
+ LispFree(com->table.constants);
+ LispFree(com->table.symbols);
+ LispFree(com->table.builtins);
+ LispFree(com->table.bytecodes);
+}
+
+/* XXX Put a breakpoint here when changing the macro expansion code.
+ * No opcodes should be generated during macro expansion. */
+static CodeTree *
+CompileNewTree(LispCom *com, CodeTreeType type)
+{
+ CodeTree *tree = LispMalloc(sizeof(CodeTree));
+
+ tree->type = type;
+ tree->next = NULL;
+ tree->block = com->block;
+ if (com->block->tree == NULL)
+ com->block->tree = tree;
+ else
+ com->block->tail->next = tree;
+ com->block->tail = tree;
+
+ return (tree);
+}
+
+static void
+CompileIniBlock(LispCom *com, LispBlockType type, LispObj *tag)
+{
+ CodeTree *tree = NEW_TREE(CodeTreeBlock);
+ CodeBlock *block = LispCalloc(1, sizeof(CodeBlock));
+
+ tree->data.block = block;
+
+ block->type = type;
+ block->tag = tag;
+ block->prev = com->block;
+ block->parent = tree;
+ block->level = com->level;
+ com->block = block;
+
+ if (type == LispBlockBody)
+ com->tagbody = com->level;
+}
+
+static void
+CompileFiniBlock(LispCom *com)
+{
+ com->block = com->block->prev;
+ if (com->block && com->block->type == LispBlockBody)
+ com->tagbody = com->block->level;
+}
+
+static void
+com_BytecodeChar(LispCom *com, LispByteOpcode code, char value)
+{
+ CodeTree *tree = NEW_TREE(CodeTreeBytecode);
+
+ tree->code = code;
+ tree->data.signed_char = value;
+}
+
+static void
+com_BytecodeShort(LispCom *com, LispByteOpcode code, short value)
+{
+ CodeTree *tree = NEW_TREE(CodeTreeBytecode);
+
+ tree->code = code;
+ tree->data.signed_short = value;
+}
+
+static void
+com_BytecodeAtom(LispCom *com, LispByteOpcode code, LispAtom *atom)
+{
+ CodeTree *tree = NEW_TREE(CodeTreeBytecode);
+
+ tree->code = code;
+ tree->data.atom = atom;
+}
+
+static void
+com_BytecodeObject(LispCom *com, LispByteOpcode code, LispObj *object)
+{
+ CodeTree *tree = NEW_TREE(CodeTreeBytecode);
+
+ tree->code = code;
+ tree->data.object = object;
+}
+
+static void
+com_BytecodeCons(LispCom *com, LispByteOpcode code, LispObj *car, LispObj *cdr)
+{
+ CodeTree *tree = NEW_TREE(CodeTreeBytecode);
+
+ tree->code = code;
+ tree->data.cons.car = car;
+ tree->data.cons.cdr = cdr;
+}
+
+static void
+com_Bytecode(LispCom *com, LispByteOpcode code)
+{
+ CodeTree *tree = NEW_TREE(CodeTreeBytecode);
+
+ tree->code = code;
+}
+
+static void
+com_Load(LispCom *com, short offset)
+{
+ com_BytecodeShort(com, XBC_LOAD, offset);
+}
+
+static void
+com_LoadLet(LispCom *com, short offset, LispAtom *name)
+{
+ CodeTree *tree = NEW_TREE(CodeTreeBytecode);
+
+ tree->code = XBC_LOAD_LET;
+ tree->data.let.offset = offset;
+ tree->data.let.name = name;
+}
+
+static void
+com_LoadPush(LispCom *com, short offset)
+{
+ com_BytecodeShort(com, XBC_LOAD_PUSH, offset);
+}
+
+static void
+com_Let(LispCom *com, LispAtom *name)
+{
+ com_BytecodeAtom(com, XBC_LET, name);
+}
+
+static void
+com_Bind(LispCom *com, short count)
+{
+ if (count)
+ com_BytecodeShort(com, XBC_LETBIND, count);
+}
+
+static void
+com_Unbind(LispCom *com, short count)
+{
+ if (count)
+ com_BytecodeShort(com, XBC_UNLET, count);
+}
+
+static void
+com_LoadSym(LispCom *com, LispAtom *atom)
+{
+ com_BytecodeAtom(com, XBC_LOADSYM, atom);
+}
+
+static void
+com_LoadSymLet(LispCom *com, LispAtom *symbol, LispAtom *name)
+{
+ CodeTree *tree = NEW_TREE(CodeTreeBytecode);
+
+ tree->code = XBC_LOADSYM_LET;
+ tree->data.let_sym.symbol = symbol;
+ tree->data.let_sym.name = name;
+}
+
+static void
+com_LoadSymPush(LispCom *com, LispAtom *name)
+{
+ com_BytecodeAtom(com, XBC_LOADSYM_PUSH, name);
+}
+
+static void
+com_LoadCon(LispCom *com, LispObj *constant)
+{
+ if (constant == NIL)
+ com_Bytecode(com, XBC_NIL);
+ else if (constant == T)
+ com_Bytecode(com, XBC_T);
+ else if (constant == UNSPEC) {
+ COMPILE_FAILURE("internal error: loading #<UNSPEC>");
+ }
+ else
+ com_BytecodeObject(com, XBC_LOADCON, constant);
+}
+
+static void
+com_LoadConLet(LispCom *com, LispObj *constant, LispAtom *name)
+{
+ if (constant == NIL)
+ com_BytecodeAtom(com, XBC_LET_NIL, name);
+ else {
+ CodeTree *tree = NEW_TREE(CodeTreeBytecode);
+
+ tree->code = XBC_LOADCON_LET;
+ tree->data.let_con.object = constant;
+ tree->data.let_con.name = name;
+ }
+}
+
+static void
+com_LoadConPush(LispCom *com, LispObj *constant)
+{
+ if (constant == NIL)
+ com_Bytecode(com, XBC_PUSH_NIL);
+ else if (constant == T)
+ com_Bytecode(com, XBC_PUSH_T);
+ else if (constant == UNSPEC)
+ com_Bytecode(com, XBC_PUSH_UNSPEC);
+ else
+ com_BytecodeObject(com, XBC_LOADCON_PUSH, constant);
+}
+
+static void
+com_Set(LispCom *com, short offset)
+{
+ com_BytecodeShort(com, XBC_SET, offset);
+}
+
+static void
+com_SetSym(LispCom *com, LispAtom *symbol)
+{
+ com_BytecodeAtom(com, XBC_SETSYM, symbol);
+}
+
+static void
+com_Struct(LispCom *com, short offset, LispObj *definition)
+{
+ CodeTree *tree = NEW_TREE(CodeTreeBytecode);
+
+ tree->code = XBC_STRUCT;
+ tree->data.struc.offset = offset;
+ tree->data.struc.definition = definition;
+}
+
+static void
+com_Structp(LispCom *com, LispObj *definition)
+{
+ com_BytecodeObject(com, XBC_STRUCTP, definition);
+}
+
+static void
+com_Call(LispCom *com, unsigned char num_arguments, LispBuiltin *builtin)
+{
+ CodeTree *tree = NEW_TREE(CodeTreeBytecode);
+
+ tree->code = XBC_CALL;
+ tree->data.builtin.num_arguments = num_arguments;
+ tree->data.builtin.builtin = builtin;
+}
+
+static void
+com_Bytecall(LispCom *com, unsigned char num_arguments, LispObj *code)
+{
+ CodeTree *tree = NEW_TREE(CodeTreeBytecode);
+
+ tree->code = XBC_BYTECALL;
+ tree->data.bytecall.num_arguments = num_arguments;
+ tree->data.bytecall.code = code;
+}
+
+static void
+com_Funcall(LispCom *com, LispObj *function, LispObj *arguments)
+{
+ com_BytecodeCons(com, XBC_FUNCALL, function, arguments);
+}
+
+static void
+CompileStackEnter(LispCom *com, int count, int builtin)
+{
+ if (!com->macro) {
+ if (builtin) {
+ com->stack.cbstack += count;
+ if (com->stack.bstack < com->stack.cbstack)
+ com->stack.bstack = com->stack.cbstack;
+ }
+ else {
+ com->stack.cstack += count;
+ if (com->stack.stack < com->stack.cstack)
+ com->stack.stack = com->stack.cstack;
+ }
+ }
+}
+
+static void
+CompileStackLeave(LispCom *com, int count, int builtin)
+{
+ if (!com->macro) {
+ if (builtin)
+ com->stack.cbstack -= count;
+ else
+ com->stack.cstack -= count;
+ }
+}
+
+static void
+LinkWarnUnused(LispCom *com, CodeBlock *block)
+{
+ int i;
+ CodeTree *tree;
+
+ for (tree = block->tree; tree; tree = tree->next) {
+ if (tree->type == CodeTreeBlock)
+ LinkWarnUnused(com, tree->data.block);
+ }
+
+ for (i = 0; i < block->variables.length; i++)
+ if (!(block->variables.flags[i] & (VARIABLE_USED | VARIABLE_ARGUMENT))) {
+ ++com->warnings;
+ LispWarning("the variable %s is unused",
+ block->variables.symbols[i]->string);
+ }
+}
+
+#define INTERNAL_ERROR_STRING "COMPILE: internal error #%d"
+#define INTERNAL_ERROR(value) LispDestroy(INTERNAL_ERROR_STRING, value)
+static long
+LinkBuildOffsets(LispCom *com, CodeTree *tree, long offset)
+{
+ for (; tree; tree = tree->next) {
+ tree->offset = offset;
+ switch (tree->type) {
+ case CodeTreeBytecode:
+ switch (tree->code) {
+ case XBC_NOOP:
+ INTERNAL_ERROR(__LINE__);
+ break;
+
+ /* byte */
+ case XBC_BCONS:
+ case XBC_BCONS1:
+ case XBC_BCONS2:
+ case XBC_BCONS3:
+ case XBC_BCONS4:
+ case XBC_BCONS5:
+ case XBC_BCONS6:
+ case XBC_BCONS7:
+ case XBC_INV:
+ case XBC_NIL:
+ case XBC_T:
+ case XBC_PUSH:
+ case XBC_CAR_PUSH:
+ case XBC_CDR_PUSH:
+ case XBC_PUSH_NIL:
+ case XBC_PUSH_UNSPEC:
+ case XBC_PUSH_T:
+ case XBC_LSTAR:
+ case XBC_LCONS:
+ case XBC_LFINI:
+ case XBC_RETURN:
+ case XBC_CSTAR:
+ case XBC_CFINI:
+ case XBC_CAR:
+ case XBC_CDR:
+ case XBC_RPLACA:
+ case XBC_RPLACD:
+ case XBC_EQ:
+ case XBC_EQL:
+ case XBC_EQUAL:
+ case XBC_EQUALP:
+ case XBC_LENGTH:
+ case XBC_LAST:
+ case XBC_NTHCDR:
+ ++offset;
+ break;
+
+ /* byte + byte */
+ case XBC_PUSH_NIL_N:
+ case XBC_PUSH_UNSPEC_N:
+ case XBC_PRED:
+ case XBC_LETREC:
+ case XBC_LOAD_PUSH:
+ case XBC_CAR_SET:
+ case XBC_CDR_SET:
+ case XBC_SET:
+ case XBC_SET_NIL:
+ case XBC_LETBIND:
+ case XBC_UNLET:
+ case XBC_LOAD:
+ case XBC_LOAD_CAR:
+ case XBC_LOAD_CDR:
+ case XBC_LOAD_CAR_STORE:
+ case XBC_LOAD_CDR_STORE:
+ case XBC_LET:
+ case XBC_LETX:
+ case XBC_LET_NIL:
+ case XBC_LETX_NIL:
+ case XBC_STRUCTP:
+ case XBC_SETSYM:
+ case XBC_LOADCON_PUSH:
+ case XBC_LOADSYM_PUSH:
+ case XBC_LOADCON:
+ case XBC_LOADSYM:
+ offset += 2;
+ break;
+
+ /* byte + byte + byte */
+ case XBC_CALL:
+ case XBC_BYTECALL:
+ case XBC_LOAD_SET:
+ case XBC_LOAD_CAR_SET:
+ case XBC_LOAD_CDR_SET:
+ case XBC_LOADCON_SET:
+ case XBC_LOAD_LET:
+ case XBC_LOAD_LETX:
+ case XBC_STRUCT:
+ case XBC_LOADCON_LET:
+ case XBC_LOADCON_LETX:
+ case XBC_LOADSYM_LET:
+ case XBC_LOADSYM_LETX:
+ case XBC_CCONS:
+ case XBC_FUNCALL:
+ offset += 3;
+ break;
+
+ /* byte + short */
+ case XBC_JUMP:
+ case XBC_JUMPT:
+ case XBC_JUMPNIL:
+ /* XXX this is likely a jump to random address here */
+ INTERNAL_ERROR(__LINE__);
+ offset += sizeof(short) + 1;
+ break;
+
+ /* byte + byte + byte + byte */
+ case XBC_CALL_SET:
+ offset += 4;
+ break;
+ }
+ break;
+ case CodeTreeLabel:
+ /* Labels are not loaded */
+ break;
+ case CodeTreeJump:
+ case CodeTreeJumpIf:
+ case CodeTreeCond:
+ /* If not the point where the conditional block finishes */
+ if (tree->code != XBC_NOOP)
+ /* Reserve space for the jump opcode */
+ offset += sizeof(short) + 1;
+ break;
+ case CodeTreeGo:
+ case CodeTreeReturn:
+ /* Reserve space for the jump opcode */
+ offset += sizeof(short) + 1;
+ break;
+ case CodeTreeBlock:
+ offset = LinkBuildOffsets(com, tree->data.block->tree, offset);
+ break;
+ }
+ }
+
+ return (offset);
+}
+
+static void
+LinkDoOptimize_0(LispCom *com, CodeBlock *block)
+{
+ CodeTree *tree, *prev, *next;
+
+ /* Remove redundant or join opcodes that can be joined. Do it here
+ * because some of these are hard to detect earlier, and/or would
+ * require a lot of duplicated code or more time. */
+ tree = prev = block->tree;
+ while (tree) {
+ next = tree->next;
+
+ /* LET -> LET* */
+ if (next &&
+ next->type == CodeTreeBytecode &&
+ next->code == XBC_LETBIND &&
+ next->data.signed_short == 1) {
+ switch (tree->code) {
+ case XBC_LET:
+ tree->code = XBC_LETX;
+ goto remove_next_label;
+ case XBC_LET_NIL:
+ tree->code = XBC_LETX_NIL;
+ goto remove_next_label;
+ case XBC_LOAD_LET:
+ tree->code = XBC_LOAD_LETX;
+ goto remove_next_label;
+ case XBC_LOADCON_LET:
+ tree->code = XBC_LOADCON_LETX;
+ goto remove_next_label;
+ case XBC_LOADSYM_LET:
+ tree->code = XBC_LOADSYM_LETX;
+ goto remove_next_label;
+ default:
+ break;
+ }
+ }
+
+ switch (tree->type) {
+ case CodeTreeBytecode:
+ switch (tree->code) {
+ case XBC_LOADCON:
+ if (next && next->type == CodeTreeBytecode) {
+ switch (next->code) {
+ case XBC_LET:
+ next->code = XBC_LOADCON_LET;
+ next->data.let_con.name =
+ next->data.atom;
+ next->data.let_con.object =
+ tree->data.object;
+ goto remove_label;
+ case XBC_PUSH:
+ next->code = XBC_LOADCON_PUSH;
+ next->data.object = tree->data.object;
+ goto remove_label;
+ case XBC_CAR:
+ if (tree->data.object != NIL) {
+ if (!CONSP(tree->data.object))
+ LispDestroy("CAR: %s is not a list",
+ STROBJ(
+ tree->data.object));
+ next->code = XBC_LOADCON;
+ next->data.object =
+ CAR(tree->data.object);
+ }
+ goto remove_label;
+ case XBC_CDR:
+ if (tree->data.object != NIL) {
+ if (!CONSP(tree->data.object))
+ LispDestroy("CAR: %s is not a list",
+ STROBJ(
+ tree->data.object));
+ next->code = XBC_LOADCON;
+ next->data.object =
+ CDR(tree->data.object);
+ }
+ goto remove_label;
+ case XBC_SET:
+ next->code = XBC_LOADCON_SET;
+ next->data.load_con_set.offset =
+ next->data.signed_short;
+ next->data.load_con_set.object =
+ tree->data.object;
+ goto remove_label;
+ default:
+ break;
+ }
+ }
+ break;
+ case XBC_LOADSYM:
+ if (next && next->type == CodeTreeBytecode) {
+ switch (next->code) {
+ case XBC_LET:
+ next->code = XBC_LOADSYM_LET;
+ next->data.let_sym.name =
+ next->data.atom;
+ next->data.let_sym.symbol =
+ tree->data.atom;
+ goto remove_label;
+ case XBC_PUSH:
+ next->code = XBC_LOADSYM_PUSH;
+ next->data.atom = tree->data.atom;
+ goto remove_label;
+ default:
+ break;
+ }
+ }
+ break;
+ case XBC_LOAD:
+ if (next && next->type == CodeTreeBytecode) {
+ switch (next->code) {
+ case XBC_SET:
+ next->code = XBC_LOAD_SET;
+ next->data.load_set.set =
+ next->data.signed_short;
+ next->data.load_set.load =
+ tree->data.signed_short;
+ goto remove_label;
+ /* TODO add XBC_LOAD_SETSYM */
+ case XBC_CAR:
+ next->code = XBC_LOAD_CAR;
+ next->data.signed_short =
+ tree->data.signed_short;
+ goto remove_label;
+ case XBC_CDR:
+ next->code = XBC_LOAD_CDR;
+ next->data.signed_short =
+ tree->data.signed_short;
+ goto remove_label;
+ case XBC_PUSH:
+ tree->code = XBC_LOAD_PUSH;
+ goto remove_next_label;
+ case XBC_LET:
+ next->code = XBC_LOAD_LET;
+ next->data.let.name = next->data.atom;
+ next->data.let.offset =
+ tree->data.signed_short;
+ goto remove_label;
+ default:
+ break;
+ }
+ }
+ break;
+ case XBC_LOAD_CAR:
+ if (next && next->type == CodeTreeBytecode &&
+ next->code == XBC_SET) {
+ if (next->data.signed_short ==
+ tree->data.signed_short)
+ next->code = XBC_LOAD_CAR_STORE;
+ else {
+ next->code = XBC_LOAD_CAR_SET;
+ next->data.load_set.set =
+ next->data.signed_short;
+ next->data.load_set.load =
+ tree->data.signed_short;
+ }
+ goto remove_label;
+ }
+ break;
+ case XBC_LOAD_CDR:
+ if (next && next->type == CodeTreeBytecode &&
+ next->code == XBC_SET) {
+ if (next->data.signed_short ==
+ tree->data.signed_short)
+ next->code = XBC_LOAD_CDR_STORE;
+ else {
+ next->code = XBC_LOAD_CDR_SET;
+ next->data.load_set.set =
+ next->data.signed_short;
+ next->data.load_set.load =
+ tree->data.signed_short;
+ }
+ goto remove_label;
+ }
+ break;
+ case XBC_CALL:
+ if (next && next->type == CodeTreeBytecode) {
+ switch (next->code) {
+ case XBC_SET:
+ next->code = XBC_CALL_SET;
+ next->data.builtin.offset =
+ next->data.signed_short;
+ next->data.builtin.num_arguments =
+ tree->data.builtin.num_arguments;
+ next->data.builtin.builtin =
+ tree->data.builtin.builtin;
+ goto remove_label;
+ /* TODO add XBC_CALL_SETSYM */
+ default:
+ break;
+ }
+ }
+ break;
+ case XBC_CAR:
+ if (next && next->type == CodeTreeBytecode) {
+ switch (next->code) {
+ case XBC_SET:
+ next->code = XBC_CAR_SET;
+ goto remove_label;
+ /* TODO add XBC_CAR_SETSYM */
+ case XBC_PUSH:
+ next->code = XBC_CAR_PUSH;
+ goto remove_label;
+ default:
+ break;
+ }
+ }
+ break;
+ case XBC_CDR:
+ if (next && next->type == CodeTreeBytecode) {
+ switch (next->code) {
+ case XBC_SET:
+ next->code = XBC_CDR_SET;
+ goto remove_label;
+ /* TODO add XBC_CDR_SETSYM */
+ case XBC_PUSH:
+ next->code = XBC_CDR_PUSH;
+ goto remove_label;
+ default:
+ break;
+ }
+ }
+ break;
+ case XBC_NIL:
+ if (next && next->type == CodeTreeBytecode) {
+ switch (next->code) {
+ case XBC_SET:
+ next->code = XBC_SET_NIL;
+ goto remove_label;
+ /* TODO add XBC_SETSYM_NIL */
+ default:
+ break;
+ }
+ }
+ break;
+ case XBC_PUSH_NIL:
+ if (next && next->type == CodeTreeBytecode &&
+ next->code == XBC_PUSH_NIL) {
+ next->code = XBC_PUSH_NIL_N;
+ next->data.signed_char = 2;
+ goto remove_label;
+ }
+ break;
+ case XBC_PUSH_NIL_N:
+ if (next && next->type == CodeTreeBytecode &&
+ next->code == XBC_PUSH_NIL) {
+ next->code = XBC_PUSH_NIL_N;
+ next->data.signed_char = tree->data.signed_char + 1;
+ goto remove_label;
+ }
+ break;
+ case XBC_PUSH_UNSPEC:
+ if (next && next->type == CodeTreeBytecode &&
+ next->code == XBC_PUSH_UNSPEC) {
+ next->code = XBC_PUSH_UNSPEC_N;
+ next->data.signed_char = 2;
+ goto remove_label;
+ }
+ break;
+ case XBC_PUSH_UNSPEC_N:
+ if (next && next->type == CodeTreeBytecode &&
+ next->code == XBC_PUSH_UNSPEC) {
+ next->code = XBC_PUSH_UNSPEC_N;
+ next->data.signed_char = tree->data.signed_char + 1;
+ goto remove_label;
+ }
+ break;
+ default:
+ break;
+ }
+ break;
+ case CodeTreeBlock:
+ LinkDoOptimize_0(com, tree->data.block);
+ break;
+ default:
+ break;
+ }
+ goto update_label;
+remove_label:
+ if (tree == block->tree) {
+ block->tree = prev = next;
+ if (tree == block->tail)
+ block->tail = tree;
+ }
+ else
+ prev->next = next;
+ CompileFreeTree(tree);
+ tree = next;
+ continue;
+remove_next_label:
+ tree->next = next->next;
+ CompileFreeTree(next);
+ continue;
+update_label:
+ prev = tree;
+ tree = tree->next;
+ }
+}
+
+static void
+LinkOptimize_0(LispCom *com)
+{
+ /* Recursive */
+ LinkDoOptimize_0(com, com->block);
+}
+
+static void
+LinkResolveLabels(LispCom *com, CodeBlock *block)
+{
+ int i;
+ CodeTree *tree = block->tree;
+
+ for (; tree; tree = tree->next) {
+ if (tree->type == CodeTreeBlock)
+ LinkResolveLabels(com, tree->data.block);
+ else if (tree->type == CodeTreeLabel) {
+ for (i = 0; i < block->tagbody.length; i++)
+ if (tree->data.object == block->tagbody.labels[i]) {
+ block->tagbody.codes[i] = tree;
+ break;
+ }
+ }
+ }
+}
+
+static void
+LinkResolveJumps(LispCom *com, CodeBlock *block)
+{
+ int i;
+ CodeBlock *body = block;
+ CodeTree *ptr, *tree = block->tree;
+
+ /* Check if there is a tagbody. Error checking already done */
+ while (body && body->type != LispBlockBody)
+ body = body->prev;
+
+ for (; tree; tree = tree->next) {
+ switch (tree->type) {
+ case CodeTreeBytecode:
+ case CodeTreeLabel:
+ break;
+
+ case CodeTreeBlock:
+ LinkResolveJumps(com, tree->data.block);
+ break;
+
+ case CodeTreeGo:
+ for (i = 0; i < body->tagbody.length; i++)
+ if (tree->data.object == body->tagbody.labels[i])
+ break;
+ if (i == body->tagbody.length)
+ LispDestroy("COMPILE: no visible tag %s to GO",
+ STROBJ(tree->data.object));
+ /* Now the jump code is known */
+ tree->data.tree = body->tagbody.codes[i];
+ break;
+
+ case CodeTreeCond:
+ if (tree->code == XBC_JUMPNIL)
+ /* If test is NIL, go to next test */
+ tree->data.tree = tree->group->next;
+ else if (tree->code == XBC_JUMPT) {
+ /* After executing code, test was T */
+ for (ptr = tree->group;
+ ptr->code != XBC_NOOP;
+ ptr = ptr->group)
+ ;
+ tree->data.tree = ptr;
+ }
+ break;
+
+ case CodeTreeJumpIf:
+ if (tree->code != XBC_NOOP) {
+ for (ptr = tree->group;
+ ptr->code != XBC_NOOP;
+ ptr = ptr->group) {
+ if (ptr->type == CodeTreeJump) {
+ /* ELSE code of IF */
+ ptr = ptr->next;
+ /* Skip inconditional jump node */
+ break;
+ }
+ }
+ tree->data.tree = ptr;
+ }
+ break;
+
+ case CodeTreeJump:
+ if (tree->code != XBC_NOOP)
+ tree->data.tree = tree->group;
+ break;
+
+ case CodeTreeReturn:
+ /* One bytecode is guaranteed to exist in the code tree */
+ if (tree->data.block->parent == NULL)
+ /* Returning from the function or toplevel form */
+ tree->data.tree = tree->data.block->tail;
+ else {
+ for (;;) {
+ ptr = tree->data.block->parent->next;
+ if (ptr) {
+ tree->data.tree = ptr;
+ break;
+ }
+ else
+ /* Move one BLOCK up */
+ tree->data.block = tree->data.block->prev;
+ }
+ }
+ break;
+ }
+ }
+}
+
+static long
+LinkPad(long offset, long adjust, int preffix, int datalen)
+{
+ /* If byte or aligned data */
+ if (datalen <= preffix || ((offset + adjust + preffix) % datalen) == 0)
+ return (adjust);
+
+ return (adjust + (datalen - ((offset + adjust + preffix) % datalen)));
+}
+
+static long
+LinkFixupOffsets(LispCom *com, CodeTree *tree, long adjust)
+{
+ for (; tree; tree = tree->next) {
+ switch (tree->type) {
+ case CodeTreeBytecode:
+ switch (tree->code) {
+ /* byte + short */
+ case XBC_JUMP:
+ case XBC_JUMPT:
+ case XBC_JUMPNIL:
+ adjust = LinkPad(tree->offset, adjust, 1,
+ sizeof(short));
+ /*FALLTROUGH*/
+ default:
+ tree->offset += adjust;
+ break;
+ }
+ break;
+ case CodeTreeLabel:
+ /* Labels are not loaded, just adjust offset */
+ tree->offset += adjust;
+ break;
+ case CodeTreeJump:
+ case CodeTreeCond:
+ case CodeTreeJumpIf:
+ /* If an opcode will be generated. */
+ if (tree->code != XBC_NOOP)
+ adjust = LinkPad(tree->offset, adjust, 1, sizeof(short));
+ tree->offset += adjust;
+ break;
+ case CodeTreeGo:
+ case CodeTreeReturn:
+ adjust = LinkPad(tree->offset, adjust, 1, sizeof(short));
+ tree->offset += adjust;
+ break;
+ case CodeTreeBlock:
+ adjust = LinkFixupOffsets(com, tree->data.block->tree, adjust);
+ break;
+ }
+ }
+
+ return (adjust);
+}
+
+static void
+LinkSkipPadding(LispCom *com, CodeTree *tree)
+{
+ int found;
+ CodeTree *ptr;
+
+ /* Recurse to adjust forward jumps or jumps to the start of the block */
+ for (ptr = tree; ptr; ptr = ptr->next) {
+ if (ptr->type == CodeTreeBlock) {
+ LinkSkipPadding(com, ptr->data.block->tree);
+ ptr->offset = ptr->data.block->tree->offset;
+ }
+ }
+
+ /* Adjust the nodes offsets */
+ for (; tree; tree = tree->next) {
+ switch (tree->type) {
+ case CodeTreeBytecode:
+ case CodeTreeBlock:
+ case CodeTreeGo:
+ case CodeTreeReturn:
+ break;
+ case CodeTreeJump:
+ case CodeTreeCond:
+ case CodeTreeJumpIf:
+ if (tree->code != XBC_NOOP)
+ /* If code will be generated */
+ break;
+ case CodeTreeLabel:
+ /* This should be done in reversed order, but to avoid
+ * the requirement of a prev pointer, do the job in a
+ * harder way here. */
+ for (found = 0, ptr = tree->next; ptr; ptr = ptr->next) {
+ switch (ptr->type) {
+ case CodeTreeBytecode:
+ case CodeTreeBlock:
+ case CodeTreeGo:
+ case CodeTreeReturn:
+ found = 1;
+ break;
+ case CodeTreeJump:
+ case CodeTreeCond:
+ case CodeTreeJumpIf:
+ if (ptr->code != XBC_NOOP)
+ found = 1;
+ break;
+ case CodeTreeLabel:
+ break;
+ }
+ if (found)
+ break;
+ }
+ if (found)
+ tree->offset = ptr->offset;
+ break;
+ }
+ }
+}
+
+static void
+LinkCalculateJump(LispCom *com, CodeTree *tree, LispByteOpcode code)
+{
+ long jumpto, offset, distance;
+
+ tree->type = CodeTreeBytecode;
+ /* After the opcode */
+ offset = tree->offset + 1;
+ jumpto = tree->data.tree->offset;
+ /* Effective distance */
+ distance = jumpto - offset;
+ tree->code = code;
+ if (distance < -32768 || distance > 32767) {
+ COMPILE_FAILURE("jump too long");
+ }
+ tree->data.signed_int = distance;
+}
+
+static void
+LinkFixupJumps(LispCom *com, CodeTree *tree)
+{
+ for (; tree; tree = tree->next) {
+ switch (tree->type) {
+ case CodeTreeBytecode:
+ case CodeTreeLabel:
+ break;
+ case CodeTreeCond:
+ if (tree->code == XBC_JUMPNIL)
+ /* Go to next test if NIL */
+ LinkCalculateJump(com, tree, XBC_JUMPNIL);
+ else if (tree->code == XBC_JUMPT)
+ /* After executing T code */
+ LinkCalculateJump(com, tree, XBC_JUMP);
+ break;
+ case CodeTreeJumpIf:
+ if (tree->code != XBC_NOOP)
+ LinkCalculateJump(com, tree, tree->code);
+ break;
+ case CodeTreeGo:
+ /* Inconditional jump */
+ LinkCalculateJump(com, tree, XBC_JUMP);
+ break;
+ case CodeTreeReturn:
+ /* Inconditional jump */
+ if (tree->data.tree != tree)
+ /* If need to skip something */
+ LinkCalculateJump(com, tree, XBC_JUMP);
+ break;
+ case CodeTreeBlock:
+ LinkFixupJumps(com, tree->data.block->tree);
+ break;
+ case CodeTreeJump:
+ if (tree->code != XBC_NOOP)
+ LinkCalculateJump(com, tree, tree->code);
+ }
+ }
+}
+
+static void
+LinkBuildTableSymbol(LispCom *com, LispAtom *symbol)
+{
+ if (BuildTablePointer(symbol, (void***)&com->table.symbols,
+ &com->table.num_symbols) > 0xff) {
+ COMPILE_FAILURE("more than 256 symbols");
+ }
+}
+
+static void
+LinkBuildTableConstant(LispCom *com, LispObj *constant)
+{
+ if (BuildTablePointer(constant, (void***)&com->table.constants,
+ &com->table.num_constants) > 0xff) {
+ COMPILE_FAILURE("more than 256 constants");
+ }
+}
+
+static void
+LinkBuildTableBuiltin(LispCom *com, LispBuiltin *builtin)
+{
+ if (BuildTablePointer(builtin, (void***)&com->table.builtins,
+ &com->table.num_builtins) > 0xff) {
+ COMPILE_FAILURE("more than 256 functions");
+ }
+}
+
+static void
+LinkBuildTableBytecode(LispCom *com, LispObj *bytecode)
+{
+ if (BuildTablePointer(bytecode, (void***)&com->table.bytecodes,
+ &com->table.num_bytecodes) > 0xff) {
+ COMPILE_FAILURE("more than 256 bytecode functions");
+ }
+}
+
+static void
+LinkBuildTables(LispCom *com, CodeBlock *block)
+{
+ CodeTree *tree;
+
+ for (tree = block->tree; tree; tree = tree->next) {
+ switch (tree->type) {
+ case CodeTreeBytecode:
+ switch (tree->code) {
+ case XBC_LET:
+ case XBC_LETX:
+ case XBC_LET_NIL:
+ case XBC_LETX_NIL:
+ case XBC_SETSYM:
+ case XBC_LOADSYM:
+ case XBC_LOADSYM_PUSH:
+ LinkBuildTableSymbol(com, tree->data.atom);
+ break;
+ case XBC_STRUCTP:
+ case XBC_LOADCON:
+ case XBC_LOADCON_PUSH:
+ LinkBuildTableConstant(com, tree->data.object);
+ break;
+ case XBC_LOADCON_SET:
+ LinkBuildTableConstant(com, tree->data.load_con_set.object);
+ break;
+ case XBC_CALL:
+ case XBC_CALL_SET:
+ LinkBuildTableBuiltin(com, tree->data.builtin.builtin);
+ break;
+ case XBC_BYTECALL:
+ LinkBuildTableBytecode(com, tree->data.bytecall.code);
+ break;
+ case XBC_LOAD_LET:
+ case XBC_LOAD_LETX:
+ LinkBuildTableSymbol(com, tree->data.let.name);
+ break;
+ case XBC_STRUCT:
+ LinkBuildTableConstant(com, tree->data.struc.definition);
+ break;
+ case XBC_LOADSYM_LET:
+ case XBC_LOADSYM_LETX:
+ LinkBuildTableSymbol(com, tree->data.let_sym.symbol);
+ LinkBuildTableSymbol(com, tree->data.let_sym.name);
+ break;
+ case XBC_LOADCON_LET:
+ case XBC_LOADCON_LETX:
+ LinkBuildTableConstant(com, tree->data.let_con.object);
+ LinkBuildTableSymbol(com, tree->data.let_con.name);
+ break;
+ case XBC_CCONS:
+ case XBC_FUNCALL:
+ LinkBuildTableConstant(com, tree->data.cons.car);
+ LinkBuildTableConstant(com, tree->data.cons.cdr);
+ break;
+ default:
+ break;
+ }
+ break;
+ case CodeTreeBlock:
+ LinkBuildTables(com, tree->data.block);
+ break;
+ default:
+ break;
+ }
+ }
+}
+
+static long
+LinkEmmitBytecode(LispCom *com, CodeTree *tree,
+ unsigned char *bytecode, long offset)
+{
+ short i;
+
+ for (; tree; tree = tree->next) {
+ /* Fill padding */
+ while (offset < tree->offset)
+ bytecode[offset++] = XBC_NOOP;
+
+ switch (tree->type) {
+ case CodeTreeBytecode:
+ bytecode[offset++] = tree->code;
+ switch (tree->code) {
+ /* Noop should not enter the CodeTree */
+ case XBC_NOOP:
+ INTERNAL_ERROR(__LINE__);
+ break;
+
+ /* byte */
+ case XBC_BCONS:
+ case XBC_BCONS1:
+ case XBC_BCONS2:
+ case XBC_BCONS3:
+ case XBC_BCONS4:
+ case XBC_BCONS5:
+ case XBC_BCONS6:
+ case XBC_BCONS7:
+ case XBC_INV:
+ case XBC_NIL:
+ case XBC_T:
+ case XBC_PUSH_NIL:
+ case XBC_PUSH_UNSPEC:
+ case XBC_PUSH_T:
+ case XBC_CAR_PUSH:
+ case XBC_CDR_PUSH:
+ case XBC_PUSH:
+ case XBC_LSTAR:
+ case XBC_LCONS:
+ case XBC_LFINI:
+ case XBC_RETURN:
+ case XBC_CSTAR:
+ case XBC_CFINI:
+ case XBC_CAR:
+ case XBC_CDR:
+ case XBC_RPLACA:
+ case XBC_RPLACD:
+ case XBC_EQ:
+ case XBC_EQL:
+ case XBC_EQUAL:
+ case XBC_EQUALP:
+ case XBC_LENGTH:
+ case XBC_LAST:
+ case XBC_NTHCDR:
+ break;
+
+ /* byte + byte */
+ case XBC_LETREC:
+ case XBC_PRED:
+ case XBC_PUSH_NIL_N:
+ case XBC_PUSH_UNSPEC_N:
+ bytecode[offset++] = tree->data.signed_char;
+ break;
+
+ /* byte + byte */
+ case XBC_CAR_SET:
+ case XBC_CDR_SET:
+ case XBC_SET:
+ case XBC_SET_NIL:
+ case XBC_LETBIND:
+ case XBC_UNLET:
+ case XBC_LOAD_PUSH:
+ case XBC_LOAD:
+ case XBC_LOAD_CAR:
+ case XBC_LOAD_CDR:
+ case XBC_LOAD_CAR_STORE:
+ case XBC_LOAD_CDR_STORE:
+ bytecode[offset++] = tree->data.signed_short;
+ break;
+
+ /* byte + byte + byte */
+ case XBC_LOAD_SET:
+ case XBC_LOAD_CAR_SET:
+ case XBC_LOAD_CDR_SET:
+ bytecode[offset++] = tree->data.load_set.load;
+ bytecode[offset++] = tree->data.load_set.set;
+ break;
+
+ /* byte + short */
+ case XBC_JUMP:
+ case XBC_JUMPT:
+ case XBC_JUMPNIL:
+ *(short*)(bytecode + offset) = tree->data.signed_int;
+ offset += sizeof(short);
+ break;
+
+ /* byte + byte */
+ case XBC_LET:
+ case XBC_LETX:
+ case XBC_LET_NIL:
+ case XBC_LETX_NIL:
+ case XBC_SETSYM:
+ case XBC_LOADSYM:
+ case XBC_LOADSYM_PUSH:
+ i = FindIndex(tree->data.atom,
+ (void**)com->table.symbols,
+ com->table.num_symbols);
+ bytecode[offset++] = i;
+ break;
+
+ /* byte + byte */
+ case XBC_STRUCTP:
+ case XBC_LOADCON:
+ case XBC_LOADCON_PUSH:
+ i = FindIndex(tree->data.object,
+ (void**)com->table.constants,
+ com->table.num_constants);
+ bytecode[offset++] = i;
+ break;
+
+ /* byte + byte + byte */
+ case XBC_LOADCON_SET:
+ i = FindIndex(tree->data.load_con_set.object,
+ (void**)com->table.constants,
+ com->table.num_constants);
+ bytecode[offset++] = i;
+ bytecode[offset++] = tree->data.load_con_set.offset;
+ break;
+
+ /* byte + byte + byte */
+ case XBC_CALL:
+ bytecode[offset++] = tree->data.builtin.num_arguments;
+ i = FindIndex(tree->data.builtin.builtin,
+ (void**)com->table.builtins,
+ com->table.num_builtins);
+ bytecode[offset++] = i;
+ break;
+
+ /* byte + byte + byte */
+ case XBC_BYTECALL:
+ bytecode[offset++] = tree->data.bytecall.num_arguments;
+ i = FindIndex(tree->data.bytecall.code,
+ (void**)com->table.bytecodes,
+ com->table.num_bytecodes);
+ bytecode[offset++] = i;
+ break;
+
+ /* byte + byte + byte + byte */
+ case XBC_CALL_SET:
+ bytecode[offset++] = tree->data.builtin.num_arguments;
+ i = FindIndex(tree->data.builtin.builtin,
+ (void**)com->table.builtins,
+ com->table.num_builtins);
+ bytecode[offset++] = i;
+ bytecode[offset++] = tree->data.builtin.offset;
+ break;
+
+ /* byte + byte + byte */
+ case XBC_LOAD_LET:
+ case XBC_LOAD_LETX:
+ bytecode[offset++] = tree->data.let.offset;
+ i = FindIndex(tree->data.let.name,
+ (void**)com->table.symbols,
+ com->table.num_symbols);
+ bytecode[offset++] = i;
+ break;
+
+ /* byte + byte + byte */
+ case XBC_STRUCT:
+ bytecode[offset++] = tree->data.struc.offset;
+ i = FindIndex(tree->data.struc.definition,
+ (void**)com->table.constants,
+ com->table.num_constants);
+ bytecode[offset++] = i;
+ break;
+
+ /* byte + byte + byte */
+ case XBC_LOADSYM_LET:
+ case XBC_LOADSYM_LETX:
+ i = FindIndex(tree->data.let_sym.symbol,
+ (void**)com->table.symbols,
+ com->table.num_symbols);
+ bytecode[offset++] = i;
+ i = FindIndex(tree->data.let_sym.name,
+ (void**)com->table.symbols,
+ com->table.num_symbols);
+ bytecode[offset++] = i;
+ break;
+
+ /* byte + byte + byte */
+ case XBC_LOADCON_LET:
+ case XBC_LOADCON_LETX:
+ i = FindIndex(tree->data.let_con.object,
+ (void**)com->table.constants,
+ com->table.num_constants);
+ bytecode[offset++] = i;
+ i = FindIndex(tree->data.let_con.name,
+ (void**)com->table.symbols,
+ com->table.num_symbols);
+ bytecode[offset++] = i;
+ break;
+
+ /* byte + byte + byte */
+ case XBC_CCONS:
+ case XBC_FUNCALL:
+ i = FindIndex(tree->data.cons.car,
+ (void**)com->table.constants,
+ com->table.num_constants);
+ bytecode[offset++] = i;
+ i = FindIndex(tree->data.cons.cdr,
+ (void**)com->table.constants,
+ com->table.num_constants);
+ bytecode[offset++] = i;
+ break;
+ }
+ break;
+ case CodeTreeLabel:
+ /* Labels are not loaded */
+ break;
+ case CodeTreeCond:
+ case CodeTreeJump:
+ case CodeTreeJumpIf:
+ if (tree->code != XBC_NOOP)
+ INTERNAL_ERROR(__LINE__);
+ break;
+ case CodeTreeGo:
+ INTERNAL_ERROR(__LINE__);
+ break;
+ case CodeTreeReturn:
+ if (tree->data.tree != tree)
+ INTERNAL_ERROR(__LINE__);
+ break;
+ case CodeTreeBlock:
+ offset = LinkEmmitBytecode(com, tree->data.block->tree,
+ bytecode, offset);
+ break;
+ }
+ }
+
+ return (offset);
+}
+
+static void
+LinkBytecode(LispCom *com)
+{
+ long offset, count;
+ unsigned char **codes;
+ LispObj **names;
+
+ /* Close bytecode */
+ com_Bytecode(com, XBC_RETURN);
+
+ /* The only usage of this information for now, and still may generate
+ * false positives because arguments to unamed functions are not being
+ * parsed as well as arguments to yet undefined function/maros.
+ * XXX should also add declaim/declare to let the code specify that
+ * the argument is unused */
+ LinkWarnUnused(com, com->block);
+
+ /* First level optimization */
+ LinkOptimize_0(com);
+
+ /* Resolve tagbody labels */
+ LinkResolveLabels(com, com->block);
+
+ /* Resolve any pending jumps */
+ LinkResolveJumps(com, com->block);
+
+ /* Calculate unpadded offsets */
+ LinkBuildOffsets(com, com->block->tree, 0);
+
+ /* Do padding for aligned memory reads */
+ LinkFixupOffsets(com, com->block->tree, 0);
+
+ /* Jumps normally are to a node that does not generate code,
+ * and due to padding, the jump may go to a address with a
+ * XBC_NOOP, so adjust the jump to the next useful opcode. */
+ LinkSkipPadding(com, com->block->tree);
+
+ /* Now addresses are known */
+ LinkFixupJumps(com, com->block->tree);
+
+ /* Build symbol, constant and builtin tables */
+ LinkBuildTables(com, com->block);
+
+ /* Stack info */
+ com->length = sizeof(short) * 3;
+ /* Tables info */
+ com->length += sizeof(short) * 4;
+ com->length += com->table.num_constants * sizeof(LispObj*);
+ com->length += com->table.num_symbols * sizeof(LispAtom*);
+ com->length += com->table.num_builtins * sizeof(LispBuiltin*);
+ com->length += com->table.num_bytecodes * sizeof(unsigned char*);
+ com->length += com->table.num_bytecodes * sizeof(LispObj*);
+
+ /* Allocate space for the bytecode stream */
+ com->length += com->block->tail->offset + 1;
+ com->bytecode = LispMalloc(com->length);
+
+ /* Add header */
+ offset = 0;
+ *(short*)(com->bytecode + offset) = com->stack.stack;
+ offset += sizeof(short);
+ *(short*)(com->bytecode + offset) = com->stack.bstack;
+ offset += sizeof(short);
+ *(short*)(com->bytecode + offset) = com->stack.pstack;
+ offset += sizeof(short);
+
+ *(short*)(com->bytecode + offset) = com->table.num_constants;
+ offset += sizeof(short);
+ *(short*)(com->bytecode + offset) = com->table.num_symbols;
+ offset += sizeof(short);
+ *(short*)(com->bytecode + offset) = com->table.num_builtins;
+ offset += sizeof(short);
+ *(short*)(com->bytecode + offset) = com->table.num_bytecodes;
+ offset += sizeof(short);
+
+ count = sizeof(LispObj*) * com->table.num_constants;
+ memcpy(com->bytecode + offset, com->table.constants, count);
+ offset += count;
+ count = sizeof(LispAtom*) * com->table.num_symbols;
+ memcpy(com->bytecode + offset, com->table.symbols, count);
+ offset += count;
+ count = sizeof(LispBuiltin*) * com->table.num_builtins;
+ memcpy(com->bytecode + offset, com->table.builtins, count);
+ offset += count;
+
+ /* Store bytecode information */
+ for (count = 0, codes = (unsigned char**)(com->bytecode + offset);
+ count < com->table.num_bytecodes; count++, codes++)
+ *codes = com->table.bytecodes[count]->data.bytecode.bytecode->code;
+ offset += com->table.num_bytecodes * sizeof(unsigned char*);
+ /* Store names, only useful for disassemble but may also be used
+ * to check if a function was redefined, and the bytecode is referencing
+ * the older version, the current version can be checked looking at
+ * <name>->data.atom */
+ for (count = 0, names = (LispObj**)(com->bytecode + offset);
+ count < com->table.num_bytecodes; count++, names++)
+ *names = com->table.bytecodes[count]->data.bytecode.name;
+ offset += com->table.num_bytecodes * sizeof(LispObj*);
+
+ /* Generate it */
+ LinkEmmitBytecode(com, com->block->tree, com->bytecode + offset, 0);
+}
+
+static LispObj *
+ExecuteBytecode(register unsigned char *stream)
+{
+ register LispObj *reg0;
+ register LispAtom *atom;
+ register short offset;
+ LispObj *reg1;
+ LispBuiltin *builtin;
+ LispObj *lambda;
+ LispObj *arguments;
+ unsigned char *bytecode;
+
+ LispObj **constants;
+ LispAtom **symbols;
+ LispBuiltin **builtins;
+ unsigned char **codes;
+ short num_constants, num_symbols, num_builtins, num_codes;
+
+ int lex, len;
+
+ /* To control gc protected slots */
+ int phead, pbase;
+
+ long fixnum = 0;
+
+#if defined(__GNUC__) && !defined(ANSI_SOURCE)
+#define ALLOW_GOTO_ADDRESS
+#endif
+
+#ifdef ALLOW_GOTO_ADDRESS
+#define JUMP_ADDRESS(label) &&label
+ static const void *opcode_labels[] = {
+ JUMP_ADDRESS(XBC_NOOP),
+ JUMP_ADDRESS(XBC_INV),
+ JUMP_ADDRESS(XBC_NIL),
+ JUMP_ADDRESS(XBC_T),
+ JUMP_ADDRESS(XBC_PRED),
+ JUMP_ADDRESS(XBC_CAR),
+ JUMP_ADDRESS(XBC_CDR),
+ JUMP_ADDRESS(XBC_CAR_SET),
+ JUMP_ADDRESS(XBC_CDR_SET),
+ JUMP_ADDRESS(XBC_RPLACA),
+ JUMP_ADDRESS(XBC_RPLACD),
+ JUMP_ADDRESS(XBC_EQ),
+ JUMP_ADDRESS(XBC_EQL),
+ JUMP_ADDRESS(XBC_EQUAL),
+ JUMP_ADDRESS(XBC_EQUALP),
+ JUMP_ADDRESS(XBC_LENGTH),
+ JUMP_ADDRESS(XBC_LAST),
+ JUMP_ADDRESS(XBC_NTHCDR),
+ JUMP_ADDRESS(XBC_CAR_PUSH),
+ JUMP_ADDRESS(XBC_CDR_PUSH),
+ JUMP_ADDRESS(XBC_PUSH),
+ JUMP_ADDRESS(XBC_PUSH_NIL),
+ JUMP_ADDRESS(XBC_PUSH_UNSPEC),
+ JUMP_ADDRESS(XBC_PUSH_T),
+ JUMP_ADDRESS(XBC_PUSH_NIL_N),
+ JUMP_ADDRESS(XBC_PUSH_UNSPEC_N),
+ JUMP_ADDRESS(XBC_LET),
+ JUMP_ADDRESS(XBC_LETX),
+ JUMP_ADDRESS(XBC_LET_NIL),
+ JUMP_ADDRESS(XBC_LETX_NIL),
+ JUMP_ADDRESS(XBC_LETBIND),
+ JUMP_ADDRESS(XBC_UNLET),
+ JUMP_ADDRESS(XBC_LOAD),
+ JUMP_ADDRESS(XBC_LOAD_LET),
+ JUMP_ADDRESS(XBC_LOAD_LETX),
+ JUMP_ADDRESS(XBC_LOAD_PUSH),
+ JUMP_ADDRESS(XBC_LOADCON),
+ JUMP_ADDRESS(XBC_LOADCON_LET),
+ JUMP_ADDRESS(XBC_LOADCON_LETX),
+ JUMP_ADDRESS(XBC_LOADCON_PUSH),
+ JUMP_ADDRESS(XBC_LOAD_CAR),
+ JUMP_ADDRESS(XBC_LOAD_CDR),
+ JUMP_ADDRESS(XBC_LOAD_CAR_STORE),
+ JUMP_ADDRESS(XBC_LOAD_CDR_STORE),
+ JUMP_ADDRESS(XBC_LOADCON_SET),
+ JUMP_ADDRESS(XBC_LOADSYM),
+ JUMP_ADDRESS(XBC_LOADSYM_LET),
+ JUMP_ADDRESS(XBC_LOADSYM_LETX),
+ JUMP_ADDRESS(XBC_LOADSYM_PUSH),
+ JUMP_ADDRESS(XBC_LOAD_SET),
+ JUMP_ADDRESS(XBC_LOAD_CAR_SET),
+ JUMP_ADDRESS(XBC_LOAD_CDR_SET),
+ JUMP_ADDRESS(XBC_SET),
+ JUMP_ADDRESS(XBC_SETSYM),
+ JUMP_ADDRESS(XBC_SET_NIL),
+ JUMP_ADDRESS(XBC_CALL),
+ JUMP_ADDRESS(XBC_CALL_SET),
+ JUMP_ADDRESS(XBC_BYTECALL),
+ JUMP_ADDRESS(XBC_FUNCALL),
+ JUMP_ADDRESS(XBC_LETREC),
+ JUMP_ADDRESS(XBC_BCONS),
+ JUMP_ADDRESS(XBC_BCONS1),
+ JUMP_ADDRESS(XBC_BCONS2),
+ JUMP_ADDRESS(XBC_BCONS3),
+ JUMP_ADDRESS(XBC_BCONS4),
+ JUMP_ADDRESS(XBC_BCONS5),
+ JUMP_ADDRESS(XBC_BCONS6),
+ JUMP_ADDRESS(XBC_BCONS7),
+ JUMP_ADDRESS(XBC_CCONS),
+ JUMP_ADDRESS(XBC_CSTAR),
+ JUMP_ADDRESS(XBC_CFINI),
+ JUMP_ADDRESS(XBC_LSTAR),
+ JUMP_ADDRESS(XBC_LCONS),
+ JUMP_ADDRESS(XBC_LFINI),
+ JUMP_ADDRESS(XBC_JUMP),
+ JUMP_ADDRESS(XBC_JUMPT),
+ JUMP_ADDRESS(XBC_JUMPNIL),
+ JUMP_ADDRESS(XBC_STRUCT),
+ JUMP_ADDRESS(XBC_STRUCTP),
+ JUMP_ADDRESS(XBC_RETURN)
+ };
+ static const void *predicate_opcode_labels[] = {
+ JUMP_ADDRESS(XBP_CONSP),
+ JUMP_ADDRESS(XBP_LISTP),
+ JUMP_ADDRESS(XBP_NUMBERP)
+ };
+#endif
+
+ reg0 = NIL;
+
+ bytecode = stream;
+ pbase = lisp__data.protect.length;
+
+ /* stack */
+ offset = *(short*)stream;
+ stream += sizeof(short);
+ if (lisp__data.env.length + offset > lisp__data.env.space) {
+ do
+ LispMoreEnvironment();
+ while (lisp__data.env.length + offset >= lisp__data.env.space);
+ }
+ /* builtin stack */
+ offset = *(short*)stream;
+ stream += sizeof(short);
+ if (lisp__data.stack.length + offset >= lisp__data.stack.space) {
+ do
+ LispMoreStack();
+ while (lisp__data.stack.length + offset >= lisp__data.stack.space);
+ }
+ /* protect stack */
+ phead = *(short*)stream;
+ stream += sizeof(short);
+ if (lisp__data.protect.length + phead > lisp__data.protect.space) {
+ do
+ LispMoreProtects();
+ while (lisp__data.protect.length + phead >= lisp__data.protect.space);
+ }
+
+ num_constants = *(short*)stream;
+ stream += sizeof(short);
+ num_symbols = *(short*)stream;
+ stream += sizeof(short);
+ num_builtins = *(short*)stream;
+ stream += sizeof(short);
+ num_codes = *(short*)stream;
+ stream += sizeof(short);
+
+ constants = (LispObj**)stream;
+ stream += num_constants * sizeof(LispObj*);
+ symbols = (LispAtom**)stream;
+ stream += num_symbols * sizeof(LispAtom*);
+ builtins = (LispBuiltin**)stream;
+ stream += num_builtins * sizeof(LispBuiltin*);
+ codes = (unsigned char**)stream;
+ stream += num_codes * (sizeof(unsigned char*) + sizeof(LispObj*));
+
+ for (; phead > 0; phead--)
+ lisp__data.protect.objects[lisp__data.protect.length++] = NIL;
+ phead = pbase;
+
+#ifdef ALLOW_GOTO_ADDRESS
+#define OPCODE_LABEL(label) label
+#define NEXT_OPCODE() goto *opcode_labels[*stream++]
+#define GOTO_PREDICATE() goto *predicate_opcode_labels[*stream++]
+#else
+#define OPCODE_LABEL(label) case label
+#define NEXT_OPCODE() goto next_opcode
+#define GOTO_PREDICATE() goto predicate_label
+ for (;;) {
+next_opcode:
+ switch (*stream++) {
+#endif /* ALLOW_GOTO_ADDRESS */
+
+OPCODE_LABEL(XBC_NOOP):
+ NEXT_OPCODE();
+
+OPCODE_LABEL(XBC_PRED):
+ GOTO_PREDICATE();
+
+OPCODE_LABEL(XBC_INV):
+ reg0 = reg0 == NIL ? T : NIL;
+ NEXT_OPCODE();
+
+OPCODE_LABEL(XBC_NIL):
+ reg0 = NIL;
+ NEXT_OPCODE();
+
+OPCODE_LABEL(XBC_T):
+ reg0 = T;
+ NEXT_OPCODE();
+
+OPCODE_LABEL(XBC_CAR):
+car:
+ if (reg0 != NIL) {
+ if (!CONSP(reg0))
+ LispDestroy("CAR: %s is not a list", STROBJ(reg0));
+ reg0 = CAR(reg0);
+ }
+ NEXT_OPCODE();
+
+OPCODE_LABEL(XBC_CDR):
+cdr:
+ if (reg0 != NIL) {
+ if (!CONSP(reg0))
+ LispDestroy("CDR: %s is not a list", STROBJ(reg0));
+ reg0 = CDR(reg0);
+ }
+ NEXT_OPCODE();
+
+OPCODE_LABEL(XBC_RPLACA):
+ reg1 = lisp__data.stack.values[--lisp__data.stack.length];
+ if (!CONSP(reg1))
+ LispDestroy("RPLACA: %s is not a cons", STROBJ(reg1));
+ RPLACA(reg1, reg0);
+ reg0 = reg1;
+ NEXT_OPCODE();
+
+OPCODE_LABEL(XBC_RPLACD):
+ reg1 = lisp__data.stack.values[--lisp__data.stack.length];
+ if (!CONSP(reg1))
+ LispDestroy("RPLACD: %s is not a cons", STROBJ(reg1));
+ RPLACD(reg1, reg0);
+ reg0 = reg1;
+ NEXT_OPCODE();
+
+OPCODE_LABEL(XBC_BCONS):
+ CAR(cons) = reg0;
+ lisp__data.stack.values[lisp__data.stack.length++] = cons;
+ NEXT_OPCODE();
+
+OPCODE_LABEL(XBC_BCONS1):
+ offset = lisp__data.stack.length - 1;
+ CAR(cons) = reg0;
+ CAR(cons1) = lisp__data.stack.values[offset];
+ lisp__data.stack.values[offset] = cons1;
+ NEXT_OPCODE();
+
+OPCODE_LABEL(XBC_BCONS2):
+ offset = lisp__data.stack.length;
+ CAR(cons) = reg0;
+ CAR(cons1) = lisp__data.stack.values[--offset];
+ CAR(cons2) = lisp__data.stack.values[--offset];
+ lisp__data.stack.values[offset] = cons2;
+ lisp__data.stack.length = offset + 1;
+ NEXT_OPCODE();
+
+OPCODE_LABEL(XBC_BCONS3):
+ offset = lisp__data.stack.length;
+ CAR(cons) = reg0;
+ CAR(cons1) = lisp__data.stack.values[--offset];
+ CAR(cons2) = lisp__data.stack.values[--offset];
+ CAR(cons3) = lisp__data.stack.values[--offset];
+ lisp__data.stack.values[offset] = cons3;
+ lisp__data.stack.length = offset + 1;
+ NEXT_OPCODE();
+
+OPCODE_LABEL(XBC_BCONS4):
+ offset = lisp__data.stack.length;
+ CAR(cons) = reg0;
+ CAR(cons1) = lisp__data.stack.values[--offset];
+ CAR(cons2) = lisp__data.stack.values[--offset];
+ CAR(cons3) = lisp__data.stack.values[--offset];
+ CAR(cons4) = lisp__data.stack.values[--offset];
+ lisp__data.stack.values[offset] = cons4;
+ lisp__data.stack.length = offset + 1;
+ NEXT_OPCODE();
+
+OPCODE_LABEL(XBC_BCONS5):
+ offset = lisp__data.stack.length;
+ CAR(cons) = reg0;
+ CAR(cons1) = lisp__data.stack.values[--offset];
+ CAR(cons2) = lisp__data.stack.values[--offset];
+ CAR(cons3) = lisp__data.stack.values[--offset];
+ CAR(cons4) = lisp__data.stack.values[--offset];
+ CAR(cons5) = lisp__data.stack.values[--offset];
+ lisp__data.stack.values[offset] = cons5;
+ lisp__data.stack.length = offset + 1;
+ NEXT_OPCODE();
+
+OPCODE_LABEL(XBC_BCONS6):
+ offset = lisp__data.stack.length;
+ CAR(cons) = reg0;
+ CAR(cons1) = lisp__data.stack.values[--offset];
+ CAR(cons2) = lisp__data.stack.values[--offset];
+ CAR(cons3) = lisp__data.stack.values[--offset];
+ CAR(cons4) = lisp__data.stack.values[--offset];
+ CAR(cons5) = lisp__data.stack.values[--offset];
+ CAR(cons6) = lisp__data.stack.values[--offset];
+ lisp__data.stack.values[offset] = cons6;
+ lisp__data.stack.length = offset + 1;
+ NEXT_OPCODE();
+
+OPCODE_LABEL(XBC_BCONS7):
+ offset = lisp__data.stack.length;
+ CAR(cons) = reg0;
+ CAR(cons1) = lisp__data.stack.values[--offset];
+ CAR(cons2) = lisp__data.stack.values[--offset];
+ CAR(cons3) = lisp__data.stack.values[--offset];
+ CAR(cons4) = lisp__data.stack.values[--offset];
+ CAR(cons5) = lisp__data.stack.values[--offset];
+ CAR(cons6) = lisp__data.stack.values[--offset];
+ CAR(cons7) = lisp__data.stack.values[--offset];
+ lisp__data.stack.values[offset] = cons7;
+ lisp__data.stack.length = offset + 1;
+ NEXT_OPCODE();
+
+OPCODE_LABEL(XBC_EQ):
+ reg0 = reg0 == lisp__data.stack.values[--lisp__data.stack.length] ? T : NIL;
+ NEXT_OPCODE();
+
+OPCODE_LABEL(XBC_EQL):
+ reg1 = lisp__data.stack.values[--lisp__data.stack.length];
+ reg0 = XEQL(reg1, reg0);
+ NEXT_OPCODE();
+
+OPCODE_LABEL(XBC_EQUAL):
+ reg1 = lisp__data.stack.values[--lisp__data.stack.length];
+ reg0 = XEQUAL(reg1, reg0);
+ NEXT_OPCODE();
+
+OPCODE_LABEL(XBC_EQUALP):
+ reg1 = lisp__data.stack.values[--lisp__data.stack.length];
+ reg0 = XEQUALP(reg1, reg0);
+ NEXT_OPCODE();
+
+OPCODE_LABEL(XBC_LENGTH):
+ reg0 = FIXNUM(LispLength(reg0));
+ NEXT_OPCODE();
+
+OPCODE_LABEL(XBC_LAST):
+ {
+ long length;
+
+ reg1 = lisp__data.stack.values[--lisp__data.stack.length];
+ if (CONSP(reg1)) {
+ if (reg0 != NIL) {
+ if (!FIXNUMP(reg0) || (fixnum = FIXNUM_VALUE(reg0)) < 0)
+ LispDestroy("LAST: %s is not a positive fixnum",
+ STROBJ(reg0));
+ }
+ else
+ fixnum = 1;
+ reg0 = reg1;
+ for (reg0 = reg1, length = 0;
+ CONSP(reg0);
+ reg0 = CDR(reg0), length++)
+ ;
+ for (length -= fixnum, reg0 = reg1; length > 0; length--)
+ reg0 = CDR(reg0);
+ }
+ else
+ reg0 = reg1;
+ } NEXT_OPCODE();
+
+OPCODE_LABEL(XBC_NTHCDR):
+ reg1 = lisp__data.stack.values[--lisp__data.stack.length];
+ if (!FIXNUMP(reg1) || (fixnum = FIXNUM_VALUE(reg1)) < 0)
+ LispDestroy("NTHCDR: %s is not a positive fixnum",
+ STROBJ(reg1));
+ if (reg0 != NIL) {
+ if (!CONSP(reg0))
+ LispDestroy("NTHCDR: %s is not a list", STROBJ(reg0));
+ for (; fixnum > 0; fixnum--) {
+ if (!CONSP(reg0))
+ break;
+ reg0 = CDR(reg0);
+ }
+ }
+ NEXT_OPCODE();
+
+ /* Push to builtin stack */
+OPCODE_LABEL(XBC_CAR_PUSH):
+ if (reg0 != NIL) {
+ if (!CONSP(reg0))
+ LispDestroy("CAR: %s is not a list", STROBJ(reg0));
+ reg0 = CAR(reg0);
+ }
+ goto push_builtin;
+
+OPCODE_LABEL(XBC_CDR_PUSH):
+ if (reg0 != NIL) {
+ if (!CONSP(reg0))
+ LispDestroy("CDR: %s is not a list", STROBJ(reg0));
+ reg0 = CDR(reg0);
+ }
+ /*FALLTROUGH*/
+
+OPCODE_LABEL(XBC_PUSH):
+push_builtin:
+ lisp__data.stack.values[lisp__data.stack.length++] = reg0;
+ NEXT_OPCODE();
+
+OPCODE_LABEL(XBC_PUSH_NIL):
+ lisp__data.stack.values[lisp__data.stack.length++] = NIL;
+ NEXT_OPCODE();
+
+OPCODE_LABEL(XBC_PUSH_UNSPEC):
+ lisp__data.stack.values[lisp__data.stack.length++] = UNSPEC;
+ NEXT_OPCODE();
+
+OPCODE_LABEL(XBC_PUSH_T):
+ lisp__data.stack.values[lisp__data.stack.length++] = T;
+ NEXT_OPCODE();
+
+OPCODE_LABEL(XBC_PUSH_NIL_N):
+ for (offset = *stream++; offset > 0; offset--)
+ lisp__data.stack.values[lisp__data.stack.length++] = NIL;
+ NEXT_OPCODE();
+
+OPCODE_LABEL(XBC_PUSH_UNSPEC_N):
+ for (offset = *stream++; offset > 0; offset--)
+ lisp__data.stack.values[lisp__data.stack.length++] = UNSPEC;
+ NEXT_OPCODE();
+
+OPCODE_LABEL(XBC_LET):
+let_argument:
+ /* The global object value is not changed, so it does not
+ * matter if it is a constant symbol. An error would be
+ * generated if it was declared as constant at the time of
+ * bytecode generation. Check can be done looking at the
+ * atom->constant field. */
+ atom = symbols[*stream++];
+ atom->offset = lisp__data.env.length;
+ lisp__data.env.names[lisp__data.env.length] = atom->string;
+ lisp__data.env.values[lisp__data.env.length++] = reg0;
+ NEXT_OPCODE();
+
+OPCODE_LABEL(XBC_LETX):
+letx_argument:
+ atom = symbols[*stream++];
+ atom->offset = lisp__data.env.length;
+ lisp__data.env.names[lisp__data.env.length] = atom->string;
+ lisp__data.env.values[lisp__data.env.length++] = reg0;
+ lisp__data.env.head++;
+ NEXT_OPCODE();
+
+OPCODE_LABEL(XBC_LET_NIL):
+ atom = symbols[*stream++];
+ atom->offset = lisp__data.env.length;
+ lisp__data.env.names[lisp__data.env.length] = atom->string;
+ lisp__data.env.values[lisp__data.env.length++] = NIL;
+ NEXT_OPCODE();
+
+OPCODE_LABEL(XBC_LETX_NIL):
+ atom = symbols[*stream++];
+ atom->offset = lisp__data.env.length;
+ lisp__data.env.names[lisp__data.env.length] = atom->string;
+ lisp__data.env.values[lisp__data.env.length++] = NIL;
+ lisp__data.env.head++;
+ NEXT_OPCODE();
+
+ /* Bind locally added variables to a block */
+OPCODE_LABEL(XBC_LETBIND):
+ offset = *stream++;
+ lisp__data.env.head += offset;
+ NEXT_OPCODE();
+
+ /* Unbind locally added variables to a block */
+OPCODE_LABEL(XBC_UNLET):
+ offset = *stream++;
+ lisp__data.env.head -= offset;
+ lisp__data.env.length -= offset;
+ NEXT_OPCODE();
+
+ /* Load value from stack */
+OPCODE_LABEL(XBC_LOAD):
+ offset = *stream++;
+ reg0 = lisp__data.env.values[lisp__data.env.lex + offset];
+ NEXT_OPCODE();
+
+OPCODE_LABEL(XBC_LOAD_CAR):
+ offset = *stream++;
+ reg0 = lisp__data.env.values[lisp__data.env.lex + offset];
+ goto car;
+
+OPCODE_LABEL(XBC_LOAD_CDR):
+ offset = *stream++;
+ reg0 = lisp__data.env.values[lisp__data.env.lex + offset];
+ goto cdr;
+
+OPCODE_LABEL(XBC_LOAD_CAR_STORE):
+ offset = *stream++;
+ reg0 = lisp__data.env.values[lisp__data.env.lex + offset];
+ if (reg0 != NIL) {
+ if (!CONSP(reg0))
+ LispDestroy("CAR: %s is not a list", STROBJ(reg0));
+ reg0 = CAR(reg0);
+ lisp__data.env.values[lisp__data.env.lex + offset] = reg0;
+ }
+ NEXT_OPCODE();
+
+OPCODE_LABEL(XBC_LOAD_CDR_STORE):
+ offset = *stream++;
+ reg0 = lisp__data.env.values[lisp__data.env.lex + offset];
+ if (reg0 != NIL) {
+ if (!CONSP(reg0))
+ LispDestroy("CDR: %s is not a list", STROBJ(reg0));
+ reg0 = CDR(reg0);
+ lisp__data.env.values[lisp__data.env.lex + offset] = reg0;
+ }
+ NEXT_OPCODE();
+
+OPCODE_LABEL(XBC_LOAD_LET):
+ offset = *stream++;
+ reg0 = lisp__data.env.values[lisp__data.env.lex + offset];
+ goto let_argument;
+
+OPCODE_LABEL(XBC_LOAD_LETX):
+ offset = *stream++;
+ reg0 = lisp__data.env.values[lisp__data.env.lex + offset];
+ goto letx_argument;
+
+OPCODE_LABEL(XBC_LOAD_PUSH):
+ offset = *stream++;
+ reg0 = lisp__data.env.values[lisp__data.env.lex + offset];
+ lisp__data.stack.values[lisp__data.stack.length++] = reg0;
+ NEXT_OPCODE();
+
+ /* Load pointer to constant */
+OPCODE_LABEL(XBC_LOADCON):
+ reg0 = constants[*stream++];
+ NEXT_OPCODE();
+
+OPCODE_LABEL(XBC_LOADCON_LET):
+ reg0 = constants[*stream++];
+ goto let_argument;
+
+OPCODE_LABEL(XBC_LOADCON_LETX):
+ reg0 = constants[*stream++];
+ goto letx_argument;
+
+OPCODE_LABEL(XBC_LOADCON_PUSH):
+ reg0 = constants[*stream++];
+ lisp__data.stack.values[lisp__data.stack.length++] = reg0;
+ NEXT_OPCODE();
+
+OPCODE_LABEL(XBC_LOADCON_SET):
+ reg0 = constants[*stream++];
+ offset = *stream++;
+ lisp__data.env.values[lisp__data.env.lex + offset] = reg0;
+ NEXT_OPCODE();
+
+ /* Change value of local variable */
+OPCODE_LABEL(XBC_CAR_SET):
+car_set:
+ if (reg0 != NIL) {
+ if (!CONSP(reg0))
+ LispDestroy("CAR: %s is not a list", STROBJ(reg0));
+ reg0 = CAR(reg0);
+ }
+ goto set_local_variable;
+
+OPCODE_LABEL(XBC_CDR_SET):
+cdr_set:
+ if (reg0 != NIL) {
+ if (!CONSP(reg0))
+ LispDestroy("CDR: %s is not a list", STROBJ(reg0));
+ reg0 = CDR(reg0);
+ }
+ goto set_local_variable;
+
+OPCODE_LABEL(XBC_LOAD_CAR_SET):
+ offset = *stream++;
+ reg0 = lisp__data.env.values[lisp__data.env.lex + offset];
+ goto car_set;
+
+OPCODE_LABEL(XBC_LOAD_CDR_SET):
+ offset = *stream++;
+ reg0 = lisp__data.env.values[lisp__data.env.lex + offset];
+ goto cdr_set;
+
+OPCODE_LABEL(XBC_LOAD_SET):
+ offset = *stream++;
+ reg0 = lisp__data.env.values[lisp__data.env.lex + offset];
+ /*FALLTROUGH*/
+
+OPCODE_LABEL(XBC_SET):
+set_local_variable:
+ offset = *stream++;
+ lisp__data.env.values[lisp__data.env.lex + offset] = reg0;
+ NEXT_OPCODE();
+
+OPCODE_LABEL(XBC_SET_NIL):
+ offset = *stream++;
+ lisp__data.env.values[lisp__data.env.lex + offset] = NIL;
+ NEXT_OPCODE();
+
+ /* Change value of a global/special variable */
+OPCODE_LABEL(XBC_SETSYM):
+ atom = symbols[*stream++];
+ if (atom->dyn) {
+ /* atom->dyn and atom->constant are exclusive, no
+ * need to check if variable declared as constant. */
+ if (atom->offset < lisp__data.env.head &&
+ lisp__data.env.names[atom->offset] == atom->string)
+ lisp__data.env.values[atom->offset] = reg0;
+ else {
+ if (atom->watch)
+ LispSetAtomObjectProperty(atom, reg0);
+ else
+ SETVALUE(atom, reg0);
+ }
+ }
+ else if (atom->a_object) {
+ if (atom->constant)
+ LispDestroy("EVAL: %s is a constant",
+ STROBJ(atom->object));
+ else if (atom->watch)
+ LispSetAtomObjectProperty(atom, reg0);
+ else
+ SETVALUE(atom, reg0);
+ }
+ else {
+ /* Create new global variable */
+ LispPackage *pack;
+
+ LispWarning("the variable %s was not declared",
+ atom->string);
+ LispSetAtomObjectProperty(atom, reg0);
+ pack = atom->package->data.package.package;
+ if (pack->glb.length >= pack->glb.space)
+ LispMoreGlobals(pack);
+ pack->glb.pairs[pack->glb.length++] = atom->object;
+ }
+ NEXT_OPCODE();
+
+/* Resolve symbol value at runtime */
+#define LOAD_SYMBOL_VALUE() \
+ atom = symbols[*stream++]; \
+ if (atom->dyn) { \
+ if (atom->offset < lisp__data.env.head && \
+ lisp__data.env.names[atom->offset] == atom->string) \
+ reg0 = lisp__data.env.values[atom->offset]; \
+ else { \
+ reg0 = atom->property->value; \
+ if (reg0 == UNBOUND) \
+ LispDestroy("EVAL: the symbol %s is unbound", \
+ STROBJ(atom->object)); \
+ } \
+ } \
+ else { \
+ if (atom->a_object) \
+ reg0 = atom->property->value; \
+ else \
+ LispDestroy("EVAL: the symbol %s is unbound", \
+ STROBJ(atom->object)); \
+ }
+
+OPCODE_LABEL(XBC_LOADSYM):
+ LOAD_SYMBOL_VALUE();
+ NEXT_OPCODE();
+
+OPCODE_LABEL(XBC_LOADSYM_LET):
+ LOAD_SYMBOL_VALUE();
+ goto let_argument;
+
+OPCODE_LABEL(XBC_LOADSYM_LETX):
+ LOAD_SYMBOL_VALUE();
+ goto letx_argument;
+
+OPCODE_LABEL(XBC_LOADSYM_PUSH):
+ LOAD_SYMBOL_VALUE();
+ lisp__data.stack.values[lisp__data.stack.length++] = reg0;
+ NEXT_OPCODE();
+
+ /* Builtin function */
+OPCODE_LABEL(XBC_CALL):
+ offset = *stream++;
+ lisp__data.stack.base = lisp__data.stack.length - offset;
+ builtin = builtins[*stream++];
+ if (builtin->multiple_values) {
+ RETURN_COUNT = 0;
+ reg0 = builtin->function(builtin);
+ }
+ else {
+ reg0 = builtin->function(builtin);
+ RETURN_COUNT = 0;
+ }
+ lisp__data.stack.length -= offset;
+ NEXT_OPCODE();
+
+OPCODE_LABEL(XBC_CALL_SET):
+ offset = *stream++;
+ lisp__data.stack.base = lisp__data.stack.length - offset;
+ builtin = builtins[*stream++];
+ if (builtin->multiple_values) {
+ RETURN_COUNT = 0;
+ reg0 = builtin->function(builtin);
+ }
+ else {
+ reg0 = builtin->function(builtin);
+ RETURN_COUNT = 0;
+ }
+ lisp__data.stack.length -= offset;
+ offset = *stream++;
+ lisp__data.env.values[lisp__data.env.lex + offset] = reg0;
+ NEXT_OPCODE();
+
+ /* Bytecode call */
+OPCODE_LABEL(XBC_BYTECALL):
+ lex = lisp__data.env.lex;
+ offset = *stream++;
+ lisp__data.env.head = lisp__data.env.length;
+ len = lisp__data.env.lex = lisp__data.env.length - offset;
+ reg0 = ExecuteBytecode(codes[*stream++]);
+ lisp__data.env.length = lisp__data.env.head = len;
+ lisp__data.env.lex = lex;
+ NEXT_OPCODE();
+
+ /* Unimplemented function/macro call */
+OPCODE_LABEL(XBC_FUNCALL):
+ lambda = constants[*stream++];
+ arguments = constants[*stream++];
+ reg0 = LispFuncall(lambda, arguments, 1);
+ NEXT_OPCODE();
+
+OPCODE_LABEL(XBC_JUMP):
+ stream += *(signed short*)stream;
+ NEXT_OPCODE();
+
+OPCODE_LABEL(XBC_JUMPT):
+ if (reg0 != NIL)
+ stream += *(signed short*)stream;
+ else
+ /* skip jump relative offset */
+ stream += sizeof(signed short);
+ NEXT_OPCODE();
+
+OPCODE_LABEL(XBC_JUMPNIL):
+ if (reg0 == NIL)
+ stream += *(signed short*)stream;
+ else
+ /* skip jump relative offset */
+ stream += sizeof(signed short);
+ NEXT_OPCODE();
+
+ /* Build CONS of two constant arguments */
+OPCODE_LABEL(XBC_CCONS):
+ reg0 = constants[*stream++];
+ reg1 = constants[*stream++];
+ reg0 = CONS(reg0, reg1);
+ NEXT_OPCODE();
+
+ /* Start CONS */
+OPCODE_LABEL(XBC_CSTAR):
+ /* This the CAR of the CONS */
+ lisp__data.protect.objects[phead++] = reg0;
+ NEXT_OPCODE();
+
+ /* Finish CONS */
+OPCODE_LABEL(XBC_CFINI):
+ reg0 = CONS(lisp__data.protect.objects[--phead], reg0);
+ NEXT_OPCODE();
+
+ /* Start building list */
+OPCODE_LABEL(XBC_LSTAR):
+ reg1 = CONS(reg0, NIL);
+ /* Start of list stored here */
+ lisp__data.protect.objects[phead++] = reg1;
+ /* Tail of list stored here */
+ lisp__data.protect.objects[phead++] = reg1;
+ NEXT_OPCODE();
+
+ /* Add to list */
+OPCODE_LABEL(XBC_LCONS):
+ reg1 = lisp__data.protect.objects[phead - 2];
+ RPLACD(reg1, CONS(reg0, NIL));
+ lisp__data.protect.objects[phead - 2] = CDR(reg1);
+ NEXT_OPCODE();
+
+ /* Finish list */
+OPCODE_LABEL(XBC_LFINI):
+ phead -= 2;
+ reg0 = lisp__data.protect.objects[phead + 1];
+ NEXT_OPCODE();
+
+OPCODE_LABEL(XBC_STRUCT):
+ offset = *stream++;
+ reg1 = constants[*stream++];
+ if (!STRUCTP(reg0) || reg0->data.struc.def != reg1) {
+ char *name = ATOMID(CAR(reg1));
+
+ for (reg1 = CDR(reg1); offset; offset--)
+ reg1 = CDR(reg1);
+ LispDestroy("%s-%s: %s is not a %s",
+ name, ATOMID(CAR(reg1)), STROBJ(reg0), name);
+ }
+ for (reg0 = reg0->data.struc.fields; offset; offset--)
+ reg0 = CDR(reg0);
+ reg0 = CAR(reg0);
+ NEXT_OPCODE();
+
+OPCODE_LABEL(XBC_STRUCTP):
+ reg1 = constants[*stream++];
+ reg0 = STRUCTP(reg0) && reg0->data.struc.def == reg1 ? T : NIL;
+ NEXT_OPCODE();
+
+OPCODE_LABEL(XBC_LETREC):
+ /* XXX could/should optimize, shouldn't need to parse
+ * the bytecode header again */
+ lex = lisp__data.env.lex;
+ offset = *stream++;
+ lisp__data.env.head = lisp__data.env.length;
+ len = lisp__data.env.lex = lisp__data.env.length - offset;
+ reg0 = ExecuteBytecode(bytecode);
+ lisp__data.env.length = lisp__data.env.head = len;
+ lisp__data.env.lex = lex;
+ NEXT_OPCODE();
+
+OPCODE_LABEL(XBC_RETURN):
+ lisp__data.protect.length = pbase;
+ return (reg0);
+
+#ifndef ALLOW_GOTO_ADDRESS
+ } /* end of switch */
+
+predicate_label:
+ switch (*stream++) {
+#endif
+
+OPCODE_LABEL(XBP_CONSP):
+ reg0 = CONSP(reg0) ? T : NIL;
+ NEXT_OPCODE();
+
+OPCODE_LABEL(XBP_LISTP):
+ reg0 = LISTP(reg0) ? T : NIL;
+ NEXT_OPCODE();
+
+OPCODE_LABEL(XBP_NUMBERP):
+ reg0 = NUMBERP(reg0) ? T : NIL;
+ NEXT_OPCODE();
+
+#ifndef ALLOW_GOTO_ADDRESS
+ } /* end of switch */
+ }
+#endif
+
+ /*NOTREACHED*/
+ return (reg0);
+}
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-22 15:44:41 +0000