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

fix arity error for method with optional arguments

Browse Source 
svn: r13375
This commit is contained in:
Matthew Flatt 2009-02-03 13:13:53 +00:00
parent 53d70e711c
commit 3d04e81fa0
1 changed files with 40 additions and 32 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

72
collects/scheme/private/kw.ss
View File

@ -337,7 +337,11 @@
[sorted-kws (sort (map list kws kw-args kw-arg?s kw-reqs) [sorted-kws (sort (map list kws kw-args kw-arg?s kw-reqs)
(lambda (a b) (keyword<? (syntax-e (car a)) (lambda (a b) (keyword<? (syntax-e (car a))
(syntax-e (car b)))))] (syntax-e (car b)))))]
[method? (syntax-property stx 'method-arity-error)]) [method? (syntax-property stx 'method-arity-error)]
[annotate-method (lambda (stx)
(if method?
(syntax-property stx 'method-arity-error #t)
stx))])
(with-syntax ([(kw-arg ...) kw-args] (with-syntax ([(kw-arg ...) kw-args]
[(kw-arg? ...) (let loop ([kw-arg?s kw-arg?s] [(kw-arg? ...) (let loop ([kw-arg?s kw-arg?s]
[kw-reqs kw-reqs]) [kw-reqs kw-reqs])
@ -380,26 +384,27 @@
(let #,(syntax-property (let #,(syntax-property
#`(#,(syntax-property #`(#,(syntax-property
#`[core #`[core
#,(syntax-property #,(annotate-method
#`(lambda #,(syntax-property (syntax-property
#`(given-kws given-args #`(lambda #,(syntax-property
new-plain-id ... #`(given-kws given-args
opt-arg ... new-plain-id ...
opt-arg? ... opt-arg ...
. new-rest) opt-arg? ...
'certify-mode . new-rest)
'transparent) 'certify-mode
;; sort out the arguments into the user-supplied bindings, 'transparent)
;; evaluating default-values expressions as needed: ;; sort out the arguments into the user-supplied bindings,
(let-kws given-kws given-args kws-sorted ;; evaluating default-values expressions as needed:
(let-maybe ([id opt-expr kind] ... . rest) (let-kws given-kws given-args kws-sorted
(kw-arg ...) (kw-arg? ...) (let-maybe ([id opt-expr kind] ... . rest)
(opt-arg ...) (opt-arg? ...) (kw-arg ...) (kw-arg? ...)
(new-plain-id ... . new-rest) (opt-arg ...) (opt-arg? ...)
;; the original body, finally: (new-plain-id ... . new-rest)
body1 body ...))) ;; the original body, finally:
'certify-mode body1 body ...)))
'transparent)] 'certify-mode
'transparent))]
'certify-mode 'certify-mode
'transparent)) 'transparent))
'certify-mode 'certify-mode
@ -411,27 +416,30 @@
[mk-no-kws [mk-no-kws
(lambda () (lambda ()
;; entry point without keywords: ;; entry point without keywords:
(syntax/loc stx (annotate-method
(opt-cases (core null null) ([opt-id opt-arg opt-arg?] ...) (plain-id ...) (syntax/loc stx
() (rest-empty rest-id . rest) (opt-cases (core null null) ([opt-id opt-arg opt-arg?] ...) (plain-id ...)
())))] () (rest-empty rest-id . rest)
()))))]
[mk-with-kws [mk-with-kws
(lambda () (lambda ()
;; entry point with keywords: ;; entry point with keywords:
(if (and (null? opts) (if (and (null? opts)
(null? #'new-rest)) (null? #'new-rest))
#'core #'core
(syntax/loc stx (annotate-method
(opt-cases (core) ([opt-id opt-arg opt-arg?] ...) (given-kws given-args plain-id ...) (syntax/loc stx
(opt-cases (core) ([opt-id opt-arg opt-arg?] ...) (given-kws given-args plain-id ...)
() (rest-empty rest-id . rest) () (rest-empty rest-id . rest)
()))))] ())))))]
[mk-kw-arity-stub [mk-kw-arity-stub
(lambda () (lambda ()
;; struct-type entry point for no keywords when a keyword is required ;; struct-type entry point for no keywords when a keyword is required
(syntax/loc stx (annotate-method
(fail-opt-cases (missing-kw) (opt-id ...) (self plain-id ...) (syntax/loc stx
() (rest-id . fail-rest) (fail-opt-cases (missing-kw) (opt-id ...) (self plain-id ...)
())))]) () (rest-id . fail-rest)
()))))])
(cond (cond
[(null? kws) [(null? kws)
;; just the no-kw part ;; just the no-kw part