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

improved code, moved customizations to runtime so they can rely on environment variables and still be compiled

Browse Source 
svn: r9734
This commit is contained in:
Eli Barzilay 2008-05-08 11:05:02 +00:00
parent f818c88a33
commit c0957923f0
1 changed files with 27 additions and 46 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

41
collects/tests/framework/debug.ss
View File

@ -1,9 +1,6 @@
(module debug mzscheme #lang mzscheme
(provide debug-printf debug-when) (provide debug-printf debug-when)
(define-syntax debug-when
(lambda (stx)
;; all of the steps in the tcp connection ;; all of the steps in the tcp connection
(define mz-tcp? #f) (define mz-tcp? #f)
(define mr-tcp? mz-tcp?) (define mr-tcp? mz-tcp?)
@ -16,35 +13,19 @@
(define schedule? #t) (define schedule? #t)
;; all of the sexpression transactions between mz and mred ;; all of the sexpression transactions between mz and mred
(define messages? #t) (define messages? (if (getenv "PLT_BUILD") #f #t))
(define-syntax (debug-when stx)
(syntax-case stx (mr-tcp mz-tcp admin schedule messages) (syntax-case stx (mr-tcp mz-tcp admin schedule messages)
[(_ mr-tcp rest ...) [(_ mr-tcp rest ...) #'(when mr-tcp? (let () rest ...))]
(if mr-tcp? [(_ mz-tcp rest ...) #'(when mz-tcp? (let () rest ...))]
(syntax (begin rest ...)) [(_ admin rest ...) #'(when admin? (let () rest ...))]
(syntax (void)))] [(_ schedule rest ...) #'(when schedule? (let () rest ...))]
[(_ mz-tcp rest ...) [(_ messages rest ...) #'(when messages? (let () rest ...))]
(if mz-tcp? [(_ unk rest ...) (raise-syntax-error #f "unknown flag" stx #'unk)]))
(syntax (begin rest ...))
(syntax (void)))]
[(_ admin rest ...)
(if admin?
(syntax (begin rest ...))
(syntax (void)))]
[(_ schedule rest ...)
(if schedule?
(syntax (begin rest ...))
(syntax (void)))]
[(_ messages rest ...)
(if messages?
(syntax (begin rest ...))
(syntax (void)))]
[(_ unk rest ...)
(raise-syntax-error 'debug-when "unknown flag" stx (syntax unk))])))
(define-syntax debug-printf (define-syntax debug-printf
(lambda (stx) (lambda (stx)
(syntax-case stx () (syntax-case stx ()
[(_ flag fmt-string rest ...) [(_ flag fmt x ...)
(with-syntax ([flag-name (format ">> ~a: " (syntax-object->datum (syntax flag)))]) #'(debug-when flag (printf ">> ~a: ~a" 'flag (format fmt x ...)))])))
(syntax (debug-when flag (printf (string-append flag-name fmt-string) rest ...))))]))))