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

Simplify typechecking for some field initializers

Browse Source 
This seems to speed up type-checking for some
initializers. The caveat is that it's slightly less
paranoid about type-checking the expansion.
This commit is contained in:
Asumu Takikawa 2013-08-26 14:19:46 -04:00
parent 80d21e106c
commit 03c74a16ff
1 changed files with 4 additions and 26 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

30
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/check-class-unit.rkt
View File

@ -791,18 +791,6 @@
(define init-name (syntax-e #'init-external)) (define init-name (syntax-e #'init-external))
(define init-type (car (dict-ref inits init-name '(#f)))) (define init-type (car (dict-ref inits init-name '(#f))))
(cond [init-type (cond [init-type
;; This is a type for the internal `extract-args` function
;; that extracts init arguments from the object. We just
;; want to make sure that init argument default value
;; (the last argument) matches the type for the init.
;;
;; The rest is plumbing to make the type system happy.
(define extract-arg-type
(cl->* (->* (list (Un (-val #f) -Symbol) (-val init-name)
(make-Univ) (-val #f)) init-type)
(->* (list (Un (-val #f) -Symbol) (-val init-name)
(make-Univ) (->* '() init-type))
init-type)))
;; Catch the exception because the error that is produced ;; Catch the exception because the error that is produced
;; in the case of a type error is incomprehensible for a ;; in the case of a type error is incomprehensible for a
;; programmer looking at surface syntax. Raise a custom ;; programmer looking at surface syntax. Raise a custom
@ -811,10 +799,8 @@
([exn:fail:syntax? ([exn:fail:syntax?
(λ (e) (tc-error/expr "Default init value has wrong type"))]) (λ (e) (tc-error/expr "Default init value has wrong type"))])
(parameterize ([delay-errors? #f]) (parameterize ([delay-errors? #f])
(with-lexical-env/extend (unless (equal? (syntax->datum #'init-val) '(quote #f))
(list #'extract-arg) (tc-expr/check #'init-val (ret (Un init-type (->* null init-type)))))))]
(list extract-arg-type)
(tc-expr form))))]
;; If the type can't be found, it means that there was no ;; If the type can't be found, it means that there was no
;; expected type or no annotation was provided via (: ...). ;; expected type or no annotation was provided via (: ...).
;; ;;
@ -838,21 +824,13 @@
(define init-name (syntax-e #'name)) (define init-name (syntax-e #'name))
(define init-type (car (dict-ref inits init-name '(#f)))) (define init-type (car (dict-ref inits init-name '(#f))))
(cond [init-type (cond [init-type
(define extract-arg-type
(cl->* (->* (list (Un (-val #f) -Symbol) (-val init-name)
(make-Univ) (-val #f)) init-type)
(->* (list (Un (-val #f) -Symbol) (-val init-name)
(make-Univ) (->* '() init-type))
init-type)))
(with-handlers (with-handlers
([exn:fail:syntax? ([exn:fail:syntax?
;; FIXME: produce a better error message ;; FIXME: produce a better error message
(λ (e) (tc-error/expr "Default init value has wrong type"))]) (λ (e) (tc-error/expr "Default init value has wrong type"))])
(parameterize ([delay-errors? #f]) (parameterize ([delay-errors? #f])
(with-lexical-env/extend (unless (equal? (syntax->datum #'init-val) '(quote #f))
(list #'extract-arg) (tc-expr/check #'init-val (ret (Un init-type (->* null init-type)))))))]
(list extract-arg-type)
(tc-expr form))))]
[else [else
(tc-error/expr "Init argument ~a has no type annotation" (tc-error/expr "Init argument ~a has no type annotation"
init-name)])] init-name)])]