From 311abc4d5f6dfdee6c630740402df8e10ac6728a Mon Sep 17 00:00:00 2001 From: Lassi Kortela Date: Fri, 1 Mar 2024 13:45:05 +0200 Subject: [PATCH] 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. --- Makefile | 2 +- lib/ext/boot.c | 617 +++++++++++++++++++++++++++-------------------- tools/mkboot.pl | 43 ++++ tools/mkboot.scm | 68 ------ 4 files changed, 405 insertions(+), 325 deletions(-) create mode 100644 tools/mkboot.pl delete mode 100644 tools/mkboot.scm diff --git a/Makefile b/Makefile index cb4c9d7b..aed49b8f 100644 --- a/Makefile +++ b/Makefile @@ -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 diff --git a/lib/ext/boot.c b/lib/ext/boot.c index c6a9a70e..6a9dd7e7 100644 --- a/lib/ext/boot.c +++ b/lib/ext/boot.c @@ -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>=? 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>=? 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>=?\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>=?\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 diff --git a/tools/mkboot.pl b/tools/mkboot.pl new file mode 100644 index 00000000..bb55db9a --- /dev/null +++ b/tools/mkboot.pl @@ -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 <