Commit | Line | Data |
---|---|---|
fd1517d8 KR |
1 | ;;; srfi-26.scm --- specializing parameters without currying. |
2 | ||
3df539b1 | 3 | ;; Copyright (C) 2002, 2006, 2010 Free Software Foundation, Inc. |
fd1517d8 KR |
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 | |
83ba2d37 | 8 | ;; version 3 of the License, or (at your option) any later version. |
fd1517d8 KR |
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 | |
92205699 | 17 | ;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA |
fd1517d8 | 18 | |
feeef4fb MV |
19 | (define-module (srfi srfi-26) |
20 | :export (cut cute)) | |
21 | ||
22 | (cond-expand-provide (current-module) '(srfi-26)) | |
23 | ||
3df539b1 AR |
24 | (define-syntax cut |
25 | (lambda (stx) | |
26 | (syntax-case stx () | |
27 | ((cut slot0 slot1+ ...) | |
28 | (let loop ((slots #'(slot0 slot1+ ...)) | |
29 | (params '()) | |
30 | (args '())) | |
31 | (if (null? slots) | |
32 | #`(lambda #,(reverse params) #,(reverse args)) | |
33 | (let ((s (car slots)) | |
34 | (rest (cdr slots))) | |
35 | (with-syntax (((var) (generate-temporaries '(var)))) | |
36 | (syntax-case s (<> <...>) | |
37 | (<> | |
38 | (loop rest (cons #'var params) (cons #'var args))) | |
39 | (<...> | |
40 | (if (pair? rest) | |
41 | (error "<...> not on the end of cut expression")) | |
42 | #`(lambda #,(append (reverse params) #'var) | |
43 | (apply #,@(reverse (cons #'var args))))) | |
44 | (else | |
45 | (loop rest params (cons s args)))))))))))) | |
feeef4fb | 46 | |
3df539b1 AR |
47 | (define-syntax cute |
48 | (lambda (stx) | |
49 | (syntax-case stx () | |
50 | ((cute slots ...) | |
51 | (let loop ((slots #'(slots ...)) | |
52 | (bindings '()) | |
53 | (arguments '())) | |
54 | (define (process-hole) | |
55 | (loop (cdr slots) bindings (cons (car slots) arguments))) | |
56 | (if (null? slots) | |
57 | #`(let #,bindings | |
58 | (cut #,@(reverse arguments))) | |
59 | (syntax-case (car slots) (<> <...>) | |
60 | (<> (process-hole)) | |
61 | (<...> (process-hole)) | |
62 | (expr | |
63 | (with-syntax (((t) (generate-temporaries '(t)))) | |
64 | (loop (cdr slots) | |
65 | (cons #'(t expr) bindings) | |
66 | (cons #'t arguments))))))))))) |