adding *print-level* and *print-length*

fixing open-string-output-port (R6RS)
making io.tostring! more consistent
adding newlines to boot file; wastes space but will allow more
  efficient diffing

femtolisp/aliases.scm

@@ -98,7 +98,10 @@
     (io.seek b 0)
     b))
 (define (open-output-string) (buffer))
-(define open-string-output-port open-output-string)
+(define (open-string-output-port)
+  (let ((b (buffer)))
+    (values b (lambda () (io.tostring! b)))))
+
 (define (get-output-string b)
   (let ((p (io.pos b)))
     (io.seek b 0)

femtolisp/flisp.c

@@ -92,7 +92,8 @@ static uint32_t N_GCHND = 0;
 value_t FL_NIL, FL_T, FL_F, FL_EOF, QUOTE;
 value_t IOError, ParseError, TypeError, ArgError, UnboundError, MemoryError;
 value_t DivideError, BoundsError, Error, KeyError, EnumerationError;
-value_t printwidthsym, printreadablysym, printprettysym;
+value_t printwidthsym, printreadablysym, printprettysym, printlengthsym;
+value_t printlevelsym;
 
 static value_t NIL, LAMBDA, IF, TRYCATCH;
 static value_t BACKQUOTE, COMMA, COMMAAT, COMMADOT, FUNCTION;
@@ -2135,6 +2136,8 @@ static void lisp_init(void)
     set(printprettysym=symbol("*print-pretty*"), FL_T);
     set(printreadablysym=symbol("*print-readably*"), FL_T);
     set(printwidthsym=symbol("*print-width*"), fixnum(SCR_WIDTH));
+    set(printlengthsym=symbol("*print-length*"), FL_F);
+    set(printlevelsym=symbol("*print-level*"), FL_F);
     lasterror = NIL;
     i = 0;
     for (i=OP_EQ; i <= OP_ASET; i++) {

femtolisp/iostream.c

@@ -361,6 +361,7 @@ value_t stream_to_string(value_t *ps)
         n = st->size;
         str = cvalue_string(n);
         memcpy(cvalue_data(str), value2c(ios_t*,*ps)->buf, n);
+        ios_trunc(st, 0);
     }
     else {
         char *b = ios_takebuf(st, &n); n--;

femtolisp/print.c

@@ -4,6 +4,9 @@ static htable_t printconses;
 static u_int32_t printlabel;
 static int print_pretty;
 static int print_princ;
+static fixnum_t print_length;
+static fixnum_t print_level;
+static fixnum_t P_LEVEL;
 static int SCR_WIDTH = 80;
 
 static int HPOS=0, VPOS;
@@ -281,10 +284,14 @@ static void print_pair(ios_t *f, value_t v)
     int after2 = indentafter2(head, v);
     int n_unindented = 1;
     while (1) {
+        cd = cdr_(v);
+        if (print_length >= 0 && n >= print_length && cd!=NIL) {
+            outsn("...)", f, 4);
+            break;
+        }
         lastv = VPOS;
         unmark_cons(v);
         fl_print_child(f, car_(v));
-        cd = cdr_(v);
         if (!iscons(cd) || ptrhash_has(&printconses, (void*)cd)) {
             if (cd != NIL) {
                 outsn(" . ", f, 3);
@@ -364,6 +371,12 @@ static int print_circle_prefix(ios_t *f, value_t v)
 void fl_print_child(ios_t *f, value_t v)
 {
     char *name;
+    if (print_level >= 0 && P_LEVEL >= print_level &&
+        (iscons(v) || isvector(v) || isclosure(v))) {
+        outc('#', f);
+        return;
+    }
+    P_LEVEL++;
 
     switch (tag(v)) {
     case TAG_NUM :
@@ -400,7 +413,7 @@ void fl_print_child(ios_t *f, value_t v)
         else {
             assert(isclosure(v));
             if (!print_princ) {
-                if (print_circle_prefix(f, v)) return;
+                if (print_circle_prefix(f, v)) break;
                 function_t *fn = (function_t*)ptr(v);
                 outs("#fn(", f);
                 char *data = cvalue_data(fn->bcode);
@@ -430,12 +443,16 @@ void fl_print_child(ios_t *f, value_t v)
         if (v == UNBOUND) { outs("#<undefined>", f); break; }
     case TAG_VECTOR:
     case TAG_CONS:
-        if (print_circle_prefix(f, v)) return;
+        if (print_circle_prefix(f, v)) break;
         if (isvector(v)) {
             outc('[', f);
             int newindent = HPOS, est;
             int i, sz = vector_size(v);
             for(i=0; i < sz; i++) {
+                if (print_length >= 0 && i >= print_length && i < sz-1) {
+                    outsn("...", f, 3);
+                    break;
+                }
                 fl_print_child(f, vector_elt(v,i));
                 if (i < sz-1) {
                     if (!print_pretty) {
@@ -463,6 +480,7 @@ void fl_print_child(ios_t *f, value_t v)
             print_pair(f, v);
         break;
     }
+    P_LEVEL--;
 }
 
 static void print_string(ios_t *f, char *str, size_t sz)
@@ -720,11 +738,24 @@ void print(ios_t *f, value_t v)
     if (print_pretty)
         set_print_width();
     print_princ = (symbol_value(printreadablysym) == FL_F);
+
+    value_t pl = symbol_value(printlengthsym);
+    if (isfixnum(pl)) print_length = numval(pl);
+    else print_length = -1;
+    pl = symbol_value(printlevelsym);
+    if (isfixnum(pl)) print_level = numval(pl);
+    else print_level = -1;
+    P_LEVEL = 0;
+
     printlabel = 0;
     print_traverse(v);
     HPOS = VPOS = 0;
 
     fl_print_child(f, v);
 
+    if (print_level >= 0 || print_length >= 0) {
+        bitvector_fill(consflags, 0, 0, heapsize/sizeof(cons_t));
+    }
+
     htable_reset(&printconses, 32);
 }

femtolisp/system.lsp

@@ -727,17 +727,16 @@
 		ex-nondefs)))))
   
   (define (expand-lambda-list l env)
-    (nconc
+    (if (atom? l) l
-     (map (lambda (x) (if (and (pair? x) (pair? (cdr x)))
+	(cons (if (and (pair? (car l)) (pair? (cdr (car l))))
-			  (list (car x) (expand-in (cadr x) env))
+		  (list (caar l) (expand-in (cadar l) env))
-			  x))
+		  (car l))
-	  l)
+	      (expand-lambda-list (cdr l) env))))
-     (lastcdr l)))
   
   (define (l-vars l)
-    (cond ((atom? l) (list l))
+    (cond ((atom? l)       (list l))
 	  ((pair? (car l)) (cons (caar l) (l-vars (cdr l))))
-	  (else (cons (car l) (l-vars (cdr l))))))
+	  (else            (cons (car l)  (l-vars (cdr l))))))
   
   (define (expand-lambda e env)
     (let ((formals (cadr e))
@@ -951,7 +950,7 @@
   (let ((f (file fname :write :create :truncate))
 	(excludes '(*linefeed* *directory-separator* *argv* that
 			       *print-pretty* *print-width* *print-readably*)))
-    (with-bindings ((*print-pretty* #f)
+    (with-bindings ((*print-pretty* #t)
 		    (*print-readably* #t))
       (let ((syms
 	     (filter (lambda (s)

femtolisp/todo

@@ -887,6 +887,8 @@ IOStream API
 *princ-to-string
 
 
+ path.exists?
+ path.dir?
  path.combine
  path.parts
  path.absolute

llt/bitvector-ops.c

@@ -122,40 +122,6 @@ void bitvector_shl_to(u_int32_t *dest, u_int32_t *b, size_t n, u_int32_t s,
         dest[i] = sc;
 }
 
-// set nbits to c, starting at given bit offset
-// assumes offs < 32
-void bitvector_fill(u_int32_t *b, u_int32_t offs, u_int32_t c, u_int32_t nbits)
-{
-    index_t i;
-    u_int32_t nw, tail;
-    u_int32_t mask;
-
-    if (nbits == 0) return;
-    nw = (offs+nbits+31)>>5;
-
-    if (nw == 1) {
-        mask = (lomask(nbits)<<offs);
-        if (c) b[0]|=mask; else b[0]&=(~mask);
-        return;
-    }
-
-    mask = lomask(offs);
-    if (c) b[0]|=(~mask); else b[0]&=mask;
-
-    if (c) mask=ONES32; else mask = 0;
-    for(i=1; i < nw-1; i++)
-        b[i] = mask;
-
-    tail = (offs+nbits)&31;
-    if (tail==0) {
-        b[i] = mask;
-    }
-    else {
-        mask = lomask(tail);
-        if (c) b[i]|=mask; else b[i]&=(~mask);
-    }
-}
-
 void bitvector_not(u_int32_t *b, u_int32_t offs, u_int32_t nbits)
 {
     index_t i;

llt/bitvector.c

@@ -72,3 +72,37 @@ u_int32_t bitvector_get(u_int32_t *b, u_int64_t n)
 {
     return b[n>>5] & (1<<(n&31));
 }
+
+// set nbits to c, starting at given bit offset
+// assumes offs < 32
+void bitvector_fill(u_int32_t *b, u_int32_t offs, u_int32_t c, u_int32_t nbits)
+{
+    index_t i;
+    u_int32_t nw, tail;
+    u_int32_t mask;
+
+    if (nbits == 0) return;
+    nw = (offs+nbits+31)>>5;
+
+    if (nw == 1) {
+        mask = (lomask(nbits)<<offs);
+        if (c) b[0]|=mask; else b[0]&=(~mask);
+        return;
+    }
+
+    mask = lomask(offs);
+    if (c) b[0]|=(~mask); else b[0]&=mask;
+
+    if (c) mask=ONES32; else mask = 0;
+    for(i=1; i < nw-1; i++)
+        b[i] = mask;
+
+    tail = (offs+nbits)&31;
+    if (tail==0) {
+        b[i] = mask;
+    }
+    else {
+        mask = lomask(tail);
+        if (c) b[i]|=mask; else b[i]&=(~mask);
+    }
+}