エラー処理なし、rest argmentなしバージョン from shiroさん
(define-macro (opt-lambda formals . body) (let ((args (gensym))) (let loop ((formals formals) (mandatory '()) (optional '())) (cond ((null? formals) `(lambda (,@(reverse! mandatory) . ,args) (let-optionals* ,args ,(reverse! optional) ,@body))) ((pair? (car formals)) (loop (cdr formals) mandatory (cons (car formals) optional))) (else (loop (cdr formals) (cons (car formals) mandatory) optional))))))
Guileにあるような、:optional, :key, :restを理解するバージョン。
(define-module optargs (use srfi-1) (use util.list) ; assq-ref (export lambda* define* %lambda*) ) (select-module optargs) (define-macro (lambda* arg . body) (if (pair? arg) (receive (mandatory optional key rest) (%parse-arg arg) `(%lambda* ,mandatory ,optional ,(map (lambda (e) (if (pair? e) e (list e #f))) key) ,rest ,body)) `(lambda ,arg ,@body))) (define (contains-duplicates? lis) (cond ((null? lis) #f) ((memq (car lis) (cdr lis)) (car lis)) (else (contains-duplicates? (cdr lis))))) (define (arglist-keyword? e) (memq e '(:optional :key :rest))) (define (split-arglist arg) (let loop ((arg arg) (r ())) (cond ((null? arg) (reverse! r)) ((null? (cdr arg)) (error "malformed lambda args")) (else (receive (left right) (break arglist-keyword? (cdr arg)) (loop right (acons (car arg) left r))))))) (define (%parse-arg arg) (receive (rest arg) (if (dotted-list? arg) (values (list (take-right arg 0)) (drop-right arg 0)) (values () arg)) (receive (mandatory arg) (break arglist-keyword? arg) (if (null? arg) (values mandatory () () rest) (let1 lis (split-arglist arg) (cond ((contains-duplicates? (unzip1 lis)) => (cut error "arglist contains duplicates" <>)) ((any (lambda (l) (< (length l) 2)) lis) => (cut error "malformed parameter" <>)) ((and (assq :rest lis) (not (= (length (assq :rest lis)) 2))) (error "invalid rest parameter")) ((and (not (null? rest)) (assq :rest lis)) (error ":rest specified twice")) (else (values mandatory (assq-ref lis :optional ()) (assq-ref lis :key ()) (if (null? rest) (assq-ref lis :rest ()) rest))))))))) (define-syntax %lambda* (syntax-rules () ((_ () () () () body) (lambda () . body)) ((_ (m0 ...) () () rest body) (lambda (m0 ... . rest) . body)) ((_ m opt key () body) (%lambda* m opt key (rest) body)) ((_ (m0 ...) (opt0 opt1 ...) () (rest) body) (lambda (m0 ... . tmp) (let-optionals* tmp (opt0 opt1 ... . rest) . body))) ((_ (m0 ...) () (key0 key1 ...) (rest) body) (lambda (m0 ... . rest) (let-keywords* rest (key0 key1 ...) . body))) ((_ (m0 ...) (opt0 opt1 ...) (key0 key1 ...) (rest) body) (lambda (m0 ... . tmp) (let-optionals* tmp (opt0 opt1 ... . rest) (let-keywords* rest (key0 key1 ...) . body)))))) (define-syntax define* (syntax-rules () ((_ (f . arg) . body) (define f (lambda* arg . body))) ((_ sym expr) (define sym expr)))) (provide "optargs")