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

WIP: precompile macros

This commit is contained in:
Yuichi Nishiwaki 2017-04-03 23:39:30 +09:00
parent 92bbf28621
commit bba2abffde
7 changed files with 893 additions and 232 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
contrib/20.r7rs/scheme/base.scm
View File

@ -1,5 +1,5 @@
(define-library (scheme base) (define-library (scheme base)
(import (picrin base) (import (except (picrin base) compile)
(only (picrin math) (only (picrin math)
abs abs
expt expt

592
lib/ext/boot.c
View File

@ -2,169 +2,310 @@
#include "picrin/extra.h" #include "picrin/extra.h"
static const char boot_rom[][80] = { static const char boot_rom[][80] = {
"(core#define-macro call-with-current-environment (core#lambda (form env) (list (", "(core#begin (core#define transformer (core#lambda (.f.172) (core#lambda (.form.1",
"cadr form) env))) (core#define here (call-with-current-environment (core#lambda ", "73 .env.174) ((core#lambda (.ephemeron1.175 .ephemeron2.176) ((core#lambda (.wra",
"(env) env))) (core#define the (core#lambda (var) (make-identifier var here))) (c", "p.177 .unwrap.178 .walk.179) (core#begin (core#set! .wrap.177 (core#lambda (.var",
"ore#define the-builtin-define (the (core#quote core#define))) (core#define the-b", "1.180) ((core#lambda (.var2.181) (core#if .var2.181 (cdr .var2.181) ((core#lambd",
"uiltin-lambda (the (core#quote core#lambda))) (core#define the-builtin-begin (th", "a (.var2.182) (core#begin (.ephemeron1.175 .var1.180 .var2.182) (core#begin (.ep",
"e (core#quote core#begin))) (core#define the-builtin-quote (the (core#quote core", "hemeron2.176 .var2.182 .var1.180) .var2.182))) (make-identifier .var1.180 .env.1",
"#quote))) (core#define the-builtin-set! (the (core#quote core#set!))) (core#defi", "74)))) (.ephemeron1.175 .var1.180)))) (core#begin (core#set! .unwrap.178 (core#l",
"ne the-builtin-if (the (core#quote core#if))) (core#define the-builtin-define-ma", "ambda (.var2.183) ((core#lambda (.var1.184) (core#if .var1.184 (cdr .var1.184) .",
"cro (the (core#quote core#define-macro))) (core#define the-define (the (core#quo", "var2.183)) (.ephemeron2.176 .var2.183)))) (core#begin (core#set! .walk.179 (core",
"te define))) (core#define the-lambda (the (core#quote lambda))) (core#define the", "#lambda (.f.185 .form.186) (core#if (identifier? .form.186) (.f.185 .form.186) (",
"-begin (the (core#quote begin))) (core#define the-quote (the (core#quote quote))", "core#if (pair? .form.186) (cons (.walk.179 .f.185 (car .form.186)) (.walk.179 .f",
") (core#define the-set! (the (core#quote set!))) (core#define the-if (the (core#", ".185 (cdr .form.186))) (core#if (vector? .form.186) (list->vector (.walk.179 .f.",
"quote if))) (core#define the-define-macro (the (core#quote define-macro))) (core", "185 (vector->list .form.186))) .form.186))))) ((core#lambda (.form.187) (.walk.1",
"#define-macro quote (core#lambda (form env) (core#if (= (length form) 2) (list t", "79 .unwrap.178 (apply .f.172 (.walk.179 .wrap.177 .form.187)))) (cdr .form.173))",
"he-builtin-quote (cadr form)) (error \"illegal quote form\" form)))) (core#define-", ")))) #f #f #f)) (make-ephemeron-table) (make-ephemeron-table))))) ((core#lambda ",
"macro if (core#lambda (form env) ((core#lambda (len) (core#if (= len 4) (cons th", "() (core#begin (core#define .define-transformer.188 (core#lambda (.name.208 .tra",
"e-builtin-if (cdr form)) (core#if (= len 3) (list the-builtin-if (list-ref form ", "nsformer.209) (add-macro! .name.208 .transformer.209))) (core#begin (core#define",
"1) (list-ref form 2) #undefined) (error \"illegal if form\" form)))) (length form)", " .the.189 (core#lambda (.var.210) (make-identifier .var.210 default-environment)",
"))) (core#define-macro begin (core#lambda (form env) ((core#lambda (len) (if (= ", ")) (core#begin (core#define .the-core-define.190 (.the.189 (core#quote core#defi",
"len 1) #undefined (if (= len 2) (cadr form) (if (= len 3) (cons the-builtin-begi", "ne))) (core#begin (core#define .the-core-lambda.191 (.the.189 (core#quote core#l",
"n (cdr form)) (list the-builtin-begin (cadr form) (cons the-begin (cddr form))))", "ambda))) (core#begin (core#define .the-core-begin.192 (.the.189 (core#quote core",
"))) (length form)))) (core#define-macro set! (core#lambda (form env) (if (= (len", "#begin))) (core#begin (core#define .the-core-quote.193 (.the.189 (core#quote cor",
"gth form) 3) (if (identifier? (cadr form)) (cons the-builtin-set! (cdr form)) (e", "e#quote))) (core#begin (core#define .the-core-set!.194 (.the.189 (core#quote cor",
"rror \"illegal set! form\" form)) (error \"illegal set! form\" form)))) (core#define", "e#set!))) (core#begin (core#define .the-core-if.195 (.the.189 (core#quote core#i",
" check-formal (core#lambda (formal) (if (null? formal) #t (if (identifier? forma", "f))) (core#begin (core#define .the-core-define-macro.196 (.the.189 (core#quote c",
"l) #t (if (pair? formal) (if (identifier? (car formal)) (check-formal (cdr forma", "ore#define-macro))) (core#begin (core#define .the-define.197 (.the.189 (core#quo",
"l)) #f) #f))))) (core#define-macro lambda (core#lambda (form env) (if (= (length", "te define))) (core#begin (core#define .the-lambda.198 (.the.189 (core#quote lamb",
" form) 1) (error \"illegal lambda form\" form) (if (check-formal (cadr form)) (lis", "da))) (core#begin (core#define .the-begin.199 (.the.189 (core#quote begin))) (co",
"t the-builtin-lambda (cadr form) (cons the-begin (cddr form))) (error \"illegal l", "re#begin (core#define .the-quote.200 (.the.189 (core#quote quote))) (core#begin ",
"ambda form\" form))))) (core#define-macro define (lambda (form env) ((lambda (len", "(core#define .the-set!.201 (.the.189 (core#quote set!))) (core#begin (core#defin",
") (if (= len 1) (error \"illegal define form\" form) (if (identifier? (cadr form))", "e .the-if.202 (.the.189 (core#quote if))) (core#begin (core#define .the-define-m",
" (if (= len 3) (cons the-builtin-define (cdr form)) (error \"illegal define form\"", "acro.203 (.the.189 (core#quote define-macro))) (core#begin (.define-transformer.",
" form)) (if (pair? (cadr form)) (list the-define (car (cadr form)) (cons the-lam", "188 (core#quote quote) (core#lambda (.form.211 .env.212) (core#if (= (length .fo",
"bda (cons (cdr (cadr form)) (cddr form)))) (error \"define: binding to non-varaib", "rm.211) 2) (cons .the-core-quote.193 (cons (cadr .form.211) (core#quote ()))) (e",
"le object\" form))))) (length form)))) (core#define-macro define-macro (lambda (f", "rror \"malformed quote\" .form.211)))) (core#begin (.define-transformer.188 (core#",
"orm env) (if (= (length form) 3) (if (identifier? (cadr form)) (cons the-builtin", "quote if) (core#lambda (.form.213 .env.214) ((core#lambda (.len.215) (core#if (=",
"-define-macro (cdr form)) (error \"define-macro: binding to non-variable object\" ", " .len.215 3) (append .form.213 (cons (core#quote #undefined) (core#quote ()))) (",
"form)) (error \"illegal define-macro form\" form)))) (define-macro syntax-error (l", "core#if (= .len.215 4) (cons .the-core-if.195 (cdr .form.213)) (error \"malformed",
"ambda (form _) (apply error (cdr form)))) (define-macro define-auxiliary-syntax ", " if\" .form.213)))) (length .form.213)))) (core#begin (.define-transformer.188 (c",
"(lambda (form _) (define message (string-append \"invalid use of auxiliary syntax", "ore#quote begin) (core#lambda (.form.216 .env.217) ((core#lambda (.len.218) (cor",
": '\" (symbol->string (cadr form)) \"'\")) (list the-define-macro (cadr form) (list", "e#if (= .len.218 1) #undefined (core#if (= .len.218 2) (cadr .form.216) (core#if",
" the-lambda '_ (list (the 'error) message))))) (define-auxiliary-syntax else) (d", " (= .len.218 3) (cons .the-core-begin.192 (cdr .form.216)) (cons .the-core-begin",
"efine-auxiliary-syntax =>) (define-auxiliary-syntax unquote) (define-auxiliary-s", ".192 (cons (cadr .form.216) (cons (cons .the-begin.199 (cddr .form.216)) (core#q",
"yntax unquote-splicing) (define-auxiliary-syntax syntax-unquote) (define-auxilia", "uote ())))))))) (length .form.216)))) (core#begin (.define-transformer.188 (core",
"ry-syntax syntax-unquote-splicing) (define-macro let (lambda (form env) (if (ide", "#quote set!) (core#lambda (.form.219 .env.220) (core#if (core#if (= (length .for",
"ntifier? (cadr form)) (list (list the-lambda '() (list the-define (cadr form) (c", "m.219) 3) (identifier? (cadr .form.219)) #f) (cons .the-core-set!.194 (cdr .form",
"ons the-lambda (cons (map car (car (cddr form))) (cdr (cddr form))))) (cons (cad", ".219)) (error \"malformed set!\" .form.219)))) (core#begin (core#define .check-for",
"r form) (map cadr (car (cddr form)))))) (cons (cons the-lambda (cons (map car (c", "mal.204 (core#lambda (.formal.221) ((core#lambda (.it.222) (core#if .it.222 .it.",
"adr form)) (cddr form))) (map cadr (cadr form)))))) (define-macro and (lambda (f", "222 ((core#lambda (.it.223) (core#if .it.223 .it.223 ((core#lambda (.it.224) (co",
"orm env) (if (null? (cdr form)) #t (if (null? (cddr form)) (cadr form) (list the", "re#if .it.224 .it.224 #f)) (core#if (pair? .formal.221) (core#if (identifier? (c",
"-if (cadr form) (cons (the 'and) (cddr form)) #f))))) (define-macro or (lambda (", "ar .formal.221)) (.check-formal.204 (cdr .formal.221)) #f) #f)))) (identifier? .",
"form env) (if (null? (cdr form)) #f (let ((tmp (make-identifier 'it env))) (list", "formal.221)))) (null? .formal.221)))) (core#begin (.define-transformer.188 (core",
" (the 'let) (list (list tmp (cadr form))) (list the-if tmp tmp (cons (the 'or) (", "#quote lambda) (core#lambda (.form.225 .env.226) (core#if (= (length .form.225) ",
"cddr form)))))))) (define-macro cond (lambda (form env) (let ((clauses (cdr form", "1) (error \"malformed lambda\" .form.225) (core#if (.check-formal.204 (cadr .form.",
"))) (if (null? clauses) #undefined (let ((clause (car clauses))) (if (and (ident", "225)) (cons .the-core-lambda.191 (cons (cadr .form.225) (cons (cons .the-begin.1",
"ifier? (car clause)) (identifier=? (the 'else) (make-identifier (car clause) env", "99 (cddr .form.225)) (core#quote ())))) (error \"malformed lambda\" .form.225)))))",
"))) (cons the-begin (cdr clause)) (if (null? (cdr clause)) (let ((tmp (make-iden", " (core#begin (.define-transformer.188 (core#quote define) (core#lambda (.form.22",
"tifier 'tmp here))) (list (the 'let) (list (list tmp (car clause))) (list the-if", "7 .env.228) ((core#lambda (.len.229) (core#if (= .len.229 1) (error \"malformed d",
" tmp tmp (cons (the 'cond) (cdr clauses))))) (if (and (identifier? (cadr clause)", "efine\" .form.227) ((core#lambda (.formal.230) (core#if (identifier? .formal.230)",
") (identifier=? (the '=>) (make-identifier (cadr clause) env))) (let ((tmp (make", " (core#if (= .len.229 3) (cons .the-core-define.190 (cdr .form.227)) (error \"mal",
"-identifier 'tmp here))) (list (the 'let) (list (list tmp (car clause))) (list t", "formed define\" .form.227)) (core#if (pair? .formal.230) (cons .the-define.197 (c",
"he-if tmp (list (car (cddr clause)) tmp) (cons (the 'cond) (cdr clauses))))) (li", "ons (car .formal.230) (cons (cons .the-lambda.198 (cons (cdr .formal.230) (cddr ",
"st the-if (car clause) (cons the-begin (cdr clause)) (cons (the 'cond) (cdr clau", ".form.227))) (core#quote ())))) (error \"define: binding to non-varaible object\" ",
"ses))))))))))) (define-macro quasiquote (lambda (form env) (define (quasiquote? ", ".form.227)))) (cadr .form.227)))) (length .form.227)))) (core#begin (.define-tra",
"form) (and (pair? form) (identifier? (car form)) (identifier=? (the 'quasiquote)", "nsformer.188 (core#quote define-macro) (core#lambda (.form.231 .env.232) (core#i",
" (make-identifier (car form) env)))) (define (unquote? form) (and (pair? form) (", "f (= (length .form.231) 3) (core#if (identifier? (cadr .form.231)) (cons .the-co",
"identifier? (car form)) (identifier=? (the 'unquote) (make-identifier (car form)", "re-define-macro.196 (cdr .form.231)) (error \"define-macro: binding to non-variab",
" env)))) (define (unquote-splicing? form) (and (pair? form) (pair? (car form)) (", "le object\" .form.231)) (error \"malformed define-macro\" .form.231)))) (core#begin",
"identifier? (caar form)) (identifier=? (the 'unquote-splicing) (make-identifier ", " (.define-transformer.188 (core#quote syntax-error) (core#lambda (.form.233 ._.2",
"(caar form) env)))) (define (qq depth expr) (cond ((unquote? expr) (if (= depth ", "34) (apply error (cdr .form.233)))) (core#begin #undefined (core#begin (.define-",
"1) (car (cdr expr)) (list (the 'list) (list (the 'quote) (the 'unquote)) (qq (- ", "transformer.188 (core#quote else) (core#lambda ._.235 (error \"invalid use of aux",
"depth 1) (car (cdr expr)))))) ((unquote-splicing? expr) (if (= depth 1) (list (t", "iliary syntax\" (core#quote else)))) (core#begin (.define-transformer.188 (core#q",
"he 'append) (car (cdr (car expr))) (qq depth (cdr expr))) (list (the 'cons) (lis", "uote =>) (core#lambda ._.236 (error \"invalid use of auxiliary syntax\" (core#quot",
"t (the 'list) (list (the 'quote) (the 'unquote-splicing)) (qq (- depth 1) (car (", "e =>)))) (core#begin (.define-transformer.188 (core#quote unquote) (core#lambda ",
"cdr (car expr))))) (qq depth (cdr expr))))) ((quasiquote? expr) (list (the 'list", "._.237 (error \"invalid use of auxiliary syntax\" (core#quote unquote)))) (core#be",
") (list (the 'quote) (the 'quasiquote)) (qq (+ depth 1) (car (cdr expr))))) ((pa", "gin (.define-transformer.188 (core#quote unquote-splicing) (core#lambda ._.238 (",
"ir? expr) (list (the 'cons) (qq depth (car expr)) (qq depth (cdr expr)))) ((vect", "error \"invalid use of auxiliary syntax\" (core#quote unquote-splicing)))) (core#b",
"or? expr) (list (the 'list->vector) (qq depth (vector->list expr)))) (else (list", "egin (.define-transformer.188 (core#quote syntax-unquote) (core#lambda ._.239 (e",
" (the 'quote) expr)))) (let ((x (cadr form))) (qq 1 x)))) (define-macro let* (la", "rror \"invalid use of auxiliary syntax\" (core#quote syntax-unquote)))) (core#begi",
"mbda (form env) (let ((bindings (car (cdr form))) (body (cdr (cdr form)))) (if (", "n (.define-transformer.188 (core#quote syntax-unquote-splicing) (core#lambda ._.",
"null? bindings) `(,(the 'let) () ,@body) `(,(the 'let) ((,(car (car bindings)) ,", "240 (error \"invalid use of auxiliary syntax\" (core#quote syntax-unquote-splicing",
"@(cdr (car bindings)))) (,(the 'let*) (,@(cdr bindings)) ,@body)))))) (define-ma", ")))) (core#begin (.define-transformer.188 (core#quote let) (core#lambda (.form.2",
"cro letrec (lambda (form env) `(,(the 'letrec*) ,@(cdr form)))) (define-macro le", "41 .env.242) (core#if (identifier? (cadr .form.241)) ((core#lambda (.name.243 .f",
"trec* (lambda (form env) (let ((bindings (car (cdr form))) (body (cdr (cdr form)", "ormal.244 .body.245) (cons (cons .the-lambda.198 (cons (core#quote ()) (cons (co",
"))) (let ((variables (map (lambda (v) `(,v #f)) (map car bindings))) (initials (", "ns .the-define.197 (cons (cons .name.243 (map car .formal.244)) .body.245)) (con",
"map (lambda (v) `(,(the 'set!) ,@v)) bindings))) `(,(the 'let) (,@variables) ,@i", "s (cons .name.243 (map cadr .formal.244)) (core#quote ()))))) (core#quote ()))) ",
"nitials ,@body))))) (define-macro let-values (lambda (form env) `(,(the 'let*-va", "(car (cdr .form.241)) (car (cdr (cdr .form.241))) (cdr (cdr (cdr .form.241)))) (",
"lues) ,@(cdr form)))) (define-macro let*-values (lambda (form env) (let ((formal", "(core#lambda (.formal.246 .body.247) (cons (cons .the-lambda.198 (cons (map car ",
" (car (cdr form))) (body (cdr (cdr form)))) (if (null? formal) `(,(the 'let) () ", ".formal.246) .body.247)) (map cadr .formal.246))) (car (cdr .form.241)) (cdr (cd",
",@body) `(,(the 'call-with-values) (,the-lambda () ,@(cdr (car formal))) (,(the ", "r .form.241)))))) (core#begin (.define-transformer.188 (core#quote and) (core#la",
"'lambda) (,@(car (car formal))) (,(the 'let*-values) (,@(cdr formal)) ,@body))))", "mbda (.form.248 .env.249) (core#if (null? (cdr .form.248)) #t (core#if (null? (c",
"))) (define-macro define-values (lambda (form env) (let ((formal (car (cdr form)", "ddr .form.248)) (cadr .form.248) (cons .the-if.202 (cons (cadr .form.248) (cons ",
")) (body (cdr (cdr form)))) (let ((arguments (make-identifier 'arguments here)))", "(cons (.the.189 (core#quote and)) (cddr .form.248)) (cons (core#quote #f) (core#",
" `(,the-begin ,@(let loop ((formal formal)) (if (pair? formal) `((,the-define ,(", "quote ()))))))))) (core#begin (.define-transformer.188 (core#quote or) (core#lam",
"car formal) #undefined) ,@(loop (cdr formal))) (if (identifier? formal) `((,the-", "bda (.form.250 .env.251) (core#if (null? (cdr .form.250)) #f ((core#lambda (.tmp",
"define ,formal #undefined)) '()))) (,(the 'call-with-values) (,the-lambda () ,@b", ".252) (cons (.the.189 (core#quote let)) (cons (cons (cons .tmp.252 (cons (cadr .",
"ody) (,the-lambda ,arguments ,@(let loop ((formal formal) (args arguments)) (if ", "form.250) (core#quote ()))) (core#quote ())) (cons (cons .the-if.202 (cons .tmp.",
"(pair? formal) `((,the-set! ,(car formal) (,(the 'car) ,args)) ,@(loop (cdr form", "252 (cons .tmp.252 (cons (cons (.the.189 (core#quote or)) (cddr .form.250)) (cor",
"al) `(,(the 'cdr) ,args))) (if (identifier? formal) `((,the-set! ,formal ,args))", "e#quote ()))))) (core#quote ()))))) (make-identifier (core#quote it) .env.251)))",
" '())))))))))) (define-macro do (lambda (form env) (let ((bindings (car (cdr for", ")) (core#begin (.define-transformer.188 (core#quote cond) (core#lambda (.form.25",
"m))) (test (car (car (cdr (cdr form))))) (cleanup (cdr (car (cdr (cdr form))))) ", "3 .env.254) ((core#lambda (.clauses.255) (core#if (null? .clauses.255) #undefine",
"(body (cdr (cdr (cdr form))))) (let ((loop (make-identifier 'loop here))) `(,(th", "d ((core#lambda (.clause.256) (core#if (core#if (identifier? (car .clause.256)) ",
"e 'let) ,loop ,(map (lambda (x) `(,(car x) ,(cadr x))) bindings) (,the-if ,test ", "(identifier=? (.the.189 (core#quote else)) (make-identifier (car .clause.256) .e",
"(,the-begin ,@cleanup) (,the-begin ,@body (,loop ,@(map (lambda (x) (if (null? (", "nv.254)) #f) (cons .the-begin.199 (cdr .clause.256)) (core#if (null? (cdr .claus",
"cdr (cdr x))) (car x) (car (cdr (cdr x))))) bindings))))))))) (define-macro when", "e.256)) (cons (.the.189 (core#quote or)) (cons (car .clause.256) (cons (cons (.t",
" (lambda (form env) (let ((test (car (cdr form))) (body (cdr (cdr form)))) `(,th", "he.189 (core#quote cond)) (cdr .clauses.255)) (core#quote ())))) (core#if (core#",
"e-if ,test (,the-begin ,@body) #undefined)))) (define-macro unless (lambda (form", "if (identifier? (cadr .clause.256)) (identifier=? (.the.189 (core#quote =>)) (ma",
" env) (let ((test (car (cdr form))) (body (cdr (cdr form)))) `(,the-if ,test #un", "ke-identifier (cadr .clause.256) .env.254)) #f) ((core#lambda (.tmp.257) (cons (",
"defined (,the-begin ,@body))))) (define-macro case (lambda (form env) (let ((key", ".the.189 (core#quote let)) (cons (cons (cons .tmp.257 (cons (car .clause.256) (c",
" (car (cdr form))) (clauses (cdr (cdr form)))) (let ((the-key (make-identifier '", "ore#quote ()))) (core#quote ())) (cons (cons .the-if.202 (cons .tmp.257 (cons (c",
"key here))) `(,(the 'let) ((,the-key ,key)) ,(let loop ((clauses clauses)) (if (", "ons (cadr (cdr .clause.256)) (cons .tmp.257 (core#quote ()))) (cons (cons (.the.",
"null? clauses) #undefined (let ((clause (car clauses))) `(,the-if ,(if (and (ide", "189 (core#quote cond)) (cddr .form.253)) (core#quote ()))))) (core#quote ())))))",
"ntifier? (car clause)) (identifier=? (the 'else) (make-identifier (car clause) e", " (make-identifier (core#quote tmp) .env.254)) (cons .the-if.202 (cons (car .clau",
"nv))) #t `(,(the 'or) ,@(map (lambda (x) `(,(the 'eqv?) ,the-key (,the-quote ,x)", "se.256) (cons (cons .the-begin.199 (cdr .clause.256)) (cons (cons (.the.189 (cor",
")) (car clause)))) ,(if (and (identifier? (cadr clause)) (identifier=? (the '=>)", "e#quote cond)) (cdr .clauses.255)) (core#quote ()))))))))) (car .clauses.255))))",
" (make-identifier (cadr clause) env))) `(,(car (cdr (cdr clause))) ,the-key) `(,", " (cdr .form.253)))) (core#begin (.define-transformer.188 (core#quote quasiquote)",
"the-begin ,@(cdr clause))) ,(loop (cdr clauses))))))))))) (define-macro paramete", " (core#lambda (.form.258 .env.259) (core#begin (core#define .quasiquote?.260 (co",
"rize (lambda (form env) (let ((formal (car (cdr form))) (body (cdr (cdr form))))", "re#lambda (.form.264) (core#if (pair? .form.264) (core#if (identifier? (car .for",
" `(,(the 'with-dynamic-environment) (,(the 'list) ,@(map (lambda (x) `(,(the 'co", "m.264)) (identifier=? (.the.189 (core#quote quasiquote)) (make-identifier (car .",
"ns) ,(car x) ,(cadr x))) formal)) (,the-lambda () ,@body))))) (define-macro synt", "form.264) .env.259)) #f) #f))) (core#begin (core#define .unquote?.261 (core#lamb",
"ax-quote (lambda (form env) (let ((renames '())) (letrec ((rename (lambda (var) ", "da (.form.265) (core#if (pair? .form.265) (core#if (identifier? (car .form.265))",
"(let ((x (assq var renames))) (if x (cadr x) (begin (set! renames `((,var ,(make", " (identifier=? (.the.189 (core#quote unquote)) (make-identifier (car .form.265) ",
"-identifier var env) (,(the 'make-identifier) ',var ',env)) unquote renames)) (r", ".env.259)) #f) #f))) (core#begin (core#define .unquote-splicing?.262 (core#lambd",
"ename var)))))) (walk (lambda (f form) (cond ((identifier? form) (f form)) ((pai", "a (.form.266) (core#if (pair? .form.266) (core#if (pair? (car .form.266)) (core#",
"r? form) `(,(the 'cons) (walk f (car form)) (walk f (cdr form)))) ((vector? form", "if (identifier? (caar .form.266)) (identifier=? (.the.189 (core#quote unquote-sp",
") `(,(the 'list->vector) (walk f (vector->list form)))) (else `(,(the 'quote) ,f", "licing)) (make-identifier (caar .form.266) .env.259)) #f) #f) #f))) (core#begin ",
"orm)))))) (let ((form (walk rename (cadr form)))) `(,(the 'let) ,(map cdr rename", "(core#define .qq.263 (core#lambda (.depth.267 .expr.268) (core#if (.unquote?.261",
"s) ,form)))))) (define-macro syntax-quasiquote (lambda (form env) (let ((renames", " .expr.268) (core#if (= .depth.267 1) (cadr .expr.268) (list (.the.189 (core#quo",
" '())) (letrec ((rename (lambda (var) (let ((x (assq var renames))) (if x (cadr ", "te list)) (list (.the.189 (core#quote quote)) (.the.189 (core#quote unquote))) (",
"x) (begin (set! renames `((,var ,(make-identifier var env) (,(the 'make-identifi", ".qq.263 (- .depth.267 1) (car (cdr .expr.268))))) (core#if (.unquote-splicing?.2",
"er) ',var ',env)) unquote renames)) (rename var))))))) (define (syntax-quasiquot", "62 .expr.268) (core#if (= .depth.267 1) (list (.the.189 (core#quote append)) (ca",
"e? form) (and (pair? form) (identifier? (car form)) (identifier=? (the 'syntax-q", "r (cdr (car .expr.268))) (.qq.263 .depth.267 (cdr .expr.268))) (list (.the.189 (",
"uasiquote) (make-identifier (car form) env)))) (define (syntax-unquote? form) (a", "core#quote cons)) (list (.the.189 (core#quote list)) (list (.the.189 (core#quote",
"nd (pair? form) (identifier? (car form)) (identifier=? (the 'syntax-unquote) (ma", " quote)) (.the.189 (core#quote unquote-splicing))) (.qq.263 (- .depth.267 1) (ca",
"ke-identifier (car form) env)))) (define (syntax-unquote-splicing? form) (and (p", "r (cdr (car .expr.268))))) (.qq.263 .depth.267 (cdr .expr.268)))) (core#if (.qua",
"air? form) (pair? (car form)) (identifier? (caar form)) (identifier=? (the 'synt", "siquote?.260 .expr.268) (list (.the.189 (core#quote list)) (list (.the.189 (core",
"ax-unquote-splicing) (make-identifier (caar form) env)))) (define (qq depth expr", "#quote quote)) (.the.189 (core#quote quasiquote))) (.qq.263 (+ .depth.267 1) (ca",
") (cond ((syntax-unquote? expr) (if (= depth 1) (car (cdr expr)) (list (the 'lis", "r (cdr .expr.268)))) (core#if (pair? .expr.268) (list (.the.189 (core#quote cons",
"t) (list (the 'quote) (the 'syntax-unquote)) (qq (- depth 1) (car (cdr expr)))))", ")) (.qq.263 .depth.267 (car .expr.268)) (.qq.263 .depth.267 (cdr .expr.268))) (c",
") ((syntax-unquote-splicing? expr) (if (= depth 1) (list (the 'append) (car (cdr", "ore#if (vector? .expr.268) (list (.the.189 (core#quote list->vector)) (.qq.263 .",
" (car expr))) (qq depth (cdr expr))) (list (the 'cons) (list (the 'list) (list (", "depth.267 (vector->list .expr.268))) (list (.the.189 (core#quote quote)) .expr.2",
"the 'quote) (the 'syntax-unquote-splicing)) (qq (- depth 1) (car (cdr (car expr)", "68)))))))) ((core#lambda (.x.269) (.qq.263 1 .x.269)) (cadr .form.258)))))))) (c",
")))) (qq depth (cdr expr))))) ((syntax-quasiquote? expr) (list (the 'list) (list", "ore#begin (.define-transformer.188 (core#quote let*) (core#lambda (.form.270 .en",
" (the 'quote) (the 'quasiquote)) (qq (+ depth 1) (car (cdr expr))))) ((pair? exp", "v.271) ((core#lambda (.bindings.272 .body.273) (core#if (null? .bindings.272) (c",
"r) (list (the 'cons) (qq depth (car expr)) (qq depth (cdr expr)))) ((vector? exp", "ons (.the.189 (core#quote let)) (cons (core#quote ()) .body.273)) (cons (.the.18",
"r) (list (the 'list->vector) (qq depth (vector->list expr)))) ((identifier? expr", "9 (core#quote let)) (cons (cons (cons (car (car .bindings.272)) (cdr (car .bindi",
") (rename expr)) (else (list (the 'quote) expr)))) (let ((body (qq 1 (cadr form)", "ngs.272))) (core#quote ())) (cons (cons (.the.189 (core#quote let*)) (cons (cdr ",
"))) `(,(the 'let) ,(map cdr renames) ,body)))))) (define (transformer f) (lambda", ".bindings.272) .body.273)) (core#quote ())))))) (car (cdr .form.270)) (cdr (cdr ",
" (form env) (let ((ephemeron1 (make-ephemeron-table)) (ephemeron2 (make-ephemero", ".form.270))))) (core#begin (.define-transformer.188 (core#quote letrec) (core#la",
"n-table))) (letrec ((wrap (lambda (var1) (let ((var2 (ephemeron1 var1))) (if var", "mbda (.form.274 .env.275) (cons (.the.189 (core#quote letrec*)) (cdr .form.274))",
"2 (cdr var2) (let ((var2 (make-identifier var1 env))) (ephemeron1 var1 var2) (ep", ")) (core#begin (.define-transformer.188 (core#quote letrec*) (core#lambda (.form",
"hemeron2 var2 var1) var2))))) (unwrap (lambda (var2) (let ((var1 (ephemeron2 var", ".276 .env.277) ((core#lambda (.bindings.278 .body.279) ((core#lambda (.variables",
"2))) (if var1 (cdr var1) var2)))) (walk (lambda (f form) (cond ((identifier? for", ".280 .initials.281) (cons (.the.189 (core#quote let)) (cons .variables.280 (appe",
"m) (f form)) ((pair? form) (cons (walk f (car form)) (walk f (cdr form)))) ((vec", "nd .initials.281 (append .body.279 (core#quote ())))))) (map (core#lambda (.v.28",
"tor? form) (list->vector (walk f (vector->list form)))) (else form))))) (let ((f", "2) (cons .v.282 (cons (core#quote #undefined) (core#quote ())))) (map car .bindi",
"orm (cdr form))) (walk unwrap (apply f (walk wrap form)))))))) (define-macro def", "ngs.278)) (map (core#lambda (.v.283) (cons (.the.189 (core#quote set!)) (append ",
"ine-syntax (lambda (form env) (let ((formal (car (cdr form))) (body (cdr (cdr fo", ".v.283 (core#quote ())))) .bindings.278))) (car (cdr .form.276)) (cdr (cdr .form",
"rm)))) (if (pair? formal) `(,(the 'define-syntax) ,(car formal) (,the-lambda ,(c", ".276))))) (core#begin (.define-transformer.188 (core#quote let-values) (core#lam",
"dr formal) ,@body)) `(,the-define-macro ,formal (,(the 'transformer) (,the-begin", "bda (.form.284 .env.285) (cons (.the.189 (core#quote let*-values)) (append (cdr ",
" ,@body))))))) (define-macro letrec-syntax (lambda (form env) (let ((formal (car", ".form.284) (core#quote ()))))) (core#begin (.define-transformer.188 (core#quote ",
" (cdr form))) (body (cdr (cdr form)))) `(let () ,@(map (lambda (x) `(,(the 'defi", "let*-values) (core#lambda (.form.286 .env.287) ((core#lambda (.formal.288 .body.",
"ne-syntax) ,(car x) ,(cadr x))) formal) ,@body)))) (define-macro let-syntax (lam", "289) (core#if (null? .formal.288) (cons (.the.189 (core#quote let)) (cons (core#",
"bda (form env) `(,(the 'letrec-syntax) ,@(cdr form)))) ", "quote ()) (append .body.289 (core#quote ())))) (cons (.the.189 (core#quote call-",
"with-values)) (cons (cons .the-lambda.198 (cons (core#quote ()) (append (cdr (ca",
"r .formal.288)) (core#quote ())))) (cons (cons (.the.189 (core#quote lambda)) (c",
"ons (append (car (car .formal.288)) (core#quote ())) (cons (cons (.the.189 (core",
"#quote let*-values)) (cons (append (cdr .formal.288) (core#quote ())) (append .b",
"ody.289 (core#quote ())))) (core#quote ())))) (core#quote ())))))) (car (cdr .fo",
"rm.286)) (cdr (cdr .form.286))))) (core#begin (.define-transformer.188 (core#quo",
"te define-values) (core#lambda (.form.290 .env.291) ((core#lambda (.formal.292 .",
"body.293) ((core#lambda (.arguments.294) (cons .the-begin.199 (append ((core#lam",
"bda () (core#begin (core#define .loop.295 (core#lambda (.formal.296) (core#if (p",
"air? .formal.296) (cons (cons .the-define.197 (cons (car .formal.296) (cons (cor",
"e#quote #undefined) (core#quote ())))) (append (.loop.295 (cdr .formal.296)) (co",
"re#quote ()))) (core#if (identifier? .formal.296) (cons (cons .the-define.197 (c",
"ons .formal.296 (cons (core#quote #undefined) (core#quote ())))) (core#quote ())",
") (core#quote ()))))) (.loop.295 .formal.292)))) (cons (cons (.the.189 (core#quo",
"te call-with-values)) (cons (cons .the-lambda.198 (cons (core#quote ()) (append ",
".body.293 (core#quote ())))) (cons (cons .the-lambda.198 (cons .arguments.294 (a",
"ppend ((core#lambda () (core#begin (core#define .loop.297 (core#lambda (.formal.",
"298 .args.299) (core#if (pair? .formal.298) (cons (cons .the-set!.201 (cons (car",
" .formal.298) (cons (cons (.the.189 (core#quote car)) (cons .args.299 (core#quot",
"e ()))) (core#quote ())))) (append (.loop.297 (cdr .formal.298) (cons (.the.189 ",
"(core#quote cdr)) (cons .args.299 (core#quote ())))) (core#quote ()))) (core#if ",
"(identifier? .formal.298) (cons (cons .the-set!.201 (cons .formal.298 (cons .arg",
"s.299 (core#quote ())))) (core#quote ())) (core#quote ()))))) (.loop.297 .formal",
".292 .arguments.294)))) (core#quote ())))) (core#quote ())))) (core#quote ()))))",
") (make-identifier (core#quote arguments) .env.291))) (car (cdr .form.290)) (cdr",
" (cdr .form.290))))) (core#begin (.define-transformer.188 (core#quote do) (core#",
"lambda (.form.300 .env.301) ((core#lambda (.bindings.302 .test.303 .cleanup.304 ",
".body.305) ((core#lambda (.loop.306) (cons (.the.189 (core#quote let)) (cons .lo",
"op.306 (cons (map (core#lambda (.x.307) (cons (car .x.307) (cons (cadr .x.307) (",
"core#quote ())))) .bindings.302) (cons (cons .the-if.202 (cons .test.303 (cons (",
"cons .the-begin.199 .cleanup.304) (cons (cons .the-begin.199 (append .body.305 (",
"cons (cons .loop.306 (map (core#lambda (.x.308) (core#if (null? (cdr (cdr .x.308",
"))) (car .x.308) (car (cdr (cdr .x.308))))) .bindings.302)) (core#quote ())))) (",
"core#quote ()))))) (core#quote ())))))) (make-identifier (core#quote loop) .env.",
"301))) (car (cdr .form.300)) (car (car (cdr (cdr .form.300)))) (cdr (car (cdr (c",
"dr .form.300)))) (cdr (cdr (cdr .form.300)))))) (core#begin (.define-transformer",
".188 (core#quote when) (core#lambda (.form.309 .env.310) ((core#lambda (.test.31",
"1 .body.312) (cons .the-if.202 (cons .test.311 (cons (cons .the-begin.199 (appen",
"d .body.312 (core#quote ()))) (cons (core#quote #undefined) (core#quote ()))))))",
" (car (cdr .form.309)) (cdr (cdr .form.309))))) (core#begin (.define-transformer",
".188 (core#quote unless) (core#lambda (.form.313 .env.314) ((core#lambda (.test.",
"315 .body.316) (cons .the-if.202 (cons .test.315 (cons (core#quote #undefined) (",
"cons (cons .the-begin.199 (append .body.316 (core#quote ()))) (core#quote ()))))",
")) (car (cdr .form.313)) (cdr (cdr .form.313))))) (core#begin (.define-transform",
"er.188 (core#quote case) (core#lambda (.form.317 .env.318) ((core#lambda (.key.3",
"19 .clauses.320) ((core#lambda (.the-key.321) (cons (.the.189 (core#quote let)) ",
"(cons (cons (cons .the-key.321 (cons .key.319 (core#quote ()))) (core#quote ()))",
" (cons ((core#lambda () (core#begin (core#define .loop.322 (core#lambda (.clause",
"s.323) (core#if (null? .clauses.323) #undefined ((core#lambda (.clause.324) (con",
"s .the-if.202 (cons (core#if (core#if (identifier? (car .clause.324)) (identifie",
"r=? (.the.189 (core#quote else)) (make-identifier (car .clause.324) .env.318)) #",
"f) #t (cons (.the.189 (core#quote or)) (append (map (core#lambda (.x.325) (cons ",
"(.the.189 (core#quote eqv?)) (cons .the-key.321 (cons (cons .the-quote.200 (cons",
" .x.325 (core#quote ()))) (core#quote ()))))) (car .clause.324)) (core#quote ())",
"))) (cons (core#if (core#if (identifier? (cadr .clause.324)) (identifier=? (.the",
".189 (core#quote =>)) (make-identifier (cadr .clause.324) .env.318)) #f) (cons (",
"car (cdr (cdr .clause.324))) (cons .the-key.321 (core#quote ()))) (cons .the-beg",
"in.199 (append (cdr .clause.324) (core#quote ())))) (cons (.loop.322 (cdr .claus",
"es.323)) (core#quote ())))))) (car .clauses.323))))) (.loop.322 .clauses.320))))",
" (core#quote ()))))) (make-identifier (core#quote key) .env.318))) (car (cdr .fo",
"rm.317)) (cdr (cdr .form.317))))) (core#begin (.define-transformer.188 (core#quo",
"te parameterize) (core#lambda (.form.326 .env.327) ((core#lambda (.formal.328 .b",
"ody.329) (cons (.the.189 (core#quote with-dynamic-environment)) (cons (cons (.th",
"e.189 (core#quote list)) (append (map (core#lambda (.x.330) (cons (.the.189 (cor",
"e#quote cons)) (cons (car .x.330) (cons (cadr .x.330) (core#quote ()))))) .forma",
"l.328) (core#quote ()))) (cons (cons .the-lambda.198 (cons (core#quote ()) (appe",
"nd .body.329 (core#quote ())))) (core#quote ()))))) (car (cdr .form.326)) (cdr (",
"cdr .form.326))))) (core#begin (.define-transformer.188 (core#quote syntax-quote",
") (core#lambda (.form.331 .env.332) ((core#lambda (.renames.333) ((core#lambda (",
".rename.334 .walk.335) (core#begin (core#set! .rename.334 (core#lambda (.var.336",
") ((core#lambda (.x.337) (core#if .x.337 (cadr .x.337) (core#begin (core#set! .r",
"enames.333 (cons (cons .var.336 (cons (make-identifier .var.336 .env.332) (cons ",
"(cons (.the.189 (core#quote make-identifier)) (cons (cons (core#quote quote) (co",
"ns .var.336 (core#quote ()))) (cons (cons (core#quote quote) (cons .env.332 (cor",
"e#quote ()))) (core#quote ())))) (core#quote ())))) .renames.333)) (.rename.334 ",
".var.336)))) (assq .var.336 .renames.333)))) (core#begin (core#set! .walk.335 (c",
"ore#lambda (.f.338 .form.339) (core#if (identifier? .form.339) (.f.338 .form.339",
") (core#if (pair? .form.339) (cons (.the.189 (core#quote cons)) (cons (cons (cor",
"e#quote walk) (cons (core#quote f) (cons (cons (core#quote car) (cons (core#quot",
"e form) (core#quote ()))) (core#quote ())))) (cons (cons (core#quote walk) (cons",
" (core#quote f) (cons (cons (core#quote cdr) (cons (core#quote form) (core#quote",
" ()))) (core#quote ())))) (core#quote ())))) (core#if (vector? .form.339) (cons ",
"(.the.189 (core#quote list->vector)) (cons (cons (core#quote walk) (cons (core#q",
"uote f) (cons (cons (core#quote vector->list) (cons (core#quote form) (core#quot",
"e ()))) (core#quote ())))) (core#quote ()))) (cons (.the.189 (core#quote quote))",
" (cons .form.339 (core#quote ())))))))) ((core#lambda (.form.340) (cons (.the.18",
"9 (core#quote let)) (cons (map cdr .renames.333) (cons .form.340 (core#quote ())",
")))) (.walk.335 .rename.334 (cadr .form.331)))))) #f #f)) (core#quote ())))) (co",
"re#begin (.define-transformer.188 (core#quote syntax-quasiquote) (core#lambda (.",
"form.341 .env.342) ((core#lambda (.renames.343) ((core#lambda (.rename.344) (cor",
"e#begin (core#set! .rename.344 (core#lambda (.var.349) ((core#lambda (.x.350) (c",
"ore#if .x.350 (cadr .x.350) (core#begin (core#set! .renames.343 (cons (cons .var",
".349 (cons (make-identifier .var.349 .env.342) (cons (cons (.the.189 (core#quote",
" make-identifier)) (cons (cons (core#quote quote) (cons .var.349 (core#quote ())",
")) (cons (cons (core#quote quote) (cons .env.342 (core#quote ()))) (core#quote (",
"))))) (core#quote ())))) .renames.343)) (.rename.344 .var.349)))) (assq .var.349",
" .renames.343)))) (core#begin (core#define .syntax-quasiquote?.345 (core#lambda ",
"(.form.351) (core#if (pair? .form.351) (core#if (identifier? (car .form.351)) (i",
"dentifier=? (.the.189 (core#quote syntax-quasiquote)) (make-identifier (car .for",
"m.351) .env.342)) #f) #f))) (core#begin (core#define .syntax-unquote?.346 (core#",
"lambda (.form.352) (core#if (pair? .form.352) (core#if (identifier? (car .form.3",
"52)) (identifier=? (.the.189 (core#quote syntax-unquote)) (make-identifier (car ",
".form.352) .env.342)) #f) #f))) (core#begin (core#define .syntax-unquote-splicin",
"g?.347 (core#lambda (.form.353) (core#if (pair? .form.353) (core#if (pair? (car ",
".form.353)) (core#if (identifier? (caar .form.353)) (identifier=? (.the.189 (cor",
"e#quote syntax-unquote-splicing)) (make-identifier (caar .form.353) .env.342)) #",
"f) #f) #f))) (core#begin (core#define .qq.348 (core#lambda (.depth.354 .expr.355",
") (core#if (.syntax-unquote?.346 .expr.355) (core#if (= .depth.354 1) (car (cdr ",
".expr.355)) (list (.the.189 (core#quote list)) (list (.the.189 (core#quote quote",
")) (.the.189 (core#quote syntax-unquote))) (.qq.348 (- .depth.354 1) (car (cdr .",
"expr.355))))) (core#if (.syntax-unquote-splicing?.347 .expr.355) (core#if (= .de",
"pth.354 1) (list (.the.189 (core#quote append)) (car (cdr (car .expr.355))) (.qq",
".348 .depth.354 (cdr .expr.355))) (list (.the.189 (core#quote cons)) (list (.the",
".189 (core#quote list)) (list (.the.189 (core#quote quote)) (.the.189 (core#quot",
"e syntax-unquote-splicing))) (.qq.348 (- .depth.354 1) (car (cdr (car .expr.355)",
")))) (.qq.348 .depth.354 (cdr .expr.355)))) (core#if (.syntax-quasiquote?.345 .e",
"xpr.355) (list (.the.189 (core#quote list)) (list (.the.189 (core#quote quote)) ",
"(.the.189 (core#quote quasiquote))) (.qq.348 (+ .depth.354 1) (car (cdr .expr.35",
"5)))) (core#if (pair? .expr.355) (list (.the.189 (core#quote cons)) (.qq.348 .de",
"pth.354 (car .expr.355)) (.qq.348 .depth.354 (cdr .expr.355))) (core#if (vector?",
" .expr.355) (list (.the.189 (core#quote list->vector)) (.qq.348 .depth.354 (vect",
"or->list .expr.355))) (core#if (identifier? .expr.355) (.rename.344 .expr.355) (",
"list (.the.189 (core#quote quote)) .expr.355))))))))) ((core#lambda (.body.356) ",
"(cons (.the.189 (core#quote let)) (cons (map cdr .renames.343) (cons .body.356 (",
"core#quote ()))))) (.qq.348 1 (cadr .form.341))))))))) #f)) (core#quote ())))) (",
"core#begin (.define-transformer.188 (core#quote define-syntax) (core#lambda (.fo",
"rm.357 .env.358) ((core#lambda (.formal.359 .body.360) (core#if (pair? .formal.3",
"59) (cons (.the.189 (core#quote define-syntax)) (cons (car .formal.359) (cons (c",
"ons .the-lambda.198 (cons (cdr .formal.359) (append .body.360 (core#quote ()))))",
" (core#quote ())))) (cons .the-define-macro.203 (cons .formal.359 (cons (cons (.",
"the.189 (core#quote transformer)) (cons (cons .the-begin.199 (append .body.360 (",
"core#quote ()))) (core#quote ()))) (core#quote ())))))) (car (cdr .form.357)) (c",
"dr (cdr .form.357))))) (core#begin (.define-transformer.188 (core#quote letrec-s",
"yntax) (core#lambda (.form.361 .env.362) ((core#lambda (.formal.363 .body.364) (",
"cons (core#quote let) (cons (core#quote ()) (append (map (core#lambda (.x.365) (",
"cons (.the.189 (core#quote define-syntax)) (cons (car .x.365) (cons (cadr .x.365",
") (core#quote ()))))) .formal.363) (append .body.364 (core#quote ())))))) (car (",
"cdr .form.361)) (cdr (cdr .form.361))))) (.define-transformer.188 (core#quote le",
"t-syntax) (core#lambda (.form.366 .env.367) (cons (.the.189 (core#quote letrec-s",
"yntax)) (append (cdr .form.366) (core#quote ()))))))))))))))))))))))))))))))))))",
")))))))))))))))))))))))))) ",
}; };
@ -202,67 +343,68 @@ static const char boot_library_rom[][80] = {
"m))) (or (null? form) (and (test (car form)) (loop (cdr form)))))) ((or) (let lo", "m))) (or (null? form) (and (test (car form)) (loop (cdr form)))))) ((or) (let lo",
"op ((form (cdr form))) (and (pair? form) (or (test (car form)) (loop (cdr form))", "op ((form (cdr form))) (and (pair? form) (or (test (car form)) (loop (cdr form))",
")))) (else #f))))))) (let loop ((clauses (cdr form))) (if (null? clauses) #undef", ")))) (else #f))))))) (let loop ((clauses (cdr form))) (if (null? clauses) #undef",
"ined (if (test (caar clauses)) `(,the-begin ,@(cdar clauses)) (loop (cdr clauses", "ined (if (test (caar clauses)) `(,(make-identifier 'begin default-environment) ,",
")))))))) (define-macro import (lambda (form _) (let ((caddr (lambda (x) (car (cd", "@(cdar clauses)) (loop (cdr clauses)))))))) (define-macro import (lambda (form _",
"r (cdr x))))) (prefix (lambda (prefix symbol) (string->symbol (string-append (sy", ") (let ((caddr (lambda (x) (car (cdr (cdr x))))) (prefix (lambda (prefix symbol)",
"mbol->string prefix) (symbol->string symbol))))) (getlib (lambda (name) (if (fin", " (string->symbol (string-append (symbol->string prefix) (symbol->string symbol))",
"d-library name) name (error \"library not found\" name))))) (letrec ((extract (lam", "))) (getlib (lambda (name) (if (find-library name) name (error \"library not foun",
"bda (spec) (case (car spec) ((only rename prefix except) (extract (cadr spec))) ", "d\" name))))) (letrec ((extract (lambda (spec) (case (car spec) ((only rename pre",
"(else (getlib spec))))) (collect (lambda (spec) (case (car spec) ((only) (let ((", "fix except) (extract (cadr spec))) (else (getlib spec))))) (collect (lambda (spe",
"alist (collect (cadr spec)))) (map (lambda (var) (assq var alist)) (cddr spec)))", "c) (case (car spec) ((only) (let ((alist (collect (cadr spec)))) (map (lambda (v",
") ((rename) (let ((alist (collect (cadr spec))) (renames (map (lambda (x) `(,(ca", "ar) (assq var alist)) (cddr spec)))) ((rename) (let ((alist (collect (cadr spec)",
"r x) unquote (cadr x))) (cddr spec)))) (map (lambda (s) (or (assq (car s) rename", ")) (renames (map (lambda (x) `(,(car x) unquote (cadr x))) (cddr spec)))) (map (",
"s) s)) alist))) ((prefix) (let ((alist (collect (cadr spec)))) (map (lambda (s) ", "lambda (s) (or (assq (car s) renames) s)) alist))) ((prefix) (let ((alist (colle",
"(cons (prefix (caddr spec) (car s)) (cdr s))) alist))) ((except) (let ((alist (c", "ct (cadr spec)))) (map (lambda (s) (cons (prefix (caddr spec) (car s)) (cdr s)))",
"ollect (cadr spec)))) (let loop ((alist alist)) (if (null? alist) '() (if (memq ", " alist))) ((except) (let ((alist (collect (cadr spec)))) (let loop ((alist alist",
"(caar alist) (cddr spec)) (loop (cdr alist)) (cons (car alist) (loop (cdr alist)", ")) (if (null? alist) '() (if (memq (caar alist) (cddr spec)) (loop (cdr alist)) ",
"))))))) (else (dictionary-map (lambda (x) (cons x x)) (library-exports (getlib s", "(cons (car alist) (loop (cdr alist)))))))) (else (dictionary-map (lambda (x) (co",
"pec)))))))) (letrec ((import (lambda (spec) (let ((lib (extract spec)) (alist (c", "ns x x)) (library-exports (getlib spec)))))))) (letrec ((import (lambda (spec) (",
"ollect spec))) (for-each (lambda (slot) (library-import lib (cdr slot) (car slot", "let ((lib (extract spec)) (alist (collect spec))) (for-each (lambda (slot) (libr",
"))) alist))))) (for-each import (cdr form))))))) (define-macro export (lambda (f", "ary-import lib (cdr slot) (car slot))) alist))))) (for-each import (cdr form))))",
"orm _) (letrec ((collect (lambda (spec) (cond ((symbol? spec) `(,spec unquote sp", "))) (define-macro export (lambda (form _) (letrec ((collect (lambda (spec) (cond",
"ec)) ((and (list? spec) (= (length spec) 3) (eq? (car spec) 'rename)) `(,(list-r", " ((symbol? spec) `(,spec unquote spec)) ((and (list? spec) (= (length spec) 3) (",
"ef spec 1) unquote (list-ref spec 2))) (else (error \"malformed export\"))))) (exp", "eq? (car spec) 'rename)) `(,(list-ref spec 1) unquote (list-ref spec 2))) (else ",
"ort (lambda (spec) (let ((slot (collect spec))) (library-export (car slot) (cdr ", "(error \"malformed export\"))))) (export (lambda (spec) (let ((slot (collect spec)",
"slot)))))) (for-each export (cdr form))))) (let () (make-library '(picrin base))", ")) (library-export (car slot) (cdr slot)))))) (for-each export (cdr form))))) (l",
" (set-car! (dictionary-ref *libraries* (mangle '(picrin base))) default-environm", "et () (make-library '(picrin base)) (set-car! (dictionary-ref *libraries* (mangl",
"ent) (let ((export-keywords (lambda (keywords) (let ((env (library-environment '", "e '(picrin base))) default-environment) (let ((export-keywords (lambda (keywords",
"(picrin base))) (exports (library-exports '(picrin base)))) (for-each (lambda (k", ") (let ((env (library-environment '(picrin base))) (exports (library-exports '(p",
"eyword) (dictionary-set! exports keyword keyword)) keywords))))) (export-keyword", "icrin base)))) (for-each (lambda (keyword) (dictionary-set! exports keyword keyw",
"s '(define lambda quote set! if begin define-macro let let* letrec letrec* let-v", "ord)) keywords))))) (export-keywords '(define lambda quote set! if begin define-",
"alues let*-values define-values quasiquote unquote unquote-splicing and or cond ", "macro let let* letrec letrec* let-values let*-values define-values quasiquote un",
"case else => do when unless parameterize define-syntax syntax-quote syntax-unquo", "quote unquote-splicing and or cond case else => do when unless parameterize defi",
"te syntax-quasiquote syntax-unquote-splicing let-syntax letrec-syntax syntax-err", "ne-syntax syntax-quote syntax-unquote syntax-quasiquote syntax-unquote-splicing ",
"or)) (export-keywords '(features eq? eqv? equal? not boolean? boolean=? pair? co", "let-syntax letrec-syntax syntax-error)) (export-keywords '(features eq? eqv? equ",
"ns car cdr null? set-car! set-cdr! caar cadr cdar cddr list? make-list list leng", "al? not boolean? boolean=? pair? cons car cdr null? set-car! set-cdr! caar cadr ",
"th append reverse list-tail list-ref list-set! list-copy map for-each memq memv ", "cdar cddr list? make-list list length append reverse list-tail list-ref list-set",
"member assq assv assoc current-input-port current-output-port current-error-port", "! list-copy map for-each memq memv member assq assv assoc current-input-port cur",
" port? input-port? output-port? port-open? close-port eof-object? eof-object rea", "rent-output-port current-error-port port? input-port? output-port? port-open? cl",
"d-u8 peek-u8 read-bytevector! write-u8 write-bytevector flush-output-port open-i", "ose-port eof-object? eof-object read-u8 peek-u8 read-bytevector! write-u8 write-",
"nput-bytevector open-output-bytevector get-output-bytevector number? exact? inex", "bytevector flush-output-port open-input-bytevector open-output-bytevector get-ou",
"act? inexact exact = < > <= >= + - * / number->string string->number procedure? ", "tput-bytevector number? exact? inexact? inexact exact = < > <= >= + - * / number",
"apply symbol? symbol=? symbol->string string->symbol make-identifier identifier?", "->string string->number procedure? apply symbol? symbol=? symbol->string string-",
" identifier=? identifier-base identifier-environment vector? vector make-vector ", ">symbol make-identifier identifier? identifier=? identifier-base identifier-envi",
"vector-length vector-ref vector-set! vector-copy! vector-copy vector-append vect", "ronment vector? vector make-vector vector-length vector-ref vector-set! vector-c",
"or-fill! vector-map vector-for-each list->vector vector->list string->vector vec", "opy! vector-copy vector-append vector-fill! vector-map vector-for-each list->vec",
"tor->string bytevector? bytevector make-bytevector bytevector-length bytevector-", "tor vector->list string->vector vector->string bytevector? bytevector make-bytev",
"u8-ref bytevector-u8-set! bytevector-copy! bytevector-copy bytevector-append byt", "ector bytevector-length bytevector-u8-ref bytevector-u8-set! bytevector-copy! by",
"evector->list list->bytevector call-with-current-continuation call/cc values cal", "tevector-copy bytevector-append bytevector->list list->bytevector call-with-curr",
"l-with-values char? char->integer integer->char char=? char<? char>? char<=? cha", "ent-continuation call/cc values call-with-values char? char->integer integer->ch",
"r>=? current-exception-handlers with-exception-handler raise raise-continuable e", "ar char=? char<? char>? char<=? char>=? current-exception-handlers with-exceptio",
"rror error-object? error-object-message error-object-irritants error-object-type", "n-handler raise raise-continuable error error-object? error-object-message error",
" string? string make-string string-length string-ref string-set! string-copy str", "-object-irritants error-object-type string? string make-string string-length str",
"ing-copy! string-fill! string-append string-map string-for-each list->string str", "ing-ref string-set! string-copy string-copy! string-fill! string-append string-m",
"ing->list string=? string<? string>? string<=? string>=? make-parameter with-dyn", "ap string-for-each list->string string->list string=? string<? string>? string<=",
"amic-environment read make-dictionary dictionary? dictionary dictionary-has? dic", "? string>=? make-parameter with-dynamic-environment read make-dictionary diction",
"tionary-ref dictionary-set! dictionary-delete! dictionary-size dictionary-map di", "ary? dictionary dictionary-has? dictionary-ref dictionary-set! dictionary-delete",
"ctionary-for-each dictionary->alist alist->dictionary dictionary->plist plist->d", "! dictionary-size dictionary-map dictionary-for-each dictionary->alist alist->di",
"ictionary make-record record? record-type record-datum default-environment make-", "ctionary dictionary->plist plist->dictionary make-record record? record-type rec",
"environment find-identifier set-identifier! eval make-ephemeron-table write writ", "ord-datum default-environment make-environment find-identifier set-identifier! e",
"e-simple write-shared display)) (export-keywords '(find-library make-library cur", "val compile add-macro! make-ephemeron-table write write-simple write-shared disp",
"rent-library))) (set! eval (let ((e eval)) (lambda (expr . lib) (let ((lib (if (", "lay)) (export-keywords '(find-library make-library current-library))) (set! eval",
"null? lib) (current-library) (car lib)))) (e expr (library-environment lib))))))", " (let ((e eval)) (lambda (expr . lib) (let ((lib (if (null? lib) (current-librar",
" (make-library '(picrin user)) (current-library '(picrin user))) ", "y) (car lib)))) (e expr (library-environment lib)))))) (make-library '(picrin us",
"er)) (current-library '(picrin user))) ",
}; };
#endif #endif
@ -270,7 +412,7 @@ static const char boot_library_rom[][80] = {
void void
pic_boot(pic_state *pic) pic_boot(pic_state *pic)
{ {
pic_load_cstr(pic, &boot_rom[0][0]); pic_call(pic, pic_compile(pic, pic_read_cstr(pic, &boot_rom[0][0])), 0);
#if PIC_USE_LIBRARY #if PIC_USE_LIBRARY
pic_load_cstr(pic, &boot_library_rom[0][0]); pic_load_cstr(pic, &boot_library_rom[0][0]);
#endif #endif

32
lib/ext/eval.c
View File

@ -128,7 +128,7 @@ pic_set_identifier(pic_state *pic, pic_value id, pic_value uid, pic_value env)
kh_val(&pic_env_ptr(pic, env)->map, it) = pic_sym_ptr(pic, uid); kh_val(&pic_env_ptr(pic, env)->map, it) = pic_sym_ptr(pic, uid);
} }
static pic_value pic_compile(pic_state *, pic_value); pic_value pic_compile(pic_state *, pic_value);
#define EQ(sym, lit) (strcmp(pic_sym(pic, sym), lit) == 0) #define EQ(sym, lit) (strcmp(pic_sym(pic, sym), lit) == 0)
#define S(lit) (pic_intern_lit(pic, lit)) #define S(lit) (pic_intern_lit(pic, lit))
@ -1179,7 +1179,7 @@ pic_codegen(pic_state *pic, pic_value obj)
#define SAVE(pic, ai, obj) pic_leave(pic, ai); pic_protect(pic, obj) #define SAVE(pic, ai, obj) pic_leave(pic, ai); pic_protect(pic, obj)
static pic_value pic_value
pic_compile(pic_state *pic, pic_value obj) pic_compile(pic_state *pic, pic_value obj)
{ {
struct irep *irep; struct irep *irep;
@ -1256,6 +1256,32 @@ pic_eval_find_identifier(pic_state *pic)
return pic_find_identifier(pic, id, env); return pic_find_identifier(pic, id, env);
} }
static pic_value
pic_eval_add_macro(pic_state *pic)
{
pic_value id, mac, uid;
pic_get_args(pic, "ol", &id, &mac);
TYPE_CHECK(pic, id, id);
uid = pic_find_identifier(pic, id, default_env(pic));
define_macro(pic, uid, mac);
return pic_undef_value(pic);
}
static pic_value
pic_eval_compile(pic_state *pic)
{
pic_value program, env = default_env(pic);
pic_get_args(pic, "o|o", &program, &env);
TYPE_CHECK(pic, env, env);
return pic_expand(pic, program, env);
}
static pic_value static pic_value
pic_eval_eval(pic_state *pic) pic_eval_eval(pic_state *pic)
{ {
@ -1293,5 +1319,7 @@ pic_init_eval(pic_state *pic)
pic_defun(pic, "make-environment", pic_eval_make_environment); pic_defun(pic, "make-environment", pic_eval_make_environment);
pic_defun(pic, "find-identifier", pic_eval_find_identifier); pic_defun(pic, "find-identifier", pic_eval_find_identifier);
pic_defun(pic, "set-identifier!", pic_eval_set_identifier); pic_defun(pic, "set-identifier!", pic_eval_set_identifier);
pic_defun(pic, "add-macro!", pic_eval_add_macro);
pic_defun(pic, "compile", pic_eval_compile);
pic_defun(pic, "eval", pic_eval_eval); pic_defun(pic, "eval", pic_eval_eval);
} }

2
lib/include/picrin/extra.h
View File

@ -24,6 +24,8 @@ void pic_load_cstr(pic_state *, const char *);
pic_value pic_fopen(pic_state *, FILE *, const char *mode); pic_value pic_fopen(pic_state *, FILE *, const char *mode);
#endif #endif
pic_value pic_compile(pic_state *, pic_value);
/* /*
* library * library

489
piclib/boot2.scm Normal file
View File

@ -0,0 +1,489 @@
(begin
;; FIXME
(define (transformer f)
(lambda (form env)
(let ((ephemeron1 (make-ephemeron-table))
(ephemeron2 (make-ephemeron-table)))
(letrec
((wrap (lambda (var1)
(let ((var2 (ephemeron1 var1)))
(if var2
(cdr var2)
(let ((var2 (make-identifier var1 env)))
(ephemeron1 var1 var2)
(ephemeron2 var2 var1)
var2)))))
(unwrap (lambda (var2)
(let ((var1 (ephemeron2 var2)))
(if var1
(cdr var1)
var2))))
(walk (lambda (f form)
(cond
((identifier? form)
(f form))
((pair? form)
(cons (walk f (car form)) (walk f (cdr form))))
((vector? form)
(list->vector (walk f (vector->list form))))
(else
form)))))
(let ((form (cdr form)))
(walk unwrap (apply f (walk wrap form))))))))
(let ()
(define (define-transformer name transformer)
(add-macro! name transformer))
(define (the var) ; synonym for #'var
(make-identifier var default-environment))
(define the-core-define (the 'core#define))
(define the-core-lambda (the 'core#lambda))
(define the-core-begin (the 'core#begin))
(define the-core-quote (the 'core#quote))
(define the-core-set! (the 'core#set!))
(define the-core-if (the 'core#if))
(define the-core-define-macro (the 'core#define-macro))
(define the-define (the 'define))
(define the-lambda (the 'lambda))
(define the-begin (the 'begin))
(define the-quote (the 'quote))
(define the-set! (the 'set!))
(define the-if (the 'if))
(define the-define-macro (the 'define-macro))
(define-transformer 'quote
(lambda (form env)
(if (= (length form) 2)
`(,the-core-quote ,(cadr form))
(error "malformed quote" form))))
(define-transformer 'if
(lambda (form env)
(let ((len (length form)))
(cond
((= len 3) `(,@form #undefined))
((= len 4) `(,the-core-if . ,(cdr form)))
(else (error "malformed if" form))))))
(define-transformer 'begin
(lambda (form env)
(let ((len (length form)))
(cond
((= len 1) #undefined)
((= len 2) (cadr form))
((= len 3) `(,the-core-begin . ,(cdr form)))
(else `(,the-core-begin ,(cadr form) (,the-begin . ,(cddr form))))))))
(define-transformer 'set!
(lambda (form env)
(if (and (= (length form) 3) (identifier? (cadr form)))
`(,the-core-set! . ,(cdr form))
(error "malformed set!" form))))
(define (check-formal formal)
(or (null? formal)
(identifier? formal)
(and (pair? formal)
(identifier? (car formal))
(check-formal (cdr formal)))))
(define-transformer 'lambda
(lambda (form env)
(if (= (length form) 1)
(error "malformed lambda" form)
(if (check-formal (cadr form))
`(,the-core-lambda ,(cadr form) (,the-begin . ,(cddr form)))
(error "malformed lambda" form)))))
(define-transformer 'define
(lambda (form env)
(let ((len (length form)))
(if (= len 1)
(error "malformed define" form)
(let ((formal (cadr form)))
(if (identifier? formal)
(if (= len 3)
`(,the-core-define . ,(cdr form))
(error "malformed define" form))
(if (pair? formal)
`(,the-define ,(car formal) (,the-lambda ,(cdr formal) . ,(cddr form)))
(error "define: binding to non-varaible object" form))))))))
(define-transformer 'define-macro
(lambda (form env)
(if (= (length form) 3)
(if (identifier? (cadr form))
`(,the-core-define-macro . ,(cdr form))
(error "define-macro: binding to non-variable object" form))
(error "malformed define-macro" form))))
(define-transformer 'syntax-error
(lambda (form _)
(apply error (cdr form))))
(define-macro define-auxiliary-syntax
(lambda (form _)
`(define-transformer ',(cadr form)
(lambda _
(error "invalid use of auxiliary syntax" ',(cadr form))))))
(define-auxiliary-syntax else)
(define-auxiliary-syntax =>)
(define-auxiliary-syntax unquote)
(define-auxiliary-syntax unquote-splicing)
(define-auxiliary-syntax syntax-unquote)
(define-auxiliary-syntax syntax-unquote-splicing)
(define-transformer 'let
(lambda (form env)
(if (identifier? (cadr form))
(let ((name (car (cdr form)))
(formal (car (cdr (cdr form))))
(body (cdr (cdr (cdr form)))))
`((,the-lambda ()
(,the-define (,name . ,(map car formal)) . ,body)
(,name . ,(map cadr formal)))))
(let ((formal (car (cdr form)))
(body (cdr (cdr form))))
`((,the-lambda ,(map car formal) . ,body) . ,(map cadr formal))))))
(define-transformer 'and
(lambda (form env)
(if (null? (cdr form))
#t
(if (null? (cddr form))
(cadr form)
`(,the-if ,(cadr form) (,(the 'and) . ,(cddr form)) #f)))))
(define-transformer 'or
(lambda (form env)
(if (null? (cdr form))
#f
(let ((tmp (make-identifier 'it env))) ; should we use #f as the env for tmp?
`(,(the 'let) ((,tmp ,(cadr form)))
(,the-if ,tmp ,tmp (,(the 'or) . ,(cddr form))))))))
(define-transformer 'cond
(lambda (form env)
(let ((clauses (cdr form)))
(if (null? clauses)
#undefined
(let ((clause (car clauses)))
(if (and (identifier? (car clause))
(identifier=? (the 'else) (make-identifier (car clause) env)))
`(,the-begin . ,(cdr clause))
(if (null? (cdr clause))
`(,(the 'or) ,(car clause) (,(the 'cond) . ,(cdr clauses)))
(if (and (identifier? (cadr clause))
(identifier=? (the '=>) (make-identifier (cadr clause) env)))
(let ((tmp (make-identifier 'tmp env)))
`(,(the 'let) ((,tmp ,(car clause)))
(,the-if ,tmp (,(cadr (cdr clause)) ,tmp) (,(the 'cond) . ,(cddr form)))))
`(,the-if ,(car clause)
(,the-begin . ,(cdr clause))
(,(the 'cond) . ,(cdr clauses)))))))))))
(define-transformer '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
((unquote? expr)
(if (= depth 1)
(cadr expr)
(list (the 'list)
(list (the 'quote) (the 'unquote))
(qq (- depth 1) (car (cdr expr))))))
;; unquote-splicing
((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 'unquote-splicing))
(qq (- depth 1) (car (cdr (car expr)))))
(qq depth (cdr expr)))))
;; quasiquote
((quasiquote? expr)
(list (the 'list)
(list (the 'quote) (the 'quasiquote))
(qq (+ depth 1) (car (cdr expr)))))
;; list
((pair? expr)
(list (the 'cons)
(qq depth (car expr))
(qq depth (cdr expr))))
;; vector
((vector? expr)
(list (the 'list->vector) (qq depth (vector->list expr))))
;; simple datum
(else
(list (the 'quote) expr))))
(let ((x (cadr form)))
(qq 1 x))))
(define-transformer 'let*
(lambda (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-transformer 'letrec
(lambda (form env)
`(,(the 'letrec*) . ,(cdr form))))
(define-transformer 'letrec*
(lambda (form env)
(let ((bindings (car (cdr form)))
(body (cdr (cdr form))))
(let ((variables (map (lambda (v) `(,v #undefined)) (map car bindings)))
(initials (map (lambda (v) `(,(the 'set!) ,@v)) bindings)))
`(,(the 'let) ,variables
,@initials
,@body)))))
(define-transformer 'let-values
(lambda (form env)
`(,(the 'let*-values) ,@(cdr form))))
(define-transformer '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-transformer 'define-values
(lambda (form env)
(let ((formal (car (cdr form)))
(body (cdr (cdr form))))
(let ((arguments (make-identifier 'arguments env)))
`(,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 () ,@body)
(,the-lambda
,arguments
,@(let loop ((formal formal) (args 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-transformer 'do
(lambda (form env)
(let ((bindings (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 env)))
`(,(the '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-transformer 'when
(lambda (form env)
(let ((test (car (cdr form)))
(body (cdr (cdr form))))
`(,the-if ,test
(,the-begin ,@body)
#undefined))))
(define-transformer 'unless
(lambda (form env)
(let ((test (car (cdr form)))
(body (cdr (cdr form))))
`(,the-if ,test
#undefined
(,the-begin ,@body)))))
(define-transformer 'case
(lambda (form env)
(let ((key (car (cdr form)))
(clauses (cdr (cdr form))))
(let ((the-key (make-identifier 'key env)))
`(,(the 'let) ((,the-key ,key))
,(let loop ((clauses clauses))
(if (null? clauses)
#undefined
(let ((clause (car clauses)))
`(,the-if ,(if (and (identifier? (car clause))
(identifier=? (the 'else) (make-identifier (car clause) env)))
#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-transformer 'parameterize
(lambda (form env)
(let ((formal (car (cdr form)))
(body (cdr (cdr form))))
`(,(the 'with-dynamic-environment)
(,(the 'list) ,@(map (lambda (x) `(,(the 'cons) ,(car x) ,(cadr x))) formal))
(,the-lambda () ,@body)))))
(define-transformer 'syntax-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)) . ,renames))
(rename var))))))
(walk (lambda (f form)
(cond
((identifier? form)
(f form))
((pair? form)
`(,(the 'cons) (walk f (car form)) (walk f (cdr form))))
((vector? form)
`(,(the 'list->vector) (walk f (vector->list form))))
(else
`(,(the 'quote) ,form))))))
(let ((form (walk rename (cadr form))))
`(,(the 'let)
,(map cdr renames)
,form))))))
(define-transformer '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-identifier) ',var ',env)) . ,renames))
(rename var)))))))
(define (syntax-quasiquote? form)
(and (pair? form)
(identifier? (car form))
(identifier=? (the 'syntax-quasiquote) (make-identifier (car form) env))))
(define (syntax-unquote? form)
(and (pair? form)
(identifier? (car form))
(identifier=? (the 'syntax-unquote) (make-identifier (car form) env))))
(define (syntax-unquote-splicing? form)
(and (pair? form)
(pair? (car form))
(identifier? (caar form))
(identifier=? (the 'syntax-unquote-splicing) (make-identifier (caar form) env))))
(define (qq depth expr)
(cond
;; syntax-unquote
((syntax-unquote? expr)
(if (= depth 1)
(car (cdr expr))
(list (the 'list)
(list (the 'quote) (the 'syntax-unquote))
(qq (- depth 1) (car (cdr expr))))))
;; syntax-unquote-splicing
((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
((syntax-quasiquote? expr)
(list (the 'list)
(list (the 'quote) (the 'quasiquote))
(qq (+ depth 1) (car (cdr expr)))))
;; list
((pair? expr)
(list (the 'cons)
(qq depth (car expr))
(qq depth (cdr expr))))
;; vector
((vector? expr)
(list (the 'list->vector) (qq depth (vector->list expr))))
;; identifier
((identifier? expr)
(rename expr))
;; simple datum
(else
(list (the 'quote) expr))))
(let ((body (qq 1 (cadr form))))
`(,(the 'let)
,(map cdr renames)
,body))))))
(define-transformer 'define-syntax
(lambda (form env)
(let ((formal (car (cdr form)))
(body (cdr (cdr form))))
(if (pair? formal)
`(,(the 'define-syntax) ,(car formal) (,the-lambda ,(cdr formal) ,@body))
`(,the-define-macro ,formal (,(the 'transformer) (,the-begin ,@body)))))))
(define-transformer 'letrec-syntax
(lambda (form env)
(let ((formal (car (cdr form)))
(body (cdr (cdr form))))
`(let ()
,@(map (lambda (x)
`(,(the 'define-syntax) ,(car x) ,(cadr x)))
formal)
,@body))))
(define-transformer 'let-syntax
(lambda (form env)
`(,(the 'letrec-syntax) ,@(cdr form))))))

4
piclib/library.scm
View File

@ -105,7 +105,7 @@
(if (null? clauses) (if (null? clauses)
#undefined #undefined
(if (test (caar clauses)) (if (test (caar clauses))
`(,the-begin ,@(cdar clauses)) `(,(make-identifier 'begin default-environment) ,@(cdar clauses))
(loop (cdr clauses)))))))) (loop (cdr clauses))))))))
(define-macro import (define-macro import
@ -256,7 +256,7 @@
dictionary->alist alist->dictionary dictionary->plist plist->dictionary dictionary->alist alist->dictionary dictionary->plist plist->dictionary
make-record record? record-type record-datum make-record record? record-type record-datum
default-environment make-environment find-identifier set-identifier! default-environment make-environment find-identifier set-identifier!
eval eval compile add-macro!
make-ephemeron-table make-ephemeron-table
write write-simple write-shared display)) write write-simple write-shared display))
(export-keywords (export-keywords

4
tools/mkboot.scm
View File

@ -65,7 +65,7 @@
"#include \"picrin/extra.h\"" "#include \"picrin/extra.h\""
"" ""
"static const char boot_rom[][80] = {" "static const char boot_rom[][80] = {"
,(generate-rom "piclib/boot.scm") ,(generate-rom "piclib/boot3.scm")
"};" "};"
"" ""
"#if PIC_USE_LIBRARY" "#if PIC_USE_LIBRARY"
@ -77,7 +77,7 @@
"void" "void"
"pic_boot(pic_state *pic)" "pic_boot(pic_state *pic)"
"{" "{"
" pic_load_cstr(pic, &boot_rom[0][0]);" " pic_call(pic, pic_compile(pic, pic_read_cstr(pic, &boot_rom[0][0])), 0);"
"#if PIC_USE_LIBRARY" "#if PIC_USE_LIBRARY"
" pic_load_cstr(pic, &boot_library_rom[0][0]);" " pic_load_cstr(pic, &boot_library_rom[0][0]);"
"#endif" "#endif"