core: typo: Remove trailing 1.
[mes.git] / module / srfi / srfi-26.scm
1 ;;; srfi-26.scm --- specializing parameters without currying.
2
3 ;; Copyright (C) 2002, 2006 Free Software Foundation, Inc.
4 ;;
5 ;; This library is free software; you can redistribute it and/or
6 ;; modify it under the terms of the GNU Lesser General Public
7 ;; License as published by the Free Software Foundation; either
8 ;; version 2.1 of the License, or (at your option) any later version.
9 ;; 
10 ;; This library is distributed in the hope that it will be useful,
11 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
12 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
13 ;; Lesser General Public License for more details.
14 ;; 
15 ;; You should have received a copy of the GNU Lesser General Public
16 ;; License along with this library; if not, write to the Free Software
17 ;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
18
19 (define-module (srfi srfi-26)
20   :export (cut cute))
21
22 (cond-expand-provide (current-module) '(srfi-26))
23
24 (define-macro (cut slot . slots)
25   (let loop ((slots     (cons slot slots))
26              (params    '())
27              (args      '()))
28     (if (null? slots)
29         `(lambda ,(reverse! params) ,(reverse! args))
30       (let ((s    (car slots))
31             (rest (cdr slots)))
32         (case s
33           ((<>)
34            (let ((var (gensym)))
35              (loop rest (cons var params) (cons var args))))
36           ((<...>)
37            (if (pair? rest)
38                (error "<...> not on the end of cut expression"))
39            (let ((var (gensym)))
40              `(lambda ,(append! (reverse! params) var)
41                 (apply ,@(reverse! (cons var args))))))
42           (else
43            (loop rest params (cons s args))))))))
44
45 (define-macro (cute . slots)
46   (let ((temp (map (lambda (s) (and (not (memq s '(<> <...>))) (gensym)))
47                    slots)))
48     `(let ,(delq! #f (map (lambda (t s) (and t (list t s))) temp slots))
49        (cut ,@(map (lambda (t s) (or t s)) temp slots)))))