diff options
Diffstat (limited to 'module/ice-9/debugging/trace.scm')
-rw-r--r-- | module/ice-9/debugging/trace.scm | 153 |
1 files changed, 0 insertions, 153 deletions
diff --git a/module/ice-9/debugging/trace.scm b/module/ice-9/debugging/trace.scm deleted file mode 100644 index c8d24d09e..000000000 --- a/module/ice-9/debugging/trace.scm +++ /dev/null @@ -1,153 +0,0 @@ -;;;; (ice-9 debugging trace) -- breakpoint trace behaviour - -;;; Copyright (C) 2002, 2010 Free Software Foundation, Inc. -;;; -;;;; This library is free software; you can redistribute it and/or -;;;; modify it under the terms of the GNU Lesser General Public -;;;; License as published by the Free Software Foundation; either -;;;; version 3 of the License, or (at your option) any later version. -;;;; -;;;; This library 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 -;;;; Lesser General Public License for more details. -;;;; -;;;; You should have received a copy of the GNU Lesser General Public -;;;; License along with this library; if not, write to the Free Software -;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA - -(define-module (ice-9 debugging trace) - #:use-module (ice-9 debugger) - #:use-module (ice-9 debugger utils) - #:use-module (ice-9 debugging steps) - #:use-module (ice-9 debugging traps) - #:export (trace-trap - trace-port - set-trace-layout - trace/pid - trace/stack-id - trace/stack-depth - trace/stack-real-depth - trace/stack - trace/source-file-name - trace/source-line - trace/source-column - trace/source - trace/type - trace/real? - trace/info - trace-at-exit - trace-until-exit)) - -(define trace-format-string #f) -(define trace-arg-procs #f) - -(define (set-trace-layout format-string . arg-procs) - (set! trace-format-string format-string) - (set! trace-arg-procs arg-procs)) - -(define (trace/pid trap-context) - (getpid)) - -(define (trace/stack-id trap-context) - (stack-id (tc:stack trap-context))) - -(define (trace/stack-depth trap-context) - (tc:depth trap-context)) - -(define (trace/stack-real-depth trap-context) - (tc:real-depth trap-context)) - -(define (trace/stack trap-context) - (format #f "~a:~a+~a" - (stack-id (tc:stack trap-context)) - (tc:real-depth trap-context) - (- (tc:depth trap-context) (tc:real-depth trap-context)))) - -(define (trace/source-file-name trap-context) - (cond ((frame->source-position (tc:frame trap-context)) => car) - (else ""))) - -(define (trace/source-line trap-context) - (cond ((frame->source-position (tc:frame trap-context)) => cadr) - (else 0))) - -(define (trace/source-column trap-context) - (cond ((frame->source-position (tc:frame trap-context)) => caddr) - (else 0))) - -(define (trace/source trap-context) - (cond ((frame->source-position (tc:frame trap-context)) - => - (lambda (pos) - (format #f "~a:~a:~a" (car pos) (cadr pos) (caddr pos)))) - (else ""))) - -(define (trace/type trap-context) - (case (tc:type trap-context) - ((#:application) "APP") - ((#:evaluation) "EVA") - ((#:return) "RET") - ((#:error) "ERR") - (else "???"))) - -(define (trace/real? trap-context) - (if (frame-real? (tc:frame trap-context)) " " "t")) - -(define (trace/info trap-context) - (with-output-to-string - (lambda () - (if (memq (tc:type trap-context) '(#:application #:evaluation)) - ((if (tc:expression trap-context) - write-frame-short/expression - write-frame-short/application) (tc:frame trap-context)) - (begin - (display "=>") - (write (tc:return-value trap-context))))))) - -(set-trace-layout "|~3@a: ~a\n" trace/stack-real-depth trace/info) - -;;; trace-trap -;;; -;;; Trace the current location, and install a hook to trace the return -;;; value when we exit the current frame. - -(define (trace-trap trap-context) - (apply format - (trace-port) - trace-format-string - (map (lambda (arg-proc) - (arg-proc trap-context)) - trace-arg-procs))) - -(set! (behaviour-ordering trace-trap) 50) - -;;; trace-port -;;; -;;; The port to which trace information is printed. - -(define trace-port - (let ((port (current-output-port))) - (make-procedure-with-setter - (lambda () port) - (lambda (new) (set! port new))))) - -;;; trace-at-exit -;;; -;;; Trace return value on exit from the current frame. - -(define (trace-at-exit trap-context) - (at-exit (tc:depth trap-context) trace-trap)) - -;;; trace-until-exit -;;; -;;; Trace absolutely everything until exit from the current frame. - -(define (trace-until-exit trap-context) - (let ((step-trap (make <step-trap> #:behaviour trace-trap))) - (install-trap step-trap) - (at-exit (tc:depth trap-context) - (lambda (trap-context) - (uninstall-trap step-trap))))) - -;;; (ice-9 debugging trace) ends here. |