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

add current-trace-notify

Browse Source 
svn: r10941

original commit: 44b1499301c327e6547b86611f0fe0a4d8000099
This commit is contained in:
Matthew Flatt 2008-07-28 14:45:16 +00:00
parent 63806763b5
commit cb7623387d
1 changed files with 36 additions and 1 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

37
collects/mzlib/trace.ss
View File

@ -3,7 +3,8 @@
(require scheme/pretty (require scheme/pretty
(for-syntax scheme/base)) (for-syntax scheme/base))
(provide trace untrace) (provide trace untrace
current-trace-notify)
(define max-dash-space-depth 10) (define max-dash-space-depth 10)
(define number-nesting-depth 6) (define number-nesting-depth 6)
@ -75,7 +76,34 @@
(insert-prefix level first rest) (insert-prefix level first rest)
(values first rest)))))) (values first rest))))))
(define current-trace-notify
(make-parameter (lambda (s)
(display s)
(newline))
(lambda (p)
(unless (and (procedure? p)
(procedure-arity-includes? p 1))
(raise-type-error 'current-trace-notify
"procedure (arity 1)"
p))
p)))
(define (as-trace-notify thunk)
(let ([p (open-output-bytes)])
(parameterize ([current-output-port p])
(thunk))
(let ([b (get-output-bytes p #t 0
;; drop newline:
(sub1 (file-position p)))])
((current-trace-notify) (bytes->string/utf-8 b)))))
(define -:trace-print-args (define -:trace-print-args
(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) (lambda (name args kws kw-vals level)
(let-values (((first rest) (let-values (((first rest)
(build-prefixes level))) (build-prefixes level)))
@ -96,6 +124,12 @@
(apply append (map list kws kw-vals)))))))) (apply append (map list kws kw-vals))))))))
(define -:trace-print-results (define -:trace-print-results
(lambda (name results level)
(as-trace-notify
(lambda ()
(trace-print-results name results level)))))
(define trace-print-results
(lambda (name results level) (lambda (name results level)
(let-values (((first rest) (let-values (((first rest)
(build-prefixes level))) (build-prefixes level)))
@ -132,6 +166,7 @@
0)))) 0))))
(for-each pretty-print (cdr results))))))))) (for-each pretty-print (cdr results)))))))))
;; A traced-proc struct instance acts like a procedure, ;; A traced-proc struct instance acts like a procedure,
;; but preserves the original, too. ;; but preserves the original, too.
(define-values (struct:traced-proc make-traced-proc traced-proc? traced-proc-ref traced-proc-set!) (define-values (struct:traced-proc make-traced-proc traced-proc? traced-proc-ref traced-proc-set!)