diff --git a/piclib/built-in.scm b/piclib/built-in.scm index c3c09059..0b94d488 100644 --- a/piclib/built-in.scm +++ b/piclib/built-in.scm @@ -1425,42 +1425,27 @@ (define-syntax case-lambda (syntax-rules () - ((case-lambda - (?a1 ?e1 ...) - ?clause1 ...) + ((case-lambda (params body0 ...) ...) (lambda args - (let ((l (length args))) - (case-lambda "CLAUSE" args l - (?a1 ?e1 ...) - ?clause1 ...)))) - ((case-lambda "CLAUSE" ?args ?l - ((?a1 ...) ?e1 ...) - ?clause1 ...) - (if (= ?l (length '(?a1 ...))) - (apply (lambda (?a1 ...) ?e1 ...) ?args) - (case-lambda "CLAUSE" ?args ?l - ?clause1 ...))) - ((case-lambda "CLAUSE" ?args ?l - ((?a1 . ?ar) ?e1 ...) - ?clause1 ...) - (case-lambda "IMPROPER" ?args ?l 1 (?a1 . ?ar) (?ar ?e1 ...) - ?clause1 ...)) - ((case-lambda "CLAUSE" ?args ?l - (?a1 ?e1 ...) - ?clause1 ...) - (let ((?a1 ?args)) - ?e1 ...)) - ((case-lambda "CLAUSE" ?args ?l) - (error "Wrong number of arguments to CASE-LAMBDA.")) - ((case-lambda "IMPROPER" ?args ?l ?k ?al ((?a1 . ?ar) ?e1 ...) - ?clause1 ...) - (case-lambda "IMPROPER" ?args ?l (+ ?k 1) ?al (?ar ?e1 ...) - ?clause1 ...)) - ((case-lambda "IMPROPER" ?args ?l ?k ?al (?ar ?e1 ...) - ?clause1 ...) - (if (>= ?l ?k) - (apply (lambda ?al ?e1 ...) ?args) - (case-lambda "CLAUSE" ?args ?l - ?clause1 ...))))) + (let ((len (length args))) + (letrec-syntax + ((cl (syntax-rules ::: () + ((cl) + (error "no matching clause")) + ((cl ((p :::) . body) . rest) + (if (= len (length '(p :::))) + (apply (lambda (p :::) + . body) + args) + (cl . rest))) + ((cl ((p ::: . tail) . body) + . rest) + (if (>= len (length '(p :::))) + (apply + (lambda (p ::: . tail) + . body) + args) + (cl . rest)))))) + (cl (params body0 ...) ...))))))) (export case-lambda))