update benz (boot.c)
This commit is contained in:
Yuichi Nishiwaki
parent
1ac0ccb05e
commit
230c87d455
|
|
@ -1 +1 @@
|
|||
Subproject commit dd80aff03ab36fea0633e0e449c71fd489bc738a
|
||||
Subproject commit 4fd4e15cc196a89e5ed5133896d7b8b9f4b2c10a
|
||||
|
|
@ -1,306 +1,4 @@
|
|||
(define-library (picrin base)
|
||||
(import (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)
|
||||
(list (r 'define-syntax) (cadr expr)
|
||||
(list (r 'lambda) '_
|
||||
(list (r 'error) "invalid use of auxiliary syntax"))))))
|
||||
|
||||
(define-auxiliary-syntax else)
|
||||
(define-auxiliary-syntax =>)
|
||||
(define-auxiliary-syntax _)
|
||||
(define-auxiliary-syntax ...)
|
||||
(define-auxiliary-syntax unquote)
|
||||
(define-auxiliary-syntax unquote-splicing)
|
||||
|
||||
(define-syntax let
|
||||
(er-macro-transformer
|
||||
(lambda (expr r compare)
|
||||
(if (symbol? (cadr expr))
|
||||
(begin
|
||||
(define name (car (cdr expr)))
|
||||
(define bindings (car (cdr (cdr expr))))
|
||||
(define body (cdr (cdr (cdr expr))))
|
||||
(list (r 'let) '()
|
||||
(list (r 'define) name
|
||||
(cons (r 'lambda) (cons (map car bindings) body)))
|
||||
(cons name (map cadr bindings))))
|
||||
(begin
|
||||
(set! bindings (cadr expr))
|
||||
(set! body (cddr expr))
|
||||
(cons (cons (r 'lambda) (cons (map car bindings) body))
|
||||
(map cadr bindings)))))))
|
||||
|
||||
(define-syntax cond
|
||||
(er-macro-transformer
|
||||
(lambda (expr r compare)
|
||||
(let ((clauses (cdr expr)))
|
||||
(if (null? clauses)
|
||||
#f
|
||||
(begin
|
||||
(define clause (car clauses))
|
||||
(if (compare (r 'else) (car clause))
|
||||
(cons (r 'begin) (cdr clause))
|
||||
(if (if (>= (length clause) 2)
|
||||
(compare (r '=>) (list-ref clause 1))
|
||||
#f)
|
||||
(list (r 'let) (list (list (r 'x) (car clause)))
|
||||
(list (r 'if) (r 'x)
|
||||
(list (list-ref clause 2) (r 'x))
|
||||
(cons (r 'cond) (cdr clauses))))
|
||||
(list (r 'if) (car clause)
|
||||
(cons (r 'begin) (cdr clause))
|
||||
(cons (r 'cond) (cdr clauses)))))))))))
|
||||
|
||||
(define-syntax and
|
||||
(er-macro-transformer
|
||||
(lambda (expr r compare)
|
||||
(let ((exprs (cdr expr)))
|
||||
(cond
|
||||
((null? exprs)
|
||||
#t)
|
||||
((= (length exprs) 1)
|
||||
(car exprs))
|
||||
(else
|
||||
(list (r 'let) (list (list (r 'it) (car exprs)))
|
||||
(list (r 'if) (r 'it)
|
||||
(cons (r 'and) (cdr exprs))
|
||||
(r 'it)))))))))
|
||||
|
||||
(define-syntax or
|
||||
(er-macro-transformer
|
||||
(lambda (expr r compare)
|
||||
(let ((exprs (cdr expr)))
|
||||
(cond
|
||||
((null? exprs)
|
||||
#t)
|
||||
((= (length exprs) 1)
|
||||
(car exprs))
|
||||
(else
|
||||
(list (r 'let) (list (list (r 'it) (car exprs)))
|
||||
(list (r 'if) (r 'it)
|
||||
(r 'it)
|
||||
(cons (r 'or) (cdr exprs))))))))))
|
||||
|
||||
(define-syntax quasiquote
|
||||
(er-macro-transformer
|
||||
(lambda (form rename compare)
|
||||
|
||||
(define (quasiquote? form)
|
||||
(and (pair? form) (compare (car form) (rename 'quasiquote))))
|
||||
|
||||
(define (unquote? form)
|
||||
(and (pair? form) (compare (car form) (rename 'unquote))))
|
||||
|
||||
(define (unquote-splicing? form)
|
||||
(and (pair? form) (pair? (car form))
|
||||
(compare (car (car form)) (rename 'unquote-splicing))))
|
||||
|
||||
(define (qq depth expr)
|
||||
(cond
|
||||
;; unquote
|
||||
((unquote? expr)
|
||||
(if (= depth 1)
|
||||
(car (cdr expr))
|
||||
(list (rename 'list)
|
||||
(list (rename 'quote) (rename 'unquote))
|
||||
(qq (- depth 1) (car (cdr expr))))))
|
||||
;; unquote-splicing
|
||||
((unquote-splicing? expr)
|
||||
(if (= depth 1)
|
||||
(list (rename 'append)
|
||||
(car (cdr (car expr)))
|
||||
(qq depth (cdr expr)))
|
||||
(list (rename 'cons)
|
||||
(list (rename 'list)
|
||||
(list (rename 'quote) (rename 'unquote-splicing))
|
||||
(qq (- depth 1) (car (cdr (car expr)))))
|
||||
(qq depth (cdr expr)))))
|
||||
;; quasiquote
|
||||
((quasiquote? expr)
|
||||
(list (rename 'list)
|
||||
(list (rename 'quote) (rename 'quasiquote))
|
||||
(qq (+ depth 1) (car (cdr expr)))))
|
||||
;; list
|
||||
((pair? expr)
|
||||
(list (rename 'cons)
|
||||
(qq depth (car expr))
|
||||
(qq depth (cdr expr))))
|
||||
;; vector
|
||||
((vector? expr)
|
||||
(list (rename 'list->vector) (qq depth (vector->list expr))))
|
||||
;; simple datum
|
||||
(else
|
||||
(list (rename 'quote) expr))))
|
||||
|
||||
(let ((x (cadr form)))
|
||||
(qq 1 x)))))
|
||||
|
||||
(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)))
|
||||
(initials (map (lambda (v) `(,(r 'set!) ,@v)) bindings)))
|
||||
`(,(r 'let) (,@vars)
|
||||
,@initials
|
||||
,@body))))))
|
||||
|
||||
(define-syntax letrec
|
||||
(er-macro-transformer
|
||||
(lambda (form rename compare)
|
||||
`(,(rename 'letrec*) ,@(cdr form)))))
|
||||
|
||||
(define-syntax let*-values
|
||||
(er-macro-transformer
|
||||
(lambda (form r c)
|
||||
(let ((formals (cadr form)))
|
||||
(if (null? formals)
|
||||
`(,(r 'let) () ,@(cddr form))
|
||||
`(,(r 'call-with-values) (,(r 'lambda) () ,@(cdar formals))
|
||||
(,(r 'lambda) (,@(caar formals))
|
||||
(,(r 'let*-values) (,@(cdr formals))
|
||||
,@(cddr form)))))))))
|
||||
|
||||
(define-syntax let-values
|
||||
(er-macro-transformer
|
||||
(lambda (form r c)
|
||||
`(,(r 'let*-values) ,@(cdr form)))))
|
||||
|
||||
(define-syntax define-values
|
||||
(er-macro-transformer
|
||||
(lambda (form r compare)
|
||||
(let ((formal (cadr form))
|
||||
(exprs (cddr form)))
|
||||
`(,(r 'begin)
|
||||
,@(let loop ((formal formal))
|
||||
(if (not (pair? formal))
|
||||
(if (symbol? formal)
|
||||
`((,(r 'define) ,formal #f))
|
||||
'())
|
||||
`((,(r 'define) ,(car formal) #f) . ,@(loop (cdr formal)))))
|
||||
(,(r 'call-with-values) (,(r 'lambda) () ,@exprs)
|
||||
(,(r 'lambda) ,(r 'args)
|
||||
,@(let loop ((formal formal) (args (r 'args)))
|
||||
(if (not (pair? formal))
|
||||
(if (symbol? formal)
|
||||
`((,(r 'set!) ,formal ,args))
|
||||
'())
|
||||
`((,(r 'set!) ,(car formal) (,(r 'car) ,args))
|
||||
,@(loop (cdr formal) `(,(r 'cdr) ,args))))))))))))
|
||||
|
||||
(define-syntax do
|
||||
(er-macro-transformer
|
||||
(lambda (form r compare)
|
||||
(let ((bindings (car (cdr form)))
|
||||
(finish (car (cdr (cdr form))))
|
||||
(body (cdr (cdr (cdr form)))))
|
||||
`(,(r 'let) ,(r 'loop) ,(map (lambda (x)
|
||||
(list (car x) (cadr x)))
|
||||
bindings)
|
||||
(,(r 'if) ,(car finish)
|
||||
(,(r 'begin) ,@(cdr finish))
|
||||
(,(r 'begin) ,@body
|
||||
(,(r 'loop) ,@(map (lambda (x)
|
||||
(if (null? (cddr x))
|
||||
(car x)
|
||||
(car (cddr x))))
|
||||
bindings)))))))))
|
||||
|
||||
(define-syntax when
|
||||
(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
|
||||
(er-macro-transformer
|
||||
(lambda (expr r compare)
|
||||
(let ((key (cadr expr))
|
||||
(clauses (cddr expr)))
|
||||
`(,(r 'let) ((,(r 'key) ,key))
|
||||
,(let loop ((clauses clauses))
|
||||
(if (null? clauses)
|
||||
#f
|
||||
(begin
|
||||
(define clause (car clauses))
|
||||
`(,(r 'if) ,(if (compare (r 'else) (car clause))
|
||||
'#t
|
||||
`(,(r 'or)
|
||||
,@(map (lambda (x)
|
||||
`(,(r 'eqv?) ,(r 'key) (,(r 'quote) ,x)))
|
||||
(car clause))))
|
||||
,(if (compare (r '=>) (list-ref clause 1))
|
||||
`(,(list-ref clause 2) ,(r 'key))
|
||||
`(,(r 'begin) ,@(cdr clause)))
|
||||
,(loop (cdr clauses)))))))))))
|
||||
|
||||
(define-syntax letrec-syntax
|
||||
(er-macro-transformer
|
||||
(lambda (form r c)
|
||||
(let ((formal (car (cdr form)))
|
||||
(body (cdr (cdr form))))
|
||||
`(let ()
|
||||
,@(map (lambda (x)
|
||||
`(,(r 'define-syntax) ,(car x) ,(cadr x)))
|
||||
formal)
|
||||
,@body)))))
|
||||
|
||||
(define-syntax let-syntax
|
||||
(er-macro-transformer
|
||||
(lambda (form r c)
|
||||
`(,(r 'letrec-syntax) ,@(cdr form)))))
|
||||
|
||||
(define-syntax include
|
||||
(letrec ((read-file
|
||||
(lambda (filename)
|
||||
(let ((port (open-input-file filename)))
|
||||
(dynamic-wind
|
||||
(lambda () #f)
|
||||
(lambda ()
|
||||
(let loop ((expr (read port)) (exprs '()))
|
||||
(if (eof-object? expr)
|
||||
(reverse exprs)
|
||||
(loop (read port) (cons expr exprs)))))
|
||||
(lambda ()
|
||||
(close-port port)))))))
|
||||
(er-macro-transformer
|
||||
(lambda (form rename compare)
|
||||
(let ((filenames (cdr form)))
|
||||
(let ((exprs (apply append (map read-file filenames))))
|
||||
`(,(rename 'begin) ,@exprs)))))))
|
||||
|
||||
(export define
|
||||
lambda
|
||||
|
|
@ -310,15 +8,31 @@
|
|||
begin
|
||||
define-syntax)
|
||||
|
||||
(export let let* letrec letrec*
|
||||
let-values let*-values define-values
|
||||
quasiquote unquote unquote-splicing
|
||||
and or
|
||||
cond case else =>
|
||||
do when unless
|
||||
let-syntax letrec-syntax
|
||||
(export let
|
||||
let*
|
||||
letrec
|
||||
letrec*
|
||||
let-values
|
||||
let*-values
|
||||
define-values
|
||||
quasiquote
|
||||
unquote
|
||||
unquote-splicing
|
||||
and
|
||||
or
|
||||
cond
|
||||
case
|
||||
do
|
||||
when
|
||||
unless
|
||||
let-syntax
|
||||
letrec-syntax
|
||||
include
|
||||
_ ... syntax-error)
|
||||
=>
|
||||
else
|
||||
_
|
||||
...
|
||||
syntax-error)
|
||||
|
||||
(export eq?
|
||||
eqv?
|
||||
|
|
|
|||
Loading…
Reference in New Issue