adding read and print support for named characters, e.g. #\space

printing infs and nans in R6RS format
making closure print syntax more compact; fn instead of function
adding more c[ad]+r functions
This commit is contained in:
JeffBezanson 2009-08-08 21:44:14 +00:00
parent 1a6d9d391f
commit 302ddec770
8 changed files with 124 additions and 50 deletions

View File

@ -7,6 +7,11 @@
(define vector-set! aset!)
(define vector-length length)
(define make-vector vector.alloc)
(define (vector-fill! v f)
(for 0 (- (length v) 1)
(lambda (i) (aset! v i f)))
#t)
(define (vector-map f v) (vector.map f v))
(define array-ref! aref)
(define (array-set! a obj i0 . idxs)
@ -23,18 +28,25 @@
(define (exact? x) (integer? x))
(define (inexact? x) (not (exact? x)))
(define quotient div0)
(define (inexact x) x)
(define (exact x)
(if (exact? x) x
(error "exact real numbers not supported")))
(define (finite? x) (and (< x +inf.0) (> x -inf.0)))
(define (infinite? x) (or (equal? x +inf.0) (equal? x -inf.0)))
(define (nan? x) (or (equal? x +nan.0) (equal? x -nan.0)))
(define (char->integer c) (fixnum c))
(define (integer->char i) (wchar i))
(define char-upcase char.upcase)
(define char-downcase char.downcase)
(define char=? =)
(define char=? eqv?)
(define char<? <)
(define char>? >)
(define char<=? <=)
(define char>=? >=)
(define string=? =)
(define string=? eqv?)
(define string<? <)
(define string>? >)
(define string<=? <=)
@ -44,6 +56,14 @@
(define string-length string.count)
(define string->symbol symbol)
(define (symbol->string s) (string s))
(define symbol=? eq?)
(define (make-string k (fill #\space))
(string.rep fill k))
(define (string-ref s i)
(string.char s (string.inc s 0 i)))
(define (input-port? x) (iostream? x))
(define (output-port? x) (iostream? x))
(define (eval-core x) (eval x))

File diff suppressed because one or more lines are too long

View File

@ -89,14 +89,21 @@ static uint32_t curr_frame = 0;
static value_t *GCHandleStack[N_GC_HANDLES];
static uint32_t N_GCHND = 0;
value_t NIL, FL_T, FL_F, LAMBDA, QUOTE, IF, TRYCATCH;
value_t BACKQUOTE, COMMA, COMMAAT, COMMADOT, FUNCTION;
value_t NIL, FL_T, FL_F;
value_t IOError, ParseError, TypeError, ArgError, UnboundError, MemoryError;
value_t DivideError, BoundsError, Error, KeyError, EnumerationError;
value_t pairsym, symbolsym, fixnumsym, vectorsym, builtinsym, vu8sym;
value_t definesym, defmacrosym, forsym, labelsym, printprettysym, setqsym;
value_t printwidthsym, printreadablysym;
value_t tsym, Tsym, fsym, Fsym, booleansym, nullsym, evalsym;
value_t printwidthsym, printreadablysym, printprettysym;
value_t QUOTE;
static value_t LAMBDA, IF, TRYCATCH;
static value_t BACKQUOTE, COMMA, COMMAAT, COMMADOT, FUNCTION;
static value_t pairsym, symbolsym, fixnumsym, vectorsym, builtinsym, vu8sym;
static value_t definesym, defmacrosym, forsym, labelsym, setqsym;
static value_t tsym, Tsym, fsym, Fsym, booleansym, nullsym, evalsym, fnsym;
// for reading characters
static value_t nulsym, alarmsym, backspacesym, tabsym, linefeedsym, newlinesym;
static value_t vtabsym, pagesym, returnsym, escsym, spacesym, deletesym;
static value_t apply_cl(uint32_t nargs);
static value_t *alloc_words(int n);
@ -2089,39 +2096,31 @@ static void lisp_init(void)
NIL = builtin(OP_THE_EMPTY_LIST);
FL_T = builtin(OP_BOOL_CONST_T);
FL_F = builtin(OP_BOOL_CONST_F);
LAMBDA = symbol("lambda");
FUNCTION = symbol("function");
QUOTE = symbol("quote");
TRYCATCH = symbol("trycatch");
BACKQUOTE = symbol("backquote");
COMMA = symbol("*comma*");
COMMAAT = symbol("*comma-at*");
COMMADOT = symbol("*comma-dot*");
IOError = symbol("io-error");
ParseError = symbol("parse-error");
TypeError = symbol("type-error");
ArgError = symbol("arg-error");
LAMBDA = symbol("lambda"); FUNCTION = symbol("function");
QUOTE = symbol("quote"); TRYCATCH = symbol("trycatch");
BACKQUOTE = symbol("backquote"); COMMA = symbol("*comma*");
COMMAAT = symbol("*comma-at*"); COMMADOT = symbol("*comma-dot*");
IOError = symbol("io-error"); ParseError = symbol("parse-error");
TypeError = symbol("type-error"); ArgError = symbol("arg-error");
UnboundError = symbol("unbound-error");
KeyError = symbol("key-error");
MemoryError = symbol("memory-error");
KeyError = symbol("key-error"); MemoryError = symbol("memory-error");
BoundsError = symbol("bounds-error");
DivideError = symbol("divide-error");
EnumerationError = symbol("enumeration-error");
Error = symbol("error");
pairsym = symbol("pair");
symbolsym = symbol("symbol");
fixnumsym = symbol("fixnum");
vectorsym = symbol("vector");
builtinsym = symbol("builtin");
booleansym = symbol("boolean");
nullsym = symbol("null");
definesym = symbol("define");
defmacrosym = symbol("define-macro");
forsym = symbol("for");
labelsym = symbol("label");
setqsym = symbol("set!");
evalsym = symbol("eval");
vu8sym = symbol("vu8");
Error = symbol("error"); pairsym = symbol("pair");
symbolsym = symbol("symbol"); fixnumsym = symbol("fixnum");
vectorsym = symbol("vector"); builtinsym = symbol("builtin");
booleansym = symbol("boolean"); nullsym = symbol("null");
definesym = symbol("define"); defmacrosym = symbol("define-macro");
forsym = symbol("for"); labelsym = symbol("label");
setqsym = symbol("set!"); evalsym = symbol("eval");
vu8sym = symbol("vu8"); fnsym = symbol("fn");
nulsym = symbol("nul"); alarmsym = symbol("alarm");
backspacesym = symbol("backspace"); tabsym = symbol("tab");
linefeedsym = symbol("linefeed"); vtabsym = symbol("vtab");
pagesym = symbol("page"); returnsym = symbol("return");
escsym = symbol("esc"); spacesym = symbol("space");
deletesym = symbol("delete"); newlinesym = symbol("newline");
tsym = symbol("t"); Tsym = symbol("T");
fsym = symbol("f"); Fsym = symbol("F");
set(printprettysym=symbol("*print-pretty*"), FL_T);

View File

@ -253,12 +253,13 @@ typedef float float_t;
typedef value_t (*builtin_t)(value_t*, uint32_t);
extern value_t QUOTE;
extern value_t int8sym, uint8sym, int16sym, uint16sym, int32sym, uint32sym;
extern value_t int64sym, uint64sym;
extern value_t longsym, ulongsym, bytesym, wcharsym;
extern value_t structsym, arraysym, enumsym, cfunctionsym, voidsym, pointersym;
extern value_t stringtypesym, wcstringtypesym, emptystringsym;
extern value_t unionsym, floatsym, doublesym, builtinsym;
extern value_t unionsym, floatsym, doublesym;
extern fltype_t *bytetype, *wchartype;
extern fltype_t *stringtype, *wcstringtype;
extern fltype_t *builtintype;

View File

@ -399,7 +399,7 @@ void fl_print_child(ios_t *f, value_t v)
if (!print_princ) {
if (print_circle_prefix(f, v)) return;
function_t *fn = (function_t*)ptr(v);
outs("#function(", f);
outs("#fn(", f);
char *data = cvalue_data(fn->bcode);
size_t i, sz = cvalue_len(fn->bcode);
for(i=0; i < sz; i++) data[i] += 48;
@ -515,15 +515,28 @@ static void cvalue_printdata(ios_t *f, void *data, size_t len, value_t type,
else if (type == wcharsym) {
uint32_t wc = *(uint32_t*)data;
char seq[8];
if (print_princ || iswprint(wc)) {
size_t nb = u8_toutf8(seq, sizeof(seq), &wc, 1);
seq[nb] = '\0';
size_t nb = u8_toutf8(seq, sizeof(seq), &wc, 1);
seq[nb] = '\0';
if (print_princ) {
// TODO: better multibyte handling
if (!print_princ) outsn("#\\", f, 2);
outs(seq, f);
}
else {
HPOS+=ios_printf(f, "#\\x%04x", (int)wc);
outsn("#\\", f, 2);
if (wc == 0x00) outsn("nul", f, 3);
else if (wc == 0x07) outsn("alarm", f, 5);
else if (wc == 0x08) outsn("backspace", f, 9);
else if (wc == 0x09) outsn("tab", f, 3);
else if (wc == 0x0A) outsn("linefeed", f, 8);
//else if (wc == 0x0A) outsn("newline", f, 7);
else if (wc == 0x0B) outsn("vtab", f, 4);
else if (wc == 0x0C) outsn("page", f, 4);
else if (wc == 0x0D) outsn("return", f, 6);
else if (wc == 0x1B) outsn("esc", f, 3);
else if (wc == 0x20) outsn("space", f, 5);
else if (wc == 0x7F) outsn("delete", f, 6);
else if (iswprint(wc)) outs(seq, f);
else HPOS+=ios_printf(f, "x%04x", (int)wc);
}
}
else if (type == int64sym
@ -569,9 +582,9 @@ static void cvalue_printdata(ios_t *f, void *data, size_t len, value_t type,
if (!DFINITE(d)) {
char *rep;
if (isnan(d))
rep = sign_bit(d) ? "-NaN" : "+NaN";
rep = sign_bit(d) ? "-nan.0" : "+nan.0";
else
rep = sign_bit(d) ? "-Inf" : "+Inf";
rep = sign_bit(d) ? "-inf.0" : "+inf.0";
if (type == floatsym && !print_princ && !weak)
HPOS+=ios_printf(f, "#%s(%s)", symbol_name(type), rep);
else

View File

@ -216,6 +216,25 @@ static u_int32_t peek()
cval = numval(tokval);
}
}
else if (cval >= 'a' && cval <= 'z') {
read_token((char)cval, 0);
tokval = symbol(buf);
if (buf[1] == '\0') /* one character */;
else if (tokval == nulsym) cval = 0x00;
else if (tokval == alarmsym) cval = 0x07;
else if (tokval == backspacesym) cval = 0x08;
else if (tokval == tabsym) cval = 0x09;
else if (tokval == linefeedsym) cval = 0x0A;
else if (tokval == newlinesym) cval = 0x0A;
else if (tokval == vtabsym) cval = 0x0B;
else if (tokval == pagesym) cval = 0x0C;
else if (tokval == returnsym) cval = 0x0D;
else if (tokval == escsym) cval = 0x1B;
else if (tokval == spacesym) cval = 0x20;
else if (tokval == deletesym) cval = 0x7F;
else
lerrorf(ParseError, "read: unknown character #\\%s", buf);
}
toktype = TOK_NUM;
tokval = mk_wchar(cval);
}
@ -580,6 +599,9 @@ static value_t do_read_sexpr(value_t label)
sym = arraysym;
Stack[SP-1] = fl_cons(uint8sym, Stack[SP-1]);
}
else if (sym == fnsym) {
sym = FUNCTION;
}
v = symbol_value(sym);
if (v == UNBOUND)
raise(list2(UnboundError, sym));

View File

@ -147,7 +147,22 @@
(define (cdadr x) (cdr (car (cdr x))))
(define (cddar x) (cdr (cdr (car x))))
(define (cdddr x) (cdr (cdr (cdr x))))
(define (caaaar x) (car (car (car (car x)))))
(define (caaadr x) (car (car (car (cdr x)))))
(define (caadar x) (car (car (cdr (car x)))))
(define (caaddr x) (car (car (cdr (cdr x)))))
(define (cadaar x) (car (cdr (car (car x)))))
(define (cadadr x) (car (cdr (car (cdr x)))))
(define (caddar x) (car (cdr (cdr (car x)))))
(define (cadddr x) (car (cdr (cdr (cdr x)))))
(define (cdaaar x) (cdr (car (car (car x)))))
(define (cdaadr x) (cdr (car (car (cdr x)))))
(define (cdadar x) (cdr (car (cdr (car x)))))
(define (cdaddr x) (cdr (car (cdr (cdr x)))))
(define (cddaar x) (cdr (cdr (car (car x)))))
(define (cddadr x) (cdr (cdr (car (cdr x)))))
(define (cdddar x) (cdr (cdr (cdr (car x)))))
(define (cddddr x) (cdr (cdr (cdr (cdr x)))))
(let ((*values* (list '*values*)))
(set! values
@ -511,10 +526,12 @@
(for-each write args)))
(define (newline) (princ *linefeed*) #t)
(define (display x) (princ x) #t)
(define (display x (port *output-stream*))
(with-output-to port (princ x))
#t)
(define (println . args) (prog1 (apply print args) (newline)))
(define (io.readline s) (io.readuntil s #\x0a))
(define (io.readline s) (io.readuntil s #\linefeed))
; call f on a stream until the stream runs out of data
(define (read-all-of f s)

View File

@ -643,6 +643,7 @@ low-level functions:
- (eltype type field [field ...])
- (memcpy dest-cv src-cv)
- (memcpy dest doffs src soffs nbytes)
- (bswap cvalue)
- (c2lisp cvalue) ; convert to sexpr form
* (typeof cvalue)
* (sizeof cvalue|type)
@ -968,7 +969,7 @@ consolidated todo list as of 7/8:
- evaluator improvements, perf & debugging (below)
* fix make-system-image to save aliases of builtins
- reading named characters, e.g. #\newline etc.
* reading named characters, e.g. #\newline etc.
- #+, #- reader macros
- printing improvements: *print-big*, keep track of horiz. position
per-stream so indenting works across print calls
@ -978,6 +979,7 @@ consolidated todo list as of 7/8:
* optional arguments
* keyword arguments
- some kind of record, struct, or object system
- improve test coverage
- special efficient reader for #array
- reimplement vectors as (array lispvalue)