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"); pic_deflibrary(pic, "srfi.106");
#define pic_defun_(pic, name, f) pic_define(pic, "srfi.106", name, pic_lambda(pic, f, 0)) pic_defun(pic, "socket?", pic_socket_socket_p);
#define pic_define_(pic, name, v) pic_define(pic, "srfi.106", name, v) pic_defun(pic, "make-socket", pic_socket_make_socket);
pic_defun(pic, "socket-accept", pic_socket_socket_accept);
pic_defun_(pic, "socket?", pic_socket_socket_p); pic_defun(pic, "socket-send", pic_socket_socket_send);
pic_defun_(pic, "make-socket", pic_socket_make_socket); pic_defun(pic, "socket-recv", pic_socket_socket_recv);
pic_defun_(pic, "socket-accept", pic_socket_socket_accept); pic_defun(pic, "socket-shutdown", pic_socket_socket_shutdown);
pic_defun_(pic, "socket-send", pic_socket_socket_send); pic_defun(pic, "socket-close", pic_socket_socket_close);
pic_defun_(pic, "socket-recv", pic_socket_socket_recv); pic_defun(pic, "socket-input-port", pic_socket_socket_input_port);
pic_defun_(pic, "socket-shutdown", pic_socket_socket_shutdown); pic_defun(pic, "socket-output-port", pic_socket_socket_output_port);
pic_defun_(pic, "socket-close", pic_socket_socket_close); pic_defun(pic, "call-with-socket", pic_socket_call_with_socket);
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 #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 #else
pic_define_(pic, "*af-inet*", pic_false_value(pic)); pic_define(pic, "*af-inet*", pic_false_value(pic));
#endif #endif
#ifdef AF_INET6 #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 #else
pic_define_(pic, "*af-inet6*", pic_false_value(pic)); pic_define(pic, "*af-inet6*", pic_false_value(pic));
#endif #endif
#ifdef AF_UNSPEC #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 #else
pic_define_(pic, "*af-unspec*", pic_false_value(pic)); pic_define(pic, "*af-unspec*", pic_false_value(pic));
#endif #endif
#ifdef SOCK_STREAM #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 #else
pic_define_(pic, "*sock-stream*", pic_false_value(pic)); pic_define(pic, "*sock-stream*", pic_false_value(pic));
#endif #endif
#ifdef SOCK_DGRAM #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 #else
pic_define_(pic, "*sock-dgram*", pic_false_value(pic)); pic_define(pic, "*sock-dgram*", pic_false_value(pic));
#endif #endif
#ifdef AI_CANONNAME #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 #else
pic_define_(pic, "*ai-canonname*", pic_false_value(pic)); pic_define(pic, "*ai-canonname*", pic_false_value(pic));
#endif #endif
#ifdef AI_NUMERICHOST #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 #else
pic_define_(pic, "*ai-numerichost*", pic_false_value(pic)); pic_define(pic, "*ai-numerichost*", pic_false_value(pic));
#endif #endif
/* AI_V4MAPPED and AI_ALL are not supported by *BSDs, even though they are defined in netdb.h. */ /* AI_V4MAPPED and AI_ALL are not supported by *BSDs, even though they are defined in netdb.h. */
#if defined(AI_V4MAPPED) && !defined(BSD) #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 #else
pic_define_(pic, "*ai-v4mapped*", pic_false_value(pic)); pic_define(pic, "*ai-v4mapped*", pic_false_value(pic));
#endif #endif
#if defined(AI_ALL) && !defined(BSD) #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 #else
pic_define_(pic, "*ai-all*", pic_false_value(pic)); pic_define(pic, "*ai-all*", pic_false_value(pic));
#endif #endif
#ifdef AI_ADDRCONFIG #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 #else
pic_define_(pic, "*ai-addrconfig*", pic_false_value(pic)); pic_define(pic, "*ai-addrconfig*", pic_false_value(pic));
#endif #endif
#ifdef AI_PASSIVE #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 #else
pic_define_(pic, "*ai-passive*", pic_false_value(pic)); pic_define(pic, "*ai-passive*", pic_false_value(pic));
#endif #endif
#ifdef IPPROTO_IP #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 #else
pic_define_(pic, "*ipproto-ip*", pic_false_value(pic)); pic_define(pic, "*ipproto-ip*", pic_false_value(pic));
#endif #endif
#ifdef IPPROTO_TCP #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 #else
pic_define_(pic, "*ipproto-tcp*", pic_false_value(pic)); pic_define(pic, "*ipproto-tcp*", pic_false_value(pic));
#endif #endif
#ifdef IPPROTO_UDP #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 #else
pic_define_(pic, "*ipproto-udp*", pic_false_value(pic)); pic_define(pic, "*ipproto-udp*", pic_false_value(pic));
#endif #endif
#ifdef MSG_PEEK #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 #else
pic_define_(pic, "*msg-peek*", pic_false_value(pic)); pic_define(pic, "*msg-peek*", pic_false_value(pic));
#endif #endif
#ifdef MSG_OOB #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 #else
pic_define_(pic, "*msg-oob*", pic_false_value(pic)); pic_define(pic, "*msg-oob*", pic_false_value(pic));
#endif #endif
#ifdef MSG_WAITALL #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 #else
pic_define_(pic, "*msg-waitall*", pic_false_value(pic)); pic_define(pic, "*msg-waitall*", pic_false_value(pic));
#endif #endif
#ifdef SHUT_RD #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 #else
pic_define_(pic, "*shut-rd*", pic_false_value(pic)); pic_define(pic, "*shut-rd*", pic_false_value(pic));
#endif #endif
#ifdef SHUT_WR #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 #else
pic_define_(pic, "*shut-wr*", pic_false_value(pic)); pic_define(pic, "*shut-wr*", pic_false_value(pic));
#endif #endif
#ifdef SHUT_RDWR #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 #else
pic_define_(pic, "*shut-rdwr*", pic_false_value(pic)); pic_define(pic, "*shut-rdwr*", pic_false_value(pic));
#endif #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)); 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 static pic_value
native_exception_handler(pic_state *pic) native_exception_handler(pic_state *pic)
{ {
@ -57,7 +59,7 @@ pic_start_try(pic_state *pic, PIC_JMPBUF *jmp)
/* with-exception-handler */ /* with-exception-handler */
var = pic_ref(pic, "picrin.base", "current-exception-handlers"); var = pic_exc(pic);
env = pic_make_weak(pic); env = pic_make_weak(pic);
pic_weak_set(pic, env, var, pic_cons(pic, handler, pic_call(pic, var, 0))); 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); 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 static pic_value
with_exception_handlers(pic_state *pic, pic_value handlers, pic_value thunk) 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)); 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 static pic_value
@ -124,7 +126,7 @@ on_raise(pic_state *pic)
pic_value pic_value
pic_raise_continuable(pic_state *pic, pic_value err) 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); handlers = pic_call(pic, var, 0);
@ -138,7 +140,7 @@ pic_raise_continuable(pic_state *pic, pic_value err)
void void
pic_raise(pic_state *pic, pic_value err) 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); handlers = pic_call(pic, var, 0);
@ -166,7 +168,7 @@ static pic_value
pic_error_with_exception_handler(pic_state *pic) pic_error_with_exception_handler(pic_state *pic)
{ {
pic_value handler, thunk; 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); pic_get_args(pic, "ll", &handler, &thunk);

372
lib/ext/boot.c
View File

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

275
lib/ext/eval.c
View File

@ -8,6 +8,126 @@
#include "state.h" #include "state.h"
#include "vm.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); static 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)
@ -61,7 +181,7 @@ expand_var(pic_state *pic, pic_value id, pic_value env, pic_value deferred)
static pic_value static pic_value
expand_quote(pic_state *pic, pic_value expr) 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 static pic_value
@ -119,7 +239,7 @@ expand_lambda(pic_state *pic, pic_value expr, pic_value env)
pic_value in; pic_value in;
pic_value a, deferred; 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)) { 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); 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); 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 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); 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 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); 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); return expand_defmacro(pic, expr, env);
} }
else if (EQ(functor, "lambda")) { else if (EQ(functor, "core#lambda")) {
return expand_defer(pic, expr, deferred); return expand_defer(pic, expr, deferred);
} }
else if (EQ(functor, "define")) { else if (EQ(functor, "core#define")) {
return expand_define(pic, expr, env, deferred); return expand_define(pic, expr, env, deferred);
} }
else if (EQ(functor, "quote")) { else if (EQ(functor, "core#quote")) {
return expand_quote(pic, expr); 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))) { if (pic_sym_p(pic, pic_list_ref(pic, expr, 0))) {
pic_value sym = 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; return expr;
} else if (EQ(sym, "lambda")) { } else if (EQ(sym, "core#lambda")) {
return pic_list(pic, 3, S("lambda"), pic_list_ref(pic, expr, 1), optimize_beta(pic, pic_list_ref(pic, expr, 2))); 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); pic_protect(pic, expr);
functor = pic_list_ref(pic, expr, 0); 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); formals = pic_list_ref(pic, functor, 1);
if (! pic_list_p(pic, formals)) if (! pic_list_p(pic, formals))
goto exit; /* TODO: support ((lambda args x) 1 2) */ goto exit; /* TODO: support ((lambda args x) 1 2) */
@ -281,12 +401,12 @@ optimize_beta(pic_state *pic, pic_value expr)
goto exit; goto exit;
defs = pic_nil_value(pic); defs = pic_nil_value(pic);
pic_for_each (val, args, it) { 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); formals = pic_cdr(pic, formals);
} }
expr = pic_list_ref(pic, functor, 2); expr = pic_list_ref(pic, functor, 2);
pic_for_each (val, defs, it) { 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: exit:
@ -316,7 +436,7 @@ normalize_body(pic_state *pic, pic_value expr, bool in)
if (! in) { if (! in) {
return v; 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 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)) { if (pic_sym_p(pic, proc)) {
pic_value sym = proc; pic_value sym = proc;
if (EQ(sym, "define")) { if (EQ(sym, "core#define")) {
pic_value var, val; pic_value var, val;
var = pic_list_ref(pic, expr, 1); 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); 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")) { else if (EQ(sym, "core#lambda")) {
return pic_list(pic, 3, S("lambda"), pic_list_ref(pic, expr, 1), normalize_body(pic, pic_list_ref(pic, expr, 2), true)); 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; return expr;
} }
} }
@ -450,11 +570,11 @@ analyze_var(pic_state *pic, analyze_scope *scope, pic_value sym)
depth = find_var(pic, scope, sym); depth = find_var(pic, scope, sym);
if (depth == scope->depth) { 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) { } else if (depth == 0) {
return pic_list(pic, 2, S("lref"), sym); return pic_list(pic, 2, S("core#lref"), sym);
} else { } 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 */ /* analyze body */
body = analyze(pic, scope, 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 static pic_value
@ -491,7 +611,7 @@ analyze_list(pic_state *pic, analyze_scope *scope, pic_value obj)
static pic_value static pic_value
analyze_call(pic_state *pic, analyze_scope *scope, pic_value obj) 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 static pic_value
@ -512,13 +632,13 @@ analyze_node(pic_state *pic, analyze_scope *scope, pic_value obj)
if (pic_sym_p(pic, proc)) { if (pic_sym_p(pic, proc)) {
pic_value sym = proc; pic_value sym = proc;
if (EQ(sym, "lambda")) { if (EQ(sym, "core#lambda")) {
return analyze_lambda(pic, scope, obj); return analyze_lambda(pic, scope, obj);
} }
else if (EQ(sym, "quote")) { else if (EQ(sym, "core#quote")) {
return obj; 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))); 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); return analyze_call(pic, scope, obj);
} }
default: 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 insn;
int argc; int argc;
} pic_vm_proc[] = { } pic_vm_proc[] = {
{ "picrin.base/cons", OP_CONS, 2 }, { "cons", OP_CONS, 2 },
{ "picrin.base/car", OP_CAR, 1 }, { "car", OP_CAR, 1 },
{ "picrin.base/cdr", OP_CDR, 1 }, { "cdr", OP_CDR, 1 },
{ "picrin.base/null?", OP_NILP, 1 }, { "null?", OP_NILP, 1 },
{ "picrin.base/symbol?", OP_SYMBOLP, 1 }, { "symbol?", OP_SYMBOLP, 1 },
{ "picrin.base/pair?", OP_PAIRP, 1 }, { "pair?", OP_PAIRP, 1 },
{ "picrin.base/not", OP_NOT, 1 }, { "not", OP_NOT, 1 },
{ "picrin.base/=", OP_EQ, 2 }, { "=", OP_EQ, 2 },
{ "picrin.base/<", OP_LT, 2 }, { "<", OP_LT, 2 },
{ "picrin.base/<=", OP_LE, 2 }, { "<=", OP_LE, 2 },
{ "picrin.base/>", OP_GT, 2 }, { ">", OP_GT, 2 },
{ "picrin.base/>=", OP_GE, 2 }, { ">=", OP_GE, 2 },
{ "picrin.base/+", OP_ADD, 2 }, { "+", OP_ADD, 2 },
{ "picrin.base/-", OP_SUB, 2 }, { "-", OP_SUB, 2 },
{ "picrin.base/*", OP_MUL, 2 }, { "*", OP_MUL, 2 },
{ "picrin.base//", OP_DIV, 2 } { "/", OP_DIV, 2 }
}; };
static int static int
@ -794,14 +914,14 @@ codegen_ref(pic_state *pic, codegen_context *cxt, pic_value obj, bool tailpos)
pic_value sym; pic_value sym;
sym = pic_car(pic, obj); sym = pic_car(pic, obj);
if (EQ(sym, "gref")) { if (EQ(sym, "core#gref")) {
pic_value name; pic_value name;
name = pic_list_ref(pic, obj, 1); name = pic_list_ref(pic, obj, 1);
emit_i(pic, cxt, OP_GREF, index_global(pic, cxt, name)); emit_i(pic, cxt, OP_GREF, index_global(pic, cxt, name));
emit_ret(pic, cxt, tailpos); emit_ret(pic, cxt, tailpos);
} }
else if (EQ(sym, "cref")) { else if (EQ(sym, "core#cref")) {
pic_value name; pic_value name;
int depth; 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_r(pic, cxt, OP_CREF, depth, index_capture(pic, cxt, name, depth));
emit_ret(pic, cxt, tailpos); emit_ret(pic, cxt, tailpos);
} }
else if (EQ(sym, "lref")) { else if (EQ(sym, "core#lref")) {
pic_value name; pic_value name;
int i; 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); var = pic_list_ref(pic, obj, 1);
type = pic_list_ref(pic, var, 0); type = pic_list_ref(pic, var, 0);
if (EQ(type, "gref")) { if (EQ(type, "core#gref")) {
pic_value name; pic_value name;
size_t i; 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_i(pic, cxt, OP_GSET, index_global(pic, cxt, name));
emit_ret(pic, cxt, tailpos); emit_ret(pic, cxt, tailpos);
} }
else if (EQ(type, "cref")) { else if (EQ(type, "core#cref")) {
pic_value name; pic_value name;
int depth; 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_r(pic, cxt, OP_CSET, depth, index_capture(pic, cxt, name, depth));
emit_ret(pic, cxt, tailpos); emit_ret(pic, cxt, tailpos);
} }
else if (EQ(type, "lref")) { else if (EQ(type, "core#lref")) {
pic_value name; pic_value name;
int i; int i;
@ -989,7 +1109,7 @@ codegen_call(pic_state *pic, codegen_context *cxt, pic_value obj, bool tailpos)
pic_value elt, it, functor; pic_value elt, it, functor;
functor = pic_list_ref(pic, obj, 1); 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; pic_value sym;
size_t i; size_t i;
@ -1019,25 +1139,25 @@ codegen(pic_state *pic, codegen_context *cxt, pic_value obj, bool tailpos)
pic_value sym; pic_value sym;
sym = pic_car(pic, obj); 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); 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); codegen_set(pic, cxt, obj, tailpos);
} }
else if (EQ(sym, "lambda")) { else if (EQ(sym, "core#lambda")) {
codegen_lambda(pic, cxt, obj, tailpos); codegen_lambda(pic, cxt, obj, tailpos);
} }
else if (EQ(sym, "if")) { else if (EQ(sym, "core#if")) {
codegen_if(pic, cxt, obj, tailpos); codegen_if(pic, cxt, obj, tailpos);
} }
else if (EQ(sym, "begin")) { else if (EQ(sym, "core#begin")) {
codegen_begin(pic, cxt, obj, tailpos); codegen_begin(pic, cxt, obj, tailpos);
} }
else if (EQ(sym, "quote")) { else if (EQ(sym, "core#quote")) {
codegen_quote(pic, cxt, obj, tailpos); codegen_quote(pic, cxt, obj, tailpos);
} }
else if (EQ(sym, "call")) { else if (EQ(sym, "core#call")) {
codegen_call(pic, cxt, obj, tailpos); codegen_call(pic, cxt, obj, tailpos);
} }
else { else {
@ -1099,40 +1219,39 @@ pic_compile(pic_state *pic, pic_value obj)
return pic_make_proc_irep(pic, irep, NULL); return pic_make_proc_irep(pic, irep, NULL);
} }
pic_value static pic_value
pic_eval(pic_state *pic, pic_value program, const char *lib) pic_eval_eval(pic_state *pic)
{ {
const char *prev_lib = pic_current_library(pic); pic_value program, env = default_env(pic), r, e;
pic_value env, r, e;
env = pic_library_environment(pic, lib); pic_get_args(pic, "o|o", &program, &env);
pic_in_library(pic, lib);
pic_try { pic_try {
r = pic_call(pic, pic_compile(pic, pic_expand(pic, program, env)), 0); r = pic_call(pic, pic_compile(pic, pic_expand(pic, program, env)), 0);
} }
pic_catch(e) { pic_catch(e) {
pic_in_library(pic, prev_lib);
pic_raise(pic, e); pic_raise(pic, e);
} }
pic_in_library(pic, prev_lib);
return r; return r;
} }
static pic_value #define add_keyword(name) do { \
pic_eval_eval(pic_state *pic) pic_value var; \
{ var = pic_intern_lit(pic, name); \
pic_value program; pic_set_identifier(pic, var, var, env); \
const char *str; } while (0)
pic_get_args(pic, "oz", &program, &str);
return pic_eval(pic, program, str);
}
void void
pic_init_eval(pic_state *pic) 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); pic_defun(pic, "eval", pic_eval_eval);
} }

352
lib/ext/lib.c
View File

@ -4,357 +4,37 @@
#include "picrin.h" #include "picrin.h"
#include "picrin/extra.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 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); v = pic_funcall(pic, "find-library", 1, name);
kh_val(&pic_env_ptr(pic, env)->map, it) = pic_sym_ptr(pic, uid); if (! pic_bool(pic, v)) {
} pic_funcall(pic, "make-library", 1, name);
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;
} }
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 void
pic_in_library(pic_state *pic, const char *lib) pic_in_library(pic_state *pic, const char *lib)
{ {
get_library(pic, lib); pic_value name = pic_intern_cstr(pic, lib);
pic->lib = lib;
}
bool pic_funcall(pic, "current-library", 1, name);
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);
} }
void void
pic_import(pic_state *pic, const char *lib) export(pic_state *pic, int n, ...)
{ {
pic_value name, realname, uid; size_t ai = pic_enter(pic);
int it = 0; va_list ap;
struct lib *our, *their;
our = get_library(pic, pic->lib); va_start(ap, n);
their = get_library(pic, lib); while (n--) {
pic_value var = pic_intern_cstr(pic, va_arg(ap, const char *));
while (pic_dict_next(pic, obj_value(pic, their->exports), &it, &name, &realname)) { pic_funcall(pic, "library-export", 2, var, var);
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_end(ap);
pic_leave(pic, ai);
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);
} }

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); size_t ai = pic_enter(pic);
while (! pic_eof_p(pic, form = pic_read(pic, port))) { 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); pic_leave(pic, ai);
} }
} }
@ -29,6 +29,5 @@ pic_load_cstr(pic_state *pic, const char *str)
pic_fclose(pic, port); pic_fclose(pic, port);
pic_raise(pic, e); pic_raise(pic, e);
} }
pic_fclose(pic, port); 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; 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)) { if (! pic_false_p(pic, num)) {
return 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) { if (obj->u.env.up) {
LOOP(obj->u.env.up); LOOP(obj->u.env.up);
} else {
LOOP(obj->u.env.prefix);
} }
break; break;
} }
@ -450,7 +452,6 @@ gc_mark_phase(pic_state *pic)
{ {
pic_value *stack; pic_value *stack;
struct callinfo *ci; struct callinfo *ci;
int it;
size_t j; size_t j;
assert(pic->heap->weaks == NULL); assert(pic->heap->weaks == NULL);
@ -487,16 +488,6 @@ gc_mark_phase(pic_state *pic)
/* features */ /* features */
gc_mark(pic, 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 */ /* weak maps */
do { do {
struct object *key; struct object *key;

2
lib/include/picconf.h
View File

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

32
lib/include/picrin.h
View File

@ -255,9 +255,9 @@ typedef struct {
#define PIC_SEEK_END 1 #define PIC_SEEK_END 1
#define PIC_SEEK_SET 2 #define PIC_SEEK_SET 2
#define pic_stdin(pic) pic_funcall(pic, "picrin.base", "current-input-port", 0) #define pic_stdin(pic) pic_funcall(pic, "current-input-port", 0)
#define pic_stdout(pic) pic_funcall(pic, "picrin.base", "current-output-port", 0) #define pic_stdout(pic) pic_funcall(pic, "current-output-port", 0)
#define pic_stderr(pic) pic_funcall(pic, "picrin.base", "current-error-port", 0) #define pic_stderr(pic) pic_funcall(pic, "current-error-port", 0)
bool pic_eof_p(pic_state *, pic_value); bool pic_eof_p(pic_state *, pic_value);
pic_value pic_eof_object(pic_state *); pic_value pic_eof_object(pic_state *);
bool pic_port_p(pic_state *, pic_value, const pic_port_type *type); 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: 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 * core language features
*/ */
void pic_add_feature(pic_state *, const char *feature); void pic_add_feature(pic_state *, const char *feature);
void pic_define(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 *lib, const char *name); pic_value pic_ref(pic_state *, const char *name);
void pic_set(pic_state *, const char *lib, const char *name, pic_value v); void pic_set(pic_state *, const char *name, pic_value v);
pic_value pic_make_var(pic_state *, pic_value init, pic_value conv); 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_defun(pic_state *, const char *name, pic_func_t f);
void pic_defvar(pic_state *, const char *name, pic_value v); 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_values(pic_state *, int n, ...);
pic_value pic_vvalues(pic_state *, int n, va_list); pic_value pic_vvalues(pic_state *, int n, va_list);
int pic_receive(pic_state *, int n, pic_value *retv); 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(pic_state *, pic_value port);
pic_value pic_read_cstr(pic_state *, const char *); 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(pic_state *, pic_value port);
void pic_load_cstr(pic_state *, const char *); void pic_load_cstr(pic_state *, const char *);
@ -28,6 +25,15 @@ pic_value pic_fopen(pic_state *, FILE *, const char *mode);
#endif #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 */ /* for debug */
#if PIC_USE_WRITE #if PIC_USE_WRITE

36
lib/object.h
View File

@ -43,7 +43,7 @@ struct env {
OBJECT_HEADER OBJECT_HEADER
khash_t(env) map; khash_t(env) map;
struct env *up; struct env *up;
struct string *lib; struct string *prefix;
}; };
struct pair { struct pair {
@ -90,6 +90,12 @@ struct data {
void *data; void *data;
}; };
struct record {
OBJECT_HEADER
pic_value type;
pic_value datum;
};
struct code { struct code {
int insn; int insn;
int a; int a;
@ -131,20 +137,6 @@ struct proc {
pic_value locals[1]; 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 { enum {
FILE_READ = 01, FILE_READ = 01,
FILE_WRITE = 02, FILE_WRITE = 02,
@ -169,6 +161,14 @@ struct port {
} file; } file;
}; };
struct error {
OBJECT_HEADER
symbol *type;
struct string *msg;
pic_value irrs;
struct string *stack;
};
#define TYPENAME_int "integer" #define TYPENAME_int "integer"
#define TYPENAME_blob "bytevector" #define TYPENAME_blob "bytevector"
#define TYPENAME_char "character" #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_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(pic_state *, pic_func_t, int, pic_value *);
pic_value pic_make_proc_irep(pic_state *, struct irep *, struct context *); 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_make_record(pic_state *, pic_value type, pic_value datum);
pic_value pic_add_identifier(pic_state *, pic_value id, pic_value env); 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); 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); pic_value pic_id_name(pic_state *, pic_value id);
struct rope *pic_rope_incref(struct rope *); 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_save_point(pic_state *, struct cont *, PIC_JMPBUF *);
void pic_exit_point(pic_state *); 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 */ void pic_warnf(pic_state *pic, const char *fmt, ...); /* deprecated */
#if defined(__cplusplus) #if defined(__cplusplus)

100
lib/state.c
View File

@ -3,6 +3,7 @@
*/ */
#include "picrin.h" #include "picrin.h"
#include "picrin/extra.h"
#include "object.h" #include "object.h"
#include "state.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); 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_bool(pic_state *);
void pic_init_pair(pic_state *); void pic_init_pair(pic_state *);
void pic_init_port(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_dict(pic_state *);
void pic_init_record(pic_state *); void pic_init_record(pic_state *);
void pic_init_eval(pic_state *); void pic_init_eval(pic_state *);
void pic_init_lib(pic_state *);
void pic_init_weak(pic_state *); void pic_init_weak(pic_state *);
void pic_boot(pic_state *); void pic_boot(pic_state *);
@ -116,19 +109,6 @@ static void
pic_init_core(pic_state *pic) pic_init_core(pic_state *pic)
{ {
size_t ai = pic_enter(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_features(pic); DONE;
pic_init_bool(pic); DONE; pic_init_bool(pic); DONE;
@ -148,7 +128,6 @@ pic_init_core(pic_state *pic)
pic_init_dict(pic); DONE; pic_init_dict(pic); DONE;
pic_init_record(pic); DONE; pic_init_record(pic); DONE;
pic_init_eval(pic); DONE; pic_init_eval(pic); DONE;
pic_init_lib(pic); DONE;
pic_init_weak(pic); DONE; pic_init_weak(pic); DONE;
#if PIC_USE_WRITE #if PIC_USE_WRITE
@ -227,10 +206,6 @@ pic_open(pic_allocf allocf, void *userdata)
/* dynamic environment */ /* dynamic environment */
pic->dyn_env = pic_invalid_value(pic); pic->dyn_env = pic_invalid_value(pic);
/* libraries */
kh_init(ltable, &pic->ltable);
pic->lib = NULL;
/* raised error object */ /* raised error object */
pic->panicf = NULL; pic->panicf = NULL;
pic->err = pic_invalid_value(pic); pic->err = pic_invalid_value(pic);
@ -240,16 +215,11 @@ pic_open(pic_allocf allocf, void *userdata)
pic->macros = pic_make_weak(pic); pic->macros = pic_make_weak(pic);
pic->dyn_env = pic_list(pic, 1, 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 */ /* turn on GC */
pic->gc_enable = true; pic->gc_enable = true;
pic_init_core(pic); pic_init_core(pic);
pic_in_library(pic, "picrin.user");
pic_leave(pic, 0); /* empty arena */ pic_leave(pic, 0); /* empty arena */
return pic; return pic;
@ -279,9 +249,6 @@ pic_close(pic_state *pic)
pic->features = pic_invalid_value(pic); pic->features = pic_invalid_value(pic);
pic->dyn_env = pic_invalid_value(pic); pic->dyn_env = pic_invalid_value(pic);
/* free all libraries */
kh_clear(ltable, &pic->ltable);
/* free all heap objects */ /* free all heap objects */
pic_gc(pic); pic_gc(pic);
@ -294,7 +261,6 @@ pic_close(pic_state *pic)
/* free global stacks */ /* free global stacks */
kh_destroy(oblist, &pic->oblist); kh_destroy(oblist, &pic->oblist);
kh_destroy(ltable, &pic->ltable);
/* free GC arena */ /* free GC arena */
allocf(pic->userdata, pic->arena, 0); allocf(pic->userdata, pic->arena, 0);
@ -303,90 +269,72 @@ pic_close(pic_state *pic)
} }
pic_value pic_value
pic_global_ref(pic_state *pic, pic_value uid) pic_global_ref(pic_state *pic, pic_value sym)
{ {
pic_value val; pic_value val;
if (! pic_weak_has(pic, pic->globals, uid)) { if (! pic_weak_has(pic, pic->globals, sym)) {
pic_error(pic, "undefined variable", 1, uid); 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)) { if (pic_invalid_p(pic, val)) {
pic_error(pic, "uninitialized global variable", 1, uid); pic_error(pic, "uninitialized global variable", 1, sym);
} }
return val; return val;
} }
void 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)) { if (! pic_weak_has(pic, pic->globals, sym)) {
pic_error(pic, "undefined variable", 1, uid); 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_value
pic_ref(pic_state *pic, const char *lib, const char *name) pic_ref(pic_state *pic, const char *name)
{ {
pic_value sym, env; return pic_global_ref(pic, pic_intern_cstr(pic, name));
sym = pic_intern_cstr(pic, name);
env = pic_library_environment(pic, lib);
return pic_global_ref(pic, pic_find_identifier(pic, sym, env));
} }
void 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; pic_global_set(pic, pic_intern_cstr(pic, name), val);
sym = pic_intern_cstr(pic, name);
env = pic_library_environment(pic, lib);
pic_global_set(pic, pic_find_identifier(pic, sym, env), val);
} }
void 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); if (pic_weak_has(pic, pic->globals, sym)) {
pic_warnf(pic, "redefining variable: %s", pic_str(pic, pic_sym_name(pic, sym), NULL));
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));
} }
pic_weak_set(pic, pic->globals, uid, val); pic_weak_set(pic, pic->globals, sym, val);
} }
void void
pic_defun(pic_state *pic, const char *name, pic_func_t f) 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_define(pic, name, pic_make_proc(pic, f, 0, NULL));
pic_export(pic, pic_intern_cstr(pic, name));
} }
void void
pic_defvar(pic_state *pic, const char *name, pic_value init) 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_define(pic, name, pic_make_var(pic, init, pic_false_value(pic)));
pic_export(pic, pic_intern_cstr(pic, name));
} }
pic_value 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; pic_value proc, r;
va_list ap; va_list ap;
proc = pic_ref(pic, lib, name); proc = pic_ref(pic, name);
TYPE_CHECK(pic, proc, proc); TYPE_CHECK(pic, proc, proc);

10
lib/state.h
View File

@ -12,12 +12,6 @@ extern "C" {
#include "khash.h" #include "khash.h"
#include "vm.h" #include "vm.h"
struct lib {
struct string *name;
struct env *env;
struct dict *exports;
};
struct callinfo { struct callinfo {
int argc, retc; int argc, retc;
const struct code *ip; const struct code *ip;
@ -30,7 +24,6 @@ struct callinfo {
}; };
KHASH_DECLARE(oblist, struct string *, struct identifier *) KHASH_DECLARE(oblist, struct string *, struct identifier *)
KHASH_DECLARE(ltable, const char *, struct lib)
struct pic_state { struct pic_state {
pic_allocf allocf; pic_allocf allocf;
@ -48,15 +41,12 @@ struct pic_state {
pic_value dyn_env; pic_value dyn_env;
const char *lib;
pic_value features; pic_value features;
khash_t(oblist) oblist; /* string to symbol */ khash_t(oblist) oblist; /* string to symbol */
int ucnt; int ucnt;
pic_value globals; /* weak */ pic_value globals; /* weak */
pic_value macros; /* weak */ pic_value macros; /* weak */
khash_t(ltable) ltable;
bool gc_enable; bool gc_enable;
struct heap *heap; 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); pic_push(pic, pic_char_value(pic, pic_str(pic, argv[j], 0)[i]), vals);
} }
vals = pic_reverse(pic, 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); 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); pic_push(pic, pic_char_value(pic, pic_str(pic, argv[j], 0)[i]), vals);
} }
vals = pic_reverse(pic, 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); 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); pic_push(pic, pic_vec_ref(pic, argv[j], i), vals);
} }
vals = pic_reverse(pic, 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; 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); pic_push(pic, pic_vec_ref(pic, argv[j], i), vals);
} }
vals = pic_reverse(pic, 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); return pic_undef_value(pic);

231
piclib/boot.scm
View File

@ -1,52 +1,52 @@
(builtin:define-macro call-with-current-environment (core#define-macro call-with-current-environment
(builtin:lambda (form env) (core#lambda (form env)
(list (cadr form) env))) (list (cadr form) env)))
(builtin:define here (core#define here
(call-with-current-environment (call-with-current-environment
(builtin:lambda (env) (core#lambda (env)
env))) env)))
(builtin:define the ; synonym for #'var (core#define the ; synonym for #'var
(builtin:lambda (var) (core#lambda (var)
(make-identifier var here))) (make-identifier var here)))
(builtin:define the-builtin-define (the (builtin:quote builtin:define))) (core#define the-builtin-define (the (core#quote core#define)))
(builtin:define the-builtin-lambda (the (builtin:quote builtin:lambda))) (core#define the-builtin-lambda (the (core#quote core#lambda)))
(builtin:define the-builtin-begin (the (builtin:quote builtin:begin))) (core#define the-builtin-begin (the (core#quote core#begin)))
(builtin:define the-builtin-quote (the (builtin:quote builtin:quote))) (core#define the-builtin-quote (the (core#quote core#quote)))
(builtin:define the-builtin-set! (the (builtin:quote builtin:set!))) (core#define the-builtin-set! (the (core#quote core#set!)))
(builtin:define the-builtin-if (the (builtin:quote builtin:if))) (core#define the-builtin-if (the (core#quote core#if)))
(builtin:define the-builtin-define-macro (the (builtin:quote builtin:define-macro))) (core#define the-builtin-define-macro (the (core#quote core#define-macro)))
(builtin:define the-define (the (builtin:quote define))) (core#define the-define (the (core#quote define)))
(builtin:define the-lambda (the (builtin:quote lambda))) (core#define the-lambda (the (core#quote lambda)))
(builtin:define the-begin (the (builtin:quote begin))) (core#define the-begin (the (core#quote begin)))
(builtin:define the-quote (the (builtin:quote quote))) (core#define the-quote (the (core#quote quote)))
(builtin:define the-set! (the (builtin:quote set!))) (core#define the-set! (the (core#quote set!)))
(builtin:define the-if (the (builtin:quote if))) (core#define the-if (the (core#quote if)))
(builtin:define the-define-macro (the (builtin:quote define-macro))) (core#define the-define-macro (the (core#quote define-macro)))
(builtin:define-macro quote (core#define-macro quote
(builtin:lambda (form env) (core#lambda (form env)
(builtin:if (= (length form) 2) (core#if (= (length form) 2)
(list the-builtin-quote (cadr form)) (list the-builtin-quote (cadr form))
(error "illegal quote form" form)))) (error "illegal quote form" form))))
(builtin:define-macro if (core#define-macro if
(builtin:lambda (form env) (core#lambda (form env)
((builtin:lambda (len) ((core#lambda (len)
(builtin:if (= len 4) (core#if (= len 4)
(cons the-builtin-if (cdr form)) (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) (list the-builtin-if (list-ref form 1) (list-ref form 2) #undefined)
(error "illegal if form" form)))) (error "illegal if form" form))))
(length form)))) (length form))))
(builtin:define-macro begin (core#define-macro begin
(builtin:lambda (form env) (core#lambda (form env)
((builtin:lambda (len) ((core#lambda (len)
(if (= len 1) (if (= len 1)
#undefined #undefined
(if (= len 2) (if (= len 2)
@ -58,16 +58,16 @@
(cons the-begin (cddr form))))))) (cons the-begin (cddr form)))))))
(length form)))) (length form))))
(builtin:define-macro set! (core#define-macro set!
(builtin:lambda (form env) (core#lambda (form env)
(if (= (length form) 3) (if (= (length form) 3)
(if (identifier? (cadr form)) (if (identifier? (cadr form))
(cons the-builtin-set! (cdr form)) (cons the-builtin-set! (cdr form))
(error "illegal set! form" form)) (error "illegal set! form" form))
(error "illegal set! form" form)))) (error "illegal set! form" form))))
(builtin:define check-formal (core#define check-formal
(builtin:lambda (formal) (core#lambda (formal)
(if (null? formal) (if (null? formal)
#t #t
(if (identifier? formal) (if (identifier? formal)
@ -78,15 +78,15 @@
#f) #f)
#f))))) #f)))))
(builtin:define-macro lambda (core#define-macro lambda
(builtin:lambda (form env) (core#lambda (form env)
(if (= (length form) 1) (if (= (length form) 1)
(error "illegal lambda form" form) (error "illegal lambda form" form)
(if (check-formal (cadr form)) (if (check-formal (cadr form))
(list the-builtin-lambda (cadr form) (cons the-begin (cddr form))) (list the-builtin-lambda (cadr form) (cons the-begin (cddr form)))
(error "illegal lambda form" form))))) (error "illegal lambda form" form)))))
(builtin:define-macro define (core#define-macro define
(lambda (form env) (lambda (form env)
((lambda (len) ((lambda (len)
(if (= len 1) (if (= len 1)
@ -102,7 +102,7 @@
(error "define: binding to non-varaible object" form))))) (error "define: binding to non-varaible object" form)))))
(length form)))) (length form))))
(builtin:define-macro define-macro (core#define-macro define-macro
(lambda (form env) (lambda (form env)
(if (= (length form) 3) (if (= (length form) 3)
(if (identifier? (cadr form)) (if (identifier? (cadr form))
@ -527,156 +527,3 @@
(define-macro let-syntax (define-macro let-syntax
(lambda (form env) (lambda (form env)
`(,(the 'letrec-syntax) ,@(cdr form)))) `(,(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_try {
pic_init_picrin(pic); pic_init_picrin(pic);
pic_funcall(pic, "picrin.main", "main", 0); pic_funcall(pic, "picrin.main:main", 0);
status = 0; status = 0;
} }