commit 9ea736ccc25db24a8a64e9fe6e45237784834434 parent 352f78287b9fc4fcce117dc834587297d2bd27c6 Author: AlexKnauth <alexander@knauth.org> Date: Thu, 19 May 2016 23:57:28 -0400 reorganize and move code to kw-lists-lambda.rkt Diffstat:
| M | kw-utils/keyword-lambda.rkt | | | 67 | +++++-------------------------------------------------------------- |
| M | kw-utils/kw-lists-lambda.rkt | | | 93 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++---- |
2 files changed, 94 insertions(+), 66 deletions(-)
diff --git a/kw-utils/keyword-lambda.rkt b/kw-utils/keyword-lambda.rkt @@ -1,71 +1,14 @@ #lang racket/base (provide keyword-lambda) -(module+ private - (provide keyword-lists-case-lambda)) - -(require (for-syntax racket/base racket/syntax syntax/parse syntax/name)) +(require "kw-lists-lambda.rkt") (module+ test - (require rackunit racket/local)) - -(begin-for-syntax - (define-syntax-class args - [pattern (arg:id ... [opt-arg:id default:expr] ...) - #:with apply-id #'#%app - #:with [apply-arg ...] #'[arg ... opt-arg ...]] - [pattern (arg:id ... [opt-arg:id default:expr] ... . rest:id) - #:with apply-id #'apply - #:with [apply-arg ...] #'[arg ... opt-arg ... rest]] - )) - -;; (keyword-lambda (kws kw-args . rest-args) body ...+) -(define-syntax keyword-lambda - (lambda (stx) - (syntax-parse stx - [(keyword-lambda (kws:id kw-args:id . rest-args:args) body:expr ...+) - #:with name (syntax-local-infer-name stx) - #:with name* (generate-temporary #'name) - #:with name*-expr #'(lambda (kws kw-args . rest-args) body ...) - #:with plain-expr #'(lambda rest-args - (rest-args.apply-id name* '() '() rest-args.apply-arg ...)) - (cond [(identifier? #'name) - #'(let ([name* name*-expr]) - (make-keyword-procedure - name* - (let ([name plain-expr]) - name)))] - [else - #'(let ([name* name*-expr]) - (make-keyword-procedure - name* - plain-expr))])]))) + (require rackunit + racket/local)) -;; (keyword-lists-case-lambda (kws kw-args . rest-args) body ...+) -(define-syntax keyword-lists-case-lambda - (lambda (stx) - (syntax-parse stx - [(keyword-lists-case-lambda kws:id kw-args:id [rest-args:args body:expr ...+] ...) - #:with name (syntax-local-infer-name stx) - #:with name* (generate-temporary #'name) - #:with name*-expr #'(case-lambda - [(kws kw-args . rest-args) body ...] - ...) - #:with plain-expr #'(case-lambda - [rest-args - (rest-args.apply-id name* '() '() rest-args.apply-arg ...)] - ...) - (cond [(identifier? #'name) - #'(let ([name* name*-expr]) - (make-keyword-procedure - name* - (let ([name plain-expr]) - name)))] - [else - #'(let ([name* name*-expr]) - (make-keyword-procedure - name* - plain-expr))])]))) +(define-syntax-rule (keyword-lambda (kws kw-args . rest-args) body ...) + (kw-lists-lambda kws kw-args rest-args body ...)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; diff --git a/kw-utils/kw-lists-lambda.rkt b/kw-utils/kw-lists-lambda.rkt @@ -2,7 +2,92 @@ (provide kw-lists-lambda kw-lists-case-lambda) -(require (only-in "keyword-lambda.rkt" - [keyword-lambda kw-lists-lambda])) -(require (only-in (submod "keyword-lambda.rkt" private) - [keyword-lists-case-lambda kw-lists-case-lambda])) +(require (for-syntax racket/base racket/syntax syntax/parse syntax/name)) + +(module+ test + (require rackunit racket/local)) + +(begin-for-syntax + (define-syntax-class args + [pattern (arg:id ... [opt-arg:id default:expr] ...) + #:with apply-id #'#%app + #:with [apply-arg ...] #'[arg ... opt-arg ...]] + [pattern (arg:id ... [opt-arg:id default:expr] ... . rest:id) + #:with apply-id #'apply + #:with [apply-arg ...] #'[arg ... opt-arg ... rest]] + )) + +;; (kw-lists-lambda kws kw-args rest-args body ...+) +(define-syntax kw-lists-lambda + (lambda (stx) + (syntax-parse stx + [(kw-lists-lambda kws:id kw-args:id rest-args:args body:expr ...+) + #:with name (syntax-local-infer-name stx) + #:with name* (generate-temporary #'name) + #:with name*-expr #'(lambda (kws kw-args . rest-args) body ...) + #:with plain-expr #'(lambda rest-args + (rest-args.apply-id name* '() '() rest-args.apply-arg ...)) + (cond [(identifier? #'name) + #'(let ([name* name*-expr]) + (make-keyword-procedure + name* + (let ([name plain-expr]) + name)))] + [else + #'(let ([name* name*-expr]) + (make-keyword-procedure + name* + plain-expr))])]))) + +;; (kw-lists-case-lambda (kws kw-args . rest-args) body ...+) +(define-syntax kw-lists-case-lambda + (lambda (stx) + (syntax-parse stx + [(kw-lists-case-lambda kws:id kw-args:id [rest-args:args body:expr ...+] ...) + #:with name (syntax-local-infer-name stx) + #:with name* (generate-temporary #'name) + #:with name*-expr #'(case-lambda + [(kws kw-args . rest-args) body ...] + ...) + #:with plain-expr #'(case-lambda + [rest-args + (rest-args.apply-id name* '() '() rest-args.apply-arg ...)] + ...) + (cond [(identifier? #'name) + #'(let ([name* name*-expr]) + (make-keyword-procedure + name* + (let ([name plain-expr]) + name)))] + [else + #'(let ([name* name*-expr]) + (make-keyword-procedure + name* + plain-expr))])]))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(module+ test + (local [(define proc + (kw-lists-lambda kws kw-args rest-args + (list kws kw-args rest-args)))] + (check-equal? (proc #:a 'a #:b 'b 0 1 2) + (list '(#:a #:b) '(a b) '(0 1 2))) + (check-equal? (object-name proc) 'proc) + ) + (local [(define proc0 + (kw-lists-lambda kws kw-args () + (list kws kw-args))) + (define proc1 + (kw-lists-lambda kws kw-args (x) + (list kws kw-args x)))] + (check-equal? (proc0 #:a 'a #:b 'b) + (list '(#:a #:b) '(a b))) + (check-equal? (proc1 #:a 'a 'x #:b 'b) + (list '(#:a #:b) '(a b) 'x)) + (check-equal? (object-name proc0) 'proc0) + (check-equal? (object-name proc1) 'proc1) + (check-equal? (procedure-arity proc0) 0) + (check-equal? (procedure-arity proc1) 1) + ) + )