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

generalize define/chk to work with case-lambda-style functions

Browse Source
This commit is contained in:
Robby Findler 2010-12-17 08:37:35 -06:00
parent e0b425e5d8
commit 4d04aa2b97
1 changed files with 42 additions and 30 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

28
collects/2htdp/private/img-err.rkt
View File

@ -42,19 +42,20 @@
(define-syntax define/chk (define-syntax define/chk
(λ (stx) (λ (stx)
(syntax-case stx () (define (adjust-case case-args bodies)
[(define/chk (fn-name args ... . final-arg) body ...) (syntax-case case-args ()
[(args ... . final-arg)
(identifier? #'final-arg) (identifier? #'final-arg)
(let ([len (length (syntax->list #'(args ...)))]) (let ([len (length (syntax->list #'(args ...)))])
(with-syntax ([(i ...) (build-list len add1)]) (with-syntax ([(i ...) (build-list len add1)])
#`(define (fn-name args ... . final-arg) #`((args ... . final-arg)
(let ([args (check/normalize 'fn-name 'args args i)] ... (let ([args (check/normalize 'fn-name 'args args i)] ...
[final-arg [final-arg
(for/list ([x (in-list final-arg)] (for/list ([x (in-list final-arg)]
[j (in-naturals #,(+ len 1))]) [j (in-naturals #,(+ len 1))])
(check/normalize 'fn-name 'final-arg x j))]) (check/normalize 'fn-name 'final-arg x j))])
body ...))))] #,@bodies))))]
[(define/chk (fn-name args ...) body ...) [(args ...)
(with-syntax ([(i ...) (build-list (length (syntax->list #'(args ...))) add1)] (with-syntax ([(i ...) (build-list (length (syntax->list #'(args ...))) add1)]
[(arg-ids ...) [(arg-ids ...)
(map (λ (arg) (map (λ (arg)
@ -68,9 +69,20 @@
[_ [_
(raise-syntax-error 'define/chk "unknown argument spec" stx arg)])) (raise-syntax-error 'define/chk "unknown argument spec" stx arg)]))
(syntax->list #'(args ...)))]) (syntax->list #'(args ...)))])
#'(define (fn-name args ...) #`((args ...)
(let ([arg-ids (check/normalize 'fn-name 'arg-ids arg-ids i)] ...) (let ([arg-ids (check/normalize 'fn-name 'arg-ids arg-ids i)] ...)
body ...)))]))) #,@bodies)))]))
(syntax-case stx (case-lambda)
[(define/chk fn-name (case-lambda [in-args in-body ...] ...))
(with-syntax ([((args body) ...) (map adjust-case
(syntax->list #'(in-args ...))
(syntax->list #'((in-body ...) ...)))])
#'(define fn-name
(case-lambda
[args body] ...)))]
[(define/chk (fn-name . args) body ...)
(with-syntax ([(args body) (adjust-case #'args #'(body ...))])
#`(define (fn-name . args) body))])))
;; check/normalize : symbol symbol any number -> any ;; check/normalize : symbol symbol any number -> any
;; based on the name of the argument, checks to see if the input ;; based on the name of the argument, checks to see if the input
@ -135,7 +147,7 @@
'integer\ greater\ than\ 2 'integer\ greater\ than\ 2
i arg) i arg)
arg] arg]
[(dx dy x1 y1 x2 y2 pull1 pull2) [(dx dy x y x1 y1 x2 y2 pull1 pull2)
(check-arg fn-name (check-arg fn-name
(real? arg) (real? arg)
'real\ number 'real\ number