101 lines
2.8 KiB
Scheme
101 lines
2.8 KiB
Scheme
|
|
(with-handlers ([exn:fail:contract:variable?
|
|
(lambda (exn)
|
|
(namespace-set-variable-value!
|
|
'flat-load
|
|
"mz.ss"))])
|
|
(namespace-variable-value 'flat-load))
|
|
|
|
(with-handlers ([exn:fail:contract:variable?
|
|
(lambda (exn)
|
|
(namespace-set-variable-value!
|
|
'lines-per-file
|
|
+inf.0))])
|
|
(namespace-variable-value 'lines-per-file))
|
|
|
|
(with-handlers ([exn:fail:contract:variable?
|
|
(lambda (exn)
|
|
(namespace-set-variable-value!
|
|
'flat-number
|
|
""))])
|
|
(namespace-variable-value 'flat-number))
|
|
|
|
(require mzlib/pretty)
|
|
|
|
(define line-count 0)
|
|
(define file-count 0)
|
|
|
|
(define flatp (open-output-file (format "flat~a.ss" flat-number) #:exists 'replace))
|
|
(define old-eval (current-eval))
|
|
(define old-namespace (current-namespace))
|
|
|
|
(pretty-print '(define error-test void) flatp)
|
|
(pretty-print '(define building-flat-tests? #t) flatp)
|
|
(pretty-print '(define section #f) flatp)
|
|
|
|
(define (flat-pp v)
|
|
(parameterize ([print-hash-table #t])
|
|
(pretty-print (if (syntax? v) (syntax->datum v) v) flatp))
|
|
(set! line-count (add1 line-count))
|
|
(when (>= line-count lines-per-file)
|
|
(set! line-count 0)
|
|
(set! file-count (add1 file-count))
|
|
(close-output-port flatp)
|
|
(set! flatp
|
|
(open-output-file
|
|
(format "flat~a.ss" file-count)
|
|
#:exists 'replace))))
|
|
|
|
(define error-test
|
|
(case-lambda
|
|
[(expr) (error-test expr #f)]
|
|
[(expr exn?)
|
|
(unless (or (eq? exn? exn:fail:syntax?)
|
|
(syntax-case expr (define define-values define-syntax define-syntaxes)
|
|
[(define . _) #t]
|
|
[(define-values . _) #t]
|
|
[(define-syntax . _) #t]
|
|
[(define-syntaxes . _) #t]
|
|
[_else #f]))
|
|
(let ([dexpr (syntax->datum expr)])
|
|
(flat-pp
|
|
`(thunk-error-test (lambda () ,dexpr)
|
|
(quote-syntax ,dexpr)
|
|
,@(if exn?
|
|
(list (object-name exn?))
|
|
null)))))]))
|
|
|
|
(define building-flat-tests? #t)
|
|
|
|
(dynamic-wind
|
|
(lambda ()
|
|
(current-eval
|
|
(lambda (e)
|
|
(unless (or (syntax-case* e (load load-relative error-test unless) (lambda (a b)
|
|
(eq? (syntax-e a) (syntax-e b)))
|
|
[(load . _) #t]
|
|
[(load-relative . _) #t]
|
|
[(error-test . _) #t]
|
|
[(unless _ (load-relative s)) (string? (syntax-e (syntax s))) #t]
|
|
[else #f])
|
|
(compiled-expression? e)
|
|
(and (syntax? e) (compiled-expression? (syntax-e e)))
|
|
(not (eq? (current-namespace) old-namespace))
|
|
;; Skip test use of `eval' on unprintable value:
|
|
(and (pair? e) (pair? (cdr e))
|
|
(eq? void (cadr e))))
|
|
(flat-pp e))
|
|
(if (syntax-case* e (quote hygiene) (lambda (a b)
|
|
(eq? (syntax-e a) (syntax-e b)))
|
|
[(_ __ 'hygiene . ___) #t]
|
|
[_else #f])
|
|
;; Don't save the evaluated:
|
|
(parameterize ([current-eval old-eval])
|
|
(old-eval e))
|
|
;; Normal:
|
|
(old-eval e)))))
|
|
(lambda ()
|
|
(load-relative flat-load))
|
|
(lambda ()
|
|
(current-eval old-eval)))
|