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

rewrite core syntaces with explicit renaming macro

This commit is contained in:
Yuichi Nishiwaki 2013-12-10 03:09:27 -08:00
parent fb34b71de1
commit 79f6f5c034
1 changed files with 150 additions and 105 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

255
piclib/built-in.scm
View File

@ -50,6 +50,9 @@
(define (cadr p) (car (cdr p))) (define (cadr p) (car (cdr p)))
(define (cdar p) (cdr (car p))) (define (cdar p) (cdr (car p)))
(define (cddr p) (cdr (cdr p))) (define (cddr p) (cdr (cdr p)))
(define (cadar p) (car (cdar p)))
(define (caddr p) (car (cddr p)))
(define (cdddr p) (cdr (cddr p)))
(define (map f list) (define (map f list)
(if (null? list) (if (null? list)
@ -57,48 +60,54 @@
(cons (f (car list)) (cons (f (car list))
(map f (cdr list))))) (map f (cdr list)))))
(define-macro (let bindings . body) (define-syntax let
(if (symbol? bindings) (er-macro-transformer
(begin (lambda (expr r compare)
(define name bindings) (if (symbol? (cadr expr))
(set! bindings (car body)) (begin
(set! body (cdr body)) (define name (cadr expr))
;; expanded form should be like below: (define bindings (caddr expr))
;; `(let () (define body (cdddr expr))
;; (define ,loop (list (r 'let) '()
;; (lambda (,@vars) (list (r 'define) name
;; ,@body)) (cons (r 'lambda) (cons (map car bindings) body)))
;; (,loop ,@vals)) (cons name (map cadr bindings))))
(list 'let '() (begin
(list 'define name (define bindings (cadr expr))
(cons 'lambda (cons (map car bindings) body))) (define body (cddr expr))
(cons name (map cadr bindings)))) (cons (cons (r 'lambda) (cons (map car bindings) body))
(cons (cons 'lambda (cons (map car bindings) body)) (map cadr bindings)))))))
(map cadr bindings))))
(define-macro (cond . clauses) (define-syntax cond
(if (null? clauses) (er-macro-transformer
#f (lambda (expr r compare)
(let ((c (car clauses))) (let ((clauses (cdr expr)))
(let ((test (car c)) (if (null? clauses)
(if-true (cons 'begin (cdr c))) #f
(if-false (cons 'cond (cdr clauses)))) (list (r 'if) (caar clauses)
(list 'if test if-true if-false))))) (cons (r 'begin) (cdar clauses))
(cons (r 'cond) (cdr clauses))))))))
(define-macro (and . exprs) (define-syntax and
(if (null? exprs) (er-macro-transformer
#t (lambda (expr r compare)
(let ((test (car exprs)) (let ((exprs (cdr expr)))
(if-true (cons 'and (cdr exprs)))) (if (null? exprs)
(list 'if test if-true #f)))) #t
(list (r 'if) (car exprs)
(cons (r 'and) (cdr exprs))
#f))))))
(define-macro (or . exprs) (define-syntax or
(if (null? exprs) (er-macro-transformer
#f (lambda (expr r compare)
(let ((test (car exprs)) (let ((exprs (cdr expr)))
(if-false (cons 'or (cdr exprs)))) (if (null? exprs)
(list 'let (list (list 'it test)) #f
(list 'if 'it 'it if-false))))) (list (r 'let) (list (list (r 'it) (car exprs)))
(list (r 'if) (r 'it)
(r 'it)
(cons (r 'or) (cdr exprs)))))))))
(define (append xs ys) (define (append xs ys)
(if (null? xs) (if (null? xs)
@ -106,77 +115,124 @@
(cons (car xs) (cons (car xs)
(append (cdr xs) ys)))) (append (cdr xs) ys))))
(define-macro (quasiquote x) (define-syntax quasiquote
(cond (er-macro-transformer
((symbol? x) (list 'quote x)) (lambda (expr r compare?)
((pair? x) (let ((x (cadr expr)))
(cond (cond
((eq? 'unquote (car x)) (cadr x)) ((symbol? x) (list (r 'quote) x)) ; should test with identifier?
((and (pair? (car x)) ((pair? x) (cond
(eq? 'unquote-splicing (caar x))) ((compare? (r 'unquote) (car x))
(list 'append (cadr (car x)) (list 'quasiquote (cdr x)))) (cadr x))
(#t (list 'cons ((and (pair? (car x))
(list 'quasiquote (car x)) (compare? (r 'unquote-splicing) (caar x)))
(list 'quasiquote (cdr x)))))) (list (r 'append) (cadar x)
(#t x))) (list (r 'quasiquote) (cdr x))))
(#t
(list (r 'cons)
(list (r 'quasiquote) (car x))
(list (r 'quasiquote) (cdr x))))))
(#t x))))))
(define-macro (let* bindings . body) #;
(if (null? bindings) (define-syntax let*
`(let () ,@body) (ir-macro-transformer
`(let ((,(caar bindings) (lambda (form inject compare)
,@(cdar bindings))) (let ((bindings (cadr form))
(let* (,@(cdr bindings)) (body (cddr form)))
,@body)))) (if (null? bindings)
`(let () ,@body)
`(let ((,(caar bindings)
,@(cdar bindings)))
(let* (,@(cdr bindings))
,@body)))))))
(define-macro (letrec bindings . body) (define-syntax let*
(let ((vars (map (lambda (v) `(,v #f)) (map car bindings))) (er-macro-transformer
(initials (map (lambda (v) `(set! ,@v)) bindings))) (lambda (form r compare)
`(let (,@vars) (let ((bindings (cadr form))
(begin ,@initials) (body (cddr form)))
,@body))) (if (null? bindings)
`(,(r 'let) () ,@body)
`(,(r 'let) ((,(caar bindings)
,@(cdar bindings)))
(,(r 'let*) (,@(cdr bindings))
,@body)))))))
(define-macro (letrec* . args) (define-syntax letrec
`(letrec ,@args)) (er-macro-transformer
(lambda (form r compare)
(let ((bindings (cadr form))
(body (cddr form)))
(let ((vars (map (lambda (v) `(,v #f)) (map car bindings)))
(initials (map (lambda (v) `(,(r 'set!) ,@v)) bindings)))
`(,(r 'let) (,@vars)
,@initials
,@body))))))
(define-macro (do bindings finish . body) (define-syntax letrec*
`(let loop ,(map (lambda (x) (er-macro-transformer
(list (car x) (cadr x))) (lambda (form rename compare)
bindings) `(,(rename 'letrec) ,@(cdr form)))))
(if ,(car finish)
(begin ,@body
(loop ,@(map (lambda (x)
(if (null? (cddr x))
(car x)
(car (cddr x))))
bindings)))
(begin ,@(cdr finish)))))
(define-macro (when test . exprs) (define-syntax do
(list 'if test (cons 'begin exprs) #f)) (er-macro-transformer
(lambda (form r compare)
(let ((bindings (cadr form))
(finish (caddr form))
(body (cdddr form)))
`(,(r 'let) ,(r 'loop) ,(map (lambda (x)
(list (car x) (cadr x)))
bindings)
(,(r 'if) ,(car finish)
(,(r 'begin) ,@body
(,(r 'loop) ,@(map (lambda (x)
(if (null? (cddr x))
(car x)
(car (cddr x))))
bindings)))
(,(r 'begin) ,@(cdr finish))))))))
(define-macro (unless test . exprs) (define-syntax when
(list 'if test #f (cons 'begin exprs))) (er-macro-transformer
(lambda (expr rename compare)
(let ((test (cadr expr))
(body (cddr expr)))
`(,(rename 'if) ,test
(,(rename 'begin) ,@body)
#f)))))
(define-syntax unless
(er-macro-transformer
(lambda (expr rename compare)
(let ((test (cadr expr))
(body (cddr expr)))
`(,(rename 'if) ,test
#f
(,(rename 'begin) ,@body))))))
(define-syntax case (define-syntax case
(ir-macro-transformer (er-macro-transformer
(lambda (expr inject compare) (lambda (expr r compare)
(let ((key (cadr expr)) (let ((key (cadr expr))
(clauses (cddr expr))) (clauses (cddr expr)))
`(let ((key ,key)) `(,(r 'let) ((,(r 'key) ,key))
,(let loop ((clauses clauses)) ,(let loop ((clauses clauses))
(if (null? clauses) (if (null? clauses)
#f #f
`(if (or ,@(map (lambda (x) `(eqv? key ,x)) (caar clauses))) `(,(r 'if) (,(r 'or)
,@(cdar clauses) ,@(map (lambda (x) `(,(r 'eqv?) ,(r 'key) (,(r 'quote) ,x)))
(caar clauses)))
(begin ,@(cdar clauses))
,(loop (cdr clauses)))))))))) ,(loop (cdr clauses))))))))))
(define-syntax define-auxiliary-syntax (define-syntax define-auxiliary-syntax
(ir-macro-transformer (er-macro-transformer
(lambda (expr i c) (lambda (expr r c)
`(define-syntax ,(cadr expr) `(,(r 'define-syntax) ,(cadr expr)
(sc-macro-transformer ,(r '(sc-macro-transformer
(lambda (expr env) (lambda (expr env)
(error "invalid use of auxiliary syntax"))))))) (error "invalid use of auxiliary syntax"))))))))
(define-auxiliary-syntax else) (define-auxiliary-syntax else)
(define-auxiliary-syntax =>) (define-auxiliary-syntax =>)
@ -680,14 +736,3 @@
(apply f (vector-ref v n) (apply f (vector-ref v n)
(map (lambda (v) (vector-ref v n)) vs)) (map (lambda (v) (vector-ref v n)) vs))
(loop (+ n 1)))))) (loop (+ n 1))))))
(define-syntax or
(ir-macro-transformer
(lambda (expr inject compare)
(let ((exprs (cdr expr)))
(if (null? exprs)
#f
`(let ((it ,(car exprs)))
(if it
it
(or ,@(cdr exprs)))))))))