1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-02 13:00:26 +02:00
guile/srfi/srfi-26.scm
2004-01-21 00:46:10 +00:00

31 lines
944 B
Scheme

(define-module (srfi srfi-26)
:export (cut cute))
(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-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)))))