adding functions io.copy, io.readall, time.fromstring

adding srfi-6 (string ports) functions
removing unnecessary behavior of sometimes printing int32s and int64s in
  hexadecimal

femtolisp/aliases.scm

@@ -2,6 +2,7 @@
 ; femtolisp procedures
 
 (define top-level-bound? bound?)
+(define (eval-core x) (eval x))
 
 (define vector-ref aref)
 (define vector-set! aset!)
@@ -65,5 +66,18 @@
 
 (define (input-port? x) (iostream? x))
 (define (output-port? x) (iostream? x))
-
-(define (eval-core x) (eval x))
+(define close-input-port io.close)
+(define close-output-port io.close)
+(define (read-char (s *input-stream*)) (io.getc s))
+(define (write-char c (s *output-stream*)) (io.putc s c))
+(define (open-input-string str)
+  (let ((b (buffer)))
+    (io.write b str)
+    (io.seek b 0)
+    b))
+(define (open-output-string) (buffer))
+(define (get-output-string b)
+  (let ((p (io.pos b)))
+    (io.seek b 0)
+    (prog1 (io.readall b)
+	   (io.seek b p))))

femtolisp/builtins.c

@@ -324,6 +324,17 @@ static value_t fl_time_string(value_t *args, uint32_t nargs)
     return string_from_cstr(buf);
 }
 
+static value_t fl_time_fromstring(value_t *args, uint32_t nargs)
+{
+    argcount("time.fromstring", nargs, 1);
+    char *ptr = tostring(args[0], "time.fromstring");
+    double t = parsetime(ptr);
+    int64_t it = (int64_t)t;
+    if ((double)it == t && fits_fixnum(it))
+        return fixnum(it);
+    return mk_double(t);
+}
+
 static value_t fl_path_cwd(value_t *args, uint32_t nargs)
 {
     if (nargs > 1)
@@ -433,6 +444,7 @@ static builtinspec_t builtin_info[] = {
 
     { "time.now", fl_time_now },
     { "time.string", fl_time_string },
+    { "time.fromstring", fl_time_fromstring },
 
     { "rand", fl_rand },
     { "rand.uint32", fl_rand32 },

femtolisp/iostream.c

@@ -299,6 +299,19 @@ value_t fl_iocopyuntil(value_t *args, u_int32_t nargs)
     return size_wrap(ios_copyuntil(dest, src, delim));
 }
 
+value_t fl_iocopy(value_t *args, u_int32_t nargs)
+{
+    if (nargs < 2 || nargs > 3)
+        argcount("io.copy", nargs, 2);
+    ios_t *dest = toiostream(args[0], "io.copy");
+    ios_t *src = toiostream(args[1], "io.copy");
+    if (nargs == 3) {
+        size_t n = toulong(args[2], "io.copy");
+        return size_wrap(ios_copy(dest, src, n));
+    }
+    return size_wrap(ios_copyall(dest, src));
+}
+
 value_t stream_to_string(value_t *ps)
 {
     value_t str;
@@ -344,6 +357,7 @@ static builtinspec_t iostreamfunc_info[] = {
     { "io.discardbuffer", fl_iopurge },
     { "io.read", fl_ioread },
     { "io.write", fl_iowrite },
+    { "io.copy", fl_iocopy },
     { "io.readuntil", fl_ioreaduntil },
     { "io.copyuntil", fl_iocopyuntil },
     { "io.tostring!", fl_iotostring },

femtolisp/print.c

@@ -501,8 +501,6 @@ static numerictype_t sym_to_numtype(value_t type);
 static void cvalue_printdata(ios_t *f, void *data, size_t len, value_t type,
                              int weak)
 {
-    int64_t tmp=0;
-
     if (type == bytesym) {
         unsigned char ch = *(unsigned char*)data;
         if (print_princ)
@@ -539,40 +537,6 @@ static void cvalue_printdata(ios_t *f, void *data, size_t len, value_t type,
             else HPOS+=ios_printf(f, "x%04x", (int)wc);
         }
     }
-    else if (type == int64sym
-#ifdef BITS64
-             || type == longsym
-#endif
-             ) {
-        int64_t i64 = *(int64_t*)data;
-        if (fits_fixnum(i64) || print_princ) {
-            if (weak || print_princ)
-                HPOS+=ios_printf(f, "%lld", i64);
-            else
-                HPOS+=ios_printf(f, "#%s(%lld)", symbol_name(type), i64);
-        }
-        else
-            HPOS+=ios_printf(f, "#%s(0x%08x%08x)", symbol_name(type),
-                             (uint32_t)(i64>>32),
-                             (uint32_t)(i64));
-    }
-    else if (type == uint64sym
-#ifdef BITS64
-             || type == ulongsym
-#endif
-             ) {
-        uint64_t ui64 = *(uint64_t*)data;
-        if (fits_fixnum(ui64) || print_princ) {
-            if (weak || print_princ)
-                HPOS+=ios_printf(f, "%llu", ui64);
-            else
-                HPOS+=ios_printf(f, "#%s(%llu)", symbol_name(type), ui64);
-        }
-        else
-            HPOS+=ios_printf(f, "#%s(0x%08x%08x)", symbol_name(type),
-                             (uint32_t)(ui64>>32),
-                             (uint32_t)(ui64));
-    }
     else if (type == floatsym || type == doublesym) {
         char buf[64];
         double d;
@@ -607,19 +571,25 @@ static void cvalue_printdata(ios_t *f, void *data, size_t len, value_t type,
                 outc('f', f);
         }
     }
-    else if (issymbol(type)) {
-        // handle other integer prims. we know it's smaller than 64 bits
-        // at this point, so int64 is big enough to capture everything.
-        tmp = conv_to_int64(data, sym_to_numtype(type));
-        if (fits_fixnum(tmp) || print_princ) {
-            if (weak || print_princ)
-                HPOS+=ios_printf(f, "%lld", tmp);
-            else
-                HPOS+=ios_printf(f, "#%s(%lld)", symbol_name(type), tmp);
-        }
+    else if (type == uint64sym
+#ifdef BITS64
+             || type == ulongsym
+#endif
+             ) {
+        uint64_t ui64 = *(uint64_t*)data;
+        if (weak || print_princ)
+            HPOS += ios_printf(f, "%llu", ui64);
         else
-            HPOS+=ios_printf(f, "#%s(0x%08x)", symbol_name(type),
-                             (uint32_t)(tmp&0xffffffff));
+            HPOS += ios_printf(f, "#%s(%llu)", symbol_name(type), ui64);
+    }
+    else if (issymbol(type)) {
+        // handle other integer prims. we know it's smaller than uint64
+        // at this point, so int64 is big enough to capture everything.
+        int64_t i64 = conv_to_int64(data, sym_to_numtype(type));
+        if (weak || print_princ)
+            HPOS += ios_printf(f, "%lld", i64);
+        else
+            HPOS += ios_printf(f, "#%s(%lld)", symbol_name(type), i64);
     }
     else if (iscons(type)) {
         if (car_(type) == arraysym) {

femtolisp/system.lsp

@@ -544,6 +544,11 @@
 (define (io.readlines s) (read-all-of io.readline s))
 (define (read-all s) (read-all-of read s))
 
+(define (io.readall s)
+  (let ((b (buffer)))
+    (io.copy b s)
+    (io.tostring! b)))
+
 (define-macro (with-output-to stream . body)
   `(with-bindings ((*output-stream* ,stream))
 		  ,@body))

femtolisp/todo

@@ -139,6 +139,7 @@ for internal use:
 x preallocate all byte,int8,uint8 values, and some wchars (up to 0x31B7?)
   . this made no difference in a string.map microbenchmark
 - use faster hash/compare in tables where the keys are eq-comparable
+- a way to do open-input-string without copying
 
 bugs:
 * with the fully recursive (simpler) relocate(), the size of cons chains
@@ -869,10 +870,11 @@ IOStream API
 *io.read      - (io.read s ctype [len])
 *io.getc      - get utf8 character
 *io.putc
+ io.peekc
 *io.readline
 *io.readuntil
- io.copy      - (io.copy to from [nbytes])
- io.copyuntil - (io.copy to from byte)
+*io.copy      - (io.copy to from [nbytes])
+*io.copyuntil - (io.copy to from byte)
  io.pos       - (io.pos s [set-pos])
  io.seek      - (io.seek s offset)
  io.seekend   - move to end of stream
@@ -880,7 +882,7 @@ IOStream API
  io.read!     - destructively take data
 *io.tostring!
 *io.readlines
- io.readall
+*io.readall
 *print-to-string
 *princ-to-string
 
@@ -899,7 +901,7 @@ IOStream API
  time.parts
  time.fromparts
 *time.string
- time.fromstring
+*time.fromstring
 
 
 *os.name
@@ -964,10 +966,10 @@ consolidated todo list as of 7/8:
 * new toplevel
 
 * make raising a memory error non-consing
-- eliminate string copy in lerror() when possible
+* eliminate string copy in lerror() when possible
 * fix printing lists of short strings
 
-- evaluator improvements, perf & debugging (below)
+* evaluator improvements, perf & debugging (below)
 * fix make-system-image to save aliases of builtins
 * reading named characters, e.g. #\newline etc.
 - #+, #- reader macros
@@ -1043,7 +1045,7 @@ new evaluator todo:
   * stack traces and better debugging support
 * improve internal define
 * try removing MAX_ARGS trickery
-- apply optimization, avoid redundant list copying calling vararg fns
+? apply optimization, avoid redundant list copying calling vararg fns
 - let eversion
 - variable analysis - avoid holding references to values in frames
   captured by closures but not used inside them

llt/ios.c

@@ -303,15 +303,17 @@ size_t ios_readall(ios_t *s, char *dest, size_t n)
 
 size_t ios_readprep(ios_t *s, size_t n)
 {
+    if (s->state == bst_wr && s->bm != bm_mem) {
+        ios_flush(s);
+        s->bpos = s->size = 0;
+    }
     size_t space = s->size - s->bpos;
-    if (s->state == bst_wr)
-        return space;
     s->state = bst_rd;
     if (space >= n || s->bm == bm_mem || s->fd == -1)
         return space;
     if (s->maxsize < s->bpos+n) {
         // it won't fit. grow buffer or move data back.
-        if (n <= s->maxsize && space <= ((s->maxsize)>>5)) {
+        if (n <= s->maxsize && space <= ((s->maxsize)>>2)) {
             if (space)
                 memmove(s->buf, s->buf+s->bpos, space);
             s->size -= s->bpos;
@@ -615,16 +617,40 @@ void ios_bswap(ios_t *s, int bswap)
     s->byteswap = !!bswap;
 }
 
-static int ios_copy_(ios_t *to, ios_t *from, size_t nbytes, bool_t all)
+static size_t ios_copy_(ios_t *to, ios_t *from, size_t nbytes, bool_t all)
 {
+    size_t total = 0, avail;
+    if (!ios_eof(from)) {
+        do {
+            avail = ios_readprep(from, IOS_BUFSIZE/2);
+            if (avail == 0) {
+                from->_eof = 1;
+                break;
+            }
+            size_t written, ntowrite;
+            ntowrite = (avail <= nbytes || all) ? avail : nbytes;
+            written = ios_write(to, from->buf+from->bpos, ntowrite);
+            // TODO: should this be +=written instead?
+            from->bpos += ntowrite;
+            total += written;
+            if (!all) {
+                nbytes -= written;
+                if (nbytes == 0)
+                    break;
+            }
+            if (written < ntowrite)
+                break;
+        } while (!ios_eof(from));
+    }
+    return total;
 }
 
-int ios_copy(ios_t *to, ios_t *from, size_t nbytes)
+size_t ios_copy(ios_t *to, ios_t *from, size_t nbytes)
 {
     return ios_copy_(to, from, nbytes, 0);
 }
 
-int ios_copyall(ios_t *to, ios_t *from)
+size_t ios_copyall(ios_t *to, ios_t *from)
 {
     return ios_copy_(to, from, 0, 1);
 }

llt/ios.h

@@ -78,8 +78,8 @@ int ios_setbuf(ios_t *s, char *buf, size_t size, int own);
 int ios_bufmode(ios_t *s, bufmode_t mode);
 void ios_set_readonly(ios_t *s);
 void ios_bswap(ios_t *s, int bswap);
-int ios_copy(ios_t *to, ios_t *from, size_t nbytes);
-int ios_copyall(ios_t *to, ios_t *from);
+size_t ios_copy(ios_t *to, ios_t *from, size_t nbytes);
+size_t ios_copyall(ios_t *to, ios_t *from);
 size_t ios_copyuntil(ios_t *to, ios_t *from, char delim);
 // ensure at least n bytes are buffered if possible. returns # available.
 size_t ios_readprep(ios_t *from, size_t n);