summaryrefslogtreecommitdiff
path: root/module/srfi/srfi-26.scm
diff options
context:
space:
mode:
authorAndreas Rottmann <a.rottmann@gmx.at>2010-12-07 23:13:55 +0100
committerLudovic Courtès <ludo@gnu.org>2010-12-07 23:13:55 +0100
commit3df539b1a5535009d8522b997e2542496cfb06fb (patch)
tree1196248e6d5542344196e0e967fbc37bdbcca627 /module/srfi/srfi-26.scm
parent51fc066ae25a0e1aa272a2eba9ecd7b42dc9ea41 (diff)
downloadguile-3df539b1a5535009d8522b997e2542496cfb06fb.tar.gz
Get rid of `define-macro' in the SRFI 26 implementation
* module/srfi/srfi-26.scm (cut, cute): Implement using `syntax-case'. The new implementation is mostly just a transcription of the old code; the reference implementation which relies only on `syntax-rules' may (or may not) be considered more elegant :-). Signed-off-by: Ludovic Courtès <ludo@gnu.org>
Diffstat (limited to 'module/srfi/srfi-26.scm')
-rw-r--r--module/srfi/srfi-26.scm69
1 files changed, 43 insertions, 26 deletions
diff --git a/module/srfi/srfi-26.scm b/module/srfi/srfi-26.scm
index 324a5dc37..4a9f4413a 100644
--- a/module/srfi/srfi-26.scm
+++ b/module/srfi/srfi-26.scm
@@ -1,6 +1,6 @@
;;; srfi-26.scm --- specializing parameters without currying.
-;; Copyright (C) 2002, 2006 Free Software Foundation, Inc.
+;; Copyright (C) 2002, 2006, 2010 Free Software Foundation, Inc.
;;
;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public
@@ -21,29 +21,46 @@
(cond-expand-provide (current-module) '(srfi-26))
-(define-macro (cut slot . slots)
- (let loop ((slots (cons slot slots))
- (params '())
- (args '()))
- (if (null? slots)
- `(lambda ,(reverse! params) ,(reverse! args))
- (let ((s (car slots))
- (rest (cdr slots)))
- (case s
- ((<>)
- (let ((var (gensym)))
- (loop rest (cons var params) (cons var args))))
- ((<...>)
- (if (pair? rest)
- (error "<...> not on the end of cut expression"))
- (let ((var (gensym)))
- `(lambda ,(append! (reverse! params) var)
- (apply ,@(reverse! (cons var args))))))
- (else
- (loop rest params (cons s args))))))))
+(define-syntax cut
+ (lambda (stx)
+ (syntax-case stx ()
+ ((cut slot0 slot1+ ...)
+ (let loop ((slots #'(slot0 slot1+ ...))
+ (params '())
+ (args '()))
+ (if (null? slots)
+ #`(lambda #,(reverse params) #,(reverse args))
+ (let ((s (car slots))
+ (rest (cdr slots)))
+ (with-syntax (((var) (generate-temporaries '(var))))
+ (syntax-case s (<> <...>)
+ (<>
+ (loop rest (cons #'var params) (cons #'var args)))
+ (<...>
+ (if (pair? rest)
+ (error "<...> not on the end of cut expression"))
+ #`(lambda #,(append (reverse params) #'var)
+ (apply #,@(reverse (cons #'var args)))))
+ (else
+ (loop rest params (cons s args))))))))))))
-(define-macro (cute . slots)
- (let ((temp (map (lambda (s) (and (not (memq s '(<> <...>))) (gensym)))
- slots)))
- `(let ,(delq! #f (map (lambda (t s) (and t (list t s))) temp slots))
- (cut ,@(map (lambda (t s) (or t s)) temp slots)))))
+(define-syntax cute
+ (lambda (stx)
+ (syntax-case stx ()
+ ((cute slots ...)
+ (let loop ((slots #'(slots ...))
+ (bindings '())
+ (arguments '()))
+ (define (process-hole)
+ (loop (cdr slots) bindings (cons (car slots) arguments)))
+ (if (null? slots)
+ #`(let #,bindings
+ (cut #,@(reverse arguments)))
+ (syntax-case (car slots) (<> <...>)
+ (<> (process-hole))
+ (<...> (process-hole))
+ (expr
+ (with-syntax (((t) (generate-temporaries '(t))))
+ (loop (cdr slots)
+ (cons #'(t expr) bindings)
+ (cons #'t arguments)))))))))))