load basic syntaxes at boot time
This commit is contained in:
Yuichi Nishiwaki
parent
dd80aff03a
commit
4fd4e15cc1
|
|
@ -0,0 +1,739 @@
|
|||
#if 0
|
||||
|
||||
use strict;
|
||||
|
||||
open IN, "./boot.c";
|
||||
my @data = <IN>;
|
||||
close IN;
|
||||
|
||||
open STDOUT, ">", "./boot.c";
|
||||
|
||||
foreach (@data) {
|
||||
print;
|
||||
last if $_ eq "#---END---\n";
|
||||
}
|
||||
|
||||
print "\n#endif\n\n";
|
||||
|
||||
my $src = <<'EOL';
|
||||
|
||||
(define-library (picrin base)
|
||||
|
||||
(define (memoize f)
|
||||
"memoize on symbols"
|
||||
(define cache (make-dictionary))
|
||||
(lambda (sym)
|
||||
(call-with-values (lambda () (dictionary-ref cache sym))
|
||||
(lambda (value exists)
|
||||
(if exists
|
||||
value
|
||||
(begin
|
||||
(define val (f sym))
|
||||
(dictionary-set! cache sym val)
|
||||
val))))))
|
||||
|
||||
(define (er-macro-transformer f)
|
||||
(lambda (expr use-env mac-env)
|
||||
|
||||
(define rename
|
||||
(memoize
|
||||
(lambda (sym)
|
||||
(make-identifier sym mac-env))))
|
||||
|
||||
(define (compare x y)
|
||||
(if (not (symbol? x))
|
||||
#f
|
||||
(if (not (symbol? y))
|
||||
#f
|
||||
(identifier=? use-env x use-env y))))
|
||||
|
||||
(f expr rename compare)))
|
||||
|
||||
(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 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
|
||||
include
|
||||
_ ... syntax-error))
|
||||
|
||||
EOL
|
||||
|
||||
print <<EOL;
|
||||
const char pic_boot[] =
|
||||
EOL
|
||||
|
||||
my @lines = split /\n/, $src;
|
||||
|
||||
foreach (@lines) {
|
||||
s/\\/\\\\/g;
|
||||
s/"/\\"/g;
|
||||
print "\"$_\\n\"\n";
|
||||
}
|
||||
|
||||
print <<EOL;
|
||||
;
|
||||
|
||||
#if 0
|
||||
=cut
|
||||
#endif
|
||||
EOL
|
||||
|
||||
=pod
|
||||
|
||||
#---END---
|
||||
|
||||
#endif
|
||||
|
||||
const char pic_boot[] =
|
||||
"\n"
|
||||
"(define-library (picrin base)\n"
|
||||
"\n"
|
||||
" (define (memoize f)\n"
|
||||
" \"memoize on symbols\"\n"
|
||||
" (define cache (make-dictionary))\n"
|
||||
" (lambda (sym)\n"
|
||||
" (call-with-values (lambda () (dictionary-ref cache sym))\n"
|
||||
" (lambda (value exists)\n"
|
||||
" (if exists\n"
|
||||
" value\n"
|
||||
" (begin\n"
|
||||
" (define val (f sym))\n"
|
||||
" (dictionary-set! cache sym val)\n"
|
||||
" val))))))\n"
|
||||
"\n"
|
||||
" (define (er-macro-transformer f)\n"
|
||||
" (lambda (expr use-env mac-env)\n"
|
||||
"\n"
|
||||
" (define rename\n"
|
||||
" (memoize\n"
|
||||
" (lambda (sym)\n"
|
||||
" (make-identifier sym mac-env))))\n"
|
||||
"\n"
|
||||
" (define (compare x y)\n"
|
||||
" (if (not (symbol? x))\n"
|
||||
" #f\n"
|
||||
" (if (not (symbol? y))\n"
|
||||
" #f\n"
|
||||
" (identifier=? use-env x use-env y))))\n"
|
||||
"\n"
|
||||
" (f expr rename compare)))\n"
|
||||
"\n"
|
||||
" (define-syntax syntax-error\n"
|
||||
" (er-macro-transformer\n"
|
||||
" (lambda (expr rename compare)\n"
|
||||
" (apply error (cdr expr)))))\n"
|
||||
"\n"
|
||||
" (define-syntax define-auxiliary-syntax\n"
|
||||
" (er-macro-transformer\n"
|
||||
" (lambda (expr r c)\n"
|
||||
" (list (r 'define-syntax) (cadr expr)\n"
|
||||
" (list (r 'lambda) '_\n"
|
||||
" (list (r 'error) \"invalid use of auxiliary syntax\"))))))\n"
|
||||
"\n"
|
||||
" (define-auxiliary-syntax else)\n"
|
||||
" (define-auxiliary-syntax =>)\n"
|
||||
" (define-auxiliary-syntax _)\n"
|
||||
" (define-auxiliary-syntax ...)\n"
|
||||
" (define-auxiliary-syntax unquote)\n"
|
||||
" (define-auxiliary-syntax unquote-splicing)\n"
|
||||
"\n"
|
||||
" (define-syntax let\n"
|
||||
" (er-macro-transformer\n"
|
||||
" (lambda (expr r compare)\n"
|
||||
" (if (symbol? (cadr expr))\n"
|
||||
" (begin\n"
|
||||
" (define name (car (cdr expr)))\n"
|
||||
" (define bindings (car (cdr (cdr expr))))\n"
|
||||
" (define body (cdr (cdr (cdr expr))))\n"
|
||||
" (list (r 'let) '()\n"
|
||||
" (list (r 'define) name\n"
|
||||
" (cons (r 'lambda) (cons (map car bindings) body)))\n"
|
||||
" (cons name (map cadr bindings))))\n"
|
||||
" (begin\n"
|
||||
" (set! bindings (cadr expr))\n"
|
||||
" (set! body (cddr expr))\n"
|
||||
" (cons (cons (r 'lambda) (cons (map car bindings) body))\n"
|
||||
" (map cadr bindings)))))))\n"
|
||||
"\n"
|
||||
" (define-syntax cond\n"
|
||||
" (er-macro-transformer\n"
|
||||
" (lambda (expr r compare)\n"
|
||||
" (let ((clauses (cdr expr)))\n"
|
||||
" (if (null? clauses)\n"
|
||||
" #f\n"
|
||||
" (begin\n"
|
||||
" (define clause (car clauses))\n"
|
||||
" (if (compare (r 'else) (car clause))\n"
|
||||
" (cons (r 'begin) (cdr clause))\n"
|
||||
" (if (if (>= (length clause) 2)\n"
|
||||
" (compare (r '=>) (list-ref clause 1))\n"
|
||||
" #f)\n"
|
||||
" (list (r 'let) (list (list (r 'x) (car clause)))\n"
|
||||
" (list (r 'if) (r 'x)\n"
|
||||
" (list (list-ref clause 2) (r 'x))\n"
|
||||
" (cons (r 'cond) (cdr clauses))))\n"
|
||||
" (list (r 'if) (car clause)\n"
|
||||
" (cons (r 'begin) (cdr clause))\n"
|
||||
" (cons (r 'cond) (cdr clauses)))))))))))\n"
|
||||
"\n"
|
||||
" (define-syntax and\n"
|
||||
" (er-macro-transformer\n"
|
||||
" (lambda (expr r compare)\n"
|
||||
" (let ((exprs (cdr expr)))\n"
|
||||
" (cond\n"
|
||||
" ((null? exprs)\n"
|
||||
" #t)\n"
|
||||
" ((= (length exprs) 1)\n"
|
||||
" (car exprs))\n"
|
||||
" (else\n"
|
||||
" (list (r 'let) (list (list (r 'it) (car exprs)))\n"
|
||||
" (list (r 'if) (r 'it)\n"
|
||||
" (cons (r 'and) (cdr exprs))\n"
|
||||
" (r 'it)))))))))\n"
|
||||
"\n"
|
||||
" (define-syntax or\n"
|
||||
" (er-macro-transformer\n"
|
||||
" (lambda (expr r compare)\n"
|
||||
" (let ((exprs (cdr expr)))\n"
|
||||
" (cond\n"
|
||||
" ((null? exprs)\n"
|
||||
" #t)\n"
|
||||
" ((= (length exprs) 1)\n"
|
||||
" (car exprs))\n"
|
||||
" (else\n"
|
||||
" (list (r 'let) (list (list (r 'it) (car exprs)))\n"
|
||||
" (list (r 'if) (r 'it)\n"
|
||||
" (r 'it)\n"
|
||||
" (cons (r 'or) (cdr exprs))))))))))\n"
|
||||
"\n"
|
||||
" (define-syntax quasiquote\n"
|
||||
" (er-macro-transformer\n"
|
||||
" (lambda (form rename compare)\n"
|
||||
"\n"
|
||||
" (define (quasiquote? form)\n"
|
||||
" (and (pair? form) (compare (car form) (rename 'quasiquote))))\n"
|
||||
"\n"
|
||||
" (define (unquote? form)\n"
|
||||
" (and (pair? form) (compare (car form) (rename 'unquote))))\n"
|
||||
"\n"
|
||||
" (define (unquote-splicing? form)\n"
|
||||
" (and (pair? form) (pair? (car form))\n"
|
||||
" (compare (car (car form)) (rename 'unquote-splicing))))\n"
|
||||
"\n"
|
||||
" (define (qq depth expr)\n"
|
||||
" (cond\n"
|
||||
" ;; unquote\n"
|
||||
" ((unquote? expr)\n"
|
||||
" (if (= depth 1)\n"
|
||||
" (car (cdr expr))\n"
|
||||
" (list (rename 'list)\n"
|
||||
" (list (rename 'quote) (rename 'unquote))\n"
|
||||
" (qq (- depth 1) (car (cdr expr))))))\n"
|
||||
" ;; unquote-splicing\n"
|
||||
" ((unquote-splicing? expr)\n"
|
||||
" (if (= depth 1)\n"
|
||||
" (list (rename 'append)\n"
|
||||
" (car (cdr (car expr)))\n"
|
||||
" (qq depth (cdr expr)))\n"
|
||||
" (list (rename 'cons)\n"
|
||||
" (list (rename 'list)\n"
|
||||
" (list (rename 'quote) (rename 'unquote-splicing))\n"
|
||||
" (qq (- depth 1) (car (cdr (car expr)))))\n"
|
||||
" (qq depth (cdr expr)))))\n"
|
||||
" ;; quasiquote\n"
|
||||
" ((quasiquote? expr)\n"
|
||||
" (list (rename 'list)\n"
|
||||
" (list (rename 'quote) (rename 'quasiquote))\n"
|
||||
" (qq (+ depth 1) (car (cdr expr)))))\n"
|
||||
" ;; list\n"
|
||||
" ((pair? expr)\n"
|
||||
" (list (rename 'cons)\n"
|
||||
" (qq depth (car expr))\n"
|
||||
" (qq depth (cdr expr))))\n"
|
||||
" ;; vector\n"
|
||||
" ((vector? expr)\n"
|
||||
" (list (rename 'list->vector) (qq depth (vector->list expr))))\n"
|
||||
" ;; simple datum\n"
|
||||
" (else\n"
|
||||
" (list (rename 'quote) expr))))\n"
|
||||
"\n"
|
||||
" (let ((x (cadr form)))\n"
|
||||
" (qq 1 x)))))\n"
|
||||
"\n"
|
||||
" (define-syntax let*\n"
|
||||
" (er-macro-transformer\n"
|
||||
" (lambda (form r compare)\n"
|
||||
" (let ((bindings (cadr form))\n"
|
||||
" (body (cddr form)))\n"
|
||||
" (if (null? bindings)\n"
|
||||
" `(,(r 'let) () ,@body)\n"
|
||||
" `(,(r 'let) ((,(caar bindings)\n"
|
||||
" ,@(cdar bindings)))\n"
|
||||
" (,(r 'let*) (,@(cdr bindings))\n"
|
||||
" ,@body)))))))\n"
|
||||
"\n"
|
||||
" (define-syntax letrec*\n"
|
||||
" (er-macro-transformer\n"
|
||||
" (lambda (form r compare)\n"
|
||||
" (let ((bindings (cadr form))\n"
|
||||
" (body (cddr form)))\n"
|
||||
" (let ((vars (map (lambda (v) `(,v #f)) (map car bindings)))\n"
|
||||
" (initials (map (lambda (v) `(,(r 'set!) ,@v)) bindings)))\n"
|
||||
" `(,(r 'let) (,@vars)\n"
|
||||
" ,@initials\n"
|
||||
" ,@body))))))\n"
|
||||
"\n"
|
||||
" (define-syntax letrec\n"
|
||||
" (er-macro-transformer\n"
|
||||
" (lambda (form rename compare)\n"
|
||||
" `(,(rename 'letrec*) ,@(cdr form)))))\n"
|
||||
"\n"
|
||||
" (define-syntax let*-values\n"
|
||||
" (er-macro-transformer\n"
|
||||
" (lambda (form r c)\n"
|
||||
" (let ((formals (cadr form)))\n"
|
||||
" (if (null? formals)\n"
|
||||
" `(,(r 'let) () ,@(cddr form))\n"
|
||||
" `(,(r 'call-with-values) (,(r 'lambda) () ,@(cdar formals))\n"
|
||||
" (,(r 'lambda) (,@(caar formals))\n"
|
||||
" (,(r 'let*-values) (,@(cdr formals))\n"
|
||||
" ,@(cddr form)))))))))\n"
|
||||
"\n"
|
||||
" (define-syntax let-values\n"
|
||||
" (er-macro-transformer\n"
|
||||
" (lambda (form r c)\n"
|
||||
" `(,(r 'let*-values) ,@(cdr form)))))\n"
|
||||
"\n"
|
||||
" (define-syntax define-values\n"
|
||||
" (er-macro-transformer\n"
|
||||
" (lambda (form r compare)\n"
|
||||
" (let ((formal (cadr form))\n"
|
||||
" (exprs (cddr form)))\n"
|
||||
" `(,(r 'begin)\n"
|
||||
" ,@(let loop ((formal formal))\n"
|
||||
" (if (not (pair? formal))\n"
|
||||
" (if (symbol? formal)\n"
|
||||
" `((,(r 'define) ,formal #f))\n"
|
||||
" '())\n"
|
||||
" `((,(r 'define) ,(car formal) #f) . ,@(loop (cdr formal)))))\n"
|
||||
" (,(r 'call-with-values) (,(r 'lambda) () ,@exprs)\n"
|
||||
" (,(r 'lambda) ,(r 'args)\n"
|
||||
" ,@(let loop ((formal formal) (args (r 'args)))\n"
|
||||
" (if (not (pair? formal))\n"
|
||||
" (if (symbol? formal)\n"
|
||||
" `((,(r 'set!) ,formal ,args))\n"
|
||||
" '())\n"
|
||||
" `((,(r 'set!) ,(car formal) (,(r 'car) ,args))\n"
|
||||
" ,@(loop (cdr formal) `(,(r 'cdr) ,args))))))))))))\n"
|
||||
"\n"
|
||||
" (define-syntax do\n"
|
||||
" (er-macro-transformer\n"
|
||||
" (lambda (form r compare)\n"
|
||||
" (let ((bindings (car (cdr form)))\n"
|
||||
" (finish (car (cdr (cdr form))))\n"
|
||||
" (body (cdr (cdr (cdr form)))))\n"
|
||||
" `(,(r 'let) ,(r 'loop) ,(map (lambda (x)\n"
|
||||
" (list (car x) (cadr x)))\n"
|
||||
" bindings)\n"
|
||||
" (,(r 'if) ,(car finish)\n"
|
||||
" (,(r 'begin) ,@(cdr finish))\n"
|
||||
" (,(r 'begin) ,@body\n"
|
||||
" (,(r 'loop) ,@(map (lambda (x)\n"
|
||||
" (if (null? (cddr x))\n"
|
||||
" (car x)\n"
|
||||
" (car (cddr x))))\n"
|
||||
" bindings)))))))))\n"
|
||||
"\n"
|
||||
" (define-syntax when\n"
|
||||
" (er-macro-transformer\n"
|
||||
" (lambda (expr rename compare)\n"
|
||||
" (let ((test (cadr expr))\n"
|
||||
" (body (cddr expr)))\n"
|
||||
" `(,(rename 'if) ,test\n"
|
||||
" (,(rename 'begin) ,@body)\n"
|
||||
" #f)))))\n"
|
||||
"\n"
|
||||
" (define-syntax unless\n"
|
||||
" (er-macro-transformer\n"
|
||||
" (lambda (expr rename compare)\n"
|
||||
" (let ((test (cadr expr))\n"
|
||||
" (body (cddr expr)))\n"
|
||||
" `(,(rename 'if) ,test\n"
|
||||
" #f\n"
|
||||
" (,(rename 'begin) ,@body))))))\n"
|
||||
"\n"
|
||||
" (define-syntax case\n"
|
||||
" (er-macro-transformer\n"
|
||||
" (lambda (expr r compare)\n"
|
||||
" (let ((key (cadr expr))\n"
|
||||
" (clauses (cddr expr)))\n"
|
||||
" `(,(r 'let) ((,(r 'key) ,key))\n"
|
||||
" ,(let loop ((clauses clauses))\n"
|
||||
" (if (null? clauses)\n"
|
||||
" #f\n"
|
||||
" (begin\n"
|
||||
" (define clause (car clauses))\n"
|
||||
" `(,(r 'if) ,(if (compare (r 'else) (car clause))\n"
|
||||
" '#t\n"
|
||||
" `(,(r 'or)\n"
|
||||
" ,@(map (lambda (x)\n"
|
||||
" `(,(r 'eqv?) ,(r 'key) (,(r 'quote) ,x)))\n"
|
||||
" (car clause))))\n"
|
||||
" ,(if (compare (r '=>) (list-ref clause 1))\n"
|
||||
" `(,(list-ref clause 2) ,(r 'key))\n"
|
||||
" `(,(r 'begin) ,@(cdr clause)))\n"
|
||||
" ,(loop (cdr clauses)))))))))))\n"
|
||||
"\n"
|
||||
" (define-syntax letrec-syntax\n"
|
||||
" (er-macro-transformer\n"
|
||||
" (lambda (form r c)\n"
|
||||
" (let ((formal (car (cdr form)))\n"
|
||||
" (body (cdr (cdr form))))\n"
|
||||
" `(let ()\n"
|
||||
" ,@(map (lambda (x)\n"
|
||||
" `(,(r 'define-syntax) ,(car x) ,(cadr x)))\n"
|
||||
" formal)\n"
|
||||
" ,@body)))))\n"
|
||||
"\n"
|
||||
" (define-syntax let-syntax\n"
|
||||
" (er-macro-transformer\n"
|
||||
" (lambda (form r c)\n"
|
||||
" `(,(r 'letrec-syntax) ,@(cdr form)))))\n"
|
||||
"\n"
|
||||
" (define-syntax include\n"
|
||||
" (letrec ((read-file\n"
|
||||
" (lambda (filename)\n"
|
||||
" (let ((port (open-input-file filename)))\n"
|
||||
" (dynamic-wind\n"
|
||||
" (lambda () #f)\n"
|
||||
" (lambda ()\n"
|
||||
" (let loop ((expr (read port)) (exprs '()))\n"
|
||||
" (if (eof-object? expr)\n"
|
||||
" (reverse exprs)\n"
|
||||
" (loop (read port) (cons expr exprs)))))\n"
|
||||
" (lambda ()\n"
|
||||
" (close-port port)))))))\n"
|
||||
" (er-macro-transformer\n"
|
||||
" (lambda (form rename compare)\n"
|
||||
" (let ((filenames (cdr form)))\n"
|
||||
" (let ((exprs (apply append (map read-file filenames))))\n"
|
||||
" `(,(rename 'begin) ,@exprs)))))))\n"
|
||||
"\n"
|
||||
" (export let let* letrec letrec*\n"
|
||||
" let-values let*-values define-values\n"
|
||||
" quasiquote unquote unquote-splicing\n"
|
||||
" and or\n"
|
||||
" cond case else =>\n"
|
||||
" do when unless\n"
|
||||
" let-syntax letrec-syntax\n"
|
||||
" include\n"
|
||||
" _ ... syntax-error))\n"
|
||||
;
|
||||
|
||||
#if 0
|
||||
=cut
|
||||
#endif
|
||||
4
init.c
4
init.c
|
|
@ -35,6 +35,8 @@ void pic_init_lib(pic_state *);
|
|||
|
||||
#define DONE pic_gc_arena_restore(pic, ai);
|
||||
|
||||
extern const char pic_boot[];
|
||||
|
||||
void
|
||||
pic_init_core(pic_state *pic)
|
||||
{
|
||||
|
|
@ -73,5 +75,7 @@ pic_init_core(pic_state *pic)
|
|||
pic_init_record(pic); DONE;
|
||||
pic_init_eval(pic); DONE;
|
||||
pic_init_lib(pic); DONE;
|
||||
|
||||
pic_load_cstr(pic, pic_boot);
|
||||
}
|
||||
}
|
||||
|
|
|
|||
Loading…
Reference in New Issue