ref: 302ddec77092fd3cd32b21a026bc907f0b402264
parent: 1a6d9d391fd84f37656ec2abefe3f5736cd742b9
author: JeffBezanson <jeff.bezanson@gmail.com>
date: Sat Aug 8 17:44:14 EDT 2009
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
--- a/femtolisp/aliases.scm
+++ b/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))
--- a/femtolisp/flisp.boot
+++ b/femtolisp/flisp.boot
@@ -1,1 +1,1 @@
-(*banner* "; _\n; |_ _ _ |_ _ | . _ _\n; | (-||||_(_)|__|_)|_)\n;-------------------|----------------------------------------------------------\n\n" *syntax-environment* #table(with-bindings #function(">000s1c0qe1c2|32e1e3|32e1c4|3243;" [#function("B000r3e0c1L1e2c3g2|33L1e4e2c5|}3331c6e0c7L1e4\x7f3132e0c7L1e4e2c8|g2333132L3L144;" [nconc let map #.list copy-list #function("8000r2c0|}L3;" [set!]) unwind-protect begin #function("8000r2c0|}L3;" [set!])]) map #.car cadr #function("6000r1e040;" [gensym])]) letrec #function("?000s1e0e0c1L1e2c3|32L1e2c4|32e5}3134L1e2c6|3242;" [nconc lambda map #.car #function("9000r1e0c1L1e2|3142;" [nconc set! copy-list]) copy-list #function("6000r1^;" [])]) backquote #function("7000r1e0|41;" [bq-process]) assert #function("<000r1c0|]c1c2c3|L2L2L2L4;" [if raise quote assert-failed]) label #function(":000r2c0|L1c1|}L3L3^L2;" [lambda set!]) do #function("A000s2c0qe130}Me2c3|32e2e4|32e2c5|3245;" [#function("B000r5c0|c1g2c2}e3c4L1e5\x7fN3132e3c4L1e5i0231e3|L1g432L133L4L3L2L1e3|L1g332L3;" [letrec lambda if nconc begin copy-list]) gensym map #.car cadr #function("7000r1e0|31F680e1|41;|M;" [cddr caddr])]) when #function("<000s1c0|c1}K^L4;" [if begin]) dotimes #function(";000s1c0q|M|\x8442;" [#function("=000r2c0`c1}aL3e2c3L1|L1L1e4\x7f3133L4;" [for - nconc lambda copy-list])]) unwind-protect #function("8000r2c0qe130e13042;" [#function("@000r2c0}c1_\x7fL3L2L1c2c3~c1|L1c4}L1c5|L2L3L3L3}L1L3L3;" [let lambda prog1 trycatch begin raise]) gensym]) define-macro #function("?000s1c0c1|ML2e2c3L1|NL1e4}3133L3;" [set-syntax! quote nconc lambda copy-list]) receive #function("@000s2c0c1_}L3e2c1L1|L1e3g23133L3;" [call-with-values lambda nconc copy-list]) unless #function("=000s1c0|^c1}KL4;" [if begin]) let #function(":000s1c0q^41;" [#function("<000r1~C6D0~m02\x7fMo002\x7fNo01530^2c0qe1c2L1e3c4~32L1e5\x7f3133e3c6~3242;" [#function("8000r2~6;0c0~|L3530|}K;" [label]) nconc lambda map #function("6000r1|F650|M;|;" []) copy-list #function("6000r1|F650|\x84;^;" [])])]) cond #function("9000s0c0q^41;" [#function("7000r1c0qm02|~41;" [#function("7000r1|?640^;c0q|M41;" [#function(";000r1|Mc0<17702|M]<6@0|N\x8550|M;c1|NK;|N\x85@0c2|Mi10~N31L3;c3|Mc1|NKi10~N31L4;" [else begin or if])] cond-clauses->if)])]) throw #function(":000r2c0c1c2c3L2|}L4L2;" [raise list quote thrown-value]) time #function("7000r1c0qe13041;" [#function(">000r1c0|c1L1L2L1c2~c3c4c5c1L1|L3c6L4L3L3;" [let time.now prog1 princ "Elapsed time: " - " seconds\n"]) gensym]) let* #function("A000s1|?6E0e0c1L1_L1e2}3133L1;e0c1L1e3|31L1L1e2|NF6H0e0c4L1|NL1e2}3133L1530}3133e5|31L2;" [nconc lambda copy-list caar let* cadar]) case #function(":000s1c0q^41;" [#function("7000r1c0m02c1qe23041;" [#function(";000r2}c0\x8250c0;}\x8540^;}C6=0c1|e2}31L3;}?6=0c3|e2}31L3;}N\x85>0c3|e2}M31L3;e4c5}326=0c6|c7}L2L3;c8|c7}L2L3;" [else eq? quote-value eqv? every #.symbol? memq quote memv] vals->cond) #function("<000r1c0|i10L2L1e1c2L1e3c4qi113232L3;" [let nconc cond map #function("8000r1i10~|M32|NK;" [])]) gensym])]) with-output-to #function("=000s1e0c1L1c2|L2L1L1e3}3143;" [nconc with-bindings *output-stream* copy-list]) catch #function("7000r2c0qe13041;" [#function("@000r1c0\x7fc1|L1c2c3c4|L2c5c6|L2c7c8L2L3c5c9|L2~L3L4c:|L2c;|L2L4L3L3;" [trycatch lambda if and pair? eq car quote thrown-value cadr caddr raise]) gensym])) *whitespace* "\t\n\v\f\r \u0085 \u2028\u2029 " /= #function("7000r2|}W@;" [] /=) 1+ #function("7000r1|aw;" [] 1+) 1- #function("7000r1|ax;" [] 1-) 1arg-lambda? #function("8000r1|F16T02|Mc0<16J02|NF16B02|\x84F16:02e1|\x84a42;" [lambda length=] 1arg-lambda?) <= #function("7000r2|}X17602|}W;" [] <=) > #function("7000r2}|X;" [] >) >= #function("7000r2}|X17602|}W;" [] >=) Instructions #table(not 16 vargc 67 load1 49 = 39 setc.l 64 sub2 72 brne.l 83 largc 74 brnn 85 loadc.l 58 loadi8 50 < 40 nop 0 set-cdr! 32 loada 55 bound? 21 / 37 neg 73 brn.l 88 lvargc 75 brt 7 trycatch 68 null? 17 load0 48 jmp.l 8 loadv 51 seta 61 keyargs 91 * 36 function? 26 builtin? 23 aref 43 optargs 89 vecto\ No newline at end of file
+(*banner* "; _\n; |_ _ _ |_ _ | . _ _\n; | (-||||_(_)|__|_)|_)\n;-------------------|----------------------------------------------------------\n\n" *syntax-environment* #table(with-bindings #fn(">000s1c0qe1c2|32e1e3|32e1c4|3243;" [#fn("B000r3e0c1L1e2c3g2|33L1e4e2c5|}3331c6e0c7L1e4\x7f3132e0c7L1e4e2c8|g2333132L3L144;" [nconc let map #.list copy-list #fn("8000r2c0|}L3;" [set!]) unwind-protect begin #fn("8000r2c0|}L3;" [set!])]) map #.car cadr #fn("6000r1e040;" [gensym])]) letrec #fn("?000s1e0e0c1L1e2c3|32L1e2c4|32e5}3134L1e2c6|3242;" [nconc lambda map #.car #fn("9000r1e0c1L1e2|3142;" [nconc set! copy-list]) copy-list #fn("6000r1^;" [])]) backquote #fn("7000r1e0|41;" [bq-process]) assert #fn("<000r1c0|]c1c2c3|L2L2L2L4;" [if raise quote assert-failed]) label #fn(":000r2c0|L1c1|}L3L3^L2;" [lambda set!]) do #fn("A000s2c0qe130}Me2c3|32e2e4|32e2c5|3245;" [#fn("B000r5c0|c1g2c2}e3c4L1e5\x7fN3132e3c4L1e5i0231e3|L1g432L133L4L3L2L1e3|L1g332L3;" [letrec lambda if nconc begin copy-list]) gensym map #.car cadr #fn("7000r1e0|31F680e1|41;|M;" [cddr caddr])]) when #fn("<000s1c0|c1}K^L4;" [if begin]) dotimes #fn(";000s1c0q|M|\x8442;" [#fn("=000r2c0`c1}aL3e2c3L1|L1L1e4\x7f3133L4;" [for - nconc lambda copy-list])]) unwind-protect #fn("8000r2c0qe130e13042;" [#fn("@000r2c0}c1_\x7fL3L2L1c2c3~c1|L1c4}L1c5|L2L3L3L3}L1L3L3;" [let lambda prog1 trycatch begin raise]) gensym]) define-macro #fn("?000s1c0c1|ML2e2c3L1|NL1e4}3133L3;" [set-syntax! quote nconc lambda copy-list]) receive #fn("@000s2c0c1_}L3e2c1L1|L1e3g23133L3;" [call-with-values lambda nconc copy-list]) unless #fn("=000s1c0|^c1}KL4;" [if begin]) let #fn(":000s1c0q^41;" [#fn("<000r1~C6D0~m02\x7fMo002\x7fNo01530^2c0qe1c2L1e3c4~32L1e5\x7f3133e3c6~3242;" [#fn("8000r2~6;0c0~|L3530|}K;" [label]) nconc lambda map #fn("6000r1|F650|M;|;" []) copy-list #fn("6000r1|F650|\x84;^;" [])])]) cond #fn("9000s0c0q^41;" [#fn("7000r1c0qm02|~41;" [#fn("7000r1|?640^;c0q|M41;" [#fn(";000r1|Mc0<17702|M]<6@0|N\x8550|M;c1|NK;|N\x85@0c2|Mi10~N31L3;c3|Mc1|NKi10~N31L4;" [else begin or if])] cond-clauses->if)])]) throw #fn(":000r2c0c1c2c3L2|}L4L2;" [raise list quote thrown-value]) time #fn("7000r1c0qe13041;" [#fn(">000r1c0|c1L1L2L1c2~c3c4c5c1L1|L3c6L4L3L3;" [let time.now prog1 princ "Elapsed time: " - " seconds\n"]) gensym]) let* #fn("A000s1|?6E0e0c1L1_L1e2}3133L1;e0c1L1e3|31L1L1e2|NF6H0e0c4L1|NL1e2}3133L1530}3133e5|31L2;" [nconc lambda copy-list caar let* cadar]) case #fn(":000s1c0q^41;" [#fn("7000r1c0m02c1qe23041;" [#fn(";000r2}c0\x8250c0;}\x8540^;}C6=0c1|e2}31L3;}?6=0c3|e2}31L3;}N\x85>0c3|e2}M31L3;e4c5}326=0c6|c7}L2L3;c8|c7}L2L3;" [else eq? quote-value eqv? every #.symbol? memq quote memv] vals->cond) #fn("<000r1c0|i10L2L1e1c2L1e3c4qi113232L3;" [let nconc cond map #fn("8000r1i10~|M32|NK;" [])]) gensym])]) with-output-to #fn("=000s1e0c1L1c2|L2L1L1e3}3143;" [nconc with-bindings *output-stream* copy-list]) catch #fn("7000r2c0qe13041;" [#fn("@000r1c0\x7fc1|L1c2c3c4|L2c5c6|L2c7c8L2L3c5c9|L2~L3L4c:|L2c;|L2L4L3L3;" [trycatch lambda if and pair? eq car quote thrown-value cadr caddr raise]) gensym])) *whitespace* "\t\n\v\f\r \u0085 \u2028\u2029 " /= #fn("7000r2|}W@;" [] /=) 1+ #fn("7000r1|aw;" [] 1+) 1- #fn("7000r1|ax;" [] 1-) 1arg-lambda? #fn("8000r1|F16T02|Mc0<16J02|NF16B02|\x84F16:02e1|\x84a42;" [lambda length=] 1arg-lambda?) <= #fn("7000r2|}X17602|}W;" [] <=) > #fn("7000r2}|X;" [] >) >= #fn("7000r2}|X17602|}W;" [] >=) Instructions #table(not 16 vargc 67 load1 49 = 39 setc.l 64 sub2 72 brne.l 83 largc 74 brnn 85 loadc.l 58 loadi8 50 < 40 nop 0 set-cdr! 32 loada 55 bound? 21 / 37 neg 73 brn.l 88 lvargc 75 brt 7 trycatch 68 null? 17 load0 48 jmp.l 8 loadv 51 seta 61 keyargs 91 * 36 function? 26 builtin? 23 aref 43 optargs 89 vector? 24 loadt 45 brf 6 symbol? 19 cdr 30 for 69 loadc00 78 pop 2 pair? 22 cadr 84 closure 65 loadf 46 compare 41 loadv.l 52 setg.l 60 brn 87 eqv? 13 aset! 44 eq? 12 atom? 15 boolean? 18 brt.l 10 tapply 70 dummy_nil 94 loada0 76 brbound 90 list 28 dup 1 apply 33 loadc 57 l\ No newline at end of file
--- a/femtolisp/flisp.c
+++ b/femtolisp/flisp.c
@@ -89,15 +89,22 @@
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);
static value_t relocate(value_t v);
@@ -2089,39 +2096,31 @@
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);--- a/femtolisp/flisp.h
+++ b/femtolisp/flisp.h
@@ -253,12 +253,13 @@
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;
--- a/femtolisp/print.c
+++ b/femtolisp/print.c
@@ -399,7 +399,7 @@
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 @@
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 @@
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
--- a/femtolisp/read.c
+++ b/femtolisp/read.c
@@ -216,6 +216,25 @@
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);
}
@@ -579,6 +598,9 @@
if (sym == vu8sym) {sym = arraysym;
Stack[SP-1] = fl_cons(uint8sym, Stack[SP-1]);
+ }
+ else if (sym == fnsym) {+ sym = FUNCTION;
}
v = symbol_value(sym);
if (v == UNBOUND)
--- a/femtolisp/system.lsp
+++ b/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)
--- a/femtolisp/todo
+++ b/femtolisp/todo
@@ -643,6 +643,7 @@
- (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 @@
- 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 @@
* 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)