Commit | Line | Data |
---|---|---|
feeef4fb MV |
1 | (define-module (srfi srfi-26) |
2 | :export (cut cute)) | |
3 | ||
4 | (cond-expand-provide (current-module) '(srfi-26)) | |
5 | ||
6 | (define-macro (cut slot . slots) | |
7 | (let loop ((slots (cons slot slots)) | |
8 | (params '()) | |
9 | (args '())) | |
10 | (if (null? slots) | |
11 | `(lambda ,(reverse! params) ,(reverse! args)) | |
12 | (let ((s (car slots)) | |
13 | (rest (cdr slots))) | |
14 | (case s | |
15 | ((<>) | |
16 | (let ((var (gensym))) | |
17 | (loop rest (cons var params) (cons var args)))) | |
18 | ((<...>) | |
19 | (if (pair? rest) | |
20 | (error "<...> not on the end of cut expression")) | |
21 | (let ((var (gensym))) | |
22 | `(lambda ,(append! (reverse! params) var) | |
23 | (apply ,@(reverse! (cons var args)))))) | |
24 | (else | |
25 | (loop rest params (cons s args)))))))) | |
26 | ||
27 | (define-macro (cute . slots) | |
28 | (let ((temp (map (lambda (s) (and (not (memq s '(<> <...>))) (gensym))) | |
29 | slots))) | |
30 | `(let ,(delq! #f (map (lambda (t s) (and t (list t s))) temp slots)) | |
31 | (cut ,@(map (lambda (t s) (or t s)) temp slots))))) |