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

Use 'no-free-identifier=? property with rename transformers.

Browse Source 
Allow use of ... without bound when only one ... var in scope.

svn: r14214

original commit: 6d8014783b16c2d31624f8bd5f6d25d9fb10b5e2
This commit is contained in:
Sam Tobin-Hochstadt 2009-03-22 12:41:26 +00:00
parent fdfa1cd04a
commit 56216d320e
5 changed files with 76 additions and 4 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
collects/tests/typed-scheme/succeed/no-bound-fl.ss Normal file
View File

@ -0,0 +1,11 @@
#lang typed-scheme
(: fold-left (All (a b ...) ((a b ... -> a) a (Listof b) ... -> a)))
(define (fold-left f a . bss)
(if (ormap null? bss)
a
(apply fold-left
f
(apply f a (map car bss))
(map cdr bss))))

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

@ -80,6 +80,10 @@
[(All (a ...) (a ... a -> Integer)) (-polydots (a) ( (list) (a a) . ->... . -Integer))]
[(∀ (a) (Listof a)) (-poly (a) (make-Listof a))]
[(∀ (a ...) (a ... a -> Integer)) (-polydots (a) ( (list) (a a) . ->... . -Integer))]
[(All (a ...) (a ... -> Number))
(-polydots (a) ((list) [a a] . ->... . N))]
[(All (a ...) (values a ...))
(-polydots (a) (make-ValuesDots (list) a 'a))]
[(case-lambda (Number -> Boolean) (Number Number -> Number)) (cl-> [(N) B]
[(N N) N])]
[1 (-val 1)]
@ -91,6 +95,8 @@
[a (-v a) (extend-env (list 'a) (list (-v a))
initial-tvar-env)]
[(All (a ...) (a ... -> Number))
(-polydots (a) ((list) [a a] . ->... . N))]
))

14
collects/typed-scheme/env/type-environments.ss vendored
View File

@ -8,6 +8,9 @@
extend/values
dotted-env
initial-tvar-env
env-filter
env-vals
env-keys+vals
with-dotted-env/extend)
(require (prefix-in r: "../utils/utils.ss"))
@ -17,6 +20,17 @@
;; eq? has the type of equal?, and l is an alist (with conses!)
(define-struct env (eq? l))
(define (env-vals e)
(map cdr (env-l e)))
(define (env-keys+vals e)
(env-l e))
(define (env-filter f e)
(match e
[(struct env (eq? l))
(make-env eq? (filter f l))]))
;; the initial type variable environment - empty
;; this is used in the parsing of types
(define initial-tvar-env (make-env eq? '()))

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

@ -350,6 +350,26 @@
(current-tvars))])
(parse-type #'rest))
(syntax-e #'bound)))))))]
[(dom ... rest ::: -> rng)
(and (eq? (syntax-e #'->) '->)
(eq? (syntax-e #':::) '...))
(begin
(add-type-name-reference #'->)
(let ([bounds (filter (compose Dotted? cdr) (env-keys+vals (current-tvars)))])
(when (null? bounds)
(tc-error/stx stx "No type variable bound with ... in scope for ... type"))
(unless (null? (cdr bounds))
(tc-error/stx stx "Cannot infer bound for ... type"))
(match-let ([(cons var (struct Dotted (t))) (car bounds)])
(make-Function
(list
(make-arr-dots (map parse-type (syntax->list #'(dom ...)))
(parse-type #'rng)
(parameterize ([current-tvars (extend-env (list var)
(list (make-DottedBoth t))
(current-tvars))])
(parse-type #'rest))
var))))))]
;; has to be below the previous one
[(dom ... -> rng)
(eq? (syntax-e #'->) '->)
@ -369,6 +389,23 @@
(current-tvars))])
(parse-type #'dty))
(syntax-e #'bound))))]
[(values tys ... dty dd)
(and (eq? (syntax-e #'values) 'values)
(eq? (syntax-e #'dd) '...))
(begin
(add-type-name-reference #'values)
(let ([bounds (filter (compose Dotted? cdr) (env-keys+vals (current-tvars)))])
(when (null? bounds)
(tc-error/stx stx "No type variable bound with ... in scope for ... type"))
(unless (null? (cdr bounds))
(tc-error/stx stx "Cannot infer bound for ... type"))
(match-let ([(cons var (struct Dotted (t))) (car bounds)])
(make-ValuesDots (map parse-type (syntax->list #'(tys ...)))
(parameterize ([current-tvars (extend-env (list var)
(list (make-DottedBoth t))
(current-tvars))])
(parse-type #'dty))
var))))]
[(values tys ...)
(eq? (syntax-e #'values) 'values)
(-values (map parse-type (syntax->list #'(tys ...))))]

12
collects/typed-scheme/typecheck/provide-handling.ss
View File

@ -54,15 +54,18 @@
(define/contract cnt-id #,cnt id)
(define-syntax export-id
(if (unbox typed-context?)
(make-rename-transformer #'id)
(make-rename-transformer #'cnt-id)))
(make-rename-transformer (syntax-property #'id
'not-free-identifier=? #t))
(make-rename-transformer (syntax-property #'cnt-id
'not-free-identifier=? #t))))
(#%provide (rename export-id out-id)))))]
[else
(with-syntax ([(export-id) (generate-temporaries #'(id))])
#`(begin
(define-syntax export-id
(if (unbox typed-context?)
(make-rename-transformer #'id)
(make-rename-transformer (syntax-property #'id
'not-free-identifier=? #t))
(lambda (stx) (tc-error/stx stx "The type of ~a cannot be converted to a contract" (syntax-e #'id)))))
(provide (rename-out [export-id out-id]))))])))]
[(mem? internal-id stx-defs)
@ -76,7 +79,8 @@
(if (unbox typed-context?)
(begin
(add-alias #'export-id #'id)
(make-rename-transformer #'id))
(make-rename-transformer (syntax-property #'id
'not-free-identifier=? #t)))
(lambda (stx)
(tc-error/stx stx "Macro ~a from typed module used in untyped code" (syntax-e #'out-id)))))
(provide (rename-out [export-id out-id]))))))]