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

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

@ -1,50 +1,31 @@
(module debug mzscheme #lang mzscheme
(provide debug-printf debug-when) (provide debug-printf debug-when)
(define-syntax debug-when ;; all of the steps in the tcp connection
(lambda (stx) (define mz-tcp? #f)
(define mr-tcp? mz-tcp?)
;; all of the steps in the tcp connection ;; administrative messages about preferences files and
(define mz-tcp? #f) ;; command line flags
(define mr-tcp? mz-tcp?) (define admin? #f)
;; administrative messages about preferences files and ;; tests that passed and those that failed
;; command line flags (define schedule? #t)
(define admin? #f)
;; tests that passed and those that failed ;; all of the sexpression transactions between mz and mred
(define schedule? #t) (define messages? (if (getenv "PLT_BUILD") #f #t))
;; all of the sexpression transactions between mz and mred (define-syntax (debug-when stx)
(define messages? #t) (syntax-case stx (mr-tcp mz-tcp admin schedule messages)
[(_ mr-tcp rest ...) #'(when mr-tcp? (let () rest ...))]
[(_ mz-tcp rest ...) #'(when mz-tcp? (let () rest ...))]
[(_ admin rest ...) #'(when admin? (let () rest ...))]
[(_ schedule rest ...) #'(when schedule? (let () rest ...))]
[(_ messages rest ...) #'(when messages? (let () rest ...))]
[(_ unk rest ...) (raise-syntax-error #f "unknown flag" stx #'unk)]))
(syntax-case stx (mr-tcp mz-tcp admin schedule messages) (define-syntax debug-printf
[(_ mr-tcp rest ...) (lambda (stx)
(if mr-tcp? (syntax-case stx ()
(syntax (begin rest ...)) [(_ flag fmt x ...)
(syntax (void)))] #'(debug-when flag (printf ">> ~a: ~a" 'flag (format fmt x ...)))])))
[(_ mz-tcp rest ...)
(if mz-tcp?
(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
(lambda (stx)
(syntax-case stx ()
[(_ flag fmt-string rest ...)
(with-syntax ([flag-name (format ">> ~a: " (syntax-object->datum (syntax flag)))])
(syntax (debug-when flag (printf (string-append flag-name fmt-string) rest ...))))]))))