From 81aae20202b46e58b315dbea6b12f277b222f035 Mon Sep 17 00:00:00 2001
From: Andy Wingo <wingo@pobox.com>
Date: Fri, 8 Aug 2008 00:26:17 +0200
Subject: [PATCH] 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.
---
 module/system/vm/disasm.scm | 31 +++++++++++++++++++++++++------
 module/system/vm/frame.scm  |  4 ++--
 src/vm_system.c             |  1 -
 3 files changed, 27 insertions(+), 9 deletions(-)

diff --git a/module/system/vm/disasm.scm b/module/system/vm/disasm.scm
index 92c91bf35..c3025fe1b 100644
--- 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 574668f62..464dffd06 100644
--- 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 e97bf9556..0e734d821 100644
--- 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;
 }