ref: aa62ae9e9640131f1ce4e158f7834878df7fd8eb
parent: 2ed581e62d38eab49c5768459c41e6ae3dcb735c
author: JeffBezanson <jeff.bezanson@gmail.com>
date: Sun Apr 19 12:48:09 EDT 2009
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))