Makefile

@@ -46,7 +46,7 @@ REPL_ISSUE_TESTS = $(wildcard t/issue/*.sh)
 
 TEST_RUNNER = picrin
 
-CFLAGS += -I./lib/include -Wall -Wextra
+CFLAGS += -I./lib -I./lib/include -Wall -Wextra
 LDFLAGS += -lm
 
 prefix ?= /usr/local
@@ -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 piclib/library.scm
+lib/ext/boot.c: piclib/boot.scm
-	cat piclib/boot.scm piclib/library.scm | bin/picrin-bootstrap tools/mkboot.scm > lib/ext/boot.c
+	bin/picrin-bootstrap tools/mkboot.scm < piclib/boot.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
 

contrib/10.math/math.c

@@ -286,32 +286,26 @@ 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, "picrin.math:floor/", pic_number_floor2);
+  pic_defun(pic, "floor/", pic_number_floor2);
-  pic_defun(pic, "picrin.math:truncate/", pic_number_trunc2);
+  pic_defun(pic, "truncate/", pic_number_trunc2);
-  pic_defun(pic, "picrin.math:floor", pic_number_floor);
+  pic_defun(pic, "floor", pic_number_floor);
-  pic_defun(pic, "picrin.math:ceiling", pic_number_ceil);
+  pic_defun(pic, "ceiling", pic_number_ceil);
-  pic_defun(pic, "picrin.math:truncate", pic_number_trunc);
+  pic_defun(pic, "truncate", pic_number_trunc);
-  pic_defun(pic, "picrin.math:round", pic_number_round);
+  pic_defun(pic, "round", pic_number_round);
 
-  pic_defun(pic, "picrin.math:finite?", pic_number_finite_p);
+  pic_defun(pic, "finite?", pic_number_finite_p);
-  pic_defun(pic, "picrin.math:infinite?", pic_number_infinite_p);
+  pic_defun(pic, "infinite?", pic_number_infinite_p);
-  pic_defun(pic, "picrin.math:nan?", pic_number_nan_p);
+  pic_defun(pic, "nan?", pic_number_nan_p);
-  pic_defun(pic, "picrin.math:sqrt", pic_number_sqrt);
+  pic_defun(pic, "sqrt", pic_number_sqrt);
-  pic_defun(pic, "picrin.math:exp", pic_number_exp);
+  pic_defun(pic, "exp", pic_number_exp);
-  pic_defun(pic, "picrin.math:log", pic_number_log);
+  pic_defun(pic, "log", pic_number_log);
-  pic_defun(pic, "picrin.math:sin", pic_number_sin);
+  pic_defun(pic, "sin", pic_number_sin);
-  pic_defun(pic, "picrin.math:cos", pic_number_cos);
+  pic_defun(pic, "cos", pic_number_cos);
-  pic_defun(pic, "picrin.math:tan", pic_number_tan);
+  pic_defun(pic, "tan", pic_number_tan);
-  pic_defun(pic, "picrin.math:acos", pic_number_acos);
+  pic_defun(pic, "acos", pic_number_acos);
-  pic_defun(pic, "picrin.math:asin", pic_number_asin);
+  pic_defun(pic, "asin", pic_number_asin);
-  pic_defun(pic, "picrin.math:atan", pic_number_atan);
+  pic_defun(pic, "atan", pic_number_atan);
-  pic_defun(pic, "picrin.math:abs", pic_number_abs);
+  pic_defun(pic, "abs", pic_number_abs);
-  pic_defun(pic, "picrin.math:expt", pic_number_expt);
+  pic_defun(pic, "expt", pic_number_expt);
 }

contrib/20.r7rs/scheme/base.scm

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

contrib/20.r7rs/scheme/eval.scm

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

contrib/20.r7rs/scheme/r5rs.scm

@@ -7,7 +7,10 @@
           (scheme cxr)
           (scheme lazy)
           (scheme eval)
-          (scheme load))
+          (scheme load)
+          (only (picrin base)
+                library-environment
+                find-library))
 
   (define-library (scheme null)
     (import (scheme base))
@@ -25,12 +28,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

contrib/20.r7rs/src/file.c

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

contrib/20.r7rs/src/load.c

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

contrib/20.r7rs/src/system.c

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

contrib/20.r7rs/src/time.c

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

contrib/30.random/src/random.c

@@ -15,8 +15,6 @@ 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, "srfi.27:random-real", pic_random_real);
+  pic_defun(pic, "random-real", pic_random_real);
 }

contrib/30.readline/src/readline.c

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

contrib/30.regexp/src/regexp.c

@@ -168,15 +168,11 @@ 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, "picrin.regexp:regexp", pic_regexp_regexp);
+  pic_defun(pic, "regexp", pic_regexp_regexp);
-  pic_defun(pic, "picrin.regexp:regexp?", pic_regexp_regexp_p);
+  pic_defun(pic, "regexp?", pic_regexp_regexp_p);
-  pic_defun(pic, "picrin.regexp:regexp-match", pic_regexp_regexp_match);
+  pic_defun(pic, "regexp-match", pic_regexp_regexp_match);
-  /* pic_defun(pic, "picrin.regexp:regexp-search", pic_regexp_regexp_search); */
+  /* pic_defun(pic, "regexp-search", pic_regexp_regexp_search); */
-  pic_defun(pic, "picrin.regexp:regexp-split", pic_regexp_regexp_split);
+  pic_defun(pic, "regexp-split", pic_regexp_regexp_split);
-  pic_defun(pic, "picrin.regexp:regexp-replace", pic_regexp_regexp_replace);
+  pic_defun(pic, "regexp-replace", pic_regexp_regexp_replace);
 }

contrib/40.srfi/src/106.c

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

contrib/40.srfi/srfi/17.scm

@@ -16,9 +16,9 @@
   (define setter
     (letrec ((setter
               (lambda (proc)
-                (let ((attr (attribute proc)))
+                (let ((setter (dictionary-ref (attribute proc) '@@setter)))
-                  (if (dictionary-has? attr '@@setter)
+                  (if setter
-                      (dictionary-ref attr '@@setter)
+                      (cdr setter)
                       (error "no setter found")))))
              (set-setter!
               (lambda (proc setter)

contrib/60.repl/repl.c

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

contrib/60.repl/repl.scm

@@ -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))
+                            (write (eval expr "picrin.user"))
                             (newline)
                             (set! str "")
                             (next (read port))))))))))

lib/blob.c

@@ -20,7 +20,7 @@ pic_blob_value(pic_state *pic, const unsigned char *buf, int len)
 }
 
 unsigned char *
-pic_blob(pic_state *pic, pic_value blob, int *len)
+pic_blob(pic_state *PIC_UNUSED(pic), pic_value blob, int *len)
 {
   if (len) {
     *len = pic_blob_ptr(pic, blob)->len;

lib/cont.c

@@ -202,17 +202,17 @@ pic_cont_values(pic_state *pic)
 static pic_value
 pic_cont_call_with_values(pic_state *pic)
 {
-  pic_value producer, consumer, retv[256];
+  pic_value producer, consumer, *retv;
   int retc;
 
   pic_get_args(pic, "ll", &producer, &consumer);
 
   pic_call(pic, producer, 0);
 
-  retc = pic_receive(pic, 256, retv);
+  retc = pic_receive(pic, 0, NULL);
-  if (retc > 256) {
+  retv = pic_alloca(pic, sizeof(pic_value) * retc);
-    pic_error(pic, "call-with-values: too many arguments", 1, pic_int_value(pic, retc));
+
-  }
+  pic_receive(pic, retc, retv);
 
   return pic_applyk(pic, consumer, retc, retv);
 }

lib/dict.c

@@ -121,16 +121,6 @@ pic_dict_dictionary_p(pic_state *pic)
   return pic_bool_value(pic, pic_dict_p(pic, obj));
 }
 
-static pic_value
-pic_dict_dictionary_has_p(pic_state *pic)
-{
-  pic_value dict, key;
-
-  pic_get_args(pic, "dm", &dict, &key);
-
-  return pic_bool_value(pic, pic_dict_has(pic, dict, key));
-}
-
 static pic_value
 pic_dict_dictionary_ref(pic_state *pic)
 {
@@ -138,7 +128,10 @@ pic_dict_dictionary_ref(pic_state *pic)
 
   pic_get_args(pic, "dm", &dict, &key);
 
-  return pic_dict_ref(pic, dict, key);
+  if (! pic_dict_has(pic, dict, key)) {
+    return pic_false_value(pic);
+  }
+  return pic_cons(pic, key, pic_dict_ref(pic, dict, key));
 }
 
 static pic_value
@@ -148,18 +141,14 @@ pic_dict_dictionary_set(pic_state *pic)
 
   pic_get_args(pic, "dmo", &dict, &key, &val);
 
-  pic_dict_set(pic, dict, key, val);
+  if (pic_undef_p(pic, val)) {
-  return pic_undef_value(pic);
+    if (pic_dict_has(pic, dict, key)) {
-}
+      pic_dict_del(pic, dict, key);
-
+    }
-static pic_value
+  }
-pic_dict_dictionary_delete(pic_state *pic)
+  else {
-{
+    pic_dict_set(pic, dict, key, val);
-  pic_value dict, key;
+  }
-
-  pic_get_args(pic, "dm", &dict, &key);
-
-  pic_dict_del(pic, dict, key);
   return pic_undef_value(pic);
 }
 
@@ -273,10 +262,8 @@ pic_init_dict(pic_state *pic)
   pic_defun(pic, "make-dictionary", pic_dict_make_dictionary);
   pic_defun(pic, "dictionary?", pic_dict_dictionary_p);
   pic_defun(pic, "dictionary", pic_dict_dictionary);
-  pic_defun(pic, "dictionary-has?", pic_dict_dictionary_has_p);
   pic_defun(pic, "dictionary-ref", pic_dict_dictionary_ref);
   pic_defun(pic, "dictionary-set!", pic_dict_dictionary_set);
-  pic_defun(pic, "dictionary-delete!", pic_dict_dictionary_delete);
   pic_defun(pic, "dictionary-size", pic_dict_dictionary_size);
   pic_defun(pic, "dictionary-map", pic_dict_dictionary_map);
   pic_defun(pic, "dictionary-for-each", pic_dict_dictionary_for_each);

lib/error.c

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

lib/ext/boot.c

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

lib/ext/eval.c

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

lib/ext/lib.c

@@ -4,37 +4,357 @@
 
 #include "picrin.h"
 #include "picrin/extra.h"
+#include "object.h"
+#include "state.h"
+
+KHASH_DEFINE(env, struct identifier *, symbol *, kh_ptr_hash_func, kh_ptr_hash_equal)
+KHASH_DEFINE(ltable, const char *, struct lib, kh_str_hash_func, kh_str_cmp_func)
+
+pic_value
+pic_make_env(pic_state *pic, pic_value up)
+{
+  struct env *env;
+
+  env = (struct env *)pic_obj_alloc(pic, sizeof(struct env), PIC_TYPE_ENV);
+  env->up = pic_env_ptr(pic, up);
+  env->lib = NULL;
+  kh_init(env, &env->map);
+
+  return obj_value(pic, env);
+}
+
+static bool
+search_scope(pic_state *pic, pic_value id, pic_value env, pic_value *uid)
+{
+  int it;
+
+  it = kh_get(env, &pic_env_ptr(pic, env)->map, pic_id_ptr(pic, id));
+  if (it == kh_end(&pic_env_ptr(pic, env)->map)) {
+    return false;
+  }
+  *uid = obj_value(pic, kh_val(&pic_env_ptr(pic, env)->map, it));
+  return true;
+}
+
+static bool
+search(pic_state *pic, pic_value id, pic_value env, pic_value *uid)
+{
+  struct env *e;
+
+  while (1) {
+    if (search_scope(pic, id, env, uid))
+      return true;
+    e = pic_env_ptr(pic, env)->up;
+    if (e == NULL)
+      break;
+    env = obj_value(pic, e);
+  }
+  return false;
+}
+
+pic_value
+pic_find_identifier(pic_state *pic, pic_value id, pic_value env)
+{
+  struct env *e;
+  pic_value uid;
+
+  while (! search(pic, id, env, &uid)) {
+    if (pic_sym_p(pic, id)) {
+      while (1) {
+        e = pic_env_ptr(pic, env);
+        if (e->up == NULL)
+          break;
+        env = obj_value(pic, e->up);
+      }
+      return pic_add_identifier(pic, id, env);
+    }
+    env = obj_value(pic, pic_id_ptr(pic, id)->env); /* do not overwrite id first */
+    id = obj_value(pic, pic_id_ptr(pic, id)->u.id);
+  }
+  return uid;
+}
+
+pic_value
+pic_add_identifier(pic_state *pic, pic_value id, pic_value env)
+{
+  const char *name, *lib;
+  pic_value uid, str;
+
+  if (search_scope(pic, id, env, &uid)) {
+    return uid;
+  }
+
+  name = pic_str(pic, pic_id_name(pic, id), NULL);
+
+  if (pic_env_ptr(pic, env)->up == NULL && pic_sym_p(pic, id)) { /* toplevel & public */
+    lib = pic_str(pic, obj_value(pic, pic_env_ptr(pic, env)->lib), NULL);
+    str = pic_strf_value(pic, "%s/%s", lib, name);
+  } else {
+    str = pic_strf_value(pic, ".%s.%d", name, pic->ucnt++);
+  }
+  uid = pic_intern(pic, str);
+
+  pic_put_identifier(pic, id, uid, env);
+
+  return uid;
+}
 
 void
-pic_deflibrary(pic_state *pic, const char *lib)
+pic_put_identifier(pic_state *pic, pic_value id, pic_value uid, pic_value env)
 {
-  pic_value name = pic_intern_cstr(pic, lib), v;
+  int it, ret;
 
-  v = pic_funcall(pic, "find-library", 1, name);
+  it = kh_put(env, &pic_env_ptr(pic, env)->map, pic_id_ptr(pic, id), &ret);
-  if (! pic_bool(pic, v)) {
+  kh_val(&pic_env_ptr(pic, env)->map, it) = pic_sym_ptr(pic, uid);
-    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
 pic_in_library(pic_state *pic, const char *lib)
 {
-  pic_value name = pic_intern_cstr(pic, lib);
+  get_library(pic, lib);
+  pic->lib = lib;
+}
 
-  pic_funcall(pic, "current-library", 1, name);
+bool
+pic_find_library(pic_state *pic, const char *lib)
+{
+  return get_library_opt(pic, lib) != NULL;
+}
+
+const char *
+pic_current_library(pic_state *pic)
+{
+  return pic->lib;
+}
+
+pic_value
+pic_library_environment(pic_state *pic, const char *lib)
+{
+  return obj_value(pic, get_library(pic, lib)->env);
 }
 
 void
-pic_export(pic_state *pic, int n, ...)
+pic_import(pic_state *pic, const char *lib)
 {
-  size_t ai = pic_enter(pic);
+  pic_value name, realname, uid;
-  va_list ap;
+  int it = 0;
+  struct lib *our, *their;
 
-  va_start(ap, n);
+  our = get_library(pic, pic->lib);
-  while (n--) {
+  their = get_library(pic, lib);
-    pic_value var = pic_intern_cstr(pic, va_arg(ap, const char *));
+
-    pic_funcall(pic, "library-export", 2, var, var);
+  while (pic_dict_next(pic, obj_value(pic, their->exports), &it, &name, &realname)) {
+    uid = pic_find_identifier(pic, realname, obj_value(pic, their->env));
+    if (! pic_weak_has(pic, pic->globals, uid) && ! pic_weak_has(pic, pic->macros, uid)) {
+      pic_error(pic, "attempted to export undefined variable", 1, realname);
+    }
+    pic_put_identifier(pic, name, uid, obj_value(pic, our->env));
   }
-  va_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);
 }

lib/ext/load.c

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

lib/ext/read.c

@@ -4,7 +4,7 @@
 
 #include "picrin.h"
 #include "picrin/extra.h"
-#include "../object.h"
+#include "object.h"
 
 #undef EOF
 #define EOF (-1)
@@ -237,7 +237,7 @@ read_number(pic_state *pic, pic_value port, int c, struct reader_control *p)
 {
   pic_value str = read_atom(pic, port, c, p), num;
 
-  num = pic_funcall(pic, "string->number", 1, str);
+  num = pic_funcall(pic, "picrin.base", "string->number", 1, str);
   if (! pic_false_p(pic, num)) {
     return num;
   }
@@ -730,7 +730,6 @@ pic_read(pic_state *pic, pic_value port)
   reader_init(pic, &p);
 
   pic_try {
-    size_t ai = pic_enter(pic);
     while ((c = skip(pic, port, next(pic, port))) != EOF) {
       val = read_nullable(pic, port, c, &p);
 

lib/ext/write.c

@@ -4,7 +4,7 @@
 
 #include "picrin.h"
 #include "picrin/extra.h"
-#include "../object.h"
+#include "object.h"
 
 struct writer_control {
   int mode;

lib/gc.c

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

lib/include/picconf.h

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

lib/include/picrin.h

@@ -97,6 +97,7 @@ typedef struct {
   void (*dtor)(pic_state *, void *);
 } pic_data_type;
 
+bool pic_undef_p(pic_state *, pic_value); /* deprecated */
 bool pic_int_p(pic_state *, pic_value);
 bool pic_float_p(pic_state *, pic_value);
 bool pic_char_p(pic_state *, pic_value);
@@ -115,7 +116,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);
-pic_value pic_cstr_value(pic_state *, const char *str);
+#define pic_cstr_value(pic, cstr) pic_str_value(pic, (cstr), strlen(cstr))
 #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);
@@ -255,9 +256,9 @@ typedef struct {
 #define PIC_SEEK_END 1
 #define PIC_SEEK_SET 2
 
-#define pic_stdin(pic) pic_funcall(pic, "current-input-port", 0)
+#define pic_stdin(pic) pic_funcall(pic, "picrin.base", "current-input-port", 0)
-#define pic_stdout(pic) pic_funcall(pic, "current-output-port", 0)
+#define pic_stdout(pic) pic_funcall(pic, "picrin.base", "current-output-port", 0)
-#define pic_stderr(pic) pic_funcall(pic, "current-error-port", 0)
+#define pic_stderr(pic) pic_funcall(pic, "picrin.base", "current-error-port", 0)
 bool pic_eof_p(pic_state *, pic_value);
 pic_value pic_eof_object(pic_state *);
 bool pic_port_p(pic_state *, pic_value, const pic_port_type *type);
@@ -319,18 +320,36 @@ pic_value pic_get_backtrace(pic_state *); /* deprecated */
   label:
 
 
+/*
+ * library
+ */
+
+void pic_make_library(pic_state *, const char *lib);
+void pic_in_library(pic_state *, const char *lib);
+bool pic_find_library(pic_state *, const char *lib);
+const char *pic_current_library(pic_state *);
+void pic_import(pic_state *, const char *lib);
+void pic_export(pic_state *, pic_value sym);
+#define pic_deflibrary(pic, lib) do {           \
+    if (! pic_find_library(pic, lib)) {         \
+      pic_make_library(pic, lib);               \
+    }                                           \
+    pic_in_library(pic, lib);                   \
+  } while (0)
+
+
 /*
  * core language features
  */
 
 void pic_add_feature(pic_state *, const char *feature);
-void pic_define(pic_state *, const char *name, pic_value v);
+void pic_define(pic_state *, const char *lib, const char *name, pic_value v);
-pic_value pic_ref(pic_state *, const char *name);
+pic_value pic_ref(pic_state *, const char *lib, const char *name);
-void pic_set(pic_state *, const char *name, pic_value v);
+void pic_set(pic_state *, const char *lib, const char *name, pic_value v);
 pic_value pic_make_var(pic_state *, pic_value init, pic_value conv);
 void pic_defun(pic_state *, const char *name, pic_func_t f);
 void pic_defvar(pic_state *, const char *name, pic_value v);
-pic_value pic_funcall(pic_state *, const char *name, int n, ...);
+pic_value pic_funcall(pic_state *, const char *lib, const char *name, int n, ...);
 pic_value pic_values(pic_state *, int n, ...);
 pic_value pic_vvalues(pic_state *, int n, va_list);
 int pic_receive(pic_state *, int n, pic_value *retv);

lib/include/picrin/extra.h

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

lib/include/picrin/value.h

@@ -41,10 +41,6 @@ enum {
   PIC_TYPE_MAX       = 63
 };
 
-PIC_STATIC_INLINE bool pic_int_p(pic_state *, pic_value);
-PIC_STATIC_INLINE bool pic_float_p(pic_state *, pic_value);
-PIC_STATIC_INLINE bool pic_char_p(pic_state *, pic_value);
-
 #if !PIC_NAN_BOXING
 
 PIC_STATIC_INLINE pic_value
@@ -65,21 +61,18 @@ pic_type(pic_state *PIC_UNUSED(pic), pic_value v)
 PIC_STATIC_INLINE int
 pic_int(pic_state *PIC_UNUSED(pic), pic_value v)
 {
-  assert(pic_int_p(pic, v));
   return v.u.i;
 }
 
 PIC_STATIC_INLINE double
 pic_float(pic_state *PIC_UNUSED(pic), pic_value v)
 {
-  assert(pic_float_p(v));
   return v.u.f;
 }
 
 PIC_STATIC_INLINE char
 pic_char(pic_state *PIC_UNUSED(pic), pic_value v)
 {
-  assert(pic_char_p(v));
   return v.u.c;
 }
 
@@ -135,7 +128,6 @@ PIC_STATIC_INLINE int
 pic_int(pic_state *PIC_UNUSED(pic), pic_value v)
 {
   union { int i; unsigned u; } u;
-  assert(pic_int_p(pic, v));
   u.u = v.v & 0xfffffffful;
   return u.i;
 }
@@ -144,7 +136,6 @@ PIC_STATIC_INLINE double
 pic_float(pic_state *PIC_UNUSED(pic), pic_value v)
 {
   union { double f; uint64_t i; } u;
-  assert(pic_float_p(pic, v));
   u.i = v.v;
   return u.f;
 }
@@ -152,7 +143,6 @@ pic_float(pic_state *PIC_UNUSED(pic), pic_value v)
 PIC_STATIC_INLINE char
 pic_char(pic_state *PIC_UNUSED(pic), pic_value v)
 {
-  assert(pic_char_p(pic, v));
   return v.v & 0xfffffffful;
 }
 

lib/object.h

@@ -43,7 +43,7 @@ struct env {
   OBJECT_HEADER
   khash_t(env) map;
   struct env *up;
-  struct string *prefix;
+  struct string *lib;
 };
 
 struct pair {
@@ -90,12 +90,6 @@ struct data {
   void *data;
 };
 
-struct record {
-  OBJECT_HEADER
-  pic_value type;
-  pic_value datum;
-};
-
 struct code {
   int insn;
   int a;
@@ -137,6 +131,20 @@ struct proc {
   pic_value locals[1];
 };
 
+struct record {
+  OBJECT_HEADER
+  pic_value type;
+  pic_value datum;
+};
+
+struct error {
+  OBJECT_HEADER
+  symbol *type;
+  struct string *msg;
+  pic_value irrs;
+  struct string *stack;
+};
+
 enum {
   FILE_READ  = 01,
   FILE_WRITE = 02,
@@ -161,14 +169,6 @@ struct port {
   } file;
 };
 
-struct error {
-  OBJECT_HEADER
-  symbol *type;
-  struct string *msg;
-  pic_value irrs;
-  struct string *stack;
-};
-
 #define TYPENAME_int   "integer"
 #define TYPENAME_blob  "bytevector"
 #define TYPENAME_char  "character"
@@ -251,43 +251,37 @@ obj_value(pic_state *PIC_UNUSED(pic), void *ptr)
 #endif  /* NAN_BOXING */
 
 #define DEFPTR(name,type)                                               \
-  PIC_STATIC_INLINE type *                                              \
+  PIC_STATIC_INLINE type *name(pic_state *PIC_UNUSED(pic), pic_value o) { \
-  pic_##name##_ptr(pic_state *PIC_UNUSED(pic), pic_value o) {           \
-    assert(pic_##name##_p(pic,o));                                      \
     return (type *) obj_ptr(pic, o);                                    \
   }
 
-#define pic_data_p(pic,o) (pic_data_p(pic,o,NULL))
+DEFPTR(pic_id_ptr, struct identifier)
-#define pic_port_p(pic,o) (pic_port_p(pic,o,NULL))
+DEFPTR(pic_sym_ptr, symbol)
-DEFPTR(id, struct identifier)
+DEFPTR(pic_str_ptr, struct string)
-DEFPTR(sym, symbol)
+DEFPTR(pic_blob_ptr, struct blob)
-DEFPTR(str, struct string)
+DEFPTR(pic_pair_ptr, struct pair)
-DEFPTR(blob, struct blob)
+DEFPTR(pic_vec_ptr, struct vector)
-DEFPTR(pair, struct pair)
+DEFPTR(pic_dict_ptr, struct dict)
-DEFPTR(vec, struct vector)
+DEFPTR(pic_weak_ptr, struct weak)
-DEFPTR(dict, struct dict)
+DEFPTR(pic_data_ptr, struct data)
-DEFPTR(weak, struct weak)
+DEFPTR(pic_proc_ptr, struct proc)
-DEFPTR(data, struct data)
+DEFPTR(pic_env_ptr, struct env)
-DEFPTR(proc, struct proc)
+DEFPTR(pic_port_ptr, struct port)
-DEFPTR(env, struct env)
+DEFPTR(pic_error_ptr, struct error)
-DEFPTR(port, struct port)
+DEFPTR(pic_rec_ptr, struct record)
-DEFPTR(error, struct error)
+DEFPTR(pic_irep_ptr, struct irep)
-DEFPTR(rec, struct record)
-DEFPTR(irep, struct irep)
-#undef pic_data_p
-#undef pic_port_p
 
 struct object *pic_obj_alloc(pic_state *, size_t, int type);
 
 pic_value pic_make_identifier(pic_state *, pic_value id, pic_value env);
 pic_value pic_make_proc(pic_state *, pic_func_t, int, pic_value *);
 pic_value pic_make_proc_irep(pic_state *, struct irep *, struct context *);
-pic_value pic_make_env(pic_state *, pic_value prefix);
+pic_value pic_make_env(pic_state *, pic_value env);
 pic_value pic_make_record(pic_state *, pic_value type, pic_value datum);
 
 pic_value pic_add_identifier(pic_state *, pic_value id, pic_value env);
+void pic_put_identifier(pic_state *, pic_value id, pic_value uid, pic_value env);
 pic_value pic_find_identifier(pic_state *, pic_value id, pic_value env);
-void pic_set_identifier(pic_state *, pic_value id, pic_value uid, pic_value env);
 pic_value pic_id_name(pic_state *, pic_value id);
 
 struct rope *pic_rope_incref(struct rope *);
@@ -298,6 +292,8 @@ pic_value pic_make_cont(pic_state *, struct cont *);
 void pic_save_point(pic_state *, struct cont *, PIC_JMPBUF *);
 void pic_exit_point(pic_state *);
 
+pic_value pic_library_environment(pic_state *, const char *);
+
 void pic_warnf(pic_state *pic, const char *fmt, ...); /* deprecated */
 
 #if defined(__cplusplus)

lib/state.c

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

lib/state.h

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

lib/string.c

@@ -213,12 +213,6 @@ 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, ...)
 {
@@ -538,7 +532,7 @@ pic_str_string_map(pic_state *pic)
       pic_push(pic, pic_char_value(pic, pic_str(pic, argv[j], 0)[i]), vals);
     }
     vals = pic_reverse(pic, vals);
-    val = pic_funcall(pic, "apply", 2, proc, vals);
+    val = pic_funcall(pic, "picrin.base", "apply", 2, proc, vals);
 
     TYPE_CHECK(pic, val, char);
 
@@ -573,7 +567,7 @@ pic_str_string_for_each(pic_state *pic)
       pic_push(pic, pic_char_value(pic, pic_str(pic, argv[j], 0)[i]), vals);
     }
     vals = pic_reverse(pic, vals);
-    pic_funcall(pic, "apply", 2, proc, vals);
+    pic_funcall(pic, "picrin.base", "apply", 2, proc, vals);
   }
   return pic_undef_value(pic);
 }

lib/var.c

@@ -40,19 +40,10 @@ var_call(pic_state *pic)
 pic_value
 pic_make_var(pic_state *pic, pic_value init, pic_value conv)
 {
-  pic_value var, env = pic->dyn_env;
+  pic_value var;
 
   var = pic_lambda(pic, var_call, 1, conv);
-  while (1) {
+  pic_call(pic, var, 1, init);
-    if (pic_nil_p(pic, pic_cdr(pic, env))) { /* top dyn env */
-      if (! pic_false_p(pic, conv)) {
-        init = pic_call(pic, conv, 1, init);
-      }
-      pic_weak_set(pic, pic_car(pic, env), var, init);
-      break;
-    }
-    env = pic_cdr(pic, env);
-  }
   return var;
 }
 

lib/vector.c

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

piclib/boot.scm

@@ -1,52 +1,52 @@
-(core#define-macro call-with-current-environment
+(builtin:define-macro call-with-current-environment
-  (core#lambda (form env)
+  (builtin:lambda (form env)
     (list (cadr form) env)))
 
-(core#define here
+(builtin:define here
   (call-with-current-environment
-   (core#lambda (env)
+   (builtin:lambda (env)
      env)))
 
-(core#define the                     ; synonym for #'var
+(builtin:define the                     ; synonym for #'var
-  (core#lambda (var)
+  (builtin:lambda (var)
     (make-identifier var here)))
 
 
-(core#define the-builtin-define (the (core#quote core#define)))
+(builtin:define the-builtin-define (the (builtin:quote builtin:define)))
-(core#define the-builtin-lambda (the (core#quote core#lambda)))
+(builtin:define the-builtin-lambda (the (builtin:quote builtin:lambda)))
-(core#define the-builtin-begin (the (core#quote core#begin)))
+(builtin:define the-builtin-begin (the (builtin:quote builtin:begin)))
-(core#define the-builtin-quote (the (core#quote core#quote)))
+(builtin:define the-builtin-quote (the (builtin:quote builtin:quote)))
-(core#define the-builtin-set! (the (core#quote core#set!)))
+(builtin:define the-builtin-set! (the (builtin:quote builtin:set!)))
-(core#define the-builtin-if (the (core#quote core#if)))
+(builtin:define the-builtin-if (the (builtin:quote builtin:if)))
-(core#define the-builtin-define-macro (the (core#quote core#define-macro)))
+(builtin:define the-builtin-define-macro (the (builtin:quote builtin:define-macro)))
 
-(core#define the-define (the (core#quote define)))
+(builtin:define the-define (the (builtin:quote define)))
-(core#define the-lambda (the (core#quote lambda)))
+(builtin:define the-lambda (the (builtin:quote lambda)))
-(core#define the-begin (the (core#quote begin)))
+(builtin:define the-begin (the (builtin:quote begin)))
-(core#define the-quote (the (core#quote quote)))
+(builtin:define the-quote (the (builtin:quote quote)))
-(core#define the-set! (the (core#quote set!)))
+(builtin:define the-set! (the (builtin:quote set!)))
-(core#define the-if (the (core#quote if)))
+(builtin:define the-if (the (builtin:quote if)))
-(core#define the-define-macro (the (core#quote define-macro)))
+(builtin:define the-define-macro (the (builtin:quote define-macro)))
 
-(core#define-macro quote
+(builtin:define-macro quote
-  (core#lambda (form env)
+  (builtin:lambda (form env)
-    (core#if (= (length form) 2)
+    (builtin:if (= (length form) 2)
       (list the-builtin-quote (cadr form))
       (error "illegal quote form" form))))
 
-(core#define-macro if
+(builtin:define-macro if
-  (core#lambda (form env)
+  (builtin:lambda (form env)
-    ((core#lambda (len)
+    ((builtin:lambda (len)
-       (core#if (= len 4)
+       (builtin:if (= len 4)
            (cons the-builtin-if (cdr form))
-           (core#if (= len 3)
+           (builtin:if (= len 3)
                (list the-builtin-if (list-ref form 1) (list-ref form 2) #undefined)
                (error "illegal if form" form))))
      (length form))))
 
-(core#define-macro begin
+(builtin:define-macro begin
-  (core#lambda (form env)
+  (builtin:lambda (form env)
-    ((core#lambda (len)
+    ((builtin:lambda (len)
        (if (= len 1)
            #undefined
            (if (= len 2)
@@ -58,16 +58,16 @@
                          (cons the-begin (cddr form)))))))
      (length form))))
 
-(core#define-macro set!
+(builtin:define-macro set!
-  (core#lambda (form env)
+  (builtin:lambda (form env)
     (if (= (length form) 3)
         (if (identifier? (cadr form))
             (cons the-builtin-set! (cdr form))
             (error "illegal set! form" form))
         (error "illegal set! form" form))))
 
-(core#define check-formal
+(builtin:define check-formal
-  (core#lambda (formal)
+  (builtin:lambda (formal)
     (if (null? formal)
         #t
         (if (identifier? formal)
@@ -78,15 +78,15 @@
                     #f)
                 #f)))))
 
-(core#define-macro lambda
+(builtin:define-macro lambda
-  (core#lambda (form env)
+  (builtin:lambda (form env)
     (if (= (length form) 1)
         (error "illegal lambda form" form)
         (if (check-formal (cadr form))
             (list the-builtin-lambda (cadr form) (cons the-begin (cddr form)))
             (error "illegal lambda form" form)))))
 
-(core#define-macro define
+(builtin:define-macro define
   (lambda (form env)
     ((lambda (len)
        (if (= len 1)
@@ -102,7 +102,7 @@
                    (error "define: binding to non-varaible object" form)))))
      (length form))))
 
-(core#define-macro define-macro
+(builtin:define-macro define-macro
   (lambda (form env)
     (if (= (length form) 3)
         (if (identifier? (cadr form))
@@ -527,3 +527,156 @@
 (define-macro let-syntax
   (lambda (form env)
     `(,(the 'letrec-syntax) ,@(cdr form))))
+
+
+;;; library primitives
+
+(define (mangle name)
+  (when (null? name)
+    (error "library name should be a list of at least one symbols" name))
+
+  (define (->string n)
+    (cond
+     ((symbol? n)
+      (let ((str (symbol->string n)))
+        (string-for-each
+         (lambda (c)
+           (when (or (char=? c #\.) (char=? c #\/))
+             (error "elements of library name may not contain '.' or '/'" n)))
+         str)
+        str))
+     ((and (number? n) (exact? n))
+      (number->string n))
+     (else
+      (error "symbol or integer is required" n))))
+
+  (define (join strs delim)
+    (let loop ((res (car strs)) (strs (cdr strs)))
+      (if (null? strs)
+          res
+          (loop (string-append res delim (car strs)) (cdr strs)))))
+
+  (join (map ->string name) "."))
+
+(define-macro define-library
+  (lambda (form _)
+    (let ((lib (mangle (cadr form)))
+          (body (cddr form)))
+      (or (find-library lib) (make-library lib))
+      (for-each (lambda (expr) (eval expr lib)) body))))
+
+(define-macro cond-expand
+  (lambda (form _)
+    (letrec
+        ((test (lambda (form)
+                 (or
+                  (eq? form 'else)
+                  (and (symbol? form)
+                       (memq form (features)))
+                  (and (pair? form)
+                       (case (car form)
+                         ((library) (find-library (mangle (cadr form))))
+                         ((not) (not (test (cadr form))))
+                         ((and) (let loop ((form (cdr form)))
+                                  (or (null? form)
+                                      (and (test (car form)) (loop (cdr form))))))
+                         ((or) (let loop ((form (cdr form)))
+                                 (and (pair? form)
+                                      (or (test (car form)) (loop (cdr form))))))
+                         (else #f)))))))
+      (let loop ((clauses (cdr form)))
+        (if (null? clauses)
+            #undefined
+            (if (test (caar clauses))
+                `(,the-begin ,@(cdar clauses))
+                (loop (cdr clauses))))))))
+
+(define-macro import
+  (lambda (form _)
+    (let ((caddr
+           (lambda (x) (car (cdr (cdr x)))))
+          (prefix
+           (lambda (prefix symbol)
+             (string->symbol
+              (string-append
+               (symbol->string prefix)
+               (symbol->string symbol)))))
+          (getlib
+           (lambda (name)
+             (let ((lib (mangle name)))
+               (if (find-library lib)
+                   lib
+                   (error "library not found" name))))))
+      (letrec
+          ((extract
+            (lambda (spec)
+              (case (car spec)
+                ((only rename prefix except)
+                 (extract (cadr spec)))
+                (else
+                 (getlib spec)))))
+           (collect
+            (lambda (spec)
+              (case (car spec)
+                ((only)
+                 (let ((alist (collect (cadr spec))))
+                   (map (lambda (var) (assq var alist)) (cddr spec))))
+                ((rename)
+                 (let ((alist (collect (cadr spec)))
+                       (renames (map (lambda (x) `((car x) . (cadr x))) (cddr spec))))
+                   (map (lambda (s) (or (assq (car s) renames) s)) alist)))
+                ((prefix)
+                 (let ((alist (collect (cadr spec))))
+                   (map (lambda (s) (cons (prefix (caddr spec) (car s)) (cdr s))) alist)))
+                ((except)
+                 (let ((alist (collect (cadr spec))))
+                   (let loop ((alist alist))
+                     (if (null? alist)
+                         '()
+                         (if (memq (caar alist) (cddr spec))
+                             (loop (cdr alist))
+                             (cons (car alist) (loop (cdr alist))))))))
+                (else
+                 (map (lambda (x) (cons x x)) (library-exports (getlib spec))))))))
+        (letrec
+            ((import
+               (lambda (spec)
+                 (let ((lib (extract spec))
+                       (alist (collect spec)))
+                   (for-each
+                    (lambda (slot)
+                      (library-import lib (cdr slot) (car slot)))
+                    alist)))))
+          (for-each import (cdr form)))))))
+
+(define-macro export
+  (lambda (form _)
+    (letrec
+        ((collect
+          (lambda (spec)
+            (cond
+             ((symbol? spec)
+              `(,spec . ,spec))
+             ((and (list? spec) (= (length spec) 3) (eq? (car spec) 'rename))
+              `(,(list-ref spec 1) . ,(list-ref spec 2)))
+             (else
+              (error "malformed export")))))
+         (export
+           (lambda (spec)
+             (let ((slot (collect spec)))
+               (library-export (car slot) (cdr slot))))))
+      (for-each export (cdr form)))))
+
+(export define lambda quote set! if begin define-macro
+        let let* letrec letrec*
+        let-values let*-values define-values
+        quasiquote unquote unquote-splicing
+        and or
+        cond case else =>
+        do when unless
+        parameterize
+        define-syntax
+        syntax-quote syntax-unquote
+        syntax-quasiquote syntax-unquote-splicing
+        let-syntax letrec-syntax
+        syntax-error)

piclib/library.scm

@@ -1,271 +0,0 @@
-;;; 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)))
-

src/main.c

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

t/issue/pic_call.scm

@@ -1,24 +0,0 @@
-(import (scheme base)
-        (scheme read)
-        (scheme file)
-        (scheme lazy)
-        (scheme write)
-        (srfi 1)
-        (picrin base)
-        (picrin test))
-
-(test-begin)
-
-(define trace '())
-
-(define task-queue (make-parameter '() (lambda (x) (set! trace (cons x trace)) x)))
-
-(define expand
-  (lambda ()
-    (task-queue)))
-
-(define result (expand))
-(test '() result)
-(test '(()) trace)
-
-(test-end)