simplified and improved some of the prettyprinting logic

• eliminated bad behavior near screen edge, added wrapping
• added behavior: indent after some number of non-indented elements
• indent after head symbols with really long names
• don't indent after first argument to setq

improvements to cps converter
• correctly dispatch to non-cps functions
• handle vararg lambdas in head position

femtolisp/cps.lsp

@@ -15,6 +15,32 @@
              (cps- (car forms) `(lambda (,_)
                                   ,(progn->cps (cdr forms) k)))))))
 
+(defmacro lambda/cc (args body)
+  `(rplaca (lambda ,args ,body) 'lambda/cc))
+
+; a utility used at run time to dispatch a call with or without
+; the continuation argument, depending on the function
+(define (funcall/cc f k . args)
+  (if (and (consp f) (eq (car f) 'lambda/cc))
+      (apply f (cons k args))
+    (k (apply f args))))
+(define *funcall/cc-names*
+  (list-to-vector
+   (map (lambda (i) (intern (string 'funcall/cc- i)))
+        (iota 6))))
+(defmacro def-funcall/cc-n (args)
+  (let* ((name (aref *funcall/cc-names* (length args))))
+    `(define (,name f k ,@args)
+       (if (and (consp f) (eq (car f) 'lambda/cc))
+           (f k ,@args)
+         (k (f ,@args))))))
+(def-funcall/cc-n ())
+(def-funcall/cc-n (a0))
+(def-funcall/cc-n (a0 a1))
+(def-funcall/cc-n (a0 a1 a2))
+(def-funcall/cc-n (a0 a1 a2 a3))
+(def-funcall/cc-n (a0 a1 a2 a3 a4))
+
 (define (rest->cps xformer form k argsyms)
   (let ((el (car form)))
     (if (or (atom el) (constantp el))
@@ -23,11 +49,17 @@
         (cps- el `(lambda (,g)
                     ,(xformer (cdr form) k (cons g argsyms))))))))
 
+(define (make-funcall/cc head ke args)
+  (let ((n (length args)))
+    (if (< n 6)
+        `(,(aref *funcall/cc-names* n) ,head ,ke ,@args)
+      `(funcall/cc ,head ,ke ,@args))))
+
 ; (f x) => (cps- f `(lambda (F) ,(cps- x `(lambda (X) (F ,k X)))))
 (define (app->cps form k argsyms)
   (cond ((atom form)
          (let ((r (reverse argsyms)))
-           `(,(car r) ,k ,@(cdr r))))
+           (make-funcall/cc (car r) k (cdr r))))
         (T (rest->cps app->cps form k argsyms))))
 
 ; (+ x) => (cps- x `(lambda (X) (,k (+ X))))
@@ -51,7 +83,7 @@
            `(,k ,form))
 
           ((eq (car form) 'lambda)
-           `(,k (lambda ,(cons g (cadr form)) ,(cps- (caddr form) g))))
+           `(,k (lambda/cc ,(cons g (cadr form)) ,(cps- (caddr form) g))))
 
           ((eq (car form) 'progn)
            (progn->cps (cdr form) k))
@@ -120,7 +152,7 @@
            (let ((v (cadr form))
                  (E (caddr form))
                  (val (gensym)))
-             `(let ((,v (lambda (,g ,val) (,g (,k ,val)))))
+             `(let ((,v (lambda/cc (,g ,val) (,g (,k ,val)))))
                 ,(cps- E *top-k*))))
 
           ((and (constantp (car form))
@@ -132,12 +164,15 @@
                 (eq (caar form) 'lambda))
            (let ((largs (cadr (car form)))
                  (lbody (caddr (car form))))
-             (if (null largs)
+             (cond ((null largs)    ; ((lambda () body))
-                 (cps- lbody k)  ; ((lambda () x))
+                    (cps- lbody k))
+                   ((symbolp largs) ; ((lambda x body) args...)
+                    (cps- `((lambda (,largs) ,lbody) (list ,@(cdr form))) k))
+                   (T
                     (cps- (cadr form) `(lambda (,(car largs))
                                          ,(cps- `((lambda ,(cdr largs) ,lbody)
                                                   ,@(cddr form))
-                                           k))))))
+                                                k)))))))
 
           (T
            (app->cps form k ())))))
@@ -148,12 +183,11 @@
   (cond ((or (atom form) (constantp form)) form)
         ((and (eq (car form) 'lambda)
               (let ((body (caddr form))
-                    (args (cadr form))
+                    (args (cadr form)))
-                    (func (car (caddr form))))
                 (and (consp body)
                      (equal (cdr body) args)
-                     (constantp func))))
+                     (constantp (car (caddr form))))))
-         (η-reduce (car (caddr form))))
+         (car (caddr form)))
         (T (map η-reduce form))))
 
 (define (contains x form)
@@ -172,7 +206,7 @@
               (eq (caar form) 'lambda)
               (let ((args (cadr (car form)))
                     (body (caddr (car form))))
-                (and (consp body)
+                (and (consp body) (consp args)
                      (= (length body) 2)
                      (= (length args) 1)
                      (eq (car body) (car args))
@@ -196,7 +230,7 @@
               (let ((args (cadr (car form)))
                     (s (cadr form))
                     (body (caddr (car form))))
-                (and (= (length args) 1)
+                (and (consp args) (= (length args) 1)
                      (consp body)
                      (consp (car body))
                      (eq (caar body) 'lambda)
@@ -250,11 +284,13 @@ T
 
 #|
 todo:
-- tag lambdas that accept continuation arguments, compile computed
+* tag lambdas that accept continuation arguments, compile computed
   calls to calls to funcall/cc that does the right thing for both
   cc-lambdas and normal lambdas
 
-- handle dotted arglists in lambda
+* handle dotted arglists in lambda
+
+- implement CPS version of apply
 
 - use fewer gensyms
 

femtolisp/flisp.c

@@ -71,7 +71,7 @@ value_t BACKQUOTE, COMMA, COMMAAT, COMMADOT;
 value_t IOError, ParseError, TypeError, ArgError, UnboundError, MemoryError;
 value_t DivideError, BoundsError, Error, KeyError;
 value_t conssym, symbolsym, fixnumsym, vectorsym, builtinsym;
-value_t defunsym, defmacrosym, forsym, labelsym, printprettysym;
+value_t defunsym, defmacrosym, forsym, labelsym, printprettysym, setqsym;
 value_t printwidthsym;
 
 static value_t eval_sexpr(value_t e, uint32_t penv, int tail);
@@ -1399,6 +1399,7 @@ void lisp_init(void)
     defmacrosym = symbol("defmacro");
     forsym = symbol("for");
     labelsym = symbol("label");
+    setqsym = symbol("setq");
     set(printprettysym=symbol("*print-pretty*"), T);
     set(printwidthsym=symbol("*print-width*"), fixnum(SCR_WIDTH));
     lasterror = NIL;

femtolisp/print.c

@@ -2,7 +2,6 @@ static htable_t printconses;
 static u_int32_t printlabel;
 static int print_pretty;
 static int SCR_WIDTH = 80;
-static int R_MARGIN, C_MARGIN, R_EDGE, L_PAD, R_PAD;
 
 static int HPOS, VPOS;
 static void outc(char c, ios_t *f)
@@ -15,8 +14,12 @@ static void outs(char *s, ios_t *f)
     ios_puts(s, f);
     HPOS += u8_strwidth(s);
 }
-static void outindent(int n, ios_t *f)
+static int outindent(int n, ios_t *f)
 {
+    // move back to left margin if we get too indented
+    if (n > SCR_WIDTH-12)
+        n = 2;
+    int n0 = n;
     ios_putc('\n', f);
     VPOS++;
     HPOS = n;
@@ -28,6 +31,7 @@ static void outindent(int n, ios_t *f)
         ios_putc(' ', f);
         n--;
     }
+    return n0;
 }
 
 void fl_print_chr(char c, ios_t *f)
@@ -137,7 +141,9 @@ static void print_symbol_name(ios_t *f, char *name)
 */
 static inline int tinyp(value_t v)
 {
-    return (issymbol(v) || isfixnum(v) || isbuiltinish(v));
+    if (issymbol(v))
+        return (u8_strwidth(symbol_name(v)) < 20);
+    return (isfixnum(v) || isbuiltinish(v));
 }
 
 static int smallp(value_t v)
@@ -203,7 +209,7 @@ static int indentevery(value_t v)
     // indent before every subform of a special form, unless every
     // subform is "small"
     value_t c = car_(v);
-    if (c == LAMBDA || c == labelsym)
+    if (c == LAMBDA || c == labelsym || c == setqsym)
         return 0;
     value_t f;
     if (issymbol(c) && (f=((symbol_t*)ptr(c))->syntax) && isspecial(f))
@@ -241,10 +247,11 @@ static void print_pair(ios_t *f, value_t v, int princ)
     int startpos = HPOS;
     outc('(', f);
     int newindent=HPOS, blk=blockindent(v);
-    int lastv, n=0, si, ind=0, est, always=0, nextsmall;
+    int lastv, n=0, si, ind=0, est, always=0, nextsmall, thistiny;
     if (!blk) always = indentevery(v);
     value_t head = car_(v);
     int after3 = indentafter3(head, v);
+    int n_unindented = 1;
     while (1) {
         lastv = VPOS;
         unmark_cons(v);
@@ -267,16 +274,13 @@ static void print_pair(ios_t *f, value_t v, int princ)
         else {
             est = lengthestimate(car_(cd));
             nextsmall = smallp(car_(cd));
-            ind = (((n > 0) &&
+            thistiny = tinyp(car_(v));
-                    ((!nextsmall && HPOS>C_MARGIN) || (VPOS > lastv))) ||
+            ind = (((VPOS > lastv) ||
+                    (HPOS>SCR_WIDTH/2 && !nextsmall && !thistiny && n>0)) ||
                    
-                   ((VPOS > lastv) && (!nextsmall || n==0)) ||
+                   (HPOS > SCR_WIDTH-4) ||
                    
-                   (HPOS > R_PAD && !nextsmall) ||
+                   (est!=-1 && (HPOS+est > SCR_WIDTH-2)) ||
-                   
-                   (HPOS > R_MARGIN) ||
-                   
-                   (est!=-1 && (HPOS+est > R_EDGE)) ||
                    
                    ((head == LAMBDA || head == labelsym) && !nextsmall) ||
                    
@@ -284,13 +288,17 @@ static void print_pair(ios_t *f, value_t v, int princ)
                    
                    (n == 2 && after3) ||
 
+                   (n_unindented >= 3 && !nextsmall) ||
+                   
                    (n == 0 && !smallp(head)));
         }
 
         if (ind) {
-            outindent(newindent, f);
+            newindent = outindent(newindent, f);
+            n_unindented = 1;
         }
         else {
+            n_unindented++;
             outc(' ', f);
             if (n==0) {
                 // set indent level after printing head
@@ -369,10 +377,12 @@ void fl_print_child(ios_t *f, value_t v, int princ)
                     }
                     else {
                         est = lengthestimate(vector_elt(v,i+1));
-                        if (HPOS > R_MARGIN ||
+                        if (HPOS > SCR_WIDTH-4 ||
-                            (est!=-1 && (HPOS+est > R_EDGE)) ||
+                            (est!=-1 && (HPOS+est > SCR_WIDTH-2)) ||
-                            (HPOS > C_MARGIN && !smallp(vector_elt(v,i+1))))
+                            (HPOS > SCR_WIDTH/2 &&
-                            outindent(newindent, f);
+                             !smallp(vector_elt(v,i+1)) &&
+                             !tinyp(vector_elt(v,i))))
+                            newindent = outindent(newindent, f);
                         else
                             outc(' ', f);
                     }
@@ -610,11 +620,6 @@ static void set_print_width()
     value_t pw = symbol_value(printwidthsym);
     if (!isfixnum(pw)) return;
     SCR_WIDTH = numval(pw);
-    R_MARGIN = SCR_WIDTH-6;
-    R_EDGE = SCR_WIDTH-2;
-    C_MARGIN = SCR_WIDTH/2;
-    L_PAD = (SCR_WIDTH*7)/20;
-    R_PAD = L_PAD*2;
 }
 
 void print(ios_t *f, value_t v, int princ)

femtolisp/system.lsp

@@ -293,6 +293,7 @@
       first)))
 
 (defun iota (n) (map-int identity n))
+(define ι iota)
 
 (defun error args (raise (cons 'error args)))