From aa62ae9e9640131f1ce4e158f7834878df7fd8eb Mon Sep 17 00:00:00 2001
From: JeffBezanson <jeff.bezanson@gmail.com>
Date: Sun, 19 Apr 2009 16:48:09 +0000
Subject: [PATCH] allowing (copy x) and other byte stream functions only on
 plain-old-data types adding plain-old-data? predicate adding string.join

---
 femtolisp/cvalues.c  | 38 +++++++++++++++++++++++++++-----------
 femtolisp/flisp.h    |  1 +
 femtolisp/iostream.c |  2 +-
 femtolisp/system.lsp |  9 +++++++++
 4 files changed, 38 insertions(+), 12 deletions(-)

diff --git a/femtolisp/cvalues.c b/femtolisp/cvalues.c
index b9b6e0d..d3f8bb4 100644
--- a/femtolisp/cvalues.c
+++ b/femtolisp/cvalues.c
@@ -583,27 +583,32 @@ size_t ctype_sizeof(value_t type, int *palign)
     return 0;
 }
 
+extern fltype_t *iostreamtype;
+
 // get pointer and size for any plain-old-data value
 void to_sized_ptr(value_t v, char *fname, char **pdata, size_t *psz)
 {
-    if (isiostream(v) && (value2c(ios_t*,v)->bm == bm_mem)) {
-        ios_t *x = value2c(ios_t*,v);
-        *pdata = x->buf;
-        *psz = x->size;
-    }
-    else if (iscvalue(v)) {
+    if (iscvalue(v)) {
         cvalue_t *pcv = (cvalue_t*)ptr(v);
-        *pdata = cv_data(pcv);
-        *psz = cv_len(pcv);
+        ios_t *x = value2c(ios_t*,v);
+        if (cv_class(pcv) == iostreamtype && (x->bm == bm_mem)) {
+            *pdata = x->buf;
+            *psz = x->size;
+            return;
+        }
+        else if (cv_isPOD(pcv)) {
+            *pdata = cv_data(pcv);
+            *psz = cv_len(pcv);
+            return;
+        }
     }
     else if (iscprim(v)) {
         cprim_t *pcp = (cprim_t*)ptr(v);
         *pdata = cp_data(pcp);
         *psz = cp_class(pcp)->size;
+        return;
     }
-    else {
-        type_error(fname, "bytes", v);
-    }
+    type_error(fname, "plain-old-data", v);
 }
 
 value_t cvalue_sizeof(value_t *args, u_int32_t nargs)
@@ -691,9 +696,19 @@ value_t fl_copy(value_t *args, u_int32_t nargs)
         lerror(ArgError, "copy: argument must be a leaf atom");
     if (!iscvalue(args[0]))
         return args[0];
+    if (!cv_isPOD((cvalue_t*)ptr(args[0])))
+        lerror(ArgError, "copy: argument must be a plain-old-data type");
     return cvalue_copy(args[0]);
 }
 
+value_t fl_podp(value_t *args, u_int32_t nargs)
+{
+    argcount("plain-old-data?", nargs, 1);
+    return (iscprim(args[0]) ||
+            (iscvalue(args[0]) && cv_isPOD((cvalue_t*)ptr(args[0])))) ?
+        FL_T : FL_F;
+}
+
 value_t fl_cv_pin(value_t *args, u_int32_t nargs)
 {
     argcount("cvalue.pin", nargs, 1);
@@ -908,6 +923,7 @@ static builtinspec_t cvalues_builtin_info[] = {
     { "builtin", fl_builtin },
     { "copy", fl_copy },
     { "cvalue.pin", fl_cv_pin },
+    { "plain-old-data?", fl_podp },
 
     { "logand", fl_logand },
     { "logior", fl_logior },
diff --git a/femtolisp/flisp.h b/femtolisp/flisp.h
index dae0b3c..2a7d052 100644
--- a/femtolisp/flisp.h
+++ b/femtolisp/flisp.h
@@ -236,6 +236,7 @@ typedef struct {
 #define cv_type(cv)    (cv_class(cv)->type)
 #define cv_data(cv)    ((cv)->data)
 #define cv_isstr(cv)   (cv_class(cv)->eltype == bytetype)
+#define cv_isPOD(cv)   (cv_class(cv)->init != NULL)
 
 #define cvalue_data(v) cv_data((cvalue_t*)ptr(v))
 #define value2c(type, v) ((type)cv_data((cvalue_t*)ptr(v)))
diff --git a/femtolisp/iostream.c b/femtolisp/iostream.c
index 2063e5c..8deb2f4 100644
--- a/femtolisp/iostream.c
+++ b/femtolisp/iostream.c
@@ -9,7 +9,7 @@
 
 static value_t iostreamsym, rdsym, wrsym, apsym, crsym, truncsym;
 static value_t instrsym, outstrsym;
-static fltype_t *iostreamtype;
+fltype_t *iostreamtype;
 
 void print_iostream(value_t v, ios_t *f, int princ)
 {
diff --git a/femtolisp/system.lsp b/femtolisp/system.lsp
index e8b8be4..6ee273e 100644
--- a/femtolisp/system.lsp
+++ b/femtolisp/system.lsp
@@ -598,6 +598,15 @@
     (io.print b v)
     (io.tostring! b)))
 
+(define (string.join strlist sep)
+  (if (null? strlist) ""
+      (let ((b (buffer)))
+	(io.write b (car strlist))
+	(for-each (lambda (s) (begin (io.write b sep)
+				     (io.write b s)))
+		  (cdr strlist))
+	(io.tostring! b))))
+
 ; toplevel --------------------------------------------------------------------
 
 (define (macrocall? e) (and (symbol? (car e))