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

.

Browse Source 
original commit: 9756e38c213a1e814cc7e1a7f6834425f95dfc7d
This commit is contained in:
Matthew Flatt 2004-11-02 19:10:49 +00:00
parent 8decda38f9
commit 575a95b313
1 changed files with 24 additions and 44 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

68
collects/mzlib/trace.ss
View File

@ -130,39 +130,24 @@
0)))) 0))))
(for-each pretty-print (cdr results))))))))) (for-each pretty-print (cdr results)))))))))
(define-struct traced-entry (original-proc trace-proc)) ;; A traced-proc struct instance acts like a procedure,
;; but preserves the original, too.
(define -:make-traced-entry make-traced-entry) (define-values (struct:traced-proc make-traced-proc traced-proc? traced-proc-ref traced-proc-set!)
(define -:traced-entry-original-proc traced-entry-original-proc) (make-struct-type 'traced-proc #f 2 0 #f null (current-inspector) 0))
(define -:traced-entry-trace-proc traced-entry-trace-proc)
(define -:trace-table
(make-hash-table))
;; Install traced versions of a given set of procedures. The traced ;; Install traced versions of a given set of procedures. The traced
;; versions are also given, so that they can be constructed to have ;; versions are also given, so that they can be constructed to have
;; a nice name. ;; a nice name.
(define (do-trace ids mk-traced-procs) (define (do-trace ids procs setters traced-procs)
(for-each (lambda (id) (for-each (lambda (id proc)
(let ((global (namespace-variable-value (unless (procedure? proc)
id #t (error 'trace
(lambda () (error 'trace "~s is not bound as a procedure" id))))) "the value of ~s is not a procedure: ~e" id proc)))
(unless (procedure? global) ids procs)
(error 'trace (for-each (lambda (proc setter traced-proc)
"the top-level value of ~s is not a procedure" id)))) (unless (traced-proc? proc)
ids) (setter (make-traced-proc traced-proc proc))))
(for-each (lambda (id mk-traced-proc) procs setters traced-procs)
(let ((global-value (namespace-variable-value id)))
(let ((table-entry (hash-table-get -:trace-table id (lambda () #f))))
(unless (and table-entry
(eq? global-value
(-:traced-entry-trace-proc table-entry)))
(let* ([real-value global-value]
[traced-proc (mk-traced-proc real-value)])
(hash-table-put! -:trace-table id
(-:make-traced-entry real-value traced-proc))
(namespace-set-variable-value! id traced-proc #f))))))
ids mk-traced-procs)
ids) ids)
;; Key used for a continuation mark to indicate ;; Key used for a continuation mark to indicate
@ -244,8 +229,10 @@
ids)]) ids)])
#'(do-trace #'(do-trace
'(id ...) '(id ...)
(list id ...)
(list (lambda (v) (set! id v)) ...)
(list (list
(lambda (real-value) (let ([real-value id])
(let ([traced-name (let ([traced-name
(lambda args (lambda args
(do-traced 'id args real-value))]) (do-traced 'id args real-value))])
@ -266,19 +253,12 @@
id))) id)))
ids) ids)
(syntax (syntax
(apply append (append
(list (if (traced-proc? id)
(let ((entry (hash-table-get -:trace-table (begin
'id (lambda () #f)))) (set! id (traced-proc-ref id 1))
(if (and entry '(id))
(eq? (namespace-variable-value 'id #f) null)
(-:traced-entry-trace-proc entry))) ...)))])))
(begin
(hash-table-put! -:trace-table 'id #f)
(namespace-set-variable-value! 'id (-:traced-entry-original-proc entry) #f)
(list 'id))
'()))
...))))])))
) )