bytecode.c revision 5dfecf96 
1/*
2 * Copyright (c) 2002 by The XFree86 Project, Inc.
3 *
4 * Permission is hereby granted, free of charge, to any person obtaining a
5 * copy of this software and associated documentation files (the "Software"),
6 * to deal in the Software without restriction, including without limitation
7 * the rights to use, copy, modify, merge, publish, distribute, sublicense,
8 * and/or sell copies of the Software, and to permit persons to whom the
9 * Software is furnished to do so, subject to the following conditions:
10 *
11 * The above copyright notice and this permission notice shall be included in
12 * all copies or substantial portions of the Software.
13 *
14 * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
15 * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
16 * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.  IN NO EVENT SHALL
17 * THE XFREE86 PROJECT BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
18 * WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF
19 * OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
20 * SOFTWARE.
21 *
22 * Except as contained in this notice, the name of the XFree86 Project shall
23 * not be used in advertising or otherwise to promote the sale, use or other
24 * dealings in this Software without prior written authorization from the
25 * XFree86 Project.
26 *
27 * Author: Paulo César Pereira de Andrade
28 */
29
30/* $XFree86: xc/programs/xedit/lisp/bytecode.c,v 1.17 2003/05/27 22:27:01 tsi Exp $ */
31
32
33/*
34somethings TODO:
35
36 o Write code for allowing storing the bytecode on disk. Basically
37   write a section of the bytecode with the package name of the symbol
38   pointers, and after that, the symbols used. At load time just put
39   the pointers in the bytecode. Constants can be stored as the string
40   representation. Probably just storing the gc protected code as a
41   string is enough to rebuild it.
42
43 o Write code to store tags of BLOCK/CATCH and setjump buffer stacks,
44   and, only keep track of this if non byte-compiled code is called,
45   as after byte-compilation RETURN and THROW are just jumps.
46
47 o Remove not reliable "optmization code" code from Com_XXX functions
48   and do it later, removing dead code, tests with a constant argument,
49   etc, in the "link time". Frequently joining sequential opcodes to a
50   compound version.
51
52 o Write an optimizer to do code transformation.
53
54 o Write code to know when variables can be changed in place, this
55   can save a huge time in loop counters.
56
57 o Write code for fast garbage collection of objects that can be
58   safely collected.
59
60 o Cleanup of interpreted code. Having bytecode mean that the interpreter
61   now is better having a clean and small code. If speed is important,
62   it should be byte compiled.
63
64 o Limit the stacks length. So that instead of using an index, use the
65   pointer where an object value should be read/stored as the stack address
66   would not change during the program execution.
67
68 o Optimize jump to jump. Common in code like:
69	(IF test
70	    (GO somewhere)
71	    (GO elsewhere)
72	)
73	(GO there)
74   that generates a bytecode like:
75	<code to evaluate test>
76	JUMPNIL :NIL-RESULT
77	:T-RESULT
78	    JUMP :SOMEWHERE
79	JUMP :END-OF-IF			;; <- this is not required, or even
80	:NIL-RESULT			;;    better, notice the jump after
81	    JUMP :ELSEWHERE		;;    the if and transform it into
82	:END-OF-IF			;;    a JUMP :THERE (assuming there
83	JUMP :THERE			;;    (was no jump in the T code).
84
85 o Optimize variables that are known to not change it's value, i.e. pseudo
86   constants. Loading the value of a constant should be faster than loading
87   the current value of a variable; the constant table could fit in the
88   processor cache line and needs less calculation to find the object address.
89
90 o Fix some known problems, like when calling return or return-from while
91   building the argument list to a builtin function, or inline of recursive
92   functions.
93 */
94
95
96#include "lisp/bytecode.h"
97#include "lisp/write.h"
98
99#define	SYMBOL_KEYWORD	-1	/* A keyword, load as constant */
100#define	SYMBOL_CONSTANT	-2	/* Defined as constant at compile time */
101#define	SYMBOL_UNBOUND	-3	/* Not a local variable */
102
103#define NEW_TREE(type)		CompileNewTree(com, type)
104
105/* If in tagbody, ignore anything that is not code */
106#define	IN_TAGBODY()		(com->block->type == LispBlockBody && \
107				 com->level == com->tagbody)
108#define	FORM_ENTER()		++com->level
109#define	FORM_LEAVE()		--com->level
110
111#define COMPILE_FAILURE(message)			\
112    LispMessage("COMPILE: %s", message);		\
113    longjmp(com->jmp, 1)
114
115/*
116 * Types
117 */
118typedef struct _CodeTree CodeTree;
119typedef struct _CodeBlock CodeBlock;
120
121typedef enum {
122    CodeTreeBytecode,
123    CodeTreeLabel,
124    CodeTreeGo,
125    CodeTreeJump,
126    CodeTreeJumpIf,
127    CodeTreeCond,
128    CodeTreeBlock,
129    CodeTreeReturn
130} CodeTreeType;
131
132struct _CodeTree {
133    CodeTreeType type;
134
135    /* Resolved when linking, may be adjusted while optimizing */
136    long offset;
137
138    LispByteOpcode code;
139
140    union {
141	signed char signed_char;
142	signed short signed_short;
143	signed int signed_int;
144	LispAtom *atom;
145	LispObj *object;
146	CodeTree *tree;
147	CodeBlock *block;
148	struct {
149	    unsigned char num_arguments;
150	    LispBuiltin *builtin;
151	    signed short offset;	/* Used if opcode is XBC_CALL_SET */
152	} builtin;
153	struct {
154	    unsigned char num_arguments;
155	    LispObj *name;
156	    LispObj *lambda;
157	} call;
158	struct {
159	    unsigned char num_arguments;
160	    LispObj *code;
161	} bytecall;
162	struct {
163	    short offset;
164	    LispAtom *name;
165	} let;
166	struct {
167	    LispAtom *symbol;
168	    LispAtom *name;
169	} let_sym;
170	struct {
171	    LispObj *object;
172	    LispAtom *name;
173	} let_con;
174	struct {
175	    signed short load;
176	    signed short set;
177	} load_set;
178	struct {
179	    LispObj *object;
180	    signed short offset;
181	} load_con_set;
182	struct {
183	    LispObj *car;
184	    LispObj *cdr;
185	} cons;
186	struct {
187	    short offset;
188	    LispObj *definition;
189	} struc;
190    } data;
191
192    CodeTree *next;
193    CodeTree *group;
194    CodeBlock *block;
195};
196
197struct _CodeBlock {
198    LispBlockType type;
199    LispObj *tag;
200
201    struct {
202	LispObj **labels;
203	CodeTree **codes;	/* Filled at link time */
204	int length;
205	int space;
206    } tagbody;
207
208    struct {
209	LispAtom **symbols;	/* Identifiers of variables in a block */
210	int *flags;		/* Information about usage of the variable */
211	int length;
212    } variables;
213
214    int bind;			/* Used in case of RETURN from LET */
215    int level;			/* Nesting level block was created */
216
217    CodeTree *tree, *tail;
218    CodeBlock *prev;		/* Linked list as a stack */
219    CodeTree *parent;		/* Back reference */
220};
221
222struct _LispCom {
223    unsigned char *bytecode;	/* Bytecode generated so far */
224    long length;
225
226    CodeBlock *block, *toplevel;
227
228    int tagbody;		/* Inside a tagbody block? */
229    int level;			/* Nesting level */
230    int macro;			/* Expanding a macro? */
231
232    int lex;
233
234    int warnings;
235
236    LispObj *form, *plist;
237
238    jmp_buf jmp;		/* Used if compilation cannot be finished */
239
240    struct {
241	int cstack;	/* Current number of objects in forms evaluation */
242	int cbstack;
243	int cpstack;
244	int stack;	/* max number of objects will be loaded in stack */
245	int bstack;
246	int pstack;
247    } stack;
248
249    struct {
250	/* Constant table */
251	LispObj **constants;
252	int num_constants;
253	/* Symbol table */
254	LispAtom **symbols;
255	int num_symbols;
256	/* Builtin table */
257	LispBuiltin **builtins;
258	int num_builtins;
259	/* Bytecode table */
260	LispObj **bytecodes;
261	int num_bytecodes;
262    } table;
263};
264
265/*
266 * Prototypes
267 */
268static LispObj *MakeBytecodeObject(LispCom*, LispObj*, LispObj*);
269
270static CodeTree *CompileNewTree(LispCom*, CodeTreeType);
271static void CompileFreeState(LispCom*);
272static void CompileFreeBlock(CodeBlock*);
273static void CompileFreeTree(CodeTree*);
274
275static void CompileIniBlock(LispCom*, LispBlockType, LispObj*);
276static void CompileFiniBlock(LispCom*);
277
278static void com_BytecodeChar(LispCom*, LispByteOpcode, char);
279static void com_BytecodeShort(LispCom*, LispByteOpcode, short);
280static void com_BytecodeObject(LispCom*, LispByteOpcode, LispObj*);
281static void com_BytecodeCons(LispCom*, LispByteOpcode, LispObj*, LispObj*);
282
283static void com_BytecodeAtom(LispCom*, LispByteOpcode, LispAtom*);
284
285static void com_Bytecode(LispCom*, LispByteOpcode);
286
287static void com_Load(LispCom*, short);
288static void com_LoadLet(LispCom*, short, LispAtom*);
289static void com_LoadPush(LispCom*, short);
290
291static void com_Let(LispCom*, LispAtom*);
292
293static void com_Bind(LispCom*, short);
294static void com_Unbind(LispCom*, short);
295
296static void com_LoadSym(LispCom*, LispAtom*);
297static void com_LoadSymLet(LispCom*, LispAtom*, LispAtom*);
298static void com_LoadSymPush(LispCom*, LispAtom*);
299
300static void com_LoadCon(LispCom*, LispObj*);
301static void com_LoadConLet(LispCom*, LispObj*, LispAtom*);
302static void com_LoadConPush(LispCom*, LispObj*);
303
304static void com_Set(LispCom*, short);
305static void com_SetSym(LispCom*, LispAtom*);
306
307static void com_Struct(LispCom*, short, LispObj*);
308static void com_Structp(LispCom*, LispObj*);
309
310static void com_Call(LispCom*, unsigned char, LispBuiltin*);
311static void com_Bytecall(LispCom*, unsigned char, LispObj*);
312static void com_Funcall(LispCom*, LispObj*, LispObj*);
313
314static void CompileStackEnter(LispCom*, int, int);
315static void CompileStackLeave(LispCom*, int, int);
316
317static void LinkBytecode(LispCom*);
318
319static LispObj *ExecuteBytecode(unsigned char*);
320
321
322/* Defined in lisp.c */
323void LispMoreStack(void);
324void LispMoreEnvironment(void);
325void LispMoreGlobals(LispPackage*);
326LispObj *LispEvalBackquote(LispObj*, int);
327void LispSetAtomObjectProperty(LispAtom*, LispObj*);
328
329/*
330 * Initialization
331 */
332extern int pagesize;
333
334LispObj x_cons[8];
335static LispObj *cons, *cons1, *cons2, *cons3, *cons4, *cons5, *cons6, *cons7;
336
337/*
338 * Implementation
339 */
340#include "lisp/compile.c"
341
342void
343LispBytecodeInit(void)
344{
345    cons = &x_cons[7];
346    cons->type = LispCons_t;
347    CDR(cons) = NIL;
348    cons1 = &x_cons[6];
349    cons1->type = LispCons_t;
350    CDR(cons1) = cons;
351    cons2 = &x_cons[5];
352    cons2->type = LispCons_t;
353    CDR(cons2) = cons1;
354    cons3 = &x_cons[4];
355    cons3->type = LispCons_t;
356    CDR(cons3) = cons2;
357    cons4 = &x_cons[3];
358    cons4->type = LispCons_t;
359    CDR(cons4) = cons3;
360    cons5 = &x_cons[2];
361    cons5->type = LispCons_t;
362    CDR(cons5) = cons4;
363    cons6 = &x_cons[1];
364    cons6->type = LispCons_t;
365    CDR(cons6) = cons5;
366    cons7 = &x_cons[0];
367    cons7->type = LispCons_t;
368    CDR(cons7) = cons6;
369}
370
371LispObj *
372Lisp_Compile(LispBuiltin *builtin)
373/*
374 compile name &optional definition
375 */
376{
377    GC_ENTER();
378    LispObj *result, *warnings_p, *failure_p;
379
380    LispObj *name, *definition;
381
382    definition = ARGUMENT(1);
383    name = ARGUMENT(0);
384
385    result = name;
386    warnings_p = NIL;
387    failure_p = T;
388
389    if (name != NIL) {
390	LispAtom *atom;
391
392	CHECK_SYMBOL(name);
393	atom = name->data.atom;
394	if (atom->a_builtin || atom->a_compiled)
395	    goto finished_compilation;
396	else if (atom->a_function) {
397	    LispCom com;
398	    int failed;
399	    int lex = 0, base;
400	    LispArgList *alist;
401	    LispObj *lambda, *form, *arguments;
402
403	    lambda = atom->property->fun.function;
404	    if (definition != UNSPEC || lambda->funtype != LispFunction)
405		/* XXX TODO replace definition etc. */
406		goto finished_compilation;
407	    alist = atom->property->alist;
408
409	    memset(&com, 0, sizeof(LispCom));
410	    com.toplevel = com.block = LispCalloc(1, sizeof(CodeBlock));
411	    com.block->type = LispBlockClosure;
412	    com.block->tag = name;
413
414	    /*  Create a fake argument list to avoid yet another flag
415	     * for ComCall. The value does not matter, just the fact
416	     * that the symbol will be bound or not in the implicit
417	     * PROGN of the function body. */
418	    base = alist->num_arguments - alist->auxs.num_symbols;
419	    if (base) {
420		LispObj *argument;
421		int i, sforms;
422
423		for (i = sforms = 0; i < alist->optionals.num_symbols; i++)
424		    if (alist->optionals.sforms[i])
425			++sforms;
426
427		arguments = form = NIL;
428		i = sforms +
429		    alist->normals.num_symbols + alist->optionals.num_symbols;
430
431		if (i) {
432		    arguments = form = CONS(NIL, NIL);
433		    GC_PROTECT(arguments);
434		    for (--i; i > 0; i--) {
435			RPLACD(form, CONS(NIL, NIL));
436			form = CDR(form);
437		    }
438		}
439
440		for (i = 0; i < alist->keys.num_symbols; i++) {
441		    /* key symbol */
442		    if (alist->keys.keys[i])
443			argument = QUOTE(alist->keys.keys[i]);
444		    else
445			argument = alist->keys.symbols[i];
446
447		    /* add key */
448		    if (arguments == NIL) {
449			arguments = form = CONS(argument, NIL);
450			GC_PROTECT(arguments);
451		    }
452		    else {
453			RPLACD(form, CONS(argument, NIL));
454			form = CDR(form);
455		    }
456
457		    /* add value */
458		    RPLACD(form, CONS(NIL, NIL));
459		    form = CDR(form);
460
461		    if (alist->keys.sforms[i]) {
462			RPLACD(form, CONS(NIL, NIL));
463			form = CDR(form);
464		    }
465		}
466
467		if (alist->rest) {
468		    if (arguments == NIL) {
469			arguments = form = CONS(NIL, NIL);
470			GC_PROTECT(arguments);
471		    }
472		    else {
473			RPLACD(form, CONS(NIL, NIL));
474			form = CDR(form);
475		    }
476		}
477	    }
478	    else
479		arguments = NIL;
480
481	    form = CONS(lambda->data.lambda.code, NIL);
482	    GC_PROTECT(form);
483	    com.form = form;
484	    com.plist = CONS(NIL, NIL);
485	    GC_PROTECT(com.plist);
486
487	    failed = 1;
488	    if (setjmp(com.jmp) == 0) {
489		/* Save interpreter state */
490		lex = com.lex = lisp__data.env.lex;
491		base = ComCall(&com, alist, name, arguments, 1, 0, 1);
492
493		/* Generate code tree */
494		lisp__data.env.lex = base;
495		ComProgn(&com, CAR(form));
496		failed = 0;
497	    }
498
499	    /* Restore interpreter state */
500	    lisp__data.env.lex = lex;
501	    lisp__data.env.head = lisp__data.env.length = base;
502
503	    if (!failed) {
504		failure_p = NIL;
505		result = MakeBytecodeObject(&com, name,
506					    lambda->data.lambda.data);
507		LispSetAtomCompiledProperty(atom, result);
508		result = name;
509	    }
510	    if (com.warnings)
511		warnings_p = FIXNUM(com.warnings);
512	    goto finished_compilation;
513	}
514	else
515	    goto undefined_function;
516    }
517
518undefined_function:
519    LispDestroy("%s: the function %s is undefined",
520		STRFUN(builtin), STROBJ(name));
521
522finished_compilation:
523    RETURN(0) = warnings_p;
524    RETURN(1) = failure_p;
525    RETURN_COUNT = 2;
526    GC_LEAVE();
527
528    return (result);
529}
530
531LispObj *
532Lisp_Disassemble(LispBuiltin *builtin)
533/*
534 disassemble function
535 */
536{
537    int macro;
538    char buffer[128];
539    LispAtom *atom;
540    LispArgList *alist;
541    LispBuiltin *xbuiltin;
542    LispObj *name, *lambda, *bytecode;
543
544    LispObj *function;
545
546    function = ARGUMENT(0);
547
548    macro = 0;
549    alist = NULL;
550    xbuiltin = NULL;
551    name = bytecode = NULL;
552
553    switch (OBJECT_TYPE(function)) {
554	case LispAtom_t:
555	    name = function;
556	    atom = function->data.atom;
557	    alist = atom->property->alist;
558	    if (atom->a_builtin) {
559		xbuiltin = atom->property->fun.builtin;
560		macro = xbuiltin->type == LispMacro;
561	    }
562	    else if (atom->a_compiled)
563		bytecode = atom->property->fun.function;
564	    else if (atom->a_function) {
565		lambda = atom->property->fun.function;
566		macro = lambda->funtype == LispMacro;
567	    }
568	    else if (atom->a_defstruct &&
569		     atom->property->structure.function != STRUCT_NAME) {
570		if (atom->property->structure.function == STRUCT_CONSTRUCTOR)
571		    atom = Omake_struct->data.atom;
572		else if (atom->property->structure.function == STRUCT_CHECK)
573		    atom = Ostruct_type->data.atom;
574		else
575		    atom = Ostruct_access->data.atom;
576		xbuiltin = atom->property->fun.builtin;
577	    }
578	    else
579		LispDestroy("%s: the function %s is not defined",
580			    STRFUN(builtin), STROBJ(function));
581	    break;
582	case LispBytecode_t:
583	    name = Olambda;
584	    bytecode = function;
585	    break;
586	case LispLambda_t:
587	    name = Olambda;
588	    alist = (LispArgList*)function->data.lambda.name->data.opaque.data;
589	    break;
590	case LispCons_t:
591	    if (CAR(function) == Olambda) {
592		function = EVAL(function);
593		if (OBJECT_TYPE(function) == LispLambda_t) {
594		    name = Olambda;
595		    alist = (LispArgList*)
596			function->data.lambda.name->data.opaque.data;
597		    break;
598		}
599	    }
600	default:
601	    LispDestroy("%s: %s is not a function",
602			STRFUN(builtin), STROBJ(function));
603	    break;
604    }
605
606    if (xbuiltin) {
607	LispWriteStr(NIL, "Builtin ", 8);
608	if (macro)
609	    LispWriteStr(NIL, "macro ", 6);
610	else
611	    LispWriteStr(NIL, "function ", 9);
612    }
613    else if (macro)
614	LispWriteStr(NIL, "Macro ", 6);
615    else
616	LispWriteStr(NIL, "Function ", 9);
617    LispWriteObject(NIL, name);
618    LispWriteStr(NIL, ":\n", 2);
619
620    if (alist) {
621	int i;
622
623	sprintf(buffer, "%d required argument%s",
624		alist->normals.num_symbols,
625		alist->normals.num_symbols != 1 ? "s" : "");
626	LispWriteStr(NIL, buffer, strlen(buffer));
627	for (i = 0; i < alist->normals.num_symbols; i++) {
628	    LispWriteChar(NIL, i ? ',' : ':');
629	    LispWriteChar(NIL, ' ');
630	    LispWriteStr(NIL, ATOMID(alist->normals.symbols[i]),
631			 strlen(ATOMID(alist->normals.symbols[i])));
632	}
633	LispWriteChar(NIL, '\n');
634
635	sprintf(buffer, "%d optional argument%s",
636		alist->optionals.num_symbols,
637		alist->optionals.num_symbols != 1 ? "s" : "");
638	LispWriteStr(NIL, buffer, strlen(buffer));
639	for (i = 0; i < alist->optionals.num_symbols; i++) {
640	    LispWriteChar(NIL, i ? ',' : ':');
641	    LispWriteChar(NIL, ' ');
642	    LispWriteStr(NIL, ATOMID(alist->optionals.symbols[i]),
643			 strlen(ATOMID(alist->optionals.symbols[i])));
644	}
645	LispWriteChar(NIL, '\n');
646
647	sprintf(buffer, "%d keyword parameter%s",
648		alist->keys.num_symbols,
649		alist->keys.num_symbols != 1 ? "s" : "");
650	LispWriteStr(NIL, buffer, strlen(buffer));
651	for (i = 0; i < alist->keys.num_symbols; i++) {
652	    LispWriteChar(NIL, i ? ',' : ':');
653	    LispWriteChar(NIL, ' ');
654	    LispWriteObject(NIL, alist->keys.symbols[i]);
655	}
656	LispWriteChar(NIL, '\n');
657
658	if (alist->rest) {
659	    LispWriteStr(NIL, "Rest argument: ", 15);
660	    LispWriteStr(NIL, ATOMID(alist->rest),
661			 strlen(ATOMID(alist->rest)));
662	    LispWriteChar(NIL, '\n');
663	}
664	else
665	    LispWriteStr(NIL, "No rest argument\n", 17);
666    }
667
668    if (bytecode) {
669	char *ptr;
670	int *offsets[4];
671	int i, done, j, sym0, sym1, con0, con1, bui0, byt0, strd, strf;
672	LispObj **constants;
673	LispAtom **symbols;
674	LispBuiltin **builtins;
675	LispObj **names;
676	short stack, num_constants, num_symbols, num_builtins, num_bytecodes;
677	unsigned char *base, *stream = bytecode->data.bytecode.bytecode->code;
678
679	LispWriteStr(NIL, "\nBytecode header:\n", 18);
680
681	/* Header information */
682	stack = *(short*)stream;
683	stream += sizeof(short);
684	sprintf(buffer, "%d element%s used in the stack\n",
685		stack, stack != 1 ? "s" : "");
686	LispWriteStr(NIL, buffer, strlen(buffer));
687	stack = *(short*)stream;
688	stream += sizeof(short);
689	sprintf(buffer, "%d element%s used in the builtin stack\n",
690		stack, stack != 1 ? "s" : "");
691	LispWriteStr(NIL, buffer, strlen(buffer));
692	stack = *(short*)stream;
693	stream += sizeof(short);
694	sprintf(buffer, "%d element%s used in the protected stack\n",
695		stack, stack != 1 ? "s" : "");
696	LispWriteStr(NIL, buffer, strlen(buffer));
697
698	num_constants = *(short*)stream;
699	stream += sizeof(short);
700	num_symbols = *(short*)stream;
701	stream += sizeof(short);
702	num_builtins = *(short*)stream;
703	stream += sizeof(short);
704	num_bytecodes = *(short*)stream;
705	stream += sizeof(short);
706
707	constants = (LispObj**)stream;
708	stream += num_constants * sizeof(LispObj*);
709	symbols = (LispAtom**)stream;
710	stream += num_symbols * sizeof(LispAtom*);
711	builtins = (LispBuiltin**)stream;
712	stream += num_builtins * sizeof(LispBuiltin*);
713	stream += num_bytecodes * sizeof(unsigned char*);
714	names = (LispObj**)stream;
715	stream += num_bytecodes * sizeof(LispObj*);
716
717	for (i = 0; i < num_constants; i++) {
718	    sprintf(buffer, "Constant %d = %s\n", i, STROBJ(constants[i]));
719	    LispWriteStr(NIL, buffer, strlen(buffer));
720	}
721
722/* Macro XSTRING avoids some noisy in the output, if it were defined as
723 * #define XSTRING(object) object ? STROBJ(object) : #<UNBOUND>
724 *	and called as XSTRING(atom->object)
725 * it would also print the package name were the symbol was first defined,
726 * but for local variables, only the symbol string is important. */
727#define XSTRING(string)		string ? string : "#<UNBOUND>"
728
729	for (i = 0; i < num_symbols; i++) {
730	    sprintf(buffer, "Symbol %d = %s\n",
731		    i, XSTRING(symbols[i]->string));
732	    LispWriteStr(NIL, buffer, strlen(buffer));
733	}
734	for (i = 0; i < num_builtins; i++) {
735	    sprintf(buffer, "Builtin %d = %s\n",
736		    i, STROBJ(builtins[i]->symbol));
737	    LispWriteStr(NIL, buffer, strlen(buffer));
738	}
739	for (i = 0; i < num_bytecodes; i++) {
740	    sprintf(buffer, "Bytecode %d = %s\n",
741		    i, STROBJ(names[i]));
742	    LispWriteStr(NIL, buffer, strlen(buffer));
743	}
744
745	/*  Make readability slightly easier printing the names of local
746	 * variables where it's offset is known, i.e. function arguments. */
747	if (alist) {
748	    if (alist->num_arguments == 0)
749		LispWriteStr(NIL, "\nNo initial stack\n", 18);
750	    else {
751		int len1, len2;
752
753		j = 0;
754		LispWriteStr(NIL, "\nInitial stack:\n", 16);
755
756		for (i = 0; i < alist->normals.num_symbols; i++, j++) {
757		    sprintf(buffer, "%d = ", j);
758		    LispWriteStr(NIL, buffer, strlen(buffer));
759		    ptr = alist->normals.symbols[i]->data.atom->string;
760		    LispWriteStr(NIL, ptr, strlen(ptr));
761		    LispWriteChar(NIL, '\n');
762		}
763
764		for (i = 0; i < alist->optionals.num_symbols; i++, j++) {
765		    sprintf(buffer, "%d = ", j);
766		    LispWriteStr(NIL, buffer, strlen(buffer));
767		    ptr = alist->optionals.symbols[i]->data.atom->string;
768		    LispWriteStr(NIL, ptr, strlen(ptr));
769		    LispWriteChar(NIL, '\n');
770		    if (alist->optionals.sforms[i]) {
771			sprintf(buffer, "%d = ", j);
772			len1 = strlen(buffer);
773			LispWriteStr(NIL, buffer, len1);
774			ptr = alist->optionals.sforms[i]->data.atom->string;
775			len2 = strlen(ptr);
776			LispWriteStr(NIL, ptr, len2);
777			LispWriteChars(NIL, ' ', 28 - (len1 + len2));
778			LispWriteStr(NIL, ";  sform\n", 9);
779			j++;
780		    }
781		}
782
783		for (i = 0; i < alist->keys.num_symbols; i++, j++) {
784		    sprintf(buffer, "%d = ", j);
785		    len1 = strlen(buffer);
786		    LispWriteStr(NIL, buffer, len1);
787		    if (alist->keys.keys[i]) {
788			ptr = alist->keys.keys[i]->data.atom->string;
789			len2 = strlen(ptr);
790			LispWriteStr(NIL, ptr, strlen(ptr));
791			LispWriteChars(NIL, ' ', 28 - (len1 + len2));
792			LispWriteStr(NIL, ";  special key", 14);
793		    }
794		    else {
795			ptr = alist->keys.symbols[i]->data.atom->string;
796			LispWriteStr(NIL, ptr, strlen(ptr));
797		    }
798		    LispWriteChar(NIL, '\n');
799		    if (alist->keys.sforms[i]) {
800			sprintf(buffer, "%d = ", j);
801			len1 = strlen(buffer);
802			LispWriteStr(NIL, buffer, len1);
803			ptr = alist->keys.sforms[i]->data.atom->string;
804			len2 = strlen(ptr);
805			LispWriteStr(NIL, ptr, len2);
806			LispWriteChars(NIL, ' ', 28 - (len1 + len2));
807			LispWriteStr(NIL, ";  sform\n", 9);
808			j++;
809		    }
810		}
811
812		if (alist->rest) {
813		    sprintf(buffer, "%d = ", j);
814		    len1 = strlen(buffer);
815		    LispWriteStr(NIL, buffer, len1);
816		    ptr = alist->rest->data.atom->string;
817		    len2 = strlen(ptr);
818		    LispWriteStr(NIL, ptr, len2);
819		    LispWriteChar(NIL, '\n');
820		    j++;
821		}
822
823		for (i = 0; i < alist->auxs.num_symbols; i++, j++) {
824		    sprintf(buffer, "%d = ", j);
825		    len1 = strlen(buffer);
826		    LispWriteStr(NIL, buffer, len1);
827		    ptr = alist->auxs.symbols[i]->data.atom->string;
828		    len2 = strlen(ptr);
829		    LispWriteStr(NIL, ptr, len2);
830		    LispWriteChars(NIL, ' ', 28 - (len1 + len2));
831		    LispWriteStr(NIL, ";  aux\n", 7);
832		}
833	    }
834	}
835
836	LispWriteStr(NIL, "\nBytecode stream:\n", 18);
837
838	base = stream;
839	for (done = j = 0; !done; j = 0) {
840	    sym0 = sym1 = con0 = con1 = bui0 = byt0 = strd = strf = -1;
841	    sprintf(buffer, "%4ld  ", (long)(stream - base));
842	    ptr = buffer + strlen(buffer);
843	    switch (*stream++) {
844		case XBC_NOOP:	strcpy(ptr, "NOOP");	break;
845		case XBC_PRED:
846		    strcpy(ptr, "PRED:");
847		    ptr += strlen(ptr);
848		    goto predicate;
849		case XBC_INV:	strcpy(ptr, "INV");	break;
850		case XBC_NIL:	strcpy(ptr, "NIL");	break;
851		case XBC_T:	strcpy(ptr, "T");	break;
852		case XBC_CAR:	strcpy(ptr, "CAR");	break;
853		case XBC_CDR:	strcpy(ptr, "CDR");	break;
854		case XBC_RPLACA:strcpy(ptr, "RPLACA");	break;
855		case XBC_RPLACD:strcpy(ptr, "RPLACD");	break;
856		case XBC_EQ:	strcpy(ptr, "EQ");	break;
857		case XBC_EQL:	strcpy(ptr, "EQL");	break;
858		case XBC_EQUAL:	strcpy(ptr, "EQUAL");	break;
859		case XBC_EQUALP:strcpy(ptr, "EQUALP");	break;
860		case XBC_LENGTH:strcpy(ptr, "LENGTH");	break;
861		case XBC_LAST:	strcpy(ptr, "LAST");	break;
862		case XBC_NTHCDR:strcpy(ptr, "NTHCDR");	break;
863		case XBC_PUSH:	strcpy(ptr, "PUSH");	break;
864		case XBC_CAR_PUSH:
865		    strcpy(ptr, "CAR&PUSH");
866		    break;
867		case XBC_CDR_PUSH:
868		    strcpy(ptr, "CDR&PUSH");
869		    break;
870		case XBC_PUSH_NIL:
871		    strcpy(ptr, "PUSH NIL");
872		    break;
873		case XBC_PUSH_UNSPEC:
874		    strcpy(ptr, "PUSH #<UNSPEC>");
875		    break;
876		case XBC_PUSH_T:
877		    strcpy(ptr, "PUSH T");
878		    break;
879		case XBC_PUSH_NIL_N:
880		    strcpy(ptr, "PUSH NIL ");
881		    ptr += strlen(ptr);
882		    sprintf(ptr, "%d", (int)(*stream++));
883		    break;
884		case XBC_PUSH_UNSPEC_N:
885		    strcpy(ptr, "PUSH #<UNSPEC> ");
886		    ptr += strlen(ptr);
887		    sprintf(ptr, "%d", (int)(*stream++));
888		    break;
889		case XBC_LET:
890		    strcpy(ptr, "LET");
891/* update sym0 */
892symbol:
893		    offsets[j++] = &sym0;
894/* update <offsets> - print [byte] */
895offset:
896		    ptr += strlen(ptr);
897		    i = *stream++;
898		    *(offsets[j - 1]) = i;
899		    sprintf(ptr, " [%d]", i);
900		    break;
901		case XBC_LETX:
902		    strcpy(ptr, "LET*");
903		    goto symbol;
904		case XBC_LET_NIL:
905		    strcpy(ptr, "LET NIL");
906		    goto symbol;
907		case XBC_LETX_NIL:
908		    strcpy(ptr, "LET* NIL");
909		    goto symbol;
910		case XBC_LETBIND:
911		    strcpy(ptr, "LETBIND");
912/* print byte */
913value:
914		    ptr += strlen(ptr);
915		    sprintf(ptr, " %d", (int)(*stream++));
916		    break;
917		case XBC_UNLET:strcpy(ptr, "UNLET");	goto value;
918		case XBC_LOAD:
919		    strcpy(ptr, "LOAD");
920/* print (byte) */
921reference:
922		    ptr += strlen(ptr);
923		    i = *stream++;
924		    sprintf(ptr, " (%d)", i);
925		    break;
926		case XBC_LOAD_CAR:
927		    strcpy(ptr, "LOAD&CAR");
928		    goto reference;
929		case XBC_LOAD_CDR:
930		    strcpy(ptr, "LOAD&CDR");
931		    goto reference;
932		case XBC_LOAD_CAR_STORE:
933		    strcpy(ptr, "LOAD&CAR&STORE");
934		    goto reference;
935		case XBC_LOAD_CDR_STORE:
936		    strcpy(ptr, "LOAD&CDR&STORE");
937		    goto reference;
938		case XBC_LOAD_LET:
939		    strcpy(ptr, "LOAD&LET");
940load_let:
941		    offsets[j++] = &sym0;
942		    i = *stream++;
943		    ptr += strlen(ptr);
944		    sprintf(ptr, " (%d)", i);
945		    goto offset;
946		case XBC_LOAD_LETX:
947		    strcpy(ptr, "LOAD&LET*");
948		    goto load_let;
949		case XBC_STRUCT:
950		    strcpy(ptr, "STRUCT");
951		    offsets[j++] = &strf;
952		    offsets[j++] = &strd;
953/* update <offsets> - print [byte] - update <offsets> - print [byte] */
954offset_offset:
955		    ptr += strlen(ptr);
956		    i = *stream++;
957		    *(offsets[j - 2]) = i;
958		    sprintf(ptr, " [%d]", i);
959		    goto offset;
960		case XBC_LOAD_PUSH:
961		    strcpy(ptr, "LOAD&PUSH");
962		    goto reference;
963		case XBC_LOADCON:
964		    strcpy(ptr, "LOADCON");
965constant:
966		    offsets[j++] = &con0;
967		    goto offset;
968		case XBC_LOADCON_SET:
969		    strcpy(ptr, "LOADCON&SET");
970		    offsets[j++] = &con0;
971/* update <offsets> - print [byte] - print (byte) */
972offset_reference:
973		    i = *stream++;
974		    *(offsets[j - 1]) = i;
975		    ptr += strlen(ptr);
976		    sprintf(ptr, " [%d]", i);
977		    goto reference;
978		case XBC_STRUCTP:
979		    strcpy(ptr, "STRUCTP");
980		    offsets[j++] = &strd;
981		    goto offset;
982		case XBC_LOADCON_LET:
983		    strcpy(ptr, "LOADCON&LET");
984loadcon_let:
985		    offsets[j++] = &con0;
986		    offsets[j++] = &sym0;
987		    goto offset_offset;
988		case XBC_LOADCON_LETX:
989		    strcpy(ptr, "LOADCON&LET*");
990		    goto loadcon_let;
991		case XBC_LOADCON_PUSH:
992		    strcpy(ptr, "LOADCON&PUSH");
993		    goto constant;
994		case XBC_LOADSYM:
995		    strcpy(ptr, "LOADSYM");
996		    goto symbol;
997		case XBC_LOADSYM_LET:
998		    strcpy(ptr, "LOADSYM&LET");
999loadsym_let:
1000		    offsets[j++] = &sym0;
1001		    offsets[j++] = &sym1;
1002		    goto offset_offset;
1003		case XBC_LOADSYM_LETX:
1004		    strcpy(ptr, "LOADSYM&LET*");
1005		    goto loadsym_let;
1006		case XBC_LOADSYM_PUSH:
1007		    strcpy(ptr, "LOADSYM&PUSH");
1008		    goto symbol;
1009		case XBC_LOAD_SET:
1010		    strcpy(ptr, "LOAD&SET");
1011/* print (byte) - print (byte) */
1012reference_reference:
1013		    ptr += strlen(ptr);
1014		    i = *stream++;
1015		    sprintf(ptr, " (%d)", i);
1016		    goto reference;
1017		case XBC_LOAD_CAR_SET:
1018		    strcpy(ptr, "LOAD&CAR&SET");
1019		    goto reference_reference;
1020		case XBC_LOAD_CDR_SET:
1021		    strcpy(ptr, "LOAD&CDR&SET");
1022		    goto reference_reference;
1023		case XBC_CAR_SET:
1024		    strcpy(ptr, "CAR&SET");
1025		    goto reference;
1026		case XBC_CDR_SET:
1027		    strcpy(ptr, "CDR&SET");
1028		    goto reference;
1029		case XBC_SET:
1030		    strcpy(ptr, "SET");
1031		    goto reference;
1032		case XBC_SETSYM:
1033		    strcpy(ptr, "SETSYM");
1034		    goto symbol;
1035		case XBC_SET_NIL:
1036		    strcpy(ptr, "SET NIL");
1037		    goto reference;
1038		case XBC_CALL:
1039		    strcpy(ptr, "CALL");
1040		    ptr += strlen(ptr);
1041		    sprintf(ptr, " %d", (int)(*stream++));
1042		    offsets[j++] = &bui0;
1043		    goto offset;
1044		case XBC_CALL_SET:
1045		    strcpy(ptr, "CALL&SET");
1046		    ptr += strlen(ptr);
1047		    sprintf(ptr, " %d", (int)(*stream++));
1048		    offsets[j++] = &bui0;
1049		    goto offset_reference;
1050		case XBC_BYTECALL:
1051		    strcpy(ptr, "BYTECALL");
1052		    ptr += strlen(ptr);
1053		    sprintf(ptr, " %d", (int)(*stream++));
1054		    offsets[j++] = &byt0;
1055		    goto offset;
1056		case XBC_FUNCALL:
1057		    strcpy(ptr, "FUNCALL");
1058constant_constant:
1059		    offsets[j++] = &con0;
1060		    offsets[j++] = &con1;
1061		    goto offset_offset;
1062		case XBC_CCONS:
1063		    strcpy(ptr, "CCONS");
1064		    goto constant_constant;
1065		case XBC_CSTAR:	strcpy(ptr, "CSTAR");	break;
1066		case XBC_CFINI:	strcpy(ptr, "CFINI");	break;
1067		case XBC_LSTAR:	strcpy(ptr, "LSTAR");	break;
1068		case XBC_LCONS:	strcpy(ptr, "LCONS");	break;
1069		case XBC_LFINI:	strcpy(ptr, "LFINI");	break;
1070		case XBC_BCONS:	strcpy(ptr, "BCONS");	break;
1071		case XBC_BCONS1:	case XBC_BCONS2:	case XBC_BCONS3:
1072		case XBC_BCONS4:	case XBC_BCONS5:	case XBC_BCONS6:
1073		case XBC_BCONS7:
1074		    strcpy(ptr, "BCONS");
1075		    ptr += strlen(ptr);
1076		    sprintf(ptr, "%d", (int)(stream[-1] - XBC_BCONS));
1077		    break;
1078		case XBC_JUMP:
1079		    strcpy(ptr, "JUMP");
1080integer:
1081		    ptr += strlen(ptr);
1082		    sprintf(ptr, " %d", *(signed short*)stream);
1083		    stream += sizeof(short);
1084		    break;
1085		case XBC_JUMPT:
1086		    strcpy(ptr, "JUMPT");
1087		    goto integer;
1088		case XBC_JUMPNIL:
1089		    strcpy(ptr, "JUMPNIL");
1090		    goto integer;
1091		case XBC_LETREC:
1092		    strcpy(ptr, "LETREC");
1093		    ptr += strlen(ptr);
1094		    sprintf(ptr, " %d", (int)*stream++);
1095		    break;
1096		case XBC_RETURN:
1097		    strcpy(ptr, "RETURN");
1098		    done = 1;
1099		    break;
1100	    }
1101	    i = ptr - buffer + strlen(ptr);
1102	    LispWriteStr(NIL, buffer, i);
1103	    if (j) {
1104
1105		/* Pad */
1106		LispWriteChars(NIL, ' ', 28 - i);
1107		LispWriteChar(NIL, ';');
1108
1109		ptr = buffer;
1110
1111		/* Structure */
1112		if (strf >= 0) {
1113		    /* strd is valid if strf set */
1114		    LispObj *fields = constants[strd];
1115
1116		    for (; strf >= 0; strf--)
1117			fields = CDR(fields);
1118		    strcpy(ptr, "  ");	    ptr += 2;
1119		    strcpy(ptr, CAR(fields)->data.atom->string);
1120		    ptr += strlen(ptr);
1121		}
1122		if (strd >= 0) {
1123		    strcpy(ptr, "  ");		ptr += 2;
1124		    strcpy(ptr, STROBJ(CAR(constants[strd])));
1125		    ptr += strlen(ptr);
1126		}
1127
1128		/* Constants */
1129		if (con0 >= 0) {
1130		    strcpy(ptr, "  ");	ptr += 2;
1131		    strcpy(ptr, STROBJ(constants[con0]));
1132		    ptr += strlen(ptr);
1133		    if (con1 >= 0) {
1134			strcpy(ptr, "  ");	ptr += 2;
1135			strcpy(ptr, STROBJ(constants[con1]));
1136			ptr += strlen(ptr);
1137		    }
1138		}
1139
1140		/* Builtin */
1141		if (bui0 >= 0) {
1142		    strcpy(ptr, "  ");	ptr += 2;
1143		    strcpy(ptr, STROBJ(builtins[bui0]->symbol));
1144		    ptr += strlen(ptr);
1145		}
1146
1147		/* Bytecode */
1148		if (byt0 >= 0) {
1149		    strcpy(ptr, "  ");	ptr += 2;
1150		    strcpy(ptr, STROBJ(names[byt0]));
1151		    ptr += strlen(ptr);
1152		}
1153
1154		/* Symbols */
1155		if (sym0 >= 0) {
1156		    strcpy(ptr, "  ");	ptr += 2;
1157		    strcpy(ptr, XSTRING(symbols[sym0]->string));
1158		    ptr += strlen(ptr);
1159		    if (sym1 >= 0) {
1160			strcpy(ptr, "  ");	ptr += 2;
1161			strcpy(ptr, XSTRING(symbols[sym1]->string));
1162			ptr += strlen(ptr);
1163		    }
1164		}
1165
1166		i = ptr - buffer;
1167		LispWriteStr(NIL, buffer, i);
1168	    }
1169	    LispWriteChar(NIL, '\n');
1170	    continue;
1171predicate:
1172	    switch (*stream++) {
1173		case XBP_CONSP:     strcpy(ptr, "CONSP");   break;
1174		case XBP_LISTP:     strcpy(ptr, "LISTP");   break;
1175		case XBP_NUMBERP:   strcpy(ptr, "NUMBERP"); break;
1176	    }
1177	    LispWriteStr(NIL, buffer, ptr - buffer + strlen(ptr));
1178	    LispWriteChar(NIL, '\n');
1179	}
1180#undef XSTRING
1181    }
1182
1183    return (function);
1184}
1185
1186
1187
1188LispObj *
1189LispCompileForm(LispObj *form)
1190{
1191    GC_ENTER();
1192    int failed;
1193    LispCom com;
1194
1195    if (!CONSP(form))
1196	/* Incorrect call or NIL */
1197	return (form);
1198
1199    memset(&com, 0, sizeof(LispCom));
1200
1201    com.toplevel = com.block = LispCalloc(1, sizeof(CodeBlock));
1202    com.block->type = LispBlockNone;
1203    com.lex = lisp__data.env.lex;
1204
1205    com.plist = CONS(NIL, NIL);
1206    GC_PROTECT(com.plist);
1207
1208    failed = 1;
1209    if (setjmp(com.jmp) == 0) {
1210	for (; CONSP(form); form = CDR(form)) {
1211	    com.form = form;
1212	    ComEval(&com, CAR(form));
1213	}
1214	failed = 0;
1215    }
1216    GC_LEAVE();
1217
1218    return (failed ? NIL : MakeBytecodeObject(&com, NIL, NIL));
1219}
1220
1221LispObj *
1222LispExecuteBytecode(LispObj *object)
1223{
1224    if (!BYTECODEP(object))
1225	return (EVAL(object));
1226
1227    return (ExecuteBytecode(object->data.bytecode.bytecode->code));
1228}
1229
1230static LispObj *
1231MakeBytecodeObject(LispCom *com, LispObj *name, LispObj *plist)
1232{
1233    LispObj *object;
1234    LispBytecode *bytecode;
1235
1236    GC_ENTER();
1237    unsigned char *stream;
1238    short i, num_constants;
1239    LispObj **constants, *code, *cons, *prev;
1240
1241    /* Resolve dependencies, optimize and create byte stream */
1242    LinkBytecode(com);
1243
1244    object = LispNew(NIL, NIL);
1245    GC_PROTECT(object);
1246    bytecode = LispMalloc(sizeof(LispBytecode));
1247    bytecode->code = com->bytecode;
1248    bytecode->length = com->length;
1249
1250
1251    stream = bytecode->code;
1252
1253    /* Skip stack information */
1254    stream += sizeof(short) * 3;
1255
1256    /* Get information */
1257    num_constants = *(short*)stream;
1258    stream += sizeof(short) * 4;
1259    constants = (LispObj**)stream;
1260
1261    GC_PROTECT(plist);
1262    code = cons = prev = NIL;
1263    for (i = 0; i < num_constants; i++) {
1264	if (POINTERP(constants[i]) && !XSYMBOLP(constants[i])) {
1265	    if (code == NIL) {
1266		code = cons = prev = CONS(constants[i], NIL);
1267		GC_PROTECT(code);
1268	    }
1269	    else {
1270		RPLACD(cons, CONS(constants[i], NIL));
1271		prev = cons;
1272		cons = CDR(cons);
1273	    }
1274	}
1275    }
1276
1277    /* Protect this in case the function is redefined */
1278    for (i = 0; i < com->table.num_bytecodes; i++) {
1279	if (code == NIL) {
1280	    code = cons = prev = CONS(com->table.bytecodes[i], NIL);
1281	    GC_PROTECT(code);
1282	}
1283	else {
1284	    RPLACD(cons, CONS(com->table.bytecodes[i], NIL));
1285	    prev = cons;
1286	    cons = CDR(cons);
1287	}
1288    }
1289
1290    /* Free everything, but the LispCom structure and the generated bytecode */
1291    CompileFreeState(com);
1292
1293    /* Allocate the minimum required number of cons cells to protect objects */
1294    if (!CONSP(code))
1295	code = plist;
1296    else if (CONSP(plist)) {
1297	if (code == cons)
1298	    RPLACD(code, plist);
1299	else
1300	    RPLACD(cons, plist);
1301    }
1302    else {
1303	if (code == cons)
1304	    code = CAR(code);
1305	else
1306	    CDR(prev) = CAR(cons);
1307    }
1308
1309    object->data.bytecode.bytecode = bytecode;
1310    /* Byte code references this object, so it cannot be garbage collected */
1311    object->data.bytecode.code = code;
1312    object->data.bytecode.name = name;
1313    object->type = LispBytecode_t;
1314
1315    LispMused(bytecode);
1316    LispMused(bytecode->code);
1317    GC_LEAVE();
1318
1319    return (object);
1320}
1321
1322static void
1323CompileFreeTree(CodeTree *tree)
1324{
1325    if (tree->type == CodeTreeBlock)
1326	CompileFreeBlock(tree->data.block);
1327    LispFree(tree);
1328}
1329
1330static void
1331CompileFreeBlock(CodeBlock *block)
1332{
1333    CodeTree *tree = block->tree, *next;
1334
1335    while (tree) {
1336	next = tree->next;
1337	CompileFreeTree(tree);
1338	tree = next;
1339    }
1340    if (block->type == LispBlockBody) {
1341	LispFree(block->tagbody.labels);
1342	LispFree(block->tagbody.codes);
1343    }
1344    LispFree(block->variables.symbols);
1345    LispFree(block->variables.flags);
1346    LispFree(block);
1347}
1348
1349static void
1350CompileFreeState(LispCom *com)
1351{
1352    CompileFreeBlock(com->block);
1353    LispFree(com->table.constants);
1354    LispFree(com->table.symbols);
1355    LispFree(com->table.builtins);
1356    LispFree(com->table.bytecodes);
1357}
1358
1359/* XXX Put a breakpoint here when changing the macro expansion code.
1360 *     No opcodes should be generated during macro expansion. */
1361static CodeTree *
1362CompileNewTree(LispCom *com, CodeTreeType type)
1363{
1364    CodeTree *tree = LispMalloc(sizeof(CodeTree));
1365
1366    tree->type = type;
1367    tree->next = NULL;
1368    tree->block = com->block;
1369    if (com->block->tree == NULL)
1370	com->block->tree = tree;
1371    else
1372	com->block->tail->next = tree;
1373    com->block->tail = tree;
1374
1375    return (tree);
1376}
1377
1378static void
1379CompileIniBlock(LispCom *com, LispBlockType type, LispObj *tag)
1380{
1381    CodeTree *tree = NEW_TREE(CodeTreeBlock);
1382    CodeBlock *block = LispCalloc(1, sizeof(CodeBlock));
1383
1384    tree->data.block = block;
1385
1386    block->type = type;
1387    block->tag = tag;
1388    block->prev = com->block;
1389    block->parent = tree;
1390    block->level = com->level;
1391    com->block = block;
1392
1393    if (type == LispBlockBody)
1394	com->tagbody = com->level;
1395}
1396
1397static void
1398CompileFiniBlock(LispCom *com)
1399{
1400    com->block = com->block->prev;
1401    if (com->block && com->block->type == LispBlockBody)
1402	com->tagbody = com->block->level;
1403}
1404
1405static void
1406com_BytecodeChar(LispCom *com, LispByteOpcode code, char value)
1407{
1408    CodeTree *tree = NEW_TREE(CodeTreeBytecode);
1409
1410    tree->code = code;
1411    tree->data.signed_char = value;
1412}
1413
1414static void
1415com_BytecodeShort(LispCom *com, LispByteOpcode code, short value)
1416{
1417    CodeTree *tree = NEW_TREE(CodeTreeBytecode);
1418
1419    tree->code = code;
1420    tree->data.signed_short = value;
1421}
1422
1423static void
1424com_BytecodeAtom(LispCom *com, LispByteOpcode code, LispAtom *atom)
1425{
1426    CodeTree *tree = NEW_TREE(CodeTreeBytecode);
1427
1428    tree->code = code;
1429    tree->data.atom = atom;
1430}
1431
1432static void
1433com_BytecodeObject(LispCom *com, LispByteOpcode code, LispObj *object)
1434{
1435    CodeTree *tree = NEW_TREE(CodeTreeBytecode);
1436
1437    tree->code = code;
1438    tree->data.object = object;
1439}
1440
1441static void
1442com_BytecodeCons(LispCom *com, LispByteOpcode code, LispObj *car, LispObj *cdr)
1443{
1444    CodeTree *tree = NEW_TREE(CodeTreeBytecode);
1445
1446    tree->code = code;
1447    tree->data.cons.car = car;
1448    tree->data.cons.cdr = cdr;
1449}
1450
1451static void
1452com_Bytecode(LispCom *com, LispByteOpcode code)
1453{
1454    CodeTree *tree = NEW_TREE(CodeTreeBytecode);
1455
1456    tree->code = code;
1457}
1458
1459static void
1460com_Load(LispCom *com, short offset)
1461{
1462    com_BytecodeShort(com, XBC_LOAD, offset);
1463}
1464
1465static void
1466com_LoadLet(LispCom *com, short offset, LispAtom *name)
1467{
1468    CodeTree *tree = NEW_TREE(CodeTreeBytecode);
1469
1470    tree->code = XBC_LOAD_LET;
1471    tree->data.let.offset = offset;
1472    tree->data.let.name = name;
1473}
1474
1475static void
1476com_LoadPush(LispCom *com, short offset)
1477{
1478    com_BytecodeShort(com, XBC_LOAD_PUSH, offset);
1479}
1480
1481static void
1482com_Let(LispCom *com, LispAtom *name)
1483{
1484    com_BytecodeAtom(com, XBC_LET, name);
1485}
1486
1487static void
1488com_Bind(LispCom *com, short count)
1489{
1490    if (count)
1491	com_BytecodeShort(com, XBC_LETBIND, count);
1492}
1493
1494static void
1495com_Unbind(LispCom *com, short count)
1496{
1497    if (count)
1498	com_BytecodeShort(com, XBC_UNLET, count);
1499}
1500
1501static void
1502com_LoadSym(LispCom *com, LispAtom *atom)
1503{
1504    com_BytecodeAtom(com, XBC_LOADSYM, atom);
1505}
1506
1507static void
1508com_LoadSymLet(LispCom *com, LispAtom *symbol, LispAtom *name)
1509{
1510    CodeTree *tree = NEW_TREE(CodeTreeBytecode);
1511
1512    tree->code = XBC_LOADSYM_LET;
1513    tree->data.let_sym.symbol = symbol;
1514    tree->data.let_sym.name = name;
1515}
1516
1517static void
1518com_LoadSymPush(LispCom *com, LispAtom *name)
1519{
1520    com_BytecodeAtom(com, XBC_LOADSYM_PUSH, name);
1521}
1522
1523static void
1524com_LoadCon(LispCom *com, LispObj *constant)
1525{
1526    if (constant == NIL)
1527	com_Bytecode(com, XBC_NIL);
1528    else if (constant == T)
1529	com_Bytecode(com, XBC_T);
1530    else if (constant == UNSPEC) {
1531	COMPILE_FAILURE("internal error: loading #<UNSPEC>");
1532    }
1533    else
1534	com_BytecodeObject(com, XBC_LOADCON, constant);
1535}
1536
1537static void
1538com_LoadConLet(LispCom *com, LispObj *constant, LispAtom *name)
1539{
1540    if (constant == NIL)
1541	com_BytecodeAtom(com, XBC_LET_NIL, name);
1542    else {
1543	CodeTree *tree = NEW_TREE(CodeTreeBytecode);
1544
1545	tree->code = XBC_LOADCON_LET;
1546	tree->data.let_con.object = constant;
1547	tree->data.let_con.name = name;
1548    }
1549}
1550
1551static void
1552com_LoadConPush(LispCom *com, LispObj *constant)
1553{
1554    if (constant == NIL)
1555	com_Bytecode(com, XBC_PUSH_NIL);
1556    else if (constant == T)
1557	com_Bytecode(com, XBC_PUSH_T);
1558    else if (constant == UNSPEC)
1559	com_Bytecode(com, XBC_PUSH_UNSPEC);
1560    else
1561	com_BytecodeObject(com, XBC_LOADCON_PUSH, constant);
1562}
1563
1564static void
1565com_Set(LispCom *com, short offset)
1566{
1567    com_BytecodeShort(com, XBC_SET, offset);
1568}
1569
1570static void
1571com_SetSym(LispCom *com, LispAtom *symbol)
1572{
1573    com_BytecodeAtom(com, XBC_SETSYM, symbol);
1574}
1575
1576static void
1577com_Struct(LispCom *com, short offset, LispObj *definition)
1578{
1579    CodeTree *tree = NEW_TREE(CodeTreeBytecode);
1580
1581    tree->code = XBC_STRUCT;
1582    tree->data.struc.offset = offset;
1583    tree->data.struc.definition = definition;
1584}
1585
1586static void
1587com_Structp(LispCom *com, LispObj *definition)
1588{
1589    com_BytecodeObject(com, XBC_STRUCTP, definition);
1590}
1591
1592static void
1593com_Call(LispCom *com, unsigned char num_arguments, LispBuiltin *builtin)
1594{
1595    CodeTree *tree = NEW_TREE(CodeTreeBytecode);
1596
1597    tree->code = XBC_CALL;
1598    tree->data.builtin.num_arguments = num_arguments;
1599    tree->data.builtin.builtin = builtin;
1600}
1601
1602static void
1603com_Bytecall(LispCom *com, unsigned char num_arguments, LispObj *code)
1604{
1605    CodeTree *tree = NEW_TREE(CodeTreeBytecode);
1606
1607    tree->code = XBC_BYTECALL;
1608    tree->data.bytecall.num_arguments = num_arguments;
1609    tree->data.bytecall.code = code;
1610}
1611
1612static void
1613com_Funcall(LispCom *com, LispObj *function, LispObj *arguments)
1614{
1615    com_BytecodeCons(com, XBC_FUNCALL, function, arguments);
1616}
1617
1618static void
1619CompileStackEnter(LispCom *com, int count, int builtin)
1620{
1621    if (!com->macro) {
1622	if (builtin) {
1623	    com->stack.cbstack += count;
1624	    if (com->stack.bstack < com->stack.cbstack)
1625		com->stack.bstack = com->stack.cbstack;
1626	}
1627	else {
1628	    com->stack.cstack += count;
1629	    if (com->stack.stack < com->stack.cstack)
1630		com->stack.stack = com->stack.cstack;
1631	}
1632    }
1633}
1634
1635static void
1636CompileStackLeave(LispCom *com, int count, int builtin)
1637{
1638    if (!com->macro) {
1639	if (builtin)
1640	    com->stack.cbstack -= count;
1641	else
1642	    com->stack.cstack -= count;
1643    }
1644}
1645
1646static void
1647LinkWarnUnused(LispCom *com, CodeBlock *block)
1648{
1649    int i;
1650    CodeTree *tree;
1651
1652    for (tree = block->tree; tree; tree = tree->next) {
1653	if (tree->type == CodeTreeBlock)
1654	    LinkWarnUnused(com, tree->data.block);
1655    }
1656
1657    for (i = 0; i < block->variables.length; i++)
1658	if (!(block->variables.flags[i] & (VARIABLE_USED | VARIABLE_ARGUMENT))) {
1659	    ++com->warnings;
1660	    LispWarning("the variable %s is unused",
1661			block->variables.symbols[i]->string);
1662	}
1663}
1664
1665#define	INTERNAL_ERROR_STRING "COMPILE: internal error #%d"
1666#define	INTERNAL_ERROR(value) LispDestroy(INTERNAL_ERROR_STRING, value)
1667static long
1668LinkBuildOffsets(LispCom *com, CodeTree *tree, long offset)
1669{
1670    for (; tree; tree = tree->next) {
1671	tree->offset = offset;
1672	switch (tree->type) {
1673	    case CodeTreeBytecode:
1674		switch (tree->code) {
1675		    case XBC_NOOP:
1676			INTERNAL_ERROR(__LINE__);
1677			break;
1678
1679		    /* byte */
1680		    case XBC_BCONS:
1681		    case XBC_BCONS1:
1682		    case XBC_BCONS2:
1683		    case XBC_BCONS3:
1684		    case XBC_BCONS4:
1685		    case XBC_BCONS5:
1686		    case XBC_BCONS6:
1687		    case XBC_BCONS7:
1688		    case XBC_INV:
1689		    case XBC_NIL:
1690		    case XBC_T:
1691		    case XBC_PUSH:
1692		    case XBC_CAR_PUSH:
1693		    case XBC_CDR_PUSH:
1694		    case XBC_PUSH_NIL:
1695		    case XBC_PUSH_UNSPEC:
1696		    case XBC_PUSH_T:
1697		    case XBC_LSTAR:
1698		    case XBC_LCONS:
1699		    case XBC_LFINI:
1700		    case XBC_RETURN:
1701		    case XBC_CSTAR:
1702		    case XBC_CFINI:
1703		    case XBC_CAR:
1704		    case XBC_CDR:
1705		    case XBC_RPLACA:
1706		    case XBC_RPLACD:
1707		    case XBC_EQ:
1708		    case XBC_EQL:
1709		    case XBC_EQUAL:
1710		    case XBC_EQUALP:
1711		    case XBC_LENGTH:
1712		    case XBC_LAST:
1713		    case XBC_NTHCDR:
1714			++offset;
1715			break;
1716
1717		    /* byte + byte */
1718		    case XBC_PUSH_NIL_N:
1719		    case XBC_PUSH_UNSPEC_N:
1720		    case XBC_PRED:
1721		    case XBC_LETREC:
1722		    case XBC_LOAD_PUSH:
1723		    case XBC_CAR_SET:
1724		    case XBC_CDR_SET:
1725		    case XBC_SET:
1726		    case XBC_SET_NIL:
1727		    case XBC_LETBIND:
1728		    case XBC_UNLET:
1729		    case XBC_LOAD:
1730		    case XBC_LOAD_CAR:
1731		    case XBC_LOAD_CDR:
1732		    case XBC_LOAD_CAR_STORE:
1733		    case XBC_LOAD_CDR_STORE:
1734		    case XBC_LET:
1735		    case XBC_LETX:
1736		    case XBC_LET_NIL:
1737		    case XBC_LETX_NIL:
1738		    case XBC_STRUCTP:
1739		    case XBC_SETSYM:
1740		    case XBC_LOADCON_PUSH:
1741		    case XBC_LOADSYM_PUSH:
1742		    case XBC_LOADCON:
1743		    case XBC_LOADSYM:
1744			offset += 2;
1745			break;
1746
1747		    /* byte + byte + byte */
1748		    case XBC_CALL:
1749		    case XBC_BYTECALL:
1750		    case XBC_LOAD_SET:
1751		    case XBC_LOAD_CAR_SET:
1752		    case XBC_LOAD_CDR_SET:
1753		    case XBC_LOADCON_SET:
1754		    case XBC_LOAD_LET:
1755		    case XBC_LOAD_LETX:
1756		    case XBC_STRUCT:
1757		    case XBC_LOADCON_LET:
1758		    case XBC_LOADCON_LETX:
1759		    case XBC_LOADSYM_LET:
1760		    case XBC_LOADSYM_LETX:
1761		    case XBC_CCONS:
1762		    case XBC_FUNCALL:
1763			offset += 3;
1764			break;
1765
1766		    /* byte + short */
1767		    case XBC_JUMP:
1768		    case XBC_JUMPT:
1769		    case XBC_JUMPNIL:
1770			/* XXX this is likely a jump to random address here */
1771			INTERNAL_ERROR(__LINE__);
1772			offset += sizeof(short) + 1;
1773			break;
1774
1775		    /* byte + byte + byte + byte */
1776		    case XBC_CALL_SET:
1777			offset += 4;
1778			break;
1779		}
1780		break;
1781	    case CodeTreeLabel:
1782		/* Labels are not loaded */
1783		break;
1784	    case CodeTreeJump:
1785	    case CodeTreeJumpIf:
1786	    case CodeTreeCond:
1787		/* If not the point where the conditional block finishes */
1788		if (tree->code != XBC_NOOP)
1789		    /* Reserve space for the jump opcode */
1790		    offset += sizeof(short) + 1;
1791		break;
1792	    case CodeTreeGo:
1793	    case CodeTreeReturn:
1794		/* Reserve space for the jump opcode */
1795		offset += sizeof(short) + 1;
1796		break;
1797	    case CodeTreeBlock:
1798		offset = LinkBuildOffsets(com, tree->data.block->tree, offset);
1799		break;
1800	}
1801    }
1802
1803    return (offset);
1804}
1805
1806static void
1807LinkDoOptimize_0(LispCom *com, CodeBlock *block)
1808{
1809    CodeTree *tree, *prev, *next;
1810
1811    /*  Remove redundant or join opcodes that can be joined. Do it here
1812     * because some of these are hard to detect earlier, and/or would
1813     * require a lot of duplicated code or more time. */
1814    tree = prev = block->tree;
1815    while (tree) {
1816	next = tree->next;
1817
1818	/* LET -> LET* */
1819	if (next &&
1820	    next->type == CodeTreeBytecode &&
1821	    next->code == XBC_LETBIND &&
1822	    next->data.signed_short == 1) {
1823	    switch (tree->code) {
1824		case XBC_LET:
1825		    tree->code = XBC_LETX;
1826		    goto remove_next_label;
1827		case XBC_LET_NIL:
1828		    tree->code = XBC_LETX_NIL;
1829		    goto remove_next_label;
1830		case XBC_LOAD_LET:
1831		    tree->code = XBC_LOAD_LETX;
1832		    goto remove_next_label;
1833		case XBC_LOADCON_LET:
1834		    tree->code = XBC_LOADCON_LETX;
1835		    goto remove_next_label;
1836		case XBC_LOADSYM_LET:
1837		    tree->code = XBC_LOADSYM_LETX;
1838		    goto remove_next_label;
1839		default:
1840		    break;
1841	    }
1842	}
1843
1844	switch (tree->type) {
1845	    case CodeTreeBytecode:
1846		switch (tree->code) {
1847		    case XBC_LOADCON:
1848			if (next && next->type == CodeTreeBytecode) {
1849			    switch (next->code) {
1850				case XBC_LET:
1851				    next->code = XBC_LOADCON_LET;
1852				    next->data.let_con.name =
1853					next->data.atom;
1854				    next->data.let_con.object =
1855					tree->data.object;
1856				    goto remove_label;
1857				case XBC_PUSH:
1858				    next->code = XBC_LOADCON_PUSH;
1859				    next->data.object = tree->data.object;
1860				    goto remove_label;
1861				case XBC_CAR:
1862				    if (tree->data.object != NIL) {
1863					if (!CONSP(tree->data.object))
1864					    LispDestroy("CAR: %s is not a list",
1865						        STROBJ(
1866							tree->data.object));
1867					next->code = XBC_LOADCON;
1868					next->data.object =
1869					    CAR(tree->data.object);
1870				    }
1871				    goto remove_label;
1872				case XBC_CDR:
1873				    if (tree->data.object != NIL) {
1874					if (!CONSP(tree->data.object))
1875					    LispDestroy("CAR: %s is not a list",
1876						        STROBJ(
1877							tree->data.object));
1878					next->code = XBC_LOADCON;
1879					next->data.object =
1880					    CDR(tree->data.object);
1881				    }
1882				    goto remove_label;
1883				case XBC_SET:
1884				    next->code = XBC_LOADCON_SET;
1885				    next->data.load_con_set.offset =
1886					next->data.signed_short;
1887				    next->data.load_con_set.object =
1888					tree->data.object;
1889				    goto remove_label;
1890				default:
1891				    break;
1892			    }
1893			}
1894			break;
1895		    case XBC_LOADSYM:
1896			if (next && next->type == CodeTreeBytecode) {
1897			    switch (next->code) {
1898				case XBC_LET:
1899				    next->code = XBC_LOADSYM_LET;
1900				    next->data.let_sym.name =
1901					next->data.atom;
1902				    next->data.let_sym.symbol =
1903					tree->data.atom;
1904				    goto remove_label;
1905				case XBC_PUSH:
1906				    next->code = XBC_LOADSYM_PUSH;
1907				    next->data.atom = tree->data.atom;
1908				    goto remove_label;
1909				default:
1910				    break;
1911			    }
1912			}
1913			break;
1914		    case XBC_LOAD:
1915			if (next && next->type == CodeTreeBytecode) {
1916			    switch (next->code) {
1917				case XBC_SET:
1918				    next->code = XBC_LOAD_SET;
1919				    next->data.load_set.set =
1920					next->data.signed_short;
1921				    next->data.load_set.load =
1922					tree->data.signed_short;
1923				    goto remove_label;
1924				/* TODO add XBC_LOAD_SETSYM */
1925				case XBC_CAR:
1926				    next->code = XBC_LOAD_CAR;
1927				    next->data.signed_short =
1928					tree->data.signed_short;
1929				    goto remove_label;
1930				case XBC_CDR:
1931				    next->code = XBC_LOAD_CDR;
1932				    next->data.signed_short =
1933					tree->data.signed_short;
1934				    goto remove_label;
1935				case XBC_PUSH:
1936				    tree->code = XBC_LOAD_PUSH;
1937				    goto remove_next_label;
1938				case XBC_LET:
1939				    next->code = XBC_LOAD_LET;
1940				    next->data.let.name = next->data.atom;
1941				    next->data.let.offset =
1942					tree->data.signed_short;
1943				    goto remove_label;
1944				default:
1945				    break;
1946			    }
1947			}
1948			break;
1949		    case XBC_LOAD_CAR:
1950			if (next && next->type == CodeTreeBytecode &&
1951			    next->code == XBC_SET) {
1952			    if (next->data.signed_short ==
1953				tree->data.signed_short)
1954				next->code = XBC_LOAD_CAR_STORE;
1955			    else {
1956				next->code = XBC_LOAD_CAR_SET;
1957				next->data.load_set.set =
1958				    next->data.signed_short;
1959				next->data.load_set.load =
1960				    tree->data.signed_short;
1961			    }
1962			    goto remove_label;
1963			}
1964			break;
1965		    case XBC_LOAD_CDR:
1966			if (next && next->type == CodeTreeBytecode &&
1967			    next->code == XBC_SET) {
1968			    if (next->data.signed_short ==
1969				tree->data.signed_short)
1970				next->code = XBC_LOAD_CDR_STORE;
1971			    else {
1972				next->code = XBC_LOAD_CDR_SET;
1973				next->data.load_set.set =
1974				    next->data.signed_short;
1975				next->data.load_set.load =
1976				    tree->data.signed_short;
1977			    }
1978			    goto remove_label;
1979			}
1980			break;
1981		    case XBC_CALL:
1982			if (next && next->type == CodeTreeBytecode) {
1983			    switch (next->code) {
1984				case XBC_SET:
1985				    next->code = XBC_CALL_SET;
1986				    next->data.builtin.offset =
1987					next->data.signed_short;
1988				    next->data.builtin.num_arguments =
1989					tree->data.builtin.num_arguments;
1990				    next->data.builtin.builtin =
1991					tree->data.builtin.builtin;
1992				    goto remove_label;
1993				/* TODO add XBC_CALL_SETSYM */
1994				default:
1995				    break;
1996			    }
1997			}
1998			break;
1999		    case XBC_CAR:
2000			if (next && next->type == CodeTreeBytecode) {
2001			    switch (next->code) {
2002				case XBC_SET:
2003				    next->code = XBC_CAR_SET;
2004				    goto remove_label;
2005				/* TODO add XBC_CAR_SETSYM */
2006				case XBC_PUSH:
2007				    next->code = XBC_CAR_PUSH;
2008				    goto remove_label;
2009				default:
2010				    break;
2011			    }
2012			}
2013			break;
2014		    case XBC_CDR:
2015			if (next && next->type == CodeTreeBytecode) {
2016			    switch (next->code) {
2017				case XBC_SET:
2018				    next->code = XBC_CDR_SET;
2019				    goto remove_label;
2020				/* TODO add XBC_CDR_SETSYM */
2021				case XBC_PUSH:
2022				    next->code = XBC_CDR_PUSH;
2023				    goto remove_label;
2024				default:
2025				    break;
2026			    }
2027			}
2028			break;
2029		    case XBC_NIL:
2030			if (next && next->type == CodeTreeBytecode) {
2031			    switch (next->code) {
2032				case XBC_SET:
2033				    next->code = XBC_SET_NIL;
2034				    goto remove_label;
2035				/* TODO add XBC_SETSYM_NIL */
2036				default:
2037				    break;
2038			    }
2039			}
2040			break;
2041		    case XBC_PUSH_NIL:
2042			if (next && next->type == CodeTreeBytecode &&
2043			    next->code == XBC_PUSH_NIL) {
2044			    next->code = XBC_PUSH_NIL_N;
2045			    next->data.signed_char = 2;
2046			    goto remove_label;
2047			}
2048			break;
2049		    case XBC_PUSH_NIL_N:
2050			if (next && next->type == CodeTreeBytecode &&
2051			    next->code == XBC_PUSH_NIL) {
2052			    next->code = XBC_PUSH_NIL_N;
2053			    next->data.signed_char = tree->data.signed_char + 1;
2054			    goto remove_label;
2055			}
2056			break;
2057		    case XBC_PUSH_UNSPEC:
2058			if (next && next->type == CodeTreeBytecode &&
2059			    next->code == XBC_PUSH_UNSPEC) {
2060			    next->code = XBC_PUSH_UNSPEC_N;
2061			    next->data.signed_char = 2;
2062			    goto remove_label;
2063			}
2064			break;
2065		    case XBC_PUSH_UNSPEC_N:
2066			if (next && next->type == CodeTreeBytecode &&
2067			    next->code == XBC_PUSH_UNSPEC) {
2068			    next->code = XBC_PUSH_UNSPEC_N;
2069			    next->data.signed_char = tree->data.signed_char + 1;
2070			    goto remove_label;
2071			}
2072			break;
2073		    default:
2074			break;
2075		}
2076		break;
2077	    case CodeTreeBlock:
2078		LinkDoOptimize_0(com, tree->data.block);
2079		break;
2080	    default:
2081		break;
2082	}
2083	goto update_label;
2084remove_label:
2085	if (tree == block->tree) {
2086	    block->tree = prev = next;
2087	    if (tree == block->tail)
2088		block->tail = tree;
2089	}
2090	else
2091	    prev->next = next;
2092	CompileFreeTree(tree);
2093	tree = next;
2094	continue;
2095remove_next_label:
2096	tree->next = next->next;
2097	CompileFreeTree(next);
2098	continue;
2099update_label:
2100	prev = tree;
2101	tree = tree->next;
2102    }
2103}
2104
2105static void
2106LinkOptimize_0(LispCom *com)
2107{
2108    /* Recursive */
2109    LinkDoOptimize_0(com, com->block);
2110}
2111
2112static void
2113LinkResolveLabels(LispCom *com, CodeBlock *block)
2114{
2115    int i;
2116    CodeTree *tree = block->tree;
2117
2118    for (; tree; tree = tree->next) {
2119	if (tree->type == CodeTreeBlock)
2120	    LinkResolveLabels(com, tree->data.block);
2121	else if (tree->type == CodeTreeLabel) {
2122	    for (i = 0; i < block->tagbody.length; i++)
2123		if (tree->data.object == block->tagbody.labels[i]) {
2124		    block->tagbody.codes[i] = tree;
2125		    break;
2126		}
2127	}
2128    }
2129}
2130
2131static void
2132LinkResolveJumps(LispCom *com, CodeBlock *block)
2133{
2134    int i;
2135    CodeBlock *body = block;
2136    CodeTree *ptr, *tree = block->tree;
2137
2138    /* Check if there is a tagbody. Error checking already done */
2139    while (body && body->type != LispBlockBody)
2140	body = body->prev;
2141
2142    for (; tree; tree = tree->next) {
2143	switch (tree->type) {
2144	    case CodeTreeBytecode:
2145	    case CodeTreeLabel:
2146		break;
2147
2148	    case CodeTreeBlock:
2149		LinkResolveJumps(com, tree->data.block);
2150		break;
2151
2152	    case CodeTreeGo:
2153		for (i = 0; i < body->tagbody.length; i++)
2154		    if (tree->data.object == body->tagbody.labels[i])
2155			break;
2156		if (i == body->tagbody.length)
2157		    LispDestroy("COMPILE: no visible tag %s to GO",
2158				STROBJ(tree->data.object));
2159		/* Now the jump code is known */
2160		tree->data.tree = body->tagbody.codes[i];
2161		break;
2162
2163	    case CodeTreeCond:
2164		if (tree->code == XBC_JUMPNIL)
2165		    /* If test is NIL, go to next test */
2166		    tree->data.tree = tree->group->next;
2167		else if (tree->code == XBC_JUMPT) {
2168		    /* After executing code, test was T */
2169		    for (ptr = tree->group;
2170			 ptr->code != XBC_NOOP;
2171			 ptr = ptr->group)
2172			;
2173		    tree->data.tree = ptr;
2174		}
2175		break;
2176
2177	    case CodeTreeJumpIf:
2178		if (tree->code != XBC_NOOP) {
2179		    for (ptr = tree->group;
2180			 ptr->code != XBC_NOOP;
2181			 ptr = ptr->group) {
2182			if (ptr->type == CodeTreeJump) {
2183			    /* ELSE code of IF */
2184			    ptr = ptr->next;
2185			    /* Skip inconditional jump node */
2186			    break;
2187			}
2188		    }
2189		    tree->data.tree = ptr;
2190		}
2191		break;
2192
2193	    case CodeTreeJump:
2194		if (tree->code != XBC_NOOP)
2195		    tree->data.tree = tree->group;
2196		break;
2197
2198	    case CodeTreeReturn:
2199		/* One bytecode is guaranteed to exist in the code tree */
2200		if (tree->data.block->parent == NULL)
2201		    /* Returning from the function or toplevel form */
2202		    tree->data.tree = tree->data.block->tail;
2203		else {
2204		    for (;;) {
2205			ptr = tree->data.block->parent->next;
2206			if (ptr) {
2207			    tree->data.tree = ptr;
2208			    break;
2209			}
2210			else
2211			    /* Move one BLOCK up */
2212			    tree->data.block = tree->data.block->prev;
2213		    }
2214		}
2215		break;
2216	}
2217    }
2218}
2219
2220static long
2221LinkPad(long offset, long adjust, int preffix, int datalen)
2222{
2223    /* If byte or aligned data */
2224    if (datalen <= preffix || ((offset + adjust + preffix) % datalen) == 0)
2225	return (adjust);
2226
2227    return (adjust + (datalen - ((offset + adjust + preffix) % datalen)));
2228}
2229
2230static long
2231LinkFixupOffsets(LispCom *com, CodeTree *tree, long adjust)
2232{
2233    for (; tree; tree = tree->next) {
2234	switch (tree->type) {
2235	    case CodeTreeBytecode:
2236		switch (tree->code) {
2237		    /* byte + short */
2238		    case XBC_JUMP:
2239		    case XBC_JUMPT:
2240		    case XBC_JUMPNIL:
2241			adjust = LinkPad(tree->offset, adjust, 1,
2242					 sizeof(short));
2243			/*FALLTROUGH*/
2244		    default:
2245			tree->offset += adjust;
2246			break;
2247		}
2248		break;
2249	    case CodeTreeLabel:
2250		/* Labels are not loaded, just adjust offset */
2251		tree->offset += adjust;
2252		break;
2253	    case CodeTreeJump:
2254	    case CodeTreeCond:
2255	    case CodeTreeJumpIf:
2256		/* If an opcode will be generated. */
2257		if (tree->code != XBC_NOOP)
2258		    adjust = LinkPad(tree->offset, adjust, 1, sizeof(short));
2259		tree->offset += adjust;
2260		break;
2261	    case CodeTreeGo:
2262	    case CodeTreeReturn:
2263		adjust = LinkPad(tree->offset, adjust, 1, sizeof(short));
2264		tree->offset += adjust;
2265		break;
2266	    case CodeTreeBlock:
2267		adjust = LinkFixupOffsets(com, tree->data.block->tree, adjust);
2268		break;
2269	}
2270    }
2271
2272    return (adjust);
2273}
2274
2275static void
2276LinkSkipPadding(LispCom *com, CodeTree *tree)
2277{
2278    int found;
2279    CodeTree *ptr;
2280
2281    /* Recurse to adjust forward jumps or jumps to the start of the block */
2282    for (ptr = tree; ptr; ptr = ptr->next) {
2283	if (ptr->type == CodeTreeBlock) {
2284	    LinkSkipPadding(com, ptr->data.block->tree);
2285	    ptr->offset = ptr->data.block->tree->offset;
2286	}
2287    }
2288
2289    /* Adjust the nodes offsets */
2290    for (; tree; tree = tree->next) {
2291	switch (tree->type) {
2292	    case CodeTreeBytecode:
2293	    case CodeTreeBlock:
2294	    case CodeTreeGo:
2295	    case CodeTreeReturn:
2296		break;
2297	    case CodeTreeJump:
2298	    case CodeTreeCond:
2299	    case CodeTreeJumpIf:
2300		if (tree->code != XBC_NOOP)
2301		    /* If code will be generated */
2302		    break;
2303	    case CodeTreeLabel:
2304		/* This should be done in reversed order, but to avoid
2305		 * the requirement of a prev pointer, do the job in a
2306		 * harder way here. */
2307		for (found = 0, ptr = tree->next; ptr; ptr = ptr->next) {
2308		    switch (ptr->type) {
2309			case CodeTreeBytecode:
2310			case CodeTreeBlock:
2311			case CodeTreeGo:
2312			case CodeTreeReturn:
2313			    found = 1;
2314			    break;
2315			case CodeTreeJump:
2316			case CodeTreeCond:
2317			case CodeTreeJumpIf:
2318			    if (ptr->code != XBC_NOOP)
2319				found = 1;
2320			    break;
2321			case CodeTreeLabel:
2322			    break;
2323		    }
2324		    if (found)
2325			break;
2326		}
2327		if (found)
2328		    tree->offset = ptr->offset;
2329		break;
2330	}
2331    }
2332}
2333
2334static void
2335LinkCalculateJump(LispCom *com, CodeTree *tree, LispByteOpcode code)
2336{
2337    long jumpto, offset, distance;
2338
2339    tree->type = CodeTreeBytecode;
2340    /* After the opcode */
2341    offset = tree->offset + 1;
2342    jumpto = tree->data.tree->offset;
2343    /* Effective distance */
2344    distance = jumpto - offset;
2345    tree->code = code;
2346    if (distance < -32768 || distance > 32767) {
2347	COMPILE_FAILURE("jump too long");
2348    }
2349    tree->data.signed_int = distance;
2350}
2351
2352static void
2353LinkFixupJumps(LispCom *com, CodeTree *tree)
2354{
2355    for (; tree; tree = tree->next) {
2356	switch (tree->type) {
2357	    case CodeTreeBytecode:
2358	    case CodeTreeLabel:
2359		break;
2360	    case CodeTreeCond:
2361		if (tree->code == XBC_JUMPNIL)
2362		    /* Go to next test if NIL */
2363		    LinkCalculateJump(com, tree, XBC_JUMPNIL);
2364		else if (tree->code == XBC_JUMPT)
2365		    /* After executing T code */
2366		    LinkCalculateJump(com, tree, XBC_JUMP);
2367		break;
2368	    case CodeTreeJumpIf:
2369		if (tree->code != XBC_NOOP)
2370		    LinkCalculateJump(com, tree, tree->code);
2371		break;
2372	    case CodeTreeGo:
2373		/* Inconditional jump */
2374		LinkCalculateJump(com, tree, XBC_JUMP);
2375		break;
2376	    case CodeTreeReturn:
2377		/* Inconditional jump */
2378		if (tree->data.tree != tree)
2379		    /* If need to skip something */
2380		    LinkCalculateJump(com, tree, XBC_JUMP);
2381		break;
2382	    case CodeTreeBlock:
2383		LinkFixupJumps(com, tree->data.block->tree);
2384		break;
2385	    case CodeTreeJump:
2386		if (tree->code != XBC_NOOP)
2387		    LinkCalculateJump(com, tree, tree->code);
2388	}
2389    }
2390}
2391
2392static void
2393LinkBuildTableSymbol(LispCom *com, LispAtom *symbol)
2394{
2395    if (BuildTablePointer(symbol, (void***)&com->table.symbols,
2396			  &com->table.num_symbols) > 0xff) {
2397	COMPILE_FAILURE("more than 256 symbols");
2398    }
2399}
2400
2401static void
2402LinkBuildTableConstant(LispCom *com, LispObj *constant)
2403{
2404    if (BuildTablePointer(constant, (void***)&com->table.constants,
2405			  &com->table.num_constants) > 0xff) {
2406	COMPILE_FAILURE("more than 256 constants");
2407    }
2408}
2409
2410static void
2411LinkBuildTableBuiltin(LispCom *com, LispBuiltin *builtin)
2412{
2413    if (BuildTablePointer(builtin, (void***)&com->table.builtins,
2414			  &com->table.num_builtins) > 0xff) {
2415	COMPILE_FAILURE("more than 256 functions");
2416    }
2417}
2418
2419static void
2420LinkBuildTableBytecode(LispCom *com, LispObj *bytecode)
2421{
2422    if (BuildTablePointer(bytecode, (void***)&com->table.bytecodes,
2423			  &com->table.num_bytecodes) > 0xff) {
2424	COMPILE_FAILURE("more than 256 bytecode functions");
2425    }
2426}
2427
2428static void
2429LinkBuildTables(LispCom *com, CodeBlock *block)
2430{
2431    CodeTree *tree;
2432
2433    for (tree = block->tree; tree; tree = tree->next) {
2434	switch (tree->type) {
2435	    case CodeTreeBytecode:
2436		switch (tree->code) {
2437		    case XBC_LET:
2438		    case XBC_LETX:
2439		    case XBC_LET_NIL:
2440		    case XBC_LETX_NIL:
2441		    case XBC_SETSYM:
2442		    case XBC_LOADSYM:
2443		    case XBC_LOADSYM_PUSH:
2444			LinkBuildTableSymbol(com, tree->data.atom);
2445			break;
2446		    case XBC_STRUCTP:
2447		    case XBC_LOADCON:
2448		    case XBC_LOADCON_PUSH:
2449			LinkBuildTableConstant(com, tree->data.object);
2450			break;
2451		    case XBC_LOADCON_SET:
2452			LinkBuildTableConstant(com, tree->data.load_con_set.object);
2453			break;
2454		    case XBC_CALL:
2455		    case XBC_CALL_SET:
2456			LinkBuildTableBuiltin(com, tree->data.builtin.builtin);
2457			break;
2458		    case XBC_BYTECALL:
2459			LinkBuildTableBytecode(com, tree->data.bytecall.code);
2460			break;
2461		    case XBC_LOAD_LET:
2462		    case XBC_LOAD_LETX:
2463			LinkBuildTableSymbol(com, tree->data.let.name);
2464			break;
2465		    case XBC_STRUCT:
2466			LinkBuildTableConstant(com, tree->data.struc.definition);
2467			break;
2468		    case XBC_LOADSYM_LET:
2469		    case XBC_LOADSYM_LETX:
2470			LinkBuildTableSymbol(com, tree->data.let_sym.symbol);
2471			LinkBuildTableSymbol(com, tree->data.let_sym.name);
2472			break;
2473		    case XBC_LOADCON_LET:
2474		    case XBC_LOADCON_LETX:
2475			LinkBuildTableConstant(com, tree->data.let_con.object);
2476			LinkBuildTableSymbol(com, tree->data.let_con.name);
2477			break;
2478		    case XBC_CCONS:
2479		    case XBC_FUNCALL:
2480			LinkBuildTableConstant(com, tree->data.cons.car);
2481			LinkBuildTableConstant(com, tree->data.cons.cdr);
2482			break;
2483		    default:
2484			break;
2485		}
2486		break;
2487	    case CodeTreeBlock:
2488		LinkBuildTables(com, tree->data.block);
2489		break;
2490	    default:
2491		break;
2492	}
2493    }
2494}
2495
2496static long
2497LinkEmmitBytecode(LispCom *com, CodeTree *tree,
2498		  unsigned char *bytecode, long offset)
2499{
2500    short i;
2501
2502    for (; tree; tree = tree->next) {
2503	/* Fill padding */
2504	while (offset < tree->offset)
2505	    bytecode[offset++] = XBC_NOOP;
2506
2507	switch (tree->type) {
2508	    case CodeTreeBytecode:
2509		bytecode[offset++] = tree->code;
2510		switch (tree->code) {
2511		    /* Noop should not enter the CodeTree */
2512		    case XBC_NOOP:
2513			INTERNAL_ERROR(__LINE__);
2514			break;
2515
2516		    /* byte */
2517		    case XBC_BCONS:
2518		    case XBC_BCONS1:
2519		    case XBC_BCONS2:
2520		    case XBC_BCONS3:
2521		    case XBC_BCONS4:
2522		    case XBC_BCONS5:
2523		    case XBC_BCONS6:
2524		    case XBC_BCONS7:
2525		    case XBC_INV:
2526		    case XBC_NIL:
2527		    case XBC_T:
2528		    case XBC_PUSH_NIL:
2529		    case XBC_PUSH_UNSPEC:
2530		    case XBC_PUSH_T:
2531		    case XBC_CAR_PUSH:
2532		    case XBC_CDR_PUSH:
2533		    case XBC_PUSH:
2534		    case XBC_LSTAR:
2535		    case XBC_LCONS:
2536		    case XBC_LFINI:
2537		    case XBC_RETURN:
2538		    case XBC_CSTAR:
2539		    case XBC_CFINI:
2540		    case XBC_CAR:
2541		    case XBC_CDR:
2542		    case XBC_RPLACA:
2543		    case XBC_RPLACD:
2544		    case XBC_EQ:
2545		    case XBC_EQL:
2546		    case XBC_EQUAL:
2547		    case XBC_EQUALP:
2548		    case XBC_LENGTH:
2549		    case XBC_LAST:
2550		    case XBC_NTHCDR:
2551			break;
2552
2553		    /* byte + byte */
2554		    case XBC_LETREC:
2555		    case XBC_PRED:
2556		    case XBC_PUSH_NIL_N:
2557		    case XBC_PUSH_UNSPEC_N:
2558			bytecode[offset++] = tree->data.signed_char;
2559			break;
2560
2561		    /* byte + byte */
2562		    case XBC_CAR_SET:
2563		    case XBC_CDR_SET:
2564		    case XBC_SET:
2565		    case XBC_SET_NIL:
2566		    case XBC_LETBIND:
2567		    case XBC_UNLET:
2568		    case XBC_LOAD_PUSH:
2569		    case XBC_LOAD:
2570		    case XBC_LOAD_CAR:
2571		    case XBC_LOAD_CDR:
2572		    case XBC_LOAD_CAR_STORE:
2573		    case XBC_LOAD_CDR_STORE:
2574			bytecode[offset++] = tree->data.signed_short;
2575			break;
2576
2577		    /* byte + byte + byte */
2578		    case XBC_LOAD_SET:
2579		    case XBC_LOAD_CAR_SET:
2580		    case XBC_LOAD_CDR_SET:
2581			bytecode[offset++] = tree->data.load_set.load;
2582			bytecode[offset++] = tree->data.load_set.set;
2583			break;
2584
2585		    /* byte + short */
2586		    case XBC_JUMP:
2587		    case XBC_JUMPT:
2588		    case XBC_JUMPNIL:
2589			*(short*)(bytecode + offset) = tree->data.signed_int;
2590			offset += sizeof(short);
2591			break;
2592
2593		    /* byte + byte */
2594		    case XBC_LET:
2595		    case XBC_LETX:
2596		    case XBC_LET_NIL:
2597		    case XBC_LETX_NIL:
2598		    case XBC_SETSYM:
2599		    case XBC_LOADSYM:
2600		    case XBC_LOADSYM_PUSH:
2601			i = FindIndex(tree->data.atom,
2602				      (void**)com->table.symbols,
2603				      com->table.num_symbols);
2604			bytecode[offset++] = i;
2605			break;
2606
2607		    /* byte + byte */
2608		    case XBC_STRUCTP:
2609		    case XBC_LOADCON:
2610		    case XBC_LOADCON_PUSH:
2611			i = FindIndex(tree->data.object,
2612				      (void**)com->table.constants,
2613				      com->table.num_constants);
2614			bytecode[offset++] = i;
2615			break;
2616
2617		    /* byte + byte + byte */
2618		    case XBC_LOADCON_SET:
2619			i = FindIndex(tree->data.load_con_set.object,
2620				      (void**)com->table.constants,
2621				      com->table.num_constants);
2622			bytecode[offset++] = i;
2623			bytecode[offset++] = tree->data.load_con_set.offset;
2624			break;
2625
2626		    /* byte + byte + byte */
2627		    case XBC_CALL:
2628			bytecode[offset++] = tree->data.builtin.num_arguments;
2629			i = FindIndex(tree->data.builtin.builtin,
2630				      (void**)com->table.builtins,
2631				      com->table.num_builtins);
2632			bytecode[offset++] = i;
2633			break;
2634
2635		    /* byte + byte + byte */
2636		    case XBC_BYTECALL:
2637			bytecode[offset++] = tree->data.bytecall.num_arguments;
2638			i = FindIndex(tree->data.bytecall.code,
2639				      (void**)com->table.bytecodes,
2640				      com->table.num_bytecodes);
2641			bytecode[offset++] = i;
2642			break;
2643
2644		    /* byte + byte + byte + byte */
2645		    case XBC_CALL_SET:
2646			bytecode[offset++] = tree->data.builtin.num_arguments;
2647			i = FindIndex(tree->data.builtin.builtin,
2648				      (void**)com->table.builtins,
2649				      com->table.num_builtins);
2650			bytecode[offset++] = i;
2651			bytecode[offset++] = tree->data.builtin.offset;
2652			break;
2653
2654		    /* byte + byte + byte */
2655		    case XBC_LOAD_LET:
2656		    case XBC_LOAD_LETX:
2657			bytecode[offset++] = tree->data.let.offset;
2658			i = FindIndex(tree->data.let.name,
2659				      (void**)com->table.symbols,
2660				      com->table.num_symbols);
2661			bytecode[offset++] = i;
2662			break;
2663
2664		    /* byte + byte + byte */
2665		    case XBC_STRUCT:
2666			bytecode[offset++] = tree->data.struc.offset;
2667			i = FindIndex(tree->data.struc.definition,
2668				      (void**)com->table.constants,
2669				      com->table.num_constants);
2670			bytecode[offset++] = i;
2671			break;
2672
2673		    /* byte + byte + byte */
2674		    case XBC_LOADSYM_LET:
2675		    case XBC_LOADSYM_LETX:
2676			i = FindIndex(tree->data.let_sym.symbol,
2677				      (void**)com->table.symbols,
2678				      com->table.num_symbols);
2679			bytecode[offset++] = i;
2680			i = FindIndex(tree->data.let_sym.name,
2681				      (void**)com->table.symbols,
2682				      com->table.num_symbols);
2683			bytecode[offset++] = i;
2684			break;
2685
2686		    /* byte + byte + byte */
2687		    case XBC_LOADCON_LET:
2688		    case XBC_LOADCON_LETX:
2689			i = FindIndex(tree->data.let_con.object,
2690				      (void**)com->table.constants,
2691				      com->table.num_constants);
2692			bytecode[offset++] = i;
2693			i = FindIndex(tree->data.let_con.name,
2694				      (void**)com->table.symbols,
2695				      com->table.num_symbols);
2696			bytecode[offset++] = i;
2697			break;
2698
2699		    /* byte + byte + byte */
2700		    case XBC_CCONS:
2701		    case XBC_FUNCALL:
2702			i = FindIndex(tree->data.cons.car,
2703				      (void**)com->table.constants,
2704				      com->table.num_constants);
2705			bytecode[offset++] = i;
2706			i = FindIndex(tree->data.cons.cdr,
2707				      (void**)com->table.constants,
2708				      com->table.num_constants);
2709			bytecode[offset++] = i;
2710			break;
2711		}
2712		break;
2713	    case CodeTreeLabel:
2714		/* Labels are not loaded */
2715		break;
2716	    case CodeTreeCond:
2717	    case CodeTreeJump:
2718	    case CodeTreeJumpIf:
2719		if (tree->code != XBC_NOOP)
2720		    INTERNAL_ERROR(__LINE__);
2721		break;
2722	    case CodeTreeGo:
2723		INTERNAL_ERROR(__LINE__);
2724		break;
2725	    case CodeTreeReturn:
2726		if (tree->data.tree != tree)
2727		    INTERNAL_ERROR(__LINE__);
2728		break;
2729	    case CodeTreeBlock:
2730		offset = LinkEmmitBytecode(com, tree->data.block->tree,
2731					   bytecode, offset);
2732		break;
2733	}
2734    }
2735
2736    return (offset);
2737}
2738
2739static void
2740LinkBytecode(LispCom *com)
2741{
2742    long offset, count;
2743    unsigned char **codes;
2744    LispObj **names;
2745
2746    /* Close bytecode */
2747    com_Bytecode(com, XBC_RETURN);
2748
2749    /* The only usage of this information for now, and still may generate
2750     * false positives because arguments to unamed functions are not being
2751     * parsed as well as arguments to yet undefined function/maros.
2752     * XXX should also add declaim/declare to let the code specify that
2753     * the argument is unused */
2754    LinkWarnUnused(com, com->block);
2755
2756    /* First level optimization */
2757    LinkOptimize_0(com);
2758
2759    /* Resolve tagbody labels */
2760    LinkResolveLabels(com, com->block);
2761
2762    /* Resolve any pending jumps */
2763    LinkResolveJumps(com, com->block);
2764
2765    /* Calculate unpadded offsets */
2766    LinkBuildOffsets(com, com->block->tree, 0);
2767
2768    /* Do padding for aligned memory reads */
2769    LinkFixupOffsets(com, com->block->tree, 0);
2770
2771    /* Jumps normally are to a node that does not generate code,
2772     * and due to padding, the jump may go to a address with a
2773     * XBC_NOOP, so adjust the jump to the next useful opcode. */
2774    LinkSkipPadding(com, com->block->tree);
2775
2776    /* Now addresses are known */
2777    LinkFixupJumps(com, com->block->tree);
2778
2779    /* Build symbol, constant and builtin tables */
2780    LinkBuildTables(com, com->block);
2781
2782    /* Stack info */
2783    com->length = sizeof(short) * 3;
2784    /* Tables info */
2785    com->length += sizeof(short) * 4;
2786    com->length += com->table.num_constants * sizeof(LispObj*);
2787    com->length += com->table.num_symbols * sizeof(LispAtom*);
2788    com->length += com->table.num_builtins * sizeof(LispBuiltin*);
2789    com->length += com->table.num_bytecodes * sizeof(unsigned char*);
2790    com->length += com->table.num_bytecodes * sizeof(LispObj*);
2791
2792    /* Allocate space for the bytecode stream */
2793    com->length += com->block->tail->offset + 1;
2794    com->bytecode = LispMalloc(com->length);
2795
2796    /* Add header */
2797    offset = 0;
2798    *(short*)(com->bytecode + offset) = com->stack.stack;
2799    offset += sizeof(short);
2800    *(short*)(com->bytecode + offset) = com->stack.bstack;
2801    offset += sizeof(short);
2802    *(short*)(com->bytecode + offset) = com->stack.pstack;
2803    offset += sizeof(short);
2804
2805    *(short*)(com->bytecode + offset) = com->table.num_constants;
2806    offset += sizeof(short);
2807    *(short*)(com->bytecode + offset) = com->table.num_symbols;
2808    offset += sizeof(short);
2809    *(short*)(com->bytecode + offset) = com->table.num_builtins;
2810    offset += sizeof(short);
2811    *(short*)(com->bytecode + offset) = com->table.num_bytecodes;
2812    offset += sizeof(short);
2813
2814    count = sizeof(LispObj*) * com->table.num_constants;
2815    memcpy(com->bytecode + offset, com->table.constants, count);
2816    offset += count;
2817    count = sizeof(LispAtom*) * com->table.num_symbols;
2818    memcpy(com->bytecode + offset, com->table.symbols, count);
2819    offset += count;
2820    count = sizeof(LispBuiltin*) * com->table.num_builtins;
2821    memcpy(com->bytecode + offset, com->table.builtins, count);
2822    offset += count;
2823
2824    /* Store bytecode information */
2825    for (count = 0, codes = (unsigned char**)(com->bytecode + offset);
2826	 count < com->table.num_bytecodes; count++, codes++)
2827	*codes = com->table.bytecodes[count]->data.bytecode.bytecode->code;
2828    offset += com->table.num_bytecodes * sizeof(unsigned char*);
2829    /* Store names, only useful for disassemble but may also be used
2830     * to check if a function was redefined, and the bytecode is referencing
2831     * the older version, the current version can be checked looking at
2832     * <name>->data.atom */
2833    for (count = 0, names = (LispObj**)(com->bytecode + offset);
2834	 count < com->table.num_bytecodes; count++, names++)
2835	*names = com->table.bytecodes[count]->data.bytecode.name;
2836    offset += com->table.num_bytecodes * sizeof(LispObj*);
2837
2838    /* Generate it */
2839    LinkEmmitBytecode(com, com->block->tree, com->bytecode + offset, 0);
2840}
2841
2842static LispObj *
2843ExecuteBytecode(register unsigned char *stream)
2844{
2845    register LispObj *reg0;
2846    register LispAtom *atom;
2847    register short offset;
2848    LispObj *reg1;
2849    LispBuiltin *builtin;
2850    LispObj *lambda;
2851    LispObj *arguments;
2852    unsigned char *bytecode;
2853
2854    LispObj **constants;
2855    LispAtom **symbols;
2856    LispBuiltin **builtins;
2857    unsigned char **codes;
2858    short num_constants, num_symbols, num_builtins, num_codes;
2859
2860    int lex, len;
2861
2862    /* To control gc protected slots */
2863    int phead, pbase;
2864
2865    long fixnum = 0;
2866
2867#if defined(__GNUC__) && !defined(ANSI_SOURCE)
2868#define ALLOW_GOTO_ADDRESS
2869#endif
2870
2871#ifdef ALLOW_GOTO_ADDRESS
2872#define JUMP_ADDRESS(label)	&&label
2873    static const void *opcode_labels[] = {
2874	JUMP_ADDRESS(XBC_NOOP),
2875	JUMP_ADDRESS(XBC_INV),
2876	JUMP_ADDRESS(XBC_NIL),
2877	JUMP_ADDRESS(XBC_T),
2878	JUMP_ADDRESS(XBC_PRED),
2879	JUMP_ADDRESS(XBC_CAR),
2880	JUMP_ADDRESS(XBC_CDR),
2881	JUMP_ADDRESS(XBC_CAR_SET),
2882	JUMP_ADDRESS(XBC_CDR_SET),
2883	JUMP_ADDRESS(XBC_RPLACA),
2884	JUMP_ADDRESS(XBC_RPLACD),
2885	JUMP_ADDRESS(XBC_EQ),
2886	JUMP_ADDRESS(XBC_EQL),
2887	JUMP_ADDRESS(XBC_EQUAL),
2888	JUMP_ADDRESS(XBC_EQUALP),
2889	JUMP_ADDRESS(XBC_LENGTH),
2890	JUMP_ADDRESS(XBC_LAST),
2891	JUMP_ADDRESS(XBC_NTHCDR),
2892	JUMP_ADDRESS(XBC_CAR_PUSH),
2893	JUMP_ADDRESS(XBC_CDR_PUSH),
2894	JUMP_ADDRESS(XBC_PUSH),
2895	JUMP_ADDRESS(XBC_PUSH_NIL),
2896	JUMP_ADDRESS(XBC_PUSH_UNSPEC),
2897	JUMP_ADDRESS(XBC_PUSH_T),
2898	JUMP_ADDRESS(XBC_PUSH_NIL_N),
2899	JUMP_ADDRESS(XBC_PUSH_UNSPEC_N),
2900	JUMP_ADDRESS(XBC_LET),
2901	JUMP_ADDRESS(XBC_LETX),
2902	JUMP_ADDRESS(XBC_LET_NIL),
2903	JUMP_ADDRESS(XBC_LETX_NIL),
2904	JUMP_ADDRESS(XBC_LETBIND),
2905	JUMP_ADDRESS(XBC_UNLET),
2906	JUMP_ADDRESS(XBC_LOAD),
2907	JUMP_ADDRESS(XBC_LOAD_LET),
2908	JUMP_ADDRESS(XBC_LOAD_LETX),
2909	JUMP_ADDRESS(XBC_LOAD_PUSH),
2910	JUMP_ADDRESS(XBC_LOADCON),
2911	JUMP_ADDRESS(XBC_LOADCON_LET),
2912	JUMP_ADDRESS(XBC_LOADCON_LETX),
2913	JUMP_ADDRESS(XBC_LOADCON_PUSH),
2914	JUMP_ADDRESS(XBC_LOAD_CAR),
2915	JUMP_ADDRESS(XBC_LOAD_CDR),
2916	JUMP_ADDRESS(XBC_LOAD_CAR_STORE),
2917	JUMP_ADDRESS(XBC_LOAD_CDR_STORE),
2918	JUMP_ADDRESS(XBC_LOADCON_SET),
2919	JUMP_ADDRESS(XBC_LOADSYM),
2920	JUMP_ADDRESS(XBC_LOADSYM_LET),
2921	JUMP_ADDRESS(XBC_LOADSYM_LETX),
2922	JUMP_ADDRESS(XBC_LOADSYM_PUSH),
2923	JUMP_ADDRESS(XBC_LOAD_SET),
2924	JUMP_ADDRESS(XBC_LOAD_CAR_SET),
2925	JUMP_ADDRESS(XBC_LOAD_CDR_SET),
2926	JUMP_ADDRESS(XBC_SET),
2927	JUMP_ADDRESS(XBC_SETSYM),
2928	JUMP_ADDRESS(XBC_SET_NIL),
2929	JUMP_ADDRESS(XBC_CALL),
2930	JUMP_ADDRESS(XBC_CALL_SET),
2931	JUMP_ADDRESS(XBC_BYTECALL),
2932	JUMP_ADDRESS(XBC_FUNCALL),
2933	JUMP_ADDRESS(XBC_LETREC),
2934	JUMP_ADDRESS(XBC_BCONS),
2935	JUMP_ADDRESS(XBC_BCONS1),
2936	JUMP_ADDRESS(XBC_BCONS2),
2937	JUMP_ADDRESS(XBC_BCONS3),
2938	JUMP_ADDRESS(XBC_BCONS4),
2939	JUMP_ADDRESS(XBC_BCONS5),
2940	JUMP_ADDRESS(XBC_BCONS6),
2941	JUMP_ADDRESS(XBC_BCONS7),
2942	JUMP_ADDRESS(XBC_CCONS),
2943	JUMP_ADDRESS(XBC_CSTAR),
2944	JUMP_ADDRESS(XBC_CFINI),
2945	JUMP_ADDRESS(XBC_LSTAR),
2946	JUMP_ADDRESS(XBC_LCONS),
2947	JUMP_ADDRESS(XBC_LFINI),
2948	JUMP_ADDRESS(XBC_JUMP),
2949	JUMP_ADDRESS(XBC_JUMPT),
2950	JUMP_ADDRESS(XBC_JUMPNIL),
2951	JUMP_ADDRESS(XBC_STRUCT),
2952	JUMP_ADDRESS(XBC_STRUCTP),
2953	JUMP_ADDRESS(XBC_RETURN)
2954    };
2955    static const void *predicate_opcode_labels[] = {
2956	JUMP_ADDRESS(XBP_CONSP),
2957	JUMP_ADDRESS(XBP_LISTP),
2958	JUMP_ADDRESS(XBP_NUMBERP)
2959    };
2960#endif
2961
2962    reg0 = NIL;
2963
2964    bytecode = stream;
2965    pbase = lisp__data.protect.length;
2966
2967    /* stack */
2968    offset = *(short*)stream;
2969    stream += sizeof(short);
2970    if (lisp__data.env.length + offset > lisp__data.env.space) {
2971	do
2972	    LispMoreEnvironment();
2973	while (lisp__data.env.length + offset >= lisp__data.env.space);
2974    }
2975    /* builtin stack */
2976    offset = *(short*)stream;
2977    stream += sizeof(short);
2978    if (lisp__data.stack.length + offset >= lisp__data.stack.space) {
2979	do
2980	    LispMoreStack();
2981	while (lisp__data.stack.length + offset >= lisp__data.stack.space);
2982    }
2983    /* protect stack */
2984    phead = *(short*)stream;
2985    stream += sizeof(short);
2986    if (lisp__data.protect.length + phead > lisp__data.protect.space) {
2987	do
2988	    LispMoreProtects();
2989	while (lisp__data.protect.length + phead >= lisp__data.protect.space);
2990    }
2991
2992    num_constants = *(short*)stream;
2993    stream += sizeof(short);
2994    num_symbols = *(short*)stream;
2995    stream += sizeof(short);
2996    num_builtins = *(short*)stream;
2997    stream += sizeof(short);
2998    num_codes = *(short*)stream;
2999    stream += sizeof(short);
3000
3001    constants = (LispObj**)stream;
3002    stream += num_constants * sizeof(LispObj*);
3003    symbols = (LispAtom**)stream;
3004    stream += num_symbols * sizeof(LispAtom*);
3005    builtins = (LispBuiltin**)stream;
3006    stream += num_builtins * sizeof(LispBuiltin*);
3007    codes = (unsigned char**)stream;
3008    stream += num_codes * (sizeof(unsigned char*) + sizeof(LispObj*));
3009
3010    for (; phead > 0; phead--)
3011	lisp__data.protect.objects[lisp__data.protect.length++] = NIL;
3012    phead = pbase;
3013
3014#ifdef ALLOW_GOTO_ADDRESS
3015#define OPCODE_LABEL(label)	label
3016#define NEXT_OPCODE()		goto *opcode_labels[*stream++]
3017#define GOTO_PREDICATE()	goto *predicate_opcode_labels[*stream++]
3018#else
3019#define OPCODE_LABEL(label)	case label
3020#define NEXT_OPCODE()		goto next_opcode
3021#define GOTO_PREDICATE()	goto predicate_label
3022    for (;;) {
3023next_opcode:
3024	switch (*stream++) {
3025#endif	/* ALLOW_GOTO_ADDRESS */
3026
3027OPCODE_LABEL(XBC_NOOP):
3028	NEXT_OPCODE();
3029
3030OPCODE_LABEL(XBC_PRED):
3031	GOTO_PREDICATE();
3032
3033OPCODE_LABEL(XBC_INV):
3034	reg0 = reg0 == NIL ? T : NIL;
3035	NEXT_OPCODE();
3036
3037OPCODE_LABEL(XBC_NIL):
3038	reg0 = NIL;
3039	NEXT_OPCODE();
3040
3041OPCODE_LABEL(XBC_T):
3042	reg0 = T;
3043	NEXT_OPCODE();
3044
3045OPCODE_LABEL(XBC_CAR):
3046car:
3047	if (reg0 != NIL) {
3048	    if (!CONSP(reg0))
3049		LispDestroy("CAR: %s is not a list", STROBJ(reg0));
3050	    reg0 = CAR(reg0);
3051	}
3052	NEXT_OPCODE();
3053
3054OPCODE_LABEL(XBC_CDR):
3055cdr:
3056	if (reg0 != NIL) {
3057	    if (!CONSP(reg0))
3058		LispDestroy("CDR: %s is not a list", STROBJ(reg0));
3059	    reg0 = CDR(reg0);
3060	}
3061	NEXT_OPCODE();
3062
3063OPCODE_LABEL(XBC_RPLACA):
3064	reg1 = lisp__data.stack.values[--lisp__data.stack.length];
3065	if (!CONSP(reg1))
3066	    LispDestroy("RPLACA: %s is not a cons", STROBJ(reg1));
3067	RPLACA(reg1, reg0);
3068	reg0 = reg1;
3069	NEXT_OPCODE();
3070
3071OPCODE_LABEL(XBC_RPLACD):
3072	reg1 = lisp__data.stack.values[--lisp__data.stack.length];
3073	if (!CONSP(reg1))
3074	    LispDestroy("RPLACD: %s is not a cons", STROBJ(reg1));
3075	RPLACD(reg1, reg0);
3076	reg0 = reg1;
3077	NEXT_OPCODE();
3078
3079OPCODE_LABEL(XBC_BCONS):
3080	CAR(cons) = reg0;
3081	lisp__data.stack.values[lisp__data.stack.length++] = cons;
3082	NEXT_OPCODE();
3083
3084OPCODE_LABEL(XBC_BCONS1):
3085	offset = lisp__data.stack.length - 1;
3086	CAR(cons) = reg0;
3087	CAR(cons1) = lisp__data.stack.values[offset];
3088	lisp__data.stack.values[offset] = cons1;
3089	NEXT_OPCODE();
3090
3091OPCODE_LABEL(XBC_BCONS2):
3092	offset = lisp__data.stack.length;
3093	CAR(cons) = reg0;
3094	CAR(cons1) = lisp__data.stack.values[--offset];
3095	CAR(cons2) = lisp__data.stack.values[--offset];
3096	lisp__data.stack.values[offset] = cons2;
3097	lisp__data.stack.length = offset + 1;
3098	NEXT_OPCODE();
3099
3100OPCODE_LABEL(XBC_BCONS3):
3101	offset = lisp__data.stack.length;
3102	CAR(cons) = reg0;
3103	CAR(cons1) = lisp__data.stack.values[--offset];
3104	CAR(cons2) = lisp__data.stack.values[--offset];
3105	CAR(cons3) = lisp__data.stack.values[--offset];
3106	lisp__data.stack.values[offset] = cons3;
3107	lisp__data.stack.length = offset + 1;
3108	NEXT_OPCODE();
3109
3110OPCODE_LABEL(XBC_BCONS4):
3111	offset = lisp__data.stack.length;
3112	CAR(cons) = reg0;
3113	CAR(cons1) = lisp__data.stack.values[--offset];
3114	CAR(cons2) = lisp__data.stack.values[--offset];
3115	CAR(cons3) = lisp__data.stack.values[--offset];
3116	CAR(cons4) = lisp__data.stack.values[--offset];
3117	lisp__data.stack.values[offset] = cons4;
3118	lisp__data.stack.length = offset + 1;
3119	NEXT_OPCODE();
3120
3121OPCODE_LABEL(XBC_BCONS5):
3122	offset = lisp__data.stack.length;
3123	CAR(cons) = reg0;
3124	CAR(cons1) = lisp__data.stack.values[--offset];
3125	CAR(cons2) = lisp__data.stack.values[--offset];
3126	CAR(cons3) = lisp__data.stack.values[--offset];
3127	CAR(cons4) = lisp__data.stack.values[--offset];
3128	CAR(cons5) = lisp__data.stack.values[--offset];
3129	lisp__data.stack.values[offset] = cons5;
3130	lisp__data.stack.length = offset + 1;
3131	NEXT_OPCODE();
3132
3133OPCODE_LABEL(XBC_BCONS6):
3134	offset = lisp__data.stack.length;
3135	CAR(cons) = reg0;
3136	CAR(cons1) = lisp__data.stack.values[--offset];
3137	CAR(cons2) = lisp__data.stack.values[--offset];
3138	CAR(cons3) = lisp__data.stack.values[--offset];
3139	CAR(cons4) = lisp__data.stack.values[--offset];
3140	CAR(cons5) = lisp__data.stack.values[--offset];
3141	CAR(cons6) = lisp__data.stack.values[--offset];
3142	lisp__data.stack.values[offset] = cons6;
3143	lisp__data.stack.length = offset + 1;
3144	NEXT_OPCODE();
3145
3146OPCODE_LABEL(XBC_BCONS7):
3147	offset = lisp__data.stack.length;
3148	CAR(cons) = reg0;
3149	CAR(cons1) = lisp__data.stack.values[--offset];
3150	CAR(cons2) = lisp__data.stack.values[--offset];
3151	CAR(cons3) = lisp__data.stack.values[--offset];
3152	CAR(cons4) = lisp__data.stack.values[--offset];
3153	CAR(cons5) = lisp__data.stack.values[--offset];
3154	CAR(cons6) = lisp__data.stack.values[--offset];
3155	CAR(cons7) = lisp__data.stack.values[--offset];
3156	lisp__data.stack.values[offset] = cons7;
3157	lisp__data.stack.length = offset + 1;
3158	NEXT_OPCODE();
3159
3160OPCODE_LABEL(XBC_EQ):
3161	reg0 = reg0 == lisp__data.stack.values[--lisp__data.stack.length] ? T : NIL;
3162	NEXT_OPCODE();
3163
3164OPCODE_LABEL(XBC_EQL):
3165	reg1 = lisp__data.stack.values[--lisp__data.stack.length];
3166	reg0 = XEQL(reg1, reg0);
3167	NEXT_OPCODE();
3168
3169OPCODE_LABEL(XBC_EQUAL):
3170	reg1 = lisp__data.stack.values[--lisp__data.stack.length];
3171	reg0 = XEQUAL(reg1, reg0);
3172	NEXT_OPCODE();
3173
3174OPCODE_LABEL(XBC_EQUALP):
3175	reg1 = lisp__data.stack.values[--lisp__data.stack.length];
3176	reg0 = XEQUALP(reg1, reg0);
3177	NEXT_OPCODE();
3178
3179OPCODE_LABEL(XBC_LENGTH):
3180	reg0 = FIXNUM(LispLength(reg0));
3181	NEXT_OPCODE();
3182
3183OPCODE_LABEL(XBC_LAST):
3184    {
3185	long length;
3186
3187	reg1 = lisp__data.stack.values[--lisp__data.stack.length];
3188	if (CONSP(reg1)) {
3189	    if (reg0 != NIL) {
3190		if (!FIXNUMP(reg0) || (fixnum = FIXNUM_VALUE(reg0)) < 0)
3191		    LispDestroy("LAST: %s is not a positive fixnum",
3192				STROBJ(reg0));
3193	    }
3194	    else
3195		fixnum = 1;
3196	    reg0 = reg1;
3197	    for (reg0 = reg1, length = 0;
3198		 CONSP(reg0);
3199		 reg0 = CDR(reg0), length++)
3200		;
3201	    for (length -= fixnum, reg0 = reg1; length > 0; length--)
3202		reg0 = CDR(reg0);
3203	}
3204	else
3205	    reg0 = reg1;
3206    }	NEXT_OPCODE();
3207
3208OPCODE_LABEL(XBC_NTHCDR):
3209	reg1 = lisp__data.stack.values[--lisp__data.stack.length];
3210	if (!FIXNUMP(reg1) || (fixnum = FIXNUM_VALUE(reg1)) < 0)
3211	    LispDestroy("NTHCDR: %s is not a positive fixnum",
3212			STROBJ(reg1));
3213	if (reg0 != NIL) {
3214	    if (!CONSP(reg0))
3215		LispDestroy("NTHCDR: %s is not a list", STROBJ(reg0));
3216	    for (; fixnum > 0; fixnum--) {
3217		if (!CONSP(reg0))
3218		    break;
3219		reg0 = CDR(reg0);
3220	    }
3221	}
3222	NEXT_OPCODE();
3223
3224	/* Push to builtin stack */
3225OPCODE_LABEL(XBC_CAR_PUSH):
3226	if (reg0 != NIL) {
3227	    if (!CONSP(reg0))
3228		LispDestroy("CAR: %s is not a list", STROBJ(reg0));
3229	    reg0 = CAR(reg0);
3230	}
3231	goto push_builtin;
3232
3233OPCODE_LABEL(XBC_CDR_PUSH):
3234	if (reg0 != NIL) {
3235	    if (!CONSP(reg0))
3236		LispDestroy("CDR: %s is not a list", STROBJ(reg0));
3237	    reg0 = CDR(reg0);
3238	}
3239	/*FALLTROUGH*/
3240
3241OPCODE_LABEL(XBC_PUSH):
3242push_builtin:
3243	lisp__data.stack.values[lisp__data.stack.length++] = reg0;
3244	NEXT_OPCODE();
3245
3246OPCODE_LABEL(XBC_PUSH_NIL):
3247	lisp__data.stack.values[lisp__data.stack.length++] = NIL;
3248	NEXT_OPCODE();
3249
3250OPCODE_LABEL(XBC_PUSH_UNSPEC):
3251	lisp__data.stack.values[lisp__data.stack.length++] = UNSPEC;
3252	NEXT_OPCODE();
3253
3254OPCODE_LABEL(XBC_PUSH_T):
3255	lisp__data.stack.values[lisp__data.stack.length++] = T;
3256	NEXT_OPCODE();
3257
3258OPCODE_LABEL(XBC_PUSH_NIL_N):
3259	for (offset = *stream++; offset > 0; offset--)
3260	    lisp__data.stack.values[lisp__data.stack.length++] = NIL;
3261	NEXT_OPCODE();
3262
3263OPCODE_LABEL(XBC_PUSH_UNSPEC_N):
3264	for (offset = *stream++; offset > 0; offset--)
3265	    lisp__data.stack.values[lisp__data.stack.length++] = UNSPEC;
3266	NEXT_OPCODE();
3267
3268OPCODE_LABEL(XBC_LET):
3269let_argument:
3270	/*  The global object value is not changed, so it does not
3271	 * matter if it is a constant symbol. An error would be
3272	 * generated if it was declared as constant at the time of
3273	 * bytecode generation. Check can be done looking at the
3274	 * atom->constant field. */
3275	atom = symbols[*stream++];
3276	atom->offset = lisp__data.env.length;
3277	lisp__data.env.names[lisp__data.env.length] = atom->string;
3278	lisp__data.env.values[lisp__data.env.length++] = reg0;
3279	NEXT_OPCODE();
3280
3281OPCODE_LABEL(XBC_LETX):
3282letx_argument:
3283	atom = symbols[*stream++];
3284	atom->offset = lisp__data.env.length;
3285	lisp__data.env.names[lisp__data.env.length] = atom->string;
3286	lisp__data.env.values[lisp__data.env.length++] = reg0;
3287	lisp__data.env.head++;
3288	NEXT_OPCODE();
3289
3290OPCODE_LABEL(XBC_LET_NIL):
3291	atom = symbols[*stream++];
3292	atom->offset = lisp__data.env.length;
3293	lisp__data.env.names[lisp__data.env.length] = atom->string;
3294	lisp__data.env.values[lisp__data.env.length++] = NIL;
3295	NEXT_OPCODE();
3296
3297OPCODE_LABEL(XBC_LETX_NIL):
3298	atom = symbols[*stream++];
3299	atom->offset = lisp__data.env.length;
3300	lisp__data.env.names[lisp__data.env.length] = atom->string;
3301	lisp__data.env.values[lisp__data.env.length++] = NIL;
3302	lisp__data.env.head++;
3303	NEXT_OPCODE();
3304
3305	/* Bind locally added variables to a block */
3306OPCODE_LABEL(XBC_LETBIND):
3307	offset = *stream++;
3308	lisp__data.env.head += offset;
3309	NEXT_OPCODE();
3310
3311	/* Unbind locally added variables to a block */
3312OPCODE_LABEL(XBC_UNLET):
3313	offset = *stream++;
3314	lisp__data.env.head -= offset;
3315	lisp__data.env.length -= offset;
3316	NEXT_OPCODE();
3317
3318	/* Load value from stack */
3319OPCODE_LABEL(XBC_LOAD):
3320	offset = *stream++;
3321	reg0 = lisp__data.env.values[lisp__data.env.lex + offset];
3322	NEXT_OPCODE();
3323
3324OPCODE_LABEL(XBC_LOAD_CAR):
3325	offset = *stream++;
3326	reg0 = lisp__data.env.values[lisp__data.env.lex + offset];
3327	goto car;
3328
3329OPCODE_LABEL(XBC_LOAD_CDR):
3330	offset = *stream++;
3331	reg0 = lisp__data.env.values[lisp__data.env.lex + offset];
3332	goto cdr;
3333
3334OPCODE_LABEL(XBC_LOAD_CAR_STORE):
3335	offset = *stream++;
3336	reg0 = lisp__data.env.values[lisp__data.env.lex + offset];
3337	if (reg0 != NIL) {
3338	    if (!CONSP(reg0))
3339		LispDestroy("CAR: %s is not a list", STROBJ(reg0));
3340	    reg0 = CAR(reg0);
3341	    lisp__data.env.values[lisp__data.env.lex + offset] = reg0;
3342	}
3343	NEXT_OPCODE();
3344
3345OPCODE_LABEL(XBC_LOAD_CDR_STORE):
3346	offset = *stream++;
3347	reg0 = lisp__data.env.values[lisp__data.env.lex + offset];
3348	if (reg0 != NIL) {
3349	    if (!CONSP(reg0))
3350		LispDestroy("CDR: %s is not a list", STROBJ(reg0));
3351	    reg0 = CDR(reg0);
3352	    lisp__data.env.values[lisp__data.env.lex + offset] = reg0;
3353	}
3354	NEXT_OPCODE();
3355
3356OPCODE_LABEL(XBC_LOAD_LET):
3357	offset = *stream++;
3358	reg0 = lisp__data.env.values[lisp__data.env.lex + offset];
3359	goto let_argument;
3360
3361OPCODE_LABEL(XBC_LOAD_LETX):
3362	offset = *stream++;
3363	reg0 = lisp__data.env.values[lisp__data.env.lex + offset];
3364	goto letx_argument;
3365
3366OPCODE_LABEL(XBC_LOAD_PUSH):
3367	offset = *stream++;
3368	reg0 = lisp__data.env.values[lisp__data.env.lex + offset];
3369	lisp__data.stack.values[lisp__data.stack.length++] = reg0;
3370	NEXT_OPCODE();
3371
3372	/* Load pointer to constant */
3373OPCODE_LABEL(XBC_LOADCON):
3374	reg0 = constants[*stream++];
3375	NEXT_OPCODE();
3376
3377OPCODE_LABEL(XBC_LOADCON_LET):
3378	reg0 = constants[*stream++];
3379	goto let_argument;
3380
3381OPCODE_LABEL(XBC_LOADCON_LETX):
3382	reg0 = constants[*stream++];
3383	goto letx_argument;
3384
3385OPCODE_LABEL(XBC_LOADCON_PUSH):
3386	reg0 = constants[*stream++];
3387	lisp__data.stack.values[lisp__data.stack.length++] = reg0;
3388	NEXT_OPCODE();
3389
3390OPCODE_LABEL(XBC_LOADCON_SET):
3391	reg0 = constants[*stream++];
3392	offset = *stream++;
3393	lisp__data.env.values[lisp__data.env.lex + offset] = reg0;
3394	NEXT_OPCODE();
3395
3396	/* Change value of local variable */
3397OPCODE_LABEL(XBC_CAR_SET):
3398car_set:
3399	if (reg0 != NIL) {
3400	    if (!CONSP(reg0))
3401		LispDestroy("CAR: %s is not a list", STROBJ(reg0));
3402	    reg0 = CAR(reg0);
3403	}
3404	goto set_local_variable;
3405
3406OPCODE_LABEL(XBC_CDR_SET):
3407cdr_set:
3408	if (reg0 != NIL) {
3409	    if (!CONSP(reg0))
3410		LispDestroy("CDR: %s is not a list", STROBJ(reg0));
3411	    reg0 = CDR(reg0);
3412	}
3413	goto set_local_variable;
3414
3415OPCODE_LABEL(XBC_LOAD_CAR_SET):
3416	offset = *stream++;
3417	reg0 = lisp__data.env.values[lisp__data.env.lex + offset];
3418	goto car_set;
3419
3420OPCODE_LABEL(XBC_LOAD_CDR_SET):
3421	offset = *stream++;
3422	reg0 = lisp__data.env.values[lisp__data.env.lex + offset];
3423	goto cdr_set;
3424
3425OPCODE_LABEL(XBC_LOAD_SET):
3426	offset = *stream++;
3427	reg0 = lisp__data.env.values[lisp__data.env.lex + offset];
3428	/*FALLTROUGH*/
3429
3430OPCODE_LABEL(XBC_SET):
3431set_local_variable:
3432	offset = *stream++;
3433	lisp__data.env.values[lisp__data.env.lex + offset] = reg0;
3434	NEXT_OPCODE();
3435
3436OPCODE_LABEL(XBC_SET_NIL):
3437	offset = *stream++;
3438	lisp__data.env.values[lisp__data.env.lex + offset] = NIL;
3439	NEXT_OPCODE();
3440
3441	/* Change value of a global/special variable */
3442OPCODE_LABEL(XBC_SETSYM):
3443	    atom = symbols[*stream++];
3444	    if (atom->dyn) {
3445		/*  atom->dyn and atom->constant are exclusive, no
3446		 * need to check if variable declared as constant. */
3447		if (atom->offset < lisp__data.env.head &&
3448		    lisp__data.env.names[atom->offset] == atom->string)
3449		    lisp__data.env.values[atom->offset] = reg0;
3450		else {
3451		    if (atom->watch)
3452			LispSetAtomObjectProperty(atom, reg0);
3453		    else
3454			SETVALUE(atom, reg0);
3455		}
3456	    }
3457	    else if (atom->a_object) {
3458		if (atom->constant)
3459		    LispDestroy("EVAL: %s is a constant",
3460				STROBJ(atom->object));
3461		else if (atom->watch)
3462		    LispSetAtomObjectProperty(atom, reg0);
3463		else
3464		    SETVALUE(atom, reg0);
3465	    }
3466	    else {
3467		/* Create new global variable */
3468		LispPackage *pack;
3469
3470		LispWarning("the variable %s was not declared",
3471			    atom->string);
3472		LispSetAtomObjectProperty(atom, reg0);
3473		pack = atom->package->data.package.package;
3474		if (pack->glb.length >= pack->glb.space)
3475		    LispMoreGlobals(pack);
3476		pack->glb.pairs[pack->glb.length++] = atom->object;
3477	    }
3478	    NEXT_OPCODE();
3479
3480/* Resolve symbol value at runtime */
3481#define LOAD_SYMBOL_VALUE()					    \
3482    atom = symbols[*stream++];					    \
3483    if (atom->dyn) {						    \
3484	if (atom->offset < lisp__data.env.head &&		    \
3485	    lisp__data.env.names[atom->offset] == atom->string)	    \
3486	    reg0 = lisp__data.env.values[atom->offset];		    \
3487	else {							    \
3488	    reg0 = atom->property->value;			    \
3489	    if (reg0 == UNBOUND)				    \
3490		LispDestroy("EVAL: the symbol %s is unbound",  \
3491			    STROBJ(atom->object));		    \
3492	}							    \
3493    }								    \
3494    else {							    \
3495	if (atom->a_object)					    \
3496	    reg0 = atom->property->value;			    \
3497	else							    \
3498	    LispDestroy("EVAL: the symbol %s is unbound",	    \
3499			STROBJ(atom->object));			    \
3500    }
3501
3502OPCODE_LABEL(XBC_LOADSYM):
3503	LOAD_SYMBOL_VALUE();
3504	NEXT_OPCODE();
3505
3506OPCODE_LABEL(XBC_LOADSYM_LET):
3507	LOAD_SYMBOL_VALUE();
3508	goto let_argument;
3509
3510OPCODE_LABEL(XBC_LOADSYM_LETX):
3511	LOAD_SYMBOL_VALUE();
3512	goto letx_argument;
3513
3514OPCODE_LABEL(XBC_LOADSYM_PUSH):
3515	LOAD_SYMBOL_VALUE();
3516	lisp__data.stack.values[lisp__data.stack.length++] = reg0;
3517	NEXT_OPCODE();
3518
3519	    /* Builtin function */
3520OPCODE_LABEL(XBC_CALL):
3521	offset = *stream++;
3522	lisp__data.stack.base = lisp__data.stack.length - offset;
3523	builtin = builtins[*stream++];
3524	if (builtin->multiple_values) {
3525	    RETURN_COUNT = 0;
3526	    reg0 = builtin->function(builtin);
3527	}
3528	else {
3529	    reg0 = builtin->function(builtin);
3530	    RETURN_COUNT = 0;
3531	}
3532	lisp__data.stack.length -= offset;
3533	NEXT_OPCODE();
3534
3535OPCODE_LABEL(XBC_CALL_SET):
3536	offset = *stream++;
3537	lisp__data.stack.base = lisp__data.stack.length - offset;
3538	builtin = builtins[*stream++];
3539	if (builtin->multiple_values) {
3540	    RETURN_COUNT = 0;
3541	    reg0 = builtin->function(builtin);
3542	}
3543	else {
3544	    reg0 = builtin->function(builtin);
3545	    RETURN_COUNT = 0;
3546	}
3547	lisp__data.stack.length -= offset;
3548	offset = *stream++;
3549	lisp__data.env.values[lisp__data.env.lex + offset] = reg0;
3550	NEXT_OPCODE();
3551
3552	/* Bytecode call */
3553OPCODE_LABEL(XBC_BYTECALL):
3554	lex = lisp__data.env.lex;
3555	offset = *stream++;
3556	lisp__data.env.head = lisp__data.env.length;
3557	len = lisp__data.env.lex = lisp__data.env.length - offset;
3558	reg0 = ExecuteBytecode(codes[*stream++]);
3559	lisp__data.env.length = lisp__data.env.head = len;
3560	lisp__data.env.lex = lex;
3561	NEXT_OPCODE();
3562
3563	/* Unimplemented function/macro call */
3564OPCODE_LABEL(XBC_FUNCALL):
3565	lambda = constants[*stream++];
3566	arguments = constants[*stream++];
3567	reg0 = LispFuncall(lambda, arguments, 1);
3568	NEXT_OPCODE();
3569
3570OPCODE_LABEL(XBC_JUMP):
3571	stream += *(signed short*)stream;
3572	NEXT_OPCODE();
3573
3574OPCODE_LABEL(XBC_JUMPT):
3575	if (reg0 != NIL)
3576	    stream += *(signed short*)stream;
3577	else
3578	    /* skip jump relative offset */
3579	    stream += sizeof(signed short);
3580	NEXT_OPCODE();
3581
3582OPCODE_LABEL(XBC_JUMPNIL):
3583	if (reg0 == NIL)
3584	    stream += *(signed short*)stream;
3585	else
3586	    /* skip jump relative offset */
3587	    stream += sizeof(signed short);
3588	NEXT_OPCODE();
3589
3590	/* Build CONS of two constant arguments */
3591OPCODE_LABEL(XBC_CCONS):
3592	reg0 = constants[*stream++];
3593	reg1 = constants[*stream++];
3594	reg0 = CONS(reg0, reg1);
3595	NEXT_OPCODE();
3596
3597	/* Start CONS */
3598OPCODE_LABEL(XBC_CSTAR):
3599	/* This the CAR of the CONS */
3600	lisp__data.protect.objects[phead++] = reg0;
3601	NEXT_OPCODE();
3602
3603	/* Finish CONS */
3604OPCODE_LABEL(XBC_CFINI):
3605	reg0 = CONS(lisp__data.protect.objects[--phead], reg0);
3606	NEXT_OPCODE();
3607
3608	/* Start building list */
3609OPCODE_LABEL(XBC_LSTAR):
3610	reg1 = CONS(reg0, NIL);
3611	/* Start of list stored here */
3612	lisp__data.protect.objects[phead++] = reg1;
3613	/* Tail of list stored here */
3614	lisp__data.protect.objects[phead++] = reg1;
3615	NEXT_OPCODE();
3616
3617	/* Add to list */
3618OPCODE_LABEL(XBC_LCONS):
3619	reg1 = lisp__data.protect.objects[phead - 2];
3620	RPLACD(reg1, CONS(reg0, NIL));
3621	 lisp__data.protect.objects[phead - 2] = CDR(reg1);
3622	NEXT_OPCODE();
3623
3624	/* Finish list */
3625OPCODE_LABEL(XBC_LFINI):
3626	phead -= 2;
3627	reg0 = lisp__data.protect.objects[phead + 1];
3628	NEXT_OPCODE();
3629
3630OPCODE_LABEL(XBC_STRUCT):
3631	offset = *stream++;
3632	reg1 = constants[*stream++];
3633	if (!STRUCTP(reg0) || reg0->data.struc.def != reg1) {
3634	    char *name = ATOMID(CAR(reg1));
3635
3636	    for (reg1 = CDR(reg1); offset; offset--)
3637		reg1 = CDR(reg1);
3638	    LispDestroy("%s-%s: %s is not a %s",
3639			name, ATOMID(CAR(reg1)), STROBJ(reg0), name);
3640	}
3641	for (reg0 = reg0->data.struc.fields; offset; offset--)
3642	    reg0 = CDR(reg0);
3643	reg0 = CAR(reg0);
3644	NEXT_OPCODE();
3645
3646OPCODE_LABEL(XBC_STRUCTP):
3647	reg1 = constants[*stream++];
3648	reg0 = STRUCTP(reg0) && reg0->data.struc.def == reg1 ? T : NIL;
3649	NEXT_OPCODE();
3650
3651OPCODE_LABEL(XBC_LETREC):
3652	/* XXX could/should optimize, shouldn't need to parse
3653	 * the bytecode header again */
3654	lex = lisp__data.env.lex;
3655	offset = *stream++;
3656	lisp__data.env.head = lisp__data.env.length;
3657	len = lisp__data.env.lex = lisp__data.env.length - offset;
3658	reg0 = ExecuteBytecode(bytecode);
3659	lisp__data.env.length = lisp__data.env.head = len;
3660	lisp__data.env.lex = lex;
3661	NEXT_OPCODE();
3662
3663OPCODE_LABEL(XBC_RETURN):
3664	lisp__data.protect.length = pbase;
3665	return (reg0);
3666
3667#ifndef ALLOW_GOTO_ADDRESS
3668	}	/* end of switch */
3669
3670predicate_label:
3671	switch (*stream++) {
3672#endif
3673
3674OPCODE_LABEL(XBP_CONSP):
3675	reg0 = CONSP(reg0) ? T : NIL;
3676	NEXT_OPCODE();
3677
3678OPCODE_LABEL(XBP_LISTP):
3679	reg0 = LISTP(reg0) ? T : NIL;
3680	NEXT_OPCODE();
3681
3682OPCODE_LABEL(XBP_NUMBERP):
3683	reg0 = NUMBERP(reg0) ? T : NIL;
3684	NEXT_OPCODE();
3685
3686#ifndef ALLOW_GOTO_ADDRESS
3687	}	/* end of switch */
3688    }
3689#endif
3690
3691    /*NOTREACHED*/
3692    return (reg0);
3693}
3694