adding io.print and io.princ

misc. touch-ups
This commit is contained in:
JeffBezanson 2009-02-09 05:38:40 +00:00
parent 1097597437
commit 79e12b2dcb
5 changed files with 61 additions and 51 deletions

View File

@ -35,30 +35,6 @@ value_t list_nth(value_t l, size_t n)
return NIL;
}
value_t fl_print(value_t *args, u_int32_t nargs)
{
unsigned i;
for (i=0; i < nargs; i++)
print(ios_stdout, args[i], 0);
ios_putc('\n', ios_stdout);
return nargs ? args[nargs-1] : NIL;
}
value_t fl_princ(value_t *args, u_int32_t nargs)
{
unsigned i;
for (i=0; i < nargs; i++)
print(ios_stdout, args[i], 1);
return nargs ? args[nargs-1] : NIL;
}
value_t fl_read(value_t *args, u_int32_t nargs)
{
(void)args;
argcount("read", nargs, 0);
return read_sexpr(ios_stdin);
}
value_t fl_load(value_t *args, u_int32_t nargs)
{
argcount("load", nargs, 1);
@ -317,7 +293,7 @@ value_t fl_path_cwd(value_t *args, uint32_t nargs)
}
char *ptr = tostring(args[0], "path.cwd");
if (set_cwd(ptr))
lerror(IOError, "could not cd to %s", ptr);
lerror(IOError, "path.cwd: could not cd to %s", ptr);
return FL_T;
}
@ -399,9 +375,6 @@ static builtinspec_t builtin_info[] = {
{ "environment", fl_global_env },
{ "constant?", fl_constantp },
{ "print", fl_print },
{ "princ", fl_princ },
{ "read", fl_read },
{ "load", fl_load },
{ "exit", fl_exit },
{ "intern", fl_intern },

View File

@ -24,17 +24,17 @@
(define (funcall/cc f k . args)
(if (and (pair? f) (eq (car f) 'lambda/cc))
(apply f (cons k args))
(k (apply f args))))
(k (apply f args))))
(define *funcall/cc-names*
(list-to-vector
(map (lambda (i) (intern (string 'funcall/cc- i)))
(iota 6))))
(define-macro (def-funcall/cc-n args)
(let* ((name (aref *funcall/cc-names* (length args))))
(let ((name (aref *funcall/cc-names* (length args))))
`(define (,name f k ,@args)
(if (and (pair? f) (eq (car f) 'lambda/cc))
(f k ,@args)
(k (f ,@args))))))
(k (f ,@args))))))
(def-funcall/cc-n ())
(def-funcall/cc-n (a0))
(def-funcall/cc-n (a0 a1))

View File

@ -7,14 +7,14 @@
#include "llt.h"
#include "flisp.h"
static value_t iostreamsym, rdsym, wrsym, apsym, crsym, truncsym;
static value_t iostreamsym, rdsym, wrsym, apsym, crsym, truncsym, instrsym;
static fltype_t *iostreamtype;
void print_iostream(value_t v, ios_t *f, int princ)
{
(void)v;
(void)princ;
fl_print_str("#<iostream>", f);
fl_print_str("#<io stream>", f);
}
void free_iostream(value_t self)
@ -71,25 +71,54 @@ value_t fl_file(value_t *args, uint32_t nargs)
value_t f = cvalue(iostreamtype, sizeof(ios_t));
ios_t *s = value2c(ios_t*, f);
if (ios_file(s, fname, r, w, c, t) == NULL)
lerror(IOError, "could not open file \"%s\"", fname);
lerror(IOError, "file: could not open \"%s\"", fname);
if (a) ios_seek_end(s);
return f;
}
value_t fl_ioread(value_t *args, u_int32_t nargs)
value_t fl_read(value_t *args, u_int32_t nargs)
{
argcount("io.read", nargs, 1);
ios_t *s = toiostream(args[0], "io.read");
if (nargs > 1)
argcount("read", nargs, 1);
ios_t *s;
if (nargs > 0)
s = toiostream(args[0], "read");
else
s = toiostream(symbol_value(instrsym), "read");
value_t v = read_sexpr(s);
if (ios_eof(s))
lerror(IOError, "end of file reached");
lerror(IOError, "read: end of file reached");
return v;
}
static void do_ioprint(value_t *args, u_int32_t nargs, int princ, char *fname)
{
if (nargs < 2)
argcount(fname, nargs, 2);
ios_t *s = toiostream(args[0], fname);
unsigned i;
for (i=1; i < nargs; i++) {
print(s, args[i], princ);
if (!princ) ios_putc('\n', s);
}
}
value_t fl_ioprint(value_t *args, u_int32_t nargs)
{
do_ioprint(args, nargs, 0, "io.print");
return args[nargs-1];
}
value_t fl_ioprinc(value_t *args, u_int32_t nargs)
{
do_ioprint(args, nargs, 1, "io.princ");
return args[nargs-1];
}
static builtinspec_t iostreamfunc_info[] = {
{ "iostream?", fl_iostreamp },
{ "file", fl_file },
{ "io.read", fl_ioread },
{ "read", fl_read },
{ "io.print", fl_ioprint },
{ "io.princ", fl_ioprinc },
{ NULL, NULL }
};
@ -101,14 +130,15 @@ void iostream_init()
apsym = symbol(":append");
crsym = symbol(":create");
truncsym = symbol(":truncate");
instrsym = symbol("*input-stream*");
iostreamtype = define_opaque_type(iostreamsym, sizeof(ios_t),
&iostream_vtable, NULL);
assign_global_builtins(iostreamfunc_info);
setc(symbol("*stdout*"), cvalue_from_ref(iostreamtype, &ios_stdout,
setc(symbol("*stdout*"), cvalue_from_ref(iostreamtype, ios_stdout,
sizeof(ios_t), NIL));
setc(symbol("*stderr*"), cvalue_from_ref(iostreamtype, &ios_stderr,
setc(symbol("*stderr*"), cvalue_from_ref(iostreamtype, ios_stderr,
sizeof(ios_t), NIL));
setc(symbol("*stdin*" ), cvalue_from_ref(iostreamtype, &ios_stdin,
setc(symbol("*stdin*" ), cvalue_from_ref(iostreamtype, ios_stdin,
sizeof(ios_t), NIL));
}

View File

@ -23,22 +23,27 @@
(list 'set-syntax! (list 'quote (car form))
(list 'lambda (cdr form) (f-body body)))))
(define-macro (label name fn)
(list (list 'lambda (list name) (list 'set! name fn)) #f))
(define-macro (define form . body)
(if (symbol? form)
(list 'set! form (car body))
(list 'set! (car form) (list 'lambda (cdr form) (f-body body)))))
(define (set s v) (eval (list 'set! s (list 'quote v))))
(define *output-stream* *stdout*)
(define *input-stream* *stdin*)
(define (print . args)
(apply io.print (cons *output-stream* args)))
(define (princ . args)
(apply io.princ (cons *output-stream* args)))
(define (identity x) x)
(define (set s v) (eval (list 'set! s (list 'quote v))))
(define (map f lst)
(if (atom? lst) lst
(cons (f (car lst)) (map f (cdr lst)))))
(define-macro (label name fn)
(list (list 'lambda (list name) (list 'set! name fn)) #f))
(define-macro (let binds . body)
((lambda (lname)
(begin
@ -166,6 +171,7 @@
(define (mod x y) (- x (* (/ x y) y)))
(define remainder mod)
(define (abs x) (if (< x 0) (- x) x))
(define (identity x) x)
(define K prog1) ; K combinator ;)
(define (caar x) (car (car x)))

View File

@ -830,14 +830,15 @@ String API
IOStream API
read - (read[ stream]) ; get next sexpr from stream
print
princ
*read - (read[ stream]) ; get next sexpr from stream
*print
*princ
iostream - (stream[ cvalue-as-bytestream])
memstream
*file
io.eof
io.write - (io.write s cvalue)
*io.read - (io.read s ctype)
io.read - (io.read s ctype [len])
io.flush
io.close
io.pos - (io.pos s [set-pos])