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)
  29   (if (memq 'backwards (debug-options))
  30       n
  31       (- (stack-length (fluid-ref the-last-stack)) n 1)))
  32
  33 \f
  34 ;;; {Trace}
  35 ;;;
  36 ;;; This code is just an experimental prototype (e. g., it is not
  37 ;;; thread safe), but since it's at the same time useful, it's
  38 ;;; included anyway.
  39 ;;;
  40 (define traced-procedures '())
  41
  42 (define-public (trace . args)
  43   (if (null? args)
  44       (nameify traced-procedures)
  45       (begin
  46         (for-each (lambda (proc)
  47                     (if (not (procedure? proc))
  48                         (error "trace: Wrong type argument:" proc))
  49                     (set-procedure-property! proc 'trace #t)
  50                     (if (not (memq proc traced-procedures))
  51                         (set! traced-procedures
  52                               (cons proc traced-procedures))))
  53                   args)
  54         (set! apply-frame-handler trace-entry)
  55         (set! exit-frame-handler trace-exit)
  56         (set! trace-level 0)
  57         (debug-enable 'trace)
  58         (nameify args))))
  59
  60 (define-public (untrace . args)
  61   (if (and (null? args)
  62            (not (null? traced-procedures)))
  63       (apply untrace traced-procedures)
  64       (begin
  65         (for-each (lambda (proc)
  66                     (set-procedure-property! proc 'trace #f)
  67                     (set! traced-procedures (delq! proc traced-procedures)))
  68                   args)
  69         (if (null? traced-procedures)
  70             (debug-disable 'trace))
  71         (nameify args))))
  72
  73 (define (nameify ls)
  74   (map (lambda (proc)
  75          (let ((name (procedure-name proc)))
  76            (or name proc)))
  77        ls))
  78
  79 (define trace-level 0)
  80 (add-hook! abort-hook (lambda () (set! trace-level 0)))
  81
  82 (define (trace-entry key cont tail)
  83   (if (eq? (stack-id cont) 'repl-stack)
  84       (let ((cep (current-error-port))
  85             (frame (last-stack-frame cont)))
  86         (if (not tail)
  87             (set! trace-level (+ trace-level 1)))
  88         (let indent ((n trace-level))
  89           (cond ((> n 1) (display "|  " cep) (indent (- n 1)))))
  90         (display-application frame cep)))
  91   ;; It's not necessary to call the continuation since
  92   ;; execution will continue if the handler returns
  93   ;(cont #f)
  94   )
  95
  96 (define (trace-exit key cont retval)
  97   (if (eq? (stack-id cont) 'repl-stack)
  98       (let ((cep (current-error-port)))
  99         (set! trace-level (- trace-level 1))
 100         (let indent ((n trace-level))
 101           (cond ((> n 0) (display "|  " cep) (indent (- n 1)))))
 102         (write retval cep)
 103         (newline cep))))
 104
 105 \f
 106 ;;; A fix to get the error handling working together with the module system.
 107 ;;;
 108 (variable-set! (builtin-variable 'debug-options) debug-options)
 109
 110 \f
 111
 112 (debug-enable 'debug)
 113 (read-enable 'positions)