Merge branch 'master' of git://github.com/wasabiz/picrin into srfi1

README.md

@@ -57,7 +57,7 @@ Picrin is a lightweight scheme implementation intended to comply with full R7RS
 | 5.6.1 Library Syntax | incomplete | In picrin, libraries can be reopend and can be nested. |
 | 5.6.2 Library example | N/A | |
 | 5.7 The REPL | yes | |
-| 6.1 Equivalence predicates | yes | |
+| 6.1 Equivalence predicates | yes | TODO: equal? must terminate if circular structure is given |
 | 6.2.1 Numerical types | yes | picrin has only two types of internal representation of numbers: fixnum and double float. It still comforms the R7RS spec. |
 | 6.2.2 Exactness | yes | |
 | 6.2.3 Implementation restrictions | yes | |
@@ -75,7 +75,7 @@ Picrin is a lightweight scheme implementation intended to comply with full R7RS
 | 6.10  Control features | yes | |
 | 6.11 Exceptions | yes | TODO: native error handling |
 | 6.12 Environments and evaluation | N/A | |
-| 6.13.1 Ports | incomplete | TODO: string I/O, bytevector I/O |
+| 6.13.1 Ports | yes | |
 | 6.13.2 Input | incomplete | |
 | 6.13.3 Output | yes | TODO: `write`, `write-shared` and `display` are unsafe against circular objects |
 | 6.14 System interface | yes | |

extlib/xfile

@@ -1 +1 @@
-Subproject commit 54889153333c7aa5a228fcf624c730e727abc769
+Subproject commit 7c62dd5c264ad1a43bd932b4097445ccc982a557

include/picrin.h

@@ -160,7 +160,7 @@ bool pic_interned_p(pic_state *, pic_sym);
 
 char *pic_strdup(pic_state *, const char *);
 char *pic_strndup(pic_state *, const char *, size_t);
-struct pic_string *pic_str_new(pic_state *, const char *, size_t);
+struct pic_string *pic_str_new(pic_state *, const char *, size_t); /* the 2nd arg may be NULL for empty string */
 struct pic_string *pic_str_new_cstr(pic_state *, const char *);
 
 struct pic_vector *pic_vec_new(pic_state *, size_t);

piclib/built-in.scm

@@ -1,3 +1,39 @@
+;;; Appendix A. Standard Libraries CxR
+(define-library (scheme cxr)
+  (import (scheme base))
+
+  (define (caaar p) (car (caar p)))
+  (define (caadr p) (car (cadr p)))
+  (define (cadar p) (car (cdar p)))
+  (define (caddr p) (car (cddr p)))
+  (define (cdaar p) (cdr (caar p)))
+  (define (cdadr p) (cdr (cadr p)))
+  (define (cddar p) (cdr (cdar p)))
+  (define (cdddr p) (cdr (cddr p)))
+  (define (caaaar p) (caar (caar p)))
+  (define (caaadr p) (caar (cadr p)))
+  (define (caadar p) (caar (cdar p)))
+  (define (caaddr p) (caar (cddr p)))
+  (define (cadaar p) (cadr (caar p)))
+  (define (cadadr p) (cadr (cadr p)))
+  (define (caddar p) (cadr (cdar p)))
+  (define (cadddr p) (cadr (cddr p)))
+  (define (cdaaar p) (cdar (caar p)))
+  (define (cdaadr p) (cdar (cadr p)))
+  (define (cdadar p) (cdar (cdar p)))
+  (define (cdaddr p) (cdar (cddr p)))
+  (define (cddaar p) (cddr (caar p)))
+  (define (cddadr p) (cddr (cadr p)))
+  (define (cdddar p) (cddr (cdar p)))
+  (define (cddddr p) (cddr (cddr p)))
+
+  (export caaar caadr cadar caddr
+          cdaar cdadr cddar cdddr
+          caaaar caaadr caadar caaddr
+          cadaar cadadr caddar cadddr
+          cdaaar cdaadr cdadar cdaddr
+          cddaar cddadr cdddar cddddr))
+
 ;;; hygienic macros
 (define-library (picrin macro)
   (import (scheme base))
@@ -13,21 +49,11 @@
   (export sc-macro-transformer
           rsc-macro-transformer))
 
-;;; bootstrap utilities
-(define-library (picrin bootstrap-tools)
-  (import (scheme base))
-
-  (define (cadar p) (car (cdar p)))
-  (define (caddr p) (car (cddr p)))
-  (define (cdddr p) (cdr (cddr p)))
-
-  (export cadar caddr cdddr))
-
 ;;; core syntaces
 (define-library (picrin core-syntax)
   (import (scheme base)
-          (picrin macro)
+          (scheme cxr)
-          (picrin bootstrap-tools))
+          (picrin macro))
 
   (define-syntax let
     (er-macro-transformer
@@ -222,9 +248,9 @@
 ;;; multiple value
 (define-library (picrin multiple-value)
   (import (scheme base)
+          (scheme cxr)
           (picrin macro)
-          (picrin core-syntax)
+          (picrin core-syntax))
-          (picrin bootstrap-tools))
 
   (define-syntax let*-values
     (er-macro-transformer
@@ -268,9 +294,9 @@
 ;;; parameter
 (define-library (picrin parameter)
   (import (scheme base)
+          (scheme cxr)
           (picrin macro)
-          (picrin core-syntax)
+          (picrin core-syntax))
-          (picrin bootstrap-tools))
 
   ;; reopen (pircin parameter)
   ;; see src/var.c
@@ -280,14 +306,19 @@
      (lambda (form r compare)
        (let ((bindings (cadr form))
              (body (cddr form)))
-         (let ((vars (map car bindings)))
+         (let ((vars (map car bindings))
+               (gensym (lambda (var)
+                         (string->symbol
+                          (string-append
+                           "parameterize-"
+                           (symbol->string var))))))
            `(,(r 'let) (,@(map (lambda (var)
-                                 `(,(r var) (,var)))
+                                 `(,(r (gensym var)) (,var)))
                             vars))
               ,@bindings
               (,(r 'let) ((,(r 'result) (begin ,@body)))
                 ,@(map (lambda (var)
-                         `(,(r 'parameter-set!) ,var ,(r var)))
+                         `(,(r 'parameter-set!) ,var ,(r (gensym var))))
                        vars)
                 ,(r 'result))))))))
 
@@ -434,15 +465,6 @@
 
 ;;; 6.7 String
 
-(define (string . objs)
-  (let ((len (length objs)))
-    (let ((v (make-string len)))
-      (do ((i 0 (+ i 1))
-	   (l objs (cdr l)))
-	  ((= i len)
-	   v)
-	(string-set! v i (car l))))))
-
 (define (string->list string . opts)
   (let ((start (if (pair? opts) (car opts) 0))
 	(end (if (>= (length opts) 2)
@@ -455,48 +477,18 @@
       (set! res (cons (string-ref string i) res)))))
 
 (define (list->string list)
-  (apply string list))
+  (let ((len (length list)))
+    (let ((v (make-string len)))
+      (do ((i 0 (+ i 1))
+	   (l list (cdr l)))
+	  ((= i len)
+	   v)
+	(string-set! v i (car l))))))
 
-(define (string-copy! to at from . opts)
+(define (string . objs)
-  (let ((start (if (pair? opts) (car opts) 0))
+  (list->string objs))
-	(end (if (>= (length opts) 2)
-		 (cadr opts)
-		 (string-length from))))
-    (do ((i at (+ i 1))
-	 (j start (+ j 1)))
-	((= j end))
-      (string-set! to i (string-ref from j)))))
 
-(define (string-copy v . opts)
+(export string string->list list->string)
-  (let ((start (if (pair? opts) (car opts) 0))
-	(end (if (>= (length opts) 2)
-		 (cadr opts)
-		 (string-length v))))
-    (let ((res (make-string (string-length v))))
-      (string-copy! res 0 v start end)
-      res)))
-
-(define (string-append . vs)
-  (define (string-append-2-inv w v)
-    (let ((res (make-string (+ (string-length v) (string-length w)))))
-      (string-copy! res 0 v)
-      (string-copy! res (string-length v) w)
-      res))
-  (fold string-append-2-inv #() vs))
-
-(define (string-fill! v fill . opts)
-  (let ((start (if (pair? opts) (car opts) 0))
-	(end (if (>= (length opts) 2)
-		 (cadr opts)
-		 (string-length v))))
-    (do ((i start (+ i 1)))
-	((= i end)
-	 #f)
-      (string-set! v i fill))))
-
-(export string string->list list->string
-        string-copy! string-copy
-        string-append string-fill!)
 
 ;;; 6.8. Vector
 
@@ -713,40 +705,3 @@
         (write obj port)))))
 
   (export write write-shared display))
-
-;;; Appendix A. Standard Libraries
-;; CxR
-(define-library (scheme cxr)
-  (import (scheme base))
-
-  (define (caaar  p) (car  (caar p)))
-  (define (caadr  p) (car  (cadr p)))
-  (define (cadar  p) (car  (cdar p)))
-  (define (caddr  p) (car  (cddr p)))
-  (define (cdaar  p) (cdr  (caar p)))
-  (define (cdadr  p) (cdr  (cadr p)))
-  (define (cddar  p) (cdr  (cdar p)))
-  (define (cdddr  p) (cdr  (cddr p)))
-  (define (caaaar p) (caar (caar p)))
-  (define (caaadr p) (caar (cadr p)))
-  (define (caadar p) (caar (cdar p)))
-  (define (caaddr p) (caar (cddr p)))
-  (define (cadaar p) (cadr (caar p)))
-  (define (cadadr p) (cadr (cadr p)))
-  (define (caddar p) (cadr (cdar p)))
-  (define (cadddr p) (cadr (cddr p)))
-  (define (cdaaar p) (cdar (caar p)))
-  (define (cdaadr p) (cdar (cadr p)))
-  (define (cdadar p) (cdar (cdar p)))
-  (define (cdaddr p) (cdar (cddr p)))
-  (define (cddaar p) (cddr (caar p)))
-  (define (cddadr p) (cddr (cadr p)))
-  (define (cdddar p) (cddr (cdar p)))
-  (define (cddddr p) (cddr (cddr p)))
-
-  (export caaar caadr cadar caddr
-          cdaar cdadr cddar cdddr
-          caaaar caaadr caadar caaddr
-          cadaar cadadr caddar cadddr
-          cdaaar cdaadr cdadar cdaddr
-          cddaar cddadr cdddar cddddr))

src/port.c

@@ -223,6 +223,121 @@ pic_port_close_port(pic_state *pic)
     }                                                                   \
   } while (0)
 
+static pic_value
+pic_port_open_input_string(pic_state *pic)
+{
+  struct pic_port *port;
+  char *str;
+  size_t len;
+
+  pic_get_args(pic, "s", &str, &len);
+
+  port = (struct pic_port *)pic_obj_alloc(pic, sizeof(struct pic_port *), PIC_TT_PORT);
+  port->file = xmopen();
+  port->flags = PIC_PORT_IN | PIC_PORT_TEXT;
+  port->status = PIC_PORT_OPEN;
+
+  xfputs(str, port->file);
+  xfflush(port->file);
+  xrewind(port->file);
+
+  return pic_obj_value(port);
+}
+
+static pic_value
+pic_port_open_output_string(pic_state *pic)
+{
+  struct pic_port *port;
+
+  pic_get_args(pic, "");
+
+  port = (struct pic_port *)pic_obj_alloc(pic, sizeof(struct pic_port *), PIC_TT_PORT);
+  port->file = xmopen();
+  port->flags = PIC_PORT_OUT | PIC_PORT_TEXT;
+  port->status = PIC_PORT_OPEN;
+
+  return pic_obj_value(port);
+}
+
+static pic_value
+pic_port_get_output_string(pic_state *pic)
+{
+  struct pic_port *port = pic_stdout(pic);;
+  long endpos;
+  char *buf;
+
+  pic_get_args(pic, "|p", &port);
+
+  assert_port_profile(port, PIC_PORT_OUT | PIC_PORT_TEXT, PIC_PORT_OPEN, "get-output-string");
+
+  /* get endpos */
+  xfflush(port->file);
+  endpos = xftell(port->file);
+  xrewind(port->file);
+
+  /* copy to buf */
+  buf = (char *)pic_alloc(pic, endpos);
+  xfread(buf, 1, endpos, port->file);
+
+  return pic_obj_value(pic_str_new(pic, buf, endpos));
+}
+
+static pic_value
+pic_port_open_input_blob(pic_state *pic)
+{
+  struct pic_port *port;
+  struct pic_blob *blob;
+
+  pic_get_args(pic, "b", &blob);
+
+  port = (struct pic_port *)pic_obj_alloc(pic, sizeof(struct pic_port *), PIC_TT_PORT);
+  port->file = xmopen();
+  port->flags = PIC_PORT_IN | PIC_PORT_BINARY;
+  port->status = PIC_PORT_OPEN;
+
+  xfwrite(blob->data, 1, blob->len, port->file);
+
+  return pic_obj_value(port);
+}
+
+static pic_value
+pic_port_open_output_bytevector(pic_state *pic)
+{
+  struct pic_port *port;
+
+  pic_get_args(pic, "");
+
+  port = (struct pic_port *)pic_obj_alloc(pic, sizeof(struct pic_port *), PIC_TT_PORT);
+  port->file = xmopen();
+  port->flags = PIC_PORT_OUT | PIC_PORT_BINARY;
+  port->status = PIC_PORT_OPEN;
+
+  return pic_obj_value(port);
+}
+
+static pic_value
+pic_port_get_output_bytevector(pic_state *pic)
+{
+  struct pic_port *port = pic_stdout(pic);;
+  long endpos;
+  char *buf;
+
+  pic_get_args(pic, "|p", &port);
+
+  assert_port_profile(port, PIC_PORT_OUT | PIC_PORT_BINARY, PIC_PORT_OPEN, "get-output-bytevector");
+
+  /* get endpos */
+  xfflush(port->file);
+  endpos = xftell(port->file);
+  xrewind(port->file);
+
+  /* copy to buf */
+  buf = (char *)pic_alloc(pic, endpos);
+  xfread(buf, 1, endpos, port->file);
+
+  return pic_obj_value(pic_blob_new(pic, buf, endpos));
+}
+
 static pic_value
 pic_port_read_char(pic_state *pic)
 {
@@ -297,11 +412,11 @@ pic_port_write_string(pic_state *pic)
 
   n = pic_get_args(pic, "s|pii", &str, &len, &port, &start, &end);
   switch (n) {
-  case 2:
+  case 1:
     port = pic_stdout(pic);
-  case 3:
+  case 2:
     start = 0;
-  case 4:
+  case 3:
     end = len;
   }
 
@@ -336,11 +451,11 @@ pic_port_write_blob(pic_state *pic)
 
   n = pic_get_args(pic, "b|pii", &blob, &port, &start, &end);
   switch (n) {
-  case 2:
+  case 1:
     port = pic_stdout(pic);
-  case 3:
+  case 2:
     start = 0;
-  case 4:
+  case 3:
     end = blob->len;
   }
 
@@ -385,6 +500,14 @@ pic_init_port(pic_state *pic)
   pic_defun(pic, "close-input-port", pic_port_close_port);
   pic_defun(pic, "close-output-port", pic_port_close_port);
 
+  /* string I/O */
+  pic_defun(pic, "open-input-string", pic_port_open_input_string);
+  pic_defun(pic, "open-output-string", pic_port_open_output_string);
+  pic_defun(pic, "get-output-string", pic_port_get_output_string);
+  pic_defun(pic, "open-input-bytevector", pic_port_open_input_blob);
+  pic_defun(pic, "open-output-bytevector", pic_port_open_output_bytevector);
+  pic_defun(pic, "get-output-bytevector", pic_port_get_output_bytevector);
+
   /* input */
   pic_defun(pic, "read-char", pic_port_read_char);
   pic_defun(pic, "peek-char", pic_port_peek_char);

src/string.c

@@ -10,10 +10,17 @@ struct pic_string *
 pic_str_new(pic_state *pic, const char *cstr, size_t len)
 {
   struct pic_string *str;
+  char *copy;
+
+  if (cstr) {
+    copy = pic_strdup(pic, cstr);
+  } else {
+    copy = (char *)pic_alloc(pic, len);
+  }
 
   str = (struct pic_string *)pic_obj_alloc(pic, sizeof(struct pic_string), PIC_TT_STRING);
   str->len = len;
-  str->str = pic_strdup(pic, cstr);
+  str->str = copy;
   return str;
 }
 
@@ -122,6 +129,97 @@ DEFINE_STRING_CMP(gt, >)
 DEFINE_STRING_CMP(le, <=)
 DEFINE_STRING_CMP(ge, >=)
 
+static pic_value
+pic_str_string_copy(pic_state *pic)
+{
+  size_t len, start, end, i;
+  char *str;
+  int n;
+  struct pic_string *copy;
+
+  n = pic_get_args(pic, "s|ii", &str, &len, &start, &end);
+
+  switch (n) {
+  case 1:
+    start = 0;
+  case 2:
+    end = len;
+  }
+
+  copy = pic_str_new(pic, NULL, end - start);
+  for (i = 0; i < end - start; ++i) {
+    copy->str[i] = str[start + i];
+  }
+  return pic_obj_value(copy);
+}
+
+static pic_value
+pic_str_string_copy_ip(pic_state *pic)
+{
+  size_t to_len, from_len, at, start, end;
+  char *to_str, *from_str;
+  int n;
+
+  n = pic_get_args(pic, "sis|ii", &to_str, &to_len, &at, &from_str, &from_len, &start, &end);
+
+  switch (n) {
+  case 3:
+    start = 0;
+  case 4:
+    end = from_len;
+  }
+
+  while (start < end) {
+    to_str[at++] = from_str[start++];
+  }
+  return pic_none_value();
+}
+
+static pic_value
+pic_str_string_append(pic_state *pic)
+{
+  size_t argc, len, i;
+  pic_value *argv;
+  char *buf;
+
+  pic_get_args(pic, "*", &argc, &argv);
+
+  len = 0;
+  buf = NULL;
+  for (i = 0; i < argc; ++i) {
+    if (! pic_str_p(argv[i])) {
+      pic_error(pic, "type error");
+    }
+    buf = pic_realloc(pic, buf, len + pic_str_ptr(argv[i])->len);
+    /* copy! */
+    memcpy(buf + len, pic_str_ptr(argv[i])->str, pic_str_ptr(argv[i])->len);
+    len += pic_str_ptr(argv[i])->len;
+  }
+  return pic_obj_value(pic_str_new(pic, buf, len));
+}
+
+static pic_value
+pic_str_string_fill_ip(pic_state *pic)
+{
+  size_t len, start, end;
+  char *str, c;
+  int n;
+
+  n = pic_get_args(pic, "sc|ii", &str, &len, &c, &start, &end);
+
+  switch (n) {
+  case 1:
+    start = 0;
+  case 2:
+    end = len;
+  }
+
+  while (start < end) {
+    str[start++] = c;
+  }
+  return pic_none_value();
+}
+
 void
 pic_init_str(pic_state *pic)
 {
@@ -130,9 +228,15 @@ pic_init_str(pic_state *pic)
   pic_defun(pic, "string-length", pic_str_string_length);
   pic_defun(pic, "string-ref", pic_str_string_ref);
   pic_defun(pic, "string-set!", pic_str_string_set);
+
   pic_defun(pic, "string=?", pic_str_string_eq);
   pic_defun(pic, "string<?", pic_str_string_lt);
   pic_defun(pic, "string>?", pic_str_string_gt);
   pic_defun(pic, "string<=?", pic_str_string_le);
   pic_defun(pic, "string>=?", pic_str_string_ge);
+
+  pic_defun(pic, "string-copy", pic_str_string_copy);
+  pic_defun(pic, "string-copy!", pic_str_string_copy_ip);
+  pic_defun(pic, "string-append", pic_str_string_append);
+  pic_defun(pic, "string-fill!", pic_str_string_fill_ip);
 }

t/parameterize.scm

@@ -0,0 +1,12 @@
+(import (scheme base)
+        (scheme write))
+
+; expects "piece by piece by piece.\n"
+(write
+ (parameterize
+     ((current-output-port (open-output-string)))
+   (display "piece")
+   (display " by piece ")
+   (display "by piece.")
+   (newline)
+   (get-output-string)))