diff --git a/module/system/repl/debug.scm b/module/system/repl/debug.scm index fdf6bb7be..a15defc25 100644 --- a/module/system/repl/debug.scm +++ b/module/system/repl/debug.scm @@ -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)))) diff --git a/module/system/vm/frame.scm b/module/system/vm/frame.scm index 017ce3c94..4477c97a6 100644 --- a/module/system/vm/frame.scm +++ b/module/system/vm/frame.scm @@ -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 + (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))) diff --git a/module/system/vm/program.scm b/module/system/vm/program.scm index 3ac73c43c..5344d3882 100644 --- a/module/system/vm/program.scm +++ b/module/system/vm/program.scm @@ -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)