/* -*- mode: c; c-basic-offset: 8 -*- */
/*
    disassembler.c -- Byte compiler and function evaluator
*/
/*
    Copyright (c) 2001, Juan Jose Garcia Ripoll.

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

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

#include <ecl/ecl.h>
#include <ecl/ecl-inl.h>
#include <ecl/bytecodes.h>
#include <ecl/internal.h>

static cl_opcode *disassemble(cl_object bytecodes, cl_opcode *vector);

static cl_opcode *base = NULL;

static void
print_noarg(const char *s) {
	ecl_princ_str(s, ECL_NIL);
}

static void
print_oparg(const char *s, cl_fixnum n) {
	ecl_princ_str(s, ECL_NIL);
	ecl_princ(ecl_make_fixnum(n), ECL_NIL);
}

static void
print_arg(const char *s, cl_object x) {
	ecl_princ_str(s, ECL_NIL);
	ecl_princ(x, ECL_NIL);
}

static void
print_oparg_arg(const char *s, cl_fixnum n, cl_object x) {
	ecl_princ_str(s, ECL_NIL);
	ecl_princ(ecl_make_fixnum(n), ECL_NIL);
	ecl_princ_str(",", ECL_NIL);
	ecl_princ(x, ECL_NIL);
}

#define GET_DATA(r,v,data) { \
	cl_oparg ndx; \
	GET_OPARG(ndx, v); \
	r = data[ndx]; \
}

static void
disassemble_lambda(cl_object bytecodes) {
	const cl_env_ptr env = ecl_process_env();
	cl_object *data;
	cl_opcode *vector;

	ecl_bds_bind(env, @'*print-pretty*', ECL_NIL);

	/* Print required arguments */
	data = bytecodes->bytecodes.data->vector.self.t;
	cl_print(1,bytecodes->bytecodes.data);

	/* Name of LAMBDA */
	print_arg("\nName:\t\t", bytecodes->bytecodes.name);
	if (bytecodes->bytecodes.name == OBJNULL ||
	    bytecodes->bytecodes.name == @'si::bytecodes') {
		print_noarg("\nEvaluated form:");
		goto NO_ARGS;
	}

 NO_ARGS:
	base = vector = (cl_opcode *)bytecodes->bytecodes.code;
	disassemble(bytecodes, vector);

	ecl_bds_unwind1(env);
}

/* -------------------- DISASSEMBLER CORE -------------------- */

/* OP_FLET	nfun{arg}, fun1{object}
   ...

	Executes the enclosed code in a lexical enviroment extended with
	the functions "fun1" ... "funn".
*/
static cl_opcode *
disassemble_flet(cl_object bytecodes, cl_opcode *vector) {
	cl_index nfun;
	cl_object *data = bytecodes->bytecodes.data->vector.self.t;
	GET_OPARG(nfun, vector);
	print_noarg("FLET");
	while (nfun--) {
		cl_object fun;
		GET_DATA(fun, vector, data);
		print_arg("\n\tFLET\t", fun->bytecodes.name);
	}
	return vector;
}

/* OP_LABELS	nfun{arg}, fun1{object}
   ...

	Executes the enclosed code in a lexical enviroment extended with
	the functions "fun1" ... "funn".
*/
static cl_opcode *
disassemble_labels(cl_object bytecodes, cl_opcode *vector) {
	cl_index nfun;
	cl_object *data = bytecodes->bytecodes.data->vector.self.t;
	GET_OPARG(nfun, vector);
	print_noarg("LABELS");
	while (nfun--) {
		cl_object fun;
		GET_DATA(fun, vector, data);
		print_arg("\n\tLABELS\t", fun->bytecodes.name);
	}
	return vector;
}

/* OP_PROGV	bindings{list}
   ...
   OP_EXIT
	Execute the code enclosed with the special variables in BINDINGS
	set to the values in the list which was passed in VALUES(0).
*/
static cl_opcode *
disassemble_progv(cl_object bytecodes, cl_opcode *vector) {
	print_noarg("PROGV");
	vector = disassemble(bytecodes, vector);
	print_noarg("\t\t; progv");
	return vector;
}

/* OP_TAGBODY	n{arg}
   label1
   ...
   labeln
label1:
   ...
labeln:
   ...
   OP_EXIT

	High level construct for the TAGBODY form.
*/
static cl_opcode *
disassemble_tagbody(cl_object bytecodes, cl_opcode *vector) {
	cl_index i, ntags;
	cl_opcode *destination;
	GET_OPARG(ntags, vector);
	print_noarg("TAGBODY");
	for (i=0; i<ntags; i++) {
		GET_LABEL(destination, vector);
		ecl_princ_str("\n\tTAG\t", ECL_T);
		ecl_princ(ecl_make_fixnum(i), ECL_T);
		ecl_princ_str(" @@ ", ECL_T);
		ecl_princ(ecl_make_fixnum(destination - base), ECL_T);
	}
	vector = disassemble(bytecodes, vector);
	print_noarg("\t\t; tagbody");

	return vector;
}

static cl_opcode *
disassemble(cl_object bytecodes, cl_opcode *vector) {
	const char *string;
	cl_object o;
	cl_fixnum n, m;
	cl_object line_format;
	cl_object *data = bytecodes->bytecodes.data->vector.self.t;
	cl_object line_no;

	if (cl_fboundp(@'si::formatter-aux') != ECL_NIL)
		line_format = make_constant_base_string("~%~4d\t");
	else
		line_format = ECL_NIL;
 BEGIN:
	if (1) {
		line_no = ecl_make_fixnum(vector-base);
	} else {
		line_no = @'*';
	}
	if (line_format != ECL_NIL) {
		cl_format(3, ECL_T, line_format, line_no);
	} else {
		ecl_princ_char('\n', ECL_T);
		ecl_princ(line_no, ECL_T);
		ecl_princ_char('\t', ECL_T);
	}
	switch (GET_OPCODE(vector)) {

	/* OP_NOP
		Sets VALUES(0) = NIL and NVALUES = 1
	*/
	case OP_NOP:		string = "NOP";	goto NOARG;

	case OP_INT:		string = "QUOTE\t";
				GET_OPARG(n, vector);
				goto OPARG;

	case OP_PINT:		string = "PUSH\t";
				GET_OPARG(n, vector);
				goto OPARG;

	/* OP_QUOTE
		Sets VALUES(0) to an immediate value.
	*/
	case OP_QUOTE:		string = "QUOTE\t";
				GET_DATA(o, vector, data);
				goto ARG;

	/* OP_CSET	n{arg}
		Replace constant with a computed value
	*/
	case OP_CSET:		string = "CSET\t";
		                GET_OPARG(n, vector);
				goto OPARG;

	/* OP_VAR	n{arg}
		Sets NVALUES=1 and VALUES(0) to the value of the n-th local.
	*/
	case OP_VAR:		string = "VAR\t";
				GET_OPARG(n, vector);
				goto OPARG;

	/* OP_VARS	var{symbol}
		Sets NVALUES=1 and VALUES(0) to the value of the symbol VAR.
		VAR should be either a special variable or a constant.
	*/
	case OP_VARS:		string = "VARS\t";
				GET_DATA(o, vector, data);
				goto ARG;

	/* OP_PUSH
		Pushes the object in VALUES(0).
	*/
	case OP_PUSH:		string = "PUSH\tVALUES(0)";
				goto NOARG;

	case OP_VALUEREG0:	string = "SET\tVALUES(0),REG0";
				goto NOARG;

	/* OP_PUSHV	n{arg}
		Pushes the value of the n-th local onto the stack.
	*/
	case OP_PUSHV:		string = "PUSHV\t";
				GET_OPARG(n, vector);
				goto OPARG;

	/* OP_PUSHVS	var{symbol}
		Pushes the value of the symbol VAR onto the stack.
		VAR should be either a special variable or a constant.
	*/
	case OP_PUSHVS:		string = "PUSHVS\t";
				GET_DATA(o, vector, data);
				goto ARG;

	/* OP_PUSHQ	value{object}
		Pushes "value" onto the stack.
	*/
	case OP_PUSHQ:		string = "PUSH\t'";
				GET_DATA(o, vector, data);
				goto ARG;

	/* OP_PUSHVALUES
		Pushes the values output by the last form, plus the number
		of values.
	*/
	case OP_PUSHVALUES:	string = "PUSH\tVALUES";
				goto NOARG;
	/* OP_PUSHMOREVALUES
		Adds more values to the ones pushed by OP_PUSHVALUES.
	*/
	case OP_PUSHMOREVALUES:	string = "PUSH\tMORE VALUES";
				goto NOARG;
	/* OP_POP
		Pops a single value pushed by a OP_PUSH[V[S]] operator.
	*/
	case OP_POP:		string = "POP";
				goto NOARG;
	/* OP_POP1
		Pops a single value pushed by a OP_PUSH[V[S]] operator.
	*/
	case OP_POP1:		string = "POP1";
				goto NOARG;
	/* OP_POPVALUES
		Pops all values pushed by a OP_PUSHVALUES operator.
	*/
	case OP_POPVALUES:	string = "POP\tVALUES";
				goto NOARG;

	case OP_BLOCK:		string = "BLOCK\t";
				GET_DATA(o, vector, data);
				goto ARG;
	case OP_CATCH:		string = "CATCH\tREG0";
				goto NOARG;
	case OP_DO:		string = "BLOCK\t";
				o = ECL_NIL;
				goto ARG;
	case OP_FRAME:		string = "FRAME\t";
				goto JMP;

	/* OP_CALL	n{arg}
		Calls the function in VALUES(0) with N arguments which
		have been deposited in the stack. The output values
		are left in VALUES(...)
	*/
	case OP_CALL:		string = "CALL\t";
				GET_OPARG(n, vector);
				goto OPARG;

	/* OP_CALLG	n{arg}, name{arg}
		Calls the function NAME with N arguments which have been
		deposited in the stack. The output values are left in VALUES.
	*/
	case OP_CALLG:		string = "CALLG\t";
				GET_OPARG(n, vector);
				GET_DATA(o, vector, data);
				goto OPARG_ARG;

	/* OP_FCALL	n{arg}
		Calls the function in the stack with N arguments which
		have been also deposited in the stack. The output values
		are left in VALUES(...)
	*/
	case OP_STEPCALL:
	case OP_FCALL:		string = "FCALL\t";
				GET_OPARG(n, vector);
				goto OPARG;

	/* OP_MCALL
		Similar to FCALL, but gets the number of arguments from
		the stack (They all have been deposited by OP_PUSHVALUES)
	*/
	case OP_MCALL:		string = "MCALL";
				goto NOARG;

	/* OP_POPREQ
		Extracts next required argument.
	*/
	case OP_POPREQ:		string = "POP\tREQ";
				goto NOARG;
	/* OP_NOMORE
		Ensure there are no more arguments.
	*/
	case OP_NOMORE:		string = "NOMORE";
				goto NOARG;
	/* OP_POPOPT
		Extracts next optional argument.
	*/
	case OP_POPOPT:		string = "POP\tOPT";
				goto NOARG;
	/* OP_POPREST
		Extracts list of remaining arguments.
	*/
	case OP_POPREST:	string = "POP\tREST";
				goto NOARG;
        /* OP_PUSHKEYS
        	Parses the keyword arguments
        */
        case OP_PUSHKEYS:	string = "PUSH\tKEYS ";
				GET_DATA(o, vector, data);
                		goto ARG;

	/* OP_EXIT
		Marks the end of a high level construct
	*/
	case OP_EXIT:		print_noarg("EXIT");
				return vector;
	/* OP_EXIT_FRAME
		Marks the end of a high level construct (BLOCK, CATCH...)
	*/
	case OP_EXIT_FRAME:	string = "EXIT\tFRAME";
				goto NOARG;
	/* OP_EXIT_TAGBODY
		Marks the end of a high level construct (TAGBODY)
	*/
	case OP_EXIT_TAGBODY:	print_noarg("EXIT\tTAGBODY");
				return vector;

	case OP_FLET:		vector = disassemble_flet(bytecodes, vector);
				break;
	case OP_LABELS:		vector = disassemble_labels(bytecodes, vector);
				break;

	/* OP_LFUNCTION	name{symbol}
		Extracts the function associated to a symbol. The function
		may be defined in the global environment or in the local
		environment. This last value takes precedence.
	*/
	case OP_LFUNCTION:	string = "LOCFUNC\t";
				GET_OPARG(n, vector);
				goto OPARG;

	/* OP_FUNCTION	name{symbol}
		Extracts the function associated to a symbol. The function
		may be defined in the global environment or in the local
		environment. This last value takes precedence.
	*/
	case OP_FUNCTION:	string = "SYMFUNC\t";
				GET_DATA(o, vector, data);
				goto ARG;

	/* OP_CLOSE	name{arg}
		Extracts the function associated to a symbol. The function
		may be defined in the global environment or in the local
		environment. This last value takes precedence.
	*/
	case OP_CLOSE:		string = "CLOSE\t";
				GET_DATA(o, vector, data);
				goto ARG;

	/* OP_GO	n{arg}
	   OP_QUOTE	tag-name{symbol}
		Jumps to the tag which is defined at the n-th position in
		the lexical environment. TAG-NAME is kept for debugging
		purposes.
	*/
	case OP_GO:		string = "GO\t";
				GET_OPARG(n, vector);
				GET_DATA(o, vector, data);
				goto OPARG_ARG;

	/* OP_RETURN	n{arg}
		Returns from the block whose record in the lexical environment
		occuppies the n-th position.
	*/
	case OP_RETURN:		string = "RETFROM";
				GET_OPARG(n, vector);
				goto OPARG;

	/* OP_THROW
		Jumps to an enclosing CATCH form whose tag matches the one
		of the THROW. The tag is taken from the stack, while the
		output values are left in VALUES(...).
	*/
	case OP_THROW:		string = "THROW";
				goto NOARG;

	/* OP_JMP	label{arg}
	   OP_JNIL	label{arg}
	   OP_JT	label{arg}
	   OP_JEQ	label{arg}, value{object}
	   OP_JNEQ	label{arg}, value{object}
		Direct or conditional jumps. The conditional jumps are made
		comparing with the value of VALUES(0).
	*/
	case OP_JMP:		string = "JMP\t";
				goto JMP;
	case OP_JNIL:		string = "JNIL\t";
				goto JMP;
	case OP_JT:		string = "JT\t";
	JMP: {			GET_OPARG(m, vector);
				n = vector + m - OPARG_SIZE - base;
				goto OPARG;
	}
	case OP_JEQL:		string = "JEQL\t";
				goto JEQL;
	case OP_JNEQL:		string = "JNEQL\t";
	JEQL: {			GET_DATA(o, vector, data);
				GET_OPARG(m, vector);
				n = vector + m - OPARG_SIZE - base;
				goto OPARG_ARG;
	}
	case OP_NOT:		string = "NOT";
				goto NOARG;

	/* OP_UNBIND	n{arg}
		Undo "n" bindings of lexical variables.
	*/
	case OP_UNBIND:		string = "UNBIND\t";
				GET_OPARG(n, vector);
				goto OPARG;
	/* OP_UNBINDS	n{arg}
		Undo "n" bindings of special variables.
	*/
	case OP_UNBINDS:	string = "UNBINDS\t";
				GET_OPARG(n, vector);
				goto OPARG;
	/* OP_BIND	name{symbol}
	   OP_PBIND	name{symbol}
	   OP_BINDS	name{symbol}
	   OP_PBINDS	name{symbol}
		Binds a lexical or special variable to the either the
		value of VALUES(0), to the first value of the stack, or
		to the n-th value of VALUES(...).
	*/
	case OP_BIND:		string = "BIND\t";
				GET_DATA(o, vector, data);
				goto ARG;
	case OP_PBIND:		string = "PBIND\t";
				GET_DATA(o, vector, data);
				goto ARG;
	case OP_VBIND:		string = "VBIND\t";
				GET_OPARG(n, vector);
				GET_DATA(o, vector, data);
				goto OPARG_ARG;
	case OP_BINDS:		string = "BINDS\t";
				GET_DATA(o, vector, data);
				goto ARG;
	case OP_PBINDS:		string = "PBINDS\t";
				GET_DATA(o, vector, data);
				goto ARG;
	case OP_VBINDS:		string = "VBINDS\t";
				GET_OPARG(n, vector);
				GET_DATA(o, vector, data);
				goto OPARG_ARG;
	/* OP_SETQ	n{arg}
	   OP_PSETQ	n{arg}
	   OP_SETQS	var-name{symbol}
	   OP_PSETQS	var-name{symbol}
		Sets either the n-th local or a special variable VAR-NAME,
		to either the value in VALUES(0) (OP_SETQ[S]) or to the 
		first value on the stack (OP_PSETQ[S]).
	*/
	case OP_SETQ:		string = "SETQ\t";
				GET_OPARG(n, vector);
				goto OPARG;
	case OP_PSETQ:		string = "PSETQ\t";
				GET_OPARG(n, vector);
				goto OPARG;
	case OP_VSETQ:		string = "VSETQ\t";
				GET_OPARG(m, vector);
				o = ecl_make_fixnum(m);
				GET_OPARG(n, vector);
				goto OPARG_ARG;
	case OP_SETQS:		string = "SETQS\t";
				GET_DATA(o, vector, data);
				goto ARG;
	case OP_PSETQS:		string = "PSETQS\t";
				GET_DATA(o, vector, data);
				goto ARG;
	case OP_VSETQS:		string = "VSETQS\t";
				GET_DATA(o, vector, data);
				GET_OPARG(n, vector);
				goto OPARG_ARG;

	case OP_PROGV:		vector = disassemble_progv(bytecodes, vector);
				break;
        case OP_EXIT_PROGV:	print_noarg("PROGV\tEXIT");
        			return vector;

	/* OP_VALUES	n{arg}
		Pop N values from the stack and store them in VALUES(...)
	*/
	case OP_VALUES:		string = "VALUES\t";
				GET_OPARG(n, vector);
				goto OPARG;
	/* OP_NTHVAL
		Set VALUES(0) to the N-th value of the VALUES(...) list.
		The index N-th is extracted from the top of the stack.
	*/
	case OP_NTHVAL:		string = "NTHVAL\t";
				goto NOARG;
	case OP_TAGBODY:	vector = disassemble_tagbody(bytecodes, vector);
				break;
	case OP_PROTECT:	string = "PROTECT\t";
				goto JMP;
	case OP_PROTECT_NORMAL:	string = "PROTECT\tNORMAL";
				goto NOARG;
	case OP_PROTECT_EXIT:	string = "PROTECT\tEXIT";
				goto NOARG;
	case OP_NIL:		string = "QUOTE\tNIL";
				goto NOARG;
	case OP_PUSHNIL:	string = "PUSH\t'NIL";
		    		goto NOARG;
	case OP_STEPIN:		string = "STEP\tIN,";
				GET_DATA(o, vector, data);
				goto ARG;
	case OP_STEPOUT:	string = "STEP\tOUT";
				goto NOARG;

	case OP_CONS:		string = "CONS"; goto NOARG;
	case OP_ENDP:		string = "ENDP\tREG0"; goto NOARG;
	case OP_CAR:		string = "CAR\tREG0"; goto NOARG;
	case OP_CDR:		string = "CDR\tREG0"; goto NOARG;
	case OP_LIST:		string = "LIST\t";
				GET_OPARG(n, vector);
				goto OPARG;
	case OP_LISTA:		string = "LIST*\t";
				GET_OPARG(n, vector);
				goto OPARG;
	case OP_CALLG1:		string = "CALLG1\t";
				GET_DATA(o, vector, data);
				goto ARG;
	case OP_CALLG2:		string = "CALLG2\t";
				GET_DATA(o, vector, data);
				goto ARG;

	default:
		FEerror("Unknown code ~S", 1, ecl_make_fixnum(*(vector-1)));
		return vector;
	NOARG:			print_noarg(string);
				break;
	ARG:			print_noarg(string);
				@prin1(1, o);
				break;
	OPARG:			print_oparg(string, n);
				break;
	OPARG_ARG:		print_oparg_arg(string, n, o);
				break;
	}
	goto BEGIN;
}

cl_object
si_bc_disassemble(cl_object v)
{
	if (type_of(v) == t_bclosure) {
		v = v->bclosure.code;
	}
	if (type_of(v) == t_bytecodes) {
		disassemble_lambda(v);
		@(return v)
	}
	@(return ECL_NIL)
}

cl_object
si_bc_split(cl_object b)
{
	cl_object vector, data, name, lex = ECL_NIL;

	if (type_of(b) == t_bclosure) {
		b = b->bclosure.code;
		lex = b->bclosure.lex;
	}
	if (type_of(b) != t_bytecodes) {
                vector = ECL_NIL;
                data = ECL_NIL;
                name = ECL_NIL;
        } else {
                vector = ecl_alloc_simple_vector(b->bytecodes.code_size *
                                                 sizeof(cl_opcode), ecl_aet_b8);
                vector->vector.self.b8 = (uint8_t*)b->bytecodes.code;
                data = cl_copy_seq(b->bytecodes.data);
                name = b->bytecodes.name;
        }
	@(return lex vector data name)
}

cl_object
si_bc_join(cl_object lex, cl_object code, cl_object data, cl_object name)
{
        cl_object output;
        if (lex != ECL_NIL) {
                output = ecl_alloc_object(t_bclosure);
                output->bclosure.code = si_bc_join(ECL_NIL, code, data, name);
                output->bclosure.lex = lex;
                output->bclosure.entry = _ecl_bclosure_dispatch_vararg;
        } else {
                /* Ensure minimal sanity of data */
                unlikely_if (!ECL_VECTORP(code) ||
                             (code->vector.elttype != ecl_aet_b8)) {
                        FEwrong_type_nth_arg(@[si::bc-join],
                                             0, code,
                                             cl_list(2,
                                                     @'simple-array',
                                                     @'ext::byte8'));
                }
                unlikely_if (!ECL_VECTORP(code) ||
                             (data->vector.elttype != ecl_aet_object)) {
                        FEwrong_type_nth_arg(@[si::bc-join],
                                             0, code,
                                             cl_list(2,
                                                     @'simple-array',
                                                     ECL_T));
                }
                /* Duplicate the vectors and steal their data pointers */
                code = cl_copy_seq(code);
                data = cl_copy_seq(data);
                output = ecl_alloc_object(t_bytecodes);
                output->bytecodes.name = ECL_NIL;
                output->bytecodes.definition = ECL_NIL;
                output->bytecodes.entry = _ecl_bytecodes_dispatch_vararg;
                output->bytecodes.code_size = code->vector.fillp / sizeof(cl_opcode);
                output->bytecodes.code = (void*)code->vector.self.b8;
                output->bytecodes.data = data;
                output->bytecodes.file = ECL_NIL;
                output->bytecodes.file_position = ECL_NIL;
        }
        @(return output)
}