From 4fd4e15cc196a89e5ed5133896d7b8b9f4b2c10a Mon Sep 17 00:00:00 2001
From: Yuichi Nishiwaki <yuichi.nishiwaki@gmail.com>
Date: Mon, 8 Sep 2014 23:31:04 +0900
Subject: [PATCH] load basic syntaxes at boot time

---
 boot.c | 739 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 init.c |   4 +
 2 files changed, 743 insertions(+)
 create mode 100644 boot.c

diff --git a/boot.c b/boot.c
new file mode 100644
index 00000000..2a0c0691
--- /dev/null
+++ b/boot.c
@@ -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
diff --git a/init.c b/init.c
index 5ff2231e..a5e70d71 100644
--- a/init.c
+++ b/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);
   }
 }