conservatory
/
picrin
4
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Rewrite tools/mkboot.scm in Perl 

Now we don't have to depend on a bin/picrin-bootstrap binary.

The old mkboot.scm filtered the Scheme source code through `read` and
`write`. This step removed extra whitespace and comments, but required
mkboot to depend on Scheme. In practice, the whitespace and comments
are not a problem, but the dependency is.

Discussed with Masanori Ogino.
This commit is contained in:
Lassi Kortela 2024-03-01 13:45:05 +02:00 committed by Masanori Ogino
parent 16615615c9
commit 311abc4d5f
4 changed files with 405 additions and 325 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
Makefile
View File

@ -74,7 +74,7 @@ src/init_contrib.c:
# $(CC) -shared $(CFLAGS) -o $@ $(LIBPICRIN_OBJS) $(LDFLAGS) # $(CC) -shared $(CFLAGS) -o $@ $(LIBPICRIN_OBJS) $(LDFLAGS)
lib/ext/boot.c: piclib/boot.scm piclib/library.scm lib/ext/boot.c: piclib/boot.scm piclib/library.scm
cat piclib/boot.scm piclib/library.scm | bin/picrin-bootstrap tools/mkboot.scm > lib/ext/boot.c cat piclib/boot.scm piclib/library.scm | perl tools/mkboot.pl > lib/ext/boot.c
$(LIBPICRIN_OBJS) $(PICRIN_OBJS) $(CONTRIB_OBJS): lib/include/picrin.h lib/include/picrin/*.h lib/khash.h lib/object.h lib/state.h lib/vm.h $(LIBPICRIN_OBJS) $(PICRIN_OBJS) $(CONTRIB_OBJS): lib/include/picrin.h lib/include/picrin/*.h lib/khash.h lib/object.h lib/state.h lib/vm.h

617
lib/ext/boot.c
View File

@ -2,262 +2,367 @@
#include "picrin/extra.h" #include "picrin/extra.h"
static const char boot_rom[][80] = { static const char boot_rom[][80] = {
"(core#define-macro call-with-current-environment (core#lambda (form env) (list (", "(core#define-macro call-with-current-environment\n (core#lambda (form env)\n (",
"cadr form) env))) (core#define here (call-with-current-environment (core#lambda ", "list (cadr form) env)))\n\n(core#define here\n (call-with-current-environment\n (",
"(env) env))) (core#define the (core#lambda (var) (make-identifier var here))) (c", "core#lambda (env)\n env)))\n\n(core#define the ; synonym fo",
"ore#define the-builtin-define (the (core#quote core#define))) (core#define the-b", "r #'var\n (core#lambda (var)\n (make-identifier var here)))\n\n\n(core#define the",
"uiltin-lambda (the (core#quote core#lambda))) (core#define the-builtin-begin (th", "-builtin-define (the (core#quote core#define)))\n(core#define the-builtin-lambda ",
"e (core#quote core#begin))) (core#define the-builtin-quote (the (core#quote core", "(the (core#quote core#lambda)))\n(core#define the-builtin-begin (the (core#quote ",
"#quote))) (core#define the-builtin-set! (the (core#quote core#set!))) (core#defi", "core#begin)))\n(core#define the-builtin-quote (the (core#quote core#quote)))\n(cor",
"ne the-builtin-if (the (core#quote core#if))) (core#define the-builtin-define-ma", "e#define the-builtin-set! (the (core#quote core#set!)))\n(core#define the-builtin",
"cro (the (core#quote core#define-macro))) (core#define the-define (the (core#quo", "-if (the (core#quote core#if)))\n(core#define the-builtin-define-macro (the (core",
"te define))) (core#define the-lambda (the (core#quote lambda))) (core#define the", "#quote core#define-macro)))\n\n(core#define the-define (the (core#quote define)))\n",
"-begin (the (core#quote begin))) (core#define the-quote (the (core#quote quote))", "(core#define the-lambda (the (core#quote lambda)))\n(core#define the-begin (the (",
") (core#define the-set! (the (core#quote set!))) (core#define the-if (the (core#", "core#quote begin)))\n(core#define the-quote (the (core#quote quote)))\n(core#defin",
"quote if))) (core#define the-define-macro (the (core#quote define-macro))) (core", "e the-set! (the (core#quote set!)))\n(core#define the-if (the (core#quote if)))\n(",
"#define-macro quote (core#lambda (form env) (core#if (= (length form) 2) (list t", "core#define the-define-macro (the (core#quote define-macro)))\n\n(core#define-macr",
"he-builtin-quote (cadr form)) (error \"illegal quote form\" form)))) (core#define-", "o quote\n (core#lambda (form env)\n (core#if (= (length form) 2)\n (list t",
"macro if (core#lambda (form env) ((core#lambda (len) (core#if (= len 4) (cons th", "he-builtin-quote (cadr form))\n (error \"illegal quote form\" form))))\n\n(core#",
"e-builtin-if (cdr form)) (core#if (= len 3) (list the-builtin-if (list-ref form ", "define-macro if\n (core#lambda (form env)\n ((core#lambda (len)\n (core#i",
"1) (list-ref form 2) #undefined) (error \"illegal if form\" form)))) (length form)", "f (= len 4)\n (cons the-builtin-if (cdr form))\n (core#if (= l",
"))) (core#define-macro begin (core#lambda (form env) ((core#lambda (len) (if (= ", "en 3)\n (list the-builtin-if (list-ref form 1) (list-ref form 2) #u",
"len 1) #undefined (if (= len 2) (cadr form) (if (= len 3) (cons the-builtin-begi", "ndefined)\n (error \"illegal if form\" form))))\n (length form))))",
"n (cdr form)) (list the-builtin-begin (cadr form) (cons the-begin (cddr form))))", "\n\n(core#define-macro begin\n (core#lambda (form env)\n ((core#lambda (len)\n ",
"))) (length form)))) (core#define-macro set! (core#lambda (form env) (if (= (len", " (if (= len 1)\n #undefined\n (if (= len 2)\n ",
"gth form) 3) (if (identifier? (cadr form)) (cons the-builtin-set! (cdr form)) (e", "(cadr form)\n (if (= len 3)\n (cons the-builtin-be",
"rror \"illegal set! form\" form)) (error \"illegal set! form\" form)))) (core#define", "gin (cdr form))\n (list the-builtin-begin\n ",
" check-formal (core#lambda (formal) (if (null? formal) #t (if (identifier? forma", " (cadr form)\n (cons the-begin (cddr form)))))))\n ",
"l) #t (if (pair? formal) (if (identifier? (car formal)) (check-formal (cdr forma", "(length form))))\n\n(core#define-macro set!\n (core#lambda (form env)\n (if (= (",
"l)) #f) #f))))) (core#define-macro lambda (core#lambda (form env) (if (= (length", "length form) 3)\n (if (identifier? (cadr form))\n (cons the-buil",
" form) 1) (error \"illegal lambda form\" form) (if (check-formal (cadr form)) (lis", "tin-set! (cdr form))\n (error \"illegal set! form\" form))\n (erro",
"t the-builtin-lambda (cadr form) (cons the-begin (cddr form))) (error \"illegal l", "r \"illegal set! form\" form))))\n\n(core#define check-formal\n (core#lambda (formal",
"ambda form\" form))))) (core#define-macro define (lambda (form env) ((lambda (len", ")\n (if (null? formal)\n #t\n (if (identifier? formal)\n ",
") (if (= len 1) (error \"illegal define form\" form) (if (identifier? (cadr form))", " #t\n (if (pair? formal)\n (if (identifier? (car formal)",
" (if (= len 3) (cons the-builtin-define (cdr form)) (error \"illegal define form\"", ")\n (check-formal (cdr formal))\n #f)\n ",
" form)) (if (pair? (cadr form)) (list the-define (car (cadr form)) (cons the-lam", " #f)))))\n\n(core#define-macro lambda\n (core#lambda (form env)\n (if (",
"bda (cons (cdr (cadr form)) (cddr form)))) (error \"define: binding to non-varaib", "= (length form) 1)\n (error \"illegal lambda form\" form)\n (if (check",
"le object\" form))))) (length form)))) (core#define-macro define-macro (lambda (f", "-formal (cadr form))\n (list the-builtin-lambda (cadr form) (cons the-",
"orm env) (if (= (length form) 3) (if (identifier? (cadr form)) (cons the-builtin", "begin (cddr form)))\n (error \"illegal lambda form\" form)))))\n\n(core#de",
"-define-macro (cdr form)) (error \"define-macro: binding to non-variable object\" ", "fine-macro define\n (lambda (form env)\n ((lambda (len)\n (if (= len 1)\n ",
"form)) (error \"illegal define-macro form\" form)))) (define-macro syntax-error (l", " (error \"illegal define form\" form)\n (if (identifier? (cadr f",
"ambda (form _) (apply error (cdr form)))) (define-macro define-auxiliary-syntax ", "orm))\n (if (= len 3)\n (cons the-builtin-define (",
"(lambda (form _) (define message (string-append \"invalid use of auxiliary syntax", "cdr form))\n (error \"illegal define form\" form))\n ",
": '\" (symbol->string (cadr form)) \"'\")) (list the-define-macro (cadr form) (list", " (if (pair? (cadr form))\n (list the-define\n ",
" the-lambda '_ (list (the 'error) message))))) (define-auxiliary-syntax else) (d", " (car (cadr form))\n (cons the-lambda (cons (cdr (ca",
"efine-auxiliary-syntax =>) (define-auxiliary-syntax unquote) (define-auxiliary-s", "dr form)) (cddr form))))\n (error \"define: binding to non-varai",
"yntax unquote-splicing) (define-auxiliary-syntax syntax-unquote) (define-auxilia", "ble object\" form)))))\n (length form))))\n\n(core#define-macro define-macro\n (",
"ry-syntax syntax-unquote-splicing) (define-macro let (lambda (form env) (if (ide", "lambda (form env)\n (if (= (length form) 3)\n (if (identifier? (cadr for",
"ntifier? (cadr form)) (list (list the-lambda '() (list the-define (cadr form) (c", "m))\n (cons the-builtin-define-macro (cdr form))\n (error \"d",
"ons the-lambda (cons (map car (car (cddr form))) (cdr (cddr form))))) (cons (cad", "efine-macro: binding to non-variable object\" form))\n (error \"illegal defi",
"r form) (map cadr (car (cddr form)))))) (cons (cons the-lambda (cons (map car (c", "ne-macro form\" form))))\n\n\n(define-macro syntax-error\n (lambda (form _)\n (app",
"adr form)) (cddr form))) (map cadr (cadr form)))))) (define-macro and (lambda (f", "ly error (cdr form))))\n\n(define-macro define-auxiliary-syntax\n (lambda (form _)",
"orm env) (if (null? (cdr form)) #t (if (null? (cddr form)) (cadr form) (list the", "\n (define message\n (string-append\n \"invalid use of auxiliary synta",
"-if (cadr form) (cons (the 'and) (cddr form)) #f))))) (define-macro or (lambda (", "x: '\" (symbol->string (cadr form)) \"'\"))\n (list\n the-define-macro\n (c",
"form env) (if (null? (cdr form)) #f (let ((tmp (make-identifier 'it env))) (list", "adr form)\n (list the-lambda '_\n (list (the 'error) message)))))\n\n(",
" (the 'let) (list (list tmp (cadr form))) (list the-if tmp tmp (cons (the 'or) (", "define-auxiliary-syntax else)\n(define-auxiliary-syntax =>)\n(define-auxiliary-syn",
"cddr form)))))))) (define-macro cond (lambda (form env) (let ((clauses (cdr form", "tax unquote)\n(define-auxiliary-syntax unquote-splicing)\n(define-auxiliary-syntax",
"))) (if (null? clauses) #undefined (let ((clause (car clauses))) (if (and (ident", " syntax-unquote)\n(define-auxiliary-syntax syntax-unquote-splicing)\n\n(define-macr",
"ifier? (car clause)) (identifier=? (the 'else) (make-identifier (car clause) env", "o let\n (lambda (form env)\n (if (identifier? (cadr form))\n (list\n ",
"))) (cons the-begin (cdr clause)) (if (null? (cdr clause)) (let ((tmp (make-iden", " (list the-lambda '()\n (list the-define (cadr form)\n ",
"tifier 'tmp here))) (list (the 'let) (list (list tmp (car clause))) (list the-if", " (cons the-lambda\n (cons (map car (car (cddr ",
" tmp tmp (cons (the 'cond) (cdr clauses))))) (if (and (identifier? (cadr clause)", "form)))\n (cdr (cddr form)))))\n (co",
") (identifier=? (the '=>) (make-identifier (cadr clause) env))) (let ((tmp (make", "ns (cadr form) (map cadr (car (cddr form))))))\n (cons\n (cons\n ",
"-identifier 'tmp here))) (list (the 'let) (list (list tmp (car clause))) (list t", " the-lambda\n (cons (map car (cadr form))\n (cddr for",
"he-if tmp (list (car (cddr clause)) tmp) (cons (the 'cond) (cdr clauses))))) (li", "m)))\n (map cadr (cadr form))))))\n\n(define-macro and\n (lambda (form env)",
"st the-if (car clause) (cons the-begin (cdr clause)) (cons (the 'cond) (cdr clau", "\n (if (null? (cdr form))\n #t\n (if (null? (cddr form))\n ",
"ses))))))))))) (define-macro quasiquote (lambda (form env) (define (quasiquote? ", " (cadr form)\n (list the-if\n (cadr form)\n ",
"form) (and (pair? form) (identifier? (car form)) (identifier=? (the 'quasiquote)", " (cons (the 'and) (cddr form))\n #f)))))\n\n(define-macro o",
" (make-identifier (car form) env)))) (define (unquote? form) (and (pair? form) (", "r\n (lambda (form env)\n (if (null? (cdr form))\n #f\n (let ((tmp ",
"identifier? (car form)) (identifier=? (the 'unquote) (make-identifier (car form)", "(make-identifier 'it env)))\n (list (the 'let)\n (list (li",
" env)))) (define (unquote-splicing? form) (and (pair? form) (pair? (car form)) (", "st tmp (cadr form)))\n (list the-if\n tmp\n ",
"identifier? (caar form)) (identifier=? (the 'unquote-splicing) (make-identifier ", " tmp\n (cons (the 'or) (cddr form))))))))\n\n",
"(caar form) env)))) (define (qq depth expr) (cond ((unquote? expr) (if (= depth ", "(define-macro cond\n (lambda (form env)\n (let ((clauses (cdr form)))\n (i",
"1) (car (cdr expr)) (list (the 'list) (list (the 'quote) (the 'unquote)) (qq (- ", "f (null? clauses)\n #undefined\n (let ((clause (car clauses)))\n ",
"depth 1) (car (cdr expr)))))) ((unquote-splicing? expr) (if (= depth 1) (list (t", " (if (and (identifier? (car clause))\n (identifier=",
"he 'append) (car (cdr (car expr))) (qq depth (cdr expr))) (list (the 'cons) (lis", "? (the 'else) (make-identifier (car clause) env)))\n (cons the-beg",
"t (the 'list) (list (the 'quote) (the 'unquote-splicing)) (qq (- depth 1) (car (", "in (cdr clause))\n (if (null? (cdr clause))\n (l",
"cdr (car expr))))) (qq depth (cdr expr))))) ((quasiquote? expr) (list (the 'list", "et ((tmp (make-identifier 'tmp here)))\n (list (the 'let) (l",
") (list (the 'quote) (the 'quasiquote)) (qq (+ depth 1) (car (cdr expr))))) ((pa", "ist (list tmp (car clause)))\n (list the-if tmp tmp (c",
"ir? expr) (list (the 'cons) (qq depth (car expr)) (qq depth (cdr expr)))) ((vect", "ons (the 'cond) (cdr clauses)))))\n (if (and (identifier? (cad",
"or? expr) (list (the 'list->vector) (qq depth (vector->list expr)))) (else (list", "r clause))\n (identifier=? (the '=>) (make-identifier",
" (the 'quote) expr)))) (let ((x (cadr form))) (qq 1 x)))) (define-macro let* (la", " (cadr clause) env)))\n (let ((tmp (make-identifier 'tmp h",
"mbda (form env) (let ((bindings (car (cdr form))) (body (cdr (cdr form)))) (if (", "ere)))\n (list (the 'let) (list (list tmp (car clause)))",
"null? bindings) `(,(the 'let) () ,@body) `(,(the 'let) ((,(car (car bindings)) ,", "\n (list the-if tmp\n ",
"@(cdr (car bindings)))) (,(the 'let*) (,@(cdr bindings)) ,@body)))))) (define-ma", " (list (car (cddr clause)) tmp)\n (co",
"cro letrec (lambda (form env) `(,(the 'letrec*) ,@(cdr form)))) (define-macro le", "ns (the 'cond) (cdr clauses)))))\n (list the-if (car claus",
"trec* (lambda (form env) (let ((bindings (car (cdr form))) (body (cdr (cdr form)", "e)\n (cons the-begin (cdr clause))\n ",
"))) (let ((variables (map (lambda (v) `(,v #f)) (map car bindings))) (initials (", " (cons (the 'cond) (cdr clauses)))))))))))\n\n(define-macro quasiquote",
"map (lambda (v) `(,(the 'set!) ,@v)) bindings))) `(,(the 'let) (,@variables) ,@i", "\n (lambda (form env)\n\n (define (quasiquote? form)\n (and (pair? form)\n ",
"nitials ,@body))))) (define-macro let-values (lambda (form env) `(,(the 'let*-va", " (identifier? (car form))\n (identifier=? (the 'quasiquote) (ma",
"lues) ,@(cdr form)))) (define-macro let*-values (lambda (form env) (let ((formal", "ke-identifier (car form) env))))\n\n (define (unquote? form)\n (and (pair? ",
" (car (cdr form))) (body (cdr (cdr form)))) (if (null? formal) `(,(the 'let) () ", "form)\n (identifier? (car form))\n (identifier=? (the 'unquote",
",@body) `(,(the 'call-with-values) (,the-lambda () ,@(cdr (car formal))) (,(the ", ") (make-identifier (car form) env))))\n\n (define (unquote-splicing? form)\n ",
"'lambda) (,@(car (car formal))) (,(the 'let*-values) (,@(cdr formal)) ,@body))))", " (and (pair? form)\n (pair? (car form))\n (identifier? (caar ",
"))) (define-macro define-values (lambda (form env) (let ((formal (car (cdr form)", "form))\n (identifier=? (the 'unquote-splicing) (make-identifier (caar f",
")) (body (cdr (cdr form)))) (let ((arguments (make-identifier 'arguments here)))", "orm) env))))\n\n (define (qq depth expr)\n (cond\n ;; unquote\n (",
" `(,the-begin ,@(let loop ((formal formal)) (if (pair? formal) `((,the-define ,(", "(unquote? expr)\n (if (= depth 1)\n (car (cdr expr))\n ",
"car formal) #undefined) ,@(loop (cdr formal))) (if (identifier? formal) `((,the-", " (list (the 'list)\n (list (the 'quote) (the 'unquote))\n ",
"define ,formal #undefined)) '()))) (,(the 'call-with-values) (,the-lambda () ,@b", " (qq (- depth 1) (car (cdr expr))))))\n ;; unquote-splicing\n ",
"ody) (,the-lambda ,arguments ,@(let loop ((formal formal) (args arguments)) (if ", " ((unquote-splicing? expr)\n (if (= depth 1)\n (list (the 'appen",
"(pair? formal) `((,the-set! ,(car formal) (,(the 'car) ,args)) ,@(loop (cdr form", "d)\n (car (cdr (car expr)))\n (qq depth (cdr exp",
"al) `(,(the 'cdr) ,args))) (if (identifier? formal) `((,the-set! ,formal ,args))", "r)))\n (list (the 'cons)\n (list (the 'list)\n ",
" '())))))))))) (define-macro do (lambda (form env) (let ((bindings (car (cdr for", " (list (the 'quote) (the 'unquote-splicing))\n ",
"m))) (test (car (car (cdr (cdr form))))) (cleanup (cdr (car (cdr (cdr form))))) ", " (qq (- depth 1) (car (cdr (car expr)))))\n (qq depth (cdr exp",
"(body (cdr (cdr (cdr form))))) (let ((loop (make-identifier 'loop here))) `(,(th", "r)))))\n ;; quasiquote\n ((quasiquote? expr)\n (list (the 'list)",
"e 'let) ,loop ,(map (lambda (x) `(,(car x) ,(cadr x))) bindings) (,the-if ,test ", "\n (list (the 'quote) (the 'quasiquote))\n (qq (+ depth ",
"(,the-begin ,@cleanup) (,the-begin ,@body (,loop ,@(map (lambda (x) (if (null? (", "1) (car (cdr expr)))))\n ;; list\n ((pair? expr)\n (list (the 'c",
"cdr (cdr x))) (car x) (car (cdr (cdr x))))) bindings))))))))) (define-macro when", "ons)\n (qq depth (car expr))\n (qq depth (cdr expr))))\n ",
" (lambda (form env) (let ((test (car (cdr form))) (body (cdr (cdr form)))) `(,th", " ;; vector\n ((vector? expr)\n (list (the 'list->vector) (qq dep",
"e-if ,test (,the-begin ,@body) #undefined)))) (define-macro unless (lambda (form", "th (vector->list expr))))\n ;; simple datum\n (else\n (list (the",
" env) (let ((test (car (cdr form))) (body (cdr (cdr form)))) `(,the-if ,test #un", " 'quote) expr))))\n\n (let ((x (cadr form)))\n (qq 1 x))))\n\n(define-macro l",
"defined (,the-begin ,@body))))) (define-macro case (lambda (form env) (let ((key", "et*\n (lambda (form env)\n (let ((bindings (car (cdr form)))\n (body ",
" (car (cdr form))) (clauses (cdr (cdr form)))) (let ((the-key (make-identifier '", " (cdr (cdr form))))\n (if (null? bindings)\n `(,(the 'let) () ,@bo",
"key here))) `(,(the 'let) ((,the-key ,key)) ,(let loop ((clauses clauses)) (if (", "dy)\n `(,(the 'let) ((,(car (car bindings)) ,@(cdr (car bindings))))\n ",
"null? clauses) #undefined (let ((clause (car clauses))) `(,the-if ,(if (and (ide", " (,(the 'let*) (,@(cdr bindings))\n ,@body))))))\n\n(define-mac",
"ntifier? (car clause)) (identifier=? (the 'else) (make-identifier (car clause) e", "ro letrec\n (lambda (form env)\n `(,(the 'letrec*) ,@(cdr form))))\n\n(define-ma",
"nv))) #t `(,(the 'or) ,@(map (lambda (x) `(,(the 'eqv?) ,the-key (,the-quote ,x)", "cro letrec*\n (lambda (form env)\n (let ((bindings (car (cdr form)))\n ",
")) (car clause)))) ,(if (and (identifier? (cadr clause)) (identifier=? (the '=>)", " (body (cdr (cdr form))))\n (let ((variables (map (lambda (v) `(,v #f)) ",
" (make-identifier (cadr clause) env))) `(,(car (cdr (cdr clause))) ,the-key) `(,", "(map car bindings)))\n (initials (map (lambda (v) `(,(the 'set!) ,@v)",
"the-begin ,@(cdr clause))) ,(loop (cdr clauses))))))))))) (define-macro paramete", ") bindings)))\n `(,(the 'let) (,@variables)\n ,@initials\n ",
"rize (lambda (form env) (let ((formal (car (cdr form))) (body (cdr (cdr form))))", " ,@body)))))\n\n(define-macro let-values\n (lambda (form env)\n `(,(the 'let*-va",
" `(,(the 'with-dynamic-environment) (,(the 'list) ,@(map (lambda (x) `(,(the 'co", "lues) ,@(cdr form))))\n\n(define-macro let*-values\n (lambda (form env)\n (let (",
"ns) ,(car x) ,(cadr x))) formal)) (,the-lambda () ,@body))))) (define-macro synt", "(formal (car (cdr form)))\n (body (cdr (cdr form))))\n (if (null? ",
"ax-quote (lambda (form env) (let ((renames '())) (letrec ((rename (lambda (var) ", "formal)\n `(,(the 'let) () ,@body)\n `(,(the 'call-with-values) ",
"(let ((x (assq var renames))) (if x (cadr x) (begin (set! renames `((,var ,(make", "(,the-lambda () ,@(cdr (car formal)))\n (,(the 'lambda) (,@(car (car f",
"-identifier var env) (,(the 'make-identifier) ',var ',env)) unquote renames)) (r", "ormal)))\n (,(the 'let*-values) (,@(cdr formal))\n ,@body",
"ename var)))))) (walk (lambda (f form) (cond ((identifier? form) (f form)) ((pai", ")))))))\n\n(define-macro define-values\n (lambda (form env)\n (let ((formal (car",
"r? form) `(,(the 'cons) (walk f (car form)) (walk f (cdr form)))) ((vector? form", " (cdr form)))\n (body (cdr (cdr form))))\n (let ((arguments (make-",
") `(,(the 'list->vector) (walk f (vector->list form)))) (else `(,(the 'quote) ,f", "identifier 'arguments here)))\n `(,the-begin\n ,@(let loop ((forma",
"orm)))))) (let ((form (walk rename (cadr form)))) `(,(the 'let) ,(map cdr rename", "l formal))\n (if (pair? formal)\n `((,the-define ,(c",
"s) ,form)))))) (define-macro syntax-quasiquote (lambda (form env) (let ((renames", "ar formal) #undefined) ,@(loop (cdr formal)))\n (if (identifier?",
" '())) (letrec ((rename (lambda (var) (let ((x (assq var renames))) (if x (cadr ", " formal)\n `((,the-define ,formal #undefined))\n ",
"x) (begin (set! renames `((,var ,(make-identifier var env) (,(the 'make-identifi", " '())))\n (,(the 'call-with-values) (,the-lambda () ,@body)\n ",
"er) ',var ',env)) unquote renames)) (rename var))))))) (define (syntax-quasiquot", " (,the-lambda\n ,arguments\n ,@(let loop ((formal form",
"e? form) (and (pair? form) (identifier? (car form)) (identifier=? (the 'syntax-q", "al) (args arguments))\n (if (pair? formal)\n `((",
"uasiquote) (make-identifier (car form) env)))) (define (syntax-unquote? form) (a", ",the-set! ,(car formal) (,(the 'car) ,args)) ,@(loop (cdr formal) `(,(the 'cdr) ",
"nd (pair? form) (identifier? (car form)) (identifier=? (the 'syntax-unquote) (ma", ",args)))\n (if (identifier? formal)\n `(",
"ke-identifier (car form) env)))) (define (syntax-unquote-splicing? form) (and (p", "(,the-set! ,formal ,args))\n '()))))))))))\n\n(define-macro ",
"air? form) (pair? (car form)) (identifier? (caar form)) (identifier=? (the 'synt", "do\n (lambda (form env)\n (let ((bindings (car (cdr form)))\n (test ",
"ax-unquote-splicing) (make-identifier (caar form) env)))) (define (qq depth expr", " (car (car (cdr (cdr form)))))\n (cleanup (cdr (car (cdr (cdr form))))",
") (cond ((syntax-unquote? expr) (if (= depth 1) (car (cdr expr)) (list (the 'lis", ")\n (body (cdr (cdr (cdr form)))))\n (let ((loop (make-identifie",
"t) (list (the 'quote) (the 'syntax-unquote)) (qq (- depth 1) (car (cdr expr)))))", "r 'loop here)))\n `(,(the 'let) ,loop ,(map (lambda (x) `(,(car x) ,(cadr ",
") ((syntax-unquote-splicing? expr) (if (= depth 1) (list (the 'append) (car (cdr", "x))) bindings)\n (,the-if ,test\n (,the-begin\n ",
" (car expr))) (qq depth (cdr expr))) (list (the 'cons) (list (the 'list) (list (", " ,@cleanup)\n (,the-begin\n ,@body\n",
"the 'quote) (the 'syntax-unquote-splicing)) (qq (- depth 1) (car (cdr (car expr)", " (,loop ,@(map (lambda (x) (if (null? (cdr (cdr x))) (car x) ",
")))) (qq depth (cdr expr))))) ((syntax-quasiquote? expr) (list (the 'list) (list", "(car (cdr (cdr x))))) bindings)))))))))\n\n(define-macro when\n (lambda (form env)",
" (the 'quote) (the 'quasiquote)) (qq (+ depth 1) (car (cdr expr))))) ((pair? exp", "\n (let ((test (car (cdr form)))\n (body (cdr (cdr form))))\n `(,t",
"r) (list (the 'cons) (qq depth (car expr)) (qq depth (cdr expr)))) ((vector? exp", "he-if ,test\n (,the-begin ,@body)\n #undefined))))\n\n",
"r) (list (the 'list->vector) (qq depth (vector->list expr)))) ((identifier? expr", "(define-macro unless\n (lambda (form env)\n (let ((test (car (cdr form)))\n ",
") (rename expr)) (else (list (the 'quote) expr)))) (let ((body (qq 1 (cadr form)", " (body (cdr (cdr form))))\n `(,the-if ,test\n #undefined\n",
"))) `(,(the 'let) ,(map cdr renames) ,body)))))) (define (transformer f) (lambda", " (,the-begin ,@body)))))\n\n(define-macro case\n (lambda (form env)",
" (form env) (let ((ephemeron1 (make-ephemeron-table)) (ephemeron2 (make-ephemero", "\n (let ((key (car (cdr form)))\n (clauses (cdr (cdr form))))\n ",
"n-table))) (letrec ((wrap (lambda (var1) (let ((var2 (ephemeron1 var1))) (if var", " (let ((the-key (make-identifier 'key here)))\n `(,(the 'let) ((,the-key ",
"2 (cdr var2) (let ((var2 (make-identifier var1 env))) (ephemeron1 var1 var2) (ep", ",key))\n ,(let loop ((clauses clauses))\n (if (null? clauses)",
"hemeron2 var2 var1) var2))))) (unwrap (lambda (var2) (let ((var1 (ephemeron2 var", "\n #undefined\n (let ((clause (car clauses)))\n ",
"2))) (if var1 (cdr var1) var2)))) (walk (lambda (f form) (cond ((identifier? for", " `(,the-if ,(if (and (identifier? (car clause))\n ",
"m) (f form)) ((pair? form) (cons (walk f (car form)) (walk f (cdr form)))) ((vec", " (identifier=? (the 'else) (make-identifier (car clause) env",
"tor? form) (list->vector (walk f (vector->list form)))) (else form))))) (let ((f", ")))\n #t\n `(,(t",
"orm (cdr form))) (walk unwrap (apply f (walk wrap form)))))))) (define-macro def", "he 'or) ,@(map (lambda (x) `(,(the 'eqv?) ,the-key (,the-quote ,x))) (car clause",
"ine-syntax (lambda (form env) (let ((formal (car (cdr form))) (body (cdr (cdr fo", "))))\n ,(if (and (identifier? (cadr clause))\n ",
"rm)))) (if (pair? formal) `(,(the 'define-syntax) ,(car formal) (,the-lambda ,(c", " (identifier=? (the '=>) (make-identifier (cadr cl",
"dr formal) ,@body)) `(,the-define-macro ,formal (,(the 'transformer) (,the-begin", "ause) env)))\n `(,(car (cdr (cdr clause))) ,the-",
" ,@body))))))) (define-macro letrec-syntax (lambda (form env) (let ((formal (car", "key)\n `(,the-begin ,@(cdr clause)))\n ",
" (cdr form))) (body (cdr (cdr form)))) `(let () ,@(map (lambda (x) `(,(the 'defi", " ,(loop (cdr clauses)))))))))))\n\n(define-macro parameterize\n (",
"ne-syntax) ,(car x) ,(cadr x))) formal) ,@body)))) (define-macro let-syntax (lam", "lambda (form env)\n (let ((formal (car (cdr form)))\n (body (cdr (cd",
"bda (form env) `(,(the 'letrec-syntax) ,@(cdr form)))) (define (mangle name) (wh", "r form))))\n `(,(the 'with-dynamic-environment)\n (,(the 'list) ,@(map",
"en (null? name) (error \"library name should be a list of at least one symbols\" n", " (lambda (x) `(,(the 'cons) ,(car x) ,(cadr x))) formal))\n (,the-lambda (",
"ame)) (define (->string n) (cond ((symbol? n) (let ((str (symbol->string n))) (s", ") ,@body)))))\n\n(define-macro syntax-quote\n (lambda (form env)\n (let ((rename",
"tring-for-each (lambda (c) (when (or (char=? c #\\.) (char=? c #\\:)) (error \"elem", "s '()))\n (letrec\n ((rename (lambda (var)\n (let",
"ents of library name may not contain '.' or ':'\" n))) str) str)) ((and (number? ", " ((x (assq var renames)))\n (if x\n ",
"n) (exact? n) (<= 0 n)) (number->string n)) (else (error \"symbol or non-negative", " (cadr x)\n (begin\n (set! ",
" integer is required\" n)))) (define (join strs delim) (let loop ((res (car strs)", "renames `((,var ,(make-identifier var env) (,(the 'make-identifier) ',var ',env)",
") (strs (cdr strs))) (if (null? strs) res (loop (string-append res delim (car st", ") . ,renames))\n (rename var))))))\n (walk (",
"rs)) (cdr strs))))) (if (symbol? name) name (string->symbol (join (map ->string ", "lambda (f form)\n (cond\n ((identifier? form)",
"name) \".\")))) (define current-library (make-parameter '(picrin base) mangle)) (d", "\n (f form))\n ((pair? form)\n ",
"efine *libraries* (make-dictionary)) (define (find-library name) (dictionary-has", " `(,(the 'cons) (walk f (car form)) (walk f (cdr form))))\n ",
"? *libraries* (mangle name))) (define (make-library name) (let ((name (mangle na", " ((vector? form)\n `(,(the 'list->vector) (walk f (vector-",
"me))) (let ((env (make-environment (string->symbol (string-append (symbol->strin", ">list form))))\n (else\n `(,(the 'quote) ,f",
"g name) \":\")))) (exports (make-dictionary))) (set-identifier! 'define-library 'd", "orm))))))\n (let ((form (walk rename (cadr form))))\n `(,(the 'let",
"efine-library env) (set-identifier! 'import 'import env) (set-identifier! 'expor", ")\n ,(map cdr renames)\n ,form))))))\n\n(define-macro syntax-q",
"t 'export env) (set-identifier! 'cond-expand 'cond-expand env) (dictionary-set! ", "uasiquote\n (lambda (form env)\n (let ((renames '()))\n (letrec\n ",
"*libraries* name `(,env unquote exports))))) (define (library-environment name) ", "((rename (lambda (var)\n (let ((x (assq var renames)))\n ",
"(car (dictionary-ref *libraries* (mangle name)))) (define (library-exports name)", " (if x\n (cadr x)\n ",
" (cdr (dictionary-ref *libraries* (mangle name)))) (define (library-import name ", " (begin\n (set! renames `((,var ,(make-identifie",
"sym alias) (let ((uid (dictionary-ref (library-exports name) sym))) (let ((env (", "r var env) (,(the 'make-identifier) ',var ',env)) . ,renames))\n ",
"library-environment (current-library)))) (set-identifier! alias uid env)))) (def", " (rename var)))))))\n\n (define (syntax-quasiquote? form)\n ",
"ine (library-export sym alias) (let ((env (library-environment (current-library)", " (and (pair? form)\n (identifier? (car form))\n (id",
")) (exports (library-exports (current-library)))) (dictionary-set! exports alias", "entifier=? (the 'syntax-quasiquote) (make-identifier (car form) env))))\n\n ",
" (find-identifier sym env)))) (define-macro define-library (lambda (form _) (let", " (define (syntax-unquote? form)\n (and (pair? form)\n (iden",
" ((name (cadr form)) (body (cddr form))) (or (find-library name) (make-library n", "tifier? (car form))\n (identifier=? (the 'syntax-unquote) (make-ide",
"ame)) (parameterize ((current-library name)) (for-each (lambda (expr) (eval expr", "ntifier (car form) env))))\n\n (define (syntax-unquote-splicing? form)\n ",
" name)) body))))) (define-macro cond-expand (lambda (form _) (letrec ((test (lam", " (and (pair? form)\n (pair? (car form))\n (identi",
"bda (form) (or (eq? form 'else) (and (symbol? form) (memq form (features))) (and", "fier? (caar form))\n (identifier=? (the 'syntax-unquote-splicing) (",
" (pair? form) (case (car form) ((library) (find-library (cadr form))) ((not) (no", "make-identifier (caar form) env))))\n\n (define (qq depth expr)\n (",
"t (test (cadr form)))) ((and) (let loop ((form (cdr form))) (or (null? form) (an", "cond\n ;; syntax-unquote\n ((syntax-unquote? expr)\n ",
"d (test (car form)) (loop (cdr form)))))) ((or) (let loop ((form (cdr form))) (a", " (if (= depth 1)\n (car (cdr expr))\n (list (the 'li",
"nd (pair? form) (or (test (car form)) (loop (cdr form)))))) (else #f))))))) (let", "st)\n (list (the 'quote) (the 'syntax-unquote))\n ",
" loop ((clauses (cdr form))) (if (null? clauses) #undefined (if (test (caar clau", " (qq (- depth 1) (car (cdr expr))))))\n ;; syntax-unquote-spli",
"ses)) `(,the-begin ,@(cdar clauses)) (loop (cdr clauses)))))))) (define-macro im", "cing\n ((syntax-unquote-splicing? expr)\n (if (= depth 1)\n ",
"port (lambda (form _) (let ((caddr (lambda (x) (car (cdr (cdr x))))) (prefix (la", " (list (the 'append)\n (car (cdr (car expr)))\n ",
"mbda (prefix symbol) (string->symbol (string-append (symbol->string prefix) (sym", " (qq depth (cdr expr)))\n (list (the 'cons)\n ",
"bol->string symbol))))) (getlib (lambda (name) (if (find-library name) name (err", " (list (the 'list)\n (list (the 'quo",
"or \"library not found\" name))))) (letrec ((extract (lambda (spec) (case (car spe", "te) (the 'syntax-unquote-splicing))\n (qq (- depth 1) ",
"c) ((only rename prefix except) (extract (cadr spec))) (else (getlib spec))))) (", "(car (cdr (car expr)))))\n (qq depth (cdr expr)))))\n ",
"collect (lambda (spec) (case (car spec) ((only) (let ((alist (collect (cadr spec", " ;; syntax-quasiquote\n ((syntax-quasiquote? expr)\n (list ",
")))) (map (lambda (var) (assq var alist)) (cddr spec)))) ((rename) (let ((alist ", "(the 'list)\n (list (the 'quote) (the 'quasiquote))\n ",
"(collect (cadr spec))) (renames (map (lambda (x) `(,(car x) unquote (cadr x))) (", " (qq (+ depth 1) (car (cdr expr)))))\n ;; list\n ((pair? ",
"cddr spec)))) (map (lambda (s) (or (assq (car s) renames) s)) alist))) ((prefix)", "expr)\n (list (the 'cons)\n (qq depth (car expr))\n ",
" (let ((alist (collect (cadr spec)))) (map (lambda (s) (cons (prefix (caddr spec", " (qq depth (cdr expr))))\n ;; vector\n ((vector? ",
") (car s)) (cdr s))) alist))) ((except) (let ((alist (collect (cadr spec)))) (le", "expr)\n (list (the 'list->vector) (qq depth (vector->list expr))))\n ",
"t loop ((alist alist)) (if (null? alist) '() (if (memq (caar alist) (cddr spec))", " ;; identifier\n ((identifier? expr)\n (rename expr))\n",
" (loop (cdr alist)) (cons (car alist) (loop (cdr alist)))))))) (else (dictionary", " ;; simple datum\n (else\n (list (the 'quote) expr)",
"-map (lambda (x) (cons x x)) (library-exports (getlib spec)))))))) (letrec ((imp", ")))\n\n (let ((body (qq 1 (cadr form))))\n `(,(the 'let)\n ",
"ort (lambda (spec) (let ((lib (extract spec)) (alist (collect spec))) (for-each ", " ,(map cdr renames)\n ,body))))))\n\n(define (transformer f)\n (lambda ",
"(lambda (slot) (library-import lib (cdr slot) (car slot))) alist))))) (for-each ", "(form env)\n (let ((ephemeron1 (make-ephemeron-table))\n (ephemeron2 (",
"import (cdr form))))))) (define-macro export (lambda (form _) (letrec ((collect ", "make-ephemeron-table)))\n (letrec\n ((wrap (lambda (var1)\n ",
"(lambda (spec) (cond ((symbol? spec) `(,spec unquote spec)) ((and (list? spec) (", " (let ((var2 (ephemeron1 var1)))\n (if var2\n ",
"= (length spec) 3) (eq? (car spec) 'rename)) `(,(list-ref spec 1) unquote (list-", " (cdr var2)\n (let ((var2 (make-identifier",
"ref spec 2))) (else (error \"malformed export\"))))) (export (lambda (spec) (let (", " var1 env)))\n (ephemeron1 var1 var2)\n ",
"(slot (collect spec))) (library-export (car slot) (cdr slot)))))) (for-each expo", " (ephemeron2 var2 var1)\n var2)))))\n ",
"rt (cdr form))))) (let () (make-library '(picrin base)) (set-car! (dictionary-re", " (unwrap (lambda (var2)\n (let ((var1 (ephemeron2 var2)))\n ",
"f *libraries* (mangle '(picrin base))) default-environment) (let ((export-keywor", " (if var1\n (cdr var1)\n ",
"ds (lambda (keywords) (let ((env (library-environment '(picrin base))) (exports ", " var2))))\n (walk (lambda (f form)\n (con",
"(library-exports '(picrin base)))) (for-each (lambda (keyword) (dictionary-set! ", "d\n ((identifier? form)\n (f form))\n ",
"exports keyword keyword)) keywords))))) (export-keywords '(define lambda quote s", " ((pair? form)\n (cons (walk f (car form)) (walk ",
"et! if begin define-macro let let* letrec letrec* let-values let*-values define-", "f (cdr form))))\n ((vector? form)\n (list->",
"values quasiquote unquote unquote-splicing and or cond case else => do when unle", "vector (walk f (vector->list form))))\n (else\n ",
"ss parameterize define-syntax syntax-quote syntax-unquote syntax-quasiquote synt", " form)))))\n (let ((form (cdr form)))\n (walk unwrap (apply f ",
"ax-unquote-splicing let-syntax letrec-syntax syntax-error)) (export-keywords '(f", "(walk wrap form))))))))\n\n(define-macro define-syntax\n (lambda (form env)\n (l",
"eatures eq? eqv? equal? not boolean? boolean=? pair? cons car cdr null? set-car!", "et ((formal (car (cdr form)))\n (body (cdr (cdr form))))\n (if (pa",
" set-cdr! caar cadr cdar cddr list? make-list list length append reverse list-ta", "ir? formal)\n `(,(the 'define-syntax) ,(car formal) (,the-lambda ,(cdr f",
"il list-ref list-set! list-copy map for-each memq memv member assq assv assoc cu", "ormal) ,@body))\n `(,the-define-macro ,formal (,(the 'transformer) (,the",
"rrent-input-port current-output-port current-error-port port? input-port? output", "-begin ,@body)))))))\n\n(define-macro letrec-syntax\n (lambda (form env)\n (let ",
"-port? port-open? close-port eof-object? eof-object read-u8 peek-u8 read-bytevec", "((formal (car (cdr form)))\n (body (cdr (cdr form))))\n `(let ()\n ",
"tor! write-u8 write-bytevector flush-output-port open-input-bytevector open-outp", " ,@(map (lambda (x)\n `(,(the 'define-syntax) ,(car x) ,(",
"ut-bytevector get-output-bytevector number? exact? inexact? inexact exact = < > ", "cadr x)))\n formal)\n ,@body))))\n\n(define-macro let-syntax\n",
"<= >= + - * / number->string string->number procedure? apply symbol? symbol=? sy", " (lambda (form env)\n `(,(the 'letrec-syntax) ,@(cdr form))))\n;;; There are t",
"mbol->string string->symbol make-identifier identifier? identifier=? identifier-", "wo ways to name a library: (foo bar) or foo.bar\n;;; The former is normalized to ",
"base identifier-environment vector? vector make-vector vector-length vector-ref ", "the latter.\n\n(define (mangle name)\n (when (null? name)\n (error \"library name",
"vector-set! vector-copy! vector-copy vector-append vector-fill! vector-map vecto", " should be a list of at least one symbols\" name))\n\n (define (->string n)\n (c",
"r-for-each list->vector vector->list string->vector vector->string bytevector? b", "ond\n ((symbol? n)\n (let ((str (symbol->string n)))\n (string-for-",
"ytevector make-bytevector bytevector-length bytevector-u8-ref bytevector-u8-set!", "each\n (lambda (c)\n (when (or (char=? c #\\.) (char=? c #\\:))\n ",
" bytevector-copy! bytevector-copy bytevector-append bytevector->list list->bytev", " (error \"elements of library name may not contain '.' or ':'\" n)))\n ",
"ector call-with-current-continuation call/cc values call-with-values char? char-", " str)\n str))\n ((and (number? n) (exact? n) (<= 0 n))\n (numb",
">integer integer->char char=? char<? char>? char<=? char>=? current-exception-ha", "er->string n))\n (else\n (error \"symbol or non-negative integer is requir",
"ndlers with-exception-handler raise raise-continuable error error-object? error-", "ed\" n))))\n\n (define (join strs delim)\n (let loop ((res (car strs)) (strs (cd",
"object-message error-object-irritants error-object-type string? string make-stri", "r strs)))\n (if (null? strs)\n res\n (loop (string-append re",
"ng string-length string-ref string-set! string-copy string-copy! string-fill! st", "s delim (car strs)) (cdr strs)))))\n\n (if (symbol? name)\n name ",
"ring-append string-map string-for-each list->string string->list string=? string", " ; TODO: check symbol names\n (string->symbol (join (map ->s",
"<? string>? string<=? string>=? make-parameter with-dynamic-environment read mak", "tring name) \".\"))))\n\n(define current-library\n (make-parameter '(picrin base) ma",
"e-dictionary dictionary? dictionary dictionary-has? dictionary-ref dictionary-se", "ngle))\n\n(define *libraries*\n (make-dictionary))\n\n(define (find-library name)\n ",
"t! dictionary-delete! dictionary-size dictionary-map dictionary-for-each diction", "(dictionary-has? *libraries* (mangle name)))\n\n(define (make-library name)\n (let",
"ary->alist alist->dictionary dictionary->plist plist->dictionary make-record rec", " ((name (mangle name)))\n (let ((env (make-environment\n (strin",
"ord? record-type record-datum default-environment make-environment find-identifi", "g->symbol (string-append (symbol->string name) \":\"))))\n (exports (make-",
"er set-identifier! eval make-ephemeron-table write write-simple write-shared dis", "dictionary)))\n ;; set up initial environment\n (set-identifier! 'define",
"play)) (export-keywords '(find-library make-library current-library))) (set! eva", "-library 'define-library env)\n (set-identifier! 'import 'import env)\n ",
"l (let ((e eval)) (lambda (expr . lib) (let ((lib (if (null? lib) (current-libra", "(set-identifier! 'export 'export env)\n (set-identifier! 'cond-expand 'cond-",
"ry) (car lib)))) (e expr (library-environment lib)))))) (make-library '(picrin u", "expand env)\n (dictionary-set! *libraries* name `(,env . ,exports)))))\n\n(def",
"ser)) (current-library '(picrin user))) ", "ine (library-environment name)\n (car (dictionary-ref *libraries* (mangle name))",
"))\n\n(define (library-exports name)\n (cdr (dictionary-ref *libraries* (mangle na",
"me))))\n\n(define (library-import name sym alias)\n (let ((uid (dictionary-ref (li",
"brary-exports name) sym)))\n (let ((env (library-environment (current-library)",
")))\n (set-identifier! alias uid env))))\n\n(define (library-export sym alias)",
"\n (let ((env (library-environment (current-library)))\n (exports (library",
"-exports (current-library))))\n (dictionary-set! exports alias (find-identifie",
"r sym env))))\n\n\n\n;;; R7RS library syntax\n\n(define-macro define-library\n (lambda",
" (form _)\n (let ((name (cadr form))\n (body (cddr form)))\n (or (",
"find-library name) (make-library name))\n (parameterize ((current-library na",
"me))\n (for-each\n (lambda (expr)\n (eval expr name)) ",
" ; TODO parse library declarations\n body)))))\n\n(define-macro cond-expan",
"d\n (lambda (form _)\n (letrec\n ((test (lambda (form)\n ",
"(or\n (eq? form 'else)\n (and (symbol? form)\n ",
" (memq form (features)))\n (and (pair? form)\n",
" (case (car form)\n ((library) (fin",
"d-library (cadr form)))\n ((not) (not (test (cadr form)))",
")\n ((and) (let loop ((form (cdr form)))\n ",
" (or (null? form)\n (and (t",
"est (car form)) (loop (cdr form))))))\n ((or) (let loop (",
"(form (cdr form)))\n (and (pair? form)\n ",
" (or (test (car form)) (loop (cdr form))))))\n ",
" (else #f)))))))\n (let loop ((clauses (cdr form)))\n ",
"(if (null? clauses)\n #undefined\n (if (test (caar clauses))",
"\n `(,the-begin ,@(cdar clauses))\n (loop (cdr claus",
"es))))))))\n\n(define-macro import\n (lambda (form _)\n (let ((caddr\n ",
"(lambda (x) (car (cdr (cdr x)))))\n (prefix\n (lambda (prefix s",
"ymbol)\n (string->symbol\n (string-append\n ",
"(symbol->string prefix)\n (symbol->string symbol)))))\n (ge",
"tlib\n (lambda (name)\n (if (find-library name)\n ",
" name\n (error \"library not found\" name)))))\n (letrec\n ",
" ((extract\n (lambda (spec)\n (case (car spec)\n ",
" ((only rename prefix except)\n (extract (cadr spec)))",
"\n (else\n (getlib spec)))))\n (collect\n ",
" (lambda (spec)\n (case (car spec)\n ((only)\n",
" (let ((alist (collect (cadr spec))))\n (map (l",
"ambda (var) (assq var alist)) (cddr spec))))\n ((rename)\n ",
" (let ((alist (collect (cadr spec)))\n (renames (map",
" (lambda (x) `(,(car x) . ,(cadr x))) (cddr spec))))\n (map (la",
"mbda (s) (or (assq (car s) renames) s)) alist)))\n ((prefix)\n ",
" (let ((alist (collect (cadr spec))))\n (map (lambda",
" (s) (cons (prefix (caddr spec) (car s)) (cdr s))) alist)))\n ((ex",
"cept)\n (let ((alist (collect (cadr spec))))\n (",
"let loop ((alist alist))\n (if (null? alist)\n ",
" '()\n (if (memq (caar alist) (cddr spec))\n ",
" (loop (cdr alist))\n (cons (ca",
"r alist) (loop (cdr alist))))))))\n (else\n (dictio",
"nary-map (lambda (x) (cons x x))\n (library-expor",
"ts (getlib spec))))))))\n (letrec\n ((import\n (lam",
"bda (spec)\n (let ((lib (extract spec))\n (a",
"list (collect spec)))\n (for-each\n (lambda (",
"slot)\n (library-import lib (cdr slot) (car slot)))\n ",
" alist)))))\n (for-each import (cdr form)))))))\n\n(define-macr",
"o export\n (lambda (form _)\n (letrec\n ((collect\n (lambda (spe",
"c)\n (cond\n ((symbol? spec)\n `(,spec . ,spec)",
")\n ((and (list? spec) (= (length spec) 3) (eq? (car spec) 'rename))\n",
" `(,(list-ref spec 1) . ,(list-ref spec 2)))\n (else\n ",
" (error \"malformed export\")))))\n (export\n (lambda (s",
"pec)\n (let ((slot (collect spec)))\n (library-export (c",
"ar slot) (cdr slot))))))\n (for-each export (cdr form)))))\n\n\n;;; bootstrap..",
".\n(let ()\n (make-library '(picrin base))\n (set-car! (dictionary-ref *libraries",
"* (mangle '(picrin base))) default-environment)\n (let ((export-keywords\n ",
" (lambda (keywords)\n (let ((env (library-environment '(picrin base)))",
"\n (exports (library-exports '(picrin base))))\n (for-",
"each\n (lambda (keyword)\n (dictionary-set! exports ke",
"yword keyword))\n keywords)))))\n (export-keywords\n '(define l",
"ambda quote set! if begin define-macro\n let let* letrec letrec*\n l",
"et-values let*-values define-values\n quasiquote unquote unquote-splicing\n",
" and or\n cond case else =>\n do when unless\n paramete",
"rize\n define-syntax\n syntax-quote syntax-unquote\n syntax-qu",
"asiquote syntax-unquote-splicing\n let-syntax letrec-syntax\n syntax",
"-error))\n (export-keywords\n '(features\n eq? eqv? equal? not boolean",
"? boolean=?\n pair? cons car cdr null? set-car! set-cdr!\n caar cadr c",
"dar cddr\n list? make-list list length append reverse\n list-tail list",
"-ref list-set! list-copy\n map for-each memq memv member assq assv assoc\n ",
" current-input-port current-output-port current-error-port\n port? inpu",
"t-port? output-port? port-open? close-port\n eof-object? eof-object\n ",
"read-u8 peek-u8 read-bytevector!\n write-u8 write-bytevector flush-output-p",
"ort\n open-input-bytevector open-output-bytevector get-output-bytevector\n ",
" number? exact? inexact? inexact exact\n = < > <= >= + - * /\n num",
"ber->string string->number\n procedure? apply\n symbol? symbol=? symbo",
"l->string string->symbol\n make-identifier identifier? identifier=? identif",
"ier-base identifier-environment\n vector? vector make-vector vector-length ",
"vector-ref vector-set!\n vector-copy! vector-copy vector-append vector-fill",
"! vector-map vector-for-each\n list->vector vector->list string->vector vec",
"tor->string\n bytevector? bytevector make-bytevector\n bytevector-leng",
"th bytevector-u8-ref bytevector-u8-set!\n bytevector-copy! bytevector-copy ",
"bytevector-append\n bytevector->list list->bytevector\n call-with-curr",
"ent-continuation call/cc values call-with-values\n char? char->integer inte",
"ger->char char=? char<? char>? char<=? char>=?\n current-exception-handlers",
" with-exception-handler\n raise raise-continuable error\n error-object",
"? error-object-message error-object-irritants\n error-object-type\n st",
"ring? string make-string string-length string-ref string-set!\n string-copy",
" string-copy! string-fill! string-append\n string-map string-for-each list-",
">string string->list\n string=? string<? string>? string<=? string>=?\n ",
" make-parameter with-dynamic-environment\n read\n make-dictionary dic",
"tionary? dictionary dictionary-has?\n dictionary-ref dictionary-set! dictio",
"nary-delete! dictionary-size\n dictionary-map dictionary-for-each\n di",
"ctionary->alist alist->dictionary dictionary->plist plist->dictionary\n mak",
"e-record record? record-type record-datum\n default-environment make-enviro",
"nment find-identifier set-identifier!\n eval\n make-ephemeron-table\n ",
" write write-simple write-shared display))\n (export-keywords\n '(find-",
"library make-library current-library)))\n (set! eval\n (let ((e eval))\n ",
" (lambda (expr . lib)\n (let ((lib (if (null? lib) (current-libr",
"ary) (car lib))))\n (e expr (library-environment lib))))))\n (make-l",
"ibrary '(picrin user))\n (current-library '(picrin user)))\n\n",
}; };
void void

43
tools/mkboot.pl Normal file
View File

@ -0,0 +1,43 @@
#!/usr/bin/perl
use strict;
# The maximum length of a string literal is 509 characters in C89.
# That is why the boot_rom is split into short strings.
my $chunk = 80;
sub print_escape_char($) {
my $c = shift;
if ($c eq "\n") {
print "\\", "n";
} elsif (($c eq "\\") || ($c eq '"')) {
print "\\", $c;
} else {
print $c;
}
}
print <<EOL;
#include "picrin.h"
#include "picrin/extra.h"
static const char boot_rom[][$chunk] = {
EOL
print "\"";
my $len = 0;
while (read(STDIN, my $c, 1)) {
if ($len && ($len % $chunk == 0)) { print "\",\n\""; }
print_escape_char($c);
$len++;
}
if ($!) { die "read error"; }
print <<EOL;
",
};
void
pic_boot(pic_state *pic)
{
pic_load_cstr(pic, &boot_rom[0][0]);
}
EOL

68
tools/mkboot.scm
View File

@ -1,68 +0,0 @@
(import (scheme base)
(scheme read)
(scheme write))
(define (with-output-to-string thunk)
(let ((port (open-output-string)))
(parameterize ((current-output-port port))
(thunk)
(let ((s (get-output-string port)))
(close-port port)
s))))
(define exprs
(let loop ((acc '()))
(let ((e (read)))
(if (eof-object? e)
(reverse acc)
(loop (cons e acc))))))
(define text
(with-output-to-string
(lambda ()
(for-each
(lambda (e)
(write e)
(write-string " "))
exprs))))
(define (escape-string s)
(with-output-to-string
(lambda ()
(string-for-each
(lambda (c)
(case c
((#\\) (write-string "\\\\"))
((#\") (write-string "\\\""))
((#\newline) (write-string "\\n"))
(else (write-char c))))
s))))
(define (group-string i s)
(let loop ((t s) (n (string-length s)) (acc '()))
(if (= n 0)
(reverse acc)
(if (< n i)
(loop "" 0 (cons t acc))
(loop (string-copy t i) (- n i) (cons (string-copy t 0 i) acc))))))
(define lines (map escape-string (group-string 80 text)))
(for-each
(lambda (s) (display s) (newline))
`("#include \"picrin.h\""
"#include \"picrin/extra.h\""
""
"static const char boot_rom[][80] = {"
,@(let loop ((lines lines) (acc '()))
(if (null? lines)
(reverse acc)
(loop (cdr lines) (cons (string-append "\"" (car lines) "\",") acc))))
"};"
""
"void"
"pic_boot(pic_state *pic)"
"{"
" pic_load_cstr(pic, &boot_rom[0][0]);"
"}"))