shithub: femtolisp

Info  •  Files  •  Log  •  Branches

allowing (copy x) and other byte stream functions only on plain-old-data types
adding plain-old-data? predicate
adding string.join

--- a/femtolisp/cvalues.c

+++ b/femtolisp/cvalues.c

@@ -583,27 +583,32 @@

     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)) {

+    if (iscvalue(v)) {

+        cvalue_t *pcv = (cvalue_t*)ptr(v);

         ios_t *x = value2c(ios_t*,v);

-        *pdata = x->buf;

-        *psz = x->size;

+        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 (iscvalue(v)) {

-        cvalue_t *pcv = (cvalue_t*)ptr(v);

-        *pdata = cv_data(pcv);

-        *psz = cv_len(pcv);

-    }

     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 @@

         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 @@

     { "builtin", fl_builtin },

     { "copy", fl_copy },

     { "cvalue.pin", fl_cv_pin },

+    { "plain-old-data?", fl_podp },

     { "logand", fl_logand },

     { "logior", fl_logior },

--- a/femtolisp/flisp.h

+++ b/femtolisp/flisp.h

@@ -236,6 +236,7 @@

 #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)))

--- 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)

 {

--- 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))