shithub: femtolisp

--- a/femtolisp/aliases.scm

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

--- a/femtolisp/iostream.c

+++ b/femtolisp/iostream.c

@@ -119,10 +119,9 @@

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

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

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

--- a/femtolisp/system.lsp

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

@@ -552,13 +552,6 @@

 (define-macro (with-output-to stream . body)

   `(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 ------------------------------------------------------------

--- a/femtolisp/todo

+++ b/femtolisp/todo

@@ -866,7 +866,7 @@

 *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

--- a/femtolisp/torture.scm

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

--- a/llt/ios.c

+++ b/llt/ios.c

@@ -859,6 +859,8 @@

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