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

* Reorganize macro code.

Browse Source 
* Change `trace-apply' to accept keyword arguments by being a keyworded
  function itself
* Renamed `trace-apply' to `trace-call' -- since it's not following the
  calling convention of `apply'.

svn: r16161
This commit is contained in:
Eli Barzilay 2009-09-29 07:33:07 +00:00
parent b280232aea
commit 6cea680b62
3 changed files with 41 additions and 58 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -57,10 +57,11 @@ 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]{
@defproc[(trace-call [id symbol?] [proc procedure?]
[#:<kw> kw-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
@scheme[args], and possibly using keyword arguments. 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].

92
collects/mzlib/trace.ss
View File

@ -179,7 +179,12 @@
;; 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))
(define trace-apply
(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
@ -236,58 +241,35 @@
;; Return the results:
(apply values results))))))))))
(define-syntax trace
(lambda (stx)
(syntax-case stx ()
[(_ id ...)
(let ([ids (syntax->list (syntax (id ...)))])
(for-each (lambda (id)
(unless (identifier? id)
(raise-syntax-error
#f
"not an identifier"
stx
id)))
ids)
(with-syntax ([(traced-name ...)
(map (lambda (id)
(datum->syntax
id
(string->symbol
(string-append "traced-"
(symbol->string (syntax-e id))))
#f))
ids)])
#'(do-trace
'(id ...)
(list id ...)
(list (lambda (v) (set! id v)) ...)
(list
(let ([real-value id])
(let ([traced-name
(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)))])
traced-name))
...))))])))
(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 untrace
(lambda (stx)
(syntax-case stx ()
[(_ id ...)
(let ([ids (syntax->list (syntax (id ...)))])
(for-each (lambda (id)
(unless (identifier? id)
(raise-syntax-error
#f
"not an identifier"
stx
id)))
ids)
(syntax
(begin
(when (traced-proc? id)
(set! id (traced-proc-ref id 1)))
...)))])))
(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)))
...)]))

2
collects/redex/private/reduction-semantics.ss
View File

@ -1480,7 +1480,7 @@
(parameterize ([current-trace-print-args
(λ (name args kws kw-args level)
(ot name (car args) kws kw-args level))])
(trace-apply name metafunc '() '() exp))
(trace-call name metafunc exp))
(metafunc exp)))])
traced-metafunc)
compiled-patterns