higher level disassemble function.

* lisplib.c (asm_set_entries): Autoload on usr:disassemble.

* share/txr/stdlib/asm.tl (assembler): Drop initializer
from bstr slot. Requires complex initialization for the
case when the buf is supplied by the constructor caller
for the sake of disassembling existing code.
(assembler :postinit): Handle cases when only one of
buf or bstr are set, and when both are not set,
for the greatest flexibility.
(disassemble-c-d, disassemble): New functions.

* vm.c (vm_desc_datavec): New static function.
(vm_init): Registered vm-desc-datavec intrinsic.

3 files changed, 32 insertions, 4 deletions

diff --git a/lisplib.c b/lisplib.c
index 50c52356..a8e68c4a 100644
--- a/lisplib.c
+++ b/lisplib.c
@@ -630,12 +630,17 @@ static val asm_instantiate(val set_fun)
 
 static val asm_set_entries(val dlt, val fun)
 {
-  val name[] = {
+  val sys_name[] = {
     lit("assembler"),
     nil
   };
+  val name[] = {
+    lit("disassemble"),
+    nil
+  };
 
-  set_dlt_entries_sys(dlt, name, fun);
+  set_dlt_entries_sys(dlt, sys_name, fun);
+  set_dlt_entries(dlt, name, fun);
   return nil;
 }
 
diff --git a/share/txr/stdlib/asm.tl b/share/txr/stdlib/asm.tl
index ff7dfb87..ce092c1e 100644
--- a/share/txr/stdlib/asm.tl
+++ b/share/txr/stdlib/asm.tl
@@ -19,7 +19,7 @@
 
 (defstruct assembler nil
   buf
-  (bstr (make-buf-stream))
+  bstr
   (labdef (hash))
   (labref (hash))
   (:static imm-width (relate '(si mi bi) '(10 16 32)))
@@ -37,7 +37,11 @@
                                   "any object"))))
 
 (defmeth assembler :postinit (me)
-  (set me.buf (get-buf-from-stream me.bstr)))
+  (cond
+    (me.buf (set me.bstr (make-buf-stream me.buf)))
+    (me.bstr (set me.buf (get-buf-from-stream me.bstr)))
+    (t (set me.bstr (make-buf-stream)
+            me.buf (get-buf-from-stream me.bstr)))))
 
 (defmeth assembler cur-pos (me)
   (seek-stream me.bstr 0 :from-current))
@@ -585,3 +589,15 @@
                   (add (operand-to-sym x))
                   (unless (minusp fix)
                     (add (operand-to-sym y))))))))))))
+
+(defun disassemble-c-d (code data *stdout*)
+  (let ((asm (new assembler buf code)))
+    (put-line "data:")
+    (mapdo (do format t "  d~,02x: ~s\n" @1 @2) (range 0) data)
+    (put-line "code:")
+    asm.(dis-listing)))
+
+(defun usr:disassemble (obj : (stream *stdout*))
+  (typecase obj
+    (vm-desc (disassemble-c-d (vm-desc-bytecode obj) (vm-desc-datavec obj) stream))
+    (t (error "~s: not a compiled object: ~s" 'vm-disassemble obj))))
diff --git a/vm.c b/vm.c
index 5c3bfc9f..09bdfb2c 100644
--- a/vm.c
+++ b/vm.c
@@ -151,6 +151,12 @@ static val vm_desc_bytecode(val desc)
   return vd->bytecode;
 }
 
+static val vm_desc_datavec(val desc)
+{
+  struct vm_desc *vd = vm_desc_struct(desc);
+  return vd->datavec;
+}
+
 static void vm_desc_mark(val obj)
 {
   struct vm_desc *vd = coerce(struct vm_desc *, obj->co.handle);
@@ -825,5 +831,6 @@ void vm_init(void)
   vm_closure_s = intern(lit("vm-closure"), system_package);
   reg_fun(intern(lit("vm-make-desc"), system_package), func_n4(vm_make_desc));
   reg_fun(intern(lit("vm-desc-bytecode"), system_package), func_n1(vm_desc_bytecode));
+  reg_fun(intern(lit("vm-desc-datavec"), system_package), func_n1(vm_desc_datavec));
   reg_fun(intern(lit("vm-execute-toplevel"), system_package), func_n1(vm_execute_toplevel));
 }