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

correctly disassemble program bindings (arguments, locals, externals)

Browse source 
* module/system/vm/disasm.scm (disassemble-bindings): New function,
  properly disassembles the bindings data. Neat!
This commit is contained in:
Andy Wingo 2008-09-12 17:55:33 +02:00
parent e91e07811a
commit 709f95afcd
1 changed files with 33 additions and 7 deletions
Download patch file Download diff file Expand all files Collapse all files

40
module/system/vm/disasm.scm
View file

@ -60,7 +60,7 @@
(if (pair? exts) (if (pair? exts)
(disassemble-externals exts)) (disassemble-externals exts))
(if meta (if meta
(disassemble-meta (meta))) (disassemble-meta prog (meta)))
;; Disassemble other bytecode in it ;; Disassemble other bytecode in it
(for-each (for-each
(lambda (x) (lambda (x)
@ -109,16 +109,42 @@
(define-macro (unless test . body) (define-macro (unless test . body)
`(if (not ,test) (begin ,@body))) `(if (not ,test) (begin ,@body)))
(define (disassemble-meta meta) (define (disassemble-bindings prog bindings)
(let* ((nargs (arity:nargs (program-arity prog)))
(args (if (zero? nargs) '() (cdar bindings)))
(nonargs (if (zero? nargs) bindings (cdr bindings))))
(unless (null? args)
(display "Arguments:\n\n")
(for-each (lambda (bind n)
(print-info n
(format #f "~a[~a]: ~a"
(if (cadr bind) 'local 'external)
(caddr bind) (car bind))
#f))
args
(iota nargs))
(newline))
(unless (null? nonargs)
(display "Bindings:\n\n")
(for-each (lambda (start binds end)
(for-each (lambda (bind)
(print-info (format #f "~a-~a" start end)
(format #f "~a[~a]: ~a"
(if (cadr bind) 'local 'external)
(caddr bind) (car bind))
#f))
binds))
(map car (filter cdr nonargs))
(map cdr (filter cdr nonargs))
(map car (filter (lambda (x) (not (cdr x))) nonargs)))
(newline))))
(define (disassemble-meta program meta)
(let ((bindings (car meta)) (let ((bindings (car meta))
(sources (cadr meta)) (sources (cadr meta))
(props (cddr meta))) (props (cddr meta)))
(unless (null? bindings) (unless (null? bindings)
(display "Bindings:\n\n") (disassemble-bindings program bindings))
(for-each (lambda (b)
(print-info (car b) (list->info (cadr b)) #f))
bindings)
(newline))
(unless (null? sources) (unless (null? sources)
(display "Sources:\n\n") (display "Sources:\n\n")
(for-each (lambda (x) (for-each (lambda (x)