ice-9/debugger/breakpoints/procedural.scm

   1 ;;;; (ice-9 debugger breakpoints procedural) -- procedural breakpoints
   2
   3 ;;; Copyright (C) 2002 Free Software Foundation, Inc.
   4 ;;;
   5 ;;; This program is free software; you can redistribute it and/or
   6 ;;; modify it under the terms of the GNU General Public License as
   7 ;;; published by the Free Software Foundation; either version 2, or
   8 ;;; (at your option) any later version.
   9 ;;;
  10 ;;; This program is distributed in the hope that it will be useful,
  11 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  13 ;;; General Public License for more details.
  14 ;;;
  15 ;;; You should have received a copy of the GNU General Public License
  16 ;;; along with this software; see the file COPYING.  If not, write to
  17 ;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
  18 ;;; Boston, MA 02111-1307 USA
  19 ;;;
  20 ;;; As a special exception, the Free Software Foundation gives permission
  21 ;;; for additional uses of the text contained in its release of GUILE.
  22 ;;;
  23 ;;; The exception is that, if you link the GUILE library with other files
  24 ;;; to produce an executable, this does not by itself cause the
  25 ;;; resulting executable to be covered by the GNU General Public License.
  26 ;;; Your use of that executable is in no way restricted on account of
  27 ;;; linking the GUILE library code into it.
  28 ;;;
  29 ;;; This exception does not however invalidate any other reasons why
  30 ;;; the executable file might be covered by the GNU General Public License.
  31 ;;;
  32 ;;; This exception applies only to the code released by the
  33 ;;; Free Software Foundation under the name GUILE.  If you copy
  34 ;;; code from other Free Software Foundation releases into a copy of
  35 ;;; GUILE, as the General Public License permits, the exception does
  36 ;;; not apply to the code that you add in this way.  To avoid misleading
  37 ;;; anyone as to the status of such modified files, you must delete
  38 ;;; this exception notice from them.
  39 ;;;
  40 ;;; If you write modifications of your own for GUILE, it is your choice
  41 ;;; whether to permit this exception to apply to your modifications.
  42 ;;; If you do not wish that, delete this exception notice.
  43
  44 (define-module (ice-9 debugger breakpoints procedural)
  45   #:use-module (ice-9 format)
  46   #:use-module (oop goops)
  47   #:use-module (ice-9 debugger breakpoints)
  48   #:use-module (ice-9 debugger trc)
  49   #:use-module (ice-9 debugger trap-hooks)
  50   #:export (<procedure-breakpoint>
  51             bp-procedure))
  52
  53 ;;; {Procedure Breakpoints}
  54 ;;;
  55 ;;; Breakpoints that activate upon application of a particular
  56 ;;; procedure.
  57
  58 (define-generic bp-procedure)
  59 (define-generic bp-hook)
  60
  61 (define-class <procedure-breakpoint> (<breakpoint>)
  62
  63   ;; The procedure to which this breakpoint applies.
  64   (procedure #:accessor bp-procedure
  65              #:init-keyword #:procedure)
  66
  67   ;; The procedure that is registered as a trace hook for this
  68   ;; breakpoint, stored here so that we can easily deregister it.
  69   (hook #:accessor bp-hook))
  70
  71 (define (nameify proc)
  72   (or (procedure-name proc) proc))
  73
  74 (define-method (bp-message (bp <procedure-breakpoint>) message port)
  75   (format port
  76           "~A ~A: [~A]\n"
  77           message
  78           (bp-number bp)
  79           (nameify (bp-procedure bp))))
  80
  81 ;;; Alist of all procedure breakpoints:
  82 ;;;   ((PROCEDURE . BREAKPOINT) ...)
  83 ;;; Keys are unique according to `eq?'.
  84 (define procedure-breakpoints '())
  85
  86 (define-method (get-breakpoint (proc <procedure>))
  87   (assq-ref procedure-breakpoints proc))
  88
  89 (define *proc* #f)
  90
  91 (add-hook! before-apply-frame-hook
  92            (lambda (cont tail?)
  93              (trc 'before-apply-frame-hook tail?)
  94              ;(set! *expr* #f)
  95              (set! *proc* (frame-procedure (last-stack-frame cont)))))
  96
  97 (define (add-breakpoint proc)
  98   (let* ((bp (make <procedure-breakpoint> #:procedure proc))
  99          (hook (lambda ()
 100                  (if (eq? proc *proc*)
 101                      (bp-run bp)))))
 102     (set-procedure-property! proc 'trace #t)
 103     (set! (bp-hook bp) hook)
 104     (add-trace-hook! hook)
 105     (set! procedure-breakpoints (assq-set! procedure-breakpoints proc bp))
 106     bp))
 107
 108 (define-method (set-breakpoint! behaviour (proc <procedure>))
 109   (let ((bp (or (get-breakpoint proc)
 110                 (add-breakpoint proc))))
 111     (set! (bp-behaviour bp) behaviour)
 112     (bp-message bp "Set breakpoint" #t)
 113     bp))
 114
 115 (define-method (bp-delete! (bp <procedure-breakpoint>))
 116   (let ((proc (bp-procedure bp)))
 117     (set! procedure-breakpoints
 118           (assq-remove! procedure-breakpoints proc))
 119     (set-procedure-property! proc 'trace #f)
 120     (remove-trace-hook! (bp-hook bp))
 121     (bp-message bp "Deleted breakpoint" #t))
 122   *unspecified*)
 123
 124 (register-breakpoint-subclass <procedure-breakpoint>
 125                               (lambda ()
 126                                 (map cdr procedure-breakpoints)))
 127
 128 ;;; (ice-9 debugger breakpoints procedure) ends here.