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

femtolisp/aliases.scm

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

femtolisp/flisp.c

@@ -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 NIL, FL_T, FL_F;
-value_t BACKQUOTE, COMMA, COMMAAT, COMMADOT, FUNCTION;
 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 printwidthsym, printreadablysym, printprettysym;
-value_t definesym, defmacrosym, forsym, labelsym, printprettysym, setqsym;
+
-value_t printwidthsym, printreadablysym;
+value_t QUOTE;
-value_t tsym, Tsym, fsym, Fsym, booleansym, nullsym, evalsym;
+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");
+    LAMBDA = symbol("lambda");        FUNCTION = symbol("function");
-    FUNCTION = symbol("function");
+    QUOTE = symbol("quote");          TRYCATCH = symbol("trycatch");
-    QUOTE = symbol("quote");
+    BACKQUOTE = symbol("backquote");  COMMA = symbol("*comma*");
-    TRYCATCH = symbol("trycatch");
+    COMMAAT = symbol("*comma-at*");   COMMADOT = symbol("*comma-dot*");
-    BACKQUOTE = symbol("backquote");
+    IOError = symbol("io-error");     ParseError = symbol("parse-error");
-    COMMA = symbol("*comma*");
+    TypeError = symbol("type-error"); ArgError = symbol("arg-error");
-    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");
+    KeyError = symbol("key-error");   MemoryError = symbol("memory-error");
-    MemoryError = symbol("memory-error");
     BoundsError = symbol("bounds-error");
     DivideError = symbol("divide-error");
     EnumerationError = symbol("enumeration-error");
-    Error = symbol("error");
+    Error = symbol("error");          pairsym = symbol("pair");
-    pairsym = symbol("pair");
+    symbolsym = symbol("symbol");     fixnumsym = symbol("fixnum");
-    symbolsym = symbol("symbol");
+    vectorsym = symbol("vector");     builtinsym = symbol("builtin");
-    fixnumsym = symbol("fixnum");
+    booleansym = symbol("boolean");   nullsym = symbol("null");
-    vectorsym = symbol("vector");
+    definesym = symbol("define");     defmacrosym = symbol("define-macro");
-    builtinsym = symbol("builtin");
+    forsym = symbol("for");           labelsym = symbol("label");
-    booleansym = symbol("boolean");
+    setqsym = symbol("set!");         evalsym = symbol("eval");
-    nullsym = symbol("null");
+    vu8sym = symbol("vu8");           fnsym = symbol("fn");
-    definesym = symbol("define");
+    nulsym = symbol("nul");           alarmsym = symbol("alarm");
-    defmacrosym = symbol("define-macro");
+    backspacesym = symbol("backspace"); tabsym = symbol("tab");
-    forsym = symbol("for");
+    linefeedsym = symbol("linefeed"); vtabsym = symbol("vtab");
-    labelsym = symbol("label");
+    pagesym = symbol("page");         returnsym = symbol("return");
-    setqsym = symbol("set!");
+    escsym = symbol("esc");           spacesym = symbol("space");
-    evalsym = symbol("eval");
+    deletesym = symbol("delete");     newlinesym = symbol("newline");
-    vu8sym = symbol("vu8");
     tsym = symbol("t"); Tsym = symbol("T");
     fsym = symbol("f"); Fsym = symbol("F");
     set(printprettysym=symbol("*print-pretty*"), FL_T);

femtolisp/flisp.h

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

femtolisp/print.c

@@ -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);
-            size_t nb = u8_toutf8(seq, sizeof(seq), &wc, 1);
+        seq[nb] = '\0';
-            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

femtolisp/read.c

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

femtolisp/system.lsp

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

femtolisp/todo

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