mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-29 19:30:36 +02:00
Code Activity

Update frame-bindings interface

Browse source 
* module/system/repl/debug.scm (print-locals): Update to work with new
  interface.
  (frame->module): Update.  Still doesn't work due to lack of
  `program-module', though.

* module/system/vm/program.scm (make-binding, binding:name)
  (binding:definition-offset, program-arity-bindings-for-ip): Remove
  these.

* module/system/vm/frame.scm (<binding>): New type.
  (available-bindings): Return a list of <binding> instances.
  (frame-lookup-binding, frame-binding-set!, frame-binding-ref):
  (frame-environment, frame-object-name): Adapt.
This commit is contained in:
Andy Wingo 2014-04-16 13:58:17 +02:00
parent c4c9bfffd7
commit 1a2711a848
3 changed files with 29 additions and 37 deletions
Download patch file Download diff file Expand all files Collapse all files

22
module/system/repl/debug.scm
View file

@ -1,6 +1,6 @@
;;; Guile VM debugging facilities
;;; Copyright (C) 2001, 2009, 2010, 2011, 2013 Free Software Foundation, Inc.
;;; Copyright (C) 2001, 2009, 2010, 2011, 2013, 2014 Free Software Foundation, Inc.
;;;
;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Lesser General Public
@ -113,14 +113,10 @@
(format port "~aLocal variables:~%" per-line-prefix)
(for-each
(lambda (binding)
(let ((v (let ((x (frame-local-ref frame (binding:index binding))))
(if (binding:boxed? binding)
(variable-ref x)
x))))
(let ((v (frame-local-ref frame (binding-slot binding))))
(display per-line-prefix port)
(run-hook before-print-hook v)
(format port "~a~:[~; (boxed)~] = ~v:@y\n"
(binding:name binding) (binding:boxed? binding) width v)))
(format port "~a = ~v:@y\n" (binding-name binding) width v)))
(frame-bindings frame))))))
(define* (print-frame frame #:optional (port (current-output-port))
@ -171,20 +167,20 @@
(define (frame->module frame)
(let ((proc (frame-procedure frame)))
(if #f
;; FIXME!
;; FIXME: program-module does not exist.
(let* ((mod (or (program-module proc) (current-module)))
(mod* (make-module)))
(module-use! mod* mod)
(for-each
(lambda (binding)
(let* ((x (frame-local-ref frame (binding:index binding)))
(var (if (binding:boxed? binding) x (make-variable x))))
(let* ((x (frame-local-ref frame (binding-slot binding)))
(var (if (variable? x) x (make-variable x))))
(format #t
"~:[Read-only~;Mutable~] local variable ~a = ~70:@y\n"
(binding:boxed? binding)
(binding:name binding)
(not (variable? x))
(binding-name binding)
(if (variable-bound? var) (variable-ref var) var))
(module-add! mod* (binding:name binding) var)))
(module-add! mod* (binding-name binding) var)))
(frame-bindings frame))
mod*)
(current-module))))

26
module/system/vm/frame.scm
View file

@ -24,15 +24,27 @@
#:use-module (system vm program)
#:use-module (system vm debug)
#:use-module (system vm disassembler)
#:use-module (srfi srfi-9)
#:use-module (rnrs bytevectors)
#:use-module (ice-9 match)
#:export (frame-bindings
#:export (binding-index
binding-name
binding-slot
frame-bindings
frame-lookup-binding
frame-binding-ref frame-binding-set!
frame-call-representation
frame-environment
frame-object-binding frame-object-name))
(define-record-type <binding>
(make-binding idx name slot)
binding?
(idx binding-index)
(name binding-name)
(slot binding-slot))
(define (parse-code code)
(let ((len (bytevector-length code)))
(let lp ((pos 0) (out '()))
@ -212,7 +224,7 @@
(if n
(match (vector-ref defs n)
(#(name def-offset slot)
(acons name slot (lp (1+ n)))))
(cons (make-binding n name slot) (lp (1+ n)))))
'()))))
(lp (1+ n) (- offset (vector-ref parsed n)))))))
@ -228,21 +240,21 @@
(let lp ((bindings (frame-bindings frame)))
(cond ((null? bindings)
#f)
((eq? (binding:name (car bindings)) var)
((eq? (binding-name (car bindings)) var)
(car bindings))
(else
(lp (cdr bindings))))))
(define (frame-binding-set! frame var val)
(frame-local-set! frame
(binding:index
(binding-slot
(or (frame-lookup-binding frame var)
(error "variable not bound in frame" var frame)))
val))
(define (frame-binding-ref frame var)
(frame-local-ref frame
(binding:index
(binding-slot
(or (frame-lookup-binding frame var)
(error "variable not bound in frame" var frame)))))
@ -342,7 +354,7 @@
(define (frame-environment frame)
(map (lambda (binding)
(cons (binding:name binding) (frame-binding-ref frame binding)))
(cons (binding-name binding) (frame-binding-ref frame binding)))
(frame-bindings frame)))
(define (frame-object-binding frame obj)
@ -351,5 +363,5 @@
(and (pair? bs) (car bs)))))
(define (frame-object-name frame obj)
(cond ((frame-object-binding frame obj) => binding:name)
(cond ((frame-object-binding frame obj) => binding-name)
(else #f)))

18
module/system/vm/program.scm
View file

@ -24,10 +24,7 @@
#:use-module (rnrs bytevectors)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
#:export (binding:name binding:definition-offset binding:slot
program-arity-bindings-for-ip
source:addr source:line source:column source:file
#:export (source:addr source:line source:column source:file
source:line-for-user
program-sources program-sources-pre-retire program-source
@ -59,12 +56,6 @@
(define (program-properties program)
(find-program-properties (program-code program)))
(define (make-binding name def-offset slot)
(vector name def-offset slot))
(define (binding:name b) (vector-ref b 0))
(define (binding:definition-offset b) (vector-ref b 1))
(define (binding:slot b) (vector-ref b 2))
(define (source:addr source)
(car source))
(define (source:file source)
@ -124,13 +115,6 @@
(source-column source)))
(find-program-sources (program-code proc))))
(define (program-arity-bindings-for-ip prog ip)
(or-map (lambda (arity)
(and (<= (arity-low-pc arity) ip)
(< ip (arity-high-pc arity))
(arity-definitions arity)))
(or (find-program-arities (program-code prog)) '())))
(define (arity:start a)
(match a ((start end . _) start) (_ (error "bad arity" a))))
(define (arity:end a)