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

start on keywords

Browse Source
This commit is contained in:
Sam Tobin-Hochstadt 2008-08-29 18:23:59 -04:00
parent ae9e317b44
commit a8417c7c1c
10 changed files with 84 additions and 47 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

32
collects/typed-scheme/private/infer-unit.ss
View File

@ -111,15 +111,15 @@
(define (cgen/arr V X t-arr s-arr)
(define (cg S T) (cgen V X S T))
(match* (t-arr s-arr)
[((arr: ts t #f #f t-thn-eff t-els-eff)
(arr: ss s #f #f s-thn-eff s-els-eff))
[((arr: ts t #f #f '() t-thn-eff t-els-eff)
(arr: ss s #f #f '() s-thn-eff s-els-eff))
(cset-meet*
(list (cgen/list V X ss ts)
(cg t s)
(cgen/eff/list V X t-thn-eff s-thn-eff)
(cgen/eff/list V X t-els-eff s-els-eff)))]
[((arr: ts t t-rest #f t-thn-eff t-els-eff)
(arr: ss s s-rest #f s-thn-eff s-els-eff))
[((arr: ts t t-rest #f '() t-thn-eff t-els-eff)
(arr: ss s s-rest #f '() s-thn-eff s-els-eff))
(let ([arg-mapping
(cond [(and t-rest s-rest (<= (length ts) (length ss)))
(cgen/list V X (cons s-rest ss) (cons t-rest (extend ss ts t-rest)))]
@ -135,8 +135,8 @@
(list arg-mapping ret-mapping
(cgen/eff/list V X t-thn-eff s-thn-eff)
(cgen/eff/list V X t-els-eff s-els-eff))))]
[((arr: ts t #f (cons dty dbound) t-thn-eff t-els-eff)
(arr: ss s #f #f s-thn-eff s-els-eff))
[((arr: ts t #f (cons dty dbound) '() t-thn-eff t-els-eff)
(arr: ss s #f #f '() s-thn-eff s-els-eff))
(unless (memq dbound X)
(fail! S T))
(unless (<= (length ts) (length ss))
@ -148,8 +148,8 @@
(substitute (make-F var) dbound dty))]
[new-cset (cgen/arr V (append vars X) (make-arr (append ts new-tys) t #f #f t-thn-eff t-els-eff) s-arr)])
(move-vars-to-dmap new-cset dbound vars))]
[((arr: ts t #f #f t-thn-eff t-els-eff)
(arr: ss s #f (cons dty dbound) s-thn-eff s-els-eff))
[((arr: ts t #f #f '() t-thn-eff t-els-eff)
(arr: ss s #f (cons dty dbound) '() s-thn-eff s-els-eff))
(unless (memq dbound X)
(fail! S T))
(unless (<= (length ss) (length ts))
@ -161,8 +161,8 @@
(substitute (make-F var) dbound dty))]
[new-cset (cgen/arr V (append vars X) t-arr (make-arr (append ss new-tys) s #f #f s-thn-eff s-els-eff))])
(move-vars-to-dmap new-cset dbound vars))]
[((arr: ts t #f (cons t-dty dbound) t-thn-eff t-els-eff)
(arr: ss s #f (cons s-dty dbound) s-thn-eff s-els-eff))
[((arr: ts t #f (cons t-dty dbound) '() t-thn-eff t-els-eff)
(arr: ss s #f (cons s-dty dbound) '() s-thn-eff s-els-eff))
(unless (= (length ts) (length ss))
(fail! S T))
;; If we want to infer the dotted bound, then why is it in both types?
@ -175,8 +175,8 @@
(list arg-mapping darg-mapping ret-mapping
(cgen/eff/list V X t-thn-eff s-thn-eff)
(cgen/eff/list V X t-els-eff s-els-eff))))]
[((arr: ts t #f (cons t-dty dbound) t-thn-eff t-els-eff)
(arr: ss s #f (cons s-dty dbound*) s-thn-eff s-els-eff))
[((arr: ts t #f (cons t-dty dbound) '() t-thn-eff t-els-eff)
(arr: ss s #f (cons s-dty dbound*) '() s-thn-eff s-els-eff))
(unless (= (length ts) (length ss))
(fail! S T))
(let* ([arg-mapping (cgen/list V X ss ts)]
@ -186,8 +186,8 @@
(list arg-mapping darg-mapping ret-mapping
(cgen/eff/list V X t-thn-eff s-thn-eff)
(cgen/eff/list V X t-els-eff s-els-eff))))]
[((arr: ts t t-rest #f t-thn-eff t-els-eff)
(arr: ss s #f (cons s-dty dbound) s-thn-eff s-els-eff))
[((arr: ts t t-rest #f '() t-thn-eff t-els-eff)
(arr: ss s #f (cons s-dty dbound) '() s-thn-eff s-els-eff))
(unless (memq dbound X)
(fail! S T))
(if (<= (length ts) (length ss))
@ -208,8 +208,8 @@
(make-arr (append ss new-tys) s #f (cons s-dty dbound) s-thn-eff s-els-eff))])
(move-vars+rest-to-dmap new-cset dbound vars)))]
;; If dotted <: starred is correct, add it below. Not sure it is.
[((arr: ts t #f (cons t-dty dbound) t-thn-eff t-els-eff)
(arr: ss s s-rest #f s-thn-eff s-els-eff))
[((arr: ts t #f (cons t-dty dbound) '() t-thn-eff t-els-eff)
(arr: ss s s-rest #f '() s-thn-eff s-els-eff))
(unless (memq dbound X)
(fail! S T))
(cond [(< (length ts) (length ss))

14
collects/typed-scheme/private/promote-demote.ss
View File

@ -2,7 +2,7 @@
(require "type-effect-convenience.ss" "type-rep.ss"
"type-utils.ss" "union.ss"
"signatures.ss"
"signatures.ss" "utils.ss"
scheme/list)
(import)
@ -26,7 +26,7 @@
[#:Param in out
(make-Param (var-demote in V)
(vp out))]
[#:arr dom rng rest drest thn els
[#:arr dom rng rest drest kws thn els
(cond
[(apply V-in? V (append thn els))
(make-arr null (Un) Univ #f null null)]
@ -35,6 +35,8 @@
(vp rng)
(var-demote (car drest) V)
#f
(for/list ([(kw kwt) (in-pairs kws)])
(cons kw (var-demote kwt V)))
thn
els)]
[else
@ -44,6 +46,8 @@
(and drest
(cons (var-demote (car drest) V)
(cdr drest)))
(for/list ([(kw kwt) (in-pairs kws)])
(cons kw (var-demote kwt V)))
thn
els)])]))
@ -61,7 +65,7 @@
[#:Param in out
(make-Param (var-promote in V)
(vd out))]
[#:arr dom rng rest drest thn els
[#:arr dom rng rest drest kws thn els
(cond
[(apply V-in? V (append thn els))
(make-arr null (Un) Univ #f null null)]
@ -70,6 +74,8 @@
(vd rng)
(var-promote (car drest) V)
#f
(for/list ([(kw kwt) (in-pairs kws)])
(cons kw (var-promote kwt V)))
thn
els)]
[else
@ -79,5 +85,7 @@
(and drest
(cons (var-promote (car drest) V)
(cdr drest)))
(for/list ([(kw kwt) (in-pairs kws)])
(cons kw (var-promote kwt V)))
thn
els)])]))

4
collects/typed-scheme/private/rep-utils.ss
View File

@ -150,7 +150,9 @@
(lambda (s)
(...
(syntax-case s ()
[(__ . fs) (quasisyntax/loc s (struct nm #, (syntax/loc #'fs (_ . fs))))]))))
[(__ . fs)
(with-syntax ([flds** (syntax/loc s (_ . fs))])
(quasisyntax/loc s (struct nm flds**)))]))))
(begin-for-syntax
(hash-set! ht-stx 'kw-stx (list #'ex #'flds bfs-fold-rhs #'#,stx)))
intern

16
collects/typed-scheme/private/subtype.ss
View File

@ -100,10 +100,13 @@
(match (list s t)
;; top for functions is above everything
[(list _ (top-arr:)) A0]
[(list (arr: s1 s2 #f #f thn-eff els-eff) (arr: t1 t2 #f #f thn-eff els-eff))
(let ([A1 (subtypes* A0 t1 s1)])
[(list (arr: s1 s2 #f #f (list (cons kw s-kw-ty) ...) thn-eff els-eff)
(arr: t1 t2 #f #f (list (cons kw t-kw-ty) ...) thn-eff els-eff))
(let* ([A1 (subtypes* A0 t1 s1)]
[A2 (subtypes* A1 t-kw-ty s-kw-ty)])
(subtype* A1 s2 t2))]
[(list (arr: s1 s2 s3 #f thn-eff els-eff) (arr: t1 t2 t3 #f thn-eff* els-eff*))
[(list (arr: s1 s2 s3 #f (list (cons kw s-kw-ty) ...) thn-eff els-eff)
(arr: t1 t2 t3 #f (list (cons kw t-kw-ty) ...) thn-eff* els-eff*))
(unless
(or (and (null? thn-eff*) (null? els-eff*))
(and (effects-equal? thn-eff thn-eff*)
@ -115,10 +118,11 @@
(andmap sub-eff els-eff els-eff*)))
(fail! s t))
;; either the effects have to be the same, or the supertype can't have effects
(let ([A (subtypes*/varargs A0 t1 s1 s3)])
(let* ([A2 (subtypes*/varargs A0 t1 s1 s3)]
[A3 (subtypes* A2 t-kw-ty s-kw-ty)])
(if (not t3)
(subtype* A s2 t2)
(let ([A1 (subtype* A t3 s3)])
(subtype* A3 s2 t2)
(let ([A1 (subtype* A3 t3 s3)])
(subtype* A1 s2 t2))))]
[else
(fail! s t)])))

2
collects/typed-scheme/private/tc-lambda-unit.ss
View File

@ -180,7 +180,7 @@
(let loop ([expected expected])
(match expected
[(Mu: _ _) (loop (unfold expected))]
[(Function: (list (arr: argss rets rests drests _ _) ...))
[(Function: (list (arr: argss rets rests drests '() _ _) ...))
(for ([args argss] [ret rets] [rest rests] [drest drests])
(tc/lambda-clause/check (car (syntax->list formals)) (car (syntax->list bodies)) args ret rest drest))
expected]

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

@ -80,13 +80,13 @@
(define (f a)
(define-values (dom* rngs* rst)
(match a
[(arr: dom (Values: rngs) #f #f _ _)
[(arr: dom (Values: rngs) #f #f '() _ _)
(values (map t->c dom) (map t->c rngs) #f)]
[(arr: dom rng #f #f _ _)
[(arr: dom rng #f #f '() _ _)
(values (map t->c dom) (list (t->c rng)) #f)]
[(arr: dom (Values: rngs) rst #f _ _)
[(arr: dom (Values: rngs) rst #f '() _ _)
(values (map t->c dom) (map t->c rngs) (t->c rst))]
[(arr: dom rng rst #f _ _)
[(arr: dom rng rst #f '() _ _)
(values (map t->c dom) (list (t->c rng)) (t->c rst))]))
(with-syntax
([(dom* ...) dom*]

6
collects/typed-scheme/private/type-effect-convenience.ss
View File

@ -80,9 +80,9 @@
(define make-arr*
(case-lambda [(dom rng) (make-arr* dom rng #f (list) (list))]
[(dom rng rest) (make-arr dom rng rest #f (list) (list))]
[(dom rng rest eff1 eff2) (make-arr dom rng rest #f eff1 eff2)]
[(dom rng rest drest eff1 eff2) (make-arr dom rng rest drest eff1 eff2)]))
[(dom rng rest) (make-arr dom rng rest #f null (list) (list))]
[(dom rng rest eff1 eff2) (make-arr dom rng rest #f null eff1 eff2)]
[(dom rng rest drest eff1 eff2) (make-arr dom rng rest drest null eff1 eff2)]))
(define (make-arr-dots dom rng dty dbound)
(make-arr* dom rng #f (cons dty dbound) null null))

6
collects/typed-scheme/private/type-effect-printer.ss
View File

@ -46,9 +46,11 @@
(match a
[(top-arr:)
(fp "Procedure")]
[(arr: dom rng rest drest thn-eff els-eff)
[(arr: dom rng rest drest kws thn-eff els-eff)
(fp "(")
(for-each (lambda (t) (fp "~a " t)) dom)
(for ([kw kws])
(fp "~a ~a " (car kw) (cdr kw)))
(when rest
(fp "~a* " rest))
(when drest
@ -102,7 +104,7 @@
(lambda (e) (fp " ") (print-arr e))
b)
(fp ")")]))]
[(arr: _ _ _ _ _ _) (print-arr c)]
[(arr: _ _ _ _ _ _ _) (print-arr c)]
[(Vector: e) (fp "(Vectorof ~a)" e)]
[(Box: e) (fp "(Box ~a)" e)]
[(Union: elems) (fp "~a" (cons 'U elems))]

29
collects/typed-scheme/private/type-rep.ss
View File

@ -94,12 +94,15 @@
;; rng : Type
;; rest : Option[Type]
;; drest : Option[Cons[Type,Name or nat]]
;; kws : Listof[Cons[Kw, Type]]
;; rest and drest NOT both true
;; thn-eff : Effect
;; els-eff : Effect
;; arr is NOT a Type
(dt arr (dom rng rest drest thn-eff els-eff)
[#:frees (combine-frees (append (map flip-variances (map free-vars* (append (if rest (list rest) null) dom)))
(dt arr (dom rng rest drest kws thn-eff els-eff)
[#:frees (combine-frees (append (map flip-variances (map free-vars* (append (if rest (list rest) null)
(map cdr kws)
dom)))
(match drest
[(cons t (? symbol? bnd))
(list (fix-bound (flip-variances (free-vars* t)) bnd))]
@ -108,7 +111,9 @@
(list (free-vars* rng))
(map make-invariant
(map free-vars* (append thn-eff els-eff)))))
(combine-frees (append (map flip-variances (map free-idxs* (append (if rest (list rest) null) dom)))
(combine-frees (append (map flip-variances (map free-idxs* (append (if rest (list rest) null)
(map cdr kws)
dom)))
(match drest
[(cons t (? number? bnd))
(list (fix-bound (flip-variances (free-idxs* t)) bnd))]
@ -121,6 +126,8 @@
(type-rec-id rng)
(and rest (type-rec-id rest))
(and drest (cons (type-rec-id (car drest)) (cdr drest)))
(for/list ([kw kws])
(cons (car kw) (type-rec-id (cdr kw))))
(map effect-rec-id thn-eff)
(map effect-rec-id els-eff))])
@ -248,9 +255,11 @@
(define cl (quasisyntax/loc src (#,pat #,(body-f rid erid))))
cl)
(syntax-case stx ()
[(tc rec-id ty [kw pats ... es] ...)
#;(andmap (lambda (k) (keyword? (syntax-e k))) (syntax->list #'(kw ...)))
(syntax/loc stx (tc rec-id (lambda (e) (sub-eff rec-id e)) ty [kw pats ... es] ...))]
[(tc rec-id ty clauses ...)
(syntax-case #'(clauses ...) ()
[([kw pats ... es] ...) #t]
[_ #f])
(syntax/loc stx (tc rec-id (lambda (e) (sub-eff rec-id e)) ty clauses ...))]
[(tc rec-id e-rec-id ty clauses ...)
(begin
(map add-clause (syntax->list #'(clauses ...)))
@ -296,7 +305,7 @@
;; necessary to avoid infinite loops
[#:Union elems (*Union (remove-dups (sort (map sb elems) type<?)))]
;; functions
[#:arr dom rng rest drest thn-eff els-eff
[#:arr dom rng rest drest kws thn-eff els-eff
(*arr (map sb dom)
(sb rng)
(if rest (sb rest) #f)
@ -304,6 +313,8 @@
(cons (sb (car drest))
(if (eq? (cdr drest) name) (+ count outer) (cdr drest)))
#f)
(for/list ([kw kws])
(cons (car kw) (sb (cdr kw))))
(map (lambda (e) (sub-eff sb e)) thn-eff)
(map (lambda (e) (sub-eff sb e)) els-eff))]
[#:ValuesDots tys dty dbound
@ -340,7 +351,7 @@
;; necessary to avoid infinite loops
[#:Union elems (*Union (remove-dups (sort (map sb elems) type<?)))]
;; functions
[#:arr dom rng rest drest thn-eff els-eff
[#:arr dom rng rest drest kws thn-eff els-eff
(*arr (map sb dom)
(sb rng)
(if rest (sb rest) #f)
@ -348,6 +359,8 @@
(cons (sb (car drest))
(if (eqv? (cdr drest) (+ count outer)) (F-n image) (cdr drest)))
#f)
(for/list ([kw kws])
(cons (car kw) (sb (cdr kw))))
(map (lambda (e) (sub-eff sb e)) thn-eff)
(map (lambda (e) (sub-eff sb e)) els-eff))]
[#:ValuesDots tys dty dbound

14
collects/typed-scheme/private/type-utils.ss
View File

@ -37,7 +37,7 @@
(if (hash-ref (free-vars* target) name #f)
(type-case sb target
[#:F name* (if (eq? name* name) image target)]
[#:arr dom rng rest drest thn-eff els-eff
[#:arr dom rng rest drest kws thn-eff els-eff
(begin
(when (and (pair? drest)
(eq? name (cdr drest))
@ -47,6 +47,8 @@
(sb rng)
(and rest (sb rest))
(and drest (cons (sb (car drest)) (cdr drest)))
(for/list ([kw kws])
(cons (car kw) (sb (cdr kw))))
(map (lambda (e) (sub-eff sb e)) thn-eff)
(map (lambda (e) (sub-eff sb e)) els-eff)))]
[#:ValuesDots types dty dbound
@ -70,7 +72,7 @@
(let ([expanded (sb dty)])
(map (lambda (img) (substitute img name expanded)) images))))
(make-ValuesDots (map sb types) (sb dty) dbound))]
[#:arr dom rng rest drest thn-eff els-eff
[#:arr dom rng rest drest kws thn-eff els-eff
(if (and (pair? drest)
(eq? name (cdr drest)))
(make-arr (append
@ -81,12 +83,16 @@
(sb rng)
rimage
#f
(for/list ([kw kws])
(cons (car kw) (sb (cdr kw))))
(map (lambda (e) (sub-eff sb e)) thn-eff)
(map (lambda (e) (sub-eff sb e)) els-eff))
(make-arr (map sb dom)
(sb rng)
(and rest (sb rest))
(and drest (cons (sb (car drest)) (cdr drest)))
(for/list ([kw kws])
(cons (car kw) (sb (cdr kw))))
(map (lambda (e) (sub-eff sb e)) thn-eff)
(map (lambda (e) (sub-eff sb e)) els-eff)))])
target))
@ -105,13 +111,15 @@
(if (eq? name* name)
image
target)]
[#:arr dom rng rest drest thn-eff els-eff
[#:arr dom rng rest drest kws thn-eff els-eff
(make-arr (map sb dom)
(sb rng)
(and rest (sb rest))
(and drest
(cons (sb (car drest))
(if (eq? name (cdr drest)) image-bound (cdr drest))))
(for/list ([kw kws])
(cons (car kw) (sb (cdr kw))))
(map (lambda (e) (sub-eff sb e)) thn-eff)
(map (lambda (e) (sub-eff sb e)) els-eff))])
target))