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

Support keywords with %.

Browse Source 
original commit: 420bb0e2037a4bf53581bb8474de2c56852d8571
This commit is contained in:
Eric Dobson 2014-05-11 10:13:02 -07:00
parent bb14c479c4
commit 1209eb25c3
2 changed files with 23 additions and 17 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

31
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/infer/fail.rkt
View File

@ -16,22 +16,31 @@
[(_ e [c . r:rhs] ...)
#'(match* e [c . r.r] ...)]))
(begin-for-syntax
(define-splicing-syntax-class arg
#:attributes (v name (arg 1))
(pattern v:expr
#:with name (generate-temporary #'v)
#:with (arg ...) #'(name))
(pattern (~seq kw:keyword v:expr)
#:with name (generate-temporary #'v)
#:with (arg ...) #'(kw name))))
;; (% f e ...) == (and e ... (f e ...)) but without repeated evaluation
(define-syntax (% stx)
(syntax-parse stx
[(_ f e ...)
(define/with-syntax (a ...) (generate-temporaries #'(e ...)))
#'(let/fail ([a e] ...)
(f a ...))]))
(syntax-parse stx
[(_ f e:arg ...)
#'(let/fail ([e.name e.v] ...)
(f e.arg ... ...))]))
;; (%1 f e0 e ...) == (and e0 (f e0 e ...)) but without repeated evaluation
(define-syntax (%1 stx)
(syntax-parse stx
[(_ f e0 e ...)
(define/with-syntax (a0 a ...) (generate-temporaries #'(e0 e ...)))
#'(let/fail ([a0 e0])
(let ([a e] ...)
(f a0 a ...)))]))
(syntax-parse stx
[(_ f e0:arg e:arg ...)
#'(let/fail ([e0.name e0.v])
(let ([e.name e.v] ...)
(f e0.arg ... e.arg ... ...)))]))
;; like `let`, but if any bindings are #f, the whole expression produces #f
(define-syntax (let/fail stx)

9
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/infer/infer-unit.rkt
View File

@ -318,15 +318,12 @@
(substitute (make-F var) dbound s-dty))]
[new-s-arr (make-arr (append ss new-tys) s #f (cons s-dty dbound) null)]
[new-cset (cgen/arr V (append vars X) Y new-s-arr t-arr)])
(and new-cset vars
(move-vars+rest-to-dmap new-cset dbound vars #:exact #t)))]
(% move-vars+rest-to-dmap new-cset dbound vars #:exact #t))]
[(= (length ss) (length ts))
;; the simple case
(let* ([arg-mapping (cgen/list V X Y (extend ss ts t-rest) ss)]
[rest-mapping (cgen V (cons dbound X) Y t-rest s-dty)]
[darg-mapping (and rest-mapping
(move-rest-to-dmap
rest-mapping dbound #:exact #t))]
[darg-mapping (% move-rest-to-dmap rest-mapping dbound #:exact #t)]
[ret-mapping (cg s t)])
(% cset-meet arg-mapping darg-mapping ret-mapping))]
[else #f])]
@ -588,7 +585,7 @@
[((Listof: s-elem) (ListDots: t-dty dbound))
#:return-unless (memq dbound Y) #f
(define v (cgen V (cons dbound X) Y s-elem t-dty))
(and v (move-rest-to-dmap v dbound #:exact #t))]
(% move-rest-to-dmap v dbound #:exact #t)]
;; two ListDots with the same bound, just check the element type
[((ListDots: s-dty dbound) (ListDots: t-dty dbound))