diff options
author | Andy Wingo <wingo@pobox.com> | 2009-10-25 13:19:11 +0100 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2009-10-25 13:19:11 +0100 |
commit | 9a8eb5fb4641bd9ea83903624c8c71192fe0d0f6 (patch) | |
tree | 1ba3fcdc7eba9f7840fe2c5039a6d94d5bb2e4f2 /module/srfi/srfi-16.scm | |
parent | 647117cd3599c1eaae5afe4b77fa15886d6d344d (diff) | |
download | guile-9a8eb5fb4641bd9ea83903624c8c71192fe0d0f6.tar.gz |
srfi-16 just re-exports psyntax's case-lambda
* module/srfi/srfi-16.scm (case-lambda): Just re-export the core's
case-lambda, it's semantically the same but faster and better
integrated.
Diffstat (limited to 'module/srfi/srfi-16.scm')
-rw-r--r-- | module/srfi/srfi-16.scm | 79 |
1 files changed, 3 insertions, 76 deletions
diff --git a/module/srfi/srfi-16.scm b/module/srfi/srfi-16.scm index 36abee613..caec784ba 100644 --- a/module/srfi/srfi-16.scm +++ b/module/srfi/srfi-16.scm @@ -46,81 +46,8 @@ ;;; Code: (define-module (srfi srfi-16) - #:replace (case-lambda)) + #:re-export (case-lambda)) -(cond-expand-provide (current-module) '(srfi-16)) - -(define-macro (case-lambda . clauses) - - ;; Return the length of the list @var{l}, but allow dotted list. - ;; - (define (alength l) - (cond ((null? l) 0) - ((pair? l) (+ 1 (alength (cdr l)))) - (else 0))) - - ;; Return @code{#t} if @var{l} is a dotted list, @code{#f} if it is - ;; a normal list. - ;; - (define (dotted? l) - (cond ((null? l) #f) - ((pair? l) (dotted? (cdr l))) - (else #t))) - - ;; Return the expression for accessing the @var{index}th element of - ;; the list called @var{args-name}. If @var{tail?} is true, code - ;; for accessing the list-tail is generated, otherwise for accessing - ;; the list element itself. - ;; - (define (accessor args-name index tail?) - (if tail? - (case index - ((0) `,args-name) - ((1) `(cdr ,args-name)) - ((2) `(cddr ,args-name)) - ((3) `(cdddr ,args-name)) - ((4) `(cddddr ,args-name)) - (else `(list-tail ,args-name ,index))) - (case index - ((0) `(car ,args-name)) - ((1) `(cadr ,args-name)) - ((2) `(caddr ,args-name)) - ((3) `(cadddr ,args-name)) - (else `(list-ref ,args-name ,index))))) +;; Case-lambda is now provided by code psyntax. - ;; Generate the binding lists of the variables of one case-lambda - ;; clause. @var{vars} is the (possibly dotted) list of variables - ;; and @var{args-name} is the generated name used for the argument - ;; list. - ;; - (define (gen-temps vars args-name) - (let lp ((v vars) (i 0)) - (cond ((null? v) '()) - ((pair? v) - (cons `(,(car v) ,(accessor args-name i #f)) - (lp (cdr v) (+ i 1)))) - (else `((,v ,(accessor args-name i #t))))))) - - ;; Generate the cond clauses for each of the clauses of case-lambda, - ;; including the parameter count check, binding of the parameters - ;; and the code of the corresponding body. - ;; - (define (gen-clauses l length-name args-name) - (cond ((null? l) (list '(else (error "too few arguments")))) - (else - (cons - `((,(if (dotted? (caar l)) '>= '=) - ,length-name ,(alength (caar l))) - (let ,(gen-temps (caar l) args-name) - ,@(cdar l))) - (gen-clauses (cdr l) length-name args-name))))) - - (let ((args-name (gensym)) - (length-name (gensym))) - (let ((proc - `(lambda ,args-name - (let ((,length-name (length ,args-name))) - (cond ,@(gen-clauses clauses length-name args-name)))))) - proc))) - -;;; srfi-16.scm ends here +(cond-expand-provide (current-module) '(srfi-16)) |