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

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

@ -42,35 +42,47 @@
(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 ()
(identifier? #'final-arg) [(args ... . final-arg)
(let ([len (length (syntax->list #'(args ...)))]) (identifier? #'final-arg)
(with-syntax ([(i ...) (build-list len add1)]) (let ([len (length (syntax->list #'(args ...)))])
#`(define (fn-name args ... . final-arg) (with-syntax ([(i ...) (build-list len add1)])
(let ([args (check/normalize 'fn-name 'args args i)] ... #`((args ... . final-arg)
[final-arg (let ([args (check/normalize 'fn-name 'args args i)] ...
(for/list ([x (in-list final-arg)] [final-arg
[j (in-naturals #,(+ len 1))]) (for/list ([x (in-list final-arg)]
(check/normalize 'fn-name 'final-arg x j))]) [j (in-naturals #,(+ len 1))])
body ...))))] (check/normalize 'fn-name 'final-arg x j))])
[(define/chk (fn-name args ...) body ...) #,@bodies))))]
(with-syntax ([(i ...) (build-list (length (syntax->list #'(args ...))) add1)] [(args ...)
[(arg-ids ...) (with-syntax ([(i ...) (build-list (length (syntax->list #'(args ...))) add1)]
(map (λ (arg) [(arg-ids ...)
(syntax-case arg () (map (λ (arg)
[x (syntax-case arg ()
(identifier? #'x) [x
#'x] (identifier? #'x)
[(x y) #'x]
(identifier? #'x) [(x y)
#'x] (identifier? #'x)
[_ #'x]
(raise-syntax-error 'define/chk "unknown argument spec" stx arg)])) [_
(syntax->list #'(args ...)))]) (raise-syntax-error 'define/chk "unknown argument spec" stx arg)]))
#'(define (fn-name args ...) (syntax->list #'(args ...)))])
(let ([arg-ids (check/normalize 'fn-name 'arg-ids arg-ids i)] ...) #`((args ...)
body ...)))]))) (let ([arg-ids (check/normalize 'fn-name 'arg-ids arg-ids i)] ...)
#,@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