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

92
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 () (unless (identifier? id)
[(_ id ...) (raise-syntax-error #f "not an identifier" stx id)))
(let ([ids (syntax->list (syntax (id ...)))]) #t)
(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-syntax untrace (define-syntax (trace stx)
(lambda (stx) (syntax-case stx ()
(syntax-case stx () [(_ id ...) (check-ids stx #'(id ...))
[(_ id ...) (with-syntax ([(tid ...)
(let ([ids (syntax->list (syntax (id ...)))]) (for/list ([id (in-list (syntax->list #'(id ...)))])
(for-each (lambda (id) (let ([tid (format "traced-~a" (syntax-e id))])
(unless (identifier? id) (datum->syntax id (string->symbol tid) #f)))])
(raise-syntax-error #'(do-trace
#f '(id ...)
"not an identifier" (list id ...)
stx (list (lambda (v) (set! id v)) ...)
id))) (list (let* ([real-value id]
ids) [tid (make-keyword-procedure
(syntax (lambda (kws vals . args)
(begin (do-traced 'id args kws vals real-value))
(when (traced-proc? id) (lambda args
(set! id (traced-proc-ref id 1))) (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)))
...)]))