adding offset and count arguments to io.write

making io.write output chars as utf8;
  suddenly switching to UTF32 was not intuitive
adding stream argument to newline (R6RS)
adding several more scheme compatibility procedures

femtolisp/aliases.scm

@@ -64,6 +64,16 @@
 (define (string-ref s i)
   (string.char s (string.inc s 0 i)))
 
+(define (list->string l) (apply string l))
+(define (string->list s)
+  (do ((i (sizeof s) i)
+       (l '() (cons (string.char s i) l)))
+      ((= i 0) l)
+    (set! i (string.dec s i))))
+
+(define (substring s start end)
+  (string.sub s (string.inc s 0 start) (string.inc s 0 end)))
+
 (define (input-port? x) (iostream? x))
 (define (output-port? x) (iostream? x))
 (define close-input-port io.close)
@@ -81,3 +91,94 @@
     (io.seek b 0)
     (prog1 (io.readall b)
 	   (io.seek b p))))
+
+(define (open-input-file name) (file name :read))
+(define (open-output-file name) (file name :write :create))
+
+(define (current-input-port (p *input-stream*))
+  (set! *input-stream* p))
+(define (current-output-port (p *output-stream*))
+  (set! *output-stream* p))
+
+(define get-datum read)
+(define (put-datum port x)
+  (with-bindings ((*print-readably* #t))
+		 (write x port)))
+
+(define (put-u8 port o) (io.write port (uint8 o)))
+(define (put-string port s (start 0) (count #f))
+  (let* ((start (string.inc s 0 start))
+	 (end (if count
+		  (string.inc s start count)
+		  (sizeof s))))
+    (io.write port s start (- end start))))
+
+(define (with-output-to-file name thunk)
+  (let ((f (file name :write :create :truncate)))
+    (unwind-protect
+     (with-output-to f (thunk))
+     (io.close f))))
+
+(define (with-input-from-file name thunk)
+  (let ((f (file name :read)))
+    (unwind-protect
+     (with-output-to f (thunk))
+     (io.close f))))
+
+(define (call-with-input-file name proc)
+  (let ((f (open-input-file name)))
+    (prog1 (proc f)
+	   (io.close f))))
+
+(define (call-with-output-file name proc)
+  (let ((f (open-output-file name)))
+    (prog1 (proc f)
+	   (io.close f))))
+
+(define (display x (port *output-stream*))
+  (with-output-to port (princ x))
+  #t)
+
+(define assertion-violation 
+  (lambda args 
+    (display 'assertion-violation)
+    (newline)
+    (display args)
+    (newline)
+    (car #f)))
+
+(define pretty-print write)
+
+(define (memp proc ls)
+  (cond ((null? ls) #f)
+        ((pair? ls) (if (proc (car ls))
+                        ls
+                        (memp proc (cdr ls))))
+        (else (assertion-violation 'memp "Invalid argument" ls))))
+
+(define (assp pred lst)
+  (cond ((atom? lst) #f)
+	((pred       (caar lst)) (car lst))
+	(else        (assp pred  (cdr lst)))))
+
+(define (for-all proc l . ls)
+  (or (null? l)
+      (and (apply proc (car l) (map car ls))
+           (apply for-all proc (cdr l) (map cdr ls)))))
+
+(define (exists proc l . ls)
+  (and (not (null? l))
+       (or (apply proc (car l) (map car ls))
+	   (apply exists proc (cdr l) (map cdr ls)))))
+
+(define cons* list*)
+
+(define (fold-left f zero lst)
+  (if (null? lst) zero
+      (fold-left f (f zero (car lst)) (cdr lst))))
+
+(define fold-right foldr)
+
+(define (partition pred lst)
+  (let ((s (separate pred lst)))
+    (values (car s) (cdr s))))

femtolisp/iostream.c

@@ -119,10 +119,9 @@ value_t fl_ioputc(value_t *args, u_int32_t nargs)
 {
     argcount("io.putc", nargs, 2);
     ios_t *s = toiostream(args[0], "io.putc");
-    uint32_t wc;
     if (!iscprim(args[1]) || ((cprim_t*)ptr(args[1]))->type != wchartype)
         type_error("io.putc", "wchar", args[1]);
-    wc = *(uint32_t*)cp_data((cprim_t*)ptr(args[1]));
+    uint32_t wc = *(uint32_t*)cp_data((cprim_t*)ptr(args[1]));
     return fixnum(ios_pututf8(s, wc));
 }
 
@@ -220,15 +219,42 @@ value_t fl_ioread(value_t *args, u_int32_t nargs)
     return cv;
 }
 
+// args must contain data[, offset[, count]]
+static void get_start_count_args(value_t *args, uint32_t nargs, size_t sz,
+                                 size_t *offs, size_t *nb, char *fname)
+{
+    if (nargs > 1) {
+        *offs = toulong(args[1], fname);
+        if (nargs > 2)
+            *nb = toulong(args[2], fname);
+        else
+            *nb = sz - *offs;
+        if (*offs >= sz || *offs + *nb > sz)
+            bounds_error(fname, args[0], args[1]);
+    }
+}
+
 value_t fl_iowrite(value_t *args, u_int32_t nargs)
 {
-    argcount("io.write", nargs, 2);
+    if (nargs < 2 || nargs > 4)
+        argcount("io.write", nargs, 2);
     ios_t *s = toiostream(args[0], "io.write");
+    if (iscprim(args[1]) && ((cprim_t*)ptr(args[1]))->type == wchartype) {
+        if (nargs > 2)
+            lerror(ArgError,
+                   "io.write: offset argument not supported for characters");
+        uint32_t wc = *(uint32_t*)cp_data((cprim_t*)ptr(args[1]));
+        return fixnum(ios_pututf8(s, wc));
+    }
     char *data;
-    size_t sz;
+    size_t sz, offs=0;
     to_sized_ptr(args[1], "io.write", &data, &sz);
-    size_t n = ios_write(s, data, sz);
-    return size_wrap(n);
+    size_t nb = sz;
+    if (nargs > 2) {
+        get_start_count_args(&args[1], nargs-1, sz, &offs, &nb, "io.write");
+        data += offs;
+    }
+    return size_wrap(ios_write(s, data, nb));
 }
 
 value_t fl_dump(value_t *args, u_int32_t nargs)
@@ -237,17 +263,11 @@ value_t fl_dump(value_t *args, u_int32_t nargs)
         argcount("dump", nargs, 1);
     ios_t *s = toiostream(symbol_value(outstrsym), "dump");
     char *data;
-    size_t sz, offs=0, nb;
+    size_t sz, offs=0;
     to_sized_ptr(args[0], "dump", &data, &sz);
-    nb = sz;
+    size_t nb = sz;
     if (nargs > 1) {
-        offs = toulong(args[1], "dump");
-        if (nargs > 2)
-            nb = toulong(args[2], "dump");
-        else
-            nb = sz - offs;
-        if (offs >= sz || offs+nb > sz)
-            bounds_error("dump", args[0], args[1]);
+        get_start_count_args(args, nargs, sz, &offs, &nb, "dump");
         data += offs;
     }
     hexdump(s, data, nb, offs);

femtolisp/system.lsp

@@ -275,11 +275,11 @@
 
 (define (foldr f zero lst)
   (if (null? lst) zero
-    (f (car lst) (foldr f zero (cdr lst)))))
+      (f (car lst) (foldr f zero (cdr lst)))))
 
 (define (foldl f zero lst)
   (if (null? lst) zero
-    (foldl f (f (car lst) zero) (cdr lst))))
+      (foldl f (f (car lst) zero) (cdr lst))))
 
 (define (reverse lst) (foldl cons () lst))
 
@@ -488,7 +488,8 @@
 (define-macro (assert expr) `(if ,expr #t (raise '(assert-failed ,expr))))
 
 (define traced?
-  (letrec ((sample-traced-lambda (lambda args (begin (println (cons 'x args))
+  (letrec ((sample-traced-lambda (lambda args (begin (write (cons 'x args))
+						     (newline)
 						     (apply #.apply args)))))
     (lambda (f)
       (equal? (function:code f)
@@ -501,7 +502,8 @@
 	(set-top-level-value! sym
 			      (eval
 			       `(lambda ,args
-				  (begin (println (cons ',sym ,args))
+				  (begin (write (cons ',sym ,args))
+					 (newline)
 					 (apply ',func ,args)))))))
   'ok)
 
@@ -525,11 +527,9 @@
   (with-bindings ((*print-readably* #f))
 		 (for-each write args)))
 
-(define (newline) (princ *linefeed*) #t)
-(define (display x (port *output-stream*))
-  (with-output-to port (princ x))
+(define (newline (port *output-stream*))
+  (io.write port *linefeed*)
   #t)
-(define (println . args) (prog1 (apply print args) (newline)))
 
 (define (io.readline s) (io.readuntil s #\linefeed))
 
@@ -553,13 +553,6 @@
   `(with-bindings ((*output-stream* ,stream))
 		  ,@body))
 
-(define (with-output-to-file name thunk)
-  (let ((f (file name :write :create :truncate)))
-    (unwind-protect
-     (with-bindings ((*output-stream* f))
-		    (thunk))
-     (io.close f))))
-
 ; vector functions ------------------------------------------------------------
 
 (define (list->vector l) (apply vector l))

femtolisp/todo

@@ -866,7 +866,7 @@ IOStream API
 *io.flush
 *io.close
 *io.discardbuffer
-*io.write     - (io.write s cvalue)
+*io.write     - (io.write s cvalue [start [count]])
 *io.read      - (io.read s ctype [len])
 *io.getc      - get utf8 character
 *io.putc

femtolisp/torture.scm

@@ -1,6 +1,6 @@
 (define ones (map (lambda (x) 1) (iota 1000000)))
 
-(display (apply + ones))
+(write (apply + ones))
 (newline)
 
 (define (big n)
@@ -10,15 +10,15 @@
 
 (define nst (big 100000))
 
-(display (eval nst))
+(write (eval nst))
 (newline)
 
 (define longg (cons '+ ones))
-(display (eval longg))
+(write (eval longg))
 (newline)
 
 (define (f x)
-  (begin (display x)
+  (begin (write x)
 	 (newline)
 	 (f (+ x 1))
 	 0))

llt/ios.c

@@ -859,6 +859,8 @@ int ios_getutf8(ios_t *s, uint32_t *pwc)
 int ios_pututf8(ios_t *s, uint32_t wc)
 {
     char buf[8];
+    if (wc < 0x80)
+        return ios_putc((int)wc, s);
     size_t n = u8_toutf8(buf, 8, &wc, 1);
     return ios_write(s, buf, n);
 }