picrin/lib/ext/boot.c

#include "picrin.h"
#include "picrin/extra.h"

static const char boot_rom[][80] = {
"(builtin:define-macro call-with-current-environment (builtin:lambda (form env) (",
"list (cadr form) env))) (builtin:define here (call-with-current-environment (bui",
"ltin:lambda (env) env))) (builtin:define the (builtin:lambda (var) (make-identif",
"ier var here))) (builtin:define the-builtin-define (the (builtin:quote builtin:d",
"efine))) (builtin:define the-builtin-lambda (the (builtin:quote builtin:lambda))",
") (builtin:define the-builtin-begin (the (builtin:quote builtin:begin))) (builti",
"n:define the-builtin-quote (the (builtin:quote builtin:quote))) (builtin:define ",
"the-builtin-set! (the (builtin:quote builtin:set!))) (builtin:define the-builtin",
"-if (the (builtin:quote builtin:if))) (builtin:define the-builtin-define-macro (",
"the (builtin:quote builtin:define-macro))) (builtin:define the-define (the (buil",
"tin:quote define))) (builtin:define the-lambda (the (builtin:quote lambda))) (bu",
"iltin:define the-begin (the (builtin:quote begin))) (builtin:define the-quote (t",
"he (builtin:quote quote))) (builtin:define the-set! (the (builtin:quote set!))) ",
"(builtin:define the-if (the (builtin:quote if))) (builtin:define the-define-macr",
"o (the (builtin:quote define-macro))) (builtin:define-macro quote (builtin:lambd",
"a (form env) (builtin:if (= (length form) 2) (list the-builtin-quote (cadr form)",
") (error \"illegal quote form\" form)))) (builtin:define-macro if (builtin:lambda ",
"(form env) ((builtin:lambda (len) (builtin:if (= len 4) (cons the-builtin-if (cd",
"r form)) (builtin:if (= len 3) (list the-builtin-if (list-ref form 1) (list-ref ",
"form 2) #undefined) (error \"illegal if form\" form)))) (length form)))) (builtin:",
"define-macro begin (builtin:lambda (form env) ((builtin:lambda (len) (if (= len ",
"1) #undefined (if (= len 2) (cadr form) (if (= len 3) (cons the-builtin-begin (c",
"dr form)) (list the-builtin-begin (cadr form) (cons the-begin (cddr form))))))) ",
"(length form)))) (builtin:define-macro set! (builtin:lambda (form env) (if (= (l",
"ength form) 3) (if (identifier? (cadr form)) (cons the-builtin-set! (cdr form)) ",
"(error \"illegal set! form\" form)) (error \"illegal set! form\" form)))) (builtin:d",
"efine check-formal (builtin:lambda (formal) (if (null? formal) #t (if (identifie",
"r? formal) #t (if (pair? formal) (if (identifier? (car formal)) (check-formal (c",
"dr formal)) #f) #f))))) (builtin:define-macro lambda (builtin:lambda (form env) ",
"(if (= (length form) 1) (error \"illegal lambda form\" form) (if (check-formal (ca",
"dr form)) (list the-builtin-lambda (cadr form) (cons the-begin (cddr form))) (er",
"ror \"illegal lambda form\" form))))) (builtin:define-macro define (lambda (form e",
"nv) ((lambda (len) (if (= len 1) (error \"illegal define form\" form) (if (identif",
"ier? (cadr form)) (if (= len 3) (cons the-builtin-define (cdr form)) (error \"ill",
"egal define form\" form)) (if (pair? (cadr form)) (list the-define (car (cadr for",
"m)) (cons the-lambda (cons (cdr (cadr form)) (cddr form)))) (error \"define: bind",
"ing to non-varaible object\" form))))) (length form)))) (builtin:define-macro def",
"ine-macro (lambda (form env) (if (= (length form) 3) (if (identifier? (cadr form",
")) (cons the-builtin-define-macro (cdr form)) (error \"define-macro: binding to n",
"on-variable object\" form)) (error \"illegal define-macro form\" form)))) (define-m",
"acro syntax-error (lambda (form _) (apply error (cdr form)))) (define-macro defi",
"ne-auxiliary-syntax (lambda (form _) (define message (string-append \"invalid use",
" of auxiliary syntax: '\" (symbol->string (cadr form)) \"'\")) (list the-define-mac",
"ro (cadr form) (list the-lambda '_ (list (the 'error) message))))) (define-auxil",
"iary-syntax else) (define-auxiliary-syntax =>) (define-auxiliary-syntax unquote)",
" (define-auxiliary-syntax unquote-splicing) (define-auxiliary-syntax syntax-unqu",
"ote) (define-auxiliary-syntax syntax-unquote-splicing) (define-macro let (lambda",
" (form env) (if (identifier? (cadr form)) (list (list the-lambda '() (list the-d",
"efine (cadr form) (cons the-lambda (cons (map car (car (cddr form))) (cdr (cddr ",
"form))))) (cons (cadr form) (map cadr (car (cddr form)))))) (cons (cons the-lamb",
"da (cons (map car (cadr form)) (cddr form))) (map cadr (cadr form)))))) (define-",
"macro and (lambda (form env) (if (null? (cdr form)) #t (if (null? (cddr form)) (",
"cadr form) (list the-if (cadr form) (cons (the 'and) (cddr form)) #f))))) (defin",
"e-macro or (lambda (form env) (if (null? (cdr form)) #f (let ((tmp (make-identif",
"ier 'it env))) (list (the 'let) (list (list tmp (cadr form))) (list the-if tmp t",
"mp (cons (the 'or) (cddr form)))))))) (define-macro cond (lambda (form env) (let",
" ((clauses (cdr form))) (if (null? clauses) #undefined (let ((clause (car clause",
"s))) (if (and (identifier? (car clause)) (identifier=? (the 'else) (make-identif",
"ier (car clause) env))) (cons the-begin (cdr clause)) (if (null? (cdr clause)) (",
"let ((tmp (make-identifier 'tmp here))) (list (the 'let) (list (list tmp (car cl",
"ause))) (list the-if tmp tmp (cons (the 'cond) (cdr clauses))))) (if (and (ident",
"ifier? (cadr clause)) (identifier=? (the '=>) (make-identifier (cadr clause) env",
"))) (let ((tmp (make-identifier 'tmp here))) (list (the 'let) (list (list tmp (c",
"ar clause))) (list the-if tmp (list (car (cddr clause)) tmp) (cons (the 'cond) (",
"cdr clauses))))) (list the-if (car clause) (cons the-begin (cdr clause)) (cons (",
"the 'cond) (cdr clauses))))))))))) (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-i",
"dentifier (car form) env)))) (define (unquote-splicing? form) (and (pair? form) ",
"(pair? (car form)) (identifier? (caar form)) (identifier=? (the 'unquote-splicin",
"g) (make-identifier (caar form) env)))) (define (qq depth expr) (cond ((unquote?",
" expr) (if (= depth 1) (car (cdr expr)) (list (the 'list) (list (the 'quote) (th",
"e 'unquote)) (qq (- depth 1) (car (cdr expr)))))) ((unquote-splicing? expr) (if ",
"(= depth 1) (list (the 'append) (car (cdr (car expr))) (qq depth (cdr expr))) (l",
"ist (the 'cons) (list (the 'list) (list (the 'quote) (the 'unquote-splicing)) (q",
"q (- depth 1) (car (cdr (car expr))))) (qq depth (cdr expr))))) ((quasiquote? ex",
"pr) (list (the 'list) (list (the 'quote) (the 'quasiquote)) (qq (+ depth 1) (car",
" (cdr expr))))) ((pair? expr) (list (the 'cons) (qq depth (car expr)) (qq depth ",
"(cdr expr)))) ((vector? expr) (list (the 'list->vector) (qq depth (vector->list ",
"expr)))) (else (list (the 'quote) expr)))) (let ((x (cadr form))) (qq 1 x)))) (d",
"efine-macro let* (lambda (form env) (let ((bindings (car (cdr form))) (body (cdr",
" (cdr form)))) (if (null? bindings) `(,(the 'let) () ,@body) `(,(the 'let) ((,(c",
"ar (car bindings)) ,@(cdr (car bindings)))) (,(the 'let*) (,@(cdr bindings)) ,@b",
"ody)))))) (define-macro letrec (lambda (form env) `(,(the 'letrec*) ,@(cdr form)",
"))) (define-macro letrec* (lambda (form env) (let ((bindings (car (cdr form))) (",
"body (cdr (cdr form)))) (let ((variables (map (lambda (v) `(,v #f)) (map car bin",
"dings))) (initials (map (lambda (v) `(,(the 'set!) ,@v)) bindings))) `(,(the 'le",
"t) (,@variables) ,@initials ,@body))))) (define-macro let-values (lambda (form e",
"nv) `(,(the 'let*-values) ,@(cdr form)))) (define-macro let*-values (lambda (for",
"m env) (let ((formal (car (cdr form))) (body (cdr (cdr form)))) (if (null? forma",
"l) `(,(the 'let) () ,@body) `(,(the 'call-with-values) (,the-lambda () ,@(cdr (c",
"ar formal))) (,(the 'lambda) (,@(car (car formal))) (,(the 'let*-values) (,@(cdr",
" formal)) ,@body))))))) (define-macro define-values (lambda (form env) (let ((fo",
"rmal (car (cdr form))) (body (cdr (cdr form)))) (let ((arguments (make-identifie",
"r 'arguments here))) `(,the-begin ,@(let loop ((formal formal)) (if (pair? forma",
"l) `((,the-define ,(car formal) #undefined) ,@(loop (cdr formal))) (if (identifi",
"er? formal) `((,the-define ,formal #undefined)) '()))) (,(the 'call-with-values)",
" (,the-lambda () ,@body) (,the-lambda ,arguments ,@(let loop ((formal formal) (a",
"rgs arguments)) (if (pair? formal) `((,the-set! ,(car formal) (,(the 'car) ,args",
")) ,@(loop (cdr formal) `(,(the 'cdr) ,args))) (if (identifier? formal) `((,the-",
"set! ,formal ,args)) '())))))))))) (define-macro do (lambda (form env) (let ((bi",
"ndings (car (cdr form))) (test (car (car (cdr (cdr form))))) (cleanup (cdr (car ",
"(cdr (cdr form))))) (body (cdr (cdr (cdr form))))) (let ((loop (make-identifier ",
"'loop here))) `(,(the 'let) ,loop ,(map (lambda (x) `(,(car x) ,(cadr x))) bindi",
"ngs) (,the-if ,test (,the-begin ,@cleanup) (,the-begin ,@body (,loop ,@(map (lam",
"bda (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)))) `(,the-if ,test (,the-begin ,@body) #undefined)))) (define-macro ",
"unless (lambda (form env) (let ((test (car (cdr form))) (body (cdr (cdr form))))",
" `(,the-if ,test #undefined (,the-begin ,@body))))) (define-macro case (lambda (",
"form env) (let ((key (car (cdr form))) (clauses (cdr (cdr form)))) (let ((the-ke",
"y (make-identifier 'key here))) `(,(the 'let) ((,the-key ,key)) ,(let loop ((cla",
"uses clauses)) (if (null? clauses) #undefined (let ((clause (car clauses))) `(,t",
"he-if ,(if (and (identifier? (car clause)) (identifier=? (the 'else) (make-ident",
"ifier (car clause) env))) #t `(,(the 'or) ,@(map (lambda (x) `(,(the 'eqv?) ,the",
"-key (,the-quote ,x))) (car clause)))) ,(if (and (identifier? (cadr clause)) (id",
"entifier=? (the '=>) (make-identifier (cadr clause) env))) `(,(car (cdr (cdr cla",
"use))) ,the-key) `(,the-begin ,@(cdr clause))) ,(loop (cdr clauses))))))))))) (d",
"efine-macro parameterize (lambda (form env) (let ((formal (car (cdr form))) (bod",
"y (cdr (cdr form)))) `(,(the 'with-dynamic-environment) (,(the 'list) ,@(map (la",
"mbda (x) `(,(the 'cons) ,(car x) ,(cadr x))) formal)) (,the-lambda () ,@body))))",
") (define-macro syntax-quote (lambda (form env) (let ((renames '())) (letrec ((r",
"ename (lambda (var) (let ((x (assq var renames))) (if x (cadr x) (begin (set! re",
"names `((,var ,(make-identifier var env) (,(the 'make-identifier) ',var ',env)) ",
"unquote renames)) (rename var)))))) (walk (lambda (f form) (cond ((identifier? f",
"orm) (f form)) ((pair? form) `(,(the 'cons) (walk f (car form)) (walk f (cdr for",
"m)))) ((vector? form) `(,(the 'list->vector) (walk f (vector->list form)))) (els",
"e `(,(the 'quote) ,form)))))) (let ((form (walk rename (cadr form)))) `(,(the 'l",
"et) ,(map cdr renames) ,form)))))) (define-macro syntax-quasiquote (lambda (form",
" env) (let ((renames '())) (letrec ((rename (lambda (var) (let ((x (assq var ren",
"ames))) (if x (cadr x) (begin (set! renames `((,var ,(make-identifier var env) (",
",(the 'make-identifier) ',var ',env)) unquote renames)) (rename var))))))) (defi",
"ne (syntax-quasiquote? form) (and (pair? form) (identifier? (car form)) (identif",
"ier=? (the 'syntax-quasiquote) (make-identifier (car form) env)))) (define (synt",
"ax-unquote? form) (and (pair? form) (identifier? (car form)) (identifier=? (the ",
"'syntax-unquote) (make-identifier (car form) env)))) (define (syntax-unquote-spl",
"icing? form) (and (pair? form) (pair? (car form)) (identifier? (caar form)) (ide",
"ntifier=? (the 'syntax-unquote-splicing) (make-identifier (caar form) env)))) (d",
"efine (qq depth expr) (cond ((syntax-unquote? expr) (if (= depth 1) (car (cdr ex",
"pr)) (list (the 'list) (list (the 'quote) (the 'syntax-unquote)) (qq (- depth 1)",
" (car (cdr expr)))))) ((syntax-unquote-splicing? expr) (if (= depth 1) (list (th",
"e '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) (li",
"st (the 'list) (list (the 'quote) (the 'quasiquote)) (qq (+ depth 1) (car (cdr e",
"xpr))))) ((pair? expr) (list (the 'cons) (qq depth (car expr)) (qq depth (cdr ex",
"pr)))) ((vector? expr) (list (the 'list->vector) (qq depth (vector->list expr)))",
") ((identifier? expr) (rename expr)) (else (list (the 'quote) expr)))) (let ((bo",
"dy (qq 1 (cadr form)))) `(,(the 'let) ,(map cdr renames) ,body)))))) (define (tr",
"ansformer f) (lambda (form env) (let ((ephemeron1 (make-ephemeron-table)) (ephem",
"eron2 (make-ephemeron-table))) (letrec ((wrap (lambda (var1) (let ((var2 (epheme",
"ron1 var1))) (if var2 (cdr var2) (let ((var2 (make-identifier var1 env))) (ephem",
"eron1 var1 var2) (ephemeron2 var2 var1) var2))))) (unwrap (lambda (var2) (let ((",
"var1 (ephemeron2 var2))) (if var1 (cdr var1) var2)))) (walk (lambda (f form) (co",
"nd ((identifier? form) (f form)) ((pair? form) (cons (walk f (car form)) (walk f",
" (cdr form)))) ((vector? form) (list->vector (walk f (vector->list form)))) (els",
"e form))))) (let ((form (cdr form))) (walk unwrap (apply f (walk wrap form))))))",
")) (define-macro define-syntax (lambda (form env) (let ((formal (car (cdr form))",
") (body (cdr (cdr form)))) (if (pair? formal) `(,(the 'define-syntax) ,(car form",
"al) (,the-lambda ,(cdr formal) ,@body)) `(,the-define-macro ,formal (,(the 'tran",
"sformer) (,the-begin ,@body))))))) (define-macro letrec-syntax (lambda (form env",
") (let ((formal (car (cdr form))) (body (cdr (cdr form)))) `(let () ,@(map (lamb",
"da (x) `(,(the 'define-syntax) ,(car x) ,(cadr x))) formal) ,@body)))) (define-m",
"acro let-syntax (lambda (form env) `(,(the 'letrec-syntax) ,@(cdr form)))) (defi",
"ne (mangle name) (when (null? name) (error \"library name should be a list of at ",
"least one symbols\" name)) (define (->string n) (cond ((symbol? n) (let ((str (sy",
"mbol->string n))) (string-for-each (lambda (c) (when (or (char=? c #\\.) (char=? ",
"c #\\/)) (error \"elements of library name may not contain '.' or '/'\" n))) str) s",
"tr)) ((and (number? n) (exact? n)) (number->string n)) (else (error \"symbol or i",
"nteger 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 strs",
")) (cdr strs))))) (join (map ->string name) \".\")) (define-macro define-library (",
"lambda (form _) (let ((lib (mangle (cadr form))) (body (cddr form))) (or (find-l",
"ibrary lib) (make-library lib)) (for-each (lambda (expr) (eval expr lib)) body))",
")) (define-macro cond-expand (lambda (form _) (letrec ((test (lambda (form) (or ",
"(eq? form 'else) (and (symbol? form) (memq form (features))) (and (pair? form) (",
"case (car form) ((library) (find-library (mangle (cadr form)))) ((not) (not (tes",
"t (cadr form)))) ((and) (let loop ((form (cdr form))) (or (null? form) (and (tes",
"t (car form)) (loop (cdr form)))))) ((or) (let loop ((form (cdr form))) (and (pa",
"ir? form) (or (test (car form)) (loop (cdr form)))))) (else #f))))))) (let loop ",
"((clauses (cdr form))) (if (null? clauses) #undefined (if (test (caar clauses)) ",
"`(,the-begin ,@(cdar clauses)) (loop (cdr clauses)))))))) (define-macro import (",
"lambda (form _) (let ((caddr (lambda (x) (car (cdr (cdr x))))) (prefix (lambda (",
"prefix symbol) (string->symbol (string-append (symbol->string prefix) (symbol->s",
"tring symbol))))) (getlib (lambda (name) (let ((lib (mangle name))) (if (find-li",
"brary lib) lib (error \"library not found\" name)))))) (letrec ((extract (lambda (",
"spec) (case (car spec) ((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)))) ((r",
"ename) (let ((alist (collect (cadr spec))) (renames (map (lambda (x) `((car x) c",
"adr x)) (cddr spec)))) (map (lambda (s) (or (assq (car s) renames) s)) alist))) ",
"((prefix) (let ((alist (collect (cadr spec)))) (map (lambda (s) (cons (prefix (c",
"addr spec) (car s)) (cdr s))) alist))) ((except) (let ((alist (collect (cadr spe",
"c)))) (let loop ((alist alist)) (if (null? alist) '() (if (memq (caar alist) (cd",
"dr spec)) (loop (cdr alist)) (cons (car alist) (loop (cdr alist)))))))) (else (m",
"ap (lambda (x) (cons x x)) (library-exports (getlib spec)))))))) (letrec ((impor",
"t (lambda (spec) (let ((lib (extract spec)) (alist (collect spec))) (for-each (l",
"ambda (slot) (library-import lib (cdr slot) (car slot))) alist))))) (for-each im",
"port (cdr form))))))) (define-macro export (lambda (form _) (letrec ((collect (l",
"ambda (spec) (cond ((symbol? spec) `(,spec unquote spec)) ((and (list? spec) (= ",
"(length spec) 3) (eq? (car spec) 'rename)) `(,(list-ref spec 1) unquote (list-re",
"f spec 2))) (else (error \"malformed export\"))))) (export (lambda (spec) (let ((s",
"lot (collect spec))) (library-export (car slot) (cdr slot)))))) (for-each export",
" (cdr form))))) (export define lambda quote set! if begin define-macro let let* ",
"letrec letrec* let-values let*-values define-values quasiquote unquote unquote-s",
"plicing and or cond case else => do when unless parameterize define-syntax synta",
"x-quote syntax-unquote syntax-quasiquote syntax-unquote-splicing let-syntax letr",
"ec-syntax syntax-error) ",
};

void
pic_boot(pic_state *pic)
{
  pic_load_cstr(pic, &boot_rom[0][0]);
}