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

WIP: reimplement library system in scheme

This commit is contained in:
Yuichi Nishiwaki 2017-04-02 19:16:25 +09:00
parent 4dd5e5b0d6
commit d319a57422
18 changed files with 540 additions and 1027 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

103
contrib/40.srfi/src/106.c
View File

@ -357,124 +357,121 @@ pic_init_srfi_106(pic_state *pic)
{
pic_deflibrary(pic, "srfi.106");
#define pic_defun_(pic, name, f) pic_define(pic, "srfi.106", name, pic_lambda(pic, f, 0))
#define pic_define_(pic, name, v) pic_define(pic, "srfi.106", name, v)
pic_defun_(pic, "socket?", pic_socket_socket_p);
pic_defun_(pic, "make-socket", pic_socket_make_socket);
pic_defun_(pic, "socket-accept", pic_socket_socket_accept);
pic_defun_(pic, "socket-send", pic_socket_socket_send);
pic_defun_(pic, "socket-recv", pic_socket_socket_recv);
pic_defun_(pic, "socket-shutdown", pic_socket_socket_shutdown);
pic_defun_(pic, "socket-close", pic_socket_socket_close);
pic_defun_(pic, "socket-input-port", pic_socket_socket_input_port);
pic_defun_(pic, "socket-output-port", pic_socket_socket_output_port);
pic_defun_(pic, "call-with-socket", pic_socket_call_with_socket);
pic_defun(pic, "socket?", pic_socket_socket_p);
pic_defun(pic, "make-socket", pic_socket_make_socket);
pic_defun(pic, "socket-accept", pic_socket_socket_accept);
pic_defun(pic, "socket-send", pic_socket_socket_send);
pic_defun(pic, "socket-recv", pic_socket_socket_recv);
pic_defun(pic, "socket-shutdown", pic_socket_socket_shutdown);
pic_defun(pic, "socket-close", pic_socket_socket_close);
pic_defun(pic, "socket-input-port", pic_socket_socket_input_port);
pic_defun(pic, "socket-output-port", pic_socket_socket_output_port);
pic_defun(pic, "call-with-socket", pic_socket_call_with_socket);
#ifdef AF_INET
pic_define_(pic, "*af-inet*", pic_int_value(pic, AF_INET));
pic_define(pic, "*af-inet*", pic_int_value(pic, AF_INET));
#else
pic_define_(pic, "*af-inet*", pic_false_value(pic));
pic_define(pic, "*af-inet*", pic_false_value(pic));
#endif
#ifdef AF_INET6
pic_define_(pic, "*af-inet6*", pic_int_value(pic, AF_INET6));
pic_define(pic, "*af-inet6*", pic_int_value(pic, AF_INET6));
#else
pic_define_(pic, "*af-inet6*", pic_false_value(pic));
pic_define(pic, "*af-inet6*", pic_false_value(pic));
#endif
#ifdef AF_UNSPEC
pic_define_(pic, "*af-unspec*", pic_int_value(pic, AF_UNSPEC));
pic_define(pic, "*af-unspec*", pic_int_value(pic, AF_UNSPEC));
#else
pic_define_(pic, "*af-unspec*", pic_false_value(pic));
pic_define(pic, "*af-unspec*", pic_false_value(pic));
#endif
#ifdef SOCK_STREAM
pic_define_(pic, "*sock-stream*", pic_int_value(pic, SOCK_STREAM));
pic_define(pic, "*sock-stream*", pic_int_value(pic, SOCK_STREAM));
#else
pic_define_(pic, "*sock-stream*", pic_false_value(pic));
pic_define(pic, "*sock-stream*", pic_false_value(pic));
#endif
#ifdef SOCK_DGRAM
pic_define_(pic, "*sock-dgram*", pic_int_value(pic, SOCK_DGRAM));
pic_define(pic, "*sock-dgram*", pic_int_value(pic, SOCK_DGRAM));
#else
pic_define_(pic, "*sock-dgram*", pic_false_value(pic));
pic_define(pic, "*sock-dgram*", pic_false_value(pic));
#endif
#ifdef AI_CANONNAME
pic_define_(pic, "*ai-canonname*", pic_int_value(pic, AI_CANONNAME));
pic_define(pic, "*ai-canonname*", pic_int_value(pic, AI_CANONNAME));
#else
pic_define_(pic, "*ai-canonname*", pic_false_value(pic));
pic_define(pic, "*ai-canonname*", pic_false_value(pic));
#endif
#ifdef AI_NUMERICHOST
pic_define_(pic, "*ai-numerichost*", pic_int_value(pic, AI_NUMERICHOST));
pic_define(pic, "*ai-numerichost*", pic_int_value(pic, AI_NUMERICHOST));
#else
pic_define_(pic, "*ai-numerichost*", pic_false_value(pic));
pic_define(pic, "*ai-numerichost*", pic_false_value(pic));
#endif
/* AI_V4MAPPED and AI_ALL are not supported by *BSDs, even though they are defined in netdb.h. */
#if defined(AI_V4MAPPED) && !defined(BSD)
pic_define_(pic, "*ai-v4mapped*", pic_int_value(pic, AI_V4MAPPED));
pic_define(pic, "*ai-v4mapped*", pic_int_value(pic, AI_V4MAPPED));
#else
pic_define_(pic, "*ai-v4mapped*", pic_false_value(pic));
pic_define(pic, "*ai-v4mapped*", pic_false_value(pic));
#endif
#if defined(AI_ALL) && !defined(BSD)
pic_define_(pic, "*ai-all*", pic_int_value(pic, AI_ALL));
pic_define(pic, "*ai-all*", pic_int_value(pic, AI_ALL));
#else
pic_define_(pic, "*ai-all*", pic_false_value(pic));
pic_define(pic, "*ai-all*", pic_false_value(pic));
#endif
#ifdef AI_ADDRCONFIG
pic_define_(pic, "*ai-addrconfig*", pic_int_value(pic, AI_ADDRCONFIG));
pic_define(pic, "*ai-addrconfig*", pic_int_value(pic, AI_ADDRCONFIG));
#else
pic_define_(pic, "*ai-addrconfig*", pic_false_value(pic));
pic_define(pic, "*ai-addrconfig*", pic_false_value(pic));
#endif
#ifdef AI_PASSIVE
pic_define_(pic, "*ai-passive*", pic_int_value(pic, AI_PASSIVE));
pic_define(pic, "*ai-passive*", pic_int_value(pic, AI_PASSIVE));
#else
pic_define_(pic, "*ai-passive*", pic_false_value(pic));
pic_define(pic, "*ai-passive*", pic_false_value(pic));
#endif
#ifdef IPPROTO_IP
pic_define_(pic, "*ipproto-ip*", pic_int_value(pic, IPPROTO_IP));
pic_define(pic, "*ipproto-ip*", pic_int_value(pic, IPPROTO_IP));
#else
pic_define_(pic, "*ipproto-ip*", pic_false_value(pic));
pic_define(pic, "*ipproto-ip*", pic_false_value(pic));
#endif
#ifdef IPPROTO_TCP
pic_define_(pic, "*ipproto-tcp*", pic_int_value(pic, IPPROTO_TCP));
pic_define(pic, "*ipproto-tcp*", pic_int_value(pic, IPPROTO_TCP));
#else
pic_define_(pic, "*ipproto-tcp*", pic_false_value(pic));
pic_define(pic, "*ipproto-tcp*", pic_false_value(pic));
#endif
#ifdef IPPROTO_UDP
pic_define_(pic, "*ipproto-udp*", pic_int_value(pic, IPPROTO_UDP));
pic_define(pic, "*ipproto-udp*", pic_int_value(pic, IPPROTO_UDP));
#else
pic_define_(pic, "*ipproto-udp*", pic_false_value(pic));
pic_define(pic, "*ipproto-udp*", pic_false_value(pic));
#endif
#ifdef MSG_PEEK
pic_define_(pic, "*msg-peek*", pic_int_value(pic, MSG_PEEK));
pic_define(pic, "*msg-peek*", pic_int_value(pic, MSG_PEEK));
#else
pic_define_(pic, "*msg-peek*", pic_false_value(pic));
pic_define(pic, "*msg-peek*", pic_false_value(pic));
#endif
#ifdef MSG_OOB
pic_define_(pic, "*msg-oob*", pic_int_value(pic, MSG_OOB));
pic_define(pic, "*msg-oob*", pic_int_value(pic, MSG_OOB));
#else
pic_define_(pic, "*msg-oob*", pic_false_value(pic));
pic_define(pic, "*msg-oob*", pic_false_value(pic));
#endif
#ifdef MSG_WAITALL
pic_define_(pic, "*msg-waitall*", pic_int_value(pic, MSG_WAITALL));
pic_define(pic, "*msg-waitall*", pic_int_value(pic, MSG_WAITALL));
#else
pic_define_(pic, "*msg-waitall*", pic_false_value(pic));
pic_define(pic, "*msg-waitall*", pic_false_value(pic));
#endif
#ifdef SHUT_RD
pic_define_(pic, "*shut-rd*", pic_int_value(pic, SHUT_RD));
pic_define(pic, "*shut-rd*", pic_int_value(pic, SHUT_RD));
#else
pic_define_(pic, "*shut-rd*", pic_false_value(pic));
pic_define(pic, "*shut-rd*", pic_false_value(pic));
#endif
#ifdef SHUT_WR
pic_define_(pic, "*shut-wr*", pic_int_value(pic, SHUT_WR));
pic_define(pic, "*shut-wr*", pic_int_value(pic, SHUT_WR));
#else
pic_define_(pic, "*shut-wr*", pic_false_value(pic));
pic_define(pic, "*shut-wr*", pic_false_value(pic));
#endif
#ifdef SHUT_RDWR
pic_define_(pic, "*shut-rdwr*", pic_int_value(pic, SHUT_RDWR));
pic_define(pic, "*shut-rdwr*", pic_int_value(pic, SHUT_RDWR));
#else
pic_define_(pic, "*shut-rdwr*", pic_false_value(pic));
pic_define(pic, "*shut-rdwr*", pic_false_value(pic));
#endif
}

14
lib/error.c
View File

@ -28,6 +28,8 @@ pic_warnf(pic_state *pic, const char *fmt, ...)
pic_fprintf(pic, pic_stderr(pic), "warn: %s\n", pic_str(pic, err, NULL));
}
#define pic_exc(pic) pic_ref(pic, "current-exception-handlers")
static pic_value
native_exception_handler(pic_state *pic)
{
@ -57,7 +59,7 @@ pic_start_try(pic_state *pic, PIC_JMPBUF *jmp)
/* with-exception-handler */
var = pic_ref(pic, "picrin.base", "current-exception-handlers");
var = pic_exc(pic);
env = pic_make_weak(pic);
pic_weak_set(pic, env, var, pic_cons(pic, handler, pic_call(pic, var, 0)));
pic->dyn_env = pic_cons(pic, env, pic->dyn_env);
@ -97,9 +99,9 @@ pic_make_error(pic_state *pic, const char *type, const char *msg, pic_value irrs
static pic_value
with_exception_handlers(pic_state *pic, pic_value handlers, pic_value thunk)
{
pic_value alist, var = pic_ref(pic, "picrin.base", "current-exception-handlers");
pic_value alist, var = pic_exc(pic);
alist = pic_list(pic, 1, pic_cons(pic, var, handlers));
return pic_funcall(pic, "picrin.base", "with-dynamic-environment", 2, alist, thunk);
return pic_funcall(pic, "with-dynamic-environment", 2, alist, thunk);
}
static pic_value
@ -124,7 +126,7 @@ on_raise(pic_state *pic)
pic_value
pic_raise_continuable(pic_state *pic, pic_value err)
{
pic_value handlers, var = pic_ref(pic, "picrin.base", "current-exception-handlers"), thunk;
pic_value handlers, var = pic_exc(pic), thunk;
handlers = pic_call(pic, var, 0);
@ -138,7 +140,7 @@ pic_raise_continuable(pic_state *pic, pic_value err)
void
pic_raise(pic_state *pic, pic_value err)
{
pic_value handlers, var = pic_ref(pic, "picrin.base", "current-exception-handlers"), thunk;
pic_value handlers, var = pic_exc(pic), thunk;
handlers = pic_call(pic, var, 0);
@ -166,7 +168,7 @@ static pic_value
pic_error_with_exception_handler(pic_state *pic)
{
pic_value handler, thunk;
pic_value handlers, exc = pic_ref(pic, "picrin.base", "current-exception-handlers");
pic_value handlers, exc = pic_exc(pic);
pic_get_args(pic, "ll", &handler, &thunk);

372
lib/ext/boot.c
View File

@ -2,215 +2,169 @@
#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) ",
"(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)))) ",
};
void

275
lib/ext/eval.c
View File

@ -8,6 +8,126 @@
#include "state.h"
#include "vm.h"
pic_value pic_expand(pic_state *pic, pic_value expr, pic_value env);
KHASH_DEFINE(env, struct identifier *, symbol *, kh_ptr_hash_func, kh_ptr_hash_equal)
pic_value
pic_make_env(pic_state *pic, pic_value prefix)
{
struct env *env;
env = (struct env *)pic_obj_alloc(pic, sizeof(struct env), PIC_TYPE_ENV);
env->up = NULL;
env->prefix = pic_str_ptr(pic, prefix);
kh_init(env, &env->map);
return obj_value(pic, env);
}
static pic_value
default_env(pic_state *pic)
{
return pic_ref(pic, "default-environment");
}
static pic_value
extend_env(pic_state *pic, pic_value up)
{
struct env *env;
env = (struct env *)pic_obj_alloc(pic, sizeof(struct env), PIC_TYPE_ENV);
env->up = pic_env_ptr(pic, up);
env->prefix = NULL;
kh_init(env, &env->map);
return obj_value(pic, env);
}
static bool
search_scope(pic_state *pic, pic_value id, pic_value env, pic_value *uid)
{
int it;
it = kh_get(env, &pic_env_ptr(pic, env)->map, pic_id_ptr(pic, id));
if (it == kh_end(&pic_env_ptr(pic, env)->map)) {
return false;
}
*uid = obj_value(pic, kh_val(&pic_env_ptr(pic, env)->map, it));
return true;
}
static bool
search(pic_state *pic, pic_value id, pic_value env, pic_value *uid)
{
struct env *e;
while (1) {
if (search_scope(pic, id, env, uid))
return true;
e = pic_env_ptr(pic, env)->up;
if (e == NULL)
break;
env = obj_value(pic, e);
}
return false;
}
pic_value
pic_find_identifier(pic_state *pic, pic_value id, pic_value env)
{
struct env *e;
pic_value uid;
while (! search(pic, id, env, &uid)) {
if (pic_sym_p(pic, id)) {
while (1) {
e = pic_env_ptr(pic, env);
if (e->up == NULL)
break;
env = obj_value(pic, e->up);
}
return pic_add_identifier(pic, id, env);
}
env = obj_value(pic, pic_id_ptr(pic, id)->env); /* do not overwrite id first */
id = obj_value(pic, pic_id_ptr(pic, id)->u.id);
}
return uid;
}
pic_value
pic_add_identifier(pic_state *pic, pic_value id, pic_value env)
{
const char *name, *prefix;
pic_value uid, str;
if (search_scope(pic, id, env, &uid)) {
return uid;
}
name = pic_str(pic, pic_id_name(pic, id), NULL);
if (pic_env_ptr(pic, env)->up == NULL && pic_sym_p(pic, id)) {
prefix = pic_str(pic, obj_value(pic, pic_env_ptr(pic, env)->prefix), NULL);
str = pic_strf_value(pic, "%s%s", prefix, name);
} else {
str = pic_strf_value(pic, ".%s.%d", name, pic->ucnt++);
}
uid = pic_intern(pic, str);
pic_set_identifier(pic, id, uid, env);
return uid;
}
void
pic_set_identifier(pic_state *pic, pic_value id, pic_value uid, pic_value env)
{
int it, ret;
it = kh_put(env, &pic_env_ptr(pic, env)->map, pic_id_ptr(pic, id), &ret);
kh_val(&pic_env_ptr(pic, env)->map, it) = pic_sym_ptr(pic, uid);
}
static pic_value pic_compile(pic_state *, pic_value);
#define EQ(sym, lit) (strcmp(pic_sym(pic, sym), lit) == 0)
@ -61,7 +181,7 @@ expand_var(pic_state *pic, pic_value id, pic_value env, pic_value deferred)
static pic_value
expand_quote(pic_state *pic, pic_value expr)
{
return pic_cons(pic, S("quote"), pic_cdr(pic, expr));
return pic_cons(pic, S("core#quote"), pic_cdr(pic, expr));
}
static pic_value
@ -119,7 +239,7 @@ expand_lambda(pic_state *pic, pic_value expr, pic_value env)
pic_value in;
pic_value a, deferred;
in = pic_make_env(pic, env);
in = extend_env(pic, env);
for (a = pic_cadr(pic, expr); pic_pair_p(pic, a); a = pic_cdr(pic, a)) {
pic_add_identifier(pic, pic_car(pic, a), in);
@ -135,7 +255,7 @@ expand_lambda(pic_state *pic, pic_value expr, pic_value env)
expand_deferred(pic, deferred, in);
return pic_list(pic, 3, S("lambda"), formal, body);
return pic_list(pic, 3, S("core#lambda"), formal, body);
}
static pic_value
@ -149,7 +269,7 @@ expand_define(pic_state *pic, pic_value expr, pic_value env, pic_value deferred)
val = expand(pic, pic_list_ref(pic, expr, 2), env, deferred);
return pic_list(pic, 3, S("define"), uid, val);
return pic_list(pic, 3, S("core#define"), uid, val);
}
static pic_value
@ -189,16 +309,16 @@ expand_node(pic_state *pic, pic_value expr, pic_value env, pic_value deferred)
functor = pic_find_identifier(pic, pic_car(pic, expr), env);
if (EQ(functor, "define-macro")) {
if (EQ(functor, "core#define-macro")) {
return expand_defmacro(pic, expr, env);
}
else if (EQ(functor, "lambda")) {
else if (EQ(functor, "core#lambda")) {
return expand_defer(pic, expr, deferred);
}
else if (EQ(functor, "define")) {
else if (EQ(functor, "core#define")) {
return expand_define(pic, expr, env, deferred);
}
else if (EQ(functor, "quote")) {
else if (EQ(functor, "core#quote")) {
return expand_quote(pic, expr);
}
@ -255,10 +375,10 @@ optimize_beta(pic_state *pic, pic_value expr)
if (pic_sym_p(pic, pic_list_ref(pic, expr, 0))) {
pic_value sym = pic_list_ref(pic, expr, 0);
if (EQ(sym, "quote")) {
if (EQ(sym, "core#quote")) {
return expr;
} else if (EQ(sym, "lambda")) {
return pic_list(pic, 3, S("lambda"), pic_list_ref(pic, expr, 1), optimize_beta(pic, pic_list_ref(pic, expr, 2)));
} else if (EQ(sym, "core#lambda")) {
return pic_list(pic, 3, S("core#lambda"), pic_list_ref(pic, expr, 1), optimize_beta(pic, pic_list_ref(pic, expr, 2)));
}
}
@ -272,7 +392,7 @@ optimize_beta(pic_state *pic, pic_value expr)
pic_protect(pic, expr);
functor = pic_list_ref(pic, expr, 0);
if (pic_pair_p(pic, functor) && pic_sym_p(pic, pic_car(pic, functor)) && EQ(pic_car(pic, functor), "lambda")) {
if (pic_pair_p(pic, functor) && pic_sym_p(pic, pic_car(pic, functor)) && EQ(pic_car(pic, functor), "core#lambda")) {
formals = pic_list_ref(pic, functor, 1);
if (! pic_list_p(pic, formals))
goto exit; /* TODO: support ((lambda args x) 1 2) */
@ -281,12 +401,12 @@ optimize_beta(pic_state *pic, pic_value expr)
goto exit;
defs = pic_nil_value(pic);
pic_for_each (val, args, it) {
pic_push(pic, pic_list(pic, 3, S("define"), pic_car(pic, formals), val), defs);
pic_push(pic, pic_list(pic, 3, S("core#define"), pic_car(pic, formals), val), defs);
formals = pic_cdr(pic, formals);
}
expr = pic_list_ref(pic, functor, 2);
pic_for_each (val, defs, it) {
expr = pic_list(pic, 3, S("begin"), val, expr);
expr = pic_list(pic, 3, S("core#begin"), val, expr);
}
}
exit:
@ -316,7 +436,7 @@ normalize_body(pic_state *pic, pic_value expr, bool in)
if (! in) {
return v;
}
return pic_list(pic, 3, S("let"), pic_car(pic, locals), v);
return pic_list(pic, 3, S("core#let"), pic_car(pic, locals), v);
}
static pic_value
@ -334,7 +454,7 @@ normalize(pic_state *pic, pic_value expr, pic_value locals, bool in)
if (pic_sym_p(pic, proc)) {
pic_value sym = proc;
if (EQ(sym, "define")) {
if (EQ(sym, "core#define")) {
pic_value var, val;
var = pic_list_ref(pic, expr, 1);
@ -359,12 +479,12 @@ normalize(pic_state *pic, pic_value expr, pic_value locals, bool in)
}
}
val = normalize(pic, pic_list_ref(pic, expr, 2), locals, in);
return pic_list(pic, 3, S("set!"), var, val);
return pic_list(pic, 3, S("core#set!"), var, val);
}
else if (EQ(sym, "lambda")) {
return pic_list(pic, 3, S("lambda"), pic_list_ref(pic, expr, 1), normalize_body(pic, pic_list_ref(pic, expr, 2), true));
else if (EQ(sym, "core#lambda")) {
return pic_list(pic, 3, S("core#lambda"), pic_list_ref(pic, expr, 1), normalize_body(pic, pic_list_ref(pic, expr, 2), true));
}
else if (EQ(sym, "quote")) {
else if (EQ(sym, "core#quote")) {
return expr;
}
}
@ -450,11 +570,11 @@ analyze_var(pic_state *pic, analyze_scope *scope, pic_value sym)
depth = find_var(pic, scope, sym);
if (depth == scope->depth) {
return pic_list(pic, 2, S("gref"), sym);
return pic_list(pic, 2, S("core#gref"), sym);
} else if (depth == 0) {
return pic_list(pic, 2, S("lref"), sym);
return pic_list(pic, 2, S("core#lref"), sym);
} else {
return pic_list(pic, 3, S("cref"), pic_int_value(pic, depth), sym);
return pic_list(pic, 3, S("core#cref"), pic_int_value(pic, depth), sym);
}
}
@ -473,7 +593,7 @@ analyze_lambda(pic_state *pic, analyze_scope *up, pic_value form)
/* analyze body */
body = analyze(pic, scope, body);
return pic_list(pic, 5, S("lambda"), args, locals, scope->captures, body);
return pic_list(pic, 5, S("core#lambda"), args, locals, scope->captures, body);
}
static pic_value
@ -491,7 +611,7 @@ analyze_list(pic_state *pic, analyze_scope *scope, pic_value obj)
static pic_value
analyze_call(pic_state *pic, analyze_scope *scope, pic_value obj)
{
return pic_cons(pic, S("call"), analyze_list(pic, scope, obj));
return pic_cons(pic, S("core#call"), analyze_list(pic, scope, obj));
}
static pic_value
@ -512,13 +632,13 @@ analyze_node(pic_state *pic, analyze_scope *scope, pic_value obj)
if (pic_sym_p(pic, proc)) {
pic_value sym = proc;
if (EQ(sym, "lambda")) {
if (EQ(sym, "core#lambda")) {
return analyze_lambda(pic, scope, obj);
}
else if (EQ(sym, "quote")) {
else if (EQ(sym, "core#quote")) {
return obj;
}
else if (EQ(sym, "begin") || EQ(sym, "set!") || EQ(sym, "if")) {
else if (EQ(sym, "core#begin") || EQ(sym, "core#set!") || EQ(sym, "core#if")) {
return pic_cons(pic, pic_car(pic, obj), analyze_list(pic, scope, pic_cdr(pic, obj)));
}
}
@ -526,7 +646,7 @@ analyze_node(pic_state *pic, analyze_scope *scope, pic_value obj)
return analyze_call(pic, scope, obj);
}
default:
return pic_list(pic, 2, S("quote"), obj);
return pic_list(pic, 2, S("core#quote"), obj);
}
}
@ -703,22 +823,22 @@ struct {
int insn;
int argc;
} pic_vm_proc[] = {
{ "picrin.base/cons", OP_CONS, 2 },
{ "picrin.base/car", OP_CAR, 1 },
{ "picrin.base/cdr", OP_CDR, 1 },
{ "picrin.base/null?", OP_NILP, 1 },
{ "picrin.base/symbol?", OP_SYMBOLP, 1 },
{ "picrin.base/pair?", OP_PAIRP, 1 },
{ "picrin.base/not", OP_NOT, 1 },
{ "picrin.base/=", OP_EQ, 2 },
{ "picrin.base/<", OP_LT, 2 },
{ "picrin.base/<=", OP_LE, 2 },
{ "picrin.base/>", OP_GT, 2 },
{ "picrin.base/>=", OP_GE, 2 },
{ "picrin.base/+", OP_ADD, 2 },
{ "picrin.base/-", OP_SUB, 2 },
{ "picrin.base/*", OP_MUL, 2 },
{ "picrin.base//", OP_DIV, 2 }
{ "cons", OP_CONS, 2 },
{ "car", OP_CAR, 1 },
{ "cdr", OP_CDR, 1 },
{ "null?", OP_NILP, 1 },
{ "symbol?", OP_SYMBOLP, 1 },
{ "pair?", OP_PAIRP, 1 },
{ "not", OP_NOT, 1 },
{ "=", OP_EQ, 2 },
{ "<", OP_LT, 2 },
{ "<=", OP_LE, 2 },
{ ">", OP_GT, 2 },
{ ">=", OP_GE, 2 },
{ "+", OP_ADD, 2 },
{ "-", OP_SUB, 2 },
{ "*", OP_MUL, 2 },
{ "/", OP_DIV, 2 }
};
static int
@ -794,14 +914,14 @@ codegen_ref(pic_state *pic, codegen_context *cxt, pic_value obj, bool tailpos)
pic_value sym;
sym = pic_car(pic, obj);
if (EQ(sym, "gref")) {
if (EQ(sym, "core#gref")) {
pic_value name;
name = pic_list_ref(pic, obj, 1);
emit_i(pic, cxt, OP_GREF, index_global(pic, cxt, name));
emit_ret(pic, cxt, tailpos);
}
else if (EQ(sym, "cref")) {
else if (EQ(sym, "core#cref")) {
pic_value name;
int depth;
@ -810,7 +930,7 @@ codegen_ref(pic_state *pic, codegen_context *cxt, pic_value obj, bool tailpos)
emit_r(pic, cxt, OP_CREF, depth, index_capture(pic, cxt, name, depth));
emit_ret(pic, cxt, tailpos);
}
else if (EQ(sym, "lref")) {
else if (EQ(sym, "core#lref")) {
pic_value name;
int i;
@ -836,7 +956,7 @@ codegen_set(pic_state *pic, codegen_context *cxt, pic_value obj, bool tailpos)
var = pic_list_ref(pic, obj, 1);
type = pic_list_ref(pic, var, 0);
if (EQ(type, "gref")) {
if (EQ(type, "core#gref")) {
pic_value name;
size_t i;
@ -850,7 +970,7 @@ codegen_set(pic_state *pic, codegen_context *cxt, pic_value obj, bool tailpos)
emit_i(pic, cxt, OP_GSET, index_global(pic, cxt, name));
emit_ret(pic, cxt, tailpos);
}
else if (EQ(type, "cref")) {
else if (EQ(type, "core#cref")) {
pic_value name;
int depth;
@ -859,7 +979,7 @@ codegen_set(pic_state *pic, codegen_context *cxt, pic_value obj, bool tailpos)
emit_r(pic, cxt, OP_CSET, depth, index_capture(pic, cxt, name, depth));
emit_ret(pic, cxt, tailpos);
}
else if (EQ(type, "lref")) {
else if (EQ(type, "core#lref")) {
pic_value name;
int i;
@ -989,7 +1109,7 @@ codegen_call(pic_state *pic, codegen_context *cxt, pic_value obj, bool tailpos)
pic_value elt, it, functor;
functor = pic_list_ref(pic, obj, 1);
if (EQ(pic_list_ref(pic, functor, 0), "gref")) {
if (EQ(pic_list_ref(pic, functor, 0), "core#gref")) {
pic_value sym;
size_t i;
@ -1019,25 +1139,25 @@ codegen(pic_state *pic, codegen_context *cxt, pic_value obj, bool tailpos)
pic_value sym;
sym = pic_car(pic, obj);
if (EQ(sym, "gref") || EQ(sym, "cref") || EQ(sym, "lref")) {
if (EQ(sym, "core#gref") || EQ(sym, "core#cref") || EQ(sym, "core#lref")) {
codegen_ref(pic, cxt, obj, tailpos);
}
else if (EQ(sym, "set!") || EQ(sym, "define")) {
else if (EQ(sym, "core#set!") || EQ(sym, "core#define")) {
codegen_set(pic, cxt, obj, tailpos);
}
else if (EQ(sym, "lambda")) {
else if (EQ(sym, "core#lambda")) {
codegen_lambda(pic, cxt, obj, tailpos);
}
else if (EQ(sym, "if")) {
else if (EQ(sym, "core#if")) {
codegen_if(pic, cxt, obj, tailpos);
}
else if (EQ(sym, "begin")) {
else if (EQ(sym, "core#begin")) {
codegen_begin(pic, cxt, obj, tailpos);
}
else if (EQ(sym, "quote")) {
else if (EQ(sym, "core#quote")) {
codegen_quote(pic, cxt, obj, tailpos);
}
else if (EQ(sym, "call")) {
else if (EQ(sym, "core#call")) {
codegen_call(pic, cxt, obj, tailpos);
}
else {
@ -1099,40 +1219,39 @@ pic_compile(pic_state *pic, pic_value obj)
return pic_make_proc_irep(pic, irep, NULL);
}
pic_value
pic_eval(pic_state *pic, pic_value program, const char *lib)
static pic_value
pic_eval_eval(pic_state *pic)
{
const char *prev_lib = pic_current_library(pic);
pic_value env, r, e;
pic_value program, env = default_env(pic), r, e;
env = pic_library_environment(pic, lib);
pic_get_args(pic, "o|o", &program, &env);
pic_in_library(pic, lib);
pic_try {
r = pic_call(pic, pic_compile(pic, pic_expand(pic, program, env)), 0);
}
pic_catch(e) {
pic_in_library(pic, prev_lib);
pic_raise(pic, e);
}
pic_in_library(pic, prev_lib);
return r;
}
static pic_value
pic_eval_eval(pic_state *pic)
{
pic_value program;
const char *str;
pic_get_args(pic, "oz", &program, &str);
return pic_eval(pic, program, str);
}
#define add_keyword(name) do { \
pic_value var; \
var = pic_intern_lit(pic, name); \
pic_set_identifier(pic, var, var, env); \
} while (0)
void
pic_init_eval(pic_state *pic)
{
pic_value env = pic_make_env(pic, pic_lit_value(pic, ""));
add_keyword("core#define");
add_keyword("core#set!");
add_keyword("core#quote");
add_keyword("core#lambda");
add_keyword("core#if");
add_keyword("core#begin");
add_keyword("core#define-macro");
pic_define(pic, "default-environment", env);
pic_defun(pic, "eval", pic_eval_eval);
}

352
lib/ext/lib.c
View File

@ -4,357 +4,37 @@
#include "picrin.h"
#include "picrin/extra.h"
#include "object.h"
#include "state.h"
KHASH_DEFINE(env, struct identifier *, symbol *, kh_ptr_hash_func, kh_ptr_hash_equal)
KHASH_DEFINE(ltable, const char *, struct lib, kh_str_hash_func, kh_str_cmp_func)
pic_value
pic_make_env(pic_state *pic, pic_value up)
{
struct env *env;
env = (struct env *)pic_obj_alloc(pic, sizeof(struct env), PIC_TYPE_ENV);
env->up = pic_env_ptr(pic, up);
env->lib = NULL;
kh_init(env, &env->map);
return obj_value(pic, env);
}
static bool
search_scope(pic_state *pic, pic_value id, pic_value env, pic_value *uid)
{
int it;
it = kh_get(env, &pic_env_ptr(pic, env)->map, pic_id_ptr(pic, id));
if (it == kh_end(&pic_env_ptr(pic, env)->map)) {
return false;
}
*uid = obj_value(pic, kh_val(&pic_env_ptr(pic, env)->map, it));
return true;
}
static bool
search(pic_state *pic, pic_value id, pic_value env, pic_value *uid)
{
struct env *e;
while (1) {
if (search_scope(pic, id, env, uid))
return true;
e = pic_env_ptr(pic, env)->up;
if (e == NULL)
break;
env = obj_value(pic, e);
}
return false;
}
pic_value
pic_find_identifier(pic_state *pic, pic_value id, pic_value env)
{
struct env *e;
pic_value uid;
while (! search(pic, id, env, &uid)) {
if (pic_sym_p(pic, id)) {
while (1) {
e = pic_env_ptr(pic, env);
if (e->up == NULL)
break;
env = obj_value(pic, e->up);
}
return pic_add_identifier(pic, id, env);
}
env = obj_value(pic, pic_id_ptr(pic, id)->env); /* do not overwrite id first */
id = obj_value(pic, pic_id_ptr(pic, id)->u.id);
}
return uid;
}
pic_value
pic_add_identifier(pic_state *pic, pic_value id, pic_value env)
{
const char *name, *lib;
pic_value uid, str;
if (search_scope(pic, id, env, &uid)) {
return uid;
}
name = pic_str(pic, pic_id_name(pic, id), NULL);
if (pic_env_ptr(pic, env)->up == NULL && pic_sym_p(pic, id)) { /* toplevel & public */
lib = pic_str(pic, obj_value(pic, pic_env_ptr(pic, env)->lib), NULL);
str = pic_strf_value(pic, "%s/%s", lib, name);
} else {
str = pic_strf_value(pic, ".%s.%d", name, pic->ucnt++);
}
uid = pic_intern(pic, str);
pic_put_identifier(pic, id, uid, env);
return uid;
}
void
pic_put_identifier(pic_state *pic, pic_value id, pic_value uid, pic_value env)
pic_deflibrary(pic_state *pic, const char *lib)
{
int it, ret;
pic_value name = pic_intern_cstr(pic, lib), v;
it = kh_put(env, &pic_env_ptr(pic, env)->map, pic_id_ptr(pic, id), &ret);
kh_val(&pic_env_ptr(pic, env)->map, it) = pic_sym_ptr(pic, uid);
}
static struct lib *
get_library_opt(pic_state *pic, const char *lib)
{
khash_t(ltable) *h = &pic->ltable;
int it;
it = kh_get(ltable, h, lib);
if (it == kh_end(h)) {
return NULL;
v = pic_funcall(pic, "find-library", 1, name);
if (! pic_bool(pic, v)) {
pic_funcall(pic, "make-library", 1, name);
}
return &kh_val(h, it);
}
static struct lib *
get_library(pic_state *pic, const char *lib)
{
struct lib *libp;
if ((libp = get_library_opt(pic, lib)) == NULL) {
pic_error(pic, "library not found", 1, pic_cstr_value(pic, lib));
}
return libp;
}
static pic_value
make_library_env(pic_state *pic, pic_value name)
{
struct env *env;
pic_value e;
env = (struct env *)pic_obj_alloc(pic, sizeof(struct env), PIC_TYPE_ENV);
env->up = NULL;
env->lib = pic_str_ptr(pic, name);
kh_init(env, &env->map);
e = obj_value(pic, env);
#define REGISTER(name) pic_put_identifier(pic, pic_intern_lit(pic, name), pic_intern_lit(pic, name), e)
/* set up default environment */
REGISTER("define-library");
REGISTER("import");
REGISTER("export");
REGISTER("cond-expand");
return e;
}
void
pic_make_library(pic_state *pic, const char *lib)
{
khash_t(ltable) *h = &pic->ltable;
pic_value name, env, exports;
int it;
int ret;
name = pic_cstr_value(pic, lib);
env = make_library_env(pic, name);
exports = pic_make_dict(pic);
it = kh_put(ltable, h, pic_str(pic, name, NULL), &ret);
if (ret == 0) { /* if exists */
pic_error(pic, "library name already in use", 1, pic_cstr_value(pic, lib));
}
kh_val(h, it).name = pic_str_ptr(pic, name);
kh_val(h, it).env = pic_env_ptr(pic, env);
kh_val(h, it).exports = pic_dict_ptr(pic, exports);
}
void
pic_in_library(pic_state *pic, const char *lib)
{
get_library(pic, lib);
pic->lib = lib;
}
pic_value name = pic_intern_cstr(pic, lib);
bool
pic_find_library(pic_state *pic, const char *lib)
{
return get_library_opt(pic, lib) != NULL;
}
const char *
pic_current_library(pic_state *pic)
{
return pic->lib;
}
pic_value
pic_library_environment(pic_state *pic, const char *lib)
{
return obj_value(pic, get_library(pic, lib)->env);
pic_funcall(pic, "current-library", 1, name);
}
void
pic_import(pic_state *pic, const char *lib)
export(pic_state *pic, int n, ...)
{
pic_value name, realname, uid;
int it = 0;
struct lib *our, *their;
size_t ai = pic_enter(pic);
va_list ap;
our = get_library(pic, pic->lib);
their = get_library(pic, lib);
while (pic_dict_next(pic, obj_value(pic, their->exports), &it, &name, &realname)) {
uid = pic_find_identifier(pic, realname, obj_value(pic, their->env));
if (! pic_weak_has(pic, pic->globals, uid) && ! pic_weak_has(pic, pic->macros, uid)) {
pic_error(pic, "attempted to export undefined variable", 1, realname);
}
pic_put_identifier(pic, name, uid, obj_value(pic, our->env));
va_start(ap, n);
while (n--) {
pic_value var = pic_intern_cstr(pic, va_arg(ap, const char *));
pic_funcall(pic, "library-export", 2, var, var);
}
}
void
pic_export(pic_state *pic, pic_value name)
{
pic_dict_set(pic, obj_value(pic, get_library(pic, pic->lib)->exports), name, name);
}
static pic_value
pic_lib_make_library(pic_state *pic)
{
const char *lib;
pic_get_args(pic, "z", &lib);
pic_make_library(pic, lib);
return pic_undef_value(pic);
}
static pic_value
pic_lib_find_library(pic_state *pic)
{
const char *lib;
pic_get_args(pic, "z", &lib);
return pic_bool_value(pic, pic_find_library(pic, lib));
}
static pic_value
pic_lib_current_library(pic_state *pic)
{
const char *lib;
int n;
n = pic_get_args(pic, "|z", &lib);
if (n == 0) {
return pic_cstr_value(pic, pic_current_library(pic));
}
else {
pic_in_library(pic, lib);
return pic_undef_value(pic);
}
}
static pic_value
pic_lib_library_import(pic_state *pic)
{
const char *lib;
pic_value name, alias, realname, uid;
struct lib *libp;
int n;
n = pic_get_args(pic, "zm|m", &lib, &name, &alias);
if (n == 2) {
alias = name;
}
libp = get_library(pic, lib);
if (! pic_dict_has(pic, obj_value(pic, libp->exports), name)) {
pic_error(pic, "library-import: variable is not exported", 1, name);
} else {
realname = pic_dict_ref(pic, obj_value(pic, libp->exports), name);
}
uid = pic_find_identifier(pic, realname, obj_value(pic, libp->env));
if (! pic_weak_has(pic, pic->globals, uid) && ! pic_weak_has(pic, pic->macros, uid)) {
pic_error(pic, "attempted to export undefined variable", 1, realname);
}
pic_put_identifier(pic, alias, uid, obj_value(pic, get_library(pic, pic->lib)->env));
return pic_undef_value(pic);
}
static pic_value
pic_lib_library_export(pic_state *pic)
{
pic_value name, alias = pic_false_value(pic);
int n;
n = pic_get_args(pic, "m|m", &name, &alias);
if (n == 1) {
alias = name;
}
pic_dict_set(pic, obj_value(pic, get_library(pic, pic->lib)->exports), alias, name);
return pic_undef_value(pic);
}
static pic_value
pic_lib_library_exports(pic_state *pic)
{
const char *lib;
pic_value sym, exports = pic_nil_value(pic);
int it = 0;
struct lib *libp;
pic_get_args(pic, "z", &lib);
libp = get_library(pic, lib);
while (pic_dict_next(pic, obj_value(pic, libp->exports), &it, &sym, NULL)) {
pic_push(pic, sym, exports);
}
return exports;
}
static pic_value
pic_lib_library_environment(pic_state *pic)
{
const char *lib;
pic_get_args(pic, "z", &lib);
return obj_value(pic, get_library(pic, lib)->env);
}
void
pic_init_lib(pic_state *pic)
{
pic_defun(pic, "make-library", pic_lib_make_library);
pic_defun(pic, "find-library", pic_lib_find_library);
pic_defun(pic, "library-exports", pic_lib_library_exports);
pic_defun(pic, "library-environment", pic_lib_library_environment);
pic_defun(pic, "current-library", pic_lib_current_library);
pic_defun(pic, "library-import", pic_lib_library_import);
pic_defun(pic, "library-export", pic_lib_library_export);
va_end(ap);
pic_leave(pic, ai);
}

3
lib/ext/load.c
View File

@ -12,7 +12,7 @@ pic_load(pic_state *pic, pic_value port)
size_t ai = pic_enter(pic);
while (! pic_eof_p(pic, form = pic_read(pic, port))) {
pic_eval(pic, form, pic_current_library(pic));
pic_funcall(pic, "eval", 1, form);
pic_leave(pic, ai);
}
}
@ -29,6 +29,5 @@ pic_load_cstr(pic_state *pic, const char *str)
pic_fclose(pic, port);
pic_raise(pic, e);
}
pic_fclose(pic, port);
}

2
lib/ext/read.c
View File

@ -237,7 +237,7 @@ read_number(pic_state *pic, pic_value port, int c, struct reader_control *p)
{
pic_value str = read_atom(pic, port, c, p), num;
num = pic_funcall(pic, "picrin.base", "string->number", 1, str);
num = pic_funcall(pic, "string->number", 1, str);
if (! pic_false_p(pic, num)) {
return num;
}

13
lib/gc.c
View File

@ -406,6 +406,8 @@ gc_mark_object(pic_state *pic, struct object *obj)
}
if (obj->u.env.up) {
LOOP(obj->u.env.up);
} else {
LOOP(obj->u.env.prefix);
}
break;
}
@ -450,7 +452,6 @@ gc_mark_phase(pic_state *pic)
{
pic_value *stack;
struct callinfo *ci;
int it;
size_t j;
assert(pic->heap->weaks == NULL);
@ -487,16 +488,6 @@ gc_mark_phase(pic_state *pic)
/* features */
gc_mark(pic, pic->features);
/* library table */
for (it = kh_begin(&pic->ltable); it != kh_end(&pic->ltable); ++it) {
if (! kh_exist(&pic->ltable, it)) {
continue;
}
gc_mark_object(pic, (struct object *)kh_val(&pic->ltable, it).name);
gc_mark_object(pic, (struct object *)kh_val(&pic->ltable, it).env);
gc_mark_object(pic, (struct object *)kh_val(&pic->ltable, it).exports);
}
/* weak maps */
do {
struct object *key;

2
lib/include/picconf.h
View File

@ -2,7 +2,7 @@
* See Copyright Notice in picrin.h
*/
/** enable libc? */
/** enable libc */
/* #define PIC_USE_LIBC 1 */
/** enable stdio */

32
lib/include/picrin.h
View File

@ -255,9 +255,9 @@ typedef struct {
#define PIC_SEEK_END 1
#define PIC_SEEK_SET 2
#define pic_stdin(pic) pic_funcall(pic, "picrin.base", "current-input-port", 0)
#define pic_stdout(pic) pic_funcall(pic, "picrin.base", "current-output-port", 0)
#define pic_stderr(pic) pic_funcall(pic, "picrin.base", "current-error-port", 0)
#define pic_stdin(pic) pic_funcall(pic, "current-input-port", 0)
#define pic_stdout(pic) pic_funcall(pic, "current-output-port", 0)
#define pic_stderr(pic) pic_funcall(pic, "current-error-port", 0)
bool pic_eof_p(pic_state *, pic_value);
pic_value pic_eof_object(pic_state *);
bool pic_port_p(pic_state *, pic_value, const pic_port_type *type);
@ -319,36 +319,18 @@ pic_value pic_get_backtrace(pic_state *); /* deprecated */
label:
/*
* library
*/
void pic_make_library(pic_state *, const char *lib);
void pic_in_library(pic_state *, const char *lib);
bool pic_find_library(pic_state *, const char *lib);
const char *pic_current_library(pic_state *);
void pic_import(pic_state *, const char *lib);
void pic_export(pic_state *, pic_value sym);
#define pic_deflibrary(pic, lib) do { \
if (! pic_find_library(pic, lib)) { \
pic_make_library(pic, lib); \
} \
pic_in_library(pic, lib); \
} while (0)
/*
* core language features
*/
void pic_add_feature(pic_state *, const char *feature);
void pic_define(pic_state *, const char *lib, const char *name, pic_value v);
pic_value pic_ref(pic_state *, const char *lib, const char *name);
void pic_set(pic_state *, const char *lib, const char *name, pic_value v);
void pic_define(pic_state *, const char *name, pic_value v);
pic_value pic_ref(pic_state *, const char *name);
void pic_set(pic_state *, const char *name, pic_value v);
pic_value pic_make_var(pic_state *, pic_value init, pic_value conv);
void pic_defun(pic_state *, const char *name, pic_func_t f);
void pic_defvar(pic_state *, const char *name, pic_value v);
pic_value pic_funcall(pic_state *, const char *lib, const char *name, int n, ...);
pic_value pic_funcall(pic_state *, const char *name, int n, ...);
pic_value pic_values(pic_state *, int n, ...);
pic_value pic_vvalues(pic_state *, int n, va_list);
int pic_receive(pic_state *, int n, pic_value *retv);

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

@ -17,9 +17,6 @@ void *pic_default_allocf(void *, void *, size_t);
pic_value pic_read(pic_state *, pic_value port);
pic_value pic_read_cstr(pic_state *, const char *);
pic_value pic_expand(pic_state *, pic_value program, pic_value env);
pic_value pic_eval(pic_state *, pic_value program, const char *lib);
void pic_load(pic_state *, pic_value port);
void pic_load_cstr(pic_state *, const char *);
@ -28,6 +25,15 @@ pic_value pic_fopen(pic_state *, FILE *, const char *mode);
#endif
/*
* library
*/
void pic_deflibrary(pic_state *, const char *lib);
void pic_in_library(pic_state *, const char *lib);
void pic_export(pic_state *, int n, ...);
/* for debug */
#if PIC_USE_WRITE

36
lib/object.h
View File

@ -43,7 +43,7 @@ struct env {
OBJECT_HEADER
khash_t(env) map;
struct env *up;
struct string *lib;
struct string *prefix;
};
struct pair {
@ -90,6 +90,12 @@ struct data {
void *data;
};
struct record {
OBJECT_HEADER
pic_value type;
pic_value datum;
};
struct code {
int insn;
int a;
@ -131,20 +137,6 @@ struct proc {
pic_value locals[1];
};
struct record {
OBJECT_HEADER
pic_value type;
pic_value datum;
};
struct error {
OBJECT_HEADER
symbol *type;
struct string *msg;
pic_value irrs;
struct string *stack;
};
enum {
FILE_READ = 01,
FILE_WRITE = 02,
@ -169,6 +161,14 @@ struct port {
} file;
};
struct error {
OBJECT_HEADER
symbol *type;
struct string *msg;
pic_value irrs;
struct string *stack;
};
#define TYPENAME_int "integer"
#define TYPENAME_blob "bytevector"
#define TYPENAME_char "character"
@ -282,12 +282,12 @@ struct object *pic_obj_alloc(pic_state *, size_t, int type);
pic_value pic_make_identifier(pic_state *, pic_value id, pic_value env);
pic_value pic_make_proc(pic_state *, pic_func_t, int, pic_value *);
pic_value pic_make_proc_irep(pic_state *, struct irep *, struct context *);
pic_value pic_make_env(pic_state *, pic_value env);
pic_value pic_make_env(pic_state *, pic_value prefix);
pic_value pic_make_record(pic_state *, pic_value type, pic_value datum);
pic_value pic_add_identifier(pic_state *, pic_value id, pic_value env);
void pic_put_identifier(pic_state *, pic_value id, pic_value uid, pic_value env);
pic_value pic_find_identifier(pic_state *, pic_value id, pic_value env);
void pic_set_identifier(pic_state *, pic_value id, pic_value uid, pic_value env);
pic_value pic_id_name(pic_state *, pic_value id);
struct rope *pic_rope_incref(struct rope *);
@ -298,8 +298,6 @@ pic_value pic_make_cont(pic_state *, struct cont *);
void pic_save_point(pic_state *, struct cont *, PIC_JMPBUF *);
void pic_exit_point(pic_state *);
pic_value pic_library_environment(pic_state *, const char *);
void pic_warnf(pic_state *pic, const char *fmt, ...); /* deprecated */
#if defined(__cplusplus)

100
lib/state.c
View File

@ -3,6 +3,7 @@
*/
#include "picrin.h"
#include "picrin/extra.h"
#include "object.h"
#include "state.h"
@ -80,13 +81,6 @@ pic_add_feature(pic_state *pic, const char *feature)
pic_push(pic, pic_intern_cstr(pic, feature), pic->features);
}
#define import_builtin_syntax(name) do { \
pic_value nick, real; \
nick = pic_intern_lit(pic, "builtin:" name); \
real = pic_intern_lit(pic, name); \
pic_put_identifier(pic, nick, real, env); \
} while (0)
void pic_init_bool(pic_state *);
void pic_init_pair(pic_state *);
void pic_init_port(pic_state *);
@ -105,7 +99,6 @@ void pic_init_read(pic_state *);
void pic_init_dict(pic_state *);
void pic_init_record(pic_state *);
void pic_init_eval(pic_state *);
void pic_init_lib(pic_state *);
void pic_init_weak(pic_state *);
void pic_boot(pic_state *);
@ -116,19 +109,6 @@ static void
pic_init_core(pic_state *pic)
{
size_t ai = pic_enter(pic);
pic_value env;
pic_deflibrary(pic, "picrin.base");
env = pic_library_environment(pic, pic->lib);
import_builtin_syntax("define");
import_builtin_syntax("set!");
import_builtin_syntax("quote");
import_builtin_syntax("lambda");
import_builtin_syntax("if");
import_builtin_syntax("begin");
import_builtin_syntax("define-macro");
pic_init_features(pic); DONE;
pic_init_bool(pic); DONE;
@ -148,7 +128,6 @@ pic_init_core(pic_state *pic)
pic_init_dict(pic); DONE;
pic_init_record(pic); DONE;
pic_init_eval(pic); DONE;
pic_init_lib(pic); DONE;
pic_init_weak(pic); DONE;
#if PIC_USE_WRITE
@ -227,10 +206,6 @@ pic_open(pic_allocf allocf, void *userdata)
/* dynamic environment */
pic->dyn_env = pic_invalid_value(pic);
/* libraries */
kh_init(ltable, &pic->ltable);
pic->lib = NULL;
/* raised error object */
pic->panicf = NULL;
pic->err = pic_invalid_value(pic);
@ -240,16 +215,11 @@ pic_open(pic_allocf allocf, void *userdata)
pic->macros = pic_make_weak(pic);
pic->dyn_env = pic_list(pic, 1, pic_make_weak(pic));
/* user land */
pic_deflibrary(pic, "picrin.user");
/* turn on GC */
pic->gc_enable = true;
pic_init_core(pic);
pic_in_library(pic, "picrin.user");
pic_leave(pic, 0); /* empty arena */
return pic;
@ -279,9 +249,6 @@ pic_close(pic_state *pic)
pic->features = pic_invalid_value(pic);
pic->dyn_env = pic_invalid_value(pic);
/* free all libraries */
kh_clear(ltable, &pic->ltable);
/* free all heap objects */
pic_gc(pic);
@ -294,7 +261,6 @@ pic_close(pic_state *pic)
/* free global stacks */
kh_destroy(oblist, &pic->oblist);
kh_destroy(ltable, &pic->ltable);
/* free GC arena */
allocf(pic->userdata, pic->arena, 0);
@ -303,90 +269,72 @@ pic_close(pic_state *pic)
}
pic_value
pic_global_ref(pic_state *pic, pic_value uid)
pic_global_ref(pic_state *pic, pic_value sym)
{
pic_value val;
if (! pic_weak_has(pic, pic->globals, uid)) {
pic_error(pic, "undefined variable", 1, uid);
if (! pic_weak_has(pic, pic->globals, sym)) {
printf("%s\n", pic_str(pic, pic_sym_name(pic, sym), 0));
pic_error(pic, "undefined variable", 1, sym);
}
val = pic_weak_ref(pic, pic->globals, uid);;
val = pic_weak_ref(pic, pic->globals, sym);;
if (pic_invalid_p(pic, val)) {
pic_error(pic, "uninitialized global variable", 1, uid);
pic_error(pic, "uninitialized global variable", 1, sym);
}
return val;
}
void
pic_global_set(pic_state *pic, pic_value uid, pic_value value)
pic_global_set(pic_state *pic, pic_value sym, pic_value value)
{
if (! pic_weak_has(pic, pic->globals, uid)) {
pic_error(pic, "undefined variable", 1, uid);
if (! pic_weak_has(pic, pic->globals, sym)) {
pic_error(pic, "undefined variable", 1, sym);
}
pic_weak_set(pic, pic->globals, uid, value);
pic_weak_set(pic, pic->globals, sym, value);
}
pic_value
pic_ref(pic_state *pic, const char *lib, const char *name)
pic_ref(pic_state *pic, const char *name)
{
pic_value sym, env;
sym = pic_intern_cstr(pic, name);
env = pic_library_environment(pic, lib);
return pic_global_ref(pic, pic_find_identifier(pic, sym, env));
return pic_global_ref(pic, pic_intern_cstr(pic, name));
}
void
pic_set(pic_state *pic, const char *lib, const char *name, pic_value val)
pic_set(pic_state *pic, const char *name, pic_value val)
{
pic_value sym, env;
sym = pic_intern_cstr(pic, name);
env = pic_library_environment(pic, lib);
pic_global_set(pic, pic_find_identifier(pic, sym, env), val);
pic_global_set(pic, pic_intern_cstr(pic, name), val);
}
void
pic_define(pic_state *pic, const char *lib, const char *name, pic_value val)
pic_define(pic_state *pic, const char *name, pic_value val)
{
pic_value sym, uid, env;
pic_value sym = pic_intern_cstr(pic, name);
sym = pic_intern_cstr(pic, name);
env = pic_library_environment(pic, lib);
uid = pic_find_identifier(pic, sym, env);
if (pic_weak_has(pic, pic->globals, uid)) {
pic_warnf(pic, "redefining variable: %s", pic_str(pic, pic_sym_name(pic, uid), NULL));
if (pic_weak_has(pic, pic->globals, sym)) {
pic_warnf(pic, "redefining variable: %s", pic_str(pic, pic_sym_name(pic, sym), NULL));
}
pic_weak_set(pic, pic->globals, uid, val);
pic_weak_set(pic, pic->globals, sym, val);
}
void
pic_defun(pic_state *pic, const char *name, pic_func_t f)
{
pic_define(pic, pic_current_library(pic), name, pic_make_proc(pic, f, 0, NULL));
pic_export(pic, pic_intern_cstr(pic, name));
pic_define(pic, name, pic_make_proc(pic, f, 0, NULL));
}
void
pic_defvar(pic_state *pic, const char *name, pic_value init)
{
pic_define(pic, pic_current_library(pic), name, pic_make_var(pic, init, pic_false_value(pic)));
pic_export(pic, pic_intern_cstr(pic, name));
pic_define(pic, name, pic_make_var(pic, init, pic_false_value(pic)));
}
pic_value
pic_funcall(pic_state *pic, const char *lib, const char *name, int n, ...)
pic_funcall(pic_state *pic, const char *name, int n, ...)
{
pic_value proc, r;
va_list ap;
proc = pic_ref(pic, lib, name);
proc = pic_ref(pic, name);
TYPE_CHECK(pic, proc, proc);

10
lib/state.h
View File

@ -12,12 +12,6 @@ extern "C" {
#include "khash.h"
#include "vm.h"
struct lib {
struct string *name;
struct env *env;
struct dict *exports;
};
struct callinfo {
int argc, retc;
const struct code *ip;
@ -30,7 +24,6 @@ struct callinfo {
};
KHASH_DECLARE(oblist, struct string *, struct identifier *)
KHASH_DECLARE(ltable, const char *, struct lib)
struct pic_state {
pic_allocf allocf;
@ -48,15 +41,12 @@ struct pic_state {
pic_value dyn_env;
const char *lib;
pic_value features;
khash_t(oblist) oblist; /* string to symbol */
int ucnt;
pic_value globals; /* weak */
pic_value macros; /* weak */
khash_t(ltable) ltable;
bool gc_enable;
struct heap *heap;

4
lib/string.c
View File

@ -532,7 +532,7 @@ pic_str_string_map(pic_state *pic)
pic_push(pic, pic_char_value(pic, pic_str(pic, argv[j], 0)[i]), vals);
}
vals = pic_reverse(pic, vals);
val = pic_funcall(pic, "picrin.base", "apply", 2, proc, vals);
val = pic_funcall(pic, "apply", 2, proc, vals);
TYPE_CHECK(pic, val, char);
@ -567,7 +567,7 @@ pic_str_string_for_each(pic_state *pic)
pic_push(pic, pic_char_value(pic, pic_str(pic, argv[j], 0)[i]), vals);
}
vals = pic_reverse(pic, vals);
pic_funcall(pic, "picrin.base", "apply", 2, proc, vals);
pic_funcall(pic, "apply", 2, proc, vals);
}
return pic_undef_value(pic);
}

4
lib/vector.c
View File

@ -249,7 +249,7 @@ pic_vec_vector_map(pic_state *pic)
pic_push(pic, pic_vec_ref(pic, argv[j], i), vals);
}
vals = pic_reverse(pic, vals);
pic_vec_set(pic, vec, i, pic_funcall(pic, "picrin.base", "apply", 2, proc, vals));
pic_vec_set(pic, vec, i, pic_funcall(pic, "apply", 2, proc, vals));
}
return vec;
@ -281,7 +281,7 @@ pic_vec_vector_for_each(pic_state *pic)
pic_push(pic, pic_vec_ref(pic, argv[j], i), vals);
}
vals = pic_reverse(pic, vals);
pic_funcall(pic, "picrin.base", "apply", 2, proc, vals);
pic_funcall(pic, "apply", 2, proc, vals);
}
return pic_undef_value(pic);

231
piclib/boot.scm
View File

@ -1,52 +1,52 @@
(builtin:define-macro call-with-current-environment
(builtin:lambda (form env)
(core#define-macro call-with-current-environment
(core#lambda (form env)
(list (cadr form) env)))
(builtin:define here
(core#define here
(call-with-current-environment
(builtin:lambda (env)
(core#lambda (env)
env)))
(builtin:define the ; synonym for #'var
(builtin:lambda (var)
(core#define the ; synonym for #'var
(core#lambda (var)
(make-identifier var here)))
(builtin:define the-builtin-define (the (builtin:quote builtin:define)))
(builtin:define the-builtin-lambda (the (builtin:quote builtin:lambda)))
(builtin:define the-builtin-begin (the (builtin:quote builtin:begin)))
(builtin: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)))
(core#define the-builtin-define (the (core#quote core#define)))
(core#define the-builtin-lambda (the (core#quote core#lambda)))
(core#define the-builtin-begin (the (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#define the-builtin-if (the (core#quote core#if)))
(core#define the-builtin-define-macro (the (core#quote core#define-macro)))
(builtin:define the-define (the (builtin:quote define)))
(builtin:define the-lambda (the (builtin:quote lambda)))
(builtin:define the-begin (the (builtin:quote begin)))
(builtin:define the-quote (the (builtin:quote quote)))
(builtin:define the-set! (the (builtin:quote set!)))
(builtin:define the-if (the (builtin:quote if)))
(builtin:define the-define-macro (the (builtin:quote define-macro)))
(core#define the-define (the (core#quote 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)))
(builtin:define-macro quote
(builtin:lambda (form env)
(builtin:if (= (length form) 2)
(core#define-macro quote
(core#lambda (form env)
(core#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)
(core#define-macro if
(core#lambda (form env)
((core#lambda (len)
(core#if (= len 4)
(cons the-builtin-if (cdr form))
(builtin:if (= len 3)
(core#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)
(core#define-macro begin
(core#lambda (form env)
((core#lambda (len)
(if (= len 1)
#undefined
(if (= len 2)
@ -58,16 +58,16 @@
(cons the-begin (cddr form)))))))
(length form))))
(builtin:define-macro set!
(builtin:lambda (form env)
(core#define-macro set!
(core#lambda (form env)
(if (= (length form) 3)
(if (identifier? (cadr form))
(cons the-builtin-set! (cdr form))
(error "illegal set! form" form))
(error "illegal set! form" form))))
(builtin:define check-formal
(builtin:lambda (formal)
(core#define check-formal
(core#lambda (formal)
(if (null? formal)
#t
(if (identifier? formal)
@ -78,15 +78,15 @@
#f)
#f)))))
(builtin:define-macro lambda
(builtin:lambda (form env)
(core#define-macro lambda
(core#lambda (form env)
(if (= (length form) 1)
(error "illegal lambda form" form)
(if (check-formal (cadr form))
(list the-builtin-lambda (cadr form) (cons the-begin (cddr form)))
(error "illegal lambda form" form)))))
(builtin:define-macro define
(core#define-macro define
(lambda (form env)
((lambda (len)
(if (= len 1)
@ -102,7 +102,7 @@
(error "define: binding to non-varaible object" form)))))
(length form))))
(builtin:define-macro define-macro
(core#define-macro define-macro
(lambda (form env)
(if (= (length form) 3)
(if (identifier? (cadr form))
@ -527,156 +527,3 @@
(define-macro let-syntax
(lambda (form env)
`(,(the 'letrec-syntax) ,@(cdr form))))
;;; library primitives
(define (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 (symbol->string n)))
(string-for-each
(lambda (c)
(when (or (char=? c #\.) (char=? c #\/))
(error "elements of library name may not contain '.' or '/'" n)))
str)
str))
((and (number? n) (exact? n))
(number->string n))
(else
(error "symbol or 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 strs)) (cdr strs)))))
(join (map ->string name) "."))
(define-macro define-library
(lambda (form _)
(let ((lib (mangle (cadr form)))
(body (cddr form)))
(or (find-library 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 (test (cadr form))))
((and) (let loop ((form (cdr form)))
(or (null? form)
(and (test (car form)) (loop (cdr form))))))
((or) (let loop ((form (cdr form)))
(and (pair? 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->string symbol)))))
(getlib
(lambda (name)
(let ((lib (mangle name)))
(if (find-library 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))))
((rename)
(let ((alist (collect (cadr spec)))
(renames (map (lambda (x) `((car x) . (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))))
(let loop ((alist alist))
(if (null? alist)
'()
(if (memq (caar alist) (cddr spec))
(loop (cdr alist))
(cons (car alist) (loop (cdr alist))))))))
(else
(map (lambda (x) (cons x x)) (library-exports (getlib spec))))))))
(letrec
((import
(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 . ,spec))
((and (list? spec) (= (length spec) 3) (eq? (car spec) 'rename))
`(,(list-ref spec 1) . ,(list-ref spec 2)))
(else
(error "malformed export")))))
(export
(lambda (spec)
(let ((slot (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-splicing
and or
cond case else =>
do when unless
parameterize
define-syntax
syntax-quote syntax-unquote
syntax-quasiquote syntax-unquote-splicing
let-syntax letrec-syntax
syntax-error)

2
src/main.c
View File

@ -35,7 +35,7 @@ main(int argc, char *argv[], char **envp)
pic_try {
pic_init_picrin(pic);
pic_funcall(pic, "picrin.main", "main", 0);
pic_funcall(pic, "picrin.main:main", 0);
status = 0;
}