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

Cleanup kw/opt lambda annotations.

Browse Source
This commit is contained in:
Eric Dobson 2013-02-23 09:27:34 -08:00
parent 74c3c130f0
commit 9f01d26f98
2 changed files with 17 additions and 6 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

13
collects/typed-racket/base-env/prims.rkt
View File

@ -1051,7 +1051,18 @@ This file defines two sorts of primitives. All of them are provided into any mod
[(_ formals . body) [(_ formals . body)
(define d (datum->syntax stx `(,#'λ ,#'formals . ,#'body) (define d (datum->syntax stx `(,#'λ ,#'formals . ,#'body)
stx stx)) stx stx))
(syntax-property d 'kw-lambda #t)])) (define-values (has-kw? has-opt?)
(syntax-parse #'formals
((~or (~and rest:id (~bind ((args 1) null)))
(args ...)
(args ...+ . rest:id))
(define arg-list (syntax->list #'(args ...)))
(values
(ormap keyword? (map syntax-e arg-list))
(ormap syntax->list arg-list)))))
(syntax-property
(syntax-property d 'kw-lambda has-kw?)
'opt-lambda has-opt?)]))
;; do this ourselves so that we don't get the static bindings, ;; do this ourselves so that we don't get the static bindings,
;; which are harder to typecheck ;; which are harder to typecheck

10
collects/typed-racket/typecheck/tc-expr-unit.rkt
View File

@ -376,15 +376,15 @@
(let-values (((_) (~and find-app (#%plain-app find-method/who _ _ _)))) (let-values (((_) (~and find-app (#%plain-app find-method/who _ _ _))))
(#%plain-app _ _ args ...)))) (#%plain-app _ _ args ...))))
(tc/send #'find-app #'rcvr #'meth #'(args ...) expected)] (tc/send #'find-app #'rcvr #'meth #'(args ...) expected)]
;; kw function def ;; kw/opt function def
[(let-values ([(_) fun]) [(let-values ([(_) fun])
. body) . body)
#:when (syntax-property form 'kw-lambda) #:when (or (syntax-property form 'kw-lambda)
(syntax-property form 'opt-lambda))
(match expected (match expected
[(tc-result1: (and f (Function: _))) [(tc-result1: (and f (or (Function: _)
(Poly: _ (Function: _)))))
(tc-expr/check/type #'fun (kw-convert f #:split #t))] (tc-expr/check/type #'fun (kw-convert f #:split #t))]
[(tc-result1: (Poly-names: names (and f (Function: _))))
(tc-expr/check/type #'fun (make-Poly names (kw-convert f #:split #t)))]
[(tc-result1: _) (tc-error/expr "Keyword functions must have function type, given ~a" expected)]) [(tc-result1: _) (tc-error/expr "Keyword functions must have function type, given ~a" expected)])
expected] expected]
;; let ;; let