Added trace-define, trace-let, trace-lambda
In racket/collects/racket/trace.rkt
This commit is contained in:
William J. Bowman
Asumu Takikawa
parent
3905334f28
commit
c6b3f337e9
|
|
@ -3,7 +3,8 @@
|
|||
scribble/eval)
|
||||
|
||||
@(begin (define ev (make-base-eval))
|
||||
(ev '(require racket/trace)))
|
||||
(ev '(require racket/trace))
|
||||
(ev '(require (for-syntax racket/base))))
|
||||
|
||||
@title{Tracing}
|
||||
|
||||
|
|
@ -49,6 +50,79 @@ The result of a @racket[trace] expression is @|void-const|.
|
|||
|
||||
}
|
||||
|
||||
@defform*[((trace-define id expr)
|
||||
(trace-define (head args) body ...+))]{
|
||||
|
||||
The @racket[trace-define] form is short-hand for first defining a
|
||||
function then tracing it. This form supports all @racket[define] forms.
|
||||
|
||||
@examples[#:eval ev
|
||||
(trace-define (f x) (if (zero? x) 0 (add1 (f (sub1 x)))))
|
||||
(f 5)
|
||||
]
|
||||
|
||||
@examples[#:eval ev
|
||||
(trace-define ((+n n) x) (+ n x))
|
||||
(map (+n 5) (list 1 3 4))
|
||||
]}
|
||||
|
||||
@defform*[((trace-define-syntax id expr)
|
||||
(trace-define-syntax (head args) body ...+))]{
|
||||
|
||||
The @racket[trace-define-syntax] form is short-hand for first defining a
|
||||
macro then tracing it. This form supports all @racket[define-syntax] forms.
|
||||
|
||||
For example:
|
||||
|
||||
@examples[#:eval ev
|
||||
(trace-define-syntax fact
|
||||
(syntax-rules ()
|
||||
[(_ x) 120]))
|
||||
(fact 5)
|
||||
]
|
||||
|
||||
By default, @racket[trace] prints out syntax objects when tracing a
|
||||
macro. This can result in too much output if you do not need to see,
|
||||
e.g., source information. To get more readable output, try this:
|
||||
|
||||
@examples[#:eval ev
|
||||
(require (for-syntax racket/trace))
|
||||
(begin-for-syntax
|
||||
(current-trace-print-args
|
||||
(let ([ctpa (current-trace-print-args)])
|
||||
(lambda (s l kw l2 n)
|
||||
(ctpa s (map syntax->datum l) kw l2 n))))
|
||||
(current-trace-print-results
|
||||
(let ([ctpr (current-trace-print-results)])
|
||||
(lambda (s l n)
|
||||
(ctpr s (map syntax->datum l) n)))))
|
||||
|
||||
(trace-define-syntax fact
|
||||
(syntax-rules ()
|
||||
[(_ x) #'120]))
|
||||
(fact 5)]}
|
||||
|
||||
@defform[(trace-lambda [#:name id] args expr)]{
|
||||
|
||||
The @racket[trace-lambda] form enables tracing an anonymous function. This
|
||||
form will attempt to infer a name using
|
||||
@racket[syntax-local-infer-name], or a name can be specified using the
|
||||
optional @racket[#:name] argument. A syntax error is raised if a name
|
||||
is not given and a name cannot be inferred.
|
||||
|
||||
@examples[#:eval ev
|
||||
((trace-lambda (x) 120) 5)]}
|
||||
|
||||
@defform[(trace-let id ([arg expr] ...+) body ...+)]{
|
||||
|
||||
The @racket[trace-let] form enables tracing a named let.
|
||||
|
||||
@examples[#:eval ev
|
||||
(trace-let f ([x 5])
|
||||
(if (zero? x)
|
||||
1
|
||||
(* x (f (sub1 x)))))]}
|
||||
|
||||
@defform[(untrace id ...)]{
|
||||
|
||||
Undoes the effects of the @racket[trace] form for each @racket[id],
|
||||
|
|
@ -79,7 +153,7 @@ trace information during the call, as described above in the docs for
|
|||
|
||||
}
|
||||
|
||||
@defparam[current-trace-print-args trace-print-args
|
||||
@defparam[current-trace-print-args trace-print-args
|
||||
(-> symbol?
|
||||
list?
|
||||
(listof keyword?)
|
||||
|
|
@ -94,7 +168,7 @@ number indicating the depth of the call.
|
|||
|
||||
}
|
||||
|
||||
@defparam[current-trace-print-results trace-print-results
|
||||
@defparam[current-trace-print-results trace-print-results
|
||||
(-> symbol?
|
||||
list?
|
||||
number?
|
||||
|
|
@ -110,7 +184,7 @@ results, and a number indicating the depth of the call.
|
|||
This string is used by the default value of @racket[current-trace-print-args]
|
||||
indicating that the current line is showing the a call to a
|
||||
traced function.
|
||||
|
||||
|
||||
It defaults to @racket[">"].
|
||||
}
|
||||
|
||||
|
|
@ -119,7 +193,7 @@ results, and a number indicating the depth of the call.
|
|||
This string is used by the default value of @racket[current-trace-print-results]
|
||||
indicating that the current line is showing the result
|
||||
of a traced call.
|
||||
|
||||
|
||||
It defaults to @racket["<"].
|
||||
}
|
||||
|
||||
|
|
|
|||
|
|
@ -69,4 +69,43 @@
|
|||
(list ">(f (1 2 3) #:q #&18)"
|
||||
"<((1 2 3) 1)")))
|
||||
|
||||
(test
|
||||
(list ">(verbose-fact 2)"
|
||||
"> (verbose-fact 1)"
|
||||
"> >(verbose-fact 0)"
|
||||
"< <1"
|
||||
"> >(verbose-fact 0)"
|
||||
"< <1"
|
||||
"< 1"
|
||||
"> (verbose-fact 1)"
|
||||
"> >(verbose-fact 0)"
|
||||
"< <1"
|
||||
"> >(verbose-fact 0)"
|
||||
"< <1"
|
||||
"< 1"
|
||||
"<2")
|
||||
'trace-define
|
||||
(trace-output
|
||||
(trace-define (verbose-fact x)
|
||||
(if (zero? x)
|
||||
(begin (displayln 1) 1)
|
||||
(begin (displayln (* x (verbose-fact (sub1 x))))
|
||||
(* x (verbose-fact (sub1 x))))))
|
||||
(parameterize ([current-output-port (open-output-nowhere)]) (verbose-fact 2))))
|
||||
|
||||
(test
|
||||
(list ">(fact 120)"
|
||||
"<120")
|
||||
'trace-lambda-named
|
||||
(trace-output
|
||||
((trace-lambda #:name fact (x) x) 120)))
|
||||
|
||||
(let ([tout (trace-output ((trace-lambda (x) x) 120))])
|
||||
(local-require racket/match)
|
||||
(test #t
|
||||
'trace-lambda-anonymous
|
||||
(match tout
|
||||
[(list (pregexp #px">\\(.+\\.rktl?:\\d+:\\d+ 120\\)") "<120") #t]
|
||||
[_ #f])))
|
||||
|
||||
(report-errs)
|
||||
|
|
|
|||
|
|
@ -1,57 +1,58 @@
|
|||
#lang racket/base
|
||||
|
||||
(require racket/pretty
|
||||
(for-syntax racket/base))
|
||||
(module trace-et-al racket/base
|
||||
(require racket/pretty
|
||||
(for-syntax racket/base))
|
||||
|
||||
(provide trace untrace
|
||||
current-trace-print-results
|
||||
current-trace-print-args
|
||||
trace-call
|
||||
current-trace-notify
|
||||
current-prefix-out current-prefix-in)
|
||||
(provide trace untrace
|
||||
current-trace-print-results
|
||||
current-trace-print-args
|
||||
trace-call
|
||||
current-trace-notify
|
||||
current-prefix-out current-prefix-in)
|
||||
|
||||
(define max-dash-space-depth 10)
|
||||
(define number-nesting-depth 6)
|
||||
(define current-prefix-out (make-parameter "<"))
|
||||
(define current-prefix-in (make-parameter ">"))
|
||||
(define max-dash-space-depth 10)
|
||||
(define number-nesting-depth 6)
|
||||
(define current-prefix-out (make-parameter "<"))
|
||||
(define current-prefix-in (make-parameter ">"))
|
||||
|
||||
(define (as-spaces s)
|
||||
(make-string (string-length s) #\space))
|
||||
(define (as-spaces s)
|
||||
(make-string (string-length s) #\space))
|
||||
|
||||
(define-struct prefix-entry (for-first for-rest))
|
||||
(define-struct prefix-entry (for-first for-rest))
|
||||
|
||||
(define prefixes (make-hash))
|
||||
(define prefixes (make-hash))
|
||||
|
||||
(define (lookup-prefix n label)
|
||||
(hash-ref prefixes (cons n label) (lambda () #f)))
|
||||
(define (lookup-prefix n label)
|
||||
(hash-ref prefixes (cons n label) (lambda () #f)))
|
||||
|
||||
(define (insert-prefix n label first rest)
|
||||
(hash-set! prefixes (cons n label) (make-prefix-entry first rest)))
|
||||
(define (insert-prefix n label first rest)
|
||||
(hash-set! prefixes (cons n label) (make-prefix-entry first rest)))
|
||||
|
||||
(define (construct-prefixes level label)
|
||||
(let loop ([n level]
|
||||
[first (list label)]
|
||||
[rest '(" ")])
|
||||
(if (>= n max-dash-space-depth)
|
||||
(define (construct-prefixes level label)
|
||||
(let loop ([n level]
|
||||
[first (list label)]
|
||||
[rest '(" ")])
|
||||
(if (>= n max-dash-space-depth)
|
||||
(let-values ([(pre-first pre-rest)
|
||||
(build-prefixes number-nesting-depth label)])
|
||||
(let ((s (number->string level)))
|
||||
(values
|
||||
(string-append pre-first "[" s "] ")
|
||||
(string-append pre-rest " " (as-spaces s) " "))))
|
||||
(string-append pre-first "[" s "] ")
|
||||
(string-append pre-rest " " (as-spaces s) " "))))
|
||||
(cond
|
||||
[(= n 0) (values (apply string-append (reverse first))
|
||||
(apply string-append (reverse rest)))]
|
||||
(apply string-append (reverse rest)))]
|
||||
[(= n 1) (loop (- n 1)
|
||||
(cons '" " first)
|
||||
(cons '" " rest))]
|
||||
(cons '" " first)
|
||||
(cons '" " rest))]
|
||||
[else (loop (- n 2)
|
||||
(cons (format " ~a" label) first)
|
||||
(cons " " rest))]))))
|
||||
|
||||
(define (build-prefixes level label)
|
||||
(let ([p (lookup-prefix level label)])
|
||||
(if p
|
||||
(define (build-prefixes level label)
|
||||
(let ([p (lookup-prefix level label)])
|
||||
(if p
|
||||
(values (prefix-entry-for-first p)
|
||||
(prefix-entry-for-rest p))
|
||||
(let-values (((first rest)
|
||||
|
|
@ -59,237 +60,290 @@
|
|||
(insert-prefix level label 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-argument-error 'current-trace-notify
|
||||
"(any/c . -> . any)"
|
||||
p))
|
||||
p)))
|
||||
(define current-trace-notify
|
||||
(make-parameter (lambda (s)
|
||||
(display s)
|
||||
(newline))
|
||||
(lambda (p)
|
||||
(unless (and (procedure? p)
|
||||
(procedure-arity-includes? p 1))
|
||||
(raise-argument-error 'current-trace-notify
|
||||
"(any/c . -> . any)"
|
||||
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 (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
|
||||
(lambda (name args kws kw-vals level)
|
||||
(as-trace-notify
|
||||
(lambda ()
|
||||
((current-trace-print-args) name args kws kw-vals level)))))
|
||||
(define -:trace-print-args
|
||||
(lambda (name args kws kw-vals level)
|
||||
(as-trace-notify
|
||||
(lambda ()
|
||||
((current-trace-print-args) name args kws kw-vals level)))))
|
||||
|
||||
(struct plain (val)
|
||||
#:property prop:custom-write (lambda (p port mode)
|
||||
(write (plain-val p) port)))
|
||||
(struct plain (val)
|
||||
#:property prop:custom-write (lambda (p port mode)
|
||||
(write (plain-val p) port)))
|
||||
|
||||
(define current-trace-print-args
|
||||
(make-parameter
|
||||
(lambda (name args kws kw-vals level)
|
||||
(let-values (((first rest)
|
||||
(build-prefixes level (current-prefix-in))))
|
||||
(parameterize ((pretty-print-print-line
|
||||
(lambda (n port offset width)
|
||||
(display
|
||||
(if n
|
||||
(if (zero? n) first (format "\n~a" rest))
|
||||
"\n")
|
||||
port)
|
||||
(if n
|
||||
(if (zero? n)
|
||||
(string-length first)
|
||||
(string-length rest))
|
||||
0))))
|
||||
;; Printing the function call in a way that adapts to
|
||||
;; different value printing --- currently a hack
|
||||
(cond
|
||||
[(print-as-expression)
|
||||
;; In expression mode, represent a function call as a
|
||||
;; transparent structure, so that it prints as a constructor
|
||||
;; application. Also, protect keywords for keyword arguments
|
||||
;; so that they print without quoting.
|
||||
(let ([args (append args
|
||||
(apply append (map (lambda (kw val)
|
||||
(list (plain kw) val))
|
||||
kws
|
||||
kw-vals)))])
|
||||
(let-values ([(struct: make- ? -ref -set!)
|
||||
(make-struct-type name #f
|
||||
(length args) 0 #f
|
||||
null #f #f null #f
|
||||
name)])
|
||||
(pretty-print (apply make- args))))]
|
||||
[else
|
||||
;; In non-expression mode, just use `write':
|
||||
(pretty-write (append (cons name args)
|
||||
(apply append (map list kws kw-vals))))]))))))
|
||||
|
||||
(define -:trace-print-results
|
||||
(lambda (name results level)
|
||||
(as-trace-notify
|
||||
(lambda ()
|
||||
((current-trace-print-results) name results level)))))
|
||||
|
||||
(define current-trace-print-results
|
||||
(make-parameter
|
||||
(lambda (name results level)
|
||||
(let-values (((first rest)
|
||||
(build-prefixes level (current-prefix-out))))
|
||||
(parameterize ((pretty-print-print-line
|
||||
(lambda (n port offset width)
|
||||
(display
|
||||
(if n
|
||||
(if (zero? n) first (format "\n~a" rest))
|
||||
"\n")
|
||||
port)
|
||||
(if n
|
||||
(if (zero? n)
|
||||
(string-length first)
|
||||
(string-length rest))
|
||||
0))))
|
||||
(cond
|
||||
((null? results)
|
||||
(pretty-display "*** no values ***"))
|
||||
((null? (cdr results))
|
||||
(pretty-print (car results)))
|
||||
(else
|
||||
(pretty-print (car results))
|
||||
(parameterize ((pretty-print-print-line
|
||||
(lambda (n port offset width)
|
||||
(display
|
||||
(if n
|
||||
(if (zero? n) rest (format "\n~a" rest))
|
||||
"\n")
|
||||
port)
|
||||
(define current-trace-print-args
|
||||
(make-parameter
|
||||
(lambda (name args kws kw-vals level)
|
||||
(let-values (((first rest)
|
||||
(build-prefixes level (current-prefix-in))))
|
||||
(parameterize ((pretty-print-print-line
|
||||
(lambda (n port offset width)
|
||||
(display
|
||||
(if n
|
||||
(string-length rest)
|
||||
0))))
|
||||
(for-each pretty-print (cdr results))))))))))
|
||||
(if (zero? n) first (format "\n~a" rest))
|
||||
"\n")
|
||||
port)
|
||||
(if n
|
||||
(if (zero? n)
|
||||
(string-length first)
|
||||
(string-length rest))
|
||||
0))))
|
||||
;; Printing the function call in a way that adapts to
|
||||
;; different value printing --- currently a hack
|
||||
(cond
|
||||
[(print-as-expression)
|
||||
;; In expression mode, represent a function call as a
|
||||
;; transparent structure, so that it prints as a constructor
|
||||
;; application. Also, protect keywords for keyword arguments
|
||||
;; so that they print without quoting.
|
||||
(let ([args (append args
|
||||
(apply append (map (lambda (kw val)
|
||||
(list (plain kw) val))
|
||||
kws
|
||||
kw-vals)))])
|
||||
(let-values ([(struct: make- ? -ref -set!)
|
||||
(make-struct-type name #f
|
||||
(length args) 0 #f
|
||||
null #f #f null #f
|
||||
name)])
|
||||
(pretty-print (apply make- args))))]
|
||||
[else
|
||||
;; In non-expression mode, just use `write':
|
||||
(pretty-write (append (cons name args)
|
||||
(apply append (map list kws kw-vals))))]))))))
|
||||
|
||||
(define -:trace-print-results
|
||||
(lambda (name results level)
|
||||
(as-trace-notify
|
||||
(lambda ()
|
||||
((current-trace-print-results) name results level)))))
|
||||
|
||||
(define current-trace-print-results
|
||||
(make-parameter
|
||||
(lambda (name results level)
|
||||
(let-values (((first rest)
|
||||
(build-prefixes level (current-prefix-out))))
|
||||
(parameterize ((pretty-print-print-line
|
||||
(lambda (n port offset width)
|
||||
(display
|
||||
(if n
|
||||
(if (zero? n) first (format "\n~a" rest))
|
||||
"\n")
|
||||
port)
|
||||
(if n
|
||||
(if (zero? n)
|
||||
(string-length first)
|
||||
(string-length rest))
|
||||
0))))
|
||||
(cond
|
||||
((null? results)
|
||||
(pretty-display "*** no values ***"))
|
||||
((null? (cdr results))
|
||||
(pretty-print (car results)))
|
||||
(else
|
||||
(pretty-print (car results))
|
||||
(parameterize ((pretty-print-print-line
|
||||
(lambda (n port offset width)
|
||||
(display
|
||||
(if n
|
||||
(if (zero? n) rest (format "\n~a" rest))
|
||||
"\n")
|
||||
port)
|
||||
(if n
|
||||
(string-length rest)
|
||||
0))))
|
||||
(for-each pretty-print (cdr results))))))))))
|
||||
|
||||
|
||||
;; A traced-proc struct instance acts like a procedure,
|
||||
;; but preserves the original, too.
|
||||
(define-values (struct:traced-proc make-traced-proc traced-proc? traced-proc-ref traced-proc-set!)
|
||||
(make-struct-type 'traced-proc #f 2 0 #f
|
||||
(list (cons prop:procedure 0))
|
||||
(current-inspector) #f (list 0 1)))
|
||||
;; A traced-proc struct instance acts like a procedure,
|
||||
;; but preserves the original, too.
|
||||
(define-values (struct:traced-proc make-traced-proc traced-proc? traced-proc-ref traced-proc-set!)
|
||||
(make-struct-type 'traced-proc #f 2 0 #f
|
||||
(list (cons prop:procedure 0))
|
||||
(current-inspector) #f (list 0 1)))
|
||||
|
||||
;; Install traced versions of a given set of procedures. The traced
|
||||
;; versions are also given, so that they can be constructed to have
|
||||
;; a nice name.
|
||||
(define (do-trace ids procs setters traced-procs)
|
||||
(for-each (lambda (id proc)
|
||||
(unless (procedure? proc)
|
||||
(error 'trace
|
||||
"the value of ~s is not a procedure: ~e" id proc)))
|
||||
ids procs)
|
||||
(for-each (lambda (proc setter traced-proc)
|
||||
(unless (traced-proc? proc)
|
||||
(setter (make-traced-proc
|
||||
(let-values ([(a) (procedure-arity proc)]
|
||||
[(req allowed) (procedure-keywords proc)])
|
||||
(procedure-reduce-keyword-arity traced-proc
|
||||
a
|
||||
req
|
||||
allowed))
|
||||
proc))))
|
||||
procs setters traced-procs))
|
||||
;; Install traced versions of a given set of procedures. The traced
|
||||
;; versions are also given, so that they can be constructed to have
|
||||
;; a nice name.
|
||||
(define (do-trace ids procs setters traced-procs)
|
||||
(for-each (lambda (id proc)
|
||||
(unless (procedure? proc)
|
||||
(error 'trace
|
||||
"the value of ~s is not a procedure: ~e" id proc)))
|
||||
ids procs)
|
||||
(for-each (lambda (proc setter traced-proc)
|
||||
(unless (traced-proc? proc)
|
||||
(setter (make-traced-proc
|
||||
(let-values ([(a) (procedure-arity proc)]
|
||||
[(req allowed) (procedure-keywords proc)])
|
||||
(procedure-reduce-keyword-arity traced-proc
|
||||
a
|
||||
req
|
||||
allowed))
|
||||
proc))))
|
||||
procs setters traced-procs))
|
||||
|
||||
;; Key used for a continuation mark to indicate
|
||||
;; the nesting depth:
|
||||
(define -:trace-level-key (gensym))
|
||||
;; Key used for a continuation mark to indicate
|
||||
;; the nesting depth:
|
||||
(define -:trace-level-key (gensym))
|
||||
|
||||
(define trace-call
|
||||
(make-keyword-procedure
|
||||
(lambda (id f kws vals . args)
|
||||
(do-traced id args kws vals f))
|
||||
(lambda (id f . args)
|
||||
(do-traced id args '() '() f))))
|
||||
(define trace-call
|
||||
(make-keyword-procedure
|
||||
(lambda (id f kws vals . args)
|
||||
(do-traced id args kws vals f))
|
||||
(lambda (id f . args)
|
||||
(do-traced id args '() '() 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.
|
||||
(define (do-traced id args kws kw-vals real-value)
|
||||
(let* ([levels (continuation-mark-set->list
|
||||
(current-continuation-marks)
|
||||
-:trace-level-key)]
|
||||
[level (if (null? levels) 0 (car levels))])
|
||||
;; Tentatively push the new depth level:
|
||||
(with-continuation-mark -:trace-level-key (add1 level)
|
||||
;; Check for tail-call => car of levels replaced,
|
||||
;; which means that the first two new marks are
|
||||
;; not consecutive:
|
||||
(let ([new-levels (continuation-mark-set->list
|
||||
(current-continuation-marks)
|
||||
-:trace-level-key)])
|
||||
(if (and (pair? (cdr new-levels))
|
||||
(> (car new-levels) (add1 (cadr new-levels))))
|
||||
;; Tail call: reset level and just call real-value.
|
||||
;; (This is in tail position to the call to `do-traced'.)
|
||||
;; We don't print the results, because the original
|
||||
;; call will.
|
||||
(begin
|
||||
(-:trace-print-args id args kws kw-vals (sub1 level))
|
||||
(with-continuation-mark -:trace-level-key (car levels)
|
||||
(if (null? kws)
|
||||
(apply real-value args)
|
||||
(keyword-apply real-value kws kw-vals args))))
|
||||
;; Not a tail call; push the old level, again, to ensure
|
||||
;; that when we push the new level, we have consecutive
|
||||
;; levels associated with the mark (i.e., set up for
|
||||
;; tail-call detection the next time around):
|
||||
(begin
|
||||
(-:trace-print-args id args kws kw-vals level)
|
||||
(with-continuation-mark -:trace-level-key level
|
||||
(call-with-values
|
||||
(lambda ()
|
||||
(with-continuation-mark -:trace-level-key (add1 level)
|
||||
(if (null? kws)
|
||||
(apply real-value args)
|
||||
(keyword-apply real-value kws kw-vals args))))
|
||||
(lambda results
|
||||
(flush-output)
|
||||
;; Print the results:
|
||||
(-:trace-print-results id results level)
|
||||
;; Return the results:
|
||||
(apply values results))))))))))
|
||||
;; 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.
|
||||
(define (do-traced id args kws kw-vals real-value)
|
||||
(let* ([levels (continuation-mark-set->list
|
||||
(current-continuation-marks)
|
||||
-:trace-level-key)]
|
||||
[level (if (null? levels) 0 (car levels))])
|
||||
;; Tentatively push the new depth level:
|
||||
(with-continuation-mark -:trace-level-key (add1 level)
|
||||
;; Check for tail-call => car of levels replaced,
|
||||
;; which means that the first two new marks are
|
||||
;; not consecutive:
|
||||
(let ([new-levels (continuation-mark-set->list
|
||||
(current-continuation-marks)
|
||||
-:trace-level-key)])
|
||||
(if (and (pair? (cdr new-levels))
|
||||
(> (car new-levels) (add1 (cadr new-levels))))
|
||||
;; Tail call: reset level and just call real-value.
|
||||
;; (This is in tail position to the call to `do-traced'.)
|
||||
;; We don't print the results, because the original
|
||||
;; call will.
|
||||
(begin
|
||||
(-:trace-print-args id args kws kw-vals (sub1 level))
|
||||
(with-continuation-mark -:trace-level-key (car levels)
|
||||
(if (null? kws)
|
||||
(apply real-value args)
|
||||
(keyword-apply real-value kws kw-vals args))))
|
||||
;; Not a tail call; push the old level, again, to ensure
|
||||
;; that when we push the new level, we have consecutive
|
||||
;; levels associated with the mark (i.e., set up for
|
||||
;; tail-call detection the next time around):
|
||||
(begin
|
||||
(-:trace-print-args id args kws kw-vals level)
|
||||
(with-continuation-mark -:trace-level-key level
|
||||
(call-with-values
|
||||
(lambda ()
|
||||
(with-continuation-mark -:trace-level-key (add1 level)
|
||||
(if (null? kws)
|
||||
(apply real-value args)
|
||||
(keyword-apply real-value kws kw-vals args))))
|
||||
(lambda results
|
||||
(flush-output)
|
||||
;; Print the results:
|
||||
(-:trace-print-results id results level)
|
||||
;; Return the results:
|
||||
(apply values results))))))))))
|
||||
|
||||
(define-for-syntax (check-ids stx ids)
|
||||
(for ([id (in-list (syntax->list ids))])
|
||||
(unless (identifier? id)
|
||||
(raise-syntax-error #f "not an identifier" stx id)))
|
||||
#t)
|
||||
(define-for-syntax (check-ids stx ids)
|
||||
(for ([id (in-list (syntax->list ids))])
|
||||
(unless (identifier? id)
|
||||
(raise-syntax-error #f "not an identifier" stx id)))
|
||||
#t)
|
||||
|
||||
(define-syntax (trace stx)
|
||||
(syntax-case stx ()
|
||||
[(_ id ...) (check-ids stx #'(id ...))
|
||||
(with-syntax ([(tid ...)
|
||||
(for/list ([id (in-list (syntax->list #'(id ...)))])
|
||||
(let ([tid (format "traced-~a" (syntax-e id))])
|
||||
(datum->syntax id (string->symbol tid) #f)))])
|
||||
#'(do-trace
|
||||
'(id ...)
|
||||
(list id ...)
|
||||
(list (lambda (v) (set! id v)) ...)
|
||||
(list (let* ([real-value id]
|
||||
[tid (make-keyword-procedure
|
||||
(lambda (kws vals . args)
|
||||
(do-traced 'id args kws vals real-value))
|
||||
(lambda args
|
||||
(do-traced 'id args null null real-value)))])
|
||||
tid)
|
||||
...)))]))
|
||||
(define-syntax (trace stx)
|
||||
(syntax-case stx ()
|
||||
[(_ id ...) (check-ids stx #'(id ...))
|
||||
(with-syntax ([(tid ...)
|
||||
(for/list ([id (in-list (syntax->list #'(id ...)))])
|
||||
(let ([tid (format "traced-~a" (syntax-e id))])
|
||||
(datum->syntax id (string->symbol tid) #f)))])
|
||||
#'(do-trace
|
||||
'(id ...)
|
||||
(list id ...)
|
||||
(list (lambda (v) (set! id v)) ...)
|
||||
(list (let* ([real-value id]
|
||||
[tid (make-keyword-procedure
|
||||
(lambda (kws vals . args)
|
||||
(do-traced 'id args kws vals real-value))
|
||||
(lambda args
|
||||
(do-traced 'id args null null real-value)))])
|
||||
tid)
|
||||
...)))]))
|
||||
|
||||
(define-syntax (untrace stx)
|
||||
(syntax-case stx ()
|
||||
[(_ id ...) (check-ids stx #'(id ...))
|
||||
#'(begin (when (traced-proc? id)
|
||||
(set! id (traced-proc-ref id 1)))
|
||||
...)]))
|
||||
(define-syntax (untrace stx)
|
||||
(syntax-case stx ()
|
||||
[(_ id ...) (check-ids stx #'(id ...))
|
||||
#'(begin (when (traced-proc? id)
|
||||
(set! id (traced-proc-ref id 1)))
|
||||
...)])))
|
||||
|
||||
(module chez-like racket/base
|
||||
(require
|
||||
(only-in (submod ".." trace-et-al) trace)
|
||||
(for-syntax
|
||||
racket/base
|
||||
syntax/define
|
||||
syntax/name
|
||||
syntax/parse
|
||||
(only-in (submod ".." trace-et-al) trace)))
|
||||
|
||||
(provide trace-define trace-lambda trace-let trace-define-syntax)
|
||||
|
||||
(define-syntax (trace-define stx)
|
||||
(syntax-case stx ()
|
||||
[(_ e ...)
|
||||
(let-values ([(name def) (normalize-definition stx #'lambda)])
|
||||
#`(begin (define #,name #,def) (trace #,name)))]))
|
||||
|
||||
(define-syntax trace-let
|
||||
(syntax-rules ()
|
||||
[(_ name ([x* e*] ...) body ...)
|
||||
((letrec ([name (lambda (x* ...) body ...)]) (trace name) name)
|
||||
e* ...)]))
|
||||
|
||||
(define-syntax (trace-lambda stx)
|
||||
(define (infer-name-or-error)
|
||||
(or (syntax-local-infer-name stx)
|
||||
(raise-syntax-error
|
||||
'trace-lambda
|
||||
"Could not infer name; give a name explicitly using #:name"
|
||||
stx)))
|
||||
(syntax-parse stx
|
||||
[(_ (~optional (~seq #:name name:id) #:defaults ([name #`#,(infer-name-or-error)])) args body:expr ...)
|
||||
#'(let ([name (lambda args body ...)]) (trace name) name)]))
|
||||
|
||||
(define-syntax (trace-define-syntax stx)
|
||||
(syntax-case stx ()
|
||||
[(_ e ...)
|
||||
(let-values ([(name def) (normalize-definition stx #'lambda)])
|
||||
#`(define-syntax #,name
|
||||
(let ([#,name #,def]) (trace #,name) #,name)))])))
|
||||
|
||||
(require 'trace-et-al 'chez-like)
|
||||
(provide trace untrace
|
||||
current-trace-print-results
|
||||
current-trace-print-args
|
||||
trace-call
|
||||
current-trace-notify
|
||||
current-prefix-out current-prefix-in
|
||||
|
||||
trace-define trace-let trace-lambda
|
||||
trace-define-syntax)
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user