fix bug in variable-set instruction; ,x prints out program metadata

* module/system/vm/disasm.scm (disassemble-program, disassemble-meta):
  Disassemble program meta information too, if it's there.

* src/vm_system.c (variable-set): Don't try to proxy name information;
  maybe we can do this later, but the code as it was was calling SCM_CAR
  on a variable, which is for the lose.

diff --git a/module/system/vm/disasm.scm b/module/system/vm/disasm.scm
index 92c91bf..c3025fe 100644 (file)
--- a/module/system/vm/disasm.scm
+++ b/module/system/vm/disasm.scm
@@ -47,6 +47,7 @@
         (nexts (arity:nexts arity))
         (bytes (program-bytecode prog))
         (objs  (program-objects prog))
+        (meta  (program-meta prog))
         (exts  (program-external prog)))
     ;; Disassemble this bytecode
     (format #t "Disassembly of ~A:\n\n" prog)
@@ -58,6 +59,8 @@
        (disassemble-objects objs))
     (if (pair? exts)
        (disassemble-externals exts))
+    (if meta
+       (disassemble-meta meta))
     ;; Disassemble other bytecode in it
     (for-each
      (lambda (x)
@@ -103,13 +106,29 @@
       (let ((info (object->string (car l))))
        (print-info n info #f)))))
 
-;; FIXME: update for recent meta changes
+(define-macro (unless test . body)
+  `(if (not ,test) (begin ,@body)))
+
 (define (disassemble-meta meta)
-  (display "Meta info:\n\n")
-  (for-each (lambda (data)
-             (print-info (car data) (list->info (cdr data)) #f))
-           meta)
-  (newline))
+  (let ((bindings (car meta))
+        (sources (cadr meta))
+        (props (cddr meta)))
+    (unless (null? bindings)
+            (display "Bindings:\n\n")
+            (for-each (lambda (b)
+                        (print-info (car b) (list->info (cadr b)) #f))
+                      bindings)
+            (newline))
+    (unless (null? sources)
+            (display "Sources:\n\n")
+            (for-each (lambda (x)
+                        (print-info (car x) (list->info (cdr x)) #f))
+                      sources)
+            (newline))
+    (unless (null? props)
+            (display "Properties:\n\n")
+            (for-each (lambda (x) (print-info #f x #f)) props)
+            (newline))))
 
 (define (original-value addr code objs)
   (define (branch-code? code)

diff --git a/module/system/vm/frame.scm b/module/system/vm/frame.scm
index 574668f..464dffd 100644 (file)
--- a/module/system/vm/frame.scm
+++ b/module/system/vm/frame.scm
@@ -74,13 +74,13 @@
                         (else (vector (abbrev (vector-ref x 0)) '...))))
          (else x)))
   (write (abbrev (cons (program-name frame)
-                      (frame-arguments frame)))))
+                       (frame-arguments frame)))))
 
 (define (program-name frame)
   (let ((prog (frame-program frame))
        (link (frame-dynamic-link frame)))
     (or (object-property prog 'name)
-       (frame-object-name link (1- (frame-address link)) prog)
+        (frame-object-name link (1- (frame-address link)) prog)
        (hash-fold (lambda (s v d) (if (eq? prog (variable-ref v)) s d))
                   prog (module-obarray (current-module))))))
 

diff --git a/src/vm_system.c b/src/vm_system.c
index e97bf95..0e734d8 100644 (file)
--- a/src/vm_system.c
+++ b/src/vm_system.c
@@ -310,7 +310,6 @@ VM_DEFINE_INSTRUCTION (external_set, "external-set", 1, 1, 0)
 VM_DEFINE_INSTRUCTION (variable_set, "variable-set", 0, 1, 0)
 {
   VARIABLE_SET (sp[0], sp[-1]);
-  scm_set_object_property_x (sp[-1], scm_sym_name, SCM_CAR (sp[0]));
   sp -= 2;
   NEXT;
 }