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