Merge branch 'master' into c89-porting

.gitignore

@@ -1,6 +1,7 @@
 build/*
 src/load_piclib.c
 src/init_contrib.c
+docs/contrib.rst
 .dir-locals.el
 GPATH
 GRTAGS

contrib/03.callcc/callcc.c

@@ -287,6 +287,10 @@ pic_callcc_callcc(pic_state *pic)
 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.partcont/docs/doc.rst

@@ -6,3 +6,6 @@ Delimited control operators.
 - **(reset h)**
 - **(shift k)**
 
+Escape Continuation
+
+- **(escape f)**

docs/contrib.rst

@@ -1,141 +0,0 @@
-Contrib Libraries (a.k.a nitros)
-================================
-
-Scheme standard libraries
--------------------------
-
-- (scheme write)
-- (scheme cxr)
-- (scheme file)
-- (scheme inexact)
-- (scheme time)
-- (scheme process-context)
-- (scheme load)
-- (scheme lazy)
-
-(picrin control)
-----------------
-
-Delimited control operators.
-
-- **(reset h)**
-- **(shift k)**
-
-(picrin pretty-print)
----------------------
-
-Pretty-printer.
-
-- **(pretty-print obj)**
-
-  Prints obj with human-readable indention to current-output-port.
-
-
-(picrin regexp)
----------------
-
-- **(regexp ptrn [flags])**
-
-  Compiles pattern string into a regexp object. A string flags may contain any of #\g, #\i, #\m.
-
-- **(regexp? obj)**
-
-  Judges if obj is a regexp object or not.
-
-- **(regexp-match re input)**
-
-  Returns two values: a list of match strings, and a list of match indeces.
-
-- **(regexp-replace re input txt)**
-- **(regexp-split re input)**
-
-
-SRFI libraries
---------------
-
-- `(srfi 1)
-  <http://srfi.schemers.org/srfi-1/>`_
-
-  List library.
-
-- `(srfi 8)
-  <http://srfi.schemers.org/srfi-8/>`_
-
-  ``receive`` macro.
-
-- `(srfi 17)
-  <http://srfi.schemers.org/srfi-17/>`_
-
-  Generalized set!
-
-- `(srfi 26)
-  <http://srfi.schemers.org/srfi-26/>`_
-
-  Cut/cute macros.
-
-- `(srfi 43)
-  <http://srfi.schemers.org/srfi-43/>`_
-
-  Vector library.
-
-- `(srfi 60)
-  <http://srfi.schemers.org/srfi-60/>`_
-
-  Bitwise operations.
-
-- `(srfi 95)
-  <http://srfi.schemers.org/srfi-95/>`_
-
-  Sorting and Marging.
-
-- `(srfi 111)
-  <http://srfi.schemers.org/srfi-111/>`_
-
-  Boxes
-
-(picrin control list)
----------------------
-
-Monadic list operators.
-
-The triple of for/in/yield enables you to write a list operation in a very easy and simple code. One of the best examples is list composition::
-
-  (for (let ((a (in '(1 2 3)))
-             (b (in '(2 3 4))))
-         (yield (+ a b))))
-
-  ;=> (5 6 7 6 7 8 7 8 9)
-
-All monadic operations are done in *for* macro. In this example, *in* operators choose an element from the given lists, a and b are bound here, then *yielding* the sum of them. Because a and b are values moving around in the list elements, the expression (+ a b) can become every possible result. *yield* operator is a operator that gathers the possibilities into a list, so *for* macro returns a list of 3 * 3 results in total. Since expression inside *for* macro is a normal expression, you can write everything that you can write elsewhere. The code below has perfectly the same effect to above one::
-
-  (for (yield (+ (in '(1 2 3))
-                 (in '(4 5 6)))))
-
-The second best exmaple is filtering. In the next case, we show that you can do something depending on the condition of chosen elements::
-
-  (for (let ((x (in (iota 10))))
-         (if (even? x)
-             (yield x)
-             (null))))
-
-  ;=> (0 2 4 6 8)
-
-This expression is equivalent to ``(filter even? (iota 10))`` but it is more procedual and non-magical.
-
-- **(for expr)**
-
-  [Macro] Executes expr in a list monad context.
-
-- **(in list)**
-
-  Choose a value from list. *in* function must only appear in *for* macro. The delimited continuation from the position of *in* function to the outside *for* macro is executed for each element in list. If list contains no values, that is ``(in '())``, the continuation is discarded.
-
-- **(yield value)**
-
-  Yields value from the monad context. The result of *for* will be a list of yielded values.
-
-- **(null . value)**
-
-  Returns ``()`` whatever value is given. The identity element of list composition. This operator corresponds to Haskell's fail method of Monad class.
-
-

extlib/benz/cont.c

@@ -99,6 +99,7 @@ escape_call(pic_state *pic)
   pic_get_args(pic, "*", &argc, &argv);
 
   e = pic_data_ptr(pic_attr_ref(pic, pic_obj_value(pic_get_proc(pic)), "@@escape"));
+  ((struct pic_escape *)e->data)->results = pic_list_by_array(pic, argc, argv);
 
   pic_load_point(pic, e->data);
 

extlib/benz/init.c

@@ -1,140 +0,0 @@
-/**
- * See Copyright Notice in picrin.h
- */
-
-#include "picrin.h"
-#include "picrin/pair.h"
-#include "picrin/lib.h"
-#include "picrin/macro.h"
-#include "picrin/error.h"
-
-void
-pic_add_feature(pic_state *pic, const char *feature)
-{
-  pic_push(pic, pic_obj_value(pic_intern_cstr(pic, feature)), pic->features);
-}
-
-void pic_init_bool(pic_state *);
-void pic_init_pair(pic_state *);
-void pic_init_port(pic_state *);
-void pic_init_number(pic_state *);
-void pic_init_proc(pic_state *);
-void pic_init_symbol(pic_state *);
-void pic_init_vector(pic_state *);
-void pic_init_blob(pic_state *);
-void pic_init_cont(pic_state *);
-void pic_init_char(pic_state *);
-void pic_init_error(pic_state *);
-void pic_init_str(pic_state *);
-void pic_init_macro(pic_state *);
-void pic_init_var(pic_state *);
-void pic_init_write(pic_state *);
-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_attr(pic_state *);
-
-extern const char pic_boot[];
-
-static void
-pic_init_features(pic_state *pic)
-{
-  pic_add_feature(pic, "picrin");
-  pic_add_feature(pic, "ieee-float");
-
-#if _POSIX_SOURCE
-  pic_add_feature(pic, "posix");
-#endif
-
-#if _WIN32
-  pic_add_feature(pic, "windows");
-#endif
-
-#if __unix__
-  pic_add_feature(pic, "unix");
-#endif
-#if __gnu_linux__
-  pic_add_feature(pic, "gnu-linux");
-#endif
-#if __FreeBSD__
-  pic_add_feature(pic, "freebsd");
-#endif
-
-#if __i386__
-  pic_add_feature(pic, "i386");
-#elif __x86_64__
-  pic_add_feature(pic, "x86-64");
-#elif __ppc__
-  pic_add_feature(pic, "ppc");
-#elif __sparc__
-  pic_add_feature(pic, "sparc");
-#endif
-
-#if __ILP32__
-  pic_add_feature(pic, "ilp32");
-#elif __LP64__
-  pic_add_feature(pic, "lp64");
-#endif
-
-#if defined(__BYTE_ORDER__)
-# if __BYTE_ORDER__ == __ORDER_LITTLE_ENDIAN__
-  pic_add_feature(pic, "little-endian");
-# elif __BYTE_ORDER__ == __ORDER_BIG_ENDIAN__
-  pic_add_feature(pic, "big-endian");
-# endif
-#else
-# if __LITTLE_ENDIAN__
-  pic_add_feature(pic, "little-endian");
-# elif __BIG_ENDIAN__
-  pic_add_feature(pic, "big-endian");
-# endif
-#endif
-}
-
-#define DONE pic_gc_arena_restore(pic, ai);
-
-void
-pic_init_core(pic_state *pic)
-{
-  size_t ai = pic_gc_arena_preserve(pic);
-
-  pic_init_features(pic);
-
-  pic_deflibrary (pic, "(picrin base)") {
-    pic_define_syntactic_keyword(pic, pic->lib->env, pic->sDEFINE, pic->rDEFINE);
-    pic_define_syntactic_keyword(pic, pic->lib->env, pic->sSETBANG, pic->rSETBANG);
-    pic_define_syntactic_keyword(pic, pic->lib->env, pic->sQUOTE, pic->rQUOTE);
-    pic_define_syntactic_keyword(pic, pic->lib->env, pic->sLAMBDA, pic->rLAMBDA);
-    pic_define_syntactic_keyword(pic, pic->lib->env, pic->sIF, pic->rIF);
-    pic_define_syntactic_keyword(pic, pic->lib->env, pic->sBEGIN, pic->rBEGIN);
-    pic_define_syntactic_keyword(pic, pic->lib->env, pic->sDEFINE_SYNTAX, pic->rDEFINE_SYNTAX);
-
-    pic_init_bool(pic); DONE;
-    pic_init_pair(pic); DONE;
-    pic_init_port(pic); DONE;
-    pic_init_number(pic); DONE;
-    pic_init_proc(pic); DONE;
-    pic_init_symbol(pic); DONE;
-    pic_init_vector(pic); DONE;
-    pic_init_blob(pic); DONE;
-    pic_init_cont(pic); DONE;
-    pic_init_char(pic); DONE;
-    pic_init_error(pic); DONE;
-    pic_init_str(pic); DONE;
-    pic_init_macro(pic); DONE;
-    pic_init_var(pic); DONE;
-    pic_init_write(pic); DONE;
-    pic_init_read(pic); DONE;
-    pic_init_dict(pic); DONE;
-    pic_init_record(pic); DONE;
-    pic_init_eval(pic); DONE;
-    pic_init_lib(pic); DONE;
-    pic_init_attr(pic); DONE;
-
-    pic_load_cstr(pic, pic_boot);
-  }
-
-  pic_import_library(pic, pic->PICRIN_BASE);
-}

extlib/benz/read.c

@@ -79,6 +79,15 @@ strcaseeq(const char *s1, const char *s2)
   return a == b;
 }
 
+static int
+case_fold(pic_state *pic, int c)
+{
+  if (pic->reader->typecase == PIC_CASE_FOLD) {
+    c = tolower(c);
+  }
+  return c;
+}
+
 static pic_value
 read_comment(pic_state *pic, struct pic_port *port, int c)
 {
@@ -198,17 +207,14 @@ read_symbol(pic_state *pic, struct pic_port *port, int c)
 
   len = 1;
   buf = pic_alloc(pic, len + 1);
-  buf[0] = c;
+  buf[0] = case_fold(pic, c);
   buf[1] = 0;
 
   while (! isdelim(peek(port))) {
     c = next(port);
-    if (pic->reader->typecase == PIC_CASE_FOLD) {
-      c = tolower(c);
-    }
     len += 1;
     buf = pic_realloc(pic, buf, len + 1);
-    buf[len - 1] = c;
+    buf[len - 1] = case_fold(pic, c);
     buf[len] = 0;
   }
 
@@ -534,8 +540,7 @@ read_blob(pic_state *pic, struct pic_port *port, int c)
 static pic_value
 read_pair(pic_state *pic, struct pic_port *port, int c)
 {
-  const int tOPEN = c;
-  const int tCLOSE = (c == '(') ? ')' : ']';
+  static const int tCLOSE = ')';
   pic_value car, cdr;
 
  retry:
@@ -564,7 +569,7 @@ read_pair(pic_state *pic, struct pic_port *port, int c)
       goto retry;
     }
 
-    cdr = read_pair(pic, port, tOPEN);
+    cdr = read_pair(pic, port, '(');
     return pic_cons(pic, car, cdr);
   }
 }
@@ -586,7 +591,7 @@ read_label_set(pic_state *pic, struct pic_port *port, int i)
   int c;
 
   switch ((c = skip(port, ' '))) {
-  case '(': case '[':
+  case '(':
     {
       pic_value tmp;
 
@@ -749,7 +754,6 @@ reader_table_init(struct pic_reader *reader)
   reader->table['+'] = read_plus;
   reader->table['-'] = read_minus;
   reader->table['('] = read_pair;
-  reader->table['['] = read_pair;
   reader->table['#'] = read_dispatch;
 
   /* read number */

extlib/benz/state.c

@@ -11,8 +11,139 @@
 #include "picrin/port.h"
 #include "picrin/error.h"
 #include "picrin/dict.h"
+#include "picrin/pair.h"
+#include "picrin/lib.h"
 
-void pic_init_core(pic_state *);
+void
+pic_add_feature(pic_state *pic, const char *feature)
+{
+  pic_push(pic, pic_obj_value(pic_intern_cstr(pic, feature)), pic->features);
+}
+
+void pic_init_bool(pic_state *);
+void pic_init_pair(pic_state *);
+void pic_init_port(pic_state *);
+void pic_init_number(pic_state *);
+void pic_init_proc(pic_state *);
+void pic_init_symbol(pic_state *);
+void pic_init_vector(pic_state *);
+void pic_init_blob(pic_state *);
+void pic_init_cont(pic_state *);
+void pic_init_char(pic_state *);
+void pic_init_error(pic_state *);
+void pic_init_str(pic_state *);
+void pic_init_macro(pic_state *);
+void pic_init_var(pic_state *);
+void pic_init_write(pic_state *);
+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_attr(pic_state *);
+
+extern const char pic_boot[];
+
+static void
+pic_init_features(pic_state *pic)
+{
+  pic_add_feature(pic, "picrin");
+  pic_add_feature(pic, "ieee-float");
+
+#if _POSIX_SOURCE
+  pic_add_feature(pic, "posix");
+#endif
+
+#if _WIN32
+  pic_add_feature(pic, "windows");
+#endif
+
+#if __unix__
+  pic_add_feature(pic, "unix");
+#endif
+#if __gnu_linux__
+  pic_add_feature(pic, "gnu-linux");
+#endif
+#if __FreeBSD__
+  pic_add_feature(pic, "freebsd");
+#endif
+
+#if __i386__
+  pic_add_feature(pic, "i386");
+#elif __x86_64__
+  pic_add_feature(pic, "x86-64");
+#elif __ppc__
+  pic_add_feature(pic, "ppc");
+#elif __sparc__
+  pic_add_feature(pic, "sparc");
+#endif
+
+#if __ILP32__
+  pic_add_feature(pic, "ilp32");
+#elif __LP64__
+  pic_add_feature(pic, "lp64");
+#endif
+
+#if defined(__BYTE_ORDER__)
+# if __BYTE_ORDER__ == __ORDER_LITTLE_ENDIAN__
+  pic_add_feature(pic, "little-endian");
+# elif __BYTE_ORDER__ == __ORDER_BIG_ENDIAN__
+  pic_add_feature(pic, "big-endian");
+# endif
+#else
+# if __LITTLE_ENDIAN__
+  pic_add_feature(pic, "little-endian");
+# elif __BIG_ENDIAN__
+  pic_add_feature(pic, "big-endian");
+# endif
+#endif
+}
+
+#define DONE pic_gc_arena_restore(pic, ai);
+
+static void
+pic_init_core(pic_state *pic)
+{
+  size_t ai = pic_gc_arena_preserve(pic);
+
+  pic_init_features(pic);
+
+  pic_deflibrary (pic, "(picrin base)") {
+    pic_define_syntactic_keyword(pic, pic->lib->env, pic->sDEFINE, pic->rDEFINE);
+    pic_define_syntactic_keyword(pic, pic->lib->env, pic->sSETBANG, pic->rSETBANG);
+    pic_define_syntactic_keyword(pic, pic->lib->env, pic->sQUOTE, pic->rQUOTE);
+    pic_define_syntactic_keyword(pic, pic->lib->env, pic->sLAMBDA, pic->rLAMBDA);
+    pic_define_syntactic_keyword(pic, pic->lib->env, pic->sIF, pic->rIF);
+    pic_define_syntactic_keyword(pic, pic->lib->env, pic->sBEGIN, pic->rBEGIN);
+    pic_define_syntactic_keyword(pic, pic->lib->env, pic->sDEFINE_SYNTAX, pic->rDEFINE_SYNTAX);
+
+    pic_init_bool(pic); DONE;
+    pic_init_pair(pic); DONE;
+    pic_init_port(pic); DONE;
+    pic_init_number(pic); DONE;
+    pic_init_proc(pic); DONE;
+    pic_init_symbol(pic); DONE;
+    pic_init_vector(pic); DONE;
+    pic_init_blob(pic); DONE;
+    pic_init_cont(pic); DONE;
+    pic_init_char(pic); DONE;
+    pic_init_error(pic); DONE;
+    pic_init_str(pic); DONE;
+    pic_init_macro(pic); DONE;
+    pic_init_var(pic); DONE;
+    pic_init_write(pic); DONE;
+    pic_init_read(pic); DONE;
+    pic_init_dict(pic); DONE;
+    pic_init_record(pic); DONE;
+    pic_init_eval(pic); DONE;
+    pic_init_lib(pic); DONE;
+    pic_init_attr(pic); DONE;
+
+    pic_load_cstr(pic, pic_boot);
+  }
+
+  pic_import_library(pic, pic->PICRIN_BASE);
+}
 
 pic_state *
 pic_open(int argc, char *argv[], char **envp)

t/escape.scm

@@ -0,0 +1,16 @@
+(import (scheme base)
+		(picrin control)
+        (picrin test))
+
+(test-begin)
+
+(test 1 (escape (lambda (exit) (begin (exit 1) 2))))
+
+(define cont #f)
+
+(test "calling dead escape continuation"
+	  (guard (c ((error-object? c) (error-object-message c)))
+			 (escape (lambda (exit) (set! cont exit)))
+			 (cont 3)))
+
+(test-end)