726 lines
33 KiB
C
726 lines
33 KiB
C
#if 0
|
|
|
|
=pod
|
|
/*
|
|
=cut
|
|
|
|
use strict;
|
|
|
|
my $src = <<'EOL';
|
|
|
|
(define-library (picrin base)
|
|
|
|
(define-macro call-with-current-environment
|
|
(lambda (form env)
|
|
(list (cadr form) env)))
|
|
|
|
(define here
|
|
(call-with-current-environment
|
|
(lambda (env)
|
|
env)))
|
|
|
|
(define (the var) ; synonym for #'var
|
|
(make-identifier var here))
|
|
|
|
(define the-define (the 'define))
|
|
(define the-lambda (the 'lambda))
|
|
(define the-begin (the 'begin))
|
|
(define the-quote (the 'quote))
|
|
(define the-set! (the 'set!))
|
|
(define the-if (the 'if))
|
|
(define the-define-macro (the 'define-macro))
|
|
|
|
(define-macro syntax-error
|
|
(lambda (form _)
|
|
(apply error (cdr form))))
|
|
|
|
(define-macro define-auxiliary-syntax
|
|
(lambda (form _)
|
|
(define message
|
|
(string-append
|
|
"invalid use of auxiliary syntax: '" (symbol->string (cadr form)) "'"))
|
|
(list
|
|
the-define-macro
|
|
(cadr form)
|
|
(list the-lambda '_
|
|
(list (the 'error) message)))))
|
|
|
|
(define-auxiliary-syntax else)
|
|
(define-auxiliary-syntax =>)
|
|
(define-auxiliary-syntax unquote)
|
|
(define-auxiliary-syntax unquote-splicing)
|
|
(define-auxiliary-syntax syntax-unquote)
|
|
(define-auxiliary-syntax syntax-unquote-splicing)
|
|
|
|
(define-macro let
|
|
(lambda (form env)
|
|
(if (variable? (cadr form))
|
|
(list
|
|
(list the-lambda '()
|
|
(list the-define (cadr form)
|
|
(cons the-lambda
|
|
(cons (map car (car (cddr form)))
|
|
(cdr (cddr form)))))
|
|
(cons (cadr form) (map cadr (car (cddr form))))))
|
|
(cons
|
|
(cons
|
|
the-lambda
|
|
(cons (map car (cadr form))
|
|
(cddr form)))
|
|
(map cadr (cadr form))))))
|
|
|
|
(define-macro and
|
|
(lambda (form env)
|
|
(if (null? (cdr form))
|
|
#t
|
|
(if (null? (cddr form))
|
|
(cadr form)
|
|
(list the-if
|
|
(cadr form)
|
|
(cons (the 'and) (cddr form))
|
|
#f)))))
|
|
|
|
(define-macro or
|
|
(lambda (form env)
|
|
(if (null? (cdr form))
|
|
#f
|
|
(let ((tmp (make-identifier 'it env)))
|
|
(list (the 'let)
|
|
(list (list tmp (cadr form)))
|
|
(list the-if
|
|
tmp
|
|
tmp
|
|
(cons (the 'or) (cddr form))))))))
|
|
|
|
(define-macro cond
|
|
(lambda (form env)
|
|
(let ((clauses (cdr form)))
|
|
(if (null? clauses)
|
|
#undefined
|
|
(let ((clause (car clauses)))
|
|
(if (and (variable? (car clause))
|
|
(variable=? (the 'else) (make-identifier (car clause) env)))
|
|
(cons the-begin (cdr clause))
|
|
(if (and (variable? (cadr clause))
|
|
(variable=? (the '=>) (make-identifier (cadr clause) env)))
|
|
(let ((tmp (make-identifier 'tmp here)))
|
|
(list (the 'let) (list (list tmp (car clause)))
|
|
(list the-if tmp
|
|
(list (car (cddr clause)) tmp)
|
|
(cons (the 'cond) (cdr clauses)))))
|
|
(list the-if (car clause)
|
|
(cons the-begin (cdr clause))
|
|
(cons (the 'cond) (cdr clauses))))))))))
|
|
|
|
(define-macro quasiquote
|
|
(lambda (form env)
|
|
|
|
(define (quasiquote? form)
|
|
(and (pair? form)
|
|
(variable? (car form))
|
|
(variable=? (the 'quasiquote) (make-identifier (car form) env))))
|
|
|
|
(define (unquote? form)
|
|
(and (pair? form)
|
|
(variable? (car form))
|
|
(variable=? (the 'unquote) (make-identifier (car form) env))))
|
|
|
|
(define (unquote-splicing? form)
|
|
(and (pair? form)
|
|
(pair? (car form))
|
|
(variable? (caar form))
|
|
(variable=? (the 'unquote-splicing) (make-identifier (caar form) env))))
|
|
|
|
(define (qq depth expr)
|
|
(cond
|
|
;; unquote
|
|
((unquote? expr)
|
|
(if (= depth 1)
|
|
(car (cdr expr))
|
|
(list (the 'list)
|
|
(list (the 'quote) (the 'unquote))
|
|
(qq (- depth 1) (car (cdr expr))))))
|
|
;; unquote-splicing
|
|
((unquote-splicing? expr)
|
|
(if (= depth 1)
|
|
(list (the 'append)
|
|
(car (cdr (car expr)))
|
|
(qq depth (cdr expr)))
|
|
(list (the 'cons)
|
|
(list (the 'list)
|
|
(list (the 'quote) (the 'unquote-splicing))
|
|
(qq (- depth 1) (car (cdr (car expr)))))
|
|
(qq depth (cdr expr)))))
|
|
;; quasiquote
|
|
((quasiquote? expr)
|
|
(list (the 'list)
|
|
(list (the 'quote) (the 'quasiquote))
|
|
(qq (+ depth 1) (car (cdr expr)))))
|
|
;; list
|
|
((pair? expr)
|
|
(list (the 'cons)
|
|
(qq depth (car expr))
|
|
(qq depth (cdr expr))))
|
|
;; vector
|
|
((vector? expr)
|
|
(list (the 'list->vector) (qq depth (vector->list expr))))
|
|
;; simple datum
|
|
(else
|
|
(list (the 'quote) expr))))
|
|
|
|
(let ((x (cadr form)))
|
|
(qq 1 x))))
|
|
|
|
(define-macro let*
|
|
(lambda (form env)
|
|
(let ((bindings (car (cdr form)))
|
|
(body (cdr (cdr form))))
|
|
(if (null? bindings)
|
|
`(,(the 'let) () ,@body)
|
|
`(,(the 'let) ((,(car (car bindings)) ,@(cdr (car bindings))))
|
|
(,(the 'let*) (,@(cdr bindings))
|
|
,@body))))))
|
|
|
|
(define-macro letrec
|
|
(lambda (form env)
|
|
`(,(the 'letrec*) ,@(cdr form))))
|
|
|
|
(define-macro letrec*
|
|
(lambda (form env)
|
|
(let ((bindings (car (cdr form)))
|
|
(body (cdr (cdr form))))
|
|
(let ((variables (map (lambda (v) `(,v #f)) (map car bindings)))
|
|
(initials (map (lambda (v) `(,(the 'set!) ,@v)) bindings)))
|
|
`(,(the 'let) (,@variables)
|
|
,@initials
|
|
,@body)))))
|
|
|
|
(define-macro let-values
|
|
(lambda (form env)
|
|
`(,(the 'let*-values) ,@(cdr form))))
|
|
|
|
(define-macro let*-values
|
|
(lambda (form env)
|
|
(let ((formal (car (cdr form)))
|
|
(body (cdr (cdr form))))
|
|
(if (null? formal)
|
|
`(,(the 'let) () ,@body)
|
|
`(,(the 'call-with-values) (,the-lambda () ,@(cdr (car formal)))
|
|
(,(the 'lambda) (,@(car (car formal)))
|
|
(,(the 'let*-values) (,@(cdr formal))
|
|
,@body)))))))
|
|
|
|
(define-macro define-values
|
|
(lambda (form env)
|
|
(let ((formal (car (cdr form)))
|
|
(body (cdr (cdr form))))
|
|
(let ((arguments (make-identifier 'arguments here)))
|
|
`(,the-begin
|
|
,@(let loop ((formal formal))
|
|
(if (pair? formal)
|
|
`((,the-define ,(car formal) #undefined) ,@(loop (cdr formal)))
|
|
(if (variable? formal)
|
|
`((,the-define ,formal #undefined))
|
|
'())))
|
|
(,(the 'call-with-values) (,the-lambda () ,@body)
|
|
(,the-lambda
|
|
,arguments
|
|
,@(let loop ((formal formal) (args arguments))
|
|
(if (pair? formal)
|
|
`((,the-set! ,(car formal) (,(the 'car) ,args)) ,@(loop (cdr formal) `(,(the 'cdr) ,args)))
|
|
(if (variable? formal)
|
|
`((,the-set! ,formal ,args))
|
|
'()))))))))))
|
|
|
|
(define-macro do
|
|
(lambda (form env)
|
|
(let ((bindings (car (cdr form)))
|
|
(test (car (car (cdr (cdr form)))))
|
|
(cleanup (cdr (car (cdr (cdr form)))))
|
|
(body (cdr (cdr (cdr form)))))
|
|
(let ((loop (make-identifier 'loop here)))
|
|
`(,(the 'let) ,loop ,(map (lambda (x) `(,(car x) ,(cadr x))) bindings)
|
|
(,the-if ,test
|
|
(,the-begin
|
|
,@cleanup)
|
|
(,the-begin
|
|
,@body
|
|
(,loop ,@(map (lambda (x) (if (null? (cdr (cdr x))) (car x) (car (cdr (cdr x))))) bindings)))))))))
|
|
|
|
(define-macro when
|
|
(lambda (form env)
|
|
(let ((test (car (cdr form)))
|
|
(body (cdr (cdr form))))
|
|
`(,the-if ,test
|
|
(,the-begin ,@body)
|
|
#undefined))))
|
|
|
|
(define-macro unless
|
|
(lambda (form env)
|
|
(let ((test (car (cdr form)))
|
|
(body (cdr (cdr form))))
|
|
`(,the-if ,test
|
|
#undefined
|
|
(,the-begin ,@body)))))
|
|
|
|
(define-macro case
|
|
(lambda (form env)
|
|
(let ((key (car (cdr form)))
|
|
(clauses (cdr (cdr form))))
|
|
(let ((the-key (make-identifier 'key here)))
|
|
`(,(the 'let) ((,the-key ,key))
|
|
,(let loop ((clauses clauses))
|
|
(if (null? clauses)
|
|
#undefined
|
|
(let ((clause (car clauses)))
|
|
`(,the-if ,(if (and (variable? (car clause))
|
|
(variable=? (the 'else) (make-identifier (car clause) env)))
|
|
#t
|
|
`(,(the 'or) ,@(map (lambda (x) `(,(the 'eqv?) ,the-key (,the-quote ,x))) (car clause))))
|
|
,(if (and (variable? (cadr clause))
|
|
(variable=? (the '=>) (make-identifier (cadr clause) env)))
|
|
`(,(car (cdr (cdr clause))) ,the-key)
|
|
`(,the-begin ,@(cdr clause)))
|
|
,(loop (cdr clauses)))))))))))
|
|
|
|
(define-macro parameterize
|
|
(lambda (form env)
|
|
(let ((formal (car (cdr form)))
|
|
(body (cdr (cdr form))))
|
|
`(,(the 'with-parameter)
|
|
(,(the 'lambda) ()
|
|
,@formal
|
|
,@body)))))
|
|
|
|
(define-macro syntax-quote
|
|
(lambda (form env)
|
|
(let ((renames '()))
|
|
(letrec
|
|
((rename (lambda (var)
|
|
(let ((x (assq var renames)))
|
|
(if x
|
|
(cadr x)
|
|
(begin
|
|
(set! renames `((,var ,(make-identifier var env) (,(the 'make-identifier) ',var ',env)) . ,renames))
|
|
(rename var))))))
|
|
(walk (lambda (f form)
|
|
(cond
|
|
((variable? form)
|
|
(f form))
|
|
((pair? form)
|
|
`(,(the 'cons) (walk f (car form)) (walk f (cdr form))))
|
|
((vector? form)
|
|
`(,(the 'list->vector) (walk f (vector->list form))))
|
|
(else
|
|
`(,(the 'quote) ,form))))))
|
|
(let ((form (walk rename (cadr form))))
|
|
`(,(the 'let)
|
|
,(map cdr renames)
|
|
,form))))))
|
|
|
|
(define-macro syntax-quasiquote
|
|
(lambda (form env)
|
|
(let ((renames '()))
|
|
(letrec
|
|
((rename (lambda (var)
|
|
(let ((x (assq var renames)))
|
|
(if x
|
|
(cadr x)
|
|
(begin
|
|
(set! renames `((,var ,(make-identifier var env) (,(the 'make-identifier) ',var ',env)) . ,renames))
|
|
(rename var)))))))
|
|
|
|
(define (syntax-quasiquote? form)
|
|
(and (pair? form)
|
|
(variable? (car form))
|
|
(variable=? (the 'syntax-quasiquote) (make-identifier (car form) env))))
|
|
|
|
(define (syntax-unquote? form)
|
|
(and (pair? form)
|
|
(variable? (car form))
|
|
(variable=? (the 'syntax-unquote) (make-identifier (car form) env))))
|
|
|
|
(define (syntax-unquote-splicing? form)
|
|
(and (pair? form)
|
|
(pair? (car form))
|
|
(variable? (caar form))
|
|
(variable=? (the 'syntax-unquote-splicing) (make-identifier (caar form) env))))
|
|
|
|
(define (qq depth expr)
|
|
(cond
|
|
;; syntax-unquote
|
|
((syntax-unquote? expr)
|
|
(if (= depth 1)
|
|
(car (cdr expr))
|
|
(list (the 'list)
|
|
(list (the 'quote) (the 'syntax-unquote))
|
|
(qq (- depth 1) (car (cdr expr))))))
|
|
;; syntax-unquote-splicing
|
|
((syntax-unquote-splicing? expr)
|
|
(if (= depth 1)
|
|
(list (the 'append)
|
|
(car (cdr (car expr)))
|
|
(qq depth (cdr expr)))
|
|
(list (the 'cons)
|
|
(list (the 'list)
|
|
(list (the 'quote) (the 'syntax-unquote-splicing))
|
|
(qq (- depth 1) (car (cdr (car expr)))))
|
|
(qq depth (cdr expr)))))
|
|
;; syntax-quasiquote
|
|
((syntax-quasiquote? expr)
|
|
(list (the 'list)
|
|
(list (the 'quote) (the 'quasiquote))
|
|
(qq (+ depth 1) (car (cdr expr)))))
|
|
;; list
|
|
((pair? expr)
|
|
(list (the 'cons)
|
|
(qq depth (car expr))
|
|
(qq depth (cdr expr))))
|
|
;; vector
|
|
((vector? expr)
|
|
(list (the 'list->vector) (qq depth (vector->list expr))))
|
|
;; variable
|
|
((variable? expr)
|
|
(rename expr))
|
|
;; simple datum
|
|
(else
|
|
(list (the 'quote) expr))))
|
|
|
|
(let ((body (qq 1 (cadr form))))
|
|
`(,(the 'let)
|
|
,(map cdr renames)
|
|
,body))))))
|
|
|
|
(define (transformer f)
|
|
(lambda (form env)
|
|
(let ((register1 (make-register))
|
|
(register2 (make-register)))
|
|
(letrec
|
|
((wrap (lambda (var1)
|
|
(let ((var2 (register1 var1)))
|
|
(if (undefined? var2)
|
|
(let ((var2 (make-identifier var1 env)))
|
|
(register1 var1 var2)
|
|
(register2 var2 var1)
|
|
var2)
|
|
var2))))
|
|
(unwrap (lambda (var2)
|
|
(let ((var1 (register2 var2)))
|
|
(if (undefined? var1)
|
|
var2
|
|
var1))))
|
|
(walk (lambda (f form)
|
|
(cond
|
|
((variable? form)
|
|
(f form))
|
|
((pair? form)
|
|
(cons (walk f (car form)) (walk f (cdr form))))
|
|
((vector? form)
|
|
(list->vector (walk f (vector->list form))))
|
|
(else
|
|
form)))))
|
|
(let ((form (cdr form)))
|
|
(walk unwrap (apply f (walk wrap form))))))))
|
|
|
|
(define-macro define-syntax
|
|
(lambda (form env)
|
|
(let ((formal (car (cdr form)))
|
|
(body (cdr (cdr form))))
|
|
(if (pair? formal)
|
|
`(,(the 'define-syntax) ,(car formal) (,the-lambda ,(cdr formal) ,@body))
|
|
`(,the-define-macro ,formal (,(the 'transformer) (,the-begin ,@body)))))))
|
|
|
|
(define-macro letrec-syntax
|
|
(lambda (form env)
|
|
(let ((formal (car (cdr form)))
|
|
(body (cdr (cdr form))))
|
|
`(let ()
|
|
,@(map (lambda (x)
|
|
`(,(the 'define-syntax) ,(car x) ,(cadr x)))
|
|
formal)
|
|
,@body))))
|
|
|
|
(define-macro let-syntax
|
|
(lambda (form env)
|
|
`(,(the '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
|
|
define-syntax
|
|
syntax-quote syntax-unquote
|
|
syntax-quasiquote syntax-unquote-splicing
|
|
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-macro call-with-current-environment\n ",
|
|
" (lambda (form env)\n (list (cadr form) env)))\n\n (define here\n (call-wi",
|
|
"th-current-environment\n (lambda (env)\n env)))\n\n (define (the var) ",
|
|
" ; synonym for #'var\n (make-identifier var here))\n\n (define ",
|
|
"the-define (the 'define))\n (define the-lambda (the 'lambda))\n (define the-begi",
|
|
"n (the 'begin))\n (define the-quote (the 'quote))\n (define the-set! (the 'set!)",
|
|
")\n (define the-if (the 'if))\n (define the-define-macro (the 'define-macro))\n\n ",
|
|
" (define-macro syntax-error\n (lambda (form _)\n (apply error (cdr form)))",
|
|
")\n\n (define-macro define-auxiliary-syntax\n (lambda (form _)\n (define me",
|
|
"ssage\n (string-append\n \"invalid use of auxiliary syntax: '\" (symb",
|
|
"ol->string (cadr form)) \"'\"))\n (list\n the-define-macro\n (cadr f",
|
|
"orm)\n (list the-lambda '_\n (list (the 'error) message)))))\n\n ",
|
|
"(define-auxiliary-syntax else)\n (define-auxiliary-syntax =>)\n (define-auxiliar",
|
|
"y-syntax unquote)\n (define-auxiliary-syntax unquote-splicing)\n (define-auxilia",
|
|
"ry-syntax syntax-unquote)\n (define-auxiliary-syntax syntax-unquote-splicing)\n\n ",
|
|
" (define-macro let\n (lambda (form env)\n (if (variable? (cadr form))\n ",
|
|
" (list\n (list the-lambda '()\n (list the-define (c",
|
|
"adr form)\n (cons the-lambda\n (",
|
|
"cons (map car (car (cddr form)))\n (cdr (cddr f",
|
|
"orm)))))\n (cons (cadr form) (map cadr (car (cddr form))))))\n ",
|
|
" (cons\n (cons\n the-lambda\n (cons (map car (",
|
|
"cadr form))\n (cddr form)))\n (map cadr (cadr form)))))",
|
|
")\n\n (define-macro and\n (lambda (form env)\n (if (null? (cdr form))\n ",
|
|
" #t\n (if (null? (cddr form))\n (cadr form)\n ",
|
|
" (list the-if\n (cadr form)\n (cons (the 'a",
|
|
"nd) (cddr form))\n #f)))))\n\n (define-macro or\n (lambda (fo",
|
|
"rm env)\n (if (null? (cdr form))\n #f\n (let ((tmp (make-ide",
|
|
"ntifier 'it env)))\n (list (the 'let)\n (list (list tm",
|
|
"p (cadr form)))\n (list the-if\n tmp\n ",
|
|
" tmp\n (cons (the 'or) (cddr form)))))))",
|
|
")\n\n (define-macro cond\n (lambda (form env)\n (let ((clauses (cdr form)))",
|
|
"\n (if (null? clauses)\n #undefined\n (let ((clause (c",
|
|
"ar clauses)))\n (if (and (variable? (car clause))\n ",
|
|
" (variable=? (the 'else) (make-identifier (car clause) env)))\n ",
|
|
" (cons the-begin (cdr clause))\n (if (and (variable? (cadr cl",
|
|
"ause))\n (variable=? (the '=>) (make-identifier (cadr c",
|
|
"lause) env)))\n (let ((tmp (make-identifier 'tmp here)))\n ",
|
|
" (list (the 'let) (list (list tmp (car clause)))\n ",
|
|
" (list the-if tmp\n (list (c",
|
|
"ar (cddr clause)) tmp)\n (cons (the 'cond) (cd",
|
|
"r clauses)))))\n (list the-if (car clause)\n ",
|
|
" (cons the-begin (cdr clause))\n (cons (the ",
|
|
"'cond) (cdr clauses))))))))))\n\n (define-macro quasiquote\n (lambda (form env)",
|
|
"\n\n (define (quasiquote? form)\n (and (pair? form)\n (varia",
|
|
"ble? (car form))\n (variable=? (the 'quasiquote) (make-identifier (ca",
|
|
"r form) env))))\n\n (define (unquote? form)\n (and (pair? form)\n ",
|
|
" (variable? (car form))\n (variable=? (the 'unquote) (make-ident",
|
|
"ifier (car form) env))))\n\n (define (unquote-splicing? form)\n (and (p",
|
|
"air? form)\n (pair? (car form))\n (variable? (caar form))\n",
|
|
" (variable=? (the 'unquote-splicing) (make-identifier (caar form) en",
|
|
"v))))\n\n (define (qq depth expr)\n (cond\n ;; unquote\n ",
|
|
"((unquote? expr)\n (if (= depth 1)\n (car (cdr expr))\n ",
|
|
" (list (the 'list)\n (list (the 'quote) (the 'unquote))",
|
|
"\n (qq (- depth 1) (car (cdr expr))))))\n ;; unquote-sp",
|
|
"licing\n ((unquote-splicing? expr)\n (if (= depth 1)\n ",
|
|
" (list (the 'append)\n (car (cdr (car expr)))\n ",
|
|
" (qq depth (cdr expr)))\n (list (the 'cons)\n ",
|
|
"(list (the 'list)\n (list (the 'quote) (the 'unquote-spl",
|
|
"icing))\n (qq (- depth 1) (car (cdr (car expr)))))\n ",
|
|
" (qq depth (cdr expr)))))\n ;; quasiquote\n ((quasiq",
|
|
"uote? expr)\n (list (the 'list)\n (list (the 'quote) (the ",
|
|
"'quasiquote))\n (qq (+ depth 1) (car (cdr expr)))))\n ;; li",
|
|
"st\n ((pair? expr)\n (list (the 'cons)\n (qq depth ",
|
|
"(car expr))\n (qq depth (cdr expr))))\n ;; vector\n ",
|
|
"((vector? expr)\n (list (the 'list->vector) (qq depth (vector->list expr",
|
|
"))))\n ;; simple datum\n (else\n (list (the 'quote) expr))",
|
|
"))\n\n (let ((x (cadr form)))\n (qq 1 x))))\n\n (define-macro let*\n (",
|
|
"lambda (form env)\n (let ((bindings (car (cdr form)))\n (body ",
|
|
"(cdr (cdr form))))\n (if (null? bindings)\n `(,(the 'let) () ,@b",
|
|
"ody)\n `(,(the 'let) ((,(car (car bindings)) ,@(cdr (car bindings))))\n",
|
|
" (,(the 'let*) (,@(cdr bindings))\n ,@body))))))\n\n (d",
|
|
"efine-macro letrec\n (lambda (form env)\n `(,(the 'letrec*) ,@(cdr form)))",
|
|
")\n\n (define-macro letrec*\n (lambda (form env)\n (let ((bindings (car (cd",
|
|
"r form)))\n (body (cdr (cdr form))))\n (let ((variables (map",
|
|
" (lambda (v) `(,v #f)) (map car bindings)))\n (initials (map (lambd",
|
|
"a (v) `(,(the 'set!) ,@v)) bindings)))\n `(,(the 'let) (,@variables)\n ",
|
|
" ,@initials\n ,@body)))))\n\n (define-macro let-values\n (lam",
|
|
"bda (form env)\n `(,(the 'let*-values) ,@(cdr form))))\n\n (define-macro let*",
|
|
"-values\n (lambda (form env)\n (let ((formal (car (cdr form)))\n ",
|
|
" (body (cdr (cdr form))))\n (if (null? formal)\n `(,(the 'let)",
|
|
" () ,@body)\n `(,(the 'call-with-values) (,the-lambda () ,@(cdr (car f",
|
|
"ormal)))\n (,(the 'lambda) (,@(car (car formal)))\n (,(",
|
|
"the 'let*-values) (,@(cdr formal))\n ,@body)))))))\n\n (define-macr",
|
|
"o define-values\n (lambda (form env)\n (let ((formal (car (cdr form)))\n ",
|
|
" (body (cdr (cdr form))))\n (let ((arguments (make-identifier 'a",
|
|
"rguments here)))\n `(,the-begin\n ,@(let loop ((formal formal)",
|
|
")\n (if (pair? formal)\n `((,the-define ,(car fo",
|
|
"rmal) #undefined) ,@(loop (cdr formal)))\n (if (variable? form",
|
|
"al)\n `((,the-define ,formal #undefined))\n ",
|
|
" '())))\n (,(the 'call-with-values) (,the-lambda () ,@body)\n ",
|
|
" (,the-lambda\n ,arguments\n ,@(let loop ((form",
|
|
"al formal) (args arguments))\n (if (pair? formal)\n ",
|
|
" `((,the-set! ,(car formal) (,(the 'car) ,args)) ,@(loop (cdr formal) `(,",
|
|
"(the 'cdr) ,args)))\n (if (variable? formal)\n ",
|
|
" `((,the-set! ,formal ,args))\n '()))))))))))\n",
|
|
"\n (define-macro do\n (lambda (form env)\n (let ((bindings (car (cdr form)",
|
|
"))\n (test (car (car (cdr (cdr form)))))\n (cleanup (cd",
|
|
"r (car (cdr (cdr form)))))\n (body (cdr (cdr (cdr form)))))\n ",
|
|
" (let ((loop (make-identifier 'loop here)))\n `(,(the 'let) ,loop ,(map",
|
|
" (lambda (x) `(,(car x) ,(cadr x))) bindings)\n (,the-if ,test\n ",
|
|
" (,the-begin\n ,@cleanup)\n (,the-begin\n ",
|
|
" ,@body\n (,loop ,@(map (lambda (x) (if (null? (cdr (cdr x))) (car ",
|
|
"x) (car (cdr (cdr x))))) bindings)))))))))\n\n (define-macro when\n (lambda (fo",
|
|
"rm env)\n (let ((test (car (cdr form)))\n (body (cdr (cdr form))))",
|
|
"\n `(,the-if ,test\n (,the-begin ,@body)\n ",
|
|
" #undefined))))\n\n (define-macro unless\n (lambda (form env)\n (let ((test",
|
|
" (car (cdr form)))\n (body (cdr (cdr form))))\n `(,the-if ,test\n",
|
|
" #undefined\n (,the-begin ,@body)))))\n\n (defin",
|
|
"e-macro case\n (lambda (form env)\n (let ((key (car (cdr form)))\n ",
|
|
" (clauses (cdr (cdr form))))\n (let ((the-key (make-identifier 'key ",
|
|
"here)))\n `(,(the 'let) ((,the-key ,key))\n ,(let loop ((claus",
|
|
"es clauses))\n (if (null? clauses)\n #undefined\n ",
|
|
" (let ((clause (car clauses)))\n `(,the-if ,(",
|
|
"if (and (variable? (car clause))\n (varia",
|
|
"ble=? (the 'else) (make-identifier (car clause) env)))\n ",
|
|
" #t\n `(,(the 'or) ,@(map (lambda (x",
|
|
") `(,(the 'eqv?) ,the-key (,the-quote ,x))) (car clause))))\n ",
|
|
" ,(if (and (variable? (cadr clause))\n ",
|
|
" (variable=? (the '=>) (make-identifier (cadr clause) env)))\n ",
|
|
" `(,(car (cdr (cdr clause))) ,the-key)\n ",
|
|
" `(,the-begin ,@(cdr clause)))\n ,",
|
|
"(loop (cdr clauses)))))))))))\n\n (define-macro parameterize\n (lambda (form en",
|
|
"v)\n (let ((formal (car (cdr form)))\n (body (cdr (cdr form))))\n",
|
|
" `(,(the 'with-parameter)\n (,(the 'lambda) ()\n ,@forma",
|
|
"l\n ,@body)))))\n\n (define-macro syntax-quote\n (lambda (form env)\n ",
|
|
" (let ((renames '()))\n (letrec\n ((rename (lambda (var)\n ",
|
|
" (let ((x (assq var renames)))\n (if x\n",
|
|
" (cadr x)\n (begin\n ",
|
|
" (set! renames `((,var ,(make-identifier var env) (,(the",
|
|
" 'make-identifier) ',var ',env)) . ,renames))\n (re",
|
|
"name var))))))\n (walk (lambda (f form)\n (cond\n ",
|
|
" ((variable? form)\n (f form))\n ",
|
|
" ((pair? form)\n `(,(the 'cons) (walk f (car fo",
|
|
"rm)) (walk f (cdr form))))\n ((vector? form)\n ",
|
|
" `(,(the 'list->vector) (walk f (vector->list form))))\n ",
|
|
" (else\n `(,(the 'quote) ,form))))))\n (let ((fo",
|
|
"rm (walk rename (cadr form))))\n `(,(the 'let)\n ,(map cdr",
|
|
" renames)\n ,form))))))\n\n (define-macro syntax-quasiquote\n (lamb",
|
|
"da (form env)\n (let ((renames '()))\n (letrec\n ((rename (l",
|
|
"ambda (var)\n (let ((x (assq var renames)))\n ",
|
|
" (if x\n (cadr x)\n ",
|
|
" (begin\n (set! renames `((,var ,(make-identifier",
|
|
" var env) (,(the 'make-identifier) ',var ',env)) . ,renames))\n ",
|
|
" (rename var)))))))\n\n (define (syntax-quasiquote? form)\n ",
|
|
" (and (pair? form)\n (variable? (car form))\n ",
|
|
" (variable=? (the 'syntax-quasiquote) (make-identifier (car form) env))))\n\n ",
|
|
" (define (syntax-unquote? form)\n (and (pair? form)\n ",
|
|
" (variable? (car form))\n (variable=? (the 'syntax-unquote) ",
|
|
"(make-identifier (car form) env))))\n\n (define (syntax-unquote-splicing?",
|
|
" form)\n (and (pair? form)\n (pair? (car form))\n ",
|
|
" (variable? (caar form))\n (variable=? (the 'syntax-unqu",
|
|
"ote-splicing) (make-identifier (caar form) env))))\n\n (define (qq depth ",
|
|
"expr)\n (cond\n ;; syntax-unquote\n ((syntax-unq",
|
|
"uote? expr)\n (if (= depth 1)\n (car (cdr expr))\n ",
|
|
" (list (the 'list)\n (list (the 'quote) (the",
|
|
" 'syntax-unquote))\n (qq (- depth 1) (car (cdr expr))))))\n",
|
|
" ;; syntax-unquote-splicing\n ((syntax-unquote-splicing? ",
|
|
"expr)\n (if (= depth 1)\n (list (the 'append)\n ",
|
|
" (car (cdr (car expr)))\n (qq depth (cdr ",
|
|
"expr)))\n (list (the 'cons)\n (list (the '",
|
|
"list)\n (list (the 'quote) (the 'syntax-unquote-spli",
|
|
"cing))\n (qq (- depth 1) (car (cdr (car expr)))))\n ",
|
|
" (qq depth (cdr expr)))))\n ;; syntax-quasiquote",
|
|
"\n ((syntax-quasiquote? expr)\n (list (the 'list)\n ",
|
|
" (list (the 'quote) (the 'quasiquote))\n (qq (+ de",
|
|
"pth 1) (car (cdr expr)))))\n ;; list\n ((pair? expr)\n ",
|
|
" (list (the 'cons)\n (qq depth (car expr))\n ",
|
|
" (qq depth (cdr expr))))\n ;; vector\n ((vector? e",
|
|
"xpr)\n (list (the 'list->vector) (qq depth (vector->list expr))))\n ",
|
|
" ;; variable\n ((variable? expr)\n (rename expr",
|
|
"))\n ;; simple datum\n (else\n (list (the 'quo",
|
|
"te) expr))))\n\n (let ((body (qq 1 (cadr form))))\n `(,(the 'le",
|
|
"t)\n ,(map cdr renames)\n ,body))))))\n\n (define (transf",
|
|
"ormer f)\n (lambda (form env)\n (let ((register1 (make-register))\n ",
|
|
" (register2 (make-register)))\n (letrec\n ((wrap (lambda (var",
|
|
"1)\n (let ((var2 (register1 var1)))\n (i",
|
|
"f (undefined? var2)\n (let ((var2 (make-identifier var1",
|
|
" env)))\n (register1 var1 var2)\n ",
|
|
" (register2 var2 var1)\n var2)\n ",
|
|
" var2))))\n (unwrap (lambda (var2)\n ",
|
|
"(let ((var1 (register2 var2)))\n (if (undefined? var1)\n ",
|
|
" var2\n var1))))\n ",
|
|
" (walk (lambda (f form)\n (cond\n ((var",
|
|
"iable? form)\n (f form))\n ((pair? form",
|
|
")\n (cons (walk f (car form)) (walk f (cdr form))))\n ",
|
|
" ((vector? form)\n (list->vector (walk f (vec",
|
|
"tor->list form))))\n (else\n form)))))\n",
|
|
" (let ((form (cdr form)))\n (walk unwrap (apply f (walk wrap ",
|
|
"form))))))))\n\n (define-macro define-syntax\n (lambda (form env)\n (let ((",
|
|
"formal (car (cdr form)))\n (body (cdr (cdr form))))\n (if (pai",
|
|
"r? formal)\n `(,(the 'define-syntax) ,(car formal) (,the-lambda ,(cdr ",
|
|
"formal) ,@body))\n `(,the-define-macro ,formal (,(the 'transformer) (,",
|
|
"the-begin ,@body)))))))\n\n (define-macro letrec-syntax\n (lambda (form env)\n ",
|
|
" (let ((formal (car (cdr form)))\n (body (cdr (cdr form))))\n ",
|
|
" `(let ()\n ,@(map (lambda (x)\n `(,(the 'define-sy",
|
|
"ntax) ,(car x) ,(cadr x)))\n formal)\n ,@body))))\n\n (d",
|
|
"efine-macro let-syntax\n (lambda (form env)\n `(,(the 'letrec-syntax) ,@(c",
|
|
"dr form))))\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 parameterize\n ",
|
|
" define-syntax\n syntax-quote syntax-unquote\n syntax-quasiquo",
|
|
"te syntax-unquote-splicing\n let-syntax letrec-syntax\n syntax-e",
|
|
"rror))\n\n",
|
|
"",
|
|
""
|
|
};
|
|
|
|
#if 0
|
|
Local Variables:
|
|
mode: scheme
|
|
End:
|
|
|
|
=cut
|
|
#endif
|