mirrors/ecl
1
Fork 0
mirror of https://gitlab.com/embeddable-common-lisp/ecl.git synced 2026-03-15 17:30:37 -07:00
Code Issues Projects Releases Packages Wiki Activity

SI:BC-SPLIT and SI:BC-JOIN now as means to deconstruct and join a bytecodes object.

Browse source
This commit is contained in:
Juan Jose Garcia Ripoll 2011-02-04 21:52:05 +01:00
parent 7923040233
commit 1a775ca835
4 changed files with 61 additions and 11 deletions
Download patch file Download diff file Expand all files Collapse all files

69
src/c/disassembler.d
View file

@ -16,6 +16,7 @@
#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);
@ -614,20 +615,66 @@ si_bc_disassemble(cl_object v)
cl_object
si_bc_split(cl_object b)
{
const cl_env_ptr the_env = ecl_process_env();
cl_object vector;
cl_object data;
cl_object lex = Cnil;
cl_object vector, data, name, lex = Cnil;
if (type_of(b) == t_bclosure) {
b = b->bclosure.code;
lex = b->bclosure.lex;
}
if (type_of(b) != t_bytecodes)
@(return Cnil Cnil)
vector = ecl_alloc_simple_vector(b->bytecodes.code_size, aet_b8);
vector->vector.self.b8 = (uint8_t*)b->bytecodes.code;
data = ecl_alloc_simple_vector(b->bytecodes.data_size, aet_object);
data->vector.self.t = b->bytecodes.data;
@(return lex vector data)
if (type_of(b) != t_bytecodes) {
vector = Cnil;
data = Cnil;
name = Cnil;
} else {
vector = ecl_alloc_simple_vector(b->bytecodes.code_size, aet_b8);
vector->vector.self.b8 = (uint8_t*)b->bytecodes.code;
data = ecl_alloc_simple_vector(b->bytecodes.data_size, aet_object);
data->vector.self.t = 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 != Cnil) {
output = ecl_alloc_object(t_bclosure);
output->bclosure.code = si_bc_join(Cnil, code, data, name);
output->bclosure.lex = lex;
output->bclosure.entry = _ecl_bclosure_dispatch_vararg;
} else {
/* Ensure minimal sanity of data */
unlikely_if (Null(cl_simple_vector_p(code)) ||
(code->vector.elttype != aet_b8)) {
FEwrong_type_nth_arg(@[si::bc-join],
0, code,
cl_list(2,
@'simple-array',
@'ext::byte8'));
}
unlikely_if (Null(cl_simple_vector_p(data)) ||
(data->vector.elttype != aet_object)) {
FEwrong_type_nth_arg(@[si::bc-join],
0, output,
cl_list(2,
@'simple-array',
Ct));
}
/* 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 = Cnil;
output->bytecodes.definition = Cnil;
output->bytecodes.entry = _ecl_bytecodes_dispatch_vararg;
output->bytecodes.code_size = code->vector.fillp;
output->bytecodes.code = (void*)code->vector.self.b8;
output->bytecodes.data_size = data->vector.fillp;
output->bytecodes.data = data->vector.self.t;
output->bytecodes.file = Cnil;
output->bytecodes.file_position = Cnil;
}
@(return output)
}

1
src/c/symbols_list.h
View file

@ -1121,6 +1121,7 @@ cl_symbols[] = {
{SYS_ "BASE-STRING-P", SI_ORDINARY, si_base_string_p, 1, OBJNULL},
{SYS_ "BC-DISASSEMBLE", SI_ORDINARY, si_bc_disassemble, 1, OBJNULL},
{SYS_ "BC-SPLIT", SI_ORDINARY, si_bc_split, 1, OBJNULL},
{SYS_ "BC-JOIN", SI_ORDINARY, si_bc_join, 4, OBJNULL},
{SYS_ "BDS-TOP", SI_ORDINARY, si_bds_top, 0, OBJNULL},
{SYS_ "BDS-VAL", SI_ORDINARY, si_bds_val, 1, OBJNULL},
{SYS_ "BDS-VAR", SI_ORDINARY, si_bds_var, 1, OBJNULL},

1
src/c/symbols_list2.h
View file

@ -1121,6 +1121,7 @@ cl_symbols[] = {
{SYS_ "BASE-STRING-P","si_base_string_p"},
{SYS_ "BC-DISASSEMBLE","si_bc_disassemble"},
{SYS_ "BC-SPLIT","si_bc_split"},
{SYS_ "BC-JOIN","si_bc_join"},
{SYS_ "BDS-TOP","si_bds_top"},
{SYS_ "BDS-VAL","si_bds_val"},
{SYS_ "BDS-VAR","si_bds_var"},

1
src/h/external.h
View file

@ -543,6 +543,7 @@ extern ECL_API cl_object _ecl_bclosure_dispatch(cl_narg narg, ...);
extern ECL_API cl_object si_bc_disassemble(cl_object v);
extern ECL_API cl_object si_bc_split(cl_object v);
extern ECL_API cl_object si_bc_join(cl_object lex, cl_object code, cl_object data, cl_object name);
/* error.c */