548 lines
24 KiB
C
548 lines
24 KiB
C
#if 0
|
|
|
|
=pod
|
|
/*
|
|
=cut
|
|
|
|
use strict;
|
|
|
|
my $src = <<'EOL';
|
|
|
|
(define-library (picrin base)
|
|
|
|
(define (memoize f)
|
|
"memoize on symbols"
|
|
(define cache (make-dictionary))
|
|
(lambda (sym)
|
|
(define value (dictionary-ref cache sym))
|
|
(if (not (undefined? value))
|
|
value
|
|
(begin
|
|
(define val (f sym))
|
|
(dictionary-set! cache sym val)
|
|
val))))
|
|
|
|
(define (er-macro-transformer f)
|
|
(lambda (mac-env)
|
|
(lambda (expr use-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 'lambda) '_
|
|
(list (r 'error) (list (r 'string-append) "invalid use of auxiliary syntax: '" (symbol->string (cadr expr)) "'"))))))))
|
|
|
|
(define-auxiliary-syntax else)
|
|
(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 parameterize
|
|
(er-macro-transformer
|
|
(lambda (form r compare)
|
|
(let ((formal (cadr form))
|
|
(body (cddr form)))
|
|
`(,(r 'with-parameter)
|
|
(lambda ()
|
|
,@formal
|
|
,@body))))))
|
|
|
|
(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)))))
|
|
|
|
(export let let* letrec letrec*
|
|
let-values let*-values define-values
|
|
quasiquote unquote unquote-splicing
|
|
and or
|
|
cond case else =>
|
|
do when unless
|
|
parameterize
|
|
let-syntax letrec-syntax
|
|
syntax-error))
|
|
|
|
EOL
|
|
|
|
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";
|
|
|
|
print <<EOL;
|
|
const char pic_boot[][80] = {
|
|
EOL
|
|
|
|
my @lines = $src =~ /.{0,80}/gs;
|
|
|
|
foreach (@lines) {
|
|
s/\\/\\\\/g;
|
|
s/"/\\"/g;
|
|
s/\n/\\n/g;
|
|
print "\"$_\",\n";
|
|
}
|
|
print "\"\"\n";
|
|
|
|
=pod
|
|
*/
|
|
=cut
|
|
|
|
print <<EOL;
|
|
};
|
|
|
|
#if 0
|
|
Local Variables:
|
|
mode: scheme
|
|
End:
|
|
|
|
=cut
|
|
#endif
|
|
EOL
|
|
|
|
=pod
|
|
|
|
#---END---
|
|
|
|
#endif
|
|
|
|
const char pic_boot[][80] = {
|
|
"\n(define-library (picrin base)\n\n (define (memoize f)\n \"memoize on symbols\"\n ",
|
|
" (define cache (make-dictionary))\n (lambda (sym)\n (define value (dicti",
|
|
"onary-ref cache sym))\n (if (not (undefined? value))\n value\n ",
|
|
" (begin\n (define val (f sym))\n (dictionary-set! cache sy",
|
|
"m val)\n val))))\n\n (define (er-macro-transformer f)\n (lambda (mac-",
|
|
"env)\n (lambda (expr use-env)\n\n (define rename\n (memoize\n ",
|
|
" (lambda (sym)\n (make-identifier sym mac-env))))\n\n (de",
|
|
"fine (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 synta",
|
|
"x-error\n (er-macro-transformer\n (lambda (expr rename compare)\n (app",
|
|
"ly 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 'lambda) '_\n ",
|
|
" (list (r 'error) (list (r 'string-append) \"invalid use of aux",
|
|
"iliary syntax: '\" (symbol->string (cadr expr)) \"'\"))))))))\n\n (define-auxiliary-",
|
|
"syntax else)\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 (defi",
|
|
"ne bindings (car (cdr (cdr expr))))\n (define body (cdr (cdr (cdr",
|
|
" expr))))\n (list (r 'let) '()\n (list (r 'define) n",
|
|
"ame\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 (ma",
|
|
"p cadr bindings)))))))\n\n (define-syntax cond\n (er-macro-transformer\n (la",
|
|
"mbda (expr r compare)\n (let ((clauses (cdr expr)))\n (if (null? cla",
|
|
"uses)\n #f\n (begin\n (define clause (car cla",
|
|
"uses))\n (if (compare (r 'else) (car clause))\n (c",
|
|
"ons (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 cla",
|
|
"use)))\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 clau",
|
|
"se)\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) (li",
|
|
"st (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 (un",
|
|
"quote? 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 ((un",
|
|
"quote? 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 'con",
|
|
"s)\n (list (rename 'list)\n (list (r",
|
|
"ename 'quote) (rename 'unquote-splicing))\n (qq (- dept",
|
|
"h 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-mac",
|
|
"ro-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 (b",
|
|
"ody (cddr form)))\n (let ((vars (map (lambda (v) `(,v #f)) (map car bindi",
|
|
"ngs)))\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 c",
|
|
"ompare)\n `(,(rename 'letrec*) ,@(cdr form)))))\n\n (define-syntax let*-valu",
|
|
"es\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-valu",
|
|
"es\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 'a",
|
|
"rgs)))\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) ,a",
|
|
"rgs))))))))))))\n\n (define-syntax do\n (er-macro-transformer\n (lambda (for",
|
|
"m r compare)\n (let ((bindings (car (cdr form)))\n (finish (ca",
|
|
"r (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 (ca",
|
|
"r 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-transform",
|
|
"er\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-transfo",
|
|
"rmer\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 (com",
|
|
"pare (r '=>) (list-ref clause 1))\n `(,(list-ref claus",
|
|
"e 2) ,(r 'key))\n `(,(r 'begin) ,@(cdr clause)))\n ",
|
|
" ,(loop (cdr clauses)))))))))))\n\n (define-syntax parameterize\n",
|
|
" (er-macro-transformer\n (lambda (form r compare)\n (let ((formal (ca",
|
|
"dr form))\n (body (cddr form)))\n `(,(r 'with-parameter)\n ",
|
|
" (lambda ()\n ,@formal\n ,@body))))))\n\n (define-synt",
|
|
"ax 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 (export let let* letrec letrec*\n ",
|
|
"let-values let*-values define-values\n quasiquote unquote unquote-splici",
|
|
"ng\n and or\n cond case else =>\n do when unless\n ",
|
|
" parameterize\n let-syntax letrec-syntax\n syntax-error))\n\n",
|
|
"",
|
|
""
|
|
};
|
|
|
|
#if 0
|
|
Local Variables:
|
|
mode: scheme
|
|
End:
|
|
|
|
=cut
|
|
#endif
|