From e6875011f44d4e4a4429e092e81dc4ac65c20b3b Mon Sep 17 00:00:00 2001 From: Mikael Djurfeldt Date: Fri, 28 Feb 1997 23:11:22 +0000 Subject: [PATCH] * * debug.scm: *Warning* This feature is a bit premature. I add it anyway because 1. it is very useful, and, 2. you can start making it less premature by complaining to me and by modifying the source! :-) (trace): Given one or more procedure objects, trace each one. Given no arguments, show all traced procedures. (untrace): Given one or more procedure objects, untrace each one. Given no arguments, untrace all traced procedures. The tracing in Guile have an advantage to most other systems: We don't create new procedure objects, but mark the procedure objects themselves. This means that also anonymous and internal procedures can be traced. * boot-9.scm (error-catching-loop): Added handling of apply-frame and exit-frame exceptions. * * boot-9.scm (assert-repl-prompt, the-prompt-string): Removed. (set-repl-prompt!): Setter for repl prompt. (scm-style-repl): If prompt is #f, don't prompt; if prompt is a string, display it; if prompt is a thunk, call it and display its result; otherwise display "> ". (Change suggested by Roland Orre .) --- ice-9/ChangeLog | 25 ++++++++++++- ice-9/boot-9.scm | 29 ++++++++++----- ice-9/debug.scm | 94 ++++++++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 139 insertions(+), 9 deletions(-) diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index 9d7082627..2fc8e81ca 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,4 +1,27 @@ -Fri Feb 28 00:00:50 1997 Mikael Djurfeldt +Sat Mar 1 00:10:38 1997 Mikael Djurfeldt + +* * debug.scm: *Warning* This feature is a bit premature. I add + it anyway because 1. it is very useful, and, 2. you can start + making it less premature by complaining to me and by modifying + the source! :-) + (trace): Given one or more procedure objects, trace each one. + Given no arguments, show all traced procedures. + (untrace): Given one or more procedure objects, untrace each one. + Given no arguments, untrace all traced procedures. The tracing in + Guile have an advantage to most other systems: We don't create new + procedure objects, but mark the procedure objects themselves. + This means that also anonymous and internal procedures can be + traced. + + * boot-9.scm (error-catching-loop): Added handling of apply-frame + and exit-frame exceptions. + +* * boot-9.scm (assert-repl-prompt, the-prompt-string): Removed. + (set-repl-prompt!): Setter for repl prompt. + (scm-style-repl): If prompt is #f, don't prompt; if prompt is a + string, display it; if prompt is a thunk, call it and display its + result; otherwise display "> ". + (Change suggested by Roland Orre .) * r4rs.scm (%load-verbosely): Reverted change to `module-defined?', since the module system isn't bootstrapped when diff --git a/ice-9/boot-9.scm b/ice-9/boot-9.scm index 5015a1325..11692e5bd 100644 --- a/ice-9/boot-9.scm +++ b/ice-9/boot-9.scm @@ -2139,10 +2139,12 @@ (define scm-repl-verbose #f) (define (assert-repl-verbosity v) (set! scm-repl-verbose v)) -(define scm-repl-prompt #t) -(define (assert-repl-prompt v) (set! scm-repl-prompt v)) +(define scm-repl-prompt "guile> ") -(define the-prompt-string "guile> ") +(define (set-repl-prompt! v) (set! scm-repl-prompt v)) + +(define apply-frame-handler #f) +(define exit-frame-handler #f) (define (error-catching-loop thunk) (define (loop first) @@ -2165,9 +2167,16 @@ #f) (lambda () (mask-signals)))) - (lambda args - (save-stack 1) - (apply throw args)))) + (lambda (key . args) + (cond ((eq? key 'apply-frame) + (and apply-frame-handler + (apply apply-frame-handler key args))) + ((eq? key 'exit-frame) + (and exit-frame-handler + (apply exit-frame-handler key args))) + (else + (save-stack 2) + (apply throw key args)))))) (lambda (key . args) (case key @@ -2224,7 +2233,7 @@ ((tk-stack) (apply make-stack #t save-stack tk-stack-mark narrowing)) ((#t) - (apply make-stack #t save-stack narrowing)) + (apply make-stack #t save-stack 0 1 narrowing)) (else (let ((id (stack-id #t))) (and (procedure? id) (apply make-stack #t save-stack id narrowing)))))) @@ -2303,7 +2312,11 @@ (-read (lambda () (if scm-repl-prompt (begin - (display the-prompt-string) + (display (cond ((string? scm-repl-prompt) + scm-repl-prompt) + ((thunk? scm-repl-prompt) + (scm-repl-prompt)) + (else "> "))) (force-output) (repl-report-reset))) (and before-read-hook (before-read-hook)) diff --git a/ice-9/debug.scm b/ice-9/debug.scm index 20e67f9cf..b397a6515 100644 --- a/ice-9/debug.scm +++ b/ice-9/debug.scm @@ -116,5 +116,99 @@ ;;; (variable-set! (builtin-variable 'debug-options) debug-options) + + +;;; {Trace} +;;; +(define traced-procedures '()) + +(define-public (trace . args) + (if (null? args) + (nameify traced-procedures) + (begin + (for-each (lambda (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) + +(define (trace-entry key cont tail) + (dynamic-wind + (lambda () + ;; We have to protect ourselves against the case that the user + ;; has chosen to trace a procedure used in the trace handler. + ;; Note that debug-disable is a very slow operation. + ;; This is not an ideal solution. *fixme* + (debug-disable 'trace)) + (lambda () + (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) + (newline cep) + ;; It's not necessary to call the continuation since + ;; execution will continue if the handler returns + ;(cont #f) + )) + (lambda () + (debug-enable 'trace)))) + +(define (trace-exit key cont retval) + (dynamic-wind + (lambda () + (debug-disable 'trace)) + (lambda () + (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))) + (lambda () + (debug-enable 'trace)))) + +(define (display-application frame port) + (display #\[ port) + (display (car (unmemoize (frame-source frame))) port) + (let loop ((args (frame-arguments frame))) + (if (not (null? args)) + (begin + (display #\space port) + (write (car args) port) + (loop (cdr args))))) + (display #\] port)) + + + (debug-enable 'debug) (read-enable 'positions)