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

20
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,7 +384,8 @@
(let #,(syntax-property (let #,(syntax-property
#`(#,(syntax-property #`(#,(syntax-property
#`[core #`[core
#,(syntax-property #,(annotate-method
(syntax-property
#`(lambda #,(syntax-property #`(lambda #,(syntax-property
#`(given-kws given-args #`(given-kws given-args
new-plain-id ... new-plain-id ...
@ -399,7 +404,7 @@
;; the original body, finally: ;; the original body, finally:
body1 body ...))) body1 body ...)))
'certify-mode 'certify-mode
'transparent)] '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:
(annotate-method
(syntax/loc stx (syntax/loc stx
(opt-cases (core null null) ([opt-id opt-arg opt-arg?] ...) (plain-id ...) (opt-cases (core null null) ([opt-id opt-arg opt-arg?] ...) (plain-id ...)
() (rest-empty rest-id . rest) () (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
(annotate-method
(syntax/loc stx (syntax/loc stx
(opt-cases (core) ([opt-id opt-arg opt-arg?] ...) (given-kws given-args plain-id ...) (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
(annotate-method
(syntax/loc stx (syntax/loc stx
(fail-opt-cases (missing-kw) (opt-id ...) (self plain-id ...) (fail-opt-cases (missing-kw) (opt-id ...) (self plain-id ...)
() (rest-id . fail-rest) () (rest-id . fail-rest)
())))]) ()))))])
(cond (cond
[(null? kws) [(null? kws)
;; just the no-kw part ;; just the no-kw part