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

prelude cosmetic changes

This commit is contained in:
Yuichi Nishiwaki 2014-07-19 13:22:24 +09:00
parent fb31793808
commit 02ebced87b
1 changed files with 22 additions and 25 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

47
piclib/prelude.scm
View File

@ -196,6 +196,11 @@
(scheme cxr)
(picrin macro))
(define-syntax syntax-error
(er-macro-transformer
(lambda (expr rename compare)
(apply error (cdr expr)))))
(define-syntax define-auxiliary-syntax
(er-macro-transformer
(lambda (expr r c)
@ -247,11 +252,6 @@
(cons (r 'begin) (cdar clauses))
(cons (r 'cond) (cdr clauses))))))))))
(define (single? list)
(if (pair? list)
(null? (cdr list))
#f))
(define-syntax and
(er-macro-transformer
(lambda (expr r compare)
@ -259,7 +259,7 @@
(cond
((null? exprs)
#t)
((single? exprs)
((= (length exprs) 1)
(car exprs))
(else
(list (r 'let) (list (list (r 'it) (car exprs)))
@ -274,7 +274,7 @@
(cond
((null? exprs)
#t)
((single? exprs)
((= (length exprs) 1)
(car exprs))
(else
(list (r 'let) (list (list (r 'it) (car exprs)))
@ -282,15 +282,6 @@
(r 'it)
(cons (r 'or) (cdr exprs))))))))))
(define (quasiquote? form compare?)
(and (pair? form) (compare? (car form) 'quasiquote)))
(define (unquote? form compare?)
(and (pair? form) (compare? (car form) 'unquote)))
(define (unquote-splicing? form compare?)
(and (pair? form) (pair? (car form)) (compare? (car (car form)) 'unquote-splicing)))
(define (list->vector list)
(let ((vector (make-vector (length list))))
(let loop ((list list) (i 0))
@ -311,17 +302,27 @@
(ir-macro-transformer
(lambda (form inject compare)
(define (quasiquote? form)
(and (pair? form) (compare (car form) 'quasiquote)))
(define (unquote? form)
(and (pair? form) (compare (car form) 'unquote)))
(define (unquote-splicing? form)
(and (pair? form) (pair? (car form))
(compare (car (car form)) 'unquote-splicing)))
(define (qq depth expr)
(cond
;; unquote
((unquote? expr compare)
((unquote? expr)
(if (= depth 1)
(car (cdr expr))
(list 'list
(list 'quote (inject 'unquote))
(qq (- depth 1) (car (cdr expr))))))
;; unquote-splicing
((unquote-splicing? expr compare)
((unquote-splicing? expr)
(if (= depth 1)
(list 'append
(car (cdr (car expr)))
@ -332,7 +333,7 @@
(qq (- depth 1) (car (cdr (car expr)))))
(qq depth (cdr expr)))))
;; quasiquote
((quasiquote? expr compare)
((quasiquote? expr)
(list 'list
(list 'quote (inject 'quasiquote))
(qq (+ depth 1) (car (cdr expr)))))
@ -440,7 +441,8 @@
`(,(r 'if) ,(if (compare (r 'else) (caar clauses))
'#t
`(,(r 'or)
,@(map (lambda (x) `(,(r 'eqv?) ,(r 'key) (,(r 'quote) ,x)))
,@(map (lambda (x)
`(,(r 'eqv?) ,(r 'key) (,(r 'quote) ,x)))
(caar clauses))))
,(if (compare (r '=>) (cadar clauses))
`(,(caddar clauses) ,(r 'key))
@ -458,11 +460,6 @@
formal)
,@body)))))
(define-syntax syntax-error
(er-macro-transformer
(lambda (expr rename compare)
(apply error (cdr expr)))))
(export let let* letrec letrec*
quasiquote unquote unquote-splicing
and or