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

checkpoint

Browse Source 
svn: r17258

original commit: 5767e23d875f1248e23132fe11f5b6b4ffb5cc39
This commit is contained in:
Sam Tobin-Hochstadt 2009-12-10 15:32:17 +00:00
commit b68c553664
7 changed files with 71 additions and 22 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

16
collects/tests/typed-scheme/succeed/logic.ss Normal file
View File

@ -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))

1
collects/tests/typed-scheme/unit-tests/parse-type-tests.ss
View File

@ -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)]

38
collects/typed-scheme/private/parse-type.ss
View File

@ -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

23
collects/typed-scheme/private/type-contract.ss
View File

@ -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)))

2
collects/typed-scheme/rep/type-rep.ss
View File

@ -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

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

@ -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

6
collects/unstable/mutated-vars.ss
View File

@ -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?)