diff options
Diffstat (limited to 'ice-9/debugger/breakpoints/source.scm')
-rw-r--r-- | ice-9/debugger/breakpoints/source.scm | 244 |
1 files changed, 0 insertions, 244 deletions
diff --git a/ice-9/debugger/breakpoints/source.scm b/ice-9/debugger/breakpoints/source.scm index fde746733..e69de29bb 100644 --- a/ice-9/debugger/breakpoints/source.scm +++ b/ice-9/debugger/breakpoints/source.scm @@ -1,244 +0,0 @@ -;;;; (ice-9 debugger breakpoints source) -- source location breakpoints - -;;; Copyright (C) 2002 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 -;; License as published by the Free Software Foundation; either -;; version 2.1 of the License, or (at your option) any later version. -;; -;; This library 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 -;; Lesser General Public License for more details. -;; -;; You should have received a copy of the GNU Lesser General Public -;; License along with this library; if not, write to the Free Software -;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA - -(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 (<source-breakpoint> - 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 <source-breakpoint> (<breakpoint>) - - ;; 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 <source-breakpoint>) 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 <source-breakpoint>) 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 <string>) - (line <integer>) - (column <integer>)) - (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 <source-breakpoint> - #: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 <pair>)) - (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 <source-breakpoint>)) - (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 <source-breakpoint> - (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')))) - ;; Don't allow breakpointed expression to have - ;; a filename property that isn't a string. - (or (string? filename) - (set-source-property! x' 'filename "<unnamed port>")) - (break! x x') - x')))) - -(read-enable 'positions) - -;;; (ice-9 debugger breakpoints source) ends here. |