Merge branch 'master' into bench

Makefile

@@ -12,6 +12,7 @@ PICRIN_LIBS = \
 	piclib/picrin/macro.scm\
 	piclib/picrin/record.scm\
 	piclib/picrin/array.scm\
+	piclib/picrin/control.scm\
 	piclib/picrin/experimental/lambda.scm\
 	piclib/picrin/syntax-rules.scm\
 	piclib/picrin/test.scm
@@ -33,7 +34,7 @@ all: bin/picrin
 
 include $(sort $(wildcard contrib/*/nitro.mk))
 
-debug: CFLAGS += -O0 -g -DDEBUG=1
+debug: CFLAGS += -O0 -g
 debug: bin/picrin
 
 bin/picrin: $(PICRIN_OBJS) $(CONTRIB_OBJS) lib/libbenz.a
@@ -48,6 +49,10 @@ src/init_contrib.c:
 lib/libbenz.a: $(BENZ_OBJS)
 	$(AR) $(ARFLAGS) $@ $(BENZ_OBJS)
 
+extlib/benz/boot.o: extlib/benz/boot.c
+	cd extlib/benz; perl boot.c
+	$(CC) $(CFLAGS) -c -o $@ $<
+
 $(BENZ_OBJS) $(PICRIN_OBJS) $(CONTRIB_OBJS): extlib/benz/include/picrin.h extlib/benz/include/picrin/*.h
 
 doc: docs/*.rst docs/contrib.rst
@@ -64,15 +69,12 @@ docs/contrib.rst: $(CONTRIB_DOCS)
 run: bin/picrin
 	bin/picrin
 
-test: test-r7rs test-contribs test-nostdlib
+test: test-contribs test-nostdlib
-
-test-r7rs: bin/picrin t/r7rs-tests.scm
-	bin/picrin t/r7rs-tests.scm
 
 test-contribs: bin/picrin $(CONTRIB_TESTS)
 
 test-nostdlib:
-	$(CC) -I extlib/benz/include -D'PIC_ENABLE_LIBC=0' -D'PIC_ENABLE_FLOAT=0'-nostdlib -fPIC -shared -std=c89 -ansi -pedantic -Wall -Wextra -o lib/libbenz.so $(BENZ_SRCS)
+	$(CC) -I extlib/benz/include -D'PIC_ENABLE_LIBC=0' -D'PIC_ENABLE_FLOAT=0' -D'PIC_ENABLE_STDIO=0' -nostdlib -fPIC -shared -std=c89 -ansi -pedantic -Wall -Wextra -o lib/libbenz.so $(BENZ_SRCS) etc/libc_polyfill.c -fno-stack-protector
 	rm -f lib/libbenz.so
 
 install: all
@@ -85,4 +87,4 @@ clean:
 	rm -f $(PICRIN_OBJS)
 	rm -f $(CONTRIB_OBJS)
 
-.PHONY: all insall clean run test test-r7rs test-contribs doc $(CONTRIB_TESTS)
+.PHONY: all install clean run test test-r7rs test-contribs doc $(CONTRIB_TESTS)

contrib/03.callcc/nitro.mk

@@ -1,2 +0,0 @@
-CONTRIB_INITS += callcc
-CONTRIB_SRCS += $(wildcard contrib/03.callcc/*.c)

contrib/05.r7rs/nitro.mk

@@ -1,24 +0,0 @@
-CONTRIB_INITS += r7rs
-
-CONTRIB_SRCS += \
-	contrib/05.r7rs/src/r7rs.c\
-	contrib/05.r7rs/src/file.c\
-	contrib/05.r7rs/src/load.c\
-	contrib/05.r7rs/src/mutable-string.c\
-	contrib/05.r7rs/src/system.c\
-	contrib/05.r7rs/src/time.c
-
-CONTRIB_LIBS += \
-	contrib/05.r7rs/scheme/base.scm\
-	contrib/05.r7rs/scheme/cxr.scm\
-	contrib/05.r7rs/scheme/read.scm\
-	contrib/05.r7rs/scheme/write.scm\
-	contrib/05.r7rs/scheme/file.scm\
-	contrib/05.r7rs/scheme/case-lambda.scm\
-	contrib/05.r7rs/scheme/lazy.scm\
-	contrib/05.r7rs/scheme/eval.scm\
-	contrib/05.r7rs/scheme/inexact.scm\
-	contrib/05.r7rs/scheme/load.scm\
-	contrib/05.r7rs/scheme/process-context.scm\
-	contrib/05.r7rs/scheme/time.scm\
-	contrib/05.r7rs/scheme/r5rs.scm

contrib/05.r7rs/scheme/case-lambda.scm

@@ -1,29 +0,0 @@
-(define-library (scheme case-lambda)
-  (import (scheme base))
-
-  (define-syntax case-lambda
-    (syntax-rules ()
-      ((case-lambda (params body0 ...) ...)
-       (lambda args
-         (let ((len (length args)))
-           (letrec-syntax
-               ((cl (syntax-rules ::: ()
-                      ((cl)
-                       (error "no matching clause"))
-                      ((cl ((p :::) . body) . rest)
-                       (if (= len (length '(p :::)))
-                           (apply (lambda (p :::)
-                                    . body)
-                                  args)
-                           (cl . rest)))
-                      ((cl ((p ::: . tail) . body)
-                           . rest)
-                       (if (>= len (length '(p :::)))
-                           (apply
-                            (lambda (p ::: . tail)
-                              . body)
-                            args)
-                           (cl . rest))))))
-             (cl (params body0 ...) ...)))))))
-
-  (export case-lambda))

contrib/05.r7rs/scheme/eval.scm

@@ -1,17 +0,0 @@
-(define-library (scheme eval)
-  (import (picrin base))
-
-  (define environment
-    (let ((counter 0))
-      (lambda specs
-        (let ((library-name `(picrin @@my-environment ,counter)))
-          (set! counter (+ counter 1))
-          (eval
-           `(define-library ,library-name
-              ,@(map (lambda (spec)
-                       `(import ,spec))
-                     specs))
-           '(scheme base))
-          library-name))))
-
-  (export environment eval))

contrib/05.r7rs/scheme/lazy.scm

@@ -1,42 +0,0 @@
-;;; Appendix A. Standard Libraries Lazy
-
-(define-library (scheme lazy)
-  (import (scheme base)
-	  (picrin macro))
-
-  (define-record-type <promise>
-    (make-promise% done obj)
-    promise?
-    (done promise-done? promise-done!)
-    (obj promise-value promise-value!))
-
-  (define-syntax delay-force
-    (ir-macro-transformer
-     (lambda (form rename compare?)
-       (let ((expr (cadr form)))
-	 `(make-promise% #f (lambda () ,expr))))))
-
-  (define-syntax delay
-    (ir-macro-transformer
-     (lambda (form rename compare?)
-       (let ((expr (cadr form)))
-	 `(delay-force (make-promise% #t ,expr))))))
-
-  (define (promise-update! new old)
-    (promise-done! old (promise-done? new))
-    (promise-value! old (promise-value new)))
-
-  (define (force promise)
-    (if (promise-done? promise)
-	(promise-value promise)
-	(let ((promise* ((promise-value promise))))
-	  (unless (promise-done? promise)
-		  (promise-update! promise* promise))
-	  (force promise))))
-
-  (define (make-promise obj)
-    (if (promise? obj)
-	obj
-	(make-promise% #t obj)))
-
-  (export delay-force delay force make-promise promise?))

contrib/10.callcc/callcc.c

@@ -3,7 +3,7 @@
 struct pic_fullcont {
   jmp_buf jmp;
 
-  pic_jmpbuf *prev_jmp;
+  struct pic_cont *prev_jmp;
 
   pic_checkpoint *cp;
 
@@ -122,7 +122,7 @@ save_cont(pic_state *pic, struct pic_fullcont **c)
 
   cont = *c = pic_malloc(pic, sizeof(struct pic_fullcont));
 
-  cont->prev_jmp = pic->jmp;
+  cont->prev_jmp = pic->cc;
 
   cont->cp = pic->cp;
 
@@ -178,11 +178,10 @@ restore_cont(pic_state *pic, struct pic_fullcont *cont)
     if (&v > cont->stk_pos) native_stack_extend(pic, cont);
   }
   else {
-    if (&v > cont->stk_pos + cont->stk_len) native_stack_extend(pic, cont);
+    if (&v < cont->stk_pos + cont->stk_len) native_stack_extend(pic, cont);
   }
 
-  pic->jmp = cont->prev_jmp;
+  pic->cc = cont->prev_jmp;
-
   pic->cp = cont->cp;
 
   pic->stbase = pic_realloc(pic, pic->stbase, sizeof(pic_value) * cont->st_len);
@@ -247,7 +246,7 @@ pic_callcc_full(pic_state *pic, struct pic_proc *proc)
     struct pic_proc *c;
     struct pic_data *dat;
 
-    c = pic_make_proc(pic, cont_call, "<continuation-procedure>");
+    c = pic_make_proc(pic, cont_call);
 
     dat = pic_data_alloc(pic, &cont_type, cont);
 
@@ -271,7 +270,7 @@ pic_callcc_full_trampoline(pic_state *pic, struct pic_proc *proc)
     struct pic_proc *c;
     struct pic_data *dat;
 
-    c = pic_make_proc(pic, cont_call, "<continuation-procedure>");
+    c = pic_make_proc(pic, cont_call);
 
     dat = pic_data_alloc(pic, &cont_type, cont);
 
@@ -293,15 +292,11 @@ pic_callcc_callcc(pic_state *pic)
 }
 
 #define pic_redefun(pic, lib, name, func)       \
-  pic_set(pic, lib, name, pic_obj_value(pic_make_proc(pic, func, name)))
+  pic_set(pic, lib, name, pic_obj_value(pic_make_proc(pic, func)))
 
 void
 pic_init_callcc(pic_state *pic)
 {
-  pic_deflibrary (pic, "(picrin control)") {
-    pic_define(pic, "escape", pic_ref(pic, pic->PICRIN_BASE, "call-with-current-continuation"));
-  }
-
   pic_deflibrary (pic, "(scheme base)") {
     pic_redefun(pic, pic->PICRIN_BASE, "call-with-current-continuation", pic_callcc_callcc);
     pic_redefun(pic, pic->PICRIN_BASE, "call/cc", pic_callcc_callcc);

contrib/10.callcc/nitro.mk

@@ -0,0 +1,2 @@
+CONTRIB_INITS += callcc
+CONTRIB_SRCS += $(wildcard contrib/10.callcc/*.c)

contrib/10.optional/nitro.mk

@@ -1,7 +0,0 @@
-CONTRIB_LIBS += $(wildcard contrib/10.optional/piclib/*.scm)
-CONTRIB_TESTS += test-optional
-
-test-optional: bin/picrin
-	for test in `ls contrib/10.optional/t/*.scm`; do \
-	  bin/picrin $$test; \
-	done

contrib/10.partcont/nitro.mk

@@ -1 +0,0 @@
-CONTRIB_LIBS += $(wildcard contrib/10.partcont/piclib/*.scm)

contrib/10.pretty-print/nitro.mk

@@ -1 +0,0 @@
-CONTRIB_LIBS += contrib/10.pretty-print/pretty-print.scm

contrib/10.srfi/nitro.mk

@@ -1,9 +0,0 @@
-CONTRIB_LIBS += \
-	contrib/10.srfi/srfi/1.scm\
-	contrib/10.srfi/srfi/8.scm\
-	contrib/10.srfi/srfi/17.scm\
-	contrib/10.srfi/srfi/26.scm\
-	contrib/10.srfi/srfi/43.scm\
-	contrib/10.srfi/srfi/60.scm\
-	contrib/10.srfi/srfi/95.scm\
-	contrib/10.srfi/srfi/111.scm

contrib/20.for/nitro.mk

@@ -1,7 +0,0 @@
-CONTRIB_LIBS += $(wildcard contrib/20.for/piclib/*.scm)
-CONTRIB_TESTS += test-for
-
-test-for: bin/picrin
-	for test in `ls contrib/20.for/t/*.scm`; do \
-	  bin/picrin "$$test"; \
-	done

contrib/20.r7rs/nitro.mk

@@ -0,0 +1,31 @@
+CONTRIB_INITS += r7rs
+
+CONTRIB_SRCS += \
+	contrib/20.r7rs/src/r7rs.c\
+	contrib/20.r7rs/src/file.c\
+	contrib/20.r7rs/src/load.c\
+	contrib/20.r7rs/src/mutable-string.c\
+	contrib/20.r7rs/src/system.c\
+	contrib/20.r7rs/src/time.c
+
+CONTRIB_LIBS += \
+	contrib/20.r7rs/scheme/base.scm\
+	contrib/20.r7rs/scheme/cxr.scm\
+	contrib/20.r7rs/scheme/read.scm\
+	contrib/20.r7rs/scheme/write.scm\
+	contrib/20.r7rs/scheme/file.scm\
+	contrib/20.r7rs/scheme/case-lambda.scm\
+	contrib/20.r7rs/scheme/lazy.scm\
+	contrib/20.r7rs/scheme/eval.scm\
+	contrib/20.r7rs/scheme/inexact.scm\
+	contrib/20.r7rs/scheme/load.scm\
+	contrib/20.r7rs/scheme/process-context.scm\
+	contrib/20.r7rs/scheme/time.scm\
+	contrib/20.r7rs/scheme/r5rs.scm
+
+CONTRIB_TESTS += test-r7rs
+
+test-r7rs: bin/picrin
+	for test in `ls contrib/20.r7rs/t/*.scm`; do \
+	  bin/picrin "$$test"; \
+	done

contrib/20.r7rs/scheme/base.scm

@@ -518,4 +518,6 @@
           write-string
           write-u8
           write-bytevector
-          flush-output-port))
+          flush-output-port)
+
+  (export features))

contrib/20.r7rs/scheme/case-lambda.scm

@@ -0,0 +1,26 @@
+(define-library (scheme case-lambda)
+  (import (scheme base))
+
+  (define (length+ list)
+    (if (pair? list)
+        (+ 1 (length+ (cdr list)))
+        0))
+
+  (define-syntax case-lambda
+    (syntax-rules ()
+      ((case-lambda (params body0 ...) ...)
+       (lambda args
+         (let ((len (length args)))
+           (letrec-syntax
+               ((cl (syntax-rules ()
+                      ((cl)
+                       (error "no matching clause"))
+                      ((cl (formal . body) . rest)
+                       (if (if (list? 'formal)
+                               (= len (length 'formal))
+                               (>= len (length+ 'formal)))
+                           (apply (lambda formal . body) args)
+                           (cl . rest))))))
+             (cl (params body0 ...) ...)))))))
+
+  (export case-lambda))

contrib/20.r7rs/scheme/eval.scm

@@ -0,0 +1,15 @@
+(define-library (scheme eval)
+  (import (picrin base))
+
+  (define environment
+    (let ((counter 0))
+      (lambda specs
+        (let ((library-name `(picrin @@my-environment ,(string->symbol (number->string counter)))))
+          (set! counter (+ counter 1))
+          (eval
+           `(define-library ,library-name
+              ,@(map (lambda (spec) `(import ,spec)) specs))
+           (library-environment (find-library '(scheme base))))
+          (library-environment (find-library library-name))))))
+
+  (export environment eval))

contrib/20.r7rs/scheme/lazy.scm

@@ -0,0 +1,40 @@
+;;; Appendix A. Standard Libraries Lazy
+
+(define-library (scheme lazy)
+  (import (scheme base)
+	  (picrin macro))
+
+  (define-record-type <promise>
+      (make-promise% done value)
+      promise?
+    (done  promise-done? set-promise-done!)
+    (value promise-value set-promise-value!))
+
+  (define-syntax delay-force
+    (syntax-rules ()
+      ((_ expr)
+       (make-promise% #f (lambda () expr)))))
+
+  (define-syntax delay
+    (syntax-rules ()
+      ((_ expr)
+       (delay-force (make-promise% #t expr)))))
+
+  (define (force promise)
+    (if (promise-done? promise)
+	(promise-value promise)
+	(let ((new-promise ((promise-value promise))))
+          (set-promise-done!  promise (promise-done? new-promise))
+          (set-promise-value! promise (promise-value new-promise))
+          (force promise))))
+
+  (define (make-promise obj)
+    (if (promise? obj)
+	obj
+	(make-promise% #t obj)))
+
+  (export delay-force
+          delay
+          force
+          make-promise
+          promise?))

contrib/20.r7rs/scheme/r5rs.scm

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

contrib/20.r7rs/src/file.c

@@ -4,6 +4,8 @@
 
 #include "picrin.h"
 
+#include <stdio.h>
+
 PIC_NORETURN static void
 file_error(pic_state *pic, const char *msg)
 {
@@ -14,25 +16,6 @@ file_error(pic_state *pic, const char *msg)
   pic_raise(pic, pic_obj_value(e));
 }
 
-static pic_value
-generic_open_file(pic_state *pic, const char *fname, char *mode, short flags)
-{
-  struct pic_port *port;
-  xFILE *file;
-
-  file = xfopen(fname, mode);
-  if (! file) {
-    file_error(pic, "could not open file");
-  }
-
-  port = (struct pic_port *)pic_obj_alloc(pic, sizeof(struct pic_port), PIC_TT_PORT);
-  port->file = file;
-  port->flags = flags;
-  port->status = PIC_PORT_OPEN;
-
-  return pic_obj_value(port);
-}
-
 pic_value
 pic_file_open_input_file(pic_state *pic)
 {
@@ -41,7 +24,7 @@ pic_file_open_input_file(pic_state *pic)
 
   pic_get_args(pic, "z", &fname);
 
-  return generic_open_file(pic, fname, "r", flags);
+  return pic_obj_value(pic_open_file(pic, fname, flags));
 }
 
 pic_value
@@ -52,7 +35,7 @@ pic_file_open_binary_input_file(pic_state *pic)
 
   pic_get_args(pic, "z", &fname);
 
-  return generic_open_file(pic, fname, "rb", flags);
+  return pic_obj_value(pic_open_file(pic, fname, flags));
 }
 
 pic_value
@@ -63,7 +46,7 @@ pic_file_open_output_file(pic_state *pic)
 
   pic_get_args(pic, "z", &fname);
 
-  return generic_open_file(pic, fname, "w", flags);
+  return pic_obj_value(pic_open_file(pic, fname, flags));
 }
 
 pic_value
@@ -74,7 +57,7 @@ pic_file_open_binary_output_file(pic_state *pic)
 
   pic_get_args(pic, "z", &fname);
 
-  return generic_open_file(pic, fname, "wb", flags);
+  return pic_obj_value(pic_open_file(pic, fname, flags));
 }
 
 pic_value

contrib/20.r7rs/src/load.c

@@ -8,17 +8,8 @@ void
 pic_load(pic_state *pic, const char *filename)
 {
   struct pic_port *port;
-  xFILE *file;
 
-  file = xfopen(filename, "r");
+  port = pic_open_file(pic, filename, PIC_PORT_IN | PIC_PORT_TEXT);
-  if (file == NULL) {
-    pic_errorf(pic, "could not open file: %s", filename);
-  }
-
-  port = (struct pic_port *)pic_obj_alloc(pic, sizeof(struct pic_port), PIC_TT_PORT);
-  port->file = file;
-  port->flags = PIC_PORT_IN | PIC_PORT_TEXT;
-  port->status = PIC_PORT_OPEN;
 
   pic_load_port(pic, port);
 

contrib/20.r7rs/t/r7rs.scm

@@ -460,9 +460,9 @@
   (syntax-rules ()
     ((be-like-begin name)
      (define-syntax name
-       (syntax-rules ()
+       (syntax-rules ::: ()
-         ((name expr (... ...))
+         ((name expr :::)
-          (begin expr (... ...))))))))
+          (begin expr :::)))))))
 (be-like-begin sequence)
 (test 4 (sequence 1 2 3 4))
 

contrib/20.repl/nitro.mk

@@ -1,3 +0,0 @@
-CONTRIB_LIBS += contrib/20.repl/repl.scm
-CONTRIB_SRCS += contrib/20.repl/repl.c
-CONTRIB_INITS += repl

contrib/30.main/nitro.mk

@@ -1 +0,0 @@
-CONTRIB_LIBS += contrib/30.main/main.scm

contrib/30.optional/nitro.mk

@@ -0,0 +1,7 @@
+CONTRIB_LIBS += $(wildcard contrib/30.optional/piclib/*.scm)
+CONTRIB_TESTS += test-optional
+
+test-optional: bin/picrin
+	for test in `ls contrib/30.optional/t/*.scm`; do \
+	  bin/picrin $$test; \
+	done

contrib/30.partcont/nitro.mk

@@ -0,0 +1 @@
+CONTRIB_LIBS += $(wildcard contrib/30.partcont/piclib/*.scm)

contrib/30.pretty-print/nitro.mk

@@ -0,0 +1 @@
+CONTRIB_LIBS += contrib/30.pretty-print/pretty-print.scm

contrib/30.random/nitro.mk

@@ -1,8 +1,8 @@
 CONTRIB_INITS += random
-CONTRIB_SRCS += $(wildcard contrib/10.random/src/*.c)
+CONTRIB_SRCS += $(wildcard contrib/30.random/src/*.c)
 CONTRIB_TESTS += test-random
 
 test-random: bin/picrin
-	for test in `ls contrib/10.random/t/*.scm`; do \
+	for test in `ls contrib/30.random/t/*.scm`; do \
 	  bin/picrin $$test; \
 	done

contrib/30.readline/nitro.mk

@@ -1,7 +1,7 @@
 libedit_exists := $(shell pkg-config libedit --exists; echo $$?)
 
 ifeq ($(libedit_exists),0)
-  CONTRIB_SRCS += contrib/10.readline/src/readline.c
+  CONTRIB_SRCS += contrib/30.readline/src/readline.c
   CONTRIB_INITS += readline
   CONTRIB_TESTS += test-readline
   LDFLAGS += `pkg-config libedit --libs`
@@ -11,6 +11,6 @@ contrib/src/readline.o: contrib/src/readline.c
 	$(CC) $(CFLAGS) -o $@ $< `pkg-config libedit --cflags`
 
 test-readline: bin/picrin
-	for test in `ls contrib/10.readline/t/*.scm`; do \
+	for test in `ls contrib/30.readline/t/*.scm`; do \
 	  bin/picrin $$test; \
 	done

contrib/30.regexp/nitro.mk

@@ -1,8 +1,8 @@
-CONTRIB_SRCS += contrib/10.regexp/src/regexp.c
+CONTRIB_SRCS += contrib/30.regexp/src/regexp.c
 CONTRIB_INITS += regexp
 CONTRIB_TESTS += test-regexp
 
 test-regexp: bin/picrin
-	for test in `ls contrib/10.regexp/t/*.scm`; do \
+	for test in `ls contrib/30.regexp/t/*.scm`; do \
 	  bin/picrin $$test; \
 	done

contrib/40.class/nitro.mk

@@ -1 +0,0 @@
-CONTRIB_LIBS += $(wildcard contrib/40.class/piclib/picrin/*.scm)

contrib/40.srfi/docs/doc.rst

@@ -36,6 +36,11 @@ SRFI libraries
 
   Sorting and Marging.
 
+- `(srfi 106)
+  <http://srfi.schemers.org/srfi-106/>`_
+
+  Basic socket interface
+
 - `(srfi 111)
   <http://srfi.schemers.org/srfi-111/>`_
 

contrib/40.srfi/examples/106/simple-echo-client.scm

@@ -0,0 +1,29 @@
+; A R7RS port of "simple echo client" example in SRFI 106
+;
+; Copyright (C) Takashi Kato (2012). All Rights Reserved.
+;
+; Permission is hereby granted, free of charge, to any person obtaining a copy
+; of this software and associated documentation files (the "Software"), to deal
+; in the Software without restriction, including without limitation the rights
+; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+; copies of the Software, and to permit persons to whom the Software is
+; furnished to do so, subject to the following conditions:
+;
+; The above copyright notice and this permission notice shall be included in
+; all copies or substantial portions of the Software.
+;
+; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+; SOFTWARE.
+
+(import (scheme base)
+        (srfi 106))
+
+(define echo-client-socket (make-client-socket "localhost" "5000"))
+
+(socket-send echo-client-socket (string->utf8 "hello\r\n"))
+(socket-recv echo-client-socket (string-length "hello\r\n"))

contrib/40.srfi/examples/106/simple-echo-server.scm

@@ -0,0 +1,47 @@
+; A R7RS port of "simple echo server" example in SRFI 106
+;
+; Copyright (C) Takashi Kato (2012). All Rights Reserved.
+;
+; Permission is hereby granted, free of charge, to any person obtaining a copy
+; of this software and associated documentation files (the "Software"), to deal
+; in the Software without restriction, including without limitation the rights
+; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+; copies of the Software, and to permit persons to whom the Software is
+; furnished to do so, subject to the following conditions:
+;
+; The above copyright notice and this permission notice shall be included in
+; all copies or substantial portions of the Software.
+;
+; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+; SOFTWARE.
+
+(import (scheme base)
+        (srfi 106))
+
+(define echo-server-socket (make-server-socket "5000"))
+
+(define (server-run)
+  (define (get-line-from-binary-port bin)
+    (utf8->string
+      (call-with-port (open-output-bytevector)
+        (lambda (out)
+          (let loop ((b (read-u8 bin)))
+            (case b
+              ((10) (get-output-bytevector out))
+              ((13) (loop (read-u8 bin)))
+              (else (write-u8 b out) (loop (read-u8 bin)))))))))
+
+  (call-with-socket (socket-accept echo-server-socket)
+    (lambda (sock)
+      (let ((in (socket-input-port sock))
+            (out (socket-output-port sock)))
+        (let loop ((r (get-line-from-binary-port in)))
+          (write-bytevector (string->utf8 (string-append r "\r\n")) out)
+          (loop (get-line-from-binary-port in)))))))
+
+(server-run)

contrib/40.srfi/nitro.mk

@@ -0,0 +1,18 @@
+CONTRIB_INITS += socket
+CONTRIB_LIBS += \
+	contrib/40.srfi/srfi/1.scm\
+	contrib/40.srfi/srfi/8.scm\
+	contrib/40.srfi/srfi/17.scm\
+	contrib/40.srfi/srfi/26.scm\
+	contrib/40.srfi/srfi/43.scm\
+	contrib/40.srfi/srfi/60.scm\
+	contrib/40.srfi/srfi/95.scm\
+	contrib/40.srfi/srfi/106.scm\
+	contrib/40.srfi/srfi/111.scm
+CONTRIB_SRCS += contrib/40.srfi/src/106.c
+CONTRIB_TESTS += test-srfi
+
+test-srfi: bin/picrin
+	for test in `ls contrib/40.srfi/t/*.scm`; do \
+	  bin/picrin "$$test"; \
+	done

contrib/40.srfi/src/106.c

@@ -0,0 +1,521 @@
+#include "picrin.h"
+
+#include <errno.h>
+#include <netdb.h>
+#include <netinet/in.h>
+#include <stdlib.h>
+#include <string.h>
+#include <sys/param.h>
+#include <sys/socket.h>
+#include <unistd.h>
+
+#ifndef EWOULDBLOCK
+#define EWOULDBLOCK EAGAIN
+#endif
+
+struct pic_socket_t {
+  int fd;
+};
+
+PIC_INLINE void
+socket_close(struct pic_socket_t *sock)
+{
+  if (sock != NULL && sock->fd != -1) {
+    close(sock->fd);
+    sock->fd = -1;
+  }
+}
+
+PIC_INLINE void
+ensure_socket_is_open(pic_state *pic, struct pic_socket_t *sock)
+{
+  if (sock != NULL && sock->fd == -1) {
+    pic_errorf(pic, "the socket is already closed");
+  }
+}
+
+static void
+socket_dtor(pic_state *pic, void *data)
+{
+  struct pic_socket_t *sock;
+
+  sock = data;
+  socket_close(sock);
+  pic_free(pic, data);
+}
+
+static const pic_data_type socket_type = { "socket", socket_dtor, NULL };
+
+#define pic_socket_p(o) (pic_data_type_p((o), &socket_type))
+#define pic_socket_data_ptr(o) ((struct pic_socket_t *)pic_data_ptr(o)->data)
+
+PIC_INLINE void
+validate_socket_object(pic_state *pic, pic_value v)
+{
+  if (! pic_socket_p(v)) {
+    pic_errorf(pic, "~s is not a socket object", v);
+  }
+}
+
+static pic_value
+pic_socket_socket_p(pic_state *pic)
+{
+  pic_value obj;
+
+  pic_get_args(pic, "o", &obj);
+  return pic_bool_value(pic_socket_p(obj));
+}
+
+static pic_value
+pic_socket_make_socket(pic_state *pic)
+{
+  pic_value n, s;
+  const char *node, *service;
+  int family, socktype, flags, protocol;
+  int result;
+  struct addrinfo hints, *ai, *it;
+  struct pic_socket_t *sock;
+
+  pic_get_args(pic, "ooiiii", &n, &s, &family, &socktype, &flags, &protocol);
+
+  node = service = NULL;
+  if (pic_str_p(n)) {
+    node = pic_str_cstr(pic, pic_str_ptr(n));
+  }
+  if (pic_str_p(s)) {
+    service = pic_str_cstr(pic, pic_str_ptr(s));
+  }
+
+  sock = pic_malloc(pic, sizeof(struct pic_socket_t));
+  sock->fd = -1;
+
+  memset(&hints, 0, sizeof(struct addrinfo));
+  hints.ai_family = family;
+  hints.ai_socktype = socktype;
+  hints.ai_flags = flags;
+  hints.ai_protocol = protocol;
+
+  errno = 0;
+
+  do {
+    result = getaddrinfo(node, service, &hints, &ai);
+  } while (result == EAI_AGAIN);
+  if (result) {
+    if (result == EAI_SYSTEM) {
+      pic_errorf(pic, "%s", strerror(errno));
+    }
+    pic_errorf(pic, "%s", gai_strerror(result));
+  }
+
+  for (it = ai; it != NULL; it = it->ai_next) {
+    int fd;
+
+    fd = socket(it->ai_family, it->ai_socktype, it->ai_protocol);
+    if (fd == -1) {
+      continue;
+    }
+
+    if (it->ai_flags & AI_PASSIVE) {
+      int yes = 1;
+      if (setsockopt(fd, SOL_SOCKET, SO_REUSEADDR, &yes, sizeof(int)) == 0 &&
+          bind(fd, it->ai_addr, it->ai_addrlen) == 0) {
+        if (it->ai_socktype == SOCK_STREAM ||
+            it->ai_socktype == SOCK_SEQPACKET) {
+          /* TODO: Backlog should be configurable. */
+          if (listen(fd, 8) == 0) {
+              sock->fd = fd;
+              break;
+          }
+        } else {
+          sock->fd = fd;
+          break;
+        }
+      }
+    } else {
+      if (connect(fd, it->ai_addr, it->ai_addrlen) == 0) {
+        sock->fd = fd;
+        break;
+      }
+    }
+
+    close(fd);
+  }
+
+  freeaddrinfo(ai);
+
+  if (sock->fd == -1) {
+    pic_errorf(pic, "%s", strerror(errno));
+  }
+
+  return pic_obj_value(pic_data_alloc(pic, &socket_type, sock));
+}
+
+static pic_value
+pic_socket_socket_accept(pic_state *pic)
+{
+  pic_value obj;
+  int fd = -1;
+  struct pic_socket_t *sock, *new_sock;
+
+  pic_get_args(pic, "o", &obj);
+  validate_socket_object(pic, obj);
+
+  sock = pic_socket_data_ptr(obj);
+  ensure_socket_is_open(pic, sock);
+
+  errno = 0;
+  while (1) {
+    struct sockaddr_storage addr;
+    socklen_t addrlen = sizeof(struct sockaddr_storage);
+
+    fd = accept(sock->fd, (struct sockaddr *)&addr, &addrlen);
+
+    if (fd < 0) {
+      if (errno == EINTR) {
+        continue;
+      } else if (errno == EAGAIN || errno == EWOULDBLOCK) {
+        continue;
+      } else {
+        pic_errorf(pic, "%s", strerror(errno));
+      }
+    } else {
+      break;
+    }
+  }
+
+  new_sock = pic_malloc(pic, sizeof(struct pic_socket_t));
+  new_sock->fd = fd;
+  return pic_obj_value(pic_data_alloc(pic, &socket_type, new_sock));
+}
+
+static pic_value
+pic_socket_socket_send(pic_state *pic)
+{
+  pic_value obj;
+  struct pic_blob *bv;
+  const unsigned char *cursor;
+  int flags = 0;
+  size_t remain, written;
+  struct pic_socket_t *sock;
+
+  pic_get_args(pic, "ob|i", &obj, &bv, &flags);
+  validate_socket_object(pic, obj);
+
+  sock = pic_socket_data_ptr(obj);
+  ensure_socket_is_open(pic, sock);
+
+  cursor = bv->data;
+  remain = bv->len;
+  written = 0;
+  errno = 0;
+  while (remain > 0) {
+    ssize_t len = send(sock->fd, cursor, remain, flags);
+    if (len < 0) {
+      if (errno == EINTR) {
+        continue;
+      } else if (errno == EAGAIN || errno == EWOULDBLOCK) {
+        break;
+      } else {
+        pic_errorf(pic, "%s", strerror(errno));
+      }
+    }
+    cursor += len;
+    remain -= len;
+    written += len;
+  }
+
+  return pic_int_value(written);
+}
+
+static pic_value
+pic_socket_socket_recv(pic_state *pic)
+{
+  pic_value obj;
+  struct pic_blob *bv;
+  void *buf;
+  int size;
+  int flags = 0;
+  ssize_t len;
+  struct pic_socket_t *sock;
+
+  pic_get_args(pic, "oi|i", &obj, &size, &flags);
+  validate_socket_object(pic, obj);
+  if (size < 0) {
+    pic_errorf(pic, "size must not be negative");
+  }
+
+  sock = pic_socket_data_ptr(obj);
+  ensure_socket_is_open(pic, sock);
+
+  buf = malloc(size);
+  if (buf == NULL && size > 0) {
+    /* XXX: Is it really OK? */
+    pic_panic(pic, "memory exhausted");
+  }
+
+  errno = 0;
+  do {
+    len = recv(sock->fd, buf, size, flags);
+  } while (len < 0 && (errno == EINTR || errno == EAGAIN || errno == EWOULDBLOCK));
+
+  if (len < 0) {
+    free(buf);
+    pic_errorf(pic, "%s", strerror(errno));
+  }
+
+  bv = pic_make_blob(pic, len);
+  memcpy(bv->data, buf, len);
+  free(buf);
+
+  return pic_obj_value(bv);
+}
+
+static pic_value
+pic_socket_socket_shutdown(pic_state *pic)
+{
+  pic_value obj;
+  int how;
+  struct pic_socket_t *sock;
+
+  pic_get_args(pic, "oi", &obj, &how);
+  validate_socket_object(pic, obj);
+
+  sock = pic_socket_data_ptr(obj);
+  if (sock->fd != -1) {
+    shutdown(sock->fd, how);
+    sock->fd = -1;
+  }
+
+  return pic_undef_value();
+}
+
+static pic_value
+pic_socket_socket_close(pic_state *pic)
+{
+  pic_value obj;
+
+  pic_get_args(pic, "o", &obj);
+  validate_socket_object(pic, obj);
+
+  socket_close(pic_socket_data_ptr(obj));
+
+  return pic_undef_value();
+}
+
+static int
+xf_socket_read(pic_state PIC_UNUSED(*pic), void *cookie, char *ptr, int size)
+{
+  struct pic_socket_t *sock;
+
+  sock = (struct pic_socket_t *)cookie;
+
+  return recv(sock->fd, ptr, size, 0);
+}
+
+static int
+xf_socket_write(pic_state PIC_UNUSED(*pic), void *cookie, const char *ptr, int size)
+{
+  struct pic_socket_t *sock;
+
+  sock = (struct pic_socket_t *)cookie;
+
+  return send(sock->fd, ptr, size, 0);
+}
+
+static long
+xf_socket_seek(pic_state PIC_UNUSED(*pic), void PIC_UNUSED(*cookie), long PIC_UNUSED(pos), int PIC_UNUSED(whence))
+{
+  errno = EBADF;
+  return -1;
+}
+
+static int
+xf_socket_close(pic_state PIC_UNUSED(*pic), void PIC_UNUSED(*cookie))
+{
+  return 0;
+}
+
+static struct pic_port *
+make_socket_port(pic_state *pic, struct pic_socket_t *sock, short dir)
+{
+  struct pic_port *port;
+
+  port = (struct pic_port *)pic_obj_alloc(pic, sizeof(struct pic_port), PIC_TT_PORT);
+  port->file = xfunopen(pic, sock, xf_socket_read, xf_socket_write, xf_socket_seek, xf_socket_close);
+  port->flags = dir | PIC_PORT_BINARY | PIC_PORT_OPEN;
+  return port;
+}
+
+static pic_value
+pic_socket_socket_input_port(pic_state *pic)
+{
+  pic_value obj;
+  struct pic_socket_t *sock;
+
+  pic_get_args(pic, "o", &obj);
+  validate_socket_object(pic, obj);
+
+  sock = pic_socket_data_ptr(obj);
+  ensure_socket_is_open(pic, sock);
+
+  return pic_obj_value(make_socket_port(pic, sock, PIC_PORT_IN));
+}
+
+static pic_value
+pic_socket_socket_output_port(pic_state *pic)
+{
+  pic_value obj;
+  struct pic_socket_t *sock;
+
+  pic_get_args(pic, "o", &obj);
+  validate_socket_object(pic, obj);
+
+  sock = pic_socket_data_ptr(obj);
+  ensure_socket_is_open(pic, sock);
+
+  return pic_obj_value(make_socket_port(pic, sock, PIC_PORT_OUT));
+}
+
+static pic_value
+pic_socket_call_with_socket(pic_state *pic)
+{
+  pic_value obj, result;
+  struct pic_proc *proc;
+  struct pic_socket_t *sock;
+
+  pic_get_args(pic, "ol", &obj, &proc);
+  validate_socket_object(pic, obj);
+
+  sock = pic_socket_data_ptr(obj);
+  ensure_socket_is_open(pic, sock);
+
+  result = pic_apply1(pic, proc, obj);
+
+  socket_close(sock);
+
+  return result;
+}
+
+void
+pic_init_socket(pic_state *pic)
+{
+  pic_deflibrary (pic, "(srfi 106)") {
+    pic_defun_(pic, "socket?", pic_socket_socket_p);
+    pic_defun_(pic, "make-socket", pic_socket_make_socket);
+    pic_defun_(pic, "socket-accept", pic_socket_socket_accept);
+    pic_defun_(pic, "socket-send", pic_socket_socket_send);
+    pic_defun_(pic, "socket-recv", pic_socket_socket_recv);
+    pic_defun_(pic, "socket-shutdown", pic_socket_socket_shutdown);
+    pic_defun_(pic, "socket-close", pic_socket_socket_close);
+    pic_defun_(pic, "socket-input-port", pic_socket_socket_input_port);
+    pic_defun_(pic, "socket-output-port", pic_socket_socket_output_port);
+    pic_defun_(pic, "call-with-socket", pic_socket_call_with_socket);
+
+#ifdef AF_INET
+    pic_define_(pic, "*af-inet*", pic_int_value(AF_INET));
+#else
+    pic_define_(pic, "*af-inet*", pic_false_value());
+#endif
+#ifdef AF_INET6
+    pic_define_(pic, "*af-inet6*", pic_int_value(AF_INET6));
+#else
+    pic_define_(pic, "*af-inet6*", pic_false_value());
+#endif
+#ifdef AF_UNSPEC
+    pic_define_(pic, "*af-unspec*", pic_int_value(AF_UNSPEC));
+#else
+    pic_define_(pic, "*af-unspec*", pic_false_value());
+#endif
+
+#ifdef SOCK_STREAM
+    pic_define_(pic, "*sock-stream*", pic_int_value(SOCK_STREAM));
+#else
+    pic_define_(pic, "*sock-stream*", pic_false_value());
+#endif
+#ifdef SOCK_DGRAM
+    pic_define_(pic, "*sock-dgram*", pic_int_value(SOCK_DGRAM));
+#else
+    pic_define_(pic, "*sock-dgram*", pic_false_value());
+#endif
+
+#ifdef AI_CANONNAME
+    pic_define_(pic, "*ai-canonname*", pic_int_value(AI_CANONNAME));
+#else
+    pic_define_(pic, "*ai-canonname*", pic_false_value());
+#endif
+#ifdef AI_NUMERICHOST
+    pic_define_(pic, "*ai-numerichost*", pic_int_value(AI_NUMERICHOST));
+#else
+    pic_define_(pic, "*ai-numerichost*", pic_false_value());
+#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(AI_V4MAPPED));
+#else
+    pic_define_(pic, "*ai-v4mapped*", pic_false_value());
+#endif
+#if defined(AI_ALL) && !defined(BSD)
+    pic_define_(pic, "*ai-all*", pic_int_value(AI_ALL));
+#else
+    pic_define_(pic, "*ai-all*", pic_false_value());
+#endif
+#ifdef AI_ADDRCONFIG
+    pic_define_(pic, "*ai-addrconfig*", pic_int_value(AI_ADDRCONFIG));
+#else
+    pic_define_(pic, "*ai-addrconfig*", pic_false_value());
+#endif
+#ifdef AI_PASSIVE
+    pic_define_(pic, "*ai-passive*", pic_int_value(AI_PASSIVE));
+#else
+    pic_define_(pic, "*ai-passive*", pic_false_value());
+#endif
+
+#ifdef IPPROTO_IP
+    pic_define_(pic, "*ipproto-ip*", pic_int_value(IPPROTO_IP));
+#else
+    pic_define_(pic, "*ipproto-ip*", pic_false_value());
+#endif
+#ifdef IPPROTO_TCP
+    pic_define_(pic, "*ipproto-tcp*", pic_int_value(IPPROTO_TCP));
+#else
+    pic_define_(pic, "*ipproto-tcp*", pic_false_value());
+#endif
+#ifdef IPPROTO_UDP
+    pic_define_(pic, "*ipproto-udp*", pic_int_value(IPPROTO_UDP));
+#else
+    pic_define_(pic, "*ipproto-udp*", pic_false_value());
+#endif
+
+#ifdef MSG_PEEK
+    pic_define_(pic, "*msg-peek*", pic_int_value(MSG_PEEK));
+#else
+    pic_define_(pic, "*msg-peek*", pic_false_value());
+#endif
+#ifdef MSG_OOB
+    pic_define_(pic, "*msg-oob*", pic_int_value(MSG_OOB));
+#else
+    pic_define_(pic, "*msg-oob*", pic_false_value());
+#endif
+#ifdef MSG_WAITALL
+    pic_define_(pic, "*msg-waitall*", pic_int_value(MSG_WAITALL));
+#else
+    pic_define_(pic, "*msg-waitall*", pic_false_value());
+#endif
+
+#ifdef SHUT_RD
+    pic_define_(pic, "*shut-rd*", pic_int_value(SHUT_RD));
+#else
+    pic_define_(pic, "*shut-rd*", pic_false_value());
+#endif
+#ifdef SHUT_WR
+    pic_define_(pic, "*shut-wr*", pic_int_value(SHUT_WR));
+#else
+    pic_define_(pic, "*shut-wr*", pic_false_value());
+#endif
+#ifdef SHUT_RDWR
+    pic_define_(pic, "*shut-rdwr*", pic_int_value(SHUT_RDWR));
+#else
+    pic_define_(pic, "*shut-rdwr*", pic_false_value());
+#endif
+  }
+}

contrib/40.srfi/srfi/106.scm

@@ -0,0 +1,168 @@
+(define-library (srfi 106)
+  (import (scheme base)
+          (srfi 60)
+          (picrin optional))
+
+  ; TODO: Define assq-ref anywhere else.
+  (define (assq-ref alist key . opt)
+    (cond
+      ((assq key alist) => cdr)
+      (else (if (null? opt) #f (car opt)))))
+
+  (define (socket-merge-flags flag . flags)
+    (if (null? flags)
+      flag
+      (apply socket-merge-flags (logior (or flag 0) (or (car flags) 0))
+             (cdr flags))))
+
+  (define (socket-purge-flags base-flag . flags)
+    (if (null? flags)
+      base-flag
+      (apply socket-purge-flags (logxor (or base-flag 0) (or (car flags) 0))
+             (cdr flags))))
+
+  (define (make-client-socket node service . args)
+    (let-optionals* args ((family *af-inet*)
+                          (type *sock-stream*)
+                          (flags (socket-merge-flags *ai-v4mapped*
+                                                     *ai-addrconfig*))
+                          (protocol *ipproto-ip*))
+      (make-socket node service family type flags protocol)))
+
+  (define (make-server-socket service . args)
+    (let-optionals* args ((family *af-inet*)
+                          (type *sock-stream*)
+                          (flags *ai-passive*)
+                          (protocol *ipproto-ip*))
+      (make-socket #f service family type flags protocol)))
+
+  (define %address-family `((inet .   ,*af-inet*)
+                            (inet6 .  ,*af-inet6*)
+                            (unspec . ,*af-unspec*)))
+
+  (define %socket-domain `((stream .   ,*sock-stream*)
+                           (datagram . ,*sock-dgram*)))
+
+  (define %address-info `((canoname .    ,*ai-canonname*)
+                          (numerichost . ,*ai-numerichost*)
+                          (v4mapped .    ,*ai-v4mapped*)
+                          (all .         ,*ai-all*)
+                          (addrconfig .  ,*ai-addrconfig*)))
+
+  (define %ip-protocol `((ip .  ,*ipproto-ip*)
+                         (tcp . ,*ipproto-tcp*)
+                         (udp . ,*ipproto-udp*)))
+
+  (define %message-types `((none .      0)
+                           (peek .     ,*msg-peek*)
+                           (oob .      ,*msg-oob*)
+                           (wait-all . ,*msg-waitall*)))
+
+  (define-syntax address-family
+    (syntax-rules ()
+      ((_ name)
+       (assq-ref %address-family 'name))))
+
+  (define-syntax socket-domain
+    (syntax-rules ()
+      ((_ name)
+       (assq-ref %socket-domain 'name))))
+
+  (define-syntax address-info
+    (syntax-rules ()
+      ((_ names ...)
+       (apply socket-merge-flags
+              (map (lambda (name) (assq-ref %address-info name))
+                   '(names ...))))))
+
+  (define-syntax ip-protocol
+    (syntax-rules ()
+      ((_ name)
+       (assq-ref %ip-protocol 'name))))
+
+  (define-syntax message-type
+    (syntax-rules ()
+      ((_ names ...)
+       (apply socket-merge-flags
+              (map (lambda (name) (assq-ref %message-types name))
+                   '(names ...))))))
+
+  (define (%shutdown-method names)
+    (define (state->method state)
+      (case state
+        ((read) *shut-rd*)
+        ((write) *shut-wr*)
+        ((read-write) *shut-rdwr*)
+        (else #f)))
+    (let loop ((names names)
+               (state 'none))
+      (cond
+        ((null? names) (state->method state))
+        ((eq? (car names) 'read)
+         (loop (cdr names)
+               (cond
+                 ((eq? state 'none) 'read)
+                 ((eq? state 'write) 'read-write)
+                 (else state))))
+        ((eq? (car names) 'write)
+         (loop (cdr names)
+               (cond
+                 ((eq? state 'none) 'write)
+                 ((eq? state 'read) 'read-write)
+                 (else state))))
+        (else (loop (cdr names) 'other)))))
+
+  (define-syntax shutdown-method
+    (syntax-rules ()
+      ((_ names ...)
+       (%shutdown-method '(names ...)))))
+
+  ;; Constructors and predicate
+  (export make-client-socket
+          make-server-socket
+          socket?)
+
+  ;; Socket operations
+  (export socket-accept
+          socket-send
+          socket-recv
+          socket-shutdown
+          socket-close)
+
+  ;; Port conversion
+  (export socket-input-port
+          socket-output-port)
+
+  ;; Control feature
+  (export call-with-socket)
+
+  ;; Flag operations
+  (export address-family
+          socket-domain
+          address-info
+          ip-protocol
+          message-type
+          shutdown-method
+          socket-merge-flags
+          socket-purge-flags)
+
+  ;; Constant values
+  (export *af-inet*
+          *af-inet6*
+          *af-unspec*)
+  (export *sock-stream*
+          *sock-dgram*)
+  (export *ai-canonname*
+          *ai-numerichost*
+          *ai-v4mapped*
+          *ai-all*
+          *ai-addrconfig*)
+  (export *ipproto-ip*
+          *ipproto-tcp*
+          *ipproto-udp*)
+  (export *msg-peek*
+          *msg-oob*
+          *msg-waitall*)
+  (export *shut-rd*
+          *shut-wr*
+          *shut-rdwr*))

contrib/40.srfi/t/106.scm

@@ -0,0 +1,72 @@
+(import (scheme base)
+        (srfi 106)
+        (picrin test))
+
+; The number 9600 has no meaning. I just borrowed from Rust.
+(define *test-port* 9600)
+(define (next-test-port)
+  (set! *test-port* (+ *test-port* 1))
+  (number->string *test-port*))
+
+(test #f (socket? '()))
+(let* ((port (next-test-port))
+       (server (make-server-socket port))
+       (client (make-client-socket "127.0.0.1" port)))
+  (test #t (socket? server))
+  (test #t (socket? client)))
+
+(let* ((port (next-test-port))
+       (server (make-server-socket port))
+       (client (make-client-socket "127.0.0.1" port)))
+  (test #t (socket? (socket-accept server))))
+
+(let* ((port (next-test-port))
+       (server (make-server-socket port))
+       (client (make-client-socket "127.0.0.1" port))
+       (conn (socket-accept server)))
+  (test 5 (socket-send conn (string->utf8 "hello")))
+  (test "hello" (utf8->string (socket-recv client 5))))
+
+(let* ((port (next-test-port))
+       (sock (make-server-socket port)))
+  (test #t (port? (socket-input-port sock)))
+  (test #t (port? (socket-output-port sock))))
+
+(test *ai-canonname* (socket-merge-flags *ai-canonname*))
+(test *ai-canonname* (socket-merge-flags *ai-canonname* *ai-canonname*))
+(test *ai-canonname* (socket-purge-flags *ai-canonname*))
+(test *ai-canonname* (socket-purge-flags (socket-merge-flags *ai-canonname* *ai-all*)
+                                         *ai-all*))
+(test *ai-canonname* (socket-purge-flags (socket-merge-flags *ai-all* *ai-canonname*)
+                                         *ai-all*))
+
+(test *af-inet* (address-family inet))
+(test *af-inet6* (address-family inet6))
+(test *af-unspec* (address-family unspec))
+
+(test *sock-stream* (socket-domain stream))
+(test *sock-dgram* (socket-domain datagram))
+
+(test *ai-canonname* (address-info canoname))
+(test *ai-numerichost* (address-info numerichost))
+(test *ai-v4mapped* (address-info v4mapped))
+(test *ai-all* (address-info all))
+(test *ai-addrconfig* (address-info addrconfig))
+(test (socket-merge-flags *ai-v4mapped* *ai-addrconfig*)
+      (address-info v4mapped addrconfig))
+
+(test *ipproto-ip* (ip-protocol ip))
+(test *ipproto-tcp* (ip-protocol tcp))
+(test *ipproto-udp* (ip-protocol udp))
+
+(test 0 (message-type none))
+(test *msg-peek* (message-type peek))
+(test *msg-oob* (message-type oob))
+(test *msg-waitall* (message-type wait-all))
+(test (socket-merge-flags *msg-oob* *msg-waitall*)
+      (message-type oob wait-all))
+
+(test *shut-rd* (shutdown-method read))
+(test *shut-wr* (shutdown-method write))
+(test *shut-rdwr* (shutdown-method read write))
+(test *shut-rdwr* (shutdown-method write read))

contrib/50.class/nitro.mk

@@ -0,0 +1 @@
+CONTRIB_LIBS += $(wildcard contrib/50.class/piclib/picrin/*.scm)

contrib/50.for/nitro.mk

@@ -0,0 +1,7 @@
+CONTRIB_LIBS += $(wildcard contrib/50.for/piclib/*.scm)
+CONTRIB_TESTS += test-for
+
+test-for: bin/picrin
+	for test in `ls contrib/50.for/t/*.scm`; do \
+	  bin/picrin "$$test"; \
+	done

contrib/50.protocol/nitro.mk

@@ -1 +0,0 @@
-CONTRIB_LIBS += $(wildcard contrib/50.protocol/piclib/picrin/*.scm)

contrib/60.repl/nitro.mk

@@ -0,0 +1,3 @@
+CONTRIB_LIBS += contrib/60.repl/repl.scm
+CONTRIB_SRCS += contrib/60.repl/repl.c
+CONTRIB_INITS += repl

contrib/60.repl/repl.scm

@@ -2,7 +2,8 @@
   (import (scheme base)
           (scheme read)
           (scheme write)
-          (scheme eval))
+          (scheme eval)
+          (picrin base))
 
   (cond-expand
    ((library (picrin readline))
@@ -18,21 +19,24 @@
       (define (add-history str)
         #f))))
 
-  (eval
+  (define user-env (library-environment (find-library '(picrin user))))
-   '(import (scheme base)
+
-            (scheme load)
+  (begin
-            (scheme process-context)
+    (current-library (find-library '(picrin user)))
-            (scheme read)
+    (eval
-            (scheme write)
+     '(import (scheme base)
-            (scheme file)
+              (scheme load)
-            (scheme inexact)
+              (scheme process-context)
-            (scheme cxr)
+              (scheme read)
-            (scheme lazy)
+              (scheme write)
-            (scheme time)
+              (scheme file)
-            (picrin macro)
+              (scheme inexact)
-            (picrin array)
+              (scheme cxr)
-            (picrin library))
+              (scheme lazy)
-   '(picrin user))
+              (scheme time)
+              (picrin macro))
+     user-env)
+    (current-library (find-library '(picrin repl))))
 
   (define (repl)
     (let loop ((buf ""))
@@ -62,7 +66,7 @@
                       (lambda (port)
                         (let next ((expr (read port)))
                           (unless (eof-object? expr)
-                            (write (eval expr '(picrin user)))
+                            (write (eval expr user-env))
                             (newline)
                             (set! str "")
                             (next (read port))))))))))

contrib/70.main/main.scm

@@ -5,6 +5,7 @@
           (scheme process-context)
           (scheme load)
           (scheme eval)
+          (picrin base)
           (picrin repl))
 
   (define (print-help)
@@ -40,7 +41,7 @@
       (lambda (in)
         (let loop ((expr (read in)))
           (unless (eof-object? expr)
-            (eval expr '(picrin user))
+            (eval expr (library-environment (find-library '(picrin user))))
             (loop (read in)))))))
 
   (define (main)

contrib/70.main/nitro.mk

@@ -0,0 +1 @@
+CONTRIB_LIBS += contrib/70.main/main.scm

contrib/80.protocol/nitro.mk

@@ -0,0 +1 @@
+CONTRIB_LIBS += $(wildcard contrib/80.protocol/piclib/picrin/*.scm)

docs/capi.rst

@@ -8,12 +8,12 @@ Extension Library
 
 If you want to create a contribution library with C, the only thing you need to do is make a directory under contrib/. Below is a sample code of extension library.
 
-* contrib/add/CMakeLists.txt
+* contrib/add/nitro.mk
 
 .. sourcecode:: cmake
 
-  list(APPEND PICRIN_CONTRIB_INITS add)
+  CONTRIB_INITS += add
-  list(APPEND PICRIN_CONTRIB_SOURCES ${PROJECT_SOURCE_DIR}/contrib/add/add.c)
+  CONTRIB_SRCS  += contrib/add/add.c
 
 * contrib/add/add.c
 

etc/libc_polyfill.c

@@ -0,0 +1,20 @@
+void abort()
+{
+  while (1);
+}
+
+typedef char jmp_buf[1];
+
+int setjmp(jmp_buf buf)
+{
+  (void)buf;
+  return 0;
+}
+
+void longjmp(jmp_buf buf, int r)
+{
+  (void)buf;
+  (void)r;
+  while (1);
+}
+

etc/mkloader.pl

@@ -41,7 +41,9 @@ pic_load_piclib(pic_state *pic)
 EOL
 
 foreach my $file (@ARGV) {
-    print "  pic_try {\n";
+    print <<EOL;
+  pic_try {
+EOL
     my $var = &escape_v($file);
     my $basename = basename($file);
     my $dirname = basename(dirname($file));
@@ -50,9 +52,8 @@ foreach my $file (@ARGV) {
   }
   pic_catch {
     /* error! */
-    fputs("fatal error: failure in loading $dirname/$basename\\n", stderr);
+    xfputs(pic, "fatal error: failure in loading $dirname/$basename\\n", xstderr);
-    fputs(pic_errmsg(pic), stderr);
+    pic_raise(pic, pic->err);
-    abort();
   }
 EOL
 }

extlib/benz/README.md

@@ -19,7 +19,7 @@ main(int argc, char *argv[])
   pic_state *pic;
   pic_value expr;
 
-  pic = pic_open(argc, argv, NULL);
+  pic = pic_open(pic_default_allocf, NULL);
 
   while (1) {
     printf("> ");
@@ -61,7 +61,7 @@ pic_value factorial(pic_state *pic) {
 int
 main(int argc, char *argv[])
 {
-  pic_state *pic = pic_open(argc, argv, NULL);
+  pic_state *pic = pic_open(pic_default_allocf, NULL);
 
   pic_defun(pic, "fact", factorial); /* define fact procedure */
 

extlib/benz/bool.c

@@ -4,89 +4,84 @@
 
 #include "picrin.h"
 
-static bool
+KHASH_DECLARE(m, void *, int)
-str_equal_p(pic_state *pic, struct pic_string *str1, struct pic_string *str2)
+KHASH_DEFINE2(m, void *, int, 0, kh_ptr_hash_func, kh_ptr_hash_equal)
-{
-  return pic_str_cmp(pic, str1, str2) == 0;
-}
 
 static bool
-blob_equal_p(struct pic_blob *blob1, struct pic_blob *blob2)
+internal_equal_p(pic_state *pic, pic_value x, pic_value y, size_t depth, khash_t(m) *h)
-{
-  size_t i;
-
-  if (blob1->len != blob2->len) {
-    return false;
-  }
-  for (i = 0; i < blob1->len; ++i) {
-    if (blob1->data[i] != blob2->data[i])
-      return false;
-  }
-  return true;
-}
-
-static bool
-internal_equal_p(pic_state *pic, pic_value x, pic_value y, size_t depth, xhash *xh, bool xh_initted_p)
 {
   pic_value local = pic_nil_value();
-  size_t c;
+  size_t c = 0;
 
   if (depth > 10) {
     if (depth > 200) {
       pic_errorf(pic, "Stack overflow in equal\n");
     }
     if (pic_pair_p(x) || pic_vec_p(x)) {
-      if (! xh_initted_p) {
+      int ret;
-        xh_init_ptr(xh, 0);
+      kh_put(m, h, pic_obj_ptr(x), &ret);
-        xh_initted_p = true;
+      if (ret != 0) {
-      }
-
-      if (xh_get_ptr(xh, pic_obj_ptr(x)) != NULL) {
         return true;            /* `x' was seen already.  */
-      } else {
-        xh_put_ptr(xh, pic_obj_ptr(x), NULL);
       }
     }
   }
 
-  c = 0;
-
  LOOP:
 
-  if (pic_eqv_p(x, y))
+  if (pic_eqv_p(x, y)) {
     return true;
-
+  }
-  if (pic_type(x) != pic_type(y))
+  if (pic_type(x) != pic_type(y)) {
     return false;
+  }
 
   switch (pic_type(x)) {
-  case PIC_TT_STRING:
+  case PIC_TT_ID: {
-    return str_equal_p(pic, pic_str_ptr(x), pic_str_ptr(y));
+    struct pic_id *id1, *id2;
 
-  case PIC_TT_BLOB:
+    id1 = pic_id_ptr(x);
-    return blob_equal_p(pic_blob_ptr(x), pic_blob_ptr(y));
+    id2 = pic_id_ptr(y);
 
+    return pic_resolve(pic, id1->var, id1->env) == pic_resolve(pic, id2->var, id2->env);
+  }
+  case PIC_TT_STRING: {
+    return pic_str_cmp(pic, pic_str_ptr(x), pic_str_ptr(y)) == 0;
+  }
+  case PIC_TT_BLOB: {
+    pic_blob *blob1, *blob2;
+    size_t i;
+
+    blob1 = pic_blob_ptr(x);
+    blob2 = pic_blob_ptr(y);
+
+    if (blob1->len != blob2->len) {
+      return false;
+    }
+    for (i = 0; i < blob1->len; ++i) {
+      if (blob1->data[i] != blob2->data[i])
+        return false;
+    }
+    return true;
+  }
   case PIC_TT_PAIR: {
+    if (! internal_equal_p(pic, pic_car(pic, x), pic_car(pic, y), depth + 1, h))
+      return false;
+
+    /* Floyd's cycle-finding algorithm */
     if (pic_nil_p(local)) {
       local = x;
     }
-    if (internal_equal_p(pic, pic_car(pic, x), pic_car(pic, y), depth + 1, xh, xh_initted_p)) {
+    x = pic_cdr(pic, x);
-      x = pic_cdr(pic, x);
+    y = pic_cdr(pic, y);
-      y = pic_cdr(pic, y);
+    c++;
-
+    if (c == 2) {
-      c++;
+      c = 0;
-
+      local = pic_cdr(pic, local);
-      if (c == 2) {
+      if (pic_eq_p(local, x)) {
-        c = 0;
+        return true;
-        local = pic_cdr(pic, local);
-        if (pic_eq_p(local, x)) {
-          return true;
-        }
       }
-      goto LOOP;
-    } else {
-      return false;
     }
+    goto LOOP;                  /* tail-call optimization */
   }
   case PIC_TT_VECTOR: {
     size_t i;
@@ -99,7 +94,7 @@ internal_equal_p(pic_state *pic, pic_value x, pic_value y, size_t depth, xhash *
       return false;
     }
     for (i = 0; i < u->len; ++i) {
-      if (! internal_equal_p(pic, u->data[i], v->data[i], depth + 1, xh, xh_initted_p))
+      if (! internal_equal_p(pic, u->data[i], v->data[i], depth + 1, h))
         return false;
     }
     return true;
@@ -112,9 +107,11 @@ internal_equal_p(pic_state *pic, pic_value x, pic_value y, size_t depth, xhash *
 bool
 pic_equal_p(pic_state *pic, pic_value x, pic_value y)
 {
-  xhash ht;
+  khash_t(m) h;
 
-  return internal_equal_p(pic, x, y, 0, &ht, false);
+  kh_init(m, &h);
+
+  return internal_equal_p(pic, x, y, 0, &h);
 }
 
 static pic_value
@@ -195,7 +192,7 @@ pic_init_bool(pic_state *pic)
   pic_defun(pic, "eqv?", pic_bool_eqv_p);
   pic_defun(pic, "equal?", pic_bool_equal_p);
 
-  pic_defun_vm(pic, "not", pic->rNOT, pic_bool_not);
+  pic_defun_vm(pic, "not", pic->uNOT, pic_bool_not);
 
   pic_defun(pic, "boolean?", pic_bool_boolean_p);
   pic_defun(pic, "boolean=?", pic_bool_boolean_eq_p);

extlib/benz/cont.c

@@ -31,7 +31,7 @@ pic_dynamic_wind(pic_state *pic, struct pic_proc *in, struct pic_proc *thunk, st
   }
 
   here = pic->cp;
-  pic->cp = pic_malloc(pic, sizeof(pic_checkpoint));
+  pic->cp = (pic_checkpoint *)pic_obj_alloc(pic, sizeof(pic_checkpoint), PIC_TT_CP);
   pic->cp->prev = here;
   pic->cp->depth = here->depth + 1;
   pic->cp->in = in;
@@ -51,9 +51,6 @@ pic_dynamic_wind(pic_state *pic, struct pic_proc *in, struct pic_proc *thunk, st
 void
 pic_save_point(pic_state *pic, struct pic_cont *cont)
 {
-  cont->jmp.prev = pic->jmp;
-  pic->jmp = &cont->jmp;
-
   /* save runtime context */
   cont->cp = pic->cp;
   cont->sp_offset = pic->sp - pic->stbase;
@@ -62,24 +59,16 @@ pic_save_point(pic_state *pic, struct pic_cont *cont)
   cont->arena_idx = pic->arena_idx;
   cont->ip = pic->ip;
   cont->ptable = pic->ptable;
-
+  cont->prev = pic->cc;
   cont->results = pic_undef_value();
+  cont->id = pic->ccnt++;
+
+  pic->cc = cont;
 }
 
 void
 pic_load_point(pic_state *pic, struct pic_cont *cont)
 {
-  pic_jmpbuf *jmp;
-
-  for (jmp = pic->jmp; jmp != NULL; jmp = jmp->prev) {
-    if (jmp == &cont->jmp) {
-      break;
-    }
-  }
-  if (jmp == NULL) {
-    pic_errorf(pic, "calling dead escape continuation");
-  }
-
   pic_wind(pic, pic->cp, cont->cp);
 
   /* load runtime context */
@@ -95,18 +84,32 @@ pic_load_point(pic_state *pic, struct pic_cont *cont)
 static pic_value
 cont_call(pic_state *pic)
 {
+  struct pic_proc *self = pic_get_proc(pic);
   size_t argc;
   pic_value *argv;
-  struct pic_data *e;
+  int id;
+  struct pic_cont *cc, *cont;
 
   pic_get_args(pic, "*", &argc, &argv);
 
-  e = pic_data_ptr(pic_proc_env_ref(pic, pic_get_proc(pic), "escape"));
+  id = pic_int(pic_proc_env_ref(pic, self, "id"));
-  ((struct pic_cont *)e->data)->results = pic_list_by_array(pic, argc, argv);
 
-  pic_load_point(pic, e->data);
+  /* check if continuation is alive */
+  for (cc = pic->cc; cc != NULL; cc = cc->prev) {
+    if (cc->id == id) {
+      break;
+    }
+  }
+  if (cc == NULL) {
+    pic_errorf(pic, "calling dead escape continuation");
+  }
 
-  PIC_LONGJMP(pic, ((struct pic_cont *)e->data)->jmp.buf, 1);
+  cont = pic_data_ptr(pic_proc_env_ref(pic, self, "escape"))->data;
+  cont->results = pic_list_by_array(pic, argc, argv);
+
+  pic_load_point(pic, cont);
+
+  PIC_LONGJMP(pic, cont->jmp, 1);
 
   PIC_UNREACHABLE();
 }
@@ -114,16 +117,17 @@ cont_call(pic_state *pic)
 struct pic_proc *
 pic_make_cont(pic_state *pic, struct pic_cont *cont)
 {
-  static const pic_data_type cont_type = { "cont", pic_free, NULL };
+  static const pic_data_type cont_type = { "cont", NULL, NULL };
   struct pic_proc *c;
   struct pic_data *e;
 
-  c = pic_make_proc(pic, cont_call, "<cont-procedure>");
+  c = pic_make_proc(pic, cont_call);
 
   e = pic_data_alloc(pic, &cont_type, cont);
 
   /* save the escape continuation in proc */
   pic_proc_env_set(pic, c, "escape", pic_obj_value(e));
+  pic_proc_env_set(pic, c, "id", pic_int_value(cont->id));
 
   return c;
 }
@@ -131,21 +135,21 @@ pic_make_cont(pic_state *pic, struct pic_cont *cont)
 pic_value
 pic_callcc(pic_state *pic, struct pic_proc *proc)
 {
-  struct pic_cont *cont = pic_malloc(pic, sizeof(struct pic_cont));
+  struct pic_cont cont;
 
-  pic_save_point(pic, cont);
+  pic_save_point(pic, &cont);
 
-  if (PIC_SETJMP(pic, cont->jmp.buf)) {
+  if (PIC_SETJMP(pic, cont.jmp)) {
-    pic->jmp = pic->jmp->prev;
+    pic->cc = pic->cc->prev;
 
-    return pic_values_by_list(pic, cont->results);
+    return pic_values_by_list(pic, cont.results);
   }
   else {
     pic_value val;
 
-    val = pic_apply1(pic, proc, pic_obj_value(pic_make_cont(pic, cont)));
+    val = pic_apply1(pic, proc, pic_obj_value(pic_make_cont(pic, &cont)));
 
-    pic->jmp = pic->jmp->prev;
+    pic->cc = pic->cc->prev;
 
     return val;
   }
@@ -288,6 +292,6 @@ pic_init_cont(pic_state *pic)
   pic_defun(pic, "call/cc", pic_cont_callcc);
   pic_defun(pic, "dynamic-wind", pic_cont_dynamic_wind);
 
-  pic_defun_vm(pic, "values", pic->rVALUES, pic_cont_values);
+  pic_defun_vm(pic, "values", pic->uVALUES, pic_cont_values);
-  pic_defun_vm(pic, "call-with-values", pic->rCALL_WITH_VALUES, pic_cont_call_with_values);
+  pic_defun_vm(pic, "call-with-values", pic->uCALL_WITH_VALUES, pic_cont_call_with_values);
 }

extlib/benz/data.c

@@ -4,11 +4,12 @@ struct pic_data *
 pic_data_alloc(pic_state *pic, const pic_data_type *type, void *userdata)
 {
   struct pic_data *data;
+  struct pic_dict *storage = pic_make_dict(pic);
 
   data = (struct pic_data *)pic_obj_alloc(pic, sizeof(struct pic_data), PIC_TT_DATA);
   data->type = type;
   data->data = userdata;
-  xh_init_str(&data->storage, sizeof(pic_value));
+  data->storage = storage;
 
   return data;
 }

extlib/benz/debug.c

@@ -17,7 +17,7 @@ pic_get_backtrace(pic_state *pic)
     struct pic_proc *proc = pic_proc_ptr(ci->fp[0]);
 
     trace = pic_str_cat(pic, trace, pic_make_str_cstr(pic, "  at "));
-    trace = pic_str_cat(pic, trace, pic_make_str_cstr(pic, pic_symbol_name(pic, pic_proc_name(proc))));
+    trace = pic_str_cat(pic, trace, pic_make_str_cstr(pic, "(anonymous lambda)"));
 
     if (pic_proc_func_p(proc)) {
       trace = pic_str_cat(pic, trace, pic_make_str_cstr(pic, " (native function)\n"));
@@ -38,22 +38,26 @@ pic_print_backtrace(pic_state *pic, xFILE *file)
   assert(! pic_invalid_p(pic->err));
 
   if (! pic_error_p(pic->err)) {
-    xfprintf(file, "raise: ");
+    xfprintf(pic, file, "raise: ");
     pic_fwrite(pic, pic->err, file);
   } else {
     struct pic_error *e;
+    pic_value elem, it;
 
     e = pic_error_ptr(pic->err);
     if (e->type != pic_intern_cstr(pic, "")) {
       pic_fwrite(pic, pic_obj_value(e->type), file);
-      xfprintf(file, " ");
+      xfprintf(pic, file, " ");
     }
-    xfprintf(file, "error: ");
+    xfprintf(pic, file, "error: ");
     pic_fwrite(pic, pic_obj_value(e->msg), file);
-    xfprintf(file, "\n");
 
-    /* TODO: print error irritants */
+    pic_for_each (elem, e->irrs, it) { /* print error irritants */
+      xfprintf(pic, file, " ");
+      pic_fwrite(pic, elem, file);
+    }
+    xfprintf(pic, file, "\n");
 
-    xfputs(pic_str_cstr(pic, e->stack), file);
+    xfputs(pic, pic_str_cstr(pic, e->stack), file);
   }
 }

extlib/benz/dict.c

@@ -4,13 +4,15 @@
 
 #include "picrin.h"
 
+KHASH_DEFINE(dict, pic_sym *, pic_value, kh_ptr_hash_func, kh_ptr_hash_equal)
+
 struct pic_dict *
 pic_make_dict(pic_state *pic)
 {
   struct pic_dict *dict;
 
   dict = (struct pic_dict *)pic_obj_alloc(pic, sizeof(struct pic_dict), PIC_TT_DICT);
-  xh_init_ptr(&dict->hash, sizeof(pic_value));
+  kh_init(dict, &dict->hash);
 
   return dict;
 }
@@ -18,41 +20,50 @@ pic_make_dict(pic_state *pic)
 pic_value
 pic_dict_ref(pic_state *pic, struct pic_dict *dict, pic_sym *key)
 {
-  xh_entry *e;
+  khash_t(dict) *h = &dict->hash;
+  khiter_t it;
 
-  e = xh_get_ptr(&dict->hash, key);
+  it = kh_get(dict, h, key);
-  if (! e) {
+  if (it == kh_end(h)) {
     pic_errorf(pic, "element not found for a key: ~s", pic_obj_value(key));
   }
-  return xh_val(e, pic_value);
+  return kh_val(h, it);
 }
 
 void
 pic_dict_set(pic_state PIC_UNUSED(*pic), struct pic_dict *dict, pic_sym *key, pic_value val)
 {
-  xh_put_ptr(&dict->hash, key, &val);
+  khash_t(dict) *h = &dict->hash;
+  int ret;
+  khiter_t it;
+
+  it = kh_put(dict, h, key, &ret);
+  kh_val(h, it) = val;
 }
 
 size_t
 pic_dict_size(pic_state PIC_UNUSED(*pic), struct pic_dict *dict)
 {
-  return dict->hash.count;
+  return kh_size(&dict->hash);
 }
 
 bool
 pic_dict_has(pic_state PIC_UNUSED(*pic), struct pic_dict *dict, pic_sym *key)
 {
-  return xh_get_ptr(&dict->hash, key) != NULL;
+  return kh_get(dict, &dict->hash, key) != kh_end(&dict->hash);
 }
 
 void
 pic_dict_del(pic_state *pic, struct pic_dict *dict, pic_sym *key)
 {
-  if (xh_get_ptr(&dict->hash, key) == NULL) {
+  khash_t(dict) *h = &dict->hash;
+  khiter_t it;
+
+  it = kh_get(dict, h, key);
+  if (it == kh_end(h)) {
     pic_errorf(pic, "no slot named ~s found in dictionary", pic_obj_value(key));
   }
-
+  kh_del(dict, h, it);
-  xh_del_ptr(&dict->hash, key);
 }
 
 static pic_value
@@ -146,43 +157,41 @@ pic_dict_dictionary_map(pic_state *pic)
   struct pic_proc *proc;
   size_t argc, i;
   pic_value *args;
-  pic_value arg, ret;
+  pic_value arg_list, ret = pic_nil_value();
-  xh_entry **it;
 
   pic_get_args(pic, "l*", &proc, &argc, &args);
 
-  it = pic_malloc(pic, argc * sizeof(xh_entry));
+  if (argc != 0) {
-  for (i = 0; i < argc; ++i) {
+    khiter_t it[argc];
-    if (! pic_dict_p(args[i])) {
+    khash_t(dict) *kh[argc];
-      pic_free(pic, it);
+
-      pic_errorf(pic, "expected dict, but got %s", pic_type_repr(pic_type(args[i])));
+    for (i = 0; i < argc; ++i) {
-    }
+      if (! pic_dict_p(args[i])) {
-    it[i] = xh_begin(&pic_dict_ptr(args[i])->hash);
+        pic_errorf(pic, "expected dict, but got %s", pic_type_repr(pic_type(args[i])));
-  }
+      }
+      kh[i] = &pic_dict_ptr(args[i])->hash;
+      it[i] = kh_begin(kh[i]);
+    }
 
-  pic_try {
-    ret = pic_nil_value();
     do {
-      arg = pic_nil_value();
+      arg_list = pic_nil_value();
       for (i = 0; i < argc; ++i) {
-        if (it[i] == NULL) {
+        while (it[i] != kh_end(kh[i])) { /* find next available */
+          if (kh_exist(kh[i], it[i]))
+            break;
+          it[i]++;
+        }
+        if (it[i] == kh_end(kh[i])) {
           break;
         }
-        pic_push(pic, pic_obj_value(xh_key(it[i], pic_sym *)), arg);
+        pic_push(pic, pic_obj_value(kh_key(kh[i], it[i]++)), arg_list);
-        it[i] = xh_next(it[i]);
       }
       if (i != argc) {
         break;
       }
-      pic_push(pic, pic_apply(pic, proc, pic_reverse(pic, arg)), ret);
+      pic_push(pic, pic_apply(pic, proc, pic_reverse(pic, arg_list)), ret);
     } while (1);
   }
-  pic_catch {
-    pic_free(pic, it);
-    pic_raise(pic, pic->err);
-  }
-
-  pic_free(pic, it);
 
   return pic_reverse(pic, ret);
 }
@@ -193,42 +202,41 @@ pic_dict_dictionary_for_each(pic_state *pic)
   struct pic_proc *proc;
   size_t argc, i;
   pic_value *args;
-  pic_value arg;
+  pic_value arg_list;
-  xh_entry **it;
 
   pic_get_args(pic, "l*", &proc, &argc, &args);
 
-  it = pic_malloc(pic, argc * sizeof(xh_entry));
+  if (argc != 0) {
-  for (i = 0; i < argc; ++i) {
+    khiter_t it[argc];
-    if (! pic_dict_p(args[i])) {
+    khash_t(dict) *kh[argc];
-      pic_free(pic, it);
+
-      pic_errorf(pic, "expected dict, but got %s", pic_type_repr(pic_type(args[i])));
+    for (i = 0; i < argc; ++i) {
-    }
+      if (! pic_dict_p(args[i])) {
-    it[i] = xh_begin(&pic_dict_ptr(args[i])->hash);
+        pic_errorf(pic, "expected dict, but got %s", pic_type_repr(pic_type(args[i])));
-  }
+      }
+      kh[i] = &pic_dict_ptr(args[i])->hash;
+      it[i] = kh_begin(kh[i]);
+    }
 
-  pic_try {
     do {
-      arg = pic_nil_value();
+      arg_list = pic_nil_value();
       for (i = 0; i < argc; ++i) {
-        if (it[i] == NULL) {
+        while (it[i] != kh_end(kh[i])) { /* find next available */
+          if (kh_exist(kh[i], it[i]))
+            break;
+          it[i]++;
+        }
+        if (it[i] == kh_end(kh[i])) {
           break;
         }
-        pic_push(pic, pic_obj_value(xh_key(it[i], pic_sym *)), arg);
+        pic_push(pic, pic_obj_value(kh_key(kh[i], it[i]++)), arg_list);
-        it[i] = xh_next(it[i]);
       }
       if (i != argc) {
         break;
       }
-      pic_void(pic_apply(pic, proc, pic_reverse(pic, arg)));
+      pic_void(pic_apply(pic, proc, pic_reverse(pic, arg_list)));
     } while (1);
   }
-  pic_catch {
-    pic_free(pic, it);
-    pic_raise(pic, pic->err);
-  }
-
-  pic_free(pic, it);
 
   return pic_undef_value();
 }
@@ -238,16 +246,17 @@ pic_dict_dictionary_to_alist(pic_state *pic)
 {
   struct pic_dict *dict;
   pic_value item, alist = pic_nil_value();
-  xh_entry *it;
+  pic_sym *sym;
+  khiter_t it;
 
   pic_get_args(pic, "d", &dict);
 
-  for (it = xh_begin(&dict->hash); it != NULL; it = xh_next(it)) {
+  pic_dict_for_each (sym, dict, it) {
-    item = pic_cons(pic, pic_obj_value(xh_key(it, pic_sym *)), xh_val(it, pic_value));
+    item = pic_cons(pic, pic_obj_value(sym), pic_dict_ref(pic, dict, sym));
     pic_push(pic, item, alist);
   }
 
-  return pic_reverse(pic, alist);
+  return alist;
 }
 
 static pic_value
@@ -273,16 +282,17 @@ pic_dict_dictionary_to_plist(pic_state *pic)
 {
   struct pic_dict *dict;
   pic_value plist = pic_nil_value();
-  xh_entry *it;
+  pic_sym *sym;
+  khiter_t it;
 
   pic_get_args(pic, "d", &dict);
 
-  for (it = xh_begin(&dict->hash); it != NULL; it = xh_next(it)) {
+  pic_dict_for_each (sym, dict, it) {
-    pic_push(pic, pic_obj_value(xh_key(it, pic_sym *)), plist);
+    pic_push(pic, pic_dict_ref(pic, dict, sym), plist);
-    pic_push(pic, xh_val(it, pic_value), plist);
+    pic_push(pic, pic_obj_value(sym), plist);
   }
 
-  return pic_reverse(pic, plist);
+  return plist;
 }
 
 static pic_value

extlib/benz/error.c

@@ -27,7 +27,7 @@ pic_warnf(pic_state *pic, const char *fmt, ...)
   err_line = pic_xvformat(pic, fmt, ap);
   va_end(ap);
 
-  xfprintf(pic_stderr(pic)->file, "warn: %s\n", pic_str_cstr(pic, pic_str_ptr(pic_car(pic, err_line))));
+  xfprintf(pic, pic_stderr(pic)->file, "warn: %s\n", pic_str_cstr(pic, pic_str_ptr(pic_car(pic, err_line))));
 }
 
 void