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

undo revision 16179, which had some junk included by mistake

Browse Source 
svn: r16180

original commit: ac39ffe73952e41758ef2454024e4d8a337a94af
This commit is contained in:
Eli Barzilay 2009-09-30 03:57:08 +00:00
parent dae17a2c21
commit 27b02aa263
1 changed files with 19 additions and 18 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

37
collects/mzlib/trace.ss
View File

@ -151,28 +151,29 @@
;; 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!)
(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 null (current-inspector) 0))
(define-struct traced-proc (proc orig)
)
;; 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 (set-traced! ids procs setters traced-procs)
(for ([id (in-list ids)] [proc (in-list procs)])
(unless (procedure? proc)
(error 'trace "the value of ~s is not a procedure: ~e" id proc)))
(for ([proc (in-list procs)]
[setter (in-list setters)]
[traced-proc (in-list traced-procs)])
(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)))))
(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:
@ -246,7 +247,7 @@
(for/list ([id (in-list (syntax->list #'(id ...)))])
(let ([tid (format "traced-~a" (syntax-e id))])
(datum->syntax id (string->symbol tid) #f)))])
#'(set-traced!
#'(do-trace
'(id ...)
(list id ...)
(list (lambda (v) (set! id v)) ...)