ref: 3fbd5e7da60f0f537a99cd65c680a0017a71a100
parent: 302ddec77092fd3cd32b21a026bc907f0b402264
author: JeffBezanson <jeff.bezanson@gmail.com>
date: Sat Aug 8 19:43:12 EDT 2009
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
--- 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);