From 1a775ca8356e22472d549506e121f01254e48eea Mon Sep 17 00:00:00 2001
From: Juan Jose Garcia Ripoll <jjgarcia@users.sourceforge.net>
Date: Fri, 4 Feb 2011 21:52:05 +0100
Subject: [PATCH] SI:BC-SPLIT and SI:BC-JOIN now as means to deconstruct and
 join a bytecodes object.

---
 src/c/disassembler.d  | 69 ++++++++++++++++++++++++++++++++++++-------
 src/c/symbols_list.h  |  1 +
 src/c/symbols_list2.h |  1 +
 src/h/external.h      |  1 +
 4 files changed, 61 insertions(+), 11 deletions(-)

diff --git a/src/c/disassembler.d b/src/c/disassembler.d
index 6c22bfd9f..c795baf5f 100644
--- a/src/c/disassembler.d
+++ b/src/c/disassembler.d
@@ -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)
 }
diff --git a/src/c/symbols_list.h b/src/c/symbols_list.h
index fca211792..195695e7c 100755
--- a/src/c/symbols_list.h
+++ b/src/c/symbols_list.h
@@ -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},
diff --git a/src/c/symbols_list2.h b/src/c/symbols_list2.h
index 507443908..44d62affc 100644
--- a/src/c/symbols_list2.h
+++ b/src/c/symbols_list2.h
@@ -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"},
diff --git a/src/h/external.h b/src/h/external.h
index b845d499c..6f1c20ff1 100755
--- a/src/h/external.h
+++ b/src/h/external.h
@@ -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 */