[Guile-commits] GNU Guile branch, string_abstraction2, updated. release_1-9-1-142-g78647c1

[Michael Gran]

This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".

http://git.savannah.gnu.org/cgit/guile.git/commit/?id=78647c15f003812f26056c879fb0b7120d35ab80

The branch, string_abstraction2 has been updated
       via  78647c15f003812f26056c879fb0b7120d35ab80 (commit)
      from  12a15195c62ba35e3441f0c1e294a4e724fe31d6 (commit)

Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.

- Log -----------------------------------------------------------------
commit 78647c15f003812f26056c879fb0b7120d35ab80
Author: Michael Gran <address@hidden>
Date:   Wed Aug 12 00:14:46 2009 -0700

    Fix disassembly of strings and symbols
    
    * module/language/assembly/decompile-bytecode.scm (decode-bytecode):
      fix disassembly of strings, symbols, keywords, and defines

-----------------------------------------------------------------------

Summary of changes:
 module/language/assembly/decompile-bytecode.scm |   24 +++++++++++++++++++++-
 1 files changed, 22 insertions(+), 2 deletions(-)

diff --git a/module/language/assembly/decompile-bytecode.scm 
b/module/language/assembly/decompile-bytecode.scm
index 0e34ab4..2f58422 100644
--- a/module/language/assembly/decompile-bytecode.scm
+++ b/module/language/assembly/decompile-bytecode.scm
@@ -24,6 +24,7 @@
   #:use-module (srfi srfi-4)
   #:use-module (rnrs bytevector)
   #:use-module (language assembly)
+  #:use-module ((system vm objcode) #:select (byte-order))
   #:export (decompile-bytecode))
 
 (define (decompile-bytecode x env opts)
@@ -95,13 +96,26 @@
                   (lp (cons exp out))))))))))
 
 (define (decode-bytecode pop)
+  (define (get1 bytes-per-char)
+    (if (= bytes-per-char 1)
+        (pop)
+        (let ((a (pop))
+              (b (pop))
+              (c (pop))
+              (d (pop)))
+          (if (= byte-order 1234)
+              (+ (ash d 24) (ash c 16) (ash b 8) a)            
+              (+ (ash a 24) (ash b 16) (ash c 8) d)))))
   (and=> (pop)
          (lambda (opcode)
            (let ((inst (opcode->instruction opcode)))
              (cond
               ((eq? inst 'load-program)
                (decode-load-program pop))
+
               ((< (instruction-length inst) 0)
+               ;; the negative length indicates a variable length
+               ;; instruction
                (let* ((make-sequence
                        (if (eq? inst 'load-array)
                            make-bytevector
@@ -111,15 +125,21 @@
                            bytevector-u8-set!
                            (lambda (str pos value)
                              (string-set! str pos (integer->char value)))))
-
                       (len (let* ((a (pop)) (b (pop)) (c (pop)))
                              (+ (ash a 16) (ash b 8) c)))
+                      (bytes-per-count
+                       (if (or (eq? inst 'load-string)
+                               (eq? inst 'load-symbol)
+                               (eq? inst 'load-keyword)
+                               (eq? inst 'define))
+                           (pop)
+                           1))
                       (seq (make-sequence len)))
                  (let lp ((i 0))
                    (if (= i len)
                        `(,inst ,seq)
                        (begin
-                         (sequence-set! seq i (pop))
+                         (sequence-set! seq i (get1 bytes-per-count))
                          (lp (1+ i)))))))
               (else
                ;; fixed length


hooks/post-receive
-- 
GNU Guile