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

Compare commits

base: conservatory:master
Branches Tags
conservatory:master
conservatory:nyuichi
conservatory:v0.2
conservatory:v0.1
..
compare: conservatory:v0.2
Branches Tags
conservatory:master
conservatory:nyuichi
conservatory:v0.2
conservatory:v0.1

No commits in common. "master" and "v0.2" have entirely different histories.
master ... v0.2

6 changed files with 325 additions and 407 deletions
Show Stats 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 | perl tools/mkboot.pl > lib/ext/boot.c cat piclib/boot.scm piclib/library.scm | bin/picrin-bootstrap tools/mkboot.scm > 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

2
README.md
View File

@ -1,7 +1,5 @@
<img width="500" src="https://raw.githubusercontent.com/picrin-scheme/picrin/master/etc/picrin-logo-fin01-02.png"></img> <img width="500" src="https://raw.githubusercontent.com/picrin-scheme/picrin/master/etc/picrin-logo-fin01-02.png"></img>
# The project is in hiatus and being archived soon...
[![Build Status](https://travis-ci.org/picrin-scheme/picrin.png?branch=master)](https://travis-ci.org/picrin-scheme/picrin) [![Build Status](https://travis-ci.org/picrin-scheme/picrin.png?branch=master)](https://travis-ci.org/picrin-scheme/picrin)
[![Docs Status](https://readthedocs.org/projects/picrin/badge/?version=latest)](https://picrin.readthedocs.org/) [![Docs Status](https://readthedocs.org/projects/picrin/badge/?version=latest)](https://picrin.readthedocs.org/)

BIN
bin/picrin-bootstrap Executable file
View File

Binary file not shown.

617
lib/ext/boot.c
View File

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

@ -1,43 +0,0 @@
#!/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 Normal file
View File

@ -0,0 +1,68 @@
(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]);"
"}"))