suzanne.soy/compatibility
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

opened up the trace library a little more to make it more useable for Redex

Browse Source 
svn: r13027

original commit: cda64e40da21ef9e639faa82f741bfd736edf245
This commit is contained in:
Robby Findler 2009-01-07 15:44:07 +00:00
parent 3fd92992ee
commit 42e6044cd4
1 changed files with 29 additions and 29 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

58
collects/mzlib/trace.ss
View File

@ -4,19 +4,16 @@
(for-syntax scheme/base))
(provide trace untrace
current-trace-print-args trace-apply
current-trace-notify)
(define max-dash-space-depth 10)
(define number-nesting-depth 6)
(define as-spaces
(lambda (s)
(let ((n (string-length s)))
(apply string-append
(let loop ((k n))
(if (zero? k) '("")
(cons " " (loop (sub1 k)))))))))
(define (as-spaces s)
(build-string (string-length s)
(lambda (i) #\space)))
(define-struct prefix-entry (for-first for-rest))
(define prefixes (make-vector 20 #f))
@ -101,28 +98,29 @@
(lambda (name args kws kw-vals level)
(as-trace-notify
(lambda ()
(trace-print-args name args kws kw-vals level)))))
(define trace-print-args
(lambda (name args kws kw-vals level)
(let-values (((first rest)
(build-prefixes level)))
(parameterize ((pretty-print-print-line
(lambda (n port offset width)
(display
(if n
(if (zero? n) first
(format "~n~a" rest))
(format "~n"))
port)
(if n
(if (zero? n)
(string-length first)
(string-length rest))
0))))
(pretty-print (append (cons name args)
(apply append (map list kws kw-vals))))))))
((current-trace-print-args) name args kws kw-vals level)))))
(define current-trace-print-args
(make-parameter
(lambda (name args kws kw-vals level)
(let-values (((first rest)
(build-prefixes level)))
(parameterize ((pretty-print-print-line
(lambda (n port offset width)
(display
(if n
(if (zero? n) first
(format "~n~a" rest))
(format "~n"))
port)
(if n
(if (zero? n)
(string-length first)
(string-length rest))
0))))
(pretty-print (append (cons name args)
(apply append (map list kws kw-vals)))))))))
(define -:trace-print-results
(lambda (name results level)
(as-trace-notify
@ -197,6 +195,8 @@
;; the nesting depth:
(define -:trace-level-key (gensym))
(define (trace-apply id f kws kw-vals . args) (do-traced id args kws kw-vals f))
;; Apply a traced procedure to arguments, printing arguments
;; and results. We set and inspect the -:trace-level-key continuation
;; mark a few times to detect tail calls.