/* -*- mode: c -*- */
/*
    compiler.c -- Bytecode compiler
*/
/*
    Copyright (c) 2001, Juan Jose Garcia Ripoll.
    Copyright (c) 2012, Jean-Claude Beaudoin.

    MKCL is free software; you can redistribute it and/or
    modify it under the terms of the GNU Lesser General Public
    License as published by the Free Software Foundation; either
    version 3 of the License, or (at your option) any later version.

    See file '../../Copyright' for full details.
*/

/*  Remarks:

    [1] The virtual machine has a word size of 16 bits. Operands and arguments
    have this very size, so that for instance, a jump

		OP_JMP increment

    takes two words of memory: one for the operator and one for the argument.
    The interpreter is written with this assumption in mind, but it should be
    easily modifed, because arguments are retrieved with "next_arg" and
    operators with "next_op".  Parts which will require a careful modification
    are marked with flag [1].
*/
#include <mkcl/mkcl.h>
#include <mkcl/mkcl-inl.h>
#include <mkcl/internal.h>
#include <mkcl/bytecode.h>

#include <string.h>

/********************* EXPORTS *********************/

#define REGISTER_SPECIALS	1
#define IGNORE_DECLARATIONS	0

/* Flags for the compilation routines: */
/* + Push the output of this form */
#define FLAG_PUSH		1
/* + Set the output of this form in VALUES */
#define FLAG_VALUES		2
/* + Set the output of this form in REG0 */
#define FLAG_REG0		4
/* + Search function binding in the global environment */
#define FLAG_GLOBAL		8
/* + Ignore this form */
#define FLAG_IGNORE		0
#define FLAG_USEFUL		(FLAG_PUSH | FLAG_VALUES | FLAG_REG0)

#define MODE_EXECUTE		0
#define MODE_LOAD		1
#define MODE_COMPILE		2
#define MODE_ONLY_LOAD		3

#define ENV_RECORD_LOCATION(r)	MKCL_CADDDR(r)

#define MKCL_SPECIAL_VAR_REF	-2
#define MKCL_UNDEFINED_VAR_REF	-1

/********************* PRIVATE ********************/

typedef struct mkcl_compiler_env *mk_cl_compiler_ptr;

#define asm_begin(env) current_pc(env)
#define current_pc(env) MKCL_TEMP_STACK_INDEX(env)
#define set_pc(env,n) asm_clear(env,n)
#define asm_ref(env,n) (mkcl_word)((env)->temp_stack[n])
static void asm_clear(MKCL, mkcl_index h);
static void asm_op(MKCL, mkcl_word op);
static void asm_op2(MKCL, int op, int arg);
static mkcl_object asm_end(MKCL, mkcl_index handle, mkcl_object definition);
static mkcl_index asm_jmp(MKCL, register int op);
static void asm_complete(MKCL, register int op, register mkcl_index original);

static mkcl_word c_var_ref(MKCL, mkcl_object var, int allow_symbol_macro, bool ensure_defined);

static int c_block(MKCL, mkcl_object args, int flags);
static int c_case(MKCL, mkcl_object args, int flags);
static int c_catch(MKCL, mkcl_object args, int flags);
static int c_compiler_let(MKCL, mkcl_object args, int flags);
static int c_cond(MKCL, mkcl_object args, int flags);
static int c_eval_when(MKCL, mkcl_object args, int flags);
static int c_flet(MKCL, mkcl_object args, int flags);
static int c_funcall(MKCL, mkcl_object args, int flags);
static int c_function(MKCL, mkcl_object args, int flags);
static int c_go(MKCL, mkcl_object args, int flags);
static int c_if(MKCL, mkcl_object args, int flags);
static int c_labels(MKCL, mkcl_object args, int flags);
static int c_let(MKCL, mkcl_object args, int flags);
static int c_leta(MKCL, mkcl_object args, int flags);
static int c_load_time_value(MKCL, mkcl_object args, int flags);
static int c_locally(MKCL, mkcl_object args, int flags);
static int c_macrolet(MKCL, mkcl_object args, int flags);
static int c_multiple_value_bind(MKCL, mkcl_object args, int flags);
static int c_multiple_value_call(MKCL, mkcl_object args, int flags);
static int c_multiple_value_prog1(MKCL, mkcl_object args, int flags);
static int c_multiple_value_setq(MKCL, mkcl_object args, int flags);
static int c_not(MKCL, mkcl_object args, int flags);
static int c_nth_value(MKCL, mkcl_object args, int flags);
static int c_prog1(MKCL, mkcl_object args, int flags);
static int c_progv(MKCL, mkcl_object args, int flags);
static int c_psetq(MKCL, mkcl_object args, int flags);
static int c_values(MKCL, mkcl_object args, int flags);
static int c_setq(MKCL, mkcl_object args, int flags);
static int c_return(MKCL, mkcl_object args, int flags);
static int c_return_from(MKCL, mkcl_object args, int flags);
static int c_symbol_macrolet(MKCL, mkcl_object args, int flags);
static int c_tagbody(MKCL, mkcl_object args, int flags);
static int c_throw(MKCL, mkcl_object args, int flags);
static int c_unwind_protect(MKCL, mkcl_object args, int flags);
static int c_while(MKCL, mkcl_object args, int flags);
static int c_until(MKCL, mkcl_object args, int flags);
static void eval_form(MKCL, mkcl_object form);
static int compile_body(MKCL, mkcl_object args, int flags);
static int compile_form(MKCL, mkcl_object args, int push);

static int c_cons(MKCL, mkcl_object args, int push);
static int c_endp(MKCL, mkcl_object args, int push);
static int c_car(MKCL, mkcl_object args, int push);
static int c_cdr(MKCL, mkcl_object args, int push);
static int c_list(MKCL, mkcl_object args, int push);
static int c_listA(MKCL, mkcl_object args, int push);

static mkcl_object mkcl_make_lambda(MKCL, mkcl_object name, mkcl_object lambda);

static void mkcl_FEill_formed_input(MKCL) /*__attribute__((noreturn))*/;

/* -------------------- SAFE LIST HANDLING -------------------- */

static mkcl_object
pop(MKCL, mkcl_object *l) {
	mkcl_object head, list = *l;
	if (MKCL_ATOM(list))
		mkcl_FEill_formed_input(env);
	head = MKCL_CONS_CAR(list);
	*l = MKCL_CONS_CDR(list);
	return head;
}

static mkcl_object
pop_maybe_nil(MKCL, mkcl_object *l) {
	mkcl_object head, list = *l;
	if (list == mk_cl_Cnil)
		return mk_cl_Cnil;
	if (MKCL_ATOM(list))
		mkcl_FEill_formed_input(env);
	head = MKCL_CONS_CAR(list);
	*l = MKCL_CONS_CDR(list);
	return head;
}

/* ------------------------------ ASSEMBLER ------------------------------ */

static mkcl_object
asm_end(MKCL, mkcl_index beginning, mkcl_object definition) {
        const mk_cl_compiler_ptr c_env = env->c_env;
	mkcl_object bytecode;
	mkcl_index code_size, data_size, i;
	mkcl_opcode *code;
	mkcl_object file = MKCL_SYM_VAL(env,@'*load-truename*');
	mkcl_object end_position = mk_cl_cdr(env, MKCL_SYM_VAL(env,@'si::*source-location*'));

	/* Save bytecode from this session in a new vector */
	code_size = current_pc(env) - beginning;
	data_size = mkcl_length(env, c_env->constants);
	bytecode = mkcl_alloc_raw_bytecode(env);
	bytecode->bytecode.name = @'si::bytecode';
	bytecode->bytecode.definition = definition;
	bytecode->bytecode.code_size = code_size;
	bytecode->bytecode.data_size = data_size;
#if 0
	bytecode->bytecode.code = mkcl_alloc_atomic(env, code_size * sizeof(mkcl_opcode));
#else
	bytecode->bytecode.code = mkcl_alloc(env, code_size * sizeof(mkcl_opcode));
#endif
	bytecode->bytecode.data = (mkcl_object*)mkcl_alloc(env, data_size * sizeof(mkcl_object));
	for (i = 0, code = (mkcl_opcode *)bytecode->bytecode.code; i < code_size; i++) {
		code[i] = (mkcl_opcode)(mkcl_word)(env->temp_stack[beginning+i]);
	}
	for (i=0; i < data_size; i++) {
		bytecode->bytecode.data[i] = MKCL_CONS_CAR(c_env->constants);
		c_env->constants = MKCL_CONS_CDR(c_env->constants);
	}

        bytecode->bytecode.f.entry =  _mkcl_bytecode_dispatch_vararg;
	bytecode->bytecode.f._[0] = _mkcl_bytecode_dispatch_f0;
	bytecode->bytecode.f._[1] = _mkcl_bytecode_dispatch_f1;
	bytecode->bytecode.f._[2] = _mkcl_bytecode_dispatch_f2;
	bytecode->bytecode.f._[3] = _mkcl_bytecode_dispatch_f3;
	bytecode->bytecode.f._[4] = _mkcl_bytecode_dispatch_f4;

        mkcl_set_function_source_file_info(env, bytecode, (file == MKCL_OBJNULL)? mk_cl_Cnil : file,
                                          (file == MKCL_OBJNULL)? mk_cl_Cnil : end_position);
	asm_clear(env, beginning);
	return bytecode;
}

#if defined(MKCL_SMALL_BYTECODE)
static void
asm_arg(MKCL, int n) {
#ifdef MKCL_WORDS_BIGENDIAN
	asm_op(env, (n >> 8) & 0xFF);
	asm_op(env, n & 0xFF);
#else
	asm_op(env, n & 0xFF);
	asm_op(env, (n >> 8) & 0xFF);
#endif
}
#else
#define asm_arg(env,n) asm_op(env,n)
#endif

static void
asm_op(MKCL, mkcl_word code) {
        mkcl_object v = (mkcl_object)code;
        MKCL_TEMP_STACK_PUSH(env,v);
}

static void
asm_clear(MKCL, mkcl_index h) {
        MKCL_TEMP_STACK_SET_INDEX(env, h);
}

static void
asm_op2(MKCL, int code, int n) {
	if (n < -MAX_OPARG || MAX_OPARG < n)
	  mkcl_FEprogram_error(env, "Argument to bytecode is too large", 0);
	asm_op(env, code);
	asm_arg(env, n);
}

static void
asm_constant(MKCL, mkcl_object c)
{
        const mk_cl_compiler_ptr c_env = env->c_env;
	c_env->constants = mkcl_nconc(env, c_env->constants, mkcl_list1(env, c));
}

static mkcl_index
asm_jmp(MKCL, int op) {
	mkcl_index output;
	asm_op(env, op);
	output = current_pc(env);
	asm_arg(env, 0);
	return output;
}

static void
asm_complete(MKCL, int op, mkcl_index pc) {
	mkcl_word delta = current_pc(env) - pc;  /* [1] */
	if (op && (asm_ref(env, pc-1) != op))
	  mkcl_FEprogram_error(env, "Non matching codes in ASM-COMPLETE2", 0);
	else if (delta < -MAX_OPARG || delta > MAX_OPARG)
	  mkcl_FEprogram_error(env, "Too large jump", 0);
	else {
#ifdef MKCL_SMALL_BYTECODE
		unsigned char low = delta & 0xFF;
		char high = delta >> 8;
# ifdef MKCL_WORDS_BIGENDIAN
		env->temp_stack[pc] = (mkcl_object)(mkcl_word)high;
		env->temp_stack[pc+1] = (mkcl_object)(mkcl_word)low;
# else
		env->temp_stack[pc] = (mkcl_object)(mkcl_word)low;
		env->temp_stack[pc+1] = (mkcl_object)(mkcl_word)high;
# endif
#else
		env->temp_stack[pc] = (mkcl_object)(mkcl_word)delta;
#endif
	}
}

/* ------------------------------ COMPILER ------------------------------ */

typedef struct {
  void *symbol;
  int (*compiler)(mkcl_env, mkcl_object, int);
  int lexical_increment;
} compiler_record;

#define DATABASE_SIZE (sizeof(database)/sizeof(database[0]))

static compiler_record const database[] = {
  {@'block', c_block, 1},
  {@'case', c_case, 1},
  {@'catch', c_catch, 1},
  {@'mkcl::compiler-let', c_compiler_let, 0},
  {@'cond', c_cond, 1},
  {@'eval-when', c_eval_when, 0},
  {@'flet', c_flet, 1},
  {@'function', c_function, 1},
  {@'funcall', c_funcall, 0},
  {@'go', c_go, 1},
  {@'if', c_if, 1},
  {@'labels', c_labels, 1},
  {@'let', c_let, 1},
  {@'let*', c_leta, 1},
  {@'locally', c_locally, 0},
  {@'load-time-value', c_load_time_value, 1},
  {@'macrolet', c_macrolet, 0},
  {@'multiple-value-bind', c_multiple_value_bind, 1},
  {@'multiple-value-call', c_multiple_value_call, 1},
  {@'multiple-value-prog1', c_multiple_value_prog1, 1},
  {@'multiple-value-setq', c_multiple_value_setq, 1},
  {@'not', c_not, 1},
  {@'nth-value', c_nth_value, 1},
  {@'null', c_not, 1},
  {@'progn', compile_body, 0},
  {@'prog1', c_prog1, 1},
  {@'progv', c_progv, 1},
  {@'psetq', c_psetq, 1},
  {@'return', c_return, 1},
  {@'return-from', c_return_from, 1},
  {@'setq', c_setq, 1},
  {@'symbol-macrolet', c_symbol_macrolet, 0},
  {@'tagbody', c_tagbody, 1},
  {@'throw', c_throw, 1},
  {@'unwind-protect', c_unwind_protect, 1},
  {@'values', c_values, 1},
  {@'si::while', c_while, 0},
  {@'si::until', c_until, 0},

  /* Extras */

  {@'cons', c_cons, 0},
  {@'car', c_car, 0},
  {@'cdr', c_cdr, 0},
  {@'first', c_car, 0},
  {@'rest', c_cdr, 0},
  {@'list', c_list, 0},
  {@'list*', c_listA, 0},
  {@'endp', c_endp, 0}
};

/* ----------------- LEXICAL ENVIRONMENT HANDLING -------------------- */

static void
mkcl_assert_type_symbol(MKCL, mkcl_object v)
{
	if (mkcl_type_of(v) != mkcl_t_symbol)
	  mkcl_FEprogram_error(env, "Expected a symbol, found ~S.", 1, v);
}

static void
mkcl_FEill_formed_input(MKCL)
{
  mkcl_FEprogram_error(env, "Syntax error: list with too few elements or improperly terminated.", 0);
}

static int
c_register_constant(MKCL, mkcl_object c)
{
        const mk_cl_compiler_ptr c_env = env->c_env;
	mkcl_object p = c_env->constants;
	int n;
	for (n = 0; !mkcl_Null(p); n++, p = MKCL_CONS_CDR(p)) {
	  if (c_env->coalesce && mkcl_eql(env, MKCL_CONS_CAR(p), c)) {
			return n;
		}
	}
	asm_constant(env, c);
	return n;
}

static void
asm_c(MKCL, mkcl_object o) {
	asm_arg(env, c_register_constant(env, o));
}

static void
asm_op2c(MKCL, int code, mkcl_object o) {
	asm_op2(env, code, c_register_constant(env, o));
}

/*
 * Note: the following should match the definitions in cmp/cmpenv.lsp, as
 * well as CMP-ENV-REGISTER-MACROLET (lsp/defmacro.lsp)
 *
 * The compiler environment consists of two lists, one stored in
 * env->variables, the other one stored in env->macros.
 *
 * variable-record =	(:block block-name [used-p | block-object] location) |
 *			(:tag ({tag-name}*) [NIL | tag-object] location) |
 *			(:function function-name used-p [location]) |
 *			(var-name {:special | nil} bound-p [location]) |
 *			(symbol si::symbol-macro macro-function) |
 *			CB | LB | UNWIND-PROTECT |
 *			(:declare declaration-arguments*)
 * macro-record =	(function-name FUNCTION [| function-object]) |
 *			(macro-name si::macro macro-function)
 *			CB | LB | UNWIND-PROTECT
 *
 * A *-NAME is a symbol. A TAG-ID is either a symbol or a number. A
 * MACRO-FUNCTION is a function that provides us with the expansion
 * for that local macro or symbol macro. BOUND-P is true when the
 * variable has been bound by an enclosing form, while it is NIL if
 * the variable-record corresponds just to a special declaration.
 * CB, LB and UNWIND-PROTECT are only used by the C compiler and they
 * denote closure, lexical environment and unwind-protect boundaries.
 *
 * The brackets [] denote differences between the bytecode and C
 * compiler environments, with the first option belonging to the
 * interpreter and the second alternative to the compiler.
 *
 * A LOCATION object is proper to the bytecode compiler and denotes
 * the position of this variable, block, tag or function, in the
 * lexical environment. Currently, it is a CONS with two integers
 * (DEPTH . ORDER), denoting the depth of the nested environments and
 * the position in the environment (from the beginning, not from the
 * tail).
 *
 * The BLOCK-, TAG- and FUNCTION- objects are proper of the compiler
 * and carry further information.
 *
 * The last variable records are devoted to declarations and are only
 * used by the C compiler. Read cmpenv.lsp for more details on the
 * structure of these declaration forms, as they do not completely
 * match those of Common-Lisp.
 */

static mkcl_object
new_location(MKCL, mkcl_object name)
{
        const mk_cl_compiler_ptr c_env = env->c_env;
	return MKCL_CONS(env, MKCL_MAKE_FIXNUM(c_env->env_depth),
                    MKCL_MAKE_FIXNUM(c_env->env_size++));
}

static mkcl_index
c_register_block(MKCL, mkcl_object name)
{
	mkcl_object loc = new_location(env, name);
        const mk_cl_compiler_ptr c_env = env->c_env;
	c_env->variables = MKCL_CONS(env, mk_cl_list(env, 4, @':block', name, mk_cl_Cnil, loc),
                                c_env->variables);
	return mkcl_fixnum_to_word(MKCL_CONS_CDR(loc));
}

static mkcl_index
c_register_tags(MKCL, mkcl_object all_tags)
{
	mkcl_object loc = new_location(env, @':tag');
        const mk_cl_compiler_ptr c_env = env->c_env;
	c_env->variables = MKCL_CONS(env, mk_cl_list(env, 4, @':tag', all_tags, mk_cl_Cnil, loc),
                                c_env->variables);
	return mkcl_fixnum_to_word(MKCL_CONS_CDR(loc));
}

static void
c_register_function(MKCL, mkcl_object name)
{
        const mk_cl_compiler_ptr c_env = env->c_env;
	c_env->variables = MKCL_CONS(env, mk_cl_list(env, 4, @':function', name, mk_cl_Cnil,
                                        new_location(env, name)),
                                c_env->variables);
	c_env->macros = MKCL_CONS(env, mk_cl_list(env, 2, name, @'function'), c_env->macros);
}

static mkcl_object
c_macro_expand1(MKCL, mkcl_object stmt)
{
        const mk_cl_compiler_ptr c_env = env->c_env;
	return mk_cl_macroexpand_1(env, 2, stmt, MKCL_CONS(env, c_env->variables, c_env->macros));
}

static void
c_register_symbol_macro(MKCL, mkcl_object name, mkcl_object exp_fun)
{
        const mk_cl_compiler_ptr c_env = env->c_env;
	c_env->variables = MKCL_CONS(env, mk_cl_list(env, 3, name, @'si::symbol-macro', exp_fun),
                                c_env->variables);
}

/* UNUSED
static void
c_register_macro(MKCL, mkcl_object name, mkcl_object exp_fun)
{
        const mk_cl_compiler_ptr c_env = env->c_env;
	c_env->macros = MKCL_CONS(mk_cl_list(3, name, @'si::macro', exp_fun), c_env->macros);
}
*/

static void
c_register_var(MKCL, mkcl_object var, bool special, bool bound)
{
	/* If this is just a declaration, ensure that the variable was not
	 * declared before as special, to save memory. */
	if (bound || (c_var_ref(env, var, 0, FALSE) >= MKCL_UNDEFINED_VAR_REF)) {
                const mk_cl_compiler_ptr c_env = env->c_env;
		c_env->variables = MKCL_CONS(env, mk_cl_list(env, 4,
							     var,
							     special ? @':special' : mk_cl_Cnil,
							     bound ? mk_cl_Ct : mk_cl_Cnil,
							     new_location(env, var)),
					     c_env->variables);
	}
}

static void
guess_environment(MKCL, mkcl_object interpreter_env)
{
        if (!MKCL_LISTP(interpreter_env))
                return;
	/*
	 * Given the environment of an interpreted function, we guess a
	 * suitable compiler enviroment to compile forms that access the
	 * variables and local functions of this interpreted code.
	 */
	for (interpreter_env = @revappend(env, interpreter_env, mk_cl_Cnil);
	     !mkcl_Null(interpreter_env);
	     interpreter_env = MKCL_CONS_CDR(interpreter_env))
	{
		mkcl_object record = MKCL_CONS_CAR(interpreter_env);
                if (!MKCL_LISTP(record)) {
			c_register_function(env, record);
                } else {
                        mkcl_object record0 = MKCL_CONS_CAR(record);
                        mkcl_object record1 = MKCL_CONS_CDR(record);
                        if (MKCL_SYMBOLP(record0)) {
                                c_register_var(env, record0, FALSE, TRUE);
                        } else if (record1 == MKCL_MAKE_FIXNUM(0)) {
                                c_register_tags(env, mk_cl_Cnil);
                        } else {
                                c_register_block(env, record1);
                        }
                }
	}
}

static void
c_new_env(mkcl_env the_env, mkcl_compiler_env_ptr new, mkcl_object env,
          mkcl_compiler_env_ptr old)
{
	the_env->c_env = new;
	new->stepping = 0;
	new->coalesce = TRUE;
	new->lexical_level = 0;
	new->constants = mk_cl_Cnil;
	new->env_depth = 0;
	new->env_size = 0;
	if (old) {
		if (!mkcl_Null(env))
			mkcl_lose(the_env, "c_new_env with both ENV and OLD");
		new->variables = old->variables;
		new->macros = old->macros;
		new->lexical_level = old->lexical_level;
		new->constants = old->constants;
		new->lex_env = old->lex_env;
		new->env_depth = old->env_depth + 1;
		new->coalesce = old->coalesce;
		new->stepping = old->stepping;
                new->mode = old->mode;
	} else {
		new->variables = MKCL_CAR(env);
		new->macros = MKCL_CDR(env);
		for (env = new->variables; !mkcl_Null(env); env = MKCL_CDR(env)) {
			mkcl_object record = MKCL_CAR(env);
			if (MKCL_ATOM(record))
				continue;
			if (MKCL_SYMBOLP(MKCL_CAR(record)) && MKCL_CADR(record) != @'si::symbol-macro') {
				continue;
			} else {
				new->lexical_level = 1;
				break;
			}
		}
                new->mode = MODE_EXECUTE;
	}
}

static mkcl_object
c_tag_ref(MKCL, mkcl_object the_tag, mkcl_object the_type)
{
	mkcl_word n = 0;
	mkcl_object l;
        const mk_cl_compiler_ptr c_env = env->c_env;
	for (l = c_env->variables; MKCL_CONSP(l); l = MKCL_CONS_CDR(l)) {
		mkcl_object type, name, record = MKCL_CONS_CAR(l);
		if (MKCL_ATOM(record))
			continue;
		type = MKCL_CONS_CAR(record);
                record = MKCL_CONS_CDR(record);
		name = MKCL_CONS_CAR(record);
		if (type == @':tag') {
			if (type == the_type) {
			  mkcl_object label = mkcl_assql(env, the_tag, name);
				if (!mkcl_Null(label)) {
				  return MKCL_CONS(env, MKCL_MAKE_FIXNUM(n), MKCL_CONS_CDR(label));
				}
			}
			n++;
		} else if (type == @':block' || type == @':function') {
			/* We compare with EQUAL, because of (SETF fname) */
		  if (type == the_type && mkcl_equal(env, name, the_tag)) {
				/* Mark as used */
                                record = MKCL_CONS_CDR(record);
				MKCL_RPLACA(record, mk_cl_Ct);
				return MKCL_MAKE_FIXNUM(n);
			}
			n++;
		} else if (mkcl_Null(name)) {
			n++;
		} else {
			/* We are counting only locals and ignore specials
			 * and other declarations */
		}
	}
	return mk_cl_Cnil;
}

static mkcl_word
c_var_ref(MKCL, mkcl_object var, int allow_symbol_macro, bool ensure_defined)
{
	mkcl_word n = 0;
	mkcl_object l, record, special, name;
        const mk_cl_compiler_ptr c_env = env->c_env;
	for (l = c_env->variables; MKCL_CONSP(l); l = MKCL_CONS_CDR(l)) {
		record = MKCL_CONS_CAR(l);
		if (MKCL_ATOM(record))
			continue;
		name = MKCL_CONS_CAR(record);
                record = MKCL_CONS_CDR(record);
		special = MKCL_CONS_CAR(record);
		if (name == @':block' || name == @':tag' || name == @':function') {
			n++;
		} else if (name == @':declare') {
			/* Ignored */
		} else if (name != var) {
			/* Symbol not yet found. Only count locals. */
			if (mkcl_Null(special)) n++;
		} else if (special == @'si::symbol-macro') {
			/* We can only get here when we try to redefine a
			   symbol macro */
			if (allow_symbol_macro)
				return -1;
			mkcl_FEprogram_error(env, "Internal error: symbol macro ~S used as variable",
					1, var);
		} else if (mkcl_Null(special)) {
			return n;
		} else {
			return MKCL_SPECIAL_VAR_REF;
		}
	}
	if (ensure_defined) {
	  l = mkcl_symbol_value(env, @'si::*action-on-undefined-variable*');
		if (l != mk_cl_Cnil) {
		  mkcl_funcall2(env, l,
				mkcl_make_simple_base_string(env,
							     "Undefined variable referenced"
							     " in interpreted code.~%Name: ~A"),
				var);
		}
	}
	return MKCL_UNDEFINED_VAR_REF;
}

static bool
c_declared_special(MKCL, register mkcl_object var, register mkcl_object specials)
{
  return ((mkcl_symbol_type(env, var) & mkcl_stp_special) || mkcl_member_eq(env, var, specials));
}

static void
c_declare_specials(MKCL, mkcl_object specials)
{
	while (!mkcl_Null(specials)) {
		int ndx;
		mkcl_object var = pop(env, &specials);
		ndx = c_var_ref(env, var,0,FALSE);
		if (ndx >= 0 || ndx == MKCL_UNDEFINED_VAR_REF)
			c_register_var(env, var, TRUE, FALSE);
	}
}

static mkcl_object
c_process_declarations(MKCL, mkcl_object body)
{
  @si::process-declarations(env, 1, body);
  body = MKCL_VALUES(1); /* No check on MKCL_NVALUES? JCB*/
  return body;
}

static bool
c_pbind(MKCL, mkcl_object var, mkcl_object specials)
{
	bool special;
	if (!MKCL_SYMBOLP(var))
	  mkcl_FEillegal_variable_name(env, var);
	else if ((special = c_declared_special(env, var, specials))) {
		c_register_var(env, var, TRUE, TRUE);
		asm_op2c(env, OP_PBINDS, var);
	} else {
		c_register_var(env, var, FALSE, TRUE);
		asm_op2c(env, OP_PBIND, var);
	}
	return special;
}

static bool
c_bind(MKCL, mkcl_object var, mkcl_object specials)
{
	bool special;
	if (!MKCL_SYMBOLP(var))
	  mkcl_FEillegal_variable_name(env, var);
	else if ((special = c_declared_special(env, var, specials))) {
		c_register_var(env, var, TRUE, TRUE);
		asm_op2c(env, OP_BINDS, var);
	} else {
		c_register_var(env, var, FALSE, TRUE);
		asm_op2c(env, OP_BIND, var);
	}
	return special;
}

static void
c_undo_bindings(mkcl_env the_env, mkcl_object old_vars, int only_specials)
{
	mkcl_object env;
	mkcl_index num_lexical = 0;
	mkcl_index num_special = 0;
        const mk_cl_compiler_ptr c_env = the_env->c_env;

	for (env = c_env->variables; env != old_vars && !mkcl_Null(env); env = MKCL_CONS_CDR(env))
	{
                mkcl_object record, name, special;
                record = MKCL_CONS_CAR(env);
		name = MKCL_CONS_CAR(record);
                record = MKCL_CONS_CDR(record);
		special = MKCL_CONS_CAR(record);
		if (name == @':block' || name == @':tag') {
			(void)0;
		} else if (name == @':function' || mkcl_Null(special)) {
			if (only_specials == 0) num_lexical++;
		} else if (name == @':declare') {
			/* Ignored */
		} else if (special != @'si::symbol-macro') {
			/* If (third special) = NIL, the variable was declared
			   special, but there is no binding! */
                        record = MKCL_CONS_CDR(record);
			if (!mkcl_Null(MKCL_CONS_CAR(record))) {
				num_special++;
			}
		}
	}
	c_env->variables = env;
	if (num_lexical) asm_op2(the_env, OP_UNBIND, num_lexical);
	if (num_special) asm_op2(the_env, OP_UNBINDS, num_special);
}

static void
compile_setq(MKCL, int op, mkcl_object var)
{
  mkcl_word ndx;

  if (!MKCL_SYMBOLP(var))
    mkcl_FEillegal_variable_name(env, var);
  ndx = c_var_ref(env, var,0,TRUE);
  if (ndx < 0) { /* Not a lexical variable */
    if (mkcl_symbol_type(env, var) & mkcl_stp_constant) {
      mkcl_FEassignment_to_constant(env, var);
    }
    ndx = c_register_constant(env, var);
    if (op == OP_SETQ)
      op = OP_SETQS;
    else if (op == OP_PSETQ)
      op = OP_PSETQS;
    else if (op == OP_VSETQ)
      op = OP_VSETQS;
  }
  asm_op2(env, op, ndx);
}

/*
 * This routine is used to change the compilation flags in optimizers
 * that do not want to push values onto the stack.  Its purpose is to
 * keep ignorable forms ignored, while preserving the value of useful
 * forms. Qualitative behavior:
 *	FLAG_PUSH		-> FLAG_VALUES
 *	FLAG_VALUES		-> FLAG_VALUES
 *	FLAG_REG0		-> FLAG_REG0
 *	FLAG_IGNORE		-> FLAG_IGNORE
 */
static int
maybe_values_or_reg0(int flags) {
	if (flags & FLAG_PUSH)
		return (flags | FLAG_VALUES) & ~FLAG_PUSH;
	else
		return flags;
}

/*
 * This routine is used to change the compilation flags in optimizers
 * that do not want to push values onto the stack, but also do not want
 * to use REG0 (maybe because the call a nested mkcl_interpret()). Ignorable
 * forms are kept ignored:
 *	FLAG_PUSH		-> FLAG_VALUES
 *	FLAG_VALUES		-> FLAG_VALUES
 *	FLAG_REG0		-> FLAG_VALUES
 *	FLAG_IGNORE		-> FLAG_IGNORE
 */
static int
maybe_values(int flags) {
	if (flags & FLAG_USEFUL)
		return (flags & ~(FLAG_PUSH | FLAG_REG0)) | FLAG_VALUES;
	else
		return flags;
}

/*
 * This routine is used to change the compilation flags in optimizers
 * that do not want to push values onto the stack.  Its purpose is to
 * keep ignorable forms ignored, while preserving the value of useful
 * forms. Qualitative behavior:
 *	FLAG_PUSH		-> FLAG_REG0
 *	FLAG_VALUES		-> FLAG_REG0
 *	FLAG_REG0		-> FLAG_REG0
 *	FLAG_IGNORE		-> FLAG_IGNORE
 */
static int
maybe_reg0(int flags) {
	if (flags & FLAG_USEFUL)
		return (flags & ~(FLAG_VALUES | FLAG_PUSH)) | FLAG_REG0;
	else
		return flags;
}

/* -------------------- THE COMPILER -------------------- */

/*
	The OP_BLOCK operator encloses several forms within a block
	named BLOCK_NAME, thus catching any OP_RETFROM whose argument
	matches BLOCK_NAME. The end of this block is marked both by
	the OP_EXIT operator and the LABELZ which is packed within
	the OP_BLOCK operator.

		[OP_BLOCK + name + labelz]
		....
		OP_EXIT_FRAME
	labelz:	...
*/

static int
c_block(MKCL, mkcl_object body, int old_flags) {
	struct mkcl_compiler_env old_env;
	mkcl_object name = pop(env, &body);
	mkcl_object block_record;
	mkcl_index labelz, pc, loc;
	int flags;

	if (!MKCL_SYMBOLP(name))
	  mkcl_FEprogram_error(env, "BLOCK: Not a valid block name, ~S", 1, name);

	old_env = *(env->c_env);
	pc = current_pc(env);

	flags = maybe_values_or_reg0(old_flags);
	loc = c_register_block(env, name);
	block_record = MKCL_CONS_CAR(env->c_env->variables);
	if (mkcl_Null(name)) {
		asm_op(env, OP_DO);
	} else {
		asm_op2c(env, OP_BLOCK, name);
	}
	labelz = asm_jmp(env, OP_FRAME);
	compile_body(env, body, flags);
	if (MKCL_CADDR(block_record) == mk_cl_Cnil) {
		/* Block unused. We remove the enclosing OP_BLOCK/OP_DO */
		*(env->c_env) = old_env;
		set_pc(env, pc);
		return compile_body(env, body, old_flags);
	} else {
		c_undo_bindings(env, old_env.variables, 0);
		asm_op(env, OP_EXIT_FRAME);
		asm_complete(env, 0, labelz);
		return flags;
	}
}

/*
	There are several ways to invoke functions and to handle the
	output arguments. These are

		[OP_CALL + nargs]
		function_name

		[OP_FCALL + nargs]

	 OP_CALL and OP_FCALL leave all arguments in the MKCL_VALUES() array,
	 while OP_PCALL and OP_PFCALL leave the first argument in the
	 stack.

	 OP_CALL and OP_PCALL use the value in MKCL_VALUES(0) to retrieve the
	 function, while OP_FCALL and OP_PFCALL use a value from the
	 stack.
 */
static int
c_arguments(MKCL, mkcl_object args) {
	mkcl_index nargs;
	for (nargs = 0; !mkcl_endp(env, args); nargs++) {
	  compile_form(env, pop(env, &args), FLAG_PUSH);
	}
	return nargs;
}

static int asm_function(MKCL, mkcl_object args, int flags);

static int
c_call(MKCL, mkcl_object args, int flags) {
	mkcl_object name;
	mkcl_index nargs;

	name = pop(env, &args);
	nargs = c_arguments(env, args);
	if (env->c_env->stepping) {
		/* When stepping, we only have one opcode to do function
		 * calls: OP_STEPFCALL. */
		asm_function(env, name, (flags & FLAG_GLOBAL) | FLAG_REG0);
		asm_op2(env, OP_STEPCALL, nargs);
/* 		asm_op(env, OP_POP1); */
		flags = FLAG_VALUES;
	} else if (MKCL_SYMBOLP(name) &&
		   ((flags & FLAG_GLOBAL) || mkcl_Null(c_tag_ref(env, name, @':function'))))
	{
		asm_op2(env, OP_CALLG, nargs);
		asm_c(env, name);
		flags = FLAG_VALUES;
	} else {
		/* Fixme!! We can optimize the case of global functions! */
		asm_function(env, name, (flags & FLAG_GLOBAL) | FLAG_REG0);
		asm_op2(env, OP_CALL, nargs);
		flags = FLAG_VALUES;
	}
	return flags;
}

static int
c_funcall(MKCL, mkcl_object args, int flags) {
	mkcl_object name;
	mkcl_index nargs;

	name = pop(env, &args);
	if (MKCL_CONSP(name)) {
                mkcl_object kind = MKCL_CONS_CAR(name);
		if (kind == @'function') {
		  if (mk_cl_list_length(env, name) != MKCL_MAKE_FIXNUM(2))
		    mkcl_FEprogram_error(env, "FUNCALL: Invalid function name ~S",
						1, name);
		  return c_call(env, MKCL_CONS(env, MKCL_CADR(name), args), flags);
		}

		if (kind == @'quote' && /* JCB */ MKCL_SYMBOLP(MKCL_CADR(name))) {