Gauche:opt-lambda

エラー処理なし、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))))))

optargs.scm

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")