ref: db94d6ef1f745bfc50211a20c0e4b3553bff72b0
parent: 3fbd5e7da60f0f537a99cd65c680a0017a71a100
author: JeffBezanson <[email protected]>
date: Sun Aug 9 00:04:31 EDT 2009
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
--- 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);
}