suzanne.soy/compatibility
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

original commit: 6cea680b629e66cf7ef796b251e386258bb8f08f
This commit is contained in:
Eli Barzilay 2009-09-29 07:33:07 +00:00
parent 572f69c778
commit dedd29a452
1 changed files with 37 additions and 55 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

70
collects/mzlib/trace.ss
View File

@ -179,7 +179,12 @@
;; the nesting depth: ;; the nesting depth:
(define -:trace-level-key (gensym)) (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 ;; Apply a traced procedure to arguments, printing arguments
;; and results. We set and inspect the -:trace-level-key continuation ;; and results. We set and inspect the -:trace-level-key continuation
@ -236,58 +241,35 @@
;; Return the results: ;; Return the results:
(apply values results)))))))))) (apply values results))))))))))
(define-syntax trace (define-for-syntax (check-ids stx ids)
(lambda (stx) (for ([id (in-list (syntax->list ids))])
(syntax-case stx ()
[(_ id ...)
(let ([ids (syntax->list (syntax (id ...)))])
(for-each (lambda (id)
(unless (identifier? id) (unless (identifier? id)
(raise-syntax-error (raise-syntax-error #f "not an identifier" stx id)))
#f #t)
"not an identifier"
stx (define-syntax (trace stx)
id))) (syntax-case stx ()
ids) [(_ id ...) (check-ids stx #'(id ...))
(with-syntax ([(traced-name ...) (with-syntax ([(tid ...)
(map (lambda (id) (for/list ([id (in-list (syntax->list #'(id ...)))])
(datum->syntax (let ([tid (format "traced-~a" (syntax-e id))])
id (datum->syntax id (string->symbol tid) #f)))])
(string->symbol
(string-append "traced-"
(symbol->string (syntax-e id))))
#f))
ids)])
#'(do-trace #'(do-trace
'(id ...) '(id ...)
(list id ...) (list id ...)
(list (lambda (v) (set! id v)) ...) (list (lambda (v) (set! id v)) ...)
(list (list (let* ([real-value id]
(let ([real-value id]) [tid (make-keyword-procedure
(let ([traced-name
(make-keyword-procedure
(lambda (kws vals . args) (lambda (kws vals . args)
(do-traced 'id args kws vals real-value)) (do-traced 'id args kws vals real-value))
(lambda args (lambda args
(do-traced 'id args null null real-value)))]) (do-traced 'id args null null real-value)))])
traced-name)) tid)
...))))]))) ...)))]))
(define-syntax untrace (define-syntax (untrace stx)
(lambda (stx)
(syntax-case stx () (syntax-case stx ()
[(_ id ...) [(_ id ...) (check-ids stx #'(id ...))
(let ([ids (syntax->list (syntax (id ...)))]) #'(begin (when (traced-proc? 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))) (set! id (traced-proc-ref id 1)))
...)))]))) ...)]))