summaryrefslogtreecommitdiff
path: root/module/ice-9/debugging/trace.scm
diff options
context:
space:
mode:
Diffstat (limited to 'module/ice-9/debugging/trace.scm')
-rw-r--r--module/ice-9/debugging/trace.scm153
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.