From 30e08424ec09a4a8c511d83519f20181d1744ef7 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Fri, 29 Jan 2010 00:08:15 +0000 Subject: [PATCH] merge to trunk svn: r17877 original commit: 9789615ed9840f09a6708d27276cf892d334b653 --- .../typecheck/check-subforms-unit.ss | 44 +++++++++++-------- .../typed-scheme/typecheck/internal-forms.ss | 23 ++++++---- collects/typed-scheme/typecheck/tc-structs.ss | 7 ++- .../typed-scheme/typecheck/tc-toplevel.ss | 35 ++++++++++----- collects/typed-scheme/utils/tc-utils.ss | 17 ++++--- 5 files changed, 80 insertions(+), 46 deletions(-) diff --git a/collects/typed-scheme/typecheck/check-subforms-unit.ss b/collects/typed-scheme/typecheck/check-subforms-unit.ss index ea97a7f1..037822e2 100644 --- a/collects/typed-scheme/typecheck/check-subforms-unit.ss +++ b/collects/typed-scheme/typecheck/check-subforms-unit.ss @@ -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))) diff --git a/collects/typed-scheme/typecheck/internal-forms.ss b/collects/typed-scheme/typecheck/internal-forms.ss index a0ce6e9c..5c5b6387 100644 --- a/collects/typed-scheme/typecheck/internal-forms.ss +++ b/collects/typed-scheme/typecheck/internal-forms.ss @@ -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) diff --git a/collects/typed-scheme/typecheck/tc-structs.ss b/collects/typed-scheme/typecheck/tc-structs.ss index 99fd72e6..634d1dd9 100644 --- a/collects/typed-scheme/typecheck/tc-structs.ss +++ b/collects/typed-scheme/typecheck/tc-structs.ss @@ -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)) diff --git a/collects/typed-scheme/typecheck/tc-toplevel.ss b/collects/typed-scheme/typecheck/tc-toplevel.ss index 328123f6..5d0a6532 100644 --- a/collects/typed-scheme/typecheck/tc-toplevel.ss +++ b/collects/typed-scheme/typecheck/tc-toplevel.ss @@ -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 diff --git a/collects/typed-scheme/utils/tc-utils.ss b/collects/typed-scheme/utils/tc-utils.ss index 60f996ec..69c990e8 100644 --- a/collects/typed-scheme/utils/tc-utils.ss +++ b/collects/typed-scheme/utils/tc-utils.ss @@ -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 ()