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 (cgen/arr V X t-arr s-arr)
(define (cg S T) (cgen V X S T)) (define (cg S T) (cgen V X S T))
(match* (t-arr s-arr) (match* (t-arr s-arr)
[((arr: ts t #f #f t-thn-eff t-els-eff) [((arr: ts t #f #f '() t-thn-eff t-els-eff)
(arr: ss s #f #f s-thn-eff s-els-eff)) (arr: ss s #f #f '() s-thn-eff s-els-eff))
(cset-meet* (cset-meet*
(list (cgen/list V X ss ts) (list (cgen/list V X ss ts)
(cg t s) (cg t s)
(cgen/eff/list V X t-thn-eff s-thn-eff) (cgen/eff/list V X t-thn-eff s-thn-eff)
(cgen/eff/list V X t-els-eff s-els-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: ts t t-rest #f '() t-thn-eff t-els-eff)
(arr: ss s s-rest #f s-thn-eff s-els-eff)) (arr: ss s s-rest #f '() s-thn-eff s-els-eff))
(let ([arg-mapping (let ([arg-mapping
(cond [(and t-rest s-rest (<= (length ts) (length ss))) (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)))] (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 (list arg-mapping ret-mapping
(cgen/eff/list V X t-thn-eff s-thn-eff) (cgen/eff/list V X t-thn-eff s-thn-eff)
(cgen/eff/list V X t-els-eff s-els-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: ts t #f (cons dty dbound) '() t-thn-eff t-els-eff)
(arr: ss s #f #f s-thn-eff s-els-eff)) (arr: ss s #f #f '() s-thn-eff s-els-eff))
(unless (memq dbound X) (unless (memq dbound X)
(fail! S T)) (fail! S T))
(unless (<= (length ts) (length ss)) (unless (<= (length ts) (length ss))
@ -148,8 +148,8 @@
(substitute (make-F var) dbound dty))] (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)]) [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))] (move-vars-to-dmap new-cset dbound vars))]
[((arr: ts t #f #f t-thn-eff t-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)) (arr: ss s #f (cons dty dbound) '() s-thn-eff s-els-eff))
(unless (memq dbound X) (unless (memq dbound X)
(fail! S T)) (fail! S T))
(unless (<= (length ss) (length ts)) (unless (<= (length ss) (length ts))
@ -161,8 +161,8 @@
(substitute (make-F var) dbound dty))] (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))]) [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))] (move-vars-to-dmap new-cset dbound vars))]
[((arr: ts t #f (cons t-dty dbound) t-thn-eff t-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: ss s #f (cons s-dty dbound) '() s-thn-eff s-els-eff))
(unless (= (length ts) (length ss)) (unless (= (length ts) (length ss))
(fail! S T)) (fail! S T))
;; If we want to infer the dotted bound, then why is it in both types? ;; 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 (list arg-mapping darg-mapping ret-mapping
(cgen/eff/list V X t-thn-eff s-thn-eff) (cgen/eff/list V X t-thn-eff s-thn-eff)
(cgen/eff/list V X t-els-eff s-els-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: 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: ss s #f (cons s-dty dbound*) '() s-thn-eff s-els-eff))
(unless (= (length ts) (length ss)) (unless (= (length ts) (length ss))
(fail! S T)) (fail! S T))
(let* ([arg-mapping (cgen/list V X ss ts)] (let* ([arg-mapping (cgen/list V X ss ts)]
@ -186,8 +186,8 @@
(list arg-mapping darg-mapping ret-mapping (list arg-mapping darg-mapping ret-mapping
(cgen/eff/list V X t-thn-eff s-thn-eff) (cgen/eff/list V X t-thn-eff s-thn-eff)
(cgen/eff/list V X t-els-eff s-els-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: 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: ss s #f (cons s-dty dbound) '() s-thn-eff s-els-eff))
(unless (memq dbound X) (unless (memq dbound X)
(fail! S T)) (fail! S T))
(if (<= (length ts) (length ss)) (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))]) (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)))] (move-vars+rest-to-dmap new-cset dbound vars)))]
;; If dotted <: starred is correct, add it below. Not sure it is. ;; 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: 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: ss s s-rest #f '() s-thn-eff s-els-eff))
(unless (memq dbound X) (unless (memq dbound X)
(fail! S T)) (fail! S T))
(cond [(< (length ts) (length ss)) (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" (require "type-effect-convenience.ss" "type-rep.ss"
"type-utils.ss" "union.ss" "type-utils.ss" "union.ss"
"signatures.ss" "signatures.ss" "utils.ss"
scheme/list) scheme/list)
(import) (import)
@ -26,7 +26,7 @@
[#:Param in out [#:Param in out
(make-Param (var-demote in V) (make-Param (var-demote in V)
(vp out))] (vp out))]
[#:arr dom rng rest drest thn els [#:arr dom rng rest drest kws thn els
(cond (cond
[(apply V-in? V (append thn els)) [(apply V-in? V (append thn els))
(make-arr null (Un) Univ #f null null)] (make-arr null (Un) Univ #f null null)]
@ -35,6 +35,8 @@
(vp rng) (vp rng)
(var-demote (car drest) V) (var-demote (car drest) V)
#f #f
(for/list ([(kw kwt) (in-pairs kws)])
(cons kw (var-demote kwt V)))
thn thn
els)] els)]
[else [else
@ -44,6 +46,8 @@
(and drest (and drest
(cons (var-demote (car drest) V) (cons (var-demote (car drest) V)
(cdr drest))) (cdr drest)))
(for/list ([(kw kwt) (in-pairs kws)])
(cons kw (var-demote kwt V)))
thn thn
els)])])) els)])]))
@ -61,7 +65,7 @@
[#:Param in out [#:Param in out
(make-Param (var-promote in V) (make-Param (var-promote in V)
(vd out))] (vd out))]
[#:arr dom rng rest drest thn els [#:arr dom rng rest drest kws thn els
(cond (cond
[(apply V-in? V (append thn els)) [(apply V-in? V (append thn els))
(make-arr null (Un) Univ #f null null)] (make-arr null (Un) Univ #f null null)]
@ -70,6 +74,8 @@
(vd rng) (vd rng)
(var-promote (car drest) V) (var-promote (car drest) V)
#f #f
(for/list ([(kw kwt) (in-pairs kws)])
(cons kw (var-promote kwt V)))
thn thn
els)] els)]
[else [else
@ -79,5 +85,7 @@
(and drest (and drest
(cons (var-promote (car drest) V) (cons (var-promote (car drest) V)
(cdr drest))) (cdr drest)))
(for/list ([(kw kwt) (in-pairs kws)])
(cons kw (var-promote kwt V)))
thn thn
els)])])) els)])]))

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

@ -150,7 +150,9 @@
(lambda (s) (lambda (s)
(... (...
(syntax-case 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 (begin-for-syntax
(hash-set! ht-stx 'kw-stx (list #'ex #'flds bfs-fold-rhs #'#,stx))) (hash-set! ht-stx 'kw-stx (list #'ex #'flds bfs-fold-rhs #'#,stx)))
intern intern

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

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

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

@ -180,7 +180,7 @@
(let loop ([expected expected]) (let loop ([expected expected])
(match expected (match expected
[(Mu: _ _) (loop (unfold 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]) (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)) (tc/lambda-clause/check (car (syntax->list formals)) (car (syntax->list bodies)) args ret rest drest))
expected] expected]

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

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

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

@ -80,9 +80,9 @@
(define make-arr* (define make-arr*
(case-lambda [(dom rng) (make-arr* dom rng #f (list) (list))] (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) (make-arr dom rng rest #f null (list) (list))]
[(dom rng rest eff1 eff2) (make-arr dom rng rest #f eff1 eff2)] [(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 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) (define (make-arr-dots dom rng dty dbound)
(make-arr* dom rng #f (cons dty dbound) null null)) (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 (match a
[(top-arr:) [(top-arr:)
(fp "Procedure")] (fp "Procedure")]
[(arr: dom rng rest drest thn-eff els-eff) [(arr: dom rng rest drest kws thn-eff els-eff)
(fp "(") (fp "(")
(for-each (lambda (t) (fp "~a " t)) dom) (for-each (lambda (t) (fp "~a " t)) dom)
(for ([kw kws])
(fp "~a ~a " (car kw) (cdr kw)))
(when rest (when rest
(fp "~a* " rest)) (fp "~a* " rest))
(when drest (when drest
@ -102,7 +104,7 @@
(lambda (e) (fp " ") (print-arr e)) (lambda (e) (fp " ") (print-arr e))
b) b)
(fp ")")]))] (fp ")")]))]
[(arr: _ _ _ _ _ _) (print-arr c)] [(arr: _ _ _ _ _ _ _) (print-arr c)]
[(Vector: e) (fp "(Vectorof ~a)" e)] [(Vector: e) (fp "(Vectorof ~a)" e)]
[(Box: e) (fp "(Box ~a)" e)] [(Box: e) (fp "(Box ~a)" e)]
[(Union: elems) (fp "~a" (cons 'U elems))] [(Union: elems) (fp "~a" (cons 'U elems))]

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

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