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

release

Browse Source 
original commit: 073414307e5da24d74c9590fdec311abfe03dd99
This commit is contained in:
Matthew Flatt 1997-08-19 20:55:34 +00:00
parent d0d3c170d7
commit 838b443062
1 changed files with 48 additions and 40 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

88
collects/mzlib/trace.ss
View File

@ -1,13 +1,10 @@
; Time-stamp: <97/08/19 13:54:02 shriram> ; Time-stamp: <97/08/19 15:07:32 shriram>
; Time-stamp: <97/07/12 12:44:01 shriram> ; Time-stamp: <97/07/12 12:44:01 shriram>
; Differences from the Chez implementation: ; Differences from the Chez implementation:
; - The code does not respect tail-calls. ; - The code does not respect tail-calls.
; - If one of the identifiers supplied to trace yields an error (such ; - If the library is loaded more than once, especially in the middle
; as not being bound), the identifiers in the prefix to the
; erroneous one will still be traced.
; - If trace.ss is loaded more than once, especially in the middle
; of a trace, the behavior is not well-defined. ; of a trace, the behavior is not well-defined.
(define-signature mzlib:trace^ (define-signature mzlib:trace^
@ -164,48 +161,59 @@
(let loop ((ids ids)) (let loop ((ids ids))
(unless (null? ids) (unless (null? ids)
(unless (symbol? (car ids)) (unless (symbol? (car ids))
(error 'trace "~s not an identifier" (car ids))) (error 'trace "~s not a name" (car ids)))
(loop (cdr ids)))) (loop (cdr ids))))
`(#%begin `(#%begin
,@(map ,@(map
(lambda (id) (lambda (id)
(let ((traced-name (string->symbol `(#%with-handlers ((#%exn:variable?
(string-append "traced-"
(symbol->string id))))
(real-value (gensym 'real-value))
(global-value (gensym 'global-value)))
`(with-handlers ((#%exn:variable?
(#%lambda (exn) (#%lambda (exn)
(#%if (#%eq? (#%exn:variable-id exn) ',id) (#%if (#%eq? (#%exn:variable-id exn) ',id)
(#%error 'trace (#%error 'trace
"~s is not bound" ',id) "~s is not bound" ',id)
(#%raise exn))))) (#%raise exn)))))
(#%let ((,global-value (#%global-defined-value ',id))) (#%let ((global (#%global-defined-value ',id)))
(unless (#%procedure? ,global-value) (#%unless (#%procedure? global)
(#%error 'trace (#%error 'trace
"the top-level value of ~s is not a procedure" ',id)) "the top-level value of ~s is not a procedure" ',id)))))
(#%let* ((,real-value ,global-value) ids)
(,traced-name ,@(map
(#%lambda args (lambda (id)
(#%dynamic-wind (let ((traced-name (string->symbol
(lambda () (string-append "traced-"
(#%set! -:trace-level (symbol->string id))))
(#%add1 -:trace-level))) (table-entry (gensym 'table-entry))
(lambda () (real-value (gensym 'real-value))
(-:trace-print-args ',id args) (global-value (gensym 'global-value)))
(#%call-with-values `(#%let ((,global-value (#%global-defined-value ',id)))
(#%lambda () (#%let ((,table-entry (#%hash-table-get -:trace-table ',id
(#%apply ,real-value args)) (#%lambda () #f))))
(#%lambda results (#%unless (#%and ,table-entry
(flush-output) (#%eq? ,global-value
(-:trace-print-results ',id results) (-:traced-entry-trace-proc ,table-entry)))
(#%apply #%values results)))) (#%let* ((,real-value ,global-value)
(lambda () (,traced-name
(#%set! -:trace-level (#%lambda args
(#%sub1 -:trace-level))))))) (#%dynamic-wind
(#%hash-table-put! -:trace-table ',id (lambda ()
(-:make-traced-entry ,real-value ,traced-name)) (#%set! -:trace-level
(#%global-defined-value ',id ,traced-name)))))) (#%add1 -:trace-level)))
(lambda ()
(-:trace-print-args ',id args)
(#%call-with-values
(#%lambda ()
(#%apply ,real-value args))
(#%lambda results
(flush-output)
(-:trace-print-results ',id
results)
(#%apply #%values results))))
(lambda ()
(#%set! -:trace-level
(#%sub1 -:trace-level)))))))
(#%hash-table-put! -:trace-table ',id
(-:make-traced-entry ,real-value ,traced-name))
(#%global-defined-value ',id ,traced-name)))))))
ids) ids)
(#%quote ,ids)))) (#%quote ,ids))))
@ -222,12 +230,12 @@
`(let ((entry (#%hash-table-get -:trace-table `(let ((entry (#%hash-table-get -:trace-table
',id (#%lambda () #f)))) ',id (#%lambda () #f))))
(#%if (#%and entry (#%if (#%and entry
(#%eq? ,id (#%eq? (#%global-defined-value ',id)
(-:traced-entry-trace-proc entry))) (-:traced-entry-trace-proc entry)))
(#%begin (#%begin
(#%hash-table-put! -:trace-table (#%hash-table-put! -:trace-table
',id #f) ',id #f)
(#%set! ,id (#%global-defined-value ',id
(-:traced-entry-original-proc entry)) (-:traced-entry-original-proc entry))
(#%list ',id)) (#%list ',id))
'()))) '())))