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

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

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