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

merge to trunk

Browse Source 
svn: r17877

original commit: 9789615ed9840f09a6708d27276cf892d334b653
This commit is contained in:
Sam Tobin-Hochstadt 2010-01-29 00:08:15 +00:00
parent d20ee9bf2b
commit 30e08424ec
5 changed files with 80 additions and 46 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

44
collects/typed-scheme/typecheck/check-subforms-unit.ss
View File

@ -2,6 +2,7 @@
(require "../utils/utils.ss"
syntax/kerncase
syntax/parse
scheme/match
"signatures.ss" "tc-metafunctions.ss"
(types utils convenience union subtype)
@ -18,33 +19,40 @@
(define body-ty #f)
(define (get-result-ty t)
(match t
[(Function: (list (arr: _ (Values: (list (Result: rngs _ _))) #f _ '()) ...)) (apply Un rngs)]
[_ (tc-error "Internal error in get-result-ty: not a function type: ~n~a" t)]))
[(Function:
(list
(arr: _
(Values: (list (Result: rngs _ _) ...))
_ _ (list (Keyword: _ _ #t) ...))))
(apply Un rngs)]
[_ (int-err "Internal error in get-result-ty: not a function type: ~n~a" t)]))
(let loop ([form form])
(parameterize ([current-orig-stx form])
(kernel-syntax-case* form #f (#%app)
(syntax-parse form
[stx
;; if this needs to be checked
(syntax-property form 'typechecker:with-type)
#:when (syntax-property form 'typechecker:with-type)
;; the form should be already ascribed the relevant type
(void
(tc-expr form))]
(tc-expr form)]
[stx
;; this is a hander function
(syntax-property form 'typechecker:exn-handler)
(let ([t (tc-expr/t form)])
(unless (subtype t (-> (Un) Univ))
(tc-error "Exception handler must be a single-argument function, got ~n~a"))
(set! handler-tys (cons (get-result-ty t) handler-tys)))]
;; this is a handler function
#:when (syntax-property form 'typechecker:exn-handler)
(let ([t (tc-expr form)])
(match t
[(tc-result1:
(and t
(Function: (list (arr: (list _) _ _ _ (list (Keyword: _ _ #f) ...)) ...))))
(set! handler-tys (cons (get-result-ty t) handler-tys))]
[(tc-results: t)
(tc-error "Exception handler must be a single-argument function, got ~n~a" t)]))]
[stx
;; this is the body of the with-handlers
(syntax-property form 'typechecker:exn-body)
(let ([t (tc-expr/t form)])
(set! body-ty t))]
#:when (syntax-property form 'typechecker:exn-body)
(match-let ([(tc-results: ts) (tc-expr form)])
(set! body-ty (-values ts)))]
[(a . b)
(begin
(loop #'a)
(loop #'b))]
(loop #'a)
(loop #'b)]
[_ (void)])))
(ret (apply Un body-ty handler-tys)))

23
collects/typed-scheme/typecheck/internal-forms.ss
View File

@ -1,16 +1,21 @@
#lang scheme/base
(require (for-syntax scheme/base))
(require (for-syntax scheme/base)
syntax/parse)
(define-syntax-rule (internal-forms nms ...)
(define-syntax-rule (internal-forms set-name nms ...)
(begin
(provide nms ...)
(provide nms ... set-name)
(define-literal-set set-name (nms ...))
(define-syntax (nms stx) (raise-syntax-error 'typecheck "Internal typechecker form used out of context" stx)) ...))
(internal-forms require/typed-internal define-type-alias-internal
define-typed-struct-internal
define-typed-struct/exec-internal
assert-predicate-internal
declare-refinement-internal
:-internal)
(internal-forms internal-literals
require/typed-internal
define-type-alias-internal
define-type-internal
define-typed-struct-internal
define-typed-struct/exec-internal
assert-predicate-internal
declare-refinement-internal
:-internal)

7
collects/typed-scheme/typecheck/tc-structs.ss
View File

@ -90,6 +90,7 @@
#:mutable [setters? #f]
#:proc-ty [proc-ty #f]
#:maker [maker* #f]
#:predicate [pred* #f]
#:constructor-return [cret #f]
#:poly? [poly? #f]
#:type-only [type-only #f])
@ -107,6 +108,7 @@
#:type-wrapper type-wrapper
#:pred-wrapper pred-wrapper
#:maker (or maker* maker)
#:predicate (or pred* pred)
#:constructor-return cret))))
;; generate names, and register the approriate types give field types and structure type
@ -117,6 +119,7 @@
#:type-wrapper [type-wrapper values]
#:pred-wrapper [pred-wrapper values]
#:maker [maker* #f]
#:predicate [pred* #f]
#:constructor-return [cret #f])
;; create the approriate names that define-struct will bind
(define-values (maker pred getters setters) (struct-names nm flds setters?))
@ -127,7 +130,7 @@
(append
(list (cons (or maker* maker)
(wrapper (->* external-fld-types (if cret cret name))))
(cons pred
(cons (or pred* pred)
(make-pred-ty (pred-wrapper name))))
(for/list ([g (in-list getters)] [t (in-list external-fld-types/no-parent)] [i (in-naturals)])
(let ([func (if setters?
@ -185,6 +188,7 @@
;; tc/struct : (U identifier (list identifier identifier)) Listof[identifier] Listof[syntax] -> void
(define (tc/struct nm/par flds tys [proc-ty #f]
#:maker [maker #f] #:constructor-return [cret #f] #:mutable [mutable #f]
#:predicate [pred #f]
#:type-only [type-only #f])
;; get the parent info and create some types and type variables
(define-values (nm parent-name parent name name-tvar) (parse-parent nm/par))
@ -200,6 +204,7 @@
;; procedure
#:proc-ty proc-ty-parsed
#:maker maker
#:predicate pred
#:constructor-return (and cret (parse-type cret))
#:mutable mutable
#:type-only type-only))

35
collects/typed-scheme/typecheck/tc-toplevel.ss
View File

@ -3,11 +3,13 @@
(require (rename-in "../utils/utils.ss" [infer r:infer]))
(require syntax/kerncase
unstable/list unstable/syntax
unstable/list unstable/syntax syntax/parse
mzlib/etc
scheme/match
"signatures.ss"
"tc-structs.ss"
;; to appease syntax-parse
"internal-forms.ss"
(rep type-rep)
(types utils convenience)
(private parse-type type-annotation type-contract)
@ -29,13 +31,17 @@
;; first, find the mutated variables:
(find-mutated-vars form)
(parameterize ([current-orig-stx form])
(kernel-syntax-case* form #f (define-type-alias-internal define-typed-struct-internal define-type-internal
define-typed-struct/exec-internal :-internal assert-predicate-internal
require/typed-internal values)
(syntax-parse form
#:literals (values define-type-alias-internal define-typed-struct-internal define-type-internal
define-typed-struct/exec-internal :-internal assert-predicate-internal
require/typed-internal declare-refinement-internal
define-values quote-syntax #%plain-app begin)
;#:literal-sets (kernel-literals)
;; forms that are handled in other ways
[stx
(or (syntax-property form 'typechecker:ignore)
(syntax-property form 'typechecker:ignore-some))
#:when (or (syntax-property form 'typechecker:ignore)
(syntax-property form 'typechecker:ignore-some))
(list)]
;; type aliases have already been handled by an earlier pass
@ -72,9 +78,16 @@
(tc/struct #'nm (syntax->list #'(fld ...)) (syntax->list #'(ty ...)))]
[(define-values () (begin (quote-syntax (define-typed-struct-internal nm ([fld : ty] ...) #:mutable)) (#%plain-app values)))
(tc/struct #'nm (syntax->list #'(fld ...)) (syntax->list #'(ty ...)) #:mutable #t)]
[(define-values () (begin (quote-syntax (define-typed-struct-internal nm ([fld : ty] ...) #:maker m #:constructor-return t))
[(define-values () (begin (quote-syntax (define-typed-struct-internal nm ([fld : ty] ...)
#:maker m #:constructor-return t #:predicate p))
(#%plain-app values)))
(tc/struct #'nm (syntax->list #'(fld ...)) (syntax->list #'(ty ...)) #:maker #'m #:constructor-return #'t)]
(tc/struct #'nm (syntax->list #'(fld ...)) (syntax->list #'(ty ...))
#:maker #'m #:constructor-return #'t #:predicate #'p)]
[(define-values () (begin (quote-syntax (define-typed-struct-internal nm ([fld : ty] ...)
#:maker m #:constructor-return t))
(#%plain-app values)))
(tc/struct #'nm (syntax->list #'(fld ...)) (syntax->list #'(ty ...))
#:maker #'m #:constructor-return #'t)]
[(define-values () (begin (quote-syntax (define-typed-struct-internal nm ([fld : ty] ...) #:type-only))
(#%plain-app values)))
(tc/struct #'nm (syntax->list #'(fld ...)) (syntax->list #'(ty ...)) #:type-only #t)]
@ -91,8 +104,7 @@
(register-type #'pred (make-pred-ty (parse-type #'ty)))]
;; top-level type annotation
[(define-values () (begin (quote-syntax (:-internal id ty)) (#%plain-app values)))
(identifier? #'id)
[(define-values () (begin (quote-syntax (:-internal id:identifier ty)) (#%plain-app values)))
(register-type/undefined #'id (parse-type #'ty))]
@ -128,8 +140,7 @@
(apply append (filter list? (map tc-toplevel/pass1 (syntax->list #'rest))))]
;; define-syntaxes just get noted
[(define-syntaxes (var ...) . rest)
(andmap identifier? (syntax->list #'(var ...)))
[(define-syntaxes (var:id ...) . rest)
(map make-def-stx-binding (syntax->list #'(var ...)))]
;; otherwise, do nothing in this pass

17
collects/typed-scheme/utils/tc-utils.ss
View File

@ -6,7 +6,9 @@ don't depend on any other portion of the system
|#
(provide (all-defined-out))
(require "syntax-traversal.ss" syntax/parse (for-syntax scheme/base syntax/parse) scheme/match
(require "syntax-traversal.ss"
"utils.ss"
syntax/parse (for-syntax scheme/base syntax/parse) scheme/match
(for-syntax unstable/syntax))
;; a parameter representing the original location of the syntax being currently checked
@ -127,11 +129,14 @@ don't depend on any other portion of the system
(define-struct (exn:fail:tc exn:fail) ())
;; raise an internal error - typechecker bug!
(define (int-err msg . args)
(raise (make-exn:fail:tc (string-append "Internal Typechecker Error: "
(apply format msg args)
(format "\nwhile typechecking\n~a" (syntax->datum (current-orig-stx))))
(current-continuation-marks))))
(define (int-err msg . args)
(parameterize ([custom-printer #t])
(raise (make-exn:fail:tc (string-append "Internal Typechecker Error: "
(apply format msg args)
(format "\nwhile typechecking\n~aoriginally\n~a"
(syntax->datum (current-orig-stx))
(syntax->datum (locate-stx (current-orig-stx)))))
(current-continuation-marks)))))
(define-syntax (nyi stx)
(syntax-case stx ()