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

library system is now implemeted in scheme

This commit is contained in:
Yuichi Nishiwaki 2017-04-03 00:37:37 +09:00
parent 408bf4cf48
commit 8f6113f61b
22 changed files with 563 additions and 144 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
Makefile
View File

@ -73,8 +73,8 @@ src/init_contrib.c:
# libpicrin.so: $(LIBPICRIN_OBJS) # libpicrin.so: $(LIBPICRIN_OBJS)
# $(CC) -shared $(CFLAGS) -o $@ $(LIBPICRIN_OBJS) $(LDFLAGS) # $(CC) -shared $(CFLAGS) -o $@ $(LIBPICRIN_OBJS) $(LDFLAGS)
lib/ext/boot.c: piclib/boot.scm lib/ext/boot.c: piclib/boot.scm piclib/library.scm
bin/picrin-bootstrap tools/mkboot.scm < piclib/boot.scm > lib/ext/boot.c cat piclib/boot.scm piclib/library.scm | bin/picrin-bootstrap tools/mkboot.scm > lib/ext/boot.c
$(LIBPICRIN_OBJS) $(PICRIN_OBJS) $(CONTRIB_OBJS): lib/include/picrin.h lib/include/picrin/*.h lib/khash.h lib/object.h lib/state.h lib/vm.h $(LIBPICRIN_OBJS) $(PICRIN_OBJS) $(CONTRIB_OBJS): lib/include/picrin.h lib/include/picrin/*.h lib/khash.h lib/object.h lib/state.h lib/vm.h

46
contrib/10.math/math.c
View File

@ -286,26 +286,32 @@ void
pic_init_math(pic_state *pic) pic_init_math(pic_state *pic)
{ {
pic_deflibrary(pic, "picrin.math"); pic_deflibrary(pic, "picrin.math");
pic_in_library(pic, "picrin.math");
pic_export(pic, 20,
"floor/", "truncate/", "floor", "ceiling", "truncate", "round",
"finite?", "infinite?", "nan?",
"sqrt", "exp", "log", "sin", "cos", "tan",
"acos", "asin", "atan", "abs", "expt");
pic_defun(pic, "floor/", pic_number_floor2); pic_defun(pic, "picrin.math:floor/", pic_number_floor2);
pic_defun(pic, "truncate/", pic_number_trunc2); pic_defun(pic, "picrin.math:truncate/", pic_number_trunc2);
pic_defun(pic, "floor", pic_number_floor); pic_defun(pic, "picrin.math:floor", pic_number_floor);
pic_defun(pic, "ceiling", pic_number_ceil); pic_defun(pic, "picrin.math:ceiling", pic_number_ceil);
pic_defun(pic, "truncate", pic_number_trunc); pic_defun(pic, "picrin.math:truncate", pic_number_trunc);
pic_defun(pic, "round", pic_number_round); pic_defun(pic, "picrin.math:round", pic_number_round);
pic_defun(pic, "finite?", pic_number_finite_p); pic_defun(pic, "picrin.math:finite?", pic_number_finite_p);
pic_defun(pic, "infinite?", pic_number_infinite_p); pic_defun(pic, "picrin.math:infinite?", pic_number_infinite_p);
pic_defun(pic, "nan?", pic_number_nan_p); pic_defun(pic, "picrin.math:nan?", pic_number_nan_p);
pic_defun(pic, "sqrt", pic_number_sqrt); pic_defun(pic, "picrin.math:sqrt", pic_number_sqrt);
pic_defun(pic, "exp", pic_number_exp); pic_defun(pic, "picrin.math:exp", pic_number_exp);
pic_defun(pic, "log", pic_number_log); pic_defun(pic, "picrin.math:log", pic_number_log);
pic_defun(pic, "sin", pic_number_sin); pic_defun(pic, "picrin.math:sin", pic_number_sin);
pic_defun(pic, "cos", pic_number_cos); pic_defun(pic, "picrin.math:cos", pic_number_cos);
pic_defun(pic, "tan", pic_number_tan); pic_defun(pic, "picrin.math:tan", pic_number_tan);
pic_defun(pic, "acos", pic_number_acos); pic_defun(pic, "picrin.math:acos", pic_number_acos);
pic_defun(pic, "asin", pic_number_asin); pic_defun(pic, "picrin.math:asin", pic_number_asin);
pic_defun(pic, "atan", pic_number_atan); pic_defun(pic, "picrin.math:atan", pic_number_atan);
pic_defun(pic, "abs", pic_number_abs); pic_defun(pic, "picrin.math:abs", pic_number_abs);
pic_defun(pic, "expt", pic_number_expt); pic_defun(pic, "picrin.math:expt", pic_number_expt);
} }

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

@ -12,8 +12,7 @@
sqrt sqrt
nan? nan?
infinite?) infinite?)
(picrin macro) (picrin macro))
(scheme file))
;; 4.1.2. Literal expressions ;; 4.1.2. Literal expressions

6
contrib/20.r7rs/scheme/eval.scm
View File

@ -7,10 +7,12 @@
#`(set! #,n (+ #,n 1))) #`(set! #,n (+ #,n 1)))
(define (environment . specs) (define (environment . specs)
(let ((lib (string-append "picrin.@@my-environment." (number->string counter)))) (let ((lib (string->symbol
(string-append "picrin.@@my-environment." (number->string counter)))))
(inc! counter) (inc! counter)
(make-library lib) (make-library lib)
(eval `(import ,@specs) lib) (parameterize ((current-library lib))
(eval `(import ,@specs) lib))
lib)) lib))
(export environment eval)) (export environment eval))

9
contrib/20.r7rs/scheme/r5rs.scm
View File

@ -7,10 +7,7 @@
(scheme cxr) (scheme cxr)
(scheme lazy) (scheme lazy)
(scheme eval) (scheme eval)
(scheme load) (scheme load))
(only (picrin base)
library-environment
find-library))
(define-library (scheme null) (define-library (scheme null)
(import (scheme base)) (import (scheme base))
@ -28,12 +25,12 @@
(define (null-environment n) (define (null-environment n)
(if (not (= n 5)) (if (not (= n 5))
(error "unsupported environment version" n) (error "unsupported environment version" n)
"scheme.null")) '(scheme null)))
(define (scheme-report-environment n) (define (scheme-report-environment n)
(if (not (= n 5)) (if (not (= n 5))
(error "unsupported environment version" n) (error "unsupported environment version" n)
"scheme.r5rs")) '(scheme r5rs)))
(export * + - / < <= = > >= (export * + - / < <= = > >=
abs acos and abs acos and

15
contrib/20.r7rs/src/file.c
View File

@ -77,12 +77,11 @@ pic_file_delete(pic_state *pic)
void void
pic_init_file(pic_state *pic) pic_init_file(pic_state *pic)
{ {
pic_deflibrary(pic, "scheme.file"); pic_defun(pic, "scheme.base:open-input-file", pic_file_open_input_file); /* for `include' */
pic_defun(pic, "scheme.file:open-input-file", pic_file_open_input_file);
pic_defun(pic, "open-input-file", pic_file_open_input_file); pic_defun(pic, "scheme.file:open-binary-input-file", pic_file_open_input_file);
pic_defun(pic, "open-binary-input-file", pic_file_open_input_file); pic_defun(pic, "scheme.file:open-output-file", pic_file_open_output_file);
pic_defun(pic, "open-output-file", pic_file_open_output_file); pic_defun(pic, "scheme.file:open-binary-output-file", pic_file_open_output_file);
pic_defun(pic, "open-binary-output-file", pic_file_open_output_file); pic_defun(pic, "scheme.file:file-exists?", pic_file_exists_p);
pic_defun(pic, "file-exists?", pic_file_exists_p); pic_defun(pic, "scheme.file:delete-file", pic_file_delete);
pic_defun(pic, "delete-file", pic_file_delete);
} }

4
contrib/20.r7rs/src/load.c
View File

@ -33,7 +33,5 @@ pic_load_load(pic_state *pic)
void void
pic_init_load(pic_state *pic) pic_init_load(pic_state *pic)
{ {
pic_deflibrary(pic, "scheme.load"); pic_defun(pic, "scheme.load:load", pic_load_load);
pic_defun(pic, "load", pic_load_load);
} }

12
contrib/20.r7rs/src/system.c
View File

@ -114,11 +114,9 @@ pic_system_getenvs(pic_state *pic)
void void
pic_init_system(pic_state *pic) pic_init_system(pic_state *pic)
{ {
pic_deflibrary(pic, "scheme.process-context"); pic_defun(pic, "scheme.process-context:command-line", pic_system_cmdline);
pic_defun(pic, "scheme.process-context:exit", pic_system_exit);
pic_defun(pic, "command-line", pic_system_cmdline); pic_defun(pic, "scheme.process-context:emergency-exit", pic_system_emergency_exit);
pic_defun(pic, "exit", pic_system_exit); pic_defun(pic, "scheme.process-context:get-environment-variable", pic_system_getenv);
pic_defun(pic, "emergency-exit", pic_system_emergency_exit); pic_defun(pic, "scheme.process-context:get-environment-variables", pic_system_getenvs);
pic_defun(pic, "get-environment-variable", pic_system_getenv);
pic_defun(pic, "get-environment-variables", pic_system_getenvs);
} }

8
contrib/20.r7rs/src/time.c
View File

@ -42,9 +42,7 @@ pic_jiffies_per_second(pic_state *pic)
void void
pic_init_time(pic_state *pic) pic_init_time(pic_state *pic)
{ {
pic_deflibrary(pic, "scheme.time"); pic_defun(pic, "scheme.time:current-second", pic_current_second);
pic_defun(pic, "scheme.time:current-jiffy", pic_current_jiffy);
pic_defun(pic, "current-second", pic_current_second); pic_defun(pic, "scheme.time:jiffies-per-second", pic_jiffies_per_second);
pic_defun(pic, "current-jiffy", pic_current_jiffy);
pic_defun(pic, "jiffies-per-second", pic_jiffies_per_second);
} }

4
contrib/30.random/src/random.c
View File

@ -15,6 +15,8 @@ void
pic_init_random(pic_state *pic) pic_init_random(pic_state *pic)
{ {
pic_deflibrary(pic, "srfi.27"); pic_deflibrary(pic, "srfi.27");
pic_in_library(pic, "srfi.27");
pic_export(pic, 1, "random-real");
pic_defun(pic, "random-real", pic_random_real); pic_defun(pic, "srfi.27:random-real", pic_random_real);
} }

53
contrib/30.readline/src/readline.c
View File

@ -245,29 +245,40 @@ pic_init_readline(pic_state *pic){
using_history(); using_history();
pic_deflibrary(pic, "picrin.readline"); pic_deflibrary(pic, "picrin.readline");
pic_in_library(pic, "picrin.readline");
pic_export(pic, 1, "readline");
pic_defun(pic, "readline", pic_rl_readline); pic_defun(pic, "picrin.readline:readline", pic_rl_readline);
pic_deflibrary(pic, "picrin.readline.history"); pic_deflibrary(pic, "picrin.readline.history");
pic_in_library(pic, "picrin.readline.history");
pic_export(pic, 19,
"history-length", "add-history", "stifle-history",
"unstifle-history", "history-stifled?",
"where-history", "current-history", "history-get",
"clear-history", "remove-history", "history-set-pos",
"previous-history", "next-history", "history-search",
"history-search-prefix", "read-history",
"write-history", "truncate-file", "history-expand");
/* pic_defun(pic, "history-offset", pic_rl_history_offset); */ /* pic_defun(pic, "picrin.readline.history:history-offset", pic_rl_history_offset); */
pic_defun(pic, "history-length", pic_rl_history_length); pic_defun(pic, "picrin.readline.history:history-length", pic_rl_history_length);
pic_defun(pic, "add-history", pic_rl_add_history); pic_defun(pic, "picrin.readline.history:add-history", pic_rl_add_history);
pic_defun(pic, "stifle-history", pic_rl_stifle_history); pic_defun(pic, "picrin.readline.history:stifle-history", pic_rl_stifle_history);
pic_defun(pic, "unstifle-history", pic_rl_unstifle_history); pic_defun(pic, "picrin.readline.history:unstifle-history", pic_rl_unstifle_history);
pic_defun(pic, "history-stifled?", pic_rl_history_is_stifled); pic_defun(pic, "picrin.readline.history:history-stifled?", pic_rl_history_is_stifled);
pic_defun(pic, "where-history", pic_rl_where_history); pic_defun(pic, "picrin.readline.history:where-history", pic_rl_where_history);
pic_defun(pic, "current-history", pic_rl_current_history); pic_defun(pic, "picrin.readline.history:current-history", pic_rl_current_history);
pic_defun(pic, "history-get", pic_rl_history_get); pic_defun(pic, "picrin.readline.history:history-get", pic_rl_history_get);
pic_defun(pic, "clear-history", pic_rl_clear_history); pic_defun(pic, "picrin.readline.history:clear-history", pic_rl_clear_history);
pic_defun(pic, "remove-history", pic_rl_remove_history); pic_defun(pic, "picrin.readline.history:remove-history", pic_rl_remove_history);
pic_defun(pic, "history-set-pos", pic_rl_history_set_pos); pic_defun(pic, "picrin.readline.history:history-set-pos", pic_rl_history_set_pos);
pic_defun(pic, "previous-history", pic_rl_previous_history); pic_defun(pic, "picrin.readline.history:previous-history", pic_rl_previous_history);
pic_defun(pic, "next-history", pic_rl_next_history); pic_defun(pic, "picrin.readline.history:next-history", pic_rl_next_history);
pic_defun(pic, "history-search", pic_rl_history_search); pic_defun(pic, "picrin.readline.history:history-search", pic_rl_history_search);
pic_defun(pic, "history-search-prefix", pic_rl_history_search_prefix); pic_defun(pic, "picrin.readline.history:history-search-prefix", pic_rl_history_search_prefix);
pic_defun(pic, "read-history", pic_rl_read_history); pic_defun(pic, "picrin.readline.history:read-history", pic_rl_read_history);
pic_defun(pic, "write-history", pic_rl_write_history); pic_defun(pic, "picrin.readline.history:write-history", pic_rl_write_history);
pic_defun(pic, "truncate-file", pic_rl_truncate_file); pic_defun(pic, "picrin.readline.history:truncate-file", pic_rl_truncate_file);
pic_defun(pic, "history-expand", pic_rl_history_expand); pic_defun(pic, "picrin.readline.history:history-expand", pic_rl_history_expand);
} }

16
contrib/30.regexp/src/regexp.c
View File

@ -168,11 +168,15 @@ void
pic_init_regexp(pic_state *pic) pic_init_regexp(pic_state *pic)
{ {
pic_deflibrary(pic, "picrin.regexp"); pic_deflibrary(pic, "picrin.regexp");
pic_in_library(pic, "picrin.regexp");
pic_export(pic, 5,
"regexp", "regexp?",
"regexp-match", "regexp-split", "regexp-replace");
pic_defun(pic, "regexp", pic_regexp_regexp); pic_defun(pic, "picrin.regexp:regexp", pic_regexp_regexp);
pic_defun(pic, "regexp?", pic_regexp_regexp_p); pic_defun(pic, "picrin.regexp:regexp?", pic_regexp_regexp_p);
pic_defun(pic, "regexp-match", pic_regexp_regexp_match); pic_defun(pic, "picrin.regexp:regexp-match", pic_regexp_regexp_match);
/* pic_defun(pic, "regexp-search", pic_regexp_regexp_search); */ /* pic_defun(pic, "picrin.regexp:regexp-search", pic_regexp_regexp_search); */
pic_defun(pic, "regexp-split", pic_regexp_regexp_split); pic_defun(pic, "picrin.regexp:regexp-split", pic_regexp_regexp_split);
pic_defun(pic, "regexp-replace", pic_regexp_regexp_replace); pic_defun(pic, "picrin.regexp:regexp-replace", pic_regexp_regexp_replace);
} }

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

@ -355,123 +355,121 @@ pic_socket_call_with_socket(pic_state *pic)
void void
pic_init_srfi_106(pic_state *pic) pic_init_srfi_106(pic_state *pic)
{ {
pic_deflibrary(pic, "srfi.106"); pic_defun(pic, "srfi.106:socket?", pic_socket_socket_p);
pic_defun(pic, "srfi.106:make-socket", pic_socket_make_socket);
pic_defun(pic, "socket?", pic_socket_socket_p); pic_defun(pic, "srfi.106:socket-accept", pic_socket_socket_accept);
pic_defun(pic, "make-socket", pic_socket_make_socket); pic_defun(pic, "srfi.106:socket-send", pic_socket_socket_send);
pic_defun(pic, "socket-accept", pic_socket_socket_accept); pic_defun(pic, "srfi.106:socket-recv", pic_socket_socket_recv);
pic_defun(pic, "socket-send", pic_socket_socket_send); pic_defun(pic, "srfi.106:socket-shutdown", pic_socket_socket_shutdown);
pic_defun(pic, "socket-recv", pic_socket_socket_recv); pic_defun(pic, "srfi.106:socket-close", pic_socket_socket_close);
pic_defun(pic, "socket-shutdown", pic_socket_socket_shutdown); pic_defun(pic, "srfi.106:socket-input-port", pic_socket_socket_input_port);
pic_defun(pic, "socket-close", pic_socket_socket_close); pic_defun(pic, "srfi.106:socket-output-port", pic_socket_socket_output_port);
pic_defun(pic, "socket-input-port", pic_socket_socket_input_port); pic_defun(pic, "srfi.106:call-with-socket", pic_socket_call_with_socket);
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, "srfi.106:*af-inet*", pic_int_value(pic, AF_INET));
#else #else
pic_define(pic, "*af-inet*", pic_false_value(pic)); pic_define(pic, "srfi.106:*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, "srfi.106:*af-inet6*", pic_int_value(pic, AF_INET6));
#else #else
pic_define(pic, "*af-inet6*", pic_false_value(pic)); pic_define(pic, "srfi.106:*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, "srfi.106:*af-unspec*", pic_int_value(pic, AF_UNSPEC));
#else #else
pic_define(pic, "*af-unspec*", pic_false_value(pic)); pic_define(pic, "srfi.106:*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, "srfi.106:*sock-stream*", pic_int_value(pic, SOCK_STREAM));
#else #else
pic_define(pic, "*sock-stream*", pic_false_value(pic)); pic_define(pic, "srfi.106:*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, "srfi.106:*sock-dgram*", pic_int_value(pic, SOCK_DGRAM));
#else #else
pic_define(pic, "*sock-dgram*", pic_false_value(pic)); pic_define(pic, "srfi.106:*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, "srfi.106:*ai-canonname*", pic_int_value(pic, AI_CANONNAME));
#else #else
pic_define(pic, "*ai-canonname*", pic_false_value(pic)); pic_define(pic, "srfi.106:*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, "srfi.106:*ai-numerichost*", pic_int_value(pic, AI_NUMERICHOST));
#else #else
pic_define(pic, "*ai-numerichost*", pic_false_value(pic)); pic_define(pic, "srfi.106:*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, "srfi.106:*ai-v4mapped*", pic_int_value(pic, AI_V4MAPPED));
#else #else
pic_define(pic, "*ai-v4mapped*", pic_false_value(pic)); pic_define(pic, "srfi.106:*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, "srfi.106:*ai-all*", pic_int_value(pic, AI_ALL));
#else #else
pic_define(pic, "*ai-all*", pic_false_value(pic)); pic_define(pic, "srfi.106:*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, "srfi.106:*ai-addrconfig*", pic_int_value(pic, AI_ADDRCONFIG));
#else #else
pic_define(pic, "*ai-addrconfig*", pic_false_value(pic)); pic_define(pic, "srfi.106:*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, "srfi.106:*ai-passive*", pic_int_value(pic, AI_PASSIVE));
#else #else
pic_define(pic, "*ai-passive*", pic_false_value(pic)); pic_define(pic, "srfi.106:*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, "srfi.106:*ipproto-ip*", pic_int_value(pic, IPPROTO_IP));
#else #else
pic_define(pic, "*ipproto-ip*", pic_false_value(pic)); pic_define(pic, "srfi.106:*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, "srfi.106:*ipproto-tcp*", pic_int_value(pic, IPPROTO_TCP));
#else #else
pic_define(pic, "*ipproto-tcp*", pic_false_value(pic)); pic_define(pic, "srfi.106:*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, "srfi.106:*ipproto-udp*", pic_int_value(pic, IPPROTO_UDP));
#else #else
pic_define(pic, "*ipproto-udp*", pic_false_value(pic)); pic_define(pic, "srfi.106:*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, "srfi.106:*msg-peek*", pic_int_value(pic, MSG_PEEK));
#else #else
pic_define(pic, "*msg-peek*", pic_false_value(pic)); pic_define(pic, "srfi.106:*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, "srfi.106:*msg-oob*", pic_int_value(pic, MSG_OOB));
#else #else
pic_define(pic, "*msg-oob*", pic_false_value(pic)); pic_define(pic, "srfi.106:*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, "srfi.106:*msg-waitall*", pic_int_value(pic, MSG_WAITALL));
#else #else
pic_define(pic, "*msg-waitall*", pic_false_value(pic)); pic_define(pic, "srfi.106:*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, "srfi.106:*shut-rd*", pic_int_value(pic, SHUT_RD));
#else #else
pic_define(pic, "*shut-rd*", pic_false_value(pic)); pic_define(pic, "srfi.106:*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, "srfi.106:*shut-wr*", pic_int_value(pic, SHUT_WR));
#else #else
pic_define(pic, "*shut-wr*", pic_false_value(pic)); pic_define(pic, "srfi.106:*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, "srfi.106:*shut-rdwr*", pic_int_value(pic, SHUT_RDWR));
#else #else
pic_define(pic, "*shut-rdwr*", pic_false_value(pic)); pic_define(pic, "srfi.106:*shut-rdwr*", pic_false_value(pic));
#endif #endif
} }

4
contrib/60.repl/repl.c
View File

@ -14,7 +14,5 @@ pic_repl_tty_p(pic_state *pic)
void void
pic_init_repl(pic_state *pic) pic_init_repl(pic_state *pic)
{ {
pic_deflibrary(pic, "picrin.repl"); pic_defun(pic, "picrin.repl:tty?", pic_repl_tty_p);
pic_defun(pic, "tty?", pic_repl_tty_p);
} }

4
contrib/60.repl/repl.scm
View File

@ -34,7 +34,7 @@
(scheme eval) (scheme eval)
(scheme r5rs) (scheme r5rs)
(picrin macro)) (picrin macro))
"picrin.user")) '(picrin user)))
(define (repeat x) (define (repeat x)
(let ((p (list x))) (let ((p (list x)))
@ -95,7 +95,7 @@
(lambda (port) (lambda (port)
(let next ((expr (read port))) (let next ((expr (read port)))
(unless (eof-object? expr) (unless (eof-object? expr)
(write (eval expr "picrin.user")) (write (eval expr))
(newline) (newline)
(set! str "") (set! str "")
(next (read port)))))))))) (next (read port))))))))))

95
lib/ext/boot.c
View File

@ -164,7 +164,100 @@ static const char boot_rom[][80] = {
" ,@body))))))) (define-macro letrec-syntax (lambda (form env) (let ((formal (car", " ,@body))))))) (define-macro letrec-syntax (lambda (form env) (let ((formal (car",
" (cdr form))) (body (cdr (cdr form)))) `(let () ,@(map (lambda (x) `(,(the 'defi", " (cdr form))) (body (cdr (cdr form)))) `(let () ,@(map (lambda (x) `(,(the 'defi",
"ne-syntax) ,(car x) ,(cadr x))) formal) ,@body)))) (define-macro let-syntax (lam", "ne-syntax) ,(car x) ,(cadr x))) formal) ,@body)))) (define-macro let-syntax (lam",
"bda (form env) `(,(the 'letrec-syntax) ,@(cdr form)))) ", "bda (form env) `(,(the 'letrec-syntax) ,@(cdr form)))) (define (mangle name) (wh",
"en (null? name) (error \"library name should be a list of at least one symbols\" n",
"ame)) (define (->string n) (cond ((symbol? n) (let ((str (symbol->string n))) (s",
"tring-for-each (lambda (c) (when (or (char=? c #\\.) (char=? c #\\:)) (error \"elem",
"ents of library name may not contain '.' or ':'\" n))) str) str)) ((and (number? ",
"n) (exact? n) (<= 0 n)) (number->string n)) (else (error \"symbol or non-negative",
" integer is required\" n)))) (define (join strs delim) (let loop ((res (car strs)",
") (strs (cdr strs))) (if (null? strs) res (loop (string-append res delim (car st",
"rs)) (cdr strs))))) (if (symbol? name) name (string->symbol (join (map ->string ",
"name) \".\")))) (define current-library (make-parameter '(picrin base) mangle)) (d",
"efine *libraries* (make-dictionary)) (define (find-library name) (dictionary-has",
"? *libraries* (mangle name))) (define (make-library name) (let ((name (mangle na",
"me))) (let ((env (make-environment (string->symbol (string-append (symbol->strin",
"g name) \":\")))) (exports (make-dictionary))) (set-identifier! 'define-library 'd",
"efine-library env) (set-identifier! 'import 'import env) (set-identifier! 'expor",
"t 'export env) (set-identifier! 'cond-expand 'cond-expand env) (dictionary-set! ",
"*libraries* name `(,env unquote exports))))) (define (library-environment name) ",
"(car (dictionary-ref *libraries* (mangle name)))) (define (library-exports name)",
" (cdr (dictionary-ref *libraries* (mangle name)))) (define (library-import name ",
"sym alias) (let ((uid (dictionary-ref (library-exports name) sym))) (let ((env (",
"library-environment (current-library)))) (set-identifier! alias uid env)))) (def",
"ine (library-export sym alias) (let ((env (library-environment (current-library)",
")) (exports (library-exports (current-library)))) (dictionary-set! exports alias",
" (find-identifier sym env)))) (define-macro define-library (lambda (form _) (let",
" ((name (cadr form)) (body (cddr form))) (or (find-library name) (make-library n",
"ame)) (parameterize ((current-library name)) (for-each (lambda (expr) (eval expr",
" name)) body))))) (define-macro cond-expand (lambda (form _) (letrec ((test (lam",
"bda (form) (or (eq? form 'else) (and (symbol? form) (memq form (features))) (and",
" (pair? form) (case (car form) ((library) (find-library (cadr form))) ((not) (no",
"t (test (cadr form)))) ((and) (let loop ((form (cdr form))) (or (null? form) (an",
"d (test (car form)) (loop (cdr form)))))) ((or) (let loop ((form (cdr form))) (a",
"nd (pair? form) (or (test (car form)) (loop (cdr form)))))) (else #f))))))) (let",
" loop ((clauses (cdr form))) (if (null? clauses) #undefined (if (test (caar clau",
"ses)) `(,the-begin ,@(cdar clauses)) (loop (cdr clauses)))))))) (define-macro im",
"port (lambda (form _) (let ((caddr (lambda (x) (car (cdr (cdr x))))) (prefix (la",
"mbda (prefix symbol) (string->symbol (string-append (symbol->string prefix) (sym",
"bol->string symbol))))) (getlib (lambda (name) (if (find-library name) name (err",
"or \"library not found\" name))))) (letrec ((extract (lambda (spec) (case (car spe",
"c) ((only rename prefix except) (extract (cadr spec))) (else (getlib spec))))) (",
"collect (lambda (spec) (case (car spec) ((only) (let ((alist (collect (cadr spec",
")))) (map (lambda (var) (assq var alist)) (cddr spec)))) ((rename) (let ((alist ",
"(collect (cadr spec))) (renames (map (lambda (x) `(,(car x) unquote (cadr x))) (",
"cddr spec)))) (map (lambda (s) (or (assq (car s) renames) s)) alist))) ((prefix)",
" (let ((alist (collect (cadr spec)))) (map (lambda (s) (cons (prefix (caddr spec",
") (car s)) (cdr s))) alist))) ((except) (let ((alist (collect (cadr spec)))) (le",
"t loop ((alist alist)) (if (null? alist) '() (if (memq (caar alist) (cddr spec))",
" (loop (cdr alist)) (cons (car alist) (loop (cdr alist)))))))) (else (dictionary",
"-map (lambda (x) (cons x x)) (library-exports (getlib spec)))))))) (letrec ((imp",
"ort (lambda (spec) (let ((lib (extract spec)) (alist (collect spec))) (for-each ",
"(lambda (slot) (library-import lib (cdr slot) (car slot))) alist))))) (for-each ",
"import (cdr form))))))) (define-macro export (lambda (form _) (letrec ((collect ",
"(lambda (spec) (cond ((symbol? spec) `(,spec unquote spec)) ((and (list? spec) (",
"= (length spec) 3) (eq? (car spec) 'rename)) `(,(list-ref spec 1) unquote (list-",
"ref spec 2))) (else (error \"malformed export\"))))) (export (lambda (spec) (let (",
"(slot (collect spec))) (library-export (car slot) (cdr slot)))))) (for-each expo",
"rt (cdr form))))) (let () (make-library '(picrin base)) (set-car! (dictionary-re",
"f *libraries* (mangle '(picrin base))) default-environment) (let ((export-keywor",
"ds (lambda (keywords) (let ((env (library-environment '(picrin base))) (exports ",
"(library-exports '(picrin base)))) (for-each (lambda (keyword) (dictionary-set! ",
"exports keyword keyword)) keywords))))) (export-keywords '(define lambda quote s",
"et! if begin define-macro let let* letrec letrec* let-values let*-values define-",
"values quasiquote unquote unquote-splicing and or cond case else => do when unle",
"ss parameterize define-syntax syntax-quote syntax-unquote syntax-quasiquote synt",
"ax-unquote-splicing let-syntax letrec-syntax syntax-error)) (export-keywords '(f",
"eatures eq? eqv? equal? not boolean? boolean=? pair? cons car cdr null? set-car!",
" set-cdr! caar cadr cdar cddr list? make-list list length append reverse list-ta",
"il list-ref list-set! list-copy map for-each memq memv member assq assv assoc cu",
"rrent-input-port current-output-port current-error-port port? input-port? output",
"-port? port-open? close-port eof-object? eof-object read-u8 peek-u8 read-bytevec",
"tor! write-u8 write-bytevector flush-output-port open-input-bytevector open-outp",
"ut-bytevector get-output-bytevector number? exact? inexact? inexact exact = < > ",
"<= >= + - * / number->string string->number procedure? apply symbol? symbol=? sy",
"mbol->string string->symbol make-identifier identifier? identifier=? identifier-",
"base identifier-environment vector? vector make-vector vector-length vector-ref ",
"vector-set! vector-copy! vector-copy vector-append vector-fill! vector-map vecto",
"r-for-each list->vector vector->list string->vector vector->string bytevector? b",
"ytevector make-bytevector bytevector-length bytevector-u8-ref bytevector-u8-set!",
" bytevector-copy! bytevector-copy bytevector-append bytevector->list list->bytev",
"ector call-with-current-continuation call/cc values call-with-values char? char-",
">integer integer->char char=? char<? char>? char<=? char>=? current-exception-ha",
"ndlers with-exception-handler raise raise-continuable error error-object? error-",
"object-message error-object-irritants error-object-type string? string make-stri",
"ng string-length string-ref string-set! string-copy string-copy! string-fill! st",
"ring-append string-map string-for-each list->string string->list string=? string",
"<? string>? string<=? string>=? make-parameter with-dynamic-environment read mak",
"e-dictionary dictionary? dictionary dictionary-has? dictionary-ref dictionary-se",
"t! dictionary-delete! dictionary-size dictionary-map dictionary-for-each diction",
"ary->alist alist->dictionary dictionary->plist plist->dictionary make-record rec",
"ord? record-type record-datum default-environment make-environment find-identifi",
"er set-identifier! eval make-ephemeron-table write write-simple write-shared dis",
"play)) (export-keywords '(find-library make-library current-library))) (set! eva",
"l (let ((e eval)) (lambda (expr . lib) (let ((lib (if (null? lib) (current-libra",
"ry) (car lib)))) (e expr (library-environment lib)))))) (make-library '(picrin u",
"ser)) (current-library '(picrin user))) ",
}; };
void void

40
lib/ext/eval.c
View File

@ -1219,6 +1219,43 @@ pic_compile(pic_state *pic, pic_value obj)
return pic_make_proc_irep(pic, irep, NULL); return pic_make_proc_irep(pic, irep, NULL);
} }
static pic_value
pic_eval_make_environment(pic_state *pic)
{
pic_value name;
pic_get_args(pic, "m", &name);
return pic_make_env(pic, pic_sym_name(pic, name));
}
static pic_value
pic_eval_set_identifier(pic_state *pic)
{
pic_value id, uid, env;
pic_get_args(pic, "omo", &id, &uid, &env);
TYPE_CHECK(pic, id, id);
TYPE_CHECK(pic, env, env);
pic_set_identifier(pic, id, uid, env);
return pic_undef_value(pic);
}
static pic_value
pic_eval_find_identifier(pic_state *pic)
{
pic_value id, env;
pic_get_args(pic, "oo", &id, &env);
TYPE_CHECK(pic, id, id);
TYPE_CHECK(pic, env, env);
return pic_find_identifier(pic, id, env);
}
static pic_value static pic_value
pic_eval_eval(pic_state *pic) pic_eval_eval(pic_state *pic)
{ {
@ -1253,5 +1290,8 @@ pic_init_eval(pic_state *pic)
add_keyword("core#begin"); add_keyword("core#begin");
add_keyword("core#define-macro"); add_keyword("core#define-macro");
pic_define(pic, "default-environment", env); pic_define(pic, "default-environment", env);
pic_defun(pic, "make-environment", pic_eval_make_environment);
pic_defun(pic, "find-identifier", pic_eval_find_identifier);
pic_defun(pic, "set-identifier!", pic_eval_set_identifier);
pic_defun(pic, "eval", pic_eval_eval); pic_defun(pic, "eval", pic_eval_eval);
} }

2
lib/ext/lib.c
View File

@ -25,7 +25,7 @@ pic_in_library(pic_state *pic, const char *lib)
} }
void void
export(pic_state *pic, int n, ...) pic_export(pic_state *pic, int n, ...)
{ {
size_t ai = pic_enter(pic); size_t ai = pic_enter(pic);
va_list ap; va_list ap;

2
lib/include/picrin.h
View File

@ -115,7 +115,7 @@ pic_value pic_bool_value(pic_state *, bool);
pic_value pic_true_value(pic_state *); pic_value pic_true_value(pic_state *);
pic_value pic_false_value(pic_state *); pic_value pic_false_value(pic_state *);
pic_value pic_str_value(pic_state *, const char *str, int len); pic_value pic_str_value(pic_state *, const char *str, int len);
#define pic_cstr_value(pic, cstr) pic_str_value(pic, (cstr), strlen(cstr)) pic_value pic_cstr_value(pic_state *, const char *str);
#define pic_lit_value(pic, lit) pic_str_value(pic, "" lit, -((int)sizeof lit - 1)) #define pic_lit_value(pic, lit) pic_str_value(pic, "" lit, -((int)sizeof lit - 1))
pic_value pic_strf_value(pic_state *, const char *fmt, ...); pic_value pic_strf_value(pic_state *, const char *fmt, ...);
pic_value pic_vstrf_value(pic_state *, const char *fmt, va_list ap); pic_value pic_vstrf_value(pic_state *, const char *fmt, va_list ap);

1
lib/state.c
View File

@ -274,7 +274,6 @@ pic_global_ref(pic_state *pic, pic_value sym)
pic_value val; pic_value val;
if (! pic_dict_has(pic, pic->globals, sym)) { if (! pic_dict_has(pic, pic->globals, sym)) {
printf("%s\n", pic_str(pic, pic_sym_name(pic, sym), 0));
pic_error(pic, "undefined variable", 1, sym); pic_error(pic, "undefined variable", 1, sym);
} }
val = pic_dict_ref(pic, pic->globals, sym); val = pic_dict_ref(pic, pic->globals, sym);

6
lib/string.c
View File

@ -213,6 +213,12 @@ pic_str_value(pic_state *pic, const char *str, int len)
return make_str(pic, r); return make_str(pic, r);
} }
pic_value
pic_cstr_value(pic_state *pic, const char *cstr)
{
return pic_str_value(pic, cstr, strlen(cstr));
}
pic_value pic_value
pic_strf_value(pic_state *pic, const char *fmt, ...) pic_strf_value(pic_state *pic, const char *fmt, ...)
{ {

271
piclib/library.scm Normal file
View File

@ -0,0 +1,271 @@
;;; There are two ways to name a library: (foo bar) or foo.bar
;;; The former is normalized to the latter.
(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) (<= 0 n))
(number->string n))
(else
(error "symbol or non-negative integer is required" n))))
(define (join strs delim)
(let loop ((res (car strs)) (strs (cdr strs)))
(if (null? strs)
res
(loop (string-append res delim (car strs)) (cdr strs)))))
(if (symbol? name)
name ; TODO: check symbol names
(string->symbol (join (map ->string name) "."))))
(define current-library
(make-parameter '(picrin base) mangle))
(define *libraries*
(make-dictionary))
(define (find-library name)
(dictionary-has? *libraries* (mangle name)))
(define (make-library name)
(let ((name (mangle name)))
(let ((env (make-environment
(string->symbol (string-append (symbol->string name) ":"))))
(exports (make-dictionary)))
;; set up initial environment
(set-identifier! 'define-library 'define-library env)
(set-identifier! 'import 'import env)
(set-identifier! 'export 'export env)
(set-identifier! 'cond-expand 'cond-expand env)
(dictionary-set! *libraries* name `(,env . ,exports)))))
(define (library-environment name)
(car (dictionary-ref *libraries* (mangle name))))
(define (library-exports name)
(cdr (dictionary-ref *libraries* (mangle name))))
(define (library-import name sym alias)
(let ((uid (dictionary-ref (library-exports name) sym)))
(let ((env (library-environment (current-library))))
(set-identifier! alias uid env))))
(define (library-export sym alias)
(let ((env (library-environment (current-library)))
(exports (library-exports (current-library))))
(dictionary-set! exports alias (find-identifier sym env))))
;;; R7RS library syntax
(define-macro define-library
(lambda (form _)
(let ((name (cadr form))
(body (cddr form)))
(or (find-library name) (make-library name))
(parameterize ((current-library name))
(for-each
(lambda (expr)
(eval expr name)) ; TODO parse library declarations
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 (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)
(if (find-library name)
name
(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
(dictionary-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)))))
;;; bootstrap...
(let ()
(make-library '(picrin base))
(set-car! (dictionary-ref *libraries* (mangle '(picrin base))) default-environment)
(let ((export-keywords
(lambda (keywords)
(let ((env (library-environment '(picrin base)))
(exports (library-exports '(picrin base))))
(for-each
(lambda (keyword)
(dictionary-set! exports keyword keyword))
keywords)))))
(export-keywords
'(define lambda quote 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))
(export-keywords
'(features
eq? eqv? equal? not boolean? boolean=?
pair? cons car cdr null? set-car! set-cdr!
caar cadr cdar cddr
list? make-list list length append reverse
list-tail list-ref list-set! list-copy
map for-each memq memv member assq assv assoc
current-input-port current-output-port current-error-port
port? input-port? output-port? port-open? close-port
eof-object? eof-object
read-u8 peek-u8 read-bytevector!
write-u8 write-bytevector flush-output-port
open-input-bytevector open-output-bytevector get-output-bytevector
number? exact? inexact? inexact exact
= < > <= >= + - * /
number->string string->number
procedure? apply
symbol? symbol=? symbol->string string->symbol
make-identifier identifier? identifier=? identifier-base identifier-environment
vector? vector make-vector vector-length vector-ref vector-set!
vector-copy! vector-copy vector-append vector-fill! vector-map vector-for-each
list->vector vector->list string->vector vector->string
bytevector? bytevector make-bytevector
bytevector-length bytevector-u8-ref bytevector-u8-set!
bytevector-copy! bytevector-copy bytevector-append
bytevector->list list->bytevector
call-with-current-continuation call/cc values call-with-values
char? char->integer integer->char char=? char<? char>? char<=? char>=?
current-exception-handlers with-exception-handler
raise raise-continuable error
error-object? error-object-message error-object-irritants
error-object-type
string? string make-string string-length string-ref string-set!
string-copy string-copy! string-fill! string-append
string-map string-for-each list->string string->list
string=? string<? string>? string<=? string>=?
make-parameter with-dynamic-environment
read
make-dictionary dictionary? dictionary dictionary-has?
dictionary-ref dictionary-set! dictionary-delete! dictionary-size
dictionary-map dictionary-for-each
dictionary->alist alist->dictionary dictionary->plist plist->dictionary
make-record record? record-type record-datum
default-environment make-environment find-identifier set-identifier!
eval
make-ephemeron-table
write write-simple write-shared display))
(export-keywords
'(find-library make-library current-library)))
(set! eval
(let ((e eval))
(lambda (expr . lib)
(let ((lib (if (null? lib) (current-library) (car lib))))
(e expr (library-environment lib))))))
(make-library '(picrin user))
(current-library '(picrin user)))