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

209
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
(lambda (expr r compare)
(if (symbol? (cadr expr))
(begin (begin
(define name bindings) (define name (cadr expr))
(set! bindings (car body)) (define bindings (caddr expr))
(set! body (cdr body)) (define body (cdddr expr))
;; expanded form should be like below: (list (r 'let) '()
;; `(let () (list (r 'define) name
;; (define ,loop (cons (r 'lambda) (cons (map car bindings) body)))
;; (lambda (,@vars)
;; ,@body))
;; (,loop ,@vals))
(list 'let '()
(list 'define name
(cons 'lambda (cons (map car bindings) body)))
(cons name (map cadr bindings)))) (cons name (map cadr bindings))))
(cons (cons 'lambda (cons (map car bindings) body)) (begin
(map cadr bindings)))) (define bindings (cadr expr))
(define body (cddr expr))
(cons (cons (r 'lambda) (cons (map car bindings) body))
(map cadr bindings)))))))
(define-macro (cond . clauses) (define-syntax cond
(er-macro-transformer
(lambda (expr r compare)
(let ((clauses (cdr expr)))
(if (null? clauses) (if (null? clauses)
#f #f
(let ((c (car clauses))) (list (r 'if) (caar clauses)
(let ((test (car c)) (cons (r 'begin) (cdar clauses))
(if-true (cons 'begin (cdr c))) (cons (r 'cond) (cdr clauses))))))))
(if-false (cons 'cond (cdr clauses))))
(list 'if test if-true if-false)))))
(define-macro (and . exprs) (define-syntax and
(er-macro-transformer
(lambda (expr r compare)
(let ((exprs (cdr expr)))
(if (null? exprs) (if (null? exprs)
#t #t
(let ((test (car exprs)) (list (r 'if) (car exprs)
(if-true (cons 'and (cdr exprs)))) (cons (r 'and) (cdr exprs))
(list 'if test if-true #f)))) #f))))))
(define-macro (or . exprs) (define-syntax or
(er-macro-transformer
(lambda (expr r compare)
(let ((exprs (cdr expr)))
(if (null? exprs) (if (null? exprs)
#f #f
(let ((test (car exprs)) (list (r 'let) (list (list (r 'it) (car exprs)))
(if-false (cons 'or (cdr exprs)))) (list (r 'if) (r 'it)
(list 'let (list (list 'it test)) (r 'it)
(list 'if 'it 'it if-false))))) (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
(er-macro-transformer
(lambda (expr r compare?)
(let ((x (cadr expr)))
(cond (cond
((symbol? x) (list 'quote x)) ((symbol? x) (list (r 'quote) x)) ; should test with identifier?
((pair? x) ((pair? x) (cond
(cond ((compare? (r 'unquote) (car x))
((eq? 'unquote (car x)) (cadr x)) (cadr x))
((and (pair? (car x)) ((and (pair? (car x))
(eq? 'unquote-splicing (caar x))) (compare? (r 'unquote-splicing) (caar x)))
(list 'append (cadr (car x)) (list 'quasiquote (cdr x)))) (list (r 'append) (cadar x)
(#t (list 'cons (list (r 'quasiquote) (cdr x))))
(list 'quasiquote (car x)) (#t
(list 'quasiquote (cdr x)))))) (list (r 'cons)
(#t x))) (list (r 'quasiquote) (car x))
(list (r 'quasiquote) (cdr x))))))
(#t x))))))
(define-macro (let* bindings . body) #;
(define-syntax let*
(ir-macro-transformer
(lambda (form inject compare)
(let ((bindings (cadr form))
(body (cddr form)))
(if (null? bindings) (if (null? bindings)
`(let () ,@body) `(let () ,@body)
`(let ((,(caar bindings) `(let ((,(caar bindings)
,@(cdar bindings))) ,@(cdar bindings)))
(let* (,@(cdr bindings)) (let* (,@(cdr bindings))
,@body)))) ,@body)))))))
(define-macro (letrec bindings . body) (define-syntax let*
(er-macro-transformer
(lambda (form r compare)
(let ((bindings (cadr form))
(body (cddr form)))
(if (null? bindings)
`(,(r 'let) () ,@body)
`(,(r 'let) ((,(caar bindings)
,@(cdar bindings)))
(,(r 'let*) (,@(cdr bindings))
,@body)))))))
(define-syntax letrec
(er-macro-transformer
(lambda (form r compare)
(let ((bindings (cadr form))
(body (cddr form)))
(let ((vars (map (lambda (v) `(,v #f)) (map car bindings))) (let ((vars (map (lambda (v) `(,v #f)) (map car bindings)))
(initials (map (lambda (v) `(set! ,@v)) bindings))) (initials (map (lambda (v) `(,(r 'set!) ,@v)) bindings)))
`(let (,@vars) `(,(r 'let) (,@vars)
(begin ,@initials) ,@initials
,@body))) ,@body))))))
(define-macro (letrec* . args) (define-syntax letrec*
`(letrec ,@args)) (er-macro-transformer
(lambda (form rename compare)
`(,(rename 'letrec) ,@(cdr form)))))
(define-macro (do bindings finish . body) (define-syntax do
`(let loop ,(map (lambda (x) (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))) (list (car x) (cadr x)))
bindings) bindings)
(if ,(car finish) (,(r 'if) ,(car finish)
(begin ,@body (,(r 'begin) ,@body
(loop ,@(map (lambda (x) (,(r 'loop) ,@(map (lambda (x)
(if (null? (cddr x)) (if (null? (cddr x))
(car x) (car x)
(car (cddr x)))) (car (cddr x))))
bindings))) bindings)))
(begin ,@(cdr finish))))) (,(r 'begin) ,@(cdr finish))))))))
(define-macro (when test . exprs) (define-syntax when
(list 'if test (cons 'begin exprs) #f)) (er-macro-transformer
(lambda (expr rename compare)
(let ((test (cadr expr))
(body (cddr expr)))
`(,(rename 'if) ,test
(,(rename 'begin) ,@body)
#f)))))
(define-macro (unless test . exprs) (define-syntax unless
(list 'if test #f (cons 'begin exprs))) (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)))))))))