kw-lists-lambda.rkt (3459B)
1 #lang racket/base 2 3 (provide kw-lists-lambda kw-lists-case-lambda) 4 5 (require (for-syntax racket/base racket/syntax syntax/parse syntax/name)) 6 7 (module+ test 8 (require rackunit racket/local)) 9 10 (begin-for-syntax 11 (define-syntax-class args 12 [pattern (arg:id ... [opt-arg:id default:expr] ...) 13 #:with apply-id #'#%app 14 #:with [apply-arg ...] #'[arg ... opt-arg ...]] 15 [pattern (arg:id ... [opt-arg:id default:expr] ... . rest:id) 16 #:with apply-id #'apply 17 #:with [apply-arg ...] #'[arg ... opt-arg ... rest]] 18 )) 19 20 ;; (kw-lists-lambda kws kw-args rest-args body ...+) 21 (define-syntax kw-lists-lambda 22 (lambda (stx) 23 (syntax-parse stx 24 [(kw-lists-lambda kws:id kw-args:id rest-args:args body:expr ...+) 25 #:with name (syntax-local-infer-name stx) 26 #:with name* (generate-temporary #'name) 27 #:with name*-expr #'(lambda (kws kw-args . rest-args) body ...) 28 #:with plain-expr #'(lambda rest-args 29 (rest-args.apply-id name* '() '() rest-args.apply-arg ...)) 30 (cond [(identifier? #'name) 31 #'(let ([name* name*-expr]) 32 (make-keyword-procedure 33 name* 34 (let ([name plain-expr]) 35 name)))] 36 [else 37 #'(let ([name* name*-expr]) 38 (make-keyword-procedure 39 name* 40 plain-expr))])]))) 41 42 ;; (kw-lists-case-lambda (kws kw-args . rest-args) body ...+) 43 (define-syntax kw-lists-case-lambda 44 (lambda (stx) 45 (syntax-parse stx 46 [(kw-lists-case-lambda kws:id kw-args:id [rest-args:args body:expr ...+] ...) 47 #:with name (syntax-local-infer-name stx) 48 #:with name* (generate-temporary #'name) 49 #:with name*-expr #'(case-lambda 50 [(kws kw-args . rest-args) body ...] 51 ...) 52 #:with plain-expr #'(case-lambda 53 [rest-args 54 (rest-args.apply-id name* '() '() rest-args.apply-arg ...)] 55 ...) 56 (cond [(identifier? #'name) 57 #'(let ([name* name*-expr]) 58 (make-keyword-procedure 59 name* 60 (let ([name plain-expr]) 61 name)))] 62 [else 63 #'(let ([name* name*-expr]) 64 (make-keyword-procedure 65 name* 66 plain-expr))])]))) 67 68 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 69 70 (module+ test 71 (local [(define proc 72 (kw-lists-lambda kws kw-args rest-args 73 (list kws kw-args rest-args)))] 74 (check-equal? (proc #:a 'a #:b 'b 0 1 2) 75 (list '(#:a #:b) '(a b) '(0 1 2))) 76 (check-equal? (object-name proc) 'proc) 77 ) 78 (local [(define proc0 79 (kw-lists-lambda kws kw-args () 80 (list kws kw-args))) 81 (define proc1 82 (kw-lists-lambda kws kw-args (x) 83 (list kws kw-args x)))] 84 (check-equal? (proc0 #:a 'a #:b 'b) 85 (list '(#:a #:b) '(a b))) 86 (check-equal? (proc1 #:a 'a 'x #:b 'b) 87 (list '(#:a #:b) '(a b) 'x)) 88 (check-equal? (object-name proc0) 'proc0) 89 (check-equal? (object-name proc1) 'proc1) 90 (check-equal? (procedure-arity proc0) 0) 91 (check-equal? (procedure-arity proc1) 1) 92 ) 93 )