;;;; (ice-9 debugger breakpoints source) -- source location breakpoints ;;; Copyright (C) 2002 Free Software Foundation, Inc. ;;; ;;; This program is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU General Public License as ;;; published by the Free Software Foundation; either version 2, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; General Public License for more details. ;;; ;;; You should have received a copy of the GNU General Public License ;;; along with this software; see the file COPYING. If not, write to ;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, ;;; Boston, MA 02111-1307 USA ;;; ;;; As a special exception, the Free Software Foundation gives permission ;;; for additional uses of the text contained in its release of GUILE. ;;; ;;; The exception is that, if you link the GUILE library with other files ;;; to produce an executable, this does not by itself cause the ;;; resulting executable to be covered by the GNU General Public License. ;;; Your use of that executable is in no way restricted on account of ;;; linking the GUILE library code into it. ;;; ;;; This exception does not however invalidate any other reasons why ;;; the executable file might be covered by the GNU General Public License. ;;; ;;; This exception applies only to the code released by the ;;; Free Software Foundation under the name GUILE. If you copy ;;; code from other Free Software Foundation releases into a copy of ;;; GUILE, as the General Public License permits, the exception does ;;; not apply to the code that you add in this way. To avoid misleading ;;; anyone as to the status of such modified files, you must delete ;;; this exception notice from them. ;;; ;;; If you write modifications of your own for GUILE, it is your choice ;;; whether to permit this exception to apply to your modifications. ;;; If you do not wish that, delete this exception notice. (define-module (ice-9 debugger breakpoints source) #:use-module (ice-9 format) #:use-module (ice-9 debugger breakpoints) #:use-module (ice-9 debugger trap-hooks) #:use-module (ice-9 debugger trc) #:use-module (ice-9 debugger utils) #:use-module (oop goops) #:export ( bp-location bp-expression)) ;;; {Source Breakpoints} ;;; ;;; Breakpoints that activate upon reaching a particular source ;;; location or range of source locations. (define-generic bp-location) (define-generic bp-expression) (define-class () ;; The location of this breakpoint. (location #:accessor bp-location #:init-keyword #:location) ;; The source expression at this breakpoint. (expression #:accessor bp-expression #:init-keyword #:expression) ;; Counter: incremented when the breakpoint is set, decremented when ;; a source expression using this breakpoint applied has been GC'd. (use-count #:accessor bp-use-count #:init-value 0)) (define (location->string filename line column) (format #f "~A:~A:~A" filename (+ line 1) (+ column 1))) (define-method (bp-message (bp ) message port) (format port "~A ~A: ~A: ~S\n" message (bp-number bp) (apply location->string (bp-location bp)) (bp-expression bp))) (define-method (bp-describe (bp ) port) (next-method) (if (zero? (bp-use-count bp)) (format port "\t(this breakpoint is a zombie)\n")) *unspecified*) ;;; Alist of all source breakpoints: ;;; ((LOCATION . BREAKPOINT) ...) ;;; where LOCATION is ;;; (FILE-NAME LINE COLUMN) ;;; Keys are unique according to `equal?'. (define source-breakpoints '()) (define-method (get-breakpoint (filename ) (line ) (column )) (assoc-ref source-breakpoints (list filename line column))) ;;; When the source expression that a breakpoint is attached to is ;;; GC'd, typically because the variable that included it in its value ;;; has been redefined, we'd like to mark the breakpoint as no longer ;;; relevant. We do this by using a property guardian ... (define (make-property-guardian) ;; Return a new property guardian. A property guardian is a ;; combination of a guardian and an object property that accepts KEY ;; -> VALUE associations and gives you back the VALUE when its KEY ;; has been garbage collected. ;; ;; To store an association, call it in the same way as you would an ;; object property: (set! (PROPERTY-GUARDIAN KEY) VALUE). ;; ;; To retrieve the VALUE for a KEY that has been GC'd, call the ;; property guardian in the same way as you would a guardian, with ;; no args: (PROPERTY-GUARDIAN). (let ((p (make-object-property)) (g (make-guardian))) (make-procedure-with-setter (lambda () (let ((collected (g))) (and collected (car collected)))) (lambda (key value) (let ((collectible (list value))) ;; Store the collectible value both as an object property, ;; and in the guardian. (set! (p key) collectible) (g collectible)))))) (define source-breakpoint-guardian (make-property-guardian)) (add-hook! after-gc-hook (lambda () (let loop ((bp (source-breakpoint-guardian))) (if bp (let ((new-use-count (- (bp-use-count bp) 1))) (set! (bp-use-count bp) new-use-count) (if (zero? new-use-count) (bp-message bp "Zombified breakpoint" #t)) (loop (source-breakpoint-guardian))))))) (define (add-breakpoint filename line column expression) (let* ((location (list filename line column)) (bp (make #:location location #:expression (if (pair? expression) ;; The point of this strange looking ;; copy is to copy the expression ;; without its source properties. ;; This is necessary to allow the ;; source properties to be GC'd when ;; the source expression becomes ;; obsolete. (Note that `copy-tree' ;; copies source properties as well!) (cons (car expression) (cdr expression)) expression)))) (set! source-breakpoints (assoc-set! source-breakpoints location bp)) bp)) (define-method (set-breakpoint! behaviour x-as-read (x-pairified )) (let ((filename (source-property x-pairified 'filename)) (line (source-property x-pairified 'line)) (column (source-property x-pairified 'column))) (let ((bp (or (get-breakpoint filename line column) (add-breakpoint filename line column x-as-read)))) (set! (bp-behaviour bp) behaviour) (install-breakpoint x-pairified bp) (bp-message bp "Set breakpoint" #t) bp))) (define (install-breakpoint x bp) ;; Make the necessary connections with the specified expression and ;; its breakpoint. (set-source-property! x 'breakpoint #t) (set! (source-breakpoint-guardian x) bp) (set! (bp-use-count bp) (+ (bp-use-count bp) 1)) (remove/install-source-breakpoint-hooks)) (define remove/install-source-breakpoint-hooks (let ((hooks-installed? #f)) (lambda () (cond ((and hooks-installed? (null? source-breakpoints)) (remove-hook! before-enter-frame-hook source-before-enter-frame-hook) (remove-breakpoint-hook! source-breakpoint-hook) (set! hooks-installed? #f)) ((and (not hooks-installed?) (not (null? source-breakpoints))) (add-hook! before-enter-frame-hook source-before-enter-frame-hook) (add-breakpoint-hook! source-breakpoint-hook) (set! hooks-installed? #t)))))) (define *cont* #f) (define (source-before-enter-frame-hook cont . ignored) (trc 'source-before-enter-frame-hook) (set! *cont* cont)) (define (source-breakpoint-hook) (trc 'source-breakpoint-hook) (let* ((frame (last-stack-frame *cont*)) (source (frame-source frame)) (position (and source (source-position source))) (bp (and position (apply get-breakpoint position)))) (if bp (bp-run bp)))) (define-method (bp-delete! (bp )) (set! source-breakpoints (assoc-remove! source-breakpoints (bp-location bp))) (remove/install-source-breakpoint-hooks) (bp-message bp "Deleted breakpoint" #t) *unspecified*) (register-breakpoint-subclass (lambda () (map cdr source-breakpoints))) (read-hash-extend #\# (lambda (c port) (let (;; Save off port coordinates before reading ;; the following expression, as we'll need ;; to install source coordinates by hand if ;; the expression turns out not to be a ;; pair. (filename (port-filename port)) (line (port-line port)) (column (port-column port))) ;; Now read the marked expression. (let* ((x (read port)) (x' (if (pair? x) x ;; The marked expression isn't a ;; pair, so it can't carry source ;; properties by itself. ;; Therefore we pretend instead ;; to have read `(begin X)', and ;; attach coordinate and ;; breakpoint information to the ;; begin expression. (let ((x' (list begin x))) (set-source-property! x' 'filename filename) (set-source-property! x' 'line line) (set-source-property! x' 'column column) x')))) (break! x x') x')))) ; (define g (make-guardian)) ; (read-hash-extend #\g ; (lambda (c port) ; (let ((x (read port)) ; (l (list 3))) ; (set-source-property! x 'test l) ; (g l) ; x))) ; (add-hook! after-gc-hook ; (lambda () ; (let loop ((obj (g))) ; (if obj ; (begin ; (display "Guardian: ") ; (write obj) ; (newline) ; (loop (g))))))) ;;; (ice-9 debugger breakpoints source) ends here.