ice-9/debug.scm

   1 ;;;;    Copyright (C) 1996, 1997, 1998 Free Software Foundation
   2 ;;;;
   3 ;;;; This program is free software; you can redistribute it and/or modify
   4 ;;;; it under the terms of the GNU General Public License as published by
   5 ;;;; the Free Software Foundation; either version 2, or (at your option)
   6 ;;;; any later version.
   7 ;;;;
   8 ;;;; This program 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
  11 ;;;; GNU General Public License for more details.
  12 ;;;;
  13 ;;;; You should have received a copy of the GNU General Public License
  14 ;;;; along with this software; see the file COPYING.  If not, write to
  15 ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
  16 ;;;; Boston, MA 02111-1307 USA
  17 ;;;;
  18 ;;;; The author can be reached at djurfeldt@nada.kth.se
  19 ;;;; Mikael Djurfeldt, SANS/NADA KTH, 10044 STOCKHOLM, SWEDEN
  20 ;;;;
  21 \f
  22
  23 (define-module (ice-9 debug))
  24
  25 \f
  26 ;;; {Misc}
  27 ;;;
  28 (define-public (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-public (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         (set! apply-frame-handler trace-entry)
  58         (set! exit-frame-handler trace-exit)
  59         (set! trace-level 0)
  60         (debug-enable 'trace)
  61         (nameify args))))
  62
  63 (define-public (untrace . args)
  64   (if (and (null? args)
  65            (not (null? traced-procedures)))
  66       (apply untrace traced-procedures)
  67       (begin
  68         (for-each (lambda (proc)
  69                     (set-procedure-property! proc 'trace #f)
  70                     (set! traced-procedures (delq! proc traced-procedures)))
  71                   args)
  72         (if (null? traced-procedures)
  73             (debug-disable 'trace))
  74         (nameify args))))
  75
  76 (define (nameify ls)
  77   (map (lambda (proc)
  78          (let ((name (procedure-name proc)))
  79            (or name proc)))
  80        ls))
  81
  82 (define trace-level 0)
  83 (add-hook! abort-hook (lambda () (set! trace-level 0)))
  84
  85 (define (trace-entry key cont tail)
  86   (if (eq? (stack-id cont) 'repl-stack)
  87       (let ((cep (current-error-port))
  88             (frame (last-stack-frame cont)))
  89         (if (not tail)
  90             (set! trace-level (+ trace-level 1)))
  91         (let indent ((n trace-level))
  92           (cond ((> n 1) (display "|  " cep) (indent (- n 1)))))
  93         (display-application frame cep)
  94         (newline cep)))
  95   ;; It's not necessary to call the continuation since
  96   ;; execution will continue if the handler returns
  97   ;(cont #f)
  98   )
  99
 100 (define (trace-exit key cont retval)
 101   (if (eq? (stack-id cont) 'repl-stack)
 102       (let ((cep (current-error-port)))
 103         (set! trace-level (- trace-level 1))
 104         (let indent ((n trace-level))
 105           (cond ((> n 0) (display "|  " cep) (indent (- n 1)))))
 106         (write retval cep)
 107         (newline cep))))
 108
 109 \f
 110 ;;; A fix to get the error handling working together with the module system.
 111 ;;;
 112 (variable-set! (builtin-variable 'debug-options) debug-options)
 113
 114 \f
 115
 116 (debug-enable 'debug)
 117 (read-enable 'positions)