conservatory
/
picrin
4
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Merge pull request #79 from stibear/srfi26 

srfi26
This commit is contained in:
Yuichi Nishiwaki 2014-03-31 22:21:22 +09:00
parent c8641d0540 b825da0e5a
commit a16d49b33e
1 changed files with 53 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

53
piclib/srfi/26.scm Normal file
View File

@ -0,0 +1,53 @@
(define-library (srfi 26)
(import (scheme base)
(picrin macro)
(srfi 1))
(define-syntax cut%
(ir-macro-transformer
(lambda (form inject compare?)
(let ((slots (second form))
(combi (third form))
(se (cdddr form)))
(cond ((null? se)
`(lambda ,slots ((begin ,(car combi)) ,@(cdr combi))))
((and (symbol? (car se))
(compare? (car se) '<...>))
`(lambda (,@slots . rest-slot) (apply ,@combi rest-slot)))
((and (symbol? (car se))
(compare? (car se) '<>))
`(cut% (,@slots x) (,@combi x) ,@(cdr se)))
(else `(cut% ,slots (,@combi ,(car se)) ,@(cdr se))))))))
(define-syntax cute%
(ir-macro-transformer
(lambda (form inject compare?)
(let ((slots (second form))
(binds (third form))
(combi (fourth form))
(se (cddddr form)))
(cond ((null? se)
`(let ,binds
(lambda ,slots ((begin ,(car combi)) ,@(cdr combi)))))
((and (symbol? (car se))
(compare? (car se) '<...>))
`(let ,binds
(lambda (,@slots . rest-slot) (apply ,@combi rest-slot))))
((and (symbol? (car se))
(compare? (car se) '<>))
`(cute% (,@slots x) ,binds (,@combi x) ,@(cdr se)))
(else
`(cute% ,slots ((x ,(car se)) ,@binds)
(,@combi x) ,@(cdr se))))))))
(define-syntax cut
(ir-macro-transformer
(lambda (form inject compare?)
`(cut% () () ,@(cdr form)))))
(define-syntax cute
(ir-macro-transformer
(lambda (form inject compare?)
`(cute% () () () ,@(cdr form)))))
(export cut cute))