library system is now implemeted in scheme
This commit is contained in:
Yuichi Nishiwaki
parent
408bf4cf48
commit
8f6113f61b
4
Makefile
4
Makefile
|
|
@ -73,8 +73,8 @@ src/init_contrib.c:
|
|||
# libpicrin.so: $(LIBPICRIN_OBJS)
|
||||
# $(CC) -shared $(CFLAGS) -o $@ $(LIBPICRIN_OBJS) $(LDFLAGS)
|
||||
|
||||
lib/ext/boot.c: piclib/boot.scm
|
||||
bin/picrin-bootstrap tools/mkboot.scm < piclib/boot.scm > lib/ext/boot.c
|
||||
lib/ext/boot.c: piclib/boot.scm piclib/library.scm
|
||||
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
|
||||
|
||||
|
|
|
|||
|
|
@ -286,26 +286,32 @@ void
|
|||
pic_init_math(pic_state *pic)
|
||||
{
|
||||
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, "truncate/", pic_number_trunc2);
|
||||
pic_defun(pic, "floor", pic_number_floor);
|
||||
pic_defun(pic, "ceiling", pic_number_ceil);
|
||||
pic_defun(pic, "truncate", pic_number_trunc);
|
||||
pic_defun(pic, "round", pic_number_round);
|
||||
pic_defun(pic, "picrin.math:floor/", pic_number_floor2);
|
||||
pic_defun(pic, "picrin.math:truncate/", pic_number_trunc2);
|
||||
pic_defun(pic, "picrin.math:floor", pic_number_floor);
|
||||
pic_defun(pic, "picrin.math:ceiling", pic_number_ceil);
|
||||
pic_defun(pic, "picrin.math:truncate", pic_number_trunc);
|
||||
pic_defun(pic, "picrin.math:round", pic_number_round);
|
||||
|
||||
pic_defun(pic, "finite?", pic_number_finite_p);
|
||||
pic_defun(pic, "infinite?", pic_number_infinite_p);
|
||||
pic_defun(pic, "nan?", pic_number_nan_p);
|
||||
pic_defun(pic, "sqrt", pic_number_sqrt);
|
||||
pic_defun(pic, "exp", pic_number_exp);
|
||||
pic_defun(pic, "log", pic_number_log);
|
||||
pic_defun(pic, "sin", pic_number_sin);
|
||||
pic_defun(pic, "cos", pic_number_cos);
|
||||
pic_defun(pic, "tan", pic_number_tan);
|
||||
pic_defun(pic, "acos", pic_number_acos);
|
||||
pic_defun(pic, "asin", pic_number_asin);
|
||||
pic_defun(pic, "atan", pic_number_atan);
|
||||
pic_defun(pic, "abs", pic_number_abs);
|
||||
pic_defun(pic, "expt", pic_number_expt);
|
||||
pic_defun(pic, "picrin.math:finite?", pic_number_finite_p);
|
||||
pic_defun(pic, "picrin.math:infinite?", pic_number_infinite_p);
|
||||
pic_defun(pic, "picrin.math:nan?", pic_number_nan_p);
|
||||
pic_defun(pic, "picrin.math:sqrt", pic_number_sqrt);
|
||||
pic_defun(pic, "picrin.math:exp", pic_number_exp);
|
||||
pic_defun(pic, "picrin.math:log", pic_number_log);
|
||||
pic_defun(pic, "picrin.math:sin", pic_number_sin);
|
||||
pic_defun(pic, "picrin.math:cos", pic_number_cos);
|
||||
pic_defun(pic, "picrin.math:tan", pic_number_tan);
|
||||
pic_defun(pic, "picrin.math:acos", pic_number_acos);
|
||||
pic_defun(pic, "picrin.math:asin", pic_number_asin);
|
||||
pic_defun(pic, "picrin.math:atan", pic_number_atan);
|
||||
pic_defun(pic, "picrin.math:abs", pic_number_abs);
|
||||
pic_defun(pic, "picrin.math:expt", pic_number_expt);
|
||||
}
|
||||
|
|
|
|||
|
|
@ -12,8 +12,7 @@
|
|||
sqrt
|
||||
nan?
|
||||
infinite?)
|
||||
(picrin macro)
|
||||
(scheme file))
|
||||
(picrin macro))
|
||||
|
||||
;; 4.1.2. Literal expressions
|
||||
|
||||
|
|
|
|||
|
|
@ -7,10 +7,12 @@
|
|||
#`(set! #,n (+ #,n 1)))
|
||||
|
||||
(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)
|
||||
(make-library lib)
|
||||
(eval `(import ,@specs) lib)
|
||||
(parameterize ((current-library lib))
|
||||
(eval `(import ,@specs) lib))
|
||||
lib))
|
||||
|
||||
(export environment eval))
|
||||
|
|
|
|||
|
|
@ -7,10 +7,7 @@
|
|||
(scheme cxr)
|
||||
(scheme lazy)
|
||||
(scheme eval)
|
||||
(scheme load)
|
||||
(only (picrin base)
|
||||
library-environment
|
||||
find-library))
|
||||
(scheme load))
|
||||
|
||||
(define-library (scheme null)
|
||||
(import (scheme base))
|
||||
|
|
@ -28,12 +25,12 @@
|
|||
(define (null-environment n)
|
||||
(if (not (= n 5))
|
||||
(error "unsupported environment version" n)
|
||||
"scheme.null"))
|
||||
'(scheme null)))
|
||||
|
||||
(define (scheme-report-environment n)
|
||||
(if (not (= n 5))
|
||||
(error "unsupported environment version" n)
|
||||
"scheme.r5rs"))
|
||||
'(scheme r5rs)))
|
||||
|
||||
(export * + - / < <= = > >=
|
||||
abs acos and
|
||||
|
|
|
|||
|
|
@ -77,12 +77,11 @@ pic_file_delete(pic_state *pic)
|
|||
void
|
||||
pic_init_file(pic_state *pic)
|
||||
{
|
||||
pic_deflibrary(pic, "scheme.file");
|
||||
|
||||
pic_defun(pic, "open-input-file", pic_file_open_input_file);
|
||||
pic_defun(pic, "open-binary-input-file", pic_file_open_input_file);
|
||||
pic_defun(pic, "open-output-file", pic_file_open_output_file);
|
||||
pic_defun(pic, "open-binary-output-file", pic_file_open_output_file);
|
||||
pic_defun(pic, "file-exists?", pic_file_exists_p);
|
||||
pic_defun(pic, "delete-file", pic_file_delete);
|
||||
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, "scheme.file: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, "scheme.file:open-binary-output-file", pic_file_open_output_file);
|
||||
pic_defun(pic, "scheme.file:file-exists?", pic_file_exists_p);
|
||||
pic_defun(pic, "scheme.file:delete-file", pic_file_delete);
|
||||
}
|
||||
|
|
|
|||
|
|
@ -33,7 +33,5 @@ pic_load_load(pic_state *pic)
|
|||
void
|
||||
pic_init_load(pic_state *pic)
|
||||
{
|
||||
pic_deflibrary(pic, "scheme.load");
|
||||
|
||||
pic_defun(pic, "load", pic_load_load);
|
||||
pic_defun(pic, "scheme.load:load", pic_load_load);
|
||||
}
|
||||
|
|
|
|||
|
|
@ -114,11 +114,9 @@ pic_system_getenvs(pic_state *pic)
|
|||
void
|
||||
pic_init_system(pic_state *pic)
|
||||
{
|
||||
pic_deflibrary(pic, "scheme.process-context");
|
||||
|
||||
pic_defun(pic, "command-line", pic_system_cmdline);
|
||||
pic_defun(pic, "exit", pic_system_exit);
|
||||
pic_defun(pic, "emergency-exit", pic_system_emergency_exit);
|
||||
pic_defun(pic, "get-environment-variable", pic_system_getenv);
|
||||
pic_defun(pic, "get-environment-variables", pic_system_getenvs);
|
||||
pic_defun(pic, "scheme.process-context:command-line", pic_system_cmdline);
|
||||
pic_defun(pic, "scheme.process-context:exit", pic_system_exit);
|
||||
pic_defun(pic, "scheme.process-context:emergency-exit", pic_system_emergency_exit);
|
||||
pic_defun(pic, "scheme.process-context:get-environment-variable", pic_system_getenv);
|
||||
pic_defun(pic, "scheme.process-context:get-environment-variables", pic_system_getenvs);
|
||||
}
|
||||
|
|
|
|||
|
|
@ -42,9 +42,7 @@ pic_jiffies_per_second(pic_state *pic)
|
|||
void
|
||||
pic_init_time(pic_state *pic)
|
||||
{
|
||||
pic_deflibrary(pic, "scheme.time");
|
||||
|
||||
pic_defun(pic, "current-second", pic_current_second);
|
||||
pic_defun(pic, "current-jiffy", pic_current_jiffy);
|
||||
pic_defun(pic, "jiffies-per-second", pic_jiffies_per_second);
|
||||
pic_defun(pic, "scheme.time:current-second", pic_current_second);
|
||||
pic_defun(pic, "scheme.time:current-jiffy", pic_current_jiffy);
|
||||
pic_defun(pic, "scheme.time:jiffies-per-second", pic_jiffies_per_second);
|
||||
}
|
||||
|
|
|
|||
|
|
@ -15,6 +15,8 @@ void
|
|||
pic_init_random(pic_state *pic)
|
||||
{
|
||||
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);
|
||||
}
|
||||
|
|
|
|||
|
|
@ -245,29 +245,40 @@ pic_init_readline(pic_state *pic){
|
|||
using_history();
|
||||
|
||||
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_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, "history-length", pic_rl_history_length);
|
||||
pic_defun(pic, "add-history", pic_rl_add_history);
|
||||
pic_defun(pic, "stifle-history", pic_rl_stifle_history);
|
||||
pic_defun(pic, "unstifle-history", pic_rl_unstifle_history);
|
||||
pic_defun(pic, "history-stifled?", pic_rl_history_is_stifled);
|
||||
pic_defun(pic, "where-history", pic_rl_where_history);
|
||||
pic_defun(pic, "current-history", pic_rl_current_history);
|
||||
pic_defun(pic, "history-get", pic_rl_history_get);
|
||||
pic_defun(pic, "clear-history", pic_rl_clear_history);
|
||||
pic_defun(pic, "remove-history", pic_rl_remove_history);
|
||||
pic_defun(pic, "history-set-pos", pic_rl_history_set_pos);
|
||||
pic_defun(pic, "previous-history", pic_rl_previous_history);
|
||||
pic_defun(pic, "next-history", pic_rl_next_history);
|
||||
pic_defun(pic, "history-search", pic_rl_history_search);
|
||||
pic_defun(pic, "history-search-prefix", pic_rl_history_search_prefix);
|
||||
pic_defun(pic, "read-history", pic_rl_read_history);
|
||||
pic_defun(pic, "write-history", pic_rl_write_history);
|
||||
pic_defun(pic, "truncate-file", pic_rl_truncate_file);
|
||||
pic_defun(pic, "history-expand", pic_rl_history_expand);
|
||||
/* pic_defun(pic, "picrin.readline.history:history-offset", pic_rl_history_offset); */
|
||||
pic_defun(pic, "picrin.readline.history:history-length", pic_rl_history_length);
|
||||
pic_defun(pic, "picrin.readline.history:add-history", pic_rl_add_history);
|
||||
pic_defun(pic, "picrin.readline.history:stifle-history", pic_rl_stifle_history);
|
||||
pic_defun(pic, "picrin.readline.history:unstifle-history", pic_rl_unstifle_history);
|
||||
pic_defun(pic, "picrin.readline.history:history-stifled?", pic_rl_history_is_stifled);
|
||||
pic_defun(pic, "picrin.readline.history:where-history", pic_rl_where_history);
|
||||
pic_defun(pic, "picrin.readline.history:current-history", pic_rl_current_history);
|
||||
pic_defun(pic, "picrin.readline.history:history-get", pic_rl_history_get);
|
||||
pic_defun(pic, "picrin.readline.history:clear-history", pic_rl_clear_history);
|
||||
pic_defun(pic, "picrin.readline.history:remove-history", pic_rl_remove_history);
|
||||
pic_defun(pic, "picrin.readline.history:history-set-pos", pic_rl_history_set_pos);
|
||||
pic_defun(pic, "picrin.readline.history:previous-history", pic_rl_previous_history);
|
||||
pic_defun(pic, "picrin.readline.history:next-history", pic_rl_next_history);
|
||||
pic_defun(pic, "picrin.readline.history:history-search", pic_rl_history_search);
|
||||
pic_defun(pic, "picrin.readline.history:history-search-prefix", pic_rl_history_search_prefix);
|
||||
pic_defun(pic, "picrin.readline.history:read-history", pic_rl_read_history);
|
||||
pic_defun(pic, "picrin.readline.history:write-history", pic_rl_write_history);
|
||||
pic_defun(pic, "picrin.readline.history:truncate-file", pic_rl_truncate_file);
|
||||
pic_defun(pic, "picrin.readline.history:history-expand", pic_rl_history_expand);
|
||||
}
|
||||
|
|
|
|||
|
|
@ -168,11 +168,15 @@ void
|
|||
pic_init_regexp(pic_state *pic)
|
||||
{
|
||||
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, "regexp?", pic_regexp_regexp_p);
|
||||
pic_defun(pic, "regexp-match", pic_regexp_regexp_match);
|
||||
/* pic_defun(pic, "regexp-search", pic_regexp_regexp_search); */
|
||||
pic_defun(pic, "regexp-split", pic_regexp_regexp_split);
|
||||
pic_defun(pic, "regexp-replace", pic_regexp_regexp_replace);
|
||||
pic_defun(pic, "picrin.regexp:regexp", pic_regexp_regexp);
|
||||
pic_defun(pic, "picrin.regexp:regexp?", pic_regexp_regexp_p);
|
||||
pic_defun(pic, "picrin.regexp:regexp-match", pic_regexp_regexp_match);
|
||||
/* pic_defun(pic, "picrin.regexp:regexp-search", pic_regexp_regexp_search); */
|
||||
pic_defun(pic, "picrin.regexp:regexp-split", pic_regexp_regexp_split);
|
||||
pic_defun(pic, "picrin.regexp:regexp-replace", pic_regexp_regexp_replace);
|
||||
}
|
||||
|
|
|
|||
|
|
@ -355,123 +355,121 @@ pic_socket_call_with_socket(pic_state *pic)
|
|||
void
|
||||
pic_init_srfi_106(pic_state *pic)
|
||||
{
|
||||
pic_deflibrary(pic, "srfi.106");
|
||||
|
||||
pic_defun(pic, "socket?", pic_socket_socket_p);
|
||||
pic_defun(pic, "make-socket", pic_socket_make_socket);
|
||||
pic_defun(pic, "socket-accept", pic_socket_socket_accept);
|
||||
pic_defun(pic, "socket-send", pic_socket_socket_send);
|
||||
pic_defun(pic, "socket-recv", pic_socket_socket_recv);
|
||||
pic_defun(pic, "socket-shutdown", pic_socket_socket_shutdown);
|
||||
pic_defun(pic, "socket-close", pic_socket_socket_close);
|
||||
pic_defun(pic, "socket-input-port", pic_socket_socket_input_port);
|
||||
pic_defun(pic, "socket-output-port", pic_socket_socket_output_port);
|
||||
pic_defun(pic, "call-with-socket", pic_socket_call_with_socket);
|
||||
pic_defun(pic, "srfi.106:socket?", pic_socket_socket_p);
|
||||
pic_defun(pic, "srfi.106:make-socket", pic_socket_make_socket);
|
||||
pic_defun(pic, "srfi.106:socket-accept", pic_socket_socket_accept);
|
||||
pic_defun(pic, "srfi.106:socket-send", pic_socket_socket_send);
|
||||
pic_defun(pic, "srfi.106:socket-recv", pic_socket_socket_recv);
|
||||
pic_defun(pic, "srfi.106:socket-shutdown", pic_socket_socket_shutdown);
|
||||
pic_defun(pic, "srfi.106:socket-close", pic_socket_socket_close);
|
||||
pic_defun(pic, "srfi.106:socket-input-port", pic_socket_socket_input_port);
|
||||
pic_defun(pic, "srfi.106:socket-output-port", pic_socket_socket_output_port);
|
||||
pic_defun(pic, "srfi.106:call-with-socket", pic_socket_call_with_socket);
|
||||
|
||||
#ifdef AF_INET
|
||||
pic_define(pic, "*af-inet*", pic_int_value(pic, AF_INET));
|
||||
pic_define(pic, "srfi.106:*af-inet*", pic_int_value(pic, AF_INET));
|
||||
#else
|
||||
pic_define(pic, "*af-inet*", pic_false_value(pic));
|
||||
pic_define(pic, "srfi.106:*af-inet*", pic_false_value(pic));
|
||||
#endif
|
||||
#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
|
||||
pic_define(pic, "*af-inet6*", pic_false_value(pic));
|
||||
pic_define(pic, "srfi.106:*af-inet6*", pic_false_value(pic));
|
||||
#endif
|
||||
#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
|
||||
pic_define(pic, "*af-unspec*", pic_false_value(pic));
|
||||
pic_define(pic, "srfi.106:*af-unspec*", pic_false_value(pic));
|
||||
#endif
|
||||
|
||||
#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
|
||||
pic_define(pic, "*sock-stream*", pic_false_value(pic));
|
||||
pic_define(pic, "srfi.106:*sock-stream*", pic_false_value(pic));
|
||||
#endif
|
||||
#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
|
||||
pic_define(pic, "*sock-dgram*", pic_false_value(pic));
|
||||
pic_define(pic, "srfi.106:*sock-dgram*", pic_false_value(pic));
|
||||
#endif
|
||||
|
||||
#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
|
||||
pic_define(pic, "*ai-canonname*", pic_false_value(pic));
|
||||
pic_define(pic, "srfi.106:*ai-canonname*", pic_false_value(pic));
|
||||
#endif
|
||||
#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
|
||||
pic_define(pic, "*ai-numerichost*", pic_false_value(pic));
|
||||
pic_define(pic, "srfi.106:*ai-numerichost*", pic_false_value(pic));
|
||||
#endif
|
||||
/* AI_V4MAPPED and AI_ALL are not supported by *BSDs, even though they are defined in netdb.h. */
|
||||
#if defined(AI_V4MAPPED) && !defined(BSD)
|
||||
pic_define(pic, "*ai-v4mapped*", pic_int_value(pic, AI_V4MAPPED));
|
||||
pic_define(pic, "srfi.106:*ai-v4mapped*", pic_int_value(pic, AI_V4MAPPED));
|
||||
#else
|
||||
pic_define(pic, "*ai-v4mapped*", pic_false_value(pic));
|
||||
pic_define(pic, "srfi.106:*ai-v4mapped*", pic_false_value(pic));
|
||||
#endif
|
||||
#if defined(AI_ALL) && !defined(BSD)
|
||||
pic_define(pic, "*ai-all*", pic_int_value(pic, AI_ALL));
|
||||
pic_define(pic, "srfi.106:*ai-all*", pic_int_value(pic, AI_ALL));
|
||||
#else
|
||||
pic_define(pic, "*ai-all*", pic_false_value(pic));
|
||||
pic_define(pic, "srfi.106:*ai-all*", pic_false_value(pic));
|
||||
#endif
|
||||
#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
|
||||
pic_define(pic, "*ai-addrconfig*", pic_false_value(pic));
|
||||
pic_define(pic, "srfi.106:*ai-addrconfig*", pic_false_value(pic));
|
||||
#endif
|
||||
#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
|
||||
pic_define(pic, "*ai-passive*", pic_false_value(pic));
|
||||
pic_define(pic, "srfi.106:*ai-passive*", pic_false_value(pic));
|
||||
#endif
|
||||
|
||||
#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
|
||||
pic_define(pic, "*ipproto-ip*", pic_false_value(pic));
|
||||
pic_define(pic, "srfi.106:*ipproto-ip*", pic_false_value(pic));
|
||||
#endif
|
||||
#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
|
||||
pic_define(pic, "*ipproto-tcp*", pic_false_value(pic));
|
||||
pic_define(pic, "srfi.106:*ipproto-tcp*", pic_false_value(pic));
|
||||
#endif
|
||||
#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
|
||||
pic_define(pic, "*ipproto-udp*", pic_false_value(pic));
|
||||
pic_define(pic, "srfi.106:*ipproto-udp*", pic_false_value(pic));
|
||||
#endif
|
||||
|
||||
#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
|
||||
pic_define(pic, "*msg-peek*", pic_false_value(pic));
|
||||
pic_define(pic, "srfi.106:*msg-peek*", pic_false_value(pic));
|
||||
#endif
|
||||
#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
|
||||
pic_define(pic, "*msg-oob*", pic_false_value(pic));
|
||||
pic_define(pic, "srfi.106:*msg-oob*", pic_false_value(pic));
|
||||
#endif
|
||||
#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
|
||||
pic_define(pic, "*msg-waitall*", pic_false_value(pic));
|
||||
pic_define(pic, "srfi.106:*msg-waitall*", pic_false_value(pic));
|
||||
#endif
|
||||
|
||||
#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
|
||||
pic_define(pic, "*shut-rd*", pic_false_value(pic));
|
||||
pic_define(pic, "srfi.106:*shut-rd*", pic_false_value(pic));
|
||||
#endif
|
||||
#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
|
||||
pic_define(pic, "*shut-wr*", pic_false_value(pic));
|
||||
pic_define(pic, "srfi.106:*shut-wr*", pic_false_value(pic));
|
||||
#endif
|
||||
#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
|
||||
pic_define(pic, "*shut-rdwr*", pic_false_value(pic));
|
||||
pic_define(pic, "srfi.106:*shut-rdwr*", pic_false_value(pic));
|
||||
#endif
|
||||
}
|
||||
|
|
|
|||
|
|
@ -14,7 +14,5 @@ pic_repl_tty_p(pic_state *pic)
|
|||
void
|
||||
pic_init_repl(pic_state *pic)
|
||||
{
|
||||
pic_deflibrary(pic, "picrin.repl");
|
||||
|
||||
pic_defun(pic, "tty?", pic_repl_tty_p);
|
||||
pic_defun(pic, "picrin.repl:tty?", pic_repl_tty_p);
|
||||
}
|
||||
|
|
|
|||
|
|
@ -34,7 +34,7 @@
|
|||
(scheme eval)
|
||||
(scheme r5rs)
|
||||
(picrin macro))
|
||||
"picrin.user"))
|
||||
'(picrin user)))
|
||||
|
||||
(define (repeat x)
|
||||
(let ((p (list x)))
|
||||
|
|
@ -95,7 +95,7 @@
|
|||
(lambda (port)
|
||||
(let next ((expr (read port)))
|
||||
(unless (eof-object? expr)
|
||||
(write (eval expr "picrin.user"))
|
||||
(write (eval expr))
|
||||
(newline)
|
||||
(set! str "")
|
||||
(next (read port))))))))))
|
||||
|
|
|
|||
|
|
@ -164,7 +164,100 @@ static const char boot_rom[][80] = {
|
|||
" ,@body))))))) (define-macro letrec-syntax (lambda (form env) (let ((formal (car",
|
||||
" (cdr form))) (body (cdr (cdr form)))) `(let () ,@(map (lambda (x) `(,(the 'defi",
|
||||
"ne-syntax) ,(car x) ,(cadr x))) formal) ,@body)))) (define-macro let-syntax (lam",
|
||||
"bda (form env) `(,(the 'letrec-syntax) ,@(cdr form)))) ",
|
||||
"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
|
||||
|
|
|
|||
|
|
@ -1219,6 +1219,43 @@ pic_compile(pic_state *pic, pic_value obj)
|
|||
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
|
||||
pic_eval_eval(pic_state *pic)
|
||||
{
|
||||
|
|
@ -1253,5 +1290,8 @@ pic_init_eval(pic_state *pic)
|
|||
add_keyword("core#begin");
|
||||
add_keyword("core#define-macro");
|
||||
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);
|
||||
}
|
||||
|
|
|
|||
|
|
@ -25,7 +25,7 @@ pic_in_library(pic_state *pic, const char *lib)
|
|||
}
|
||||
|
||||
void
|
||||
export(pic_state *pic, int n, ...)
|
||||
pic_export(pic_state *pic, int n, ...)
|
||||
{
|
||||
size_t ai = pic_enter(pic);
|
||||
va_list ap;
|
||||
|
|
|
|||
|
|
@ -115,7 +115,7 @@ pic_value pic_bool_value(pic_state *, bool);
|
|||
pic_value pic_true_value(pic_state *);
|
||||
pic_value pic_false_value(pic_state *);
|
||||
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))
|
||||
pic_value pic_strf_value(pic_state *, const char *fmt, ...);
|
||||
pic_value pic_vstrf_value(pic_state *, const char *fmt, va_list ap);
|
||||
|
|
|
|||
|
|
@ -274,7 +274,6 @@ pic_global_ref(pic_state *pic, pic_value sym)
|
|||
pic_value val;
|
||||
|
||||
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);
|
||||
}
|
||||
val = pic_dict_ref(pic, pic->globals, sym);
|
||||
|
|
|
|||
|
|
@ -213,6 +213,12 @@ pic_str_value(pic_state *pic, const char *str, int len)
|
|||
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_strf_value(pic_state *pic, const char *fmt, ...)
|
||||
{
|
||||
|
|
|
|||
|
|
@ -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)))
|
||||
|
||||
Loading…
Reference in New Issue