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

more mzlib scribbling

Browse Source 
svn: r8621

original commit: e958a5af7ad7cfae58f0afc3a7e2e0c801d0fdad
This commit is contained in:
Matthew Flatt 2008-02-11 14:27:42 +00:00
parent a982e14bb3
commit 732be097b2
1 changed files with 23 additions and 47 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

70
collects/mzlib/traceld.ss
View File

@ -1,49 +1,25 @@
#lang scheme/base
(module traceld scheme/base
(let ([load (current-load)]
[load-extension (current-load-extension)]
[ep (current-error-port)]
[tab ""])
(let ([mk-chain
(lambda (load)
(lambda (filename expected-module)
(fprintf ep
"~aloading ~a at ~a~n"
tab filename (current-process-milliseconds))
(begin0
(let ([s tab])
(dynamic-wind
(lambda () (set! tab (string-append " " tab)))
(lambda ()
(load filename expected-module))
(lambda () (set! tab s))))
(fprintf ep
"~adone ~a at ~a~n"
tab filename (current-process-milliseconds)))))])
(current-load (mk-chain load))
(current-load-extension (mk-chain load-extension))))
(let ([load (current-load)]
[load-extension (current-load-extension)]
[ep (current-error-port)]
[tab ""])
(let ([mk-chain
(lambda (load)
(lambda (filename expected-module)
(fprintf ep
"~aloading ~a at ~a~n"
tab filename (current-process-milliseconds))
(begin0
(let ([s tab])
(dynamic-wind
(lambda () (set! tab (string-append " " tab)))
(lambda ()
(if (regexp-match #rx#"_loader" (path->bytes filename))
(let ([f (load filename #f)])
(lambda (sym)
(fprintf ep
"~atrying ~a's ~a~n" tab filename sym)
(let-values ([(loader provided-module) (f sym)])
(values
(and loader
(lambda ()
(fprintf ep
"~astarting ~a's ~a at ~a~n"
tab filename sym
(current-process-milliseconds))
(let ([s tab])
(begin0
(dynamic-wind
(lambda () (set! tab (string-append " " tab)))
(lambda () (loader))
(lambda () (set! tab s)))
(fprintf ep
"~adone ~a's ~a at ~a~n"
tab filename sym
(current-process-milliseconds))))))
provided-module))))
(load filename expected-module)))
(lambda () (set! tab s))))
(fprintf ep
"~adone ~a at ~a~n"
tab filename (current-process-milliseconds)))))])
(current-load (mk-chain load))
(current-load-extension (mk-chain load-extension)))))