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

Add logging to typechecker main loop.

Browse Source
This commit is contained in:
Sam Tobin-Hochstadt 2011-09-05 17:27:11 -04:00
parent c25f7cea27
commit 41bfb878c3
1 changed files with 71 additions and 64 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

135
collects/typed-racket/typecheck/tc-toplevel.rkt
View File

@ -252,65 +252,70 @@
[_ (int-err "not define-type-alias")])) [_ (int-err "not define-type-alias")]))
(define (type-check forms0) (define (type-check forms0)
(begin-with-definitions (define forms (syntax->list forms0))
(define forms (syntax->list forms0)) (define-values (type-aliases struct-defs stx-defs0 val-defs0 provs reqs)
(define-values (type-aliases struct-defs stx-defs0 val-defs0 provs reqs) (filter-multiple
(filter-multiple forms
forms (internal-syntax-pred define-type-alias-internal)
(internal-syntax-pred define-type-alias-internal) (lambda (e) (or ((internal-syntax-pred define-typed-struct-internal) e)
(lambda (e) (or ((internal-syntax-pred define-typed-struct-internal) e) ((internal-syntax-pred define-typed-struct/exec-internal) e)))
((internal-syntax-pred define-typed-struct/exec-internal) e))) parse-syntax-def
parse-syntax-def parse-def
parse-def provide?
provide? define/fixup-contract?))
define/fixup-contract?)) (do-time "Form splitting done")
(for-each (compose register-type-alias parse-type-alias) type-aliases) (for-each (compose register-type-alias parse-type-alias) type-aliases)
;; add the struct names to the type table ;; add the struct names to the type table
(for-each (compose add-type-name! names-of-struct) struct-defs) (for-each (compose add-type-name! names-of-struct) struct-defs)
;; resolve all the type aliases, and error if there are cycles ;; resolve all the type aliases, and error if there are cycles
(resolve-type-aliases parse-type) (resolve-type-aliases parse-type)
;; do pass 1, and collect the defintions (do-time "Starting pass1")
(define defs (apply append (filter list? (map tc-toplevel/pass1 forms)))) ;; do pass 1, and collect the defintions
;; separate the definitions into structures we'll handle for provides (define defs (apply append (filter list? (map tc-toplevel/pass1 forms))))
(define def-tbl (do-time "Finished pass1")
(for/fold ([h (make-immutable-free-id-table)]) ;; separate the definitions into structures we'll handle for provides
([def (in-list defs)]) (define def-tbl
(dict-set h (binding-name def) def))) (for/fold ([h (make-immutable-free-id-table)])
;; typecheck the expressions and the rhss of defintions ([def (in-list defs)])
(for-each tc-toplevel/pass2 forms) (dict-set h (binding-name def) def)))
;; check that declarations correspond to definitions ;; typecheck the expressions and the rhss of defintions
(check-all-registered-types) (do-time "Starting pass2")
;; report delayed errors (for-each tc-toplevel/pass2 forms)
(report-all-errors) (do-time "Finished pass2")
(define syntax-provide? #f) ;; check that declarations correspond to definitions
(define provide-tbl (check-all-registered-types)
(for/fold ([h (make-immutable-free-id-table)]) ([p (in-list provs)]) ;; report delayed errors
(define-syntax-class unknown-provide-form (report-all-errors)
(pattern (define syntax-provide? #f)
(~and name (define provide-tbl
(~or (~datum protect) (~datum for-syntax) (~datum for-label) (~datum for-meta) (for/fold ([h (make-immutable-free-id-table)]) ([p (in-list provs)])
(~datum struct) (~datum all-from) (~datum all-from-except) (define-syntax-class unknown-provide-form
(~datum all-defined) (~datum all-defined-except) (pattern
(~datum prefix-all-defined) (~datum prefix-all-defined-except) (~and name
(~datum expand))))) (~or (~datum protect) (~datum for-syntax) (~datum for-label) (~datum for-meta)
(syntax-parse p #:literals (#%provide) (~datum struct) (~datum all-from) (~datum all-from-except)
[(#%provide form ...) (~datum all-defined) (~datum all-defined-except)
(for/fold ([h h]) ([f (syntax->list #'(form ...))]) (~datum prefix-all-defined) (~datum prefix-all-defined-except)
(parameterize ([current-orig-stx f]) (~datum expand)))))
(syntax-parse f (syntax-parse p #:literals (#%provide)
[i:id [(#%provide form ...)
(when (def-stx-binding? (dict-ref def-tbl #'i #f)) (for/fold ([h h]) ([f (syntax->list #'(form ...))])
(set! syntax-provide? #t)) (parameterize ([current-orig-stx f])
(dict-set h #'i #'i)] (syntax-parse f
[((~datum rename) in out) [i:id
(when (def-stx-binding? (dict-ref def-tbl #'in #f)) (when (def-stx-binding? (dict-ref def-tbl #'i #f))
(set! syntax-provide? #t)) (set! syntax-provide? #t))
(dict-set h #'in #'out)] (dict-set h #'i #'i)]
[(name:unknown-provide-form . _) [((~datum rename) in out)
(tc-error "provide: ~a not supported by Typed Racket" (syntax-e #'name.name))] (when (def-stx-binding? (dict-ref def-tbl #'in #f))
[_ (int-err "unknown provide form")])))] (set! syntax-provide? #t))
[_ (int-err "non-provide form! ~a" (syntax->datum p))]))) (dict-set h #'in #'out)]
;; compute the new provides [(name:unknown-provide-form . _)
(tc-error "provide: ~a not supported by Typed Racket" (syntax-e #'name.name))]
[_ (int-err "unknown provide form")])))]
[_ (int-err "non-provide form! ~a" (syntax->datum p))])))
;; compute the new provides
(define new-stx
(with-syntax* (with-syntax*
([the-variable-reference (generate-temporary #'blame)] ([the-variable-reference (generate-temporary #'blame)]
[(new-provs ...) [(new-provs ...)
@ -319,11 +324,13 @@
#,(if (null? (syntax-e #'(new-provs ...))) #,(if (null? (syntax-e #'(new-provs ...)))
#'(begin) #'(begin)
#'(define the-variable-reference (quote-module-name))) #'(define the-variable-reference (quote-module-name)))
#,(env-init-code syntax-provide? provide-tbl def-tbl) #,(env-init-code syntax-provide? provide-tbl def-tbl)
#,(tname-env-init-code) #,(tname-env-init-code)
#,(talias-env-init-code) #,(talias-env-init-code)
(begin-for-syntax #,(make-struct-table-code)) (begin-for-syntax #,(make-struct-table-code))
(begin new-provs ...))))) (begin new-provs ...))))
(do-time "finished provide generation")
new-stx)
;; typecheck a whole module ;; typecheck a whole module
;; syntax -> syntax ;; syntax -> syntax