diff options
Diffstat (limited to 'ice-9/debug.scm')
-rw-r--r-- | ice-9/debug.scm | 113 |
1 files changed, 0 insertions, 113 deletions
diff --git a/ice-9/debug.scm b/ice-9/debug.scm deleted file mode 100644 index 9dadcf050..000000000 --- a/ice-9/debug.scm +++ /dev/null @@ -1,113 +0,0 @@ -;;;; Copyright (C) 1996, 1997 Free Software Foundation -;;;; -;;;; This program is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License as published by -;;;; the Free Software Foundation; either version 2, or (at your option) -;;;; any later version. -;;;; -;;;; This program 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 General Public License for more details. -;;;; -;;;; You should have received a copy of the GNU General Public License -;;;; along with this software; see the file COPYING. If not, write to -;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, -;;;; Boston, MA 02111-1307 USA -;;;; -;;;; The author can be reached at djurfeldt@nada.kth.se -;;;; Mikael Djurfeldt, SANS/NADA KTH, 10044 STOCKHOLM, SWEDEN -;;;; - - -(define-module (ice-9 debug)) - - -;;; {Misc} -;;; -(define-public (frame-number->index n) - (if (memq 'backwards (debug-options)) - n - (- (stack-length (fluid-ref the-last-stack)) n 1))) - - -;;; {Trace} -;;; -;;; This code is just an experimental prototype (e. g., it is not -;;; thread safe), but since it's at the same time useful, it's -;;; included anyway. -;;; -(define traced-procedures '()) - -(define-public (trace . args) - (if (null? args) - (nameify traced-procedures) - (begin - (for-each (lambda (proc) - (if (not (procedure? proc)) - (error "trace: Wrong type argument:" proc)) - (set-procedure-property! proc 'trace #t) - (if (not (memq proc traced-procedures)) - (set! traced-procedures - (cons proc traced-procedures)))) - args) - (set! apply-frame-handler trace-entry) - (set! exit-frame-handler trace-exit) - (set! trace-level 0) - (debug-enable 'trace) - (nameify args)))) - -(define-public (untrace . args) - (if (and (null? args) - (not (null? traced-procedures))) - (apply untrace traced-procedures) - (begin - (for-each (lambda (proc) - (set-procedure-property! proc 'trace #f) - (set! traced-procedures (delq! proc traced-procedures))) - args) - (if (null? traced-procedures) - (debug-disable 'trace)) - (nameify args)))) - -(define (nameify ls) - (map (lambda (proc) - (let ((name (procedure-name proc))) - (or name proc))) - ls)) - -(define trace-level 0) -(add-hook! abort-hook (lambda () (set! trace-level 0))) - -(define (trace-entry key cont tail) - (if (eq? (stack-id cont) 'repl-stack) - (let ((cep (current-error-port)) - (frame (last-stack-frame cont))) - (if (not tail) - (set! trace-level (+ trace-level 1))) - (let indent ((n trace-level)) - (cond ((> n 1) (display "| " cep) (indent (- n 1))))) - (display-application frame cep))) - ;; It's not necessary to call the continuation since - ;; execution will continue if the handler returns - ;(cont #f) - ) - -(define (trace-exit key cont retval) - (if (eq? (stack-id cont) 'repl-stack) - (let ((cep (current-error-port))) - (set! trace-level (- trace-level 1)) - (let indent ((n trace-level)) - (cond ((> n 0) (display "| " cep) (indent (- n 1))))) - (write retval cep) - (newline cep)))) - - -;;; A fix to get the error handling working together with the module system. -;;; -(variable-set! (builtin-variable 'debug-options) debug-options) - - - -(debug-enable 'debug) -(read-enable 'positions) |