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

This shouldn't have been left in.

Browse Source 
svn: r10966
This commit is contained in:
Stevie Strickland 2008-07-29 16:58:21 +00:00
parent 3379ec96b6
commit 2d9a48a11d
1 changed files with 49 additions and 53 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

102
collects/typed-scheme/typed-scheme.ss
View File

@ -39,59 +39,55 @@
(define-syntax (module-begin stx) (define-syntax (module-begin stx)
(define module-name (syntax-property stx 'enclosing-module-name)) (define module-name (syntax-property stx 'enclosing-module-name))
;(printf "BEGIN: ~a~n" (syntax->datum stx)) ;(printf "BEGIN: ~a~n" (syntax->datum stx))
(with-logging-to-file (syntax-case stx ()
"/tmp/ts-poly.log" [(mb forms ...)
#; (nest
(log-file-name (syntax-source stx) module-name) ([begin (set-box! typed-context? #t)
(syntax-case stx () (start-timing module-name)]
[(mb forms ...) [with-handlers
(nest ([(lambda (e) (and catch-errors? (exn:fail? e) (not (exn:fail:syntax? e))))
([begin (set-box! typed-context? #t) (lambda (e) (tc-error "Internal error: ~a" e))])]
(start-timing module-name)] [parameterize (;; a cheat to avoid units
[with-handlers [infer-param infer]
([(lambda (e) (and catch-errors? (exn:fail? e) (not (exn:fail:syntax? e)))) ;; do we report multiple errors
(lambda (e) (tc-error "Internal error: ~a" e))])] [delay-errors? #t]
[parameterize (;; a cheat to avoid units ;; this parameter is for parsing types
[infer-param infer] [current-tvars initial-tvar-env]
;; do we report multiple errors ;; this parameter is just for printing types
[delay-errors? #t] ;; this is a parameter to avoid dependency issues
;; this parameter is for parsing types [current-type-names
[current-tvars initial-tvar-env] (lambda ()
;; this parameter is just for printing types (append
;; this is a parameter to avoid dependency issues (type-name-env-map (lambda (id ty)
[current-type-names (cons (syntax-e id) ty)))
(lambda () (type-alias-env-map (lambda (id ty)
(append (cons (syntax-e id) ty)))))]
(type-name-env-map (lambda (id ty) ;; reinitialize seen type variables
(cons (syntax-e id) ty))) [type-name-references null])]
(type-alias-env-map (lambda (id ty) [begin (do-time "Initialized Envs")]
(cons (syntax-e id) ty)))))] ;; local-expand the module
;; reinitialize seen type variables ;; pmb = #%plain-module-begin
[type-name-references null])] [with-syntax ([new-mod
[begin (do-time "Initialized Envs")] (local-expand (syntax/loc stx
;; local-expand the module (#%plain-module-begin
;; pmb = #%plain-module-begin forms ...))
[with-syntax ([new-mod 'module-begin
(local-expand (syntax/loc stx null)])]
(#%plain-module-begin [with-syntax ([(pmb body2 ...) #'new-mod])]
forms ...)) [begin (do-time "Local Expand Done")]
'module-begin [with-syntax ([after-code (parameterize ([orig-module-stx stx]
null)])] [expanded-module-stx #'new-mod])
[with-syntax ([(pmb body2 ...) #'new-mod])] (type-check #'(body2 ...)))]
[begin (do-time "Local Expand Done")] [check-syntax-help (syntax-property #'(void) 'disappeared-use (type-name-references))]
[with-syntax ([after-code (parameterize ([orig-module-stx stx] [(transformed-body ...) (remove-provides #'(body2 ...))])]
[expanded-module-stx #'new-mod]) [with-syntax ([(transformed-body ...) (change-contract-fixups #'(transformed-body ...))])])
(type-check #'(body2 ...)))] (do-time "Typechecked")
[check-syntax-help (syntax-property #'(void) 'disappeared-use (type-name-references))] #;(printf "checked ~a~n" module-name)
[(transformed-body ...) (remove-provides #'(body2 ...))])] #;(printf "created ~a types~n" (count!))
[with-syntax ([(transformed-body ...) (change-contract-fixups #'(transformed-body ...))])]) #;(printf "tried to create ~a types~n" (all-count!))
(do-time "Typechecked") #;(printf "created ~a union types~n" (union-count!))
#;(printf "checked ~a~n" module-name) ;; reconstruct the module with the extra code
#;(printf "created ~a types~n" (count!)) #'(#%module-begin transformed-body ... after-code check-syntax-help))]))
#;(printf "tried to create ~a types~n" (all-count!))
#;(printf "created ~a union types~n" (union-count!))
;; reconstruct the module with the extra code
#'(#%module-begin transformed-body ... after-code check-syntax-help))])))
(define-syntax (top-interaction stx) (define-syntax (top-interaction stx)
(syntax-case stx () (syntax-case stx ()