mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-11 14:21:10 +02:00
Code Activity

Fix disassembly of strings and symbols

Browse source 
* module/language/assembly/decompile-bytecode.scm (decode-bytecode):
  fix disassembly of strings, symbols, keywords, and defines
This commit is contained in:
Michael Gran 2009-08-12 00:26:12 -07:00
parent 744c8724a7
commit 6cf4830798
1 changed files with 22 additions and 2 deletions
Download patch file Download diff file Expand all files Collapse all files

24
module/language/assembly/decompile-bytecode.scm
View file

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