suzanne.soy/racket
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
This commit is contained in:
Robby Findler 2009-01-07 15:44:07 +00:00
parent fe62b97137
commit cda64e40da
2 changed files with 52 additions and 29 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

23
collects/mzlib/scribblings/trace.scrbl
View File

@ -56,3 +56,26 @@ end with a newline, but it may contain internal newlines. Each call or
result is converted into a string using @scheme[pretty-print]. The
parameter's default value prints the given string followed by a newline to
@scheme[(current-output-port)].}
@defproc[(trace-apply [id symbol?] [proc procedure?] [kws (listof keyword)] [kw-vals list?] [arg any/c] ...) any/c]{
Calls @scheme[proc] with the arguments supplied in
@scheme[args], @scheme[kws], and @scheme[kw-vals]. Also prints out the
trace information during the call, as described above in the docs for
@scheme[trace], using @scheme[id] as the name of @scheme[proc].
}
@defparam[current-trace-print-args trace-print-args
(-> symbol?
(listof keyword?)
list?
list?
number?)]{
The value of this parameter is invoked to print out the arguments of a
traced call. It receives the name of the function, the function's
ordinary arguments, its keywords, the values of the keywords, and a
number indicating the depth of the call.
}

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.