shithub: femtolisp

--- a/femtolisp/aliases.scm

+++ b/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))))

--- a/femtolisp/builtins.c

+++ b/femtolisp/builtins.c

@@ -324,6 +324,17 @@

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

     { "time.now", fl_time_now },

     { "time.string", fl_time_string },

+    { "time.fromstring", fl_time_fromstring },

     { "rand", fl_rand },

     { "rand.uint32", fl_rand32 },

--- a/femtolisp/iostream.c

+++ b/femtolisp/iostream.c

@@ -299,6 +299,19 @@

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

     { "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 },

--- a/femtolisp/print.c

+++ b/femtolisp/print.c

@@ -501,8 +501,6 @@

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

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

                 outc('f', f);

+    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(%llu)", symbol_name(type), ui64);

+    }

     else if (issymbol(type)) {

-        // handle other integer prims. we know it's smaller than 64 bits

+        // handle other integer prims. we know it's smaller than uint64

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

-        }

+        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(0x%08x)", symbol_name(type),

-                             (uint32_t)(tmp&0xffffffff));

+            HPOS += ios_printf(f, "#%s(%lld)", symbol_name(type), i64);

     else if (iscons(type)) {

         if (car_(type) == arraysym) {

--- a/femtolisp/system.lsp

+++ b/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))

--- a/femtolisp/todo

+++ b/femtolisp/todo

@@ -139,6 +139,7 @@

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

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

  io.read!     - destructively take data

 *io.tostring!

 *io.readlines

- io.readall

+*io.readall

 *print-to-string

 *princ-to-string

@@ -899,7 +901,7 @@

  time.parts

  time.fromparts

 *time.string

- time.fromstring

+*time.fromstring

 *os.name

@@ -964,10 +966,10 @@

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

   * 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

--- a/llt/ios.c

+++ b/llt/ios.c

@@ -303,15 +303,17 @@

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

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

--- a/llt/ios.h

+++ b/llt/ios.h

@@ -78,8 +78,8 @@

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