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

Compare commits

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

2 Commits
e273cba24d ... 311abc4d5f

Author SHA1 Message Date
Lassi Kortela 311abc4d5f 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.
 2024-03-01 21:08:12 +09:00
Masanori Ogino 16615615c9 Add status note 
Signed-off-by: Masanori Ogino <mogino@acm.org>
 2024-03-01 10:31:41 +09:00
6 changed files with 407 additions and 325 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)
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

2
README.md
View File

@ -1,5 +1,7 @@
<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)
[![Docs Status](https://readthedocs.org/projects/picrin/badge/?version=latest)](https://picrin.readthedocs.org/)

BIN
bin/picrin-bootstrap
View File

Binary file not shown.

617
lib/ext/boot.c
View File

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

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]);"
"}"))