picrin/contrib/05.r7rs/scheme/case-lambda.scm

27 lines
843 B
Scheme
Raw Normal View History

2014-07-19 01:15:53 -04:00
(define-library (scheme case-lambda)
(import (scheme base))
(define (length+ list)
(if (pair? list)
(+ 1 (length+ (cdr list)))
0))
2014-07-19 01:15:53 -04:00
(define-syntax case-lambda
(syntax-rules ()
((case-lambda (params body0 ...) ...)
(lambda args
(let ((len (length args)))
(letrec-syntax
((cl (syntax-rules ()
2014-07-19 01:15:53 -04:00
((cl)
(error "no matching clause"))
((cl (formal . body) . rest)
(if (if (list? 'formal)
(= len (length 'formal))
(>= len (length+ 'formal)))
(apply (lambda formal . body) args)
2014-07-19 01:15:53 -04:00
(cl . rest))))))
(cl (params body0 ...) ...)))))))
(export case-lambda))