conservatory
/
picrin
4
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

syntax-rules: rewrite case-lambda.scm. (p ... . var) pattern is not supported

This commit is contained in:
Yuichi Nishiwaki 2015-06-16 19:10:49 +09:00
parent 2c269b4f0e
commit 1570bd1cd4
1 changed files with 11 additions and 14 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

25
contrib/05.r7rs/scheme/case-lambda.scm
View File

@ -1,28 +1,25 @@
(define-library (scheme case-lambda) (define-library (scheme case-lambda)
(import (scheme base)) (import (scheme base))
(define (length+ list)
(if (pair? list)
(+ 1 (length+ (cdr list)))
0))
(define-syntax case-lambda (define-syntax case-lambda
(syntax-rules () (syntax-rules ()
((case-lambda (params body0 ...) ...) ((case-lambda (params body0 ...) ...)
(lambda args (lambda args
(let ((len (length args))) (let ((len (length args)))
(letrec-syntax (letrec-syntax
((cl (syntax-rules ::: () ((cl (syntax-rules ()
((cl) ((cl)
(error "no matching clause")) (error "no matching clause"))
((cl ((p :::) . body) . rest) ((cl (formal . body) . rest)
(if (= len (length '(p :::))) (if (if (list? 'formal)
(apply (lambda (p :::) (= len (length 'formal))
. body) (>= len (length+ 'formal)))
args) (apply (lambda formal . body) args)
(cl . rest)))
((cl ((p ::: . tail) . body)
. rest)
(if (>= len (length '(p :::)))
(apply
(lambda (p ::: . tail)
. body)
args)
(cl . rest)))))) (cl . rest))))))
(cl (params body0 ...) ...))))))) (cl (params body0 ...) ...)))))))