guile18/ice-9/debug.scm

   1 ;;;;    Copyright (C) 1996, 1997, 1998, 1999, 2001, 2006 Free Software Foundation
   2 ;;;;
   3 ;;;; This library is free software; you can redistribute it and/or
   4 ;;;; modify it under the terms of the GNU Lesser General Public
   5 ;;;; License as published by the Free Software Foundation; either
   6 ;;;; version 2.1 of the License, or (at your option) any later version.
   7 ;;;;
   8 ;;;; This library is distributed in the hope that it will be useful,
   9 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  10 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  11 ;;;; Lesser General Public License for more details.
  12 ;;;;
  13 ;;;; You should have received a copy of the GNU Lesser General Public
  14 ;;;; License along with this library; if not, write to the Free Software
  15 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  16 ;;;;
  17 ;;;; The author can be reached at djurfeldt@nada.kth.se
  18 ;;;; Mikael Djurfeldt, SANS/NADA KTH, 10044 STOCKHOLM, SWEDEN
  19 ;;;;
  20 \f
  21
  22 (define-module (ice-9 debug)
  23   :export (frame-number->index trace untrace trace-stack untrace-stack))
  24
  25 \f
  26 ;;; {Misc}
  27 ;;;
  28 (define (frame-number->index n . stack)
  29   (let ((stack (if (null? stack)
  30                    (fluid-ref the-last-stack)
  31                    (car stack))))
  32     (if (memq 'backwards (debug-options))
  33         n
  34         (- (stack-length stack) n 1))))
  35
  36 \f
  37 ;;; {Trace}
  38 ;;;
  39 ;;; This code is just an experimental prototype (e. g., it is not
  40 ;;; thread safe), but since it's at the same time useful, it's
  41 ;;; included anyway.
  42 ;;;
  43 (define traced-procedures '())
  44
  45 (define (trace . args)
  46   (if (null? args)
  47       (nameify traced-procedures)
  48       (begin
  49         (for-each (lambda (proc)
  50                     (if (not (procedure? proc))
  51                         (error "trace: Wrong type argument:" proc))
  52                     (set-procedure-property! proc 'trace #t)
  53                     (if (not (memq proc traced-procedures))
  54                         (set! traced-procedures
  55                               (cons proc traced-procedures))))
  56                   args)
  57         (trap-set! apply-frame-handler trace-entry)
  58         (trap-set! exit-frame-handler trace-exit)
  59         ;; We used to reset `trace-level' here to 0, but this is wrong
  60         ;; if `trace' itself is being traced, since `trace-exit' will
  61         ;; then decrement `trace-level' to -1!  It shouldn't actually
  62         ;; be necessary to set `trace-level' here at all.
  63         (debug-enable 'trace)
  64         (nameify args))))
  65
  66 (define (untrace . args)
  67   (if (and (null? args)
  68            (not (null? traced-procedures)))
  69       (apply untrace traced-procedures)
  70       (begin
  71         (for-each (lambda (proc)
  72                     (set-procedure-property! proc 'trace #f)
  73                     (set! traced-procedures (delq! proc traced-procedures)))
  74                   args)
  75         (if (null? traced-procedures)
  76             (debug-disable 'trace))
  77         (nameify args))))
  78
  79 (define (nameify ls)
  80   (map (lambda (proc)
  81          (let ((name (procedure-name proc)))
  82            (or name proc)))
  83        ls))
  84
  85 (define trace-level 0)
  86 (add-hook! abort-hook (lambda () (set! trace-level 0)))
  87
  88 (define traced-stack-ids (list 'repl-stack))
  89 (define trace-all-stacks? #f)
  90
  91 (define (trace-stack id)
  92   "Add ID to the set of stack ids for which tracing is active.
  93 If `#t' is in this set, tracing is active regardless of stack context.
  94 To remove ID again, use `untrace-stack'.  If you add the same ID twice
  95 using `trace-stack', you will need to remove it twice."
  96   (set! traced-stack-ids (cons id traced-stack-ids))
  97   (set! trace-all-stacks? (memq #t traced-stack-ids)))
  98
  99 (define (untrace-stack id)
 100   "Remove ID from the set of stack ids for which tracing is active."
 101   (set! traced-stack-ids (delq1! id traced-stack-ids))
 102   (set! trace-all-stacks? (memq #t traced-stack-ids)))
 103
 104 (define (trace-entry key cont tail)
 105   (if (or trace-all-stacks?
 106           (memq (stack-id cont) traced-stack-ids))
 107       (let ((cep (current-error-port))
 108             (frame (last-stack-frame cont)))
 109         (if (not tail)
 110             (set! trace-level (+ trace-level 1)))
 111         (let indent ((n trace-level))
 112           (cond ((> n 1) (display "|  " cep) (indent (- n 1)))))
 113         (display-application frame cep)
 114         (newline cep)))
 115   ;; It's not necessary to call the continuation since
 116   ;; execution will continue if the handler returns
 117   ;(cont #f)
 118   )
 119
 120 (define (trace-exit key cont retval)
 121   (if (or trace-all-stacks?
 122           (memq (stack-id cont) traced-stack-ids))
 123       (let ((cep (current-error-port)))
 124         (set! trace-level (- trace-level 1))
 125         (let indent ((n trace-level))
 126           (cond ((> n 0) (display "|  " cep) (indent (- n 1)))))
 127         (write retval cep)
 128         (newline cep))))
 129
 130 \f
 131 ;;; A fix to get the error handling working together with the module system.
 132 ;;;
 133 ;;; XXX - Still needed?
 134 (module-set! the-root-module 'debug-options debug-options)