fix include path

dynamic env

Makefile

@@ -46,7 +46,7 @@ REPL_ISSUE_TESTS = $(wildcard t/issue/*.sh)
 
 TEST_RUNNER = picrin
 
-CFLAGS += -I./lib -I./lib/include -Wall -Wextra
+CFLAGS += -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
-	bin/picrin-bootstrap tools/mkboot.scm < piclib/boot.scm > lib/ext/boot.c
+lib/ext/boot.c: piclib/boot.scm piclib/library.scm
+	cat piclib/boot.scm piclib/library.scm | bin/picrin-bootstrap tools/mkboot.scm > lib/ext/boot.c
 
 $(LIBPICRIN_OBJS) $(PICRIN_OBJS) $(CONTRIB_OBJS): lib/include/picrin.h lib/include/picrin/*.h lib/khash.h lib/object.h lib/state.h lib/vm.h
 

contrib/10.math/math.c

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

contrib/20.r7rs/scheme/base.scm

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

contrib/20.r7rs/scheme/eval.scm

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

contrib/20.r7rs/scheme/r5rs.scm

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

contrib/20.r7rs/src/file.c

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

contrib/20.r7rs/src/load.c

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

contrib/20.r7rs/src/system.c

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

contrib/20.r7rs/src/time.c

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

contrib/30.random/src/random.c

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

contrib/30.readline/src/readline.c

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

contrib/30.regexp/src/regexp.c

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

contrib/40.srfi/src/106.c

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

contrib/40.srfi/srfi/17.scm

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

contrib/60.repl/repl.c

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

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 "picrin.user"))
+                            (write (eval expr))
                             (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_UNUSED(pic), pic_value blob, int *len)
+pic_blob(pic_state *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;
+  pic_value producer, consumer, retv[256];
   int retc;
 
   pic_get_args(pic, "ll", &producer, &consumer);
 
   pic_call(pic, producer, 0);
 
-  retc = pic_receive(pic, 0, NULL);
-  retv = pic_alloca(pic, sizeof(pic_value) * retc);
-
-  pic_receive(pic, retc, retv);
+  retc = pic_receive(pic, 256, retv);
+  if (retc > 256) {
+    pic_error(pic, "call-with-values: too many arguments", 1, pic_int_value(pic, retc));
+  }
 
   return pic_applyk(pic, consumer, retc, retv);
 }

lib/dict.c

@@ -121,6 +121,16 @@ 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)
 {
@@ -128,10 +138,7 @@ pic_dict_dictionary_ref(pic_state *pic)
 
   pic_get_args(pic, "dm", &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));
+  return pic_dict_ref(pic, dict, key);
 }
 
 static pic_value
@@ -141,14 +148,18 @@ pic_dict_dictionary_set(pic_state *pic)
 
   pic_get_args(pic, "dmo", &dict, &key, &val);
 
-  if (pic_undef_p(pic, val)) {
-    if (pic_dict_has(pic, dict, key)) {
-      pic_dict_del(pic, dict, key);
-    }
-  }
-  else {
-    pic_dict_set(pic, dict, key, val);
-  }
+  pic_dict_set(pic, dict, key, val);
+  return pic_undef_value(pic);
+}
+
+static pic_value
+pic_dict_dictionary_delete(pic_state *pic)
+{
+  pic_value dict, key;
+
+  pic_get_args(pic, "dm", &dict, &key);
+
+  pic_dict_del(pic, dict, key);
   return pic_undef_value(pic);
 }
 
@@ -262,8 +273,10 @@ 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,6 +28,8 @@ pic_warnf(pic_state *pic, const char *fmt, ...)
   pic_fprintf(pic, pic_stderr(pic), "warn: %s\n", pic_str(pic, err, NULL));
 }
 
+#define pic_exc(pic) pic_ref(pic, "current-exception-handlers")
+
 static pic_value
 native_exception_handler(pic_state *pic)
 {
@@ -57,7 +59,7 @@ pic_start_try(pic_state *pic, PIC_JMPBUF *jmp)
 
   /* with-exception-handler */
 
-  var = pic_ref(pic, "picrin.base", "current-exception-handlers");
+  var = pic_exc(pic);
   env = pic_make_weak(pic);
   pic_weak_set(pic, env, var, pic_cons(pic, handler, pic_call(pic, var, 0)));
   pic->dyn_env = pic_cons(pic, env, pic->dyn_env);
@@ -97,9 +99,9 @@ pic_make_error(pic_state *pic, const char *type, const char *msg, pic_value irrs
 static pic_value
 with_exception_handlers(pic_state *pic, pic_value handlers, pic_value thunk)
 {
-  pic_value alist, var = pic_ref(pic, "picrin.base", "current-exception-handlers");
+  pic_value alist, var = pic_exc(pic);
   alist = pic_list(pic, 1, pic_cons(pic, var, handlers));
-  return pic_funcall(pic, "picrin.base", "with-dynamic-environment", 2, alist, thunk);
+  return pic_funcall(pic, "with-dynamic-environment", 2, alist, thunk);
 }
 
 static pic_value
@@ -124,7 +126,7 @@ on_raise(pic_state *pic)
 pic_value
 pic_raise_continuable(pic_state *pic, pic_value err)
 {
-  pic_value handlers, var = pic_ref(pic, "picrin.base", "current-exception-handlers"), thunk;
+  pic_value handlers, var = pic_exc(pic), thunk;
 
   handlers = pic_call(pic, var, 0);
 
@@ -138,7 +140,7 @@ pic_raise_continuable(pic_state *pic, pic_value err)
 void
 pic_raise(pic_state *pic, pic_value err)
 {
-  pic_value handlers, var = pic_ref(pic, "picrin.base", "current-exception-handlers"), thunk;
+  pic_value handlers, var = pic_exc(pic), thunk;
 
   handlers = pic_call(pic, var, 0);
 
@@ -166,7 +168,7 @@ static pic_value
 pic_error_with_exception_handler(pic_state *pic)
 {
   pic_value handler, thunk;
-  pic_value handlers, exc = pic_ref(pic, "picrin.base", "current-exception-handlers");
+  pic_value handlers, exc = pic_exc(pic);
 
   pic_get_args(pic, "ll", &handler, &thunk);
 

lib/ext/boot.c

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

lib/ext/eval.c

@@ -4,9 +4,129 @@
 
 #include "picrin.h"
 #include "picrin/extra.h"
-#include "object.h"
-#include "state.h"
-#include "vm.h"
+#include "../object.h"
+#include "../state.h"
+#include "../vm.h"
+
+pic_value pic_expand(pic_state *pic, pic_value expr, pic_value env);
+
+KHASH_DEFINE(env, struct identifier *, symbol *, kh_ptr_hash_func, kh_ptr_hash_equal)
+
+pic_value
+pic_make_env(pic_state *pic, pic_value prefix)
+{
+  struct env *env;
+
+  env = (struct env *)pic_obj_alloc(pic, sizeof(struct env), PIC_TYPE_ENV);
+  env->up = NULL;
+  env->prefix = pic_str_ptr(pic, prefix);
+  kh_init(env, &env->map);
+
+  return obj_value(pic, env);
+}
+
+static pic_value
+default_env(pic_state *pic)
+{
+  return pic_ref(pic, "default-environment");
+}
+
+static pic_value
+extend_env(pic_state *pic, pic_value up)
+{
+  struct env *env;
+
+  env = (struct env *)pic_obj_alloc(pic, sizeof(struct env), PIC_TYPE_ENV);
+  env->up = pic_env_ptr(pic, up);
+  env->prefix = NULL;
+  kh_init(env, &env->map);
+
+  return obj_value(pic, env);
+}
+
+static bool
+search_scope(pic_state *pic, pic_value id, pic_value env, pic_value *uid)
+{
+  int it;
+
+  it = kh_get(env, &pic_env_ptr(pic, env)->map, pic_id_ptr(pic, id));
+  if (it == kh_end(&pic_env_ptr(pic, env)->map)) {
+    return false;
+  }
+  *uid = obj_value(pic, kh_val(&pic_env_ptr(pic, env)->map, it));
+  return true;
+}
+
+static bool
+search(pic_state *pic, pic_value id, pic_value env, pic_value *uid)
+{
+  struct env *e;
+
+  while (1) {
+    if (search_scope(pic, id, env, uid))
+      return true;
+    e = pic_env_ptr(pic, env)->up;
+    if (e == NULL)
+      break;
+    env = obj_value(pic, e);
+  }
+  return false;
+}
+
+pic_value
+pic_find_identifier(pic_state *pic, pic_value id, pic_value env)
+{
+  struct env *e;
+  pic_value uid;
+
+  while (! search(pic, id, env, &uid)) {
+    if (pic_sym_p(pic, id)) {
+      while (1) {
+        e = pic_env_ptr(pic, env);
+        if (e->up == NULL)
+          break;
+        env = obj_value(pic, e->up);
+      }
+      return pic_add_identifier(pic, id, env);
+    }
+    env = obj_value(pic, pic_id_ptr(pic, id)->env); /* do not overwrite id first */
+    id = obj_value(pic, pic_id_ptr(pic, id)->u.id);
+  }
+  return uid;
+}
+
+pic_value
+pic_add_identifier(pic_state *pic, pic_value id, pic_value env)
+{
+  const char *name, *prefix;
+  pic_value uid, str;
+
+  if (search_scope(pic, id, env, &uid)) {
+    return uid;
+  }
+
+  name = pic_str(pic, pic_id_name(pic, id), NULL);
+
+  if (pic_env_ptr(pic, env)->up == NULL && pic_sym_p(pic, id)) {
+    prefix = pic_str(pic, obj_value(pic, pic_env_ptr(pic, env)->prefix), NULL);
+    str = pic_strf_value(pic, "%s%s", prefix, name);
+  } else {
+    str = pic_strf_value(pic, ".%s.%d", name, pic->ucnt++);
+  }
+  uid = pic_intern(pic, str);
+
+  pic_set_identifier(pic, id, uid, env);
+
+  return uid;
+}
+
+void
+pic_set_identifier(pic_state *pic, pic_value id, pic_value uid, pic_value env)
+{
+  int it, ret;
+  it = kh_put(env, &pic_env_ptr(pic, env)->map, pic_id_ptr(pic, id), &ret);
+  kh_val(&pic_env_ptr(pic, env)->map, it) = pic_sym_ptr(pic, uid);
+}
 
 static pic_value pic_compile(pic_state *, pic_value);
 
@@ -61,7 +181,7 @@ expand_var(pic_state *pic, pic_value id, pic_value env, pic_value deferred)
 static pic_value
 expand_quote(pic_state *pic, pic_value expr)
 {
-  return pic_cons(pic, S("quote"), pic_cdr(pic, expr));
+  return pic_cons(pic, S("core#quote"), pic_cdr(pic, expr));
 }
 
 static pic_value
@@ -119,7 +239,7 @@ expand_lambda(pic_state *pic, pic_value expr, pic_value env)
   pic_value in;
   pic_value a, deferred;
 
-  in = pic_make_env(pic, env);
+  in = extend_env(pic, env);
 
   for (a = pic_cadr(pic, expr); pic_pair_p(pic, a); a = pic_cdr(pic, a)) {
     pic_add_identifier(pic, pic_car(pic, a), in);
@@ -135,7 +255,7 @@ expand_lambda(pic_state *pic, pic_value expr, pic_value env)
 
   expand_deferred(pic, deferred, in);
 
-  return pic_list(pic, 3, S("lambda"), formal, body);
+  return pic_list(pic, 3, S("core#lambda"), formal, body);
 }
 
 static pic_value
@@ -149,7 +269,7 @@ expand_define(pic_state *pic, pic_value expr, pic_value env, pic_value deferred)
 
   val = expand(pic, pic_list_ref(pic, expr, 2), env, deferred);
 
-  return pic_list(pic, 3, S("define"), uid, val);
+  return pic_list(pic, 3, S("core#define"), uid, val);
 }
 
 static pic_value
@@ -189,16 +309,16 @@ expand_node(pic_state *pic, pic_value expr, pic_value env, pic_value deferred)
 
       functor = pic_find_identifier(pic, pic_car(pic, expr), env);
 
-      if (EQ(functor, "define-macro")) {
+      if (EQ(functor, "core#define-macro")) {
         return expand_defmacro(pic, expr, env);
       }
-      else if (EQ(functor, "lambda")) {
+      else if (EQ(functor, "core#lambda")) {
         return expand_defer(pic, expr, deferred);
       }
-      else if (EQ(functor, "define")) {
+      else if (EQ(functor, "core#define")) {
         return expand_define(pic, expr, env, deferred);
       }
-      else if (EQ(functor, "quote")) {
+      else if (EQ(functor, "core#quote")) {
         return expand_quote(pic, expr);
       }
 
@@ -255,10 +375,10 @@ optimize_beta(pic_state *pic, pic_value expr)
   if (pic_sym_p(pic, pic_list_ref(pic, expr, 0))) {
     pic_value sym = pic_list_ref(pic, expr, 0);
 
-    if (EQ(sym, "quote")) {
+    if (EQ(sym, "core#quote")) {
       return expr;
-    } else if (EQ(sym, "lambda")) {
-      return pic_list(pic, 3, S("lambda"), pic_list_ref(pic, expr, 1), optimize_beta(pic, pic_list_ref(pic, expr, 2)));
+    } else if (EQ(sym, "core#lambda")) {
+      return pic_list(pic, 3, S("core#lambda"), pic_list_ref(pic, expr, 1), optimize_beta(pic, pic_list_ref(pic, expr, 2)));
     }
   }
 
@@ -272,7 +392,7 @@ optimize_beta(pic_state *pic, pic_value expr)
   pic_protect(pic, expr);
 
   functor = pic_list_ref(pic, expr, 0);
-  if (pic_pair_p(pic, functor) && EQ(pic_car(pic, functor), "lambda")) {
+  if (pic_pair_p(pic, functor) && pic_sym_p(pic, pic_car(pic, functor)) && EQ(pic_car(pic, functor), "core#lambda")) {
     formals = pic_list_ref(pic, functor, 1);
     if (! pic_list_p(pic, formals))
       goto exit;              /* TODO: support ((lambda args x) 1 2) */
@@ -281,12 +401,12 @@ optimize_beta(pic_state *pic, pic_value expr)
       goto exit;
     defs = pic_nil_value(pic);
     pic_for_each (val, args, it) {
-      pic_push(pic, pic_list(pic, 3, S("define"), pic_car(pic, formals), val), defs);
+      pic_push(pic, pic_list(pic, 3, S("core#define"), pic_car(pic, formals), val), defs);
       formals = pic_cdr(pic, formals);
     }
     expr = pic_list_ref(pic, functor, 2);
     pic_for_each (val, defs, it) {
-      expr = pic_list(pic, 3, S("begin"), val, expr);
+      expr = pic_list(pic, 3, S("core#begin"), val, expr);
     }
   }
  exit:
@@ -316,7 +436,7 @@ normalize_body(pic_state *pic, pic_value expr, bool in)
   if (! in) {
     return v;
   }
-  return pic_list(pic, 3, S("let"), pic_car(pic, locals), v);
+  return pic_list(pic, 3, S("core#let"), pic_car(pic, locals), v);
 }
 
 static pic_value
@@ -334,16 +454,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, "define")) {
+    if (EQ(sym, "core#define")) {
       pic_value var, val;
 
       var = pic_list_ref(pic, expr, 1);
 
       if (! in) {               /* global */
-        if (pic_weak_has(pic, pic->globals, var)) {
+        if (pic_dict_has(pic, pic->globals, var)) {
           pic_warnf(pic, "redefining variable: %s", pic_sym(pic, var));
         }
-        pic_weak_set(pic, pic->globals, var, pic_invalid_value(pic));
+        pic_dict_set(pic, pic->globals, var, pic_invalid_value(pic));
       } else {                  /* local */
         bool found = false;
 
@@ -359,12 +479,12 @@ normalize(pic_state *pic, pic_value expr, pic_value locals, bool in)
         }
       }
       val = normalize(pic, pic_list_ref(pic, expr, 2), locals, in);
-      return pic_list(pic, 3, S("set!"), var, val);
+      return pic_list(pic, 3, S("core#set!"), var, val);
     }
-    else if (EQ(sym, "lambda")) {
-      return pic_list(pic, 3, S("lambda"), pic_list_ref(pic, expr, 1), normalize_body(pic, pic_list_ref(pic, expr, 2), true));
+    else if (EQ(sym, "core#lambda")) {
+      return pic_list(pic, 3, S("core#lambda"), pic_list_ref(pic, expr, 1), normalize_body(pic, pic_list_ref(pic, expr, 2), true));
     }
-    else if (EQ(sym, "quote")) {
+    else if (EQ(sym, "core#quote")) {
       return expr;
     }
   }
@@ -450,11 +570,11 @@ analyze_var(pic_state *pic, analyze_scope *scope, pic_value sym)
   depth = find_var(pic, scope, sym);
 
   if (depth == scope->depth) {
-    return pic_list(pic, 2, S("gref"), sym);
+    return pic_list(pic, 2, S("core#gref"), sym);
   } else if (depth == 0) {
-    return pic_list(pic, 2, S("lref"), sym);
+    return pic_list(pic, 2, S("core#lref"), sym);
   } else {
-    return pic_list(pic, 3, S("cref"), pic_int_value(pic, depth), sym);
+    return pic_list(pic, 3, S("core#cref"), pic_int_value(pic, depth), sym);
   }
 }
 
@@ -473,7 +593,7 @@ analyze_lambda(pic_state *pic, analyze_scope *up, pic_value form)
   /* analyze body */
   body = analyze(pic, scope, body);
 
-  return pic_list(pic, 5, S("lambda"), args, locals, scope->captures, body);
+  return pic_list(pic, 5, S("core#lambda"), args, locals, scope->captures, body);
 }
 
 static pic_value
@@ -491,7 +611,7 @@ analyze_list(pic_state *pic, analyze_scope *scope, pic_value obj)
 static pic_value
 analyze_call(pic_state *pic, analyze_scope *scope, pic_value obj)
 {
-  return pic_cons(pic, S("call"), analyze_list(pic, scope, obj));
+  return pic_cons(pic, S("core#call"), analyze_list(pic, scope, obj));
 }
 
 static pic_value
@@ -512,13 +632,13 @@ analyze_node(pic_state *pic, analyze_scope *scope, pic_value obj)
     if (pic_sym_p(pic, proc)) {
       pic_value sym = proc;
 
-      if (EQ(sym, "lambda")) {
+      if (EQ(sym, "core#lambda")) {
         return analyze_lambda(pic, scope, obj);
       }
-      else if (EQ(sym, "quote")) {
+      else if (EQ(sym, "core#quote")) {
         return obj;
       }
-      else if (EQ(sym, "begin") || EQ(sym, "set!") || EQ(sym, "if")) {
+      else if (EQ(sym, "core#begin") || EQ(sym, "core#set!") || EQ(sym, "core#if")) {
         return pic_cons(pic, pic_car(pic, obj), analyze_list(pic, scope, pic_cdr(pic, obj)));
       }
     }
@@ -526,7 +646,7 @@ analyze_node(pic_state *pic, analyze_scope *scope, pic_value obj)
     return analyze_call(pic, scope, obj);
   }
   default:
-    return pic_list(pic, 2, S("quote"), obj);
+    return pic_list(pic, 2, S("core#quote"), obj);
   }
 }
 
@@ -703,22 +823,22 @@ struct {
   int insn;
   int argc;
 } pic_vm_proc[] = {
-  { "picrin.base/cons", OP_CONS, 2 },
-  { "picrin.base/car", OP_CAR, 1 },
-  { "picrin.base/cdr", OP_CDR, 1 },
-  { "picrin.base/null?", OP_NILP, 1 },
-  { "picrin.base/symbol?", OP_SYMBOLP, 1 },
-  { "picrin.base/pair?", OP_PAIRP, 1 },
-  { "picrin.base/not", OP_NOT, 1 },
-  { "picrin.base/=", OP_EQ, 2 },
-  { "picrin.base/<", OP_LT, 2 },
-  { "picrin.base/<=", OP_LE, 2 },
-  { "picrin.base/>", OP_GT, 2 },
-  { "picrin.base/>=", OP_GE, 2 },
-  { "picrin.base/+", OP_ADD, 2 },
-  { "picrin.base/-", OP_SUB, 2 },
-  { "picrin.base/*", OP_MUL, 2 },
-  { "picrin.base//", OP_DIV, 2 }
+  { "cons", OP_CONS, 2 },
+  { "car", OP_CAR, 1 },
+  { "cdr", OP_CDR, 1 },
+  { "null?", OP_NILP, 1 },
+  { "symbol?", OP_SYMBOLP, 1 },
+  { "pair?", OP_PAIRP, 1 },
+  { "not", OP_NOT, 1 },
+  { "=", OP_EQ, 2 },
+  { "<", OP_LT, 2 },
+  { "<=", OP_LE, 2 },
+  { ">", OP_GT, 2 },
+  { ">=", OP_GE, 2 },
+  { "+", OP_ADD, 2 },
+  { "-", OP_SUB, 2 },
+  { "*", OP_MUL, 2 },
+  { "/", OP_DIV, 2 }
 };
 
 static int
@@ -794,14 +914,14 @@ codegen_ref(pic_state *pic, codegen_context *cxt, pic_value obj, bool tailpos)
   pic_value sym;
 
   sym = pic_car(pic, obj);
-  if (EQ(sym, "gref")) {
+  if (EQ(sym, "core#gref")) {
     pic_value name;
 
     name = pic_list_ref(pic, obj, 1);
     emit_i(pic, cxt, OP_GREF, index_global(pic, cxt, name));
     emit_ret(pic, cxt, tailpos);
   }
-  else if (EQ(sym, "cref")) {
+  else if (EQ(sym, "core#cref")) {
     pic_value name;
     int depth;
 
@@ -810,7 +930,7 @@ codegen_ref(pic_state *pic, codegen_context *cxt, pic_value obj, bool tailpos)
     emit_r(pic, cxt, OP_CREF, depth, index_capture(pic, cxt, name, depth));
     emit_ret(pic, cxt, tailpos);
   }
-  else if (EQ(sym, "lref")) {
+  else if (EQ(sym, "core#lref")) {
     pic_value name;
     int i;
 
@@ -836,7 +956,7 @@ codegen_set(pic_state *pic, codegen_context *cxt, pic_value obj, bool tailpos)
 
   var = pic_list_ref(pic, obj, 1);
   type = pic_list_ref(pic, var, 0);
-  if (EQ(type, "gref")) {
+  if (EQ(type, "core#gref")) {
     pic_value name;
     size_t i;
 
@@ -850,7 +970,7 @@ codegen_set(pic_state *pic, codegen_context *cxt, pic_value obj, bool tailpos)
     emit_i(pic, cxt, OP_GSET, index_global(pic, cxt, name));
     emit_ret(pic, cxt, tailpos);
   }
-  else if (EQ(type, "cref")) {
+  else if (EQ(type, "core#cref")) {
     pic_value name;
     int depth;
 
@@ -859,7 +979,7 @@ codegen_set(pic_state *pic, codegen_context *cxt, pic_value obj, bool tailpos)
     emit_r(pic, cxt, OP_CSET, depth, index_capture(pic, cxt, name, depth));
     emit_ret(pic, cxt, tailpos);
   }
-  else if (EQ(type, "lref")) {
+  else if (EQ(type, "core#lref")) {
     pic_value name;
     int i;
 
@@ -989,7 +1109,7 @@ codegen_call(pic_state *pic, codegen_context *cxt, pic_value obj, bool tailpos)
   pic_value elt, it, functor;
 
   functor = pic_list_ref(pic, obj, 1);
-  if (EQ(pic_list_ref(pic, functor, 0), "gref")) {
+  if (EQ(pic_list_ref(pic, functor, 0), "core#gref")) {
     pic_value sym;
     size_t i;
 
@@ -1019,25 +1139,25 @@ codegen(pic_state *pic, codegen_context *cxt, pic_value obj, bool tailpos)
   pic_value sym;
 
   sym = pic_car(pic, obj);
-  if (EQ(sym, "gref") || EQ(sym, "cref") || EQ(sym, "lref")) {
+  if (EQ(sym, "core#gref") || EQ(sym, "core#cref") || EQ(sym, "core#lref")) {
     codegen_ref(pic, cxt, obj, tailpos);
   }
-  else if (EQ(sym, "set!") || EQ(sym, "define")) {
+  else if (EQ(sym, "core#set!") || EQ(sym, "core#define")) {
     codegen_set(pic, cxt, obj, tailpos);
   }
-  else if (EQ(sym, "lambda")) {
+  else if (EQ(sym, "core#lambda")) {
     codegen_lambda(pic, cxt, obj, tailpos);
   }
-  else if (EQ(sym, "if")) {
+  else if (EQ(sym, "core#if")) {
     codegen_if(pic, cxt, obj, tailpos);
   }
-  else if (EQ(sym, "begin")) {
+  else if (EQ(sym, "core#begin")) {
     codegen_begin(pic, cxt, obj, tailpos);
   }
-  else if (EQ(sym, "quote")) {
+  else if (EQ(sym, "core#quote")) {
     codegen_quote(pic, cxt, obj, tailpos);
   }
-  else if (EQ(sym, "call")) {
+  else if (EQ(sym, "core#call")) {
     codegen_call(pic, cxt, obj, tailpos);
   }
   else {
@@ -1099,40 +1219,79 @@ pic_compile(pic_state *pic, pic_value obj)
   return pic_make_proc_irep(pic, irep, NULL);
 }
 
-pic_value
-pic_eval(pic_state *pic, pic_value program, const char *lib)
+static pic_value
+pic_eval_make_environment(pic_state *pic)
 {
-  const char *prev_lib = pic_current_library(pic);
-  pic_value env, r, e;
+  pic_value name;
 
-  env = pic_library_environment(pic, lib);
+  pic_get_args(pic, "m", &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);
+  return pic_make_env(pic, pic_sym_name(pic, name));
+}
 
-  return r;
+static pic_value
+pic_eval_set_identifier(pic_state *pic)
+{
+  pic_value id, uid, env;
+
+  pic_get_args(pic, "omo", &id, &uid, &env);
+
+  TYPE_CHECK(pic, id, id);
+  TYPE_CHECK(pic, env, env);
+
+  pic_set_identifier(pic, id, uid, env);
+  return pic_undef_value(pic);
+}
+
+static pic_value
+pic_eval_find_identifier(pic_state *pic)
+{
+  pic_value id, env;
+
+  pic_get_args(pic, "oo", &id, &env);
+
+  TYPE_CHECK(pic, id, id);
+  TYPE_CHECK(pic, env, env);
+
+  return pic_find_identifier(pic, id, env);
 }
 
 static pic_value
 pic_eval_eval(pic_state *pic)
 {
-  pic_value program;
-  const char *str;
+  pic_value program, env = default_env(pic), r, e;
 
-  pic_get_args(pic, "oz", &program, &str);
+  pic_get_args(pic, "o|o", &program, &env);
 
-  return pic_eval(pic, program, str);
+  pic_try {
+    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,357 +4,37 @@
 
 #include "picrin.h"
 #include "picrin/extra.h"
-#include "object.h"
-#include "state.h"
-
-KHASH_DEFINE(env, struct identifier *, symbol *, kh_ptr_hash_func, kh_ptr_hash_equal)
-KHASH_DEFINE(ltable, const char *, struct lib, kh_str_hash_func, kh_str_cmp_func)
-
-pic_value
-pic_make_env(pic_state *pic, pic_value up)
-{
-  struct env *env;
-
-  env = (struct env *)pic_obj_alloc(pic, sizeof(struct env), PIC_TYPE_ENV);
-  env->up = pic_env_ptr(pic, up);
-  env->lib = NULL;
-  kh_init(env, &env->map);
-
-  return obj_value(pic, env);
-}
-
-static bool
-search_scope(pic_state *pic, pic_value id, pic_value env, pic_value *uid)
-{
-  int it;
-
-  it = kh_get(env, &pic_env_ptr(pic, env)->map, pic_id_ptr(pic, id));
-  if (it == kh_end(&pic_env_ptr(pic, env)->map)) {
-    return false;
-  }
-  *uid = obj_value(pic, kh_val(&pic_env_ptr(pic, env)->map, it));
-  return true;
-}
-
-static bool
-search(pic_state *pic, pic_value id, pic_value env, pic_value *uid)
-{
-  struct env *e;
-
-  while (1) {
-    if (search_scope(pic, id, env, uid))
-      return true;
-    e = pic_env_ptr(pic, env)->up;
-    if (e == NULL)
-      break;
-    env = obj_value(pic, e);
-  }
-  return false;
-}
-
-pic_value
-pic_find_identifier(pic_state *pic, pic_value id, pic_value env)
-{
-  struct env *e;
-  pic_value uid;
-
-  while (! search(pic, id, env, &uid)) {
-    if (pic_sym_p(pic, id)) {
-      while (1) {
-        e = pic_env_ptr(pic, env);
-        if (e->up == NULL)
-          break;
-        env = obj_value(pic, e->up);
-      }
-      return pic_add_identifier(pic, id, env);
-    }
-    env = obj_value(pic, pic_id_ptr(pic, id)->env); /* do not overwrite id first */
-    id = obj_value(pic, pic_id_ptr(pic, id)->u.id);
-  }
-  return uid;
-}
-
-pic_value
-pic_add_identifier(pic_state *pic, pic_value id, pic_value env)
-{
-  const char *name, *lib;
-  pic_value uid, str;
-
-  if (search_scope(pic, id, env, &uid)) {
-    return uid;
-  }
-
-  name = pic_str(pic, pic_id_name(pic, id), NULL);
-
-  if (pic_env_ptr(pic, env)->up == NULL && pic_sym_p(pic, id)) { /* toplevel & public */
-    lib = pic_str(pic, obj_value(pic, pic_env_ptr(pic, env)->lib), NULL);
-    str = pic_strf_value(pic, "%s/%s", lib, name);
-  } else {
-    str = pic_strf_value(pic, ".%s.%d", name, pic->ucnt++);
-  }
-  uid = pic_intern(pic, str);
-
-  pic_put_identifier(pic, id, uid, env);
-
-  return uid;
-}
 
 void
-pic_put_identifier(pic_state *pic, pic_value id, pic_value uid, pic_value env)
+pic_deflibrary(pic_state *pic, const char *lib)
 {
-  int it, ret;
+  pic_value name = pic_intern_cstr(pic, lib), v;
 
-  it = kh_put(env, &pic_env_ptr(pic, env)->map, pic_id_ptr(pic, id), &ret);
-  kh_val(&pic_env_ptr(pic, env)->map, it) = pic_sym_ptr(pic, uid);
-}
-
-static struct lib *
-get_library_opt(pic_state *pic, const char *lib)
-{
-  khash_t(ltable) *h = &pic->ltable;
-  int it;
-
-  it = kh_get(ltable, h, lib);
-  if (it == kh_end(h)) {
-    return NULL;
+  v = pic_funcall(pic, "find-library", 1, name);
+  if (! pic_bool(pic, v)) {
+    pic_funcall(pic, "make-library", 1, name);
   }
-  return &kh_val(h, it);
-}
-
-static struct lib *
-get_library(pic_state *pic, const char *lib)
-{
-  struct lib *libp;
-
-  if ((libp = get_library_opt(pic, lib)) == NULL) {
-    pic_error(pic, "library not found", 1, pic_cstr_value(pic, lib));
-  }
-  return libp;
-}
-
-static pic_value
-make_library_env(pic_state *pic, pic_value name)
-{
-  struct env *env;
-  pic_value e;
-
-  env = (struct env *)pic_obj_alloc(pic, sizeof(struct env), PIC_TYPE_ENV);
-  env->up = NULL;
-  env->lib = pic_str_ptr(pic, name);
-  kh_init(env, &env->map);
-
-  e = obj_value(pic, env);
-
-#define REGISTER(name) pic_put_identifier(pic, pic_intern_lit(pic, name), pic_intern_lit(pic, name), e)
-
-  /* set up default environment */
-  REGISTER("define-library");
-  REGISTER("import");
-  REGISTER("export");
-  REGISTER("cond-expand");
-
-  return e;
-}
-
-void
-pic_make_library(pic_state *pic, const char *lib)
-{
-  khash_t(ltable) *h = &pic->ltable;
-  pic_value name, env, exports;
-  int it;
-  int ret;
-
-  name = pic_cstr_value(pic, lib);
-  env = make_library_env(pic, name);
-  exports = pic_make_dict(pic);
-
-  it = kh_put(ltable, h, pic_str(pic, name, NULL), &ret);
-  if (ret == 0) {               /* if exists */
-    pic_error(pic, "library name already in use", 1, pic_cstr_value(pic, lib));
-  }
-
-  kh_val(h, it).name = pic_str_ptr(pic, name);
-  kh_val(h, it).env = pic_env_ptr(pic, env);
-  kh_val(h, it).exports = pic_dict_ptr(pic, exports);
 }
 
 void
 pic_in_library(pic_state *pic, const char *lib)
 {
-  get_library(pic, lib);
-  pic->lib = lib;
-}
+  pic_value name = pic_intern_cstr(pic, lib);
 
-bool
-pic_find_library(pic_state *pic, const char *lib)
-{
-  return get_library_opt(pic, lib) != NULL;
-}
-
-const char *
-pic_current_library(pic_state *pic)
-{
-  return pic->lib;
-}
-
-pic_value
-pic_library_environment(pic_state *pic, const char *lib)
-{
-  return obj_value(pic, get_library(pic, lib)->env);
+  pic_funcall(pic, "current-library", 1, name);
 }
 
 void
-pic_import(pic_state *pic, const char *lib)
+pic_export(pic_state *pic, int n, ...)
 {
-  pic_value name, realname, uid;
-  int it = 0;
-  struct lib *our, *their;
+  size_t ai = pic_enter(pic);
+  va_list ap;
 
-  our = get_library(pic, pic->lib);
-  their = get_library(pic, lib);
-
-  while (pic_dict_next(pic, obj_value(pic, their->exports), &it, &name, &realname)) {
-    uid = pic_find_identifier(pic, realname, obj_value(pic, their->env));
-    if (! pic_weak_has(pic, pic->globals, uid) && ! pic_weak_has(pic, pic->macros, uid)) {
-      pic_error(pic, "attempted to export undefined variable", 1, realname);
-    }
-    pic_put_identifier(pic, name, uid, obj_value(pic, our->env));
+  va_start(ap, n);
+  while (n--) {
+    pic_value var = pic_intern_cstr(pic, va_arg(ap, const char *));
+    pic_funcall(pic, "library-export", 2, var, var);
   }
-}
-
-void
-pic_export(pic_state *pic, pic_value name)
-{
-  pic_dict_set(pic, obj_value(pic, get_library(pic, pic->lib)->exports), name, name);
-}
-
-static pic_value
-pic_lib_make_library(pic_state *pic)
-{
-  const char *lib;
-
-  pic_get_args(pic, "z", &lib);
-
-  pic_make_library(pic, lib);
-
-  return pic_undef_value(pic);
-}
-
-static pic_value
-pic_lib_find_library(pic_state *pic)
-{
-  const char *lib;
-
-  pic_get_args(pic, "z", &lib);
-
-  return pic_bool_value(pic, pic_find_library(pic, lib));
-}
-
-static pic_value
-pic_lib_current_library(pic_state *pic)
-{
-  const char *lib;
-  int n;
-
-  n = pic_get_args(pic, "|z", &lib);
-
-  if (n == 0) {
-    return pic_cstr_value(pic, pic_current_library(pic));
-  }
-  else {
-    pic_in_library(pic, lib);
-
-    return pic_undef_value(pic);
-  }
-}
-
-static pic_value
-pic_lib_library_import(pic_state *pic)
-{
-  const char *lib;
-  pic_value name, alias, realname, uid;
-  struct lib *libp;
-  int n;
-
-  n = pic_get_args(pic, "zm|m", &lib, &name, &alias);
-
-  if (n == 2) {
-    alias = name;
-  }
-
-  libp = get_library(pic, lib);
-
-  if (! pic_dict_has(pic, obj_value(pic, libp->exports), name)) {
-    pic_error(pic, "library-import: variable is not exported", 1, name);
-  } else {
-    realname = pic_dict_ref(pic, obj_value(pic, libp->exports), name);
-  }
-
-  uid = pic_find_identifier(pic, realname, obj_value(pic, libp->env));
-  if (! pic_weak_has(pic, pic->globals, uid) && ! pic_weak_has(pic, pic->macros, uid)) {
-    pic_error(pic, "attempted to export undefined variable", 1, realname);
-  }
-
-  pic_put_identifier(pic, alias, uid, obj_value(pic, get_library(pic, pic->lib)->env));
-
-  return pic_undef_value(pic);
-}
-
-static pic_value
-pic_lib_library_export(pic_state *pic)
-{
-  pic_value name, alias = pic_false_value(pic);
-  int n;
-
-  n = pic_get_args(pic, "m|m", &name, &alias);
-
-  if (n == 1) {
-    alias = name;
-  }
-
-  pic_dict_set(pic, obj_value(pic, get_library(pic, pic->lib)->exports), alias, name);
-
-  return pic_undef_value(pic);
-}
-
-static pic_value
-pic_lib_library_exports(pic_state *pic)
-{
-  const char *lib;
-  pic_value sym, exports = pic_nil_value(pic);
-  int it = 0;
-  struct lib *libp;
-
-  pic_get_args(pic, "z", &lib);
-
-  libp = get_library(pic, lib);
-
-  while (pic_dict_next(pic, obj_value(pic, libp->exports), &it, &sym, NULL)) {
-    pic_push(pic, sym, exports);
-  }
-
-  return exports;
-}
-
-static pic_value
-pic_lib_library_environment(pic_state *pic)
-{
-  const char *lib;
-
-  pic_get_args(pic, "z", &lib);
-
-  return obj_value(pic, get_library(pic, lib)->env);
-}
-
-void
-pic_init_lib(pic_state *pic)
-{
-  pic_defun(pic, "make-library", pic_lib_make_library);
-  pic_defun(pic, "find-library", pic_lib_find_library);
-  pic_defun(pic, "library-exports", pic_lib_library_exports);
-  pic_defun(pic, "library-environment", pic_lib_library_environment);
-
-  pic_defun(pic, "current-library", pic_lib_current_library);
-  pic_defun(pic, "library-import", pic_lib_library_import);
-  pic_defun(pic, "library-export", pic_lib_library_export);
+  va_end(ap);
+  pic_leave(pic, ai);
 }

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_eval(pic, form, pic_current_library(pic));
+    pic_funcall(pic, "eval", 1, form);
     pic_leave(pic, ai);
   }
 }
@@ -29,6 +29,5 @@ pic_load_cstr(pic_state *pic, const char *str)
     pic_fclose(pic, port);
     pic_raise(pic, e);
   }
-
   pic_fclose(pic, port);
 }

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, "picrin.base", "string->number", 1, str);
+  num = pic_funcall(pic, "string->number", 1, str);
   if (! pic_false_p(pic, num)) {
     return num;
   }
@@ -730,6 +730,7 @@ 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)); /* TODO optimize */
+  return pic_data(pic, pic_data_value(pic, pic_malloc(pic, n), &t));
 }
 
 /* MARK */
@@ -406,6 +406,8 @@ gc_mark_object(pic_state *pic, struct object *obj)
     }
     if (obj->u.env.up) {
       LOOP(obj->u.env.up);
+    } else {
+      LOOP(obj->u.env.prefix);
     }
     break;
   }
@@ -450,7 +452,6 @@ gc_mark_phase(pic_state *pic)
 {
   pic_value *stack;
   struct callinfo *ci;
-  int it;
   size_t j;
 
   assert(pic->heap->weaks == NULL);
@@ -487,16 +488,6 @@ gc_mark_phase(pic_state *pic)
   /* features */
   gc_mark(pic, pic->features);
 
-  /* library table */
-  for (it = kh_begin(&pic->ltable); it != kh_end(&pic->ltable); ++it) {
-    if (! kh_exist(&pic->ltable, it)) {
-      continue;
-    }
-    gc_mark_object(pic, (struct object *)kh_val(&pic->ltable, it).name);
-    gc_mark_object(pic, (struct object *)kh_val(&pic->ltable, it).env);
-    gc_mark_object(pic, (struct object *)kh_val(&pic->ltable, it).exports);
-  }
-
   /* weak maps */
   do {
     struct object *key;

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

lib/include/picrin/extra.h

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

lib/include/picrin/value.h

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

lib/state.c

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

lib/state.h

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

lib/string.c

@@ -213,6 +213,12 @@ pic_str_value(pic_state *pic, const char *str, int len)
   return make_str(pic, r);
 }
 
+pic_value
+pic_cstr_value(pic_state *pic, const char *cstr)
+{
+  return pic_str_value(pic, cstr, strlen(cstr));
+}
+
 pic_value
 pic_strf_value(pic_state *pic, const char *fmt, ...)
 {
@@ -532,7 +538,7 @@ pic_str_string_map(pic_state *pic)
       pic_push(pic, pic_char_value(pic, pic_str(pic, argv[j], 0)[i]), vals);
     }
     vals = pic_reverse(pic, vals);
-    val = pic_funcall(pic, "picrin.base", "apply", 2, proc, vals);
+    val = pic_funcall(pic, "apply", 2, proc, vals);
 
     TYPE_CHECK(pic, val, char);
 
@@ -567,7 +573,7 @@ pic_str_string_for_each(pic_state *pic)
       pic_push(pic, pic_char_value(pic, pic_str(pic, argv[j], 0)[i]), vals);
     }
     vals = pic_reverse(pic, vals);
-    pic_funcall(pic, "picrin.base", "apply", 2, proc, vals);
+    pic_funcall(pic, "apply", 2, proc, vals);
   }
   return pic_undef_value(pic);
 }

lib/var.c

@@ -40,10 +40,19 @@ var_call(pic_state *pic)
 pic_value
 pic_make_var(pic_state *pic, pic_value init, pic_value conv)
 {
-  pic_value var;
+  pic_value var, env = pic->dyn_env;
 
   var = pic_lambda(pic, var_call, 1, conv);
-  pic_call(pic, var, 1, init);
+  while (1) {
+    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, "picrin.base", "apply", 2, proc, vals));
+    pic_vec_set(pic, vec, i, pic_funcall(pic, "apply", 2, proc, vals));
   }
 
   return vec;
@@ -281,7 +281,7 @@ pic_vec_vector_for_each(pic_state *pic)
       pic_push(pic, pic_vec_ref(pic, argv[j], i), vals);
     }
     vals = pic_reverse(pic, vals);
-    pic_funcall(pic, "picrin.base", "apply", 2, proc, vals);
+    pic_funcall(pic, "apply", 2, proc, vals);
   }
 
   return pic_undef_value(pic);

piclib/boot.scm

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

piclib/library.scm

@@ -0,0 +1,271 @@
+;;; There are two ways to name a library: (foo bar) or foo.bar
+;;; The former is normalized to the latter.
+
+(define (mangle name)
+  (when (null? name)
+    (error "library name should be a list of at least one symbols" name))
+
+  (define (->string n)
+    (cond
+     ((symbol? n)
+      (let ((str (symbol->string n)))
+        (string-for-each
+         (lambda (c)
+           (when (or (char=? c #\.) (char=? c #\:))
+             (error "elements of library name may not contain '.' or ':'" n)))
+         str)
+        str))
+     ((and (number? n) (exact? n) (<= 0 n))
+      (number->string n))
+     (else
+      (error "symbol or non-negative integer is required" n))))
+
+  (define (join strs delim)
+    (let loop ((res (car strs)) (strs (cdr strs)))
+      (if (null? strs)
+          res
+          (loop (string-append res delim (car strs)) (cdr strs)))))
+
+  (if (symbol? name)
+      name                              ; TODO: check symbol names
+      (string->symbol (join (map ->string name) "."))))
+
+(define current-library
+  (make-parameter '(picrin base) mangle))
+
+(define *libraries*
+  (make-dictionary))
+
+(define (find-library name)
+  (dictionary-has? *libraries* (mangle name)))
+
+(define (make-library name)
+  (let ((name (mangle name)))
+    (let ((env (make-environment
+                 (string->symbol (string-append (symbol->string name) ":"))))
+          (exports (make-dictionary)))
+      ;; set up initial environment
+      (set-identifier! 'define-library 'define-library env)
+      (set-identifier! 'import 'import env)
+      (set-identifier! 'export 'export env)
+      (set-identifier! 'cond-expand 'cond-expand env)
+      (dictionary-set! *libraries* name `(,env . ,exports)))))
+
+(define (library-environment name)
+  (car (dictionary-ref *libraries* (mangle name))))
+
+(define (library-exports name)
+  (cdr (dictionary-ref *libraries* (mangle name))))
+
+(define (library-import name sym alias)
+  (let ((uid (dictionary-ref (library-exports name) sym)))
+    (let ((env (library-environment (current-library))))
+      (set-identifier! alias uid env))))
+
+(define (library-export sym alias)
+  (let ((env (library-environment (current-library)))
+        (exports (library-exports (current-library))))
+    (dictionary-set! exports alias (find-identifier sym env))))
+
+
+
+;;; R7RS library syntax
+
+(define-macro define-library
+  (lambda (form _)
+    (let ((name (cadr form))
+          (body (cddr form)))
+      (or (find-library name) (make-library name))
+      (parameterize ((current-library name))
+        (for-each
+         (lambda (expr)
+           (eval expr name))       ; TODO parse library declarations
+         body)))))
+
+(define-macro cond-expand
+  (lambda (form _)
+    (letrec
+        ((test (lambda (form)
+                 (or
+                  (eq? form 'else)
+                  (and (symbol? form)
+                       (memq form (features)))
+                  (and (pair? form)
+                       (case (car form)
+                         ((library) (find-library (cadr form)))
+                         ((not) (not (test (cadr form))))
+                         ((and) (let loop ((form (cdr form)))
+                                  (or (null? form)
+                                      (and (test (car form)) (loop (cdr form))))))
+                         ((or) (let loop ((form (cdr form)))
+                                 (and (pair? form)
+                                      (or (test (car form)) (loop (cdr form))))))
+                         (else #f)))))))
+      (let loop ((clauses (cdr form)))
+        (if (null? clauses)
+            #undefined
+            (if (test (caar clauses))
+                `(,the-begin ,@(cdar clauses))
+                (loop (cdr clauses))))))))
+
+(define-macro import
+  (lambda (form _)
+    (let ((caddr
+           (lambda (x) (car (cdr (cdr x)))))
+          (prefix
+           (lambda (prefix symbol)
+             (string->symbol
+              (string-append
+               (symbol->string prefix)
+               (symbol->string symbol)))))
+          (getlib
+           (lambda (name)
+             (if (find-library name)
+                 name
+                 (error "library not found" name)))))
+      (letrec
+          ((extract
+            (lambda (spec)
+              (case (car spec)
+                ((only rename prefix except)
+                 (extract (cadr spec)))
+                (else
+                 (getlib spec)))))
+           (collect
+            (lambda (spec)
+              (case (car spec)
+                ((only)
+                 (let ((alist (collect (cadr spec))))
+                   (map (lambda (var) (assq var alist)) (cddr spec))))
+                ((rename)
+                 (let ((alist (collect (cadr spec)))
+                       (renames (map (lambda (x) `(,(car x) . ,(cadr x))) (cddr spec))))
+                   (map (lambda (s) (or (assq (car s) renames) s)) alist)))
+                ((prefix)
+                 (let ((alist (collect (cadr spec))))
+                   (map (lambda (s) (cons (prefix (caddr spec) (car s)) (cdr s))) alist)))
+                ((except)
+                 (let ((alist (collect (cadr spec))))
+                   (let loop ((alist alist))
+                     (if (null? alist)
+                         '()
+                         (if (memq (caar alist) (cddr spec))
+                             (loop (cdr alist))
+                             (cons (car alist) (loop (cdr alist))))))))
+                (else
+                 (dictionary-map (lambda (x) (cons x x))
+                                 (library-exports (getlib spec))))))))
+        (letrec
+            ((import
+               (lambda (spec)
+                 (let ((lib (extract spec))
+                       (alist (collect spec)))
+                   (for-each
+                    (lambda (slot)
+                      (library-import lib (cdr slot) (car slot)))
+                    alist)))))
+          (for-each import (cdr form)))))))
+
+(define-macro export
+  (lambda (form _)
+    (letrec
+        ((collect
+          (lambda (spec)
+            (cond
+             ((symbol? spec)
+              `(,spec . ,spec))
+             ((and (list? spec) (= (length spec) 3) (eq? (car spec) 'rename))
+              `(,(list-ref spec 1) . ,(list-ref spec 2)))
+             (else
+              (error "malformed export")))))
+         (export
+           (lambda (spec)
+             (let ((slot (collect spec)))
+               (library-export (car slot) (cdr slot))))))
+      (for-each export (cdr form)))))
+
+
+;;; bootstrap...
+(let ()
+  (make-library '(picrin base))
+  (set-car! (dictionary-ref *libraries* (mangle '(picrin base))) default-environment)
+  (let ((export-keywords
+         (lambda (keywords)
+           (let ((env (library-environment '(picrin base)))
+                 (exports (library-exports '(picrin base))))
+             (for-each
+              (lambda (keyword)
+                (dictionary-set! exports keyword keyword))
+              keywords)))))
+    (export-keywords
+     '(define lambda quote set! if begin define-macro
+        let let* letrec letrec*
+        let-values let*-values define-values
+        quasiquote unquote unquote-splicing
+        and or
+        cond case else =>
+        do when unless
+        parameterize
+        define-syntax
+        syntax-quote syntax-unquote
+        syntax-quasiquote syntax-unquote-splicing
+        let-syntax letrec-syntax
+        syntax-error))
+    (export-keywords
+     '(features
+       eq? eqv? equal? not boolean? boolean=?
+       pair? cons car cdr null? set-car! set-cdr!
+       caar cadr cdar cddr
+       list? make-list list length append reverse
+       list-tail list-ref list-set! list-copy
+       map for-each memq memv member assq assv assoc
+       current-input-port current-output-port current-error-port
+       port? input-port? output-port? port-open? close-port
+       eof-object? eof-object
+       read-u8 peek-u8 read-bytevector!
+       write-u8 write-bytevector flush-output-port
+       open-input-bytevector open-output-bytevector get-output-bytevector
+       number? exact? inexact? inexact exact
+       = < > <= >= + - * /
+       number->string string->number
+       procedure? apply
+       symbol? symbol=? symbol->string string->symbol
+       make-identifier identifier? identifier=? identifier-base identifier-environment
+       vector? vector make-vector vector-length vector-ref vector-set!
+       vector-copy! vector-copy vector-append vector-fill! vector-map vector-for-each
+       list->vector vector->list string->vector vector->string
+       bytevector? bytevector make-bytevector
+       bytevector-length bytevector-u8-ref bytevector-u8-set!
+       bytevector-copy! bytevector-copy bytevector-append
+       bytevector->list list->bytevector
+       call-with-current-continuation call/cc values call-with-values
+       char? char->integer integer->char char=? char<? char>? char<=? char>=?
+       current-exception-handlers with-exception-handler
+       raise raise-continuable error
+       error-object? error-object-message error-object-irritants
+       error-object-type
+       string? string make-string string-length string-ref string-set!
+       string-copy string-copy! string-fill! string-append
+       string-map string-for-each list->string string->list
+       string=? string<? string>? string<=? string>=?
+       make-parameter with-dynamic-environment
+       read
+       make-dictionary dictionary? dictionary dictionary-has?
+       dictionary-ref dictionary-set! dictionary-delete! dictionary-size
+       dictionary-map dictionary-for-each
+       dictionary->alist alist->dictionary dictionary->plist plist->dictionary
+       make-record record? record-type record-datum
+       default-environment make-environment find-identifier set-identifier!
+       eval
+       make-ephemeron-table
+       write write-simple write-shared display))
+    (export-keywords
+     '(find-library make-library current-library)))
+  (set! eval
+        (let ((e eval))
+          (lambda (expr . lib)
+            (let ((lib (if (null? lib) (current-library) (car lib))))
+              (e expr (library-environment lib))))))
+  (make-library '(picrin user))
+  (current-library '(picrin user)))
+

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

@@ -0,0 +1,24 @@
+(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)