(module parameter-utils mzscheme (require (lib "etc.ss")) (require-for-template (lib "plt-mzscheme.ss" "lang")) (require-for-syntax (lib "etc.ss") (planet "syntax-utils.ss" ("cce" "syntax-utils.plt" 1 (= 0)))) (provide param-lambda) (define-syntax (param-lambda stx) (define (process-param-args stx args) (recur next-arg ([args args] [id-args null] [opt-args null] [param-args null]) (syntax-case-by-name args (=>) [ID (identifier? #'ID) #`((#,@(reverse id-args)) (#,@(reverse opt-args)) (#,@(reverse param-args)) ID)] [() #`((#,@(reverse id-args)) (#,@(reverse opt-args)) (#,@(reverse param-args)) ())] [(ID . REST) (identifier? #'ID) (if (null? opt-args) (next-arg #'REST (cons #'ID id-args) opt-args param-args) (raise-syntax-error #f "argument needs default" stx #'ID))] [([ID EXPR] . REST) (identifier? #'ID) (next-arg #'REST id-args (cons #'[ID EXPR] opt-args) param-args)] [([ID => EXPR] . REST) (next-arg #'REST id-args (cons #'[ID (EXPR)] opt-args) (cons #'[ID EXPR] param-args))]))) (syntax-case stx () [(_ ARGS BODY MORE ...) (with-syntax ([((ID-ARG ...) ([OPT-ARG DEFAULT] ...) ([PARAM-ARG PARAM] ...) REST-ARG) (process-param-args stx #'ARGS)]) #'(opt-lambda (ID-ARG ... [OPT-ARG DEFAULT] ... . REST-ARG) (parameterize ([PARAM PARAM-ARG] ...) BODY MORE ...)))])) )