diff --git a/collects/tests/typed-scheme/succeed/logic.ss b/collects/tests/typed-scheme/succeed/logic.ss new file mode 100644 index 00000000..34f3fd0a --- /dev/null +++ b/collects/tests/typed-scheme/succeed/logic.ss @@ -0,0 +1,16 @@ + +#lang typed-scheme + +(: f ((U Number #f) (cons Any Any) -> Number)) + +(define (f x y) + (cond + [(and (number? x) (number? (car y))) (+ x (car y))] + [(number? (car y)) (+ (bool-to-0-or-1 x) (car y))] + [(number? x) x] + [else 0])) + +(: bool-to-0-or-1 (Boolean -> Number)) + +(define (bool-to-0-or-1 b) + (if b 1 0)) \ No newline at end of file diff --git a/collects/tests/typed-scheme/unit-tests/parse-type-tests.ss b/collects/tests/typed-scheme/unit-tests/parse-type-tests.ss index a62938aa..973c53ad 100644 --- a/collects/tests/typed-scheme/unit-tests/parse-type-tests.ss +++ b/collects/tests/typed-scheme/unit-tests/parse-type-tests.ss @@ -96,6 +96,7 @@ [#t (-val #t)] [#f (-val #f)] ["foo" (-val "foo")] + ['(1 2 3) (-Tuple (map -val '(1 2 3)))] [(Listof Number) (make-Listof N)] diff --git a/collects/typed-scheme/private/parse-type.ss b/collects/typed-scheme/private/parse-type.ss index f3db1d68..d0756184 100644 --- a/collects/typed-scheme/private/parse-type.ss +++ b/collects/typed-scheme/private/parse-type.ss @@ -66,6 +66,12 @@ (make-Poly vars (parse-type #'t))))] [(t:All . rest) (tc-error "All: bad syntax")])) +(define-splicing-syntax-class keyword-tys + (pattern (~seq k:keyword t:expr) + #:attr Keyword (make-Keyword (syntax-e #'k) (parse-type #'t) #t)) + (pattern (~seq [k:keyword t:expr]) + #:attr Keyword (make-Keyword (syntax-e #'k) (parse-type #'t) #f))) + (define (parse-type stx) (parameterize ([current-orig-stx stx]) (syntax-parse @@ -119,10 +125,15 @@ (add-type-name-reference #'kw) ;; use parse-type instead of parse-values-type because we need to add the filters from the pred-ty (make-pred-ty (list (parse-type #'dom)) (parse-type #'rng) (parse-type #'pred-ty))] - [(dom ... rest ddd:star (~and kw t:->) rng) + [(dom:expr ... rest:expr ddd:star kws:keyword-tys ... (~and kw t:->) rng) (add-type-name-reference #'kw) - (->* (map parse-type (syntax->list #'(dom ...))) (parse-type #'rest) (parse-values-type #'rng))] - [(dom ... rest :ddd/bound (~and kw t:->) rng) + (make-Function + (list (make-arr + (map parse-type (syntax->list #'(dom ...))) + (parse-values-type #'rng) + #:rest (parse-type #'rest) + #:kws (attribute kws.Keyword))))] + [(dom:expr ... rest:expr :ddd/bound (~and kw t:->) rng) (add-type-name-reference #'kw) (let ([var (lookup (current-tvars) (syntax-e #'bound) (lambda (_) #f))]) (if (not (Dotted? var)) @@ -141,7 +152,7 @@ (current-tvars))]) (parse-type #'rest)) (syntax-e #'bound))))))] - [(dom ... rest _:ddd (~and kw t:->) rng) + [(dom:expr ... rest:expr _:ddd (~and kw t:->) rng) (add-type-name-reference #'kw) (let ([bounds (filter (compose Dotted? cdr) (env-keys+vals (current-tvars)))]) @@ -160,11 +171,19 @@ (current-tvars))]) (parse-type #'rest)) var)))))] - ;; has to be below the previous one - [(dom ... (~and kw t:->) rng) + #| ;; has to be below the previous one + [(dom:expr ... (~and kw t:->) rng) (add-type-name-reference #'kw) (->* (map parse-type (syntax->list #'(dom ...))) - (parse-values-type #'rng))] + (parse-values-type #'rng))] |# + ;; use expr to rule out keywords + [(dom:expr ... kws:keyword-tys ... (~and kw t:->) rng) + (add-type-name-reference #'kw) + (make-Function + (list (make-arr + (map parse-type (syntax->list #'(dom ...))) + (parse-values-type #'rng) + #:kws (attribute kws.Keyword))))] [((~and kw case-lambda) tys ...) (add-type-name-reference #'kw) (make-Function @@ -194,9 +213,12 @@ [((~and kw t:U) ts ...) (add-type-name-reference #'kw) (apply Un (map parse-type (syntax->list #'(ts ...))))] + [((~and kw quote) (t1 . t2)) + (add-type-name-reference #'kw) + (-pair (parse-type #'(quote t1)) (parse-type #'(quote t2)))] [((~and kw quote) t) (add-type-name-reference #'kw) - (-val (syntax-e #'t))] + (-val (syntax->datum #'t))] #; [(All-kw . rest) #:fail-unless (eq? 'All (syntax-e #'All-kw)) #f diff --git a/collects/typed-scheme/private/type-contract.ss b/collects/typed-scheme/private/type-contract.ss index 6e348b96..5ac589a9 100644 --- a/collects/typed-scheme/private/type-contract.ss +++ b/collects/typed-scheme/private/type-contract.ss @@ -70,25 +70,34 @@ [(Function: arrs) (let () (define (f a) - (define-values (dom* rngs* rst) + (define-values (dom* opt-dom* rngs* rst) (match a - [(arr: dom (Values: (list (Result: rngs (LFilterSet: '() '()) (LEmpty:)) ...)) rst #f '()) - (values (map t->c/neg dom) (map t->c rngs) (and rst (t->c/neg rst)))] + [(arr: dom (Values: (list (Result: rngs (LFilterSet: '() '()) (LEmpty:)) ...)) rst #f kws) + (let-values ([(mand-kws opt-kws) (partition (match-lambda [(Keyword: _ _ mand?) mand?]) kws)] + [(conv) (match-lambda [(Keyword: kw kty _) (list kw (t->c/neg kty))])]) + (values (append (map t->c/neg dom) (append-map conv mand-kws)) + (append-map conv opt-kws) + (map t->c rngs) + (and rst (t->c/neg rst))))] [(arr: dom (Values: (list (Result: rngs _ _) ...)) rst #f '()) (if (and out? pos?) - (values (map t->c/neg dom) (map t->c rngs) (and rst (t->c/neg rst))) + (values (map t->c/neg dom) + null + (map t->c rngs) + (and rst (t->c/neg rst))) (exit (fail)))] [_ (exit (fail))])) (trace f) (with-syntax ([(dom* ...) dom*] + [(opt-dom* ...) opt-dom*] [rng* (match rngs* [(list r) r] [_ #`(values #,@rngs*)])] [rst* rst]) - (if rst - #'((dom* ...) () #:rest (listof rst*) . ->* . rng*) - #'(dom* ... . -> . rng*)))) + (if (or rst (pair? (syntax-e #'(opt-dom* ...)))) + #'((dom* ...) (opt-dom* ...) #:rest (listof rst*) . ->* . rng*) + #'(dom* ... . -> . rng*)))) (unless (no-duplicates (for/list ([t arrs]) (match t [(arr: dom _ _ _ _) (length dom)]))) (exit (fail))) diff --git a/collects/typed-scheme/rep/type-rep.ss b/collects/typed-scheme/rep/type-rep.ss index a23d9c75..2e28f10a 100644 --- a/collects/typed-scheme/rep/type-rep.ss +++ b/collects/typed-scheme/rep/type-rep.ss @@ -283,7 +283,7 @@ ;; pos-flds : (Listof Type) ;; name-flds : (Listof (Tuple Symbol Type Boolean)) ;; methods : (Listof (Tuple Symbol Function)) -(dt Class ([pos-flds (listof Type/c)] +(dt Class ([pos-flds (listof Type/c)] [name-flds (listof (list/c symbol? Type/c boolean?))] [methods (listof (list/c symbol? Function?))]) [#:frees (combine-frees diff --git a/collects/typed-scheme/typecheck/tc-metafunctions.ss b/collects/typed-scheme/typecheck/tc-metafunctions.ss index 2d703756..716faecc 100644 --- a/collects/typed-scheme/typecheck/tc-metafunctions.ss +++ b/collects/typed-scheme/typecheck/tc-metafunctions.ss @@ -147,12 +147,11 @@ ;; and [((FilterSet: f1+ f1-) (FilterSet: f2+ f2-) (F-FS:)) (mk (combine (append f1+ f2+) - null - #; + null (append (for/list ([f f1-]) - (make-ImpFilter f2+ f)) + (make-ImpFilter f2+ (list f))) (for/list ([f f2-]) - (make-ImpFilter f1+ f)))))] + (make-ImpFilter f1+ (list f))))))] [(f f* f*) (mk f*)] [(_ _ _) ;; could intersect f2 and f3 here diff --git a/collects/unstable/mutated-vars.ss b/collects/unstable/mutated-vars.ss index efa9b39e..a585a2c3 100644 --- a/collects/unstable/mutated-vars.ss +++ b/collects/unstable/mutated-vars.ss @@ -13,8 +13,7 @@ ;; syntax -> void (define (fmv/list lstx) (for-each find-mutated-vars (syntax->list lstx))) - ;(when (and (pair? (syntax->datum form))) (printf "called with ~a~n" (syntax->datum form))) - (kernel-syntax-case* form #f (define-type-alias-internal define-typed-struct-internal require/typed-internal) + (kernel-syntax-case* form #f () ;; what we care about: set! [(set! v e) (begin @@ -51,5 +50,8 @@ ;; less general. ;; - What's with the typed-scheme literals? If they were needed, then ;; typed-scheme is probably broken now. +;; ryanc: +;; - The for-template is needed. +;; - I've removed the bogus literals. (provide find-mutated-vars is-var-mutated?)