ref: 209b77a534b953d8197b6d0dc2ddb4db16f8fb80
parent: d8132ad204af5131c4cddcf7be4669adfc167ba7
author: JeffBezanson <[email protected]>
date: Sat Jan 3 00:30:22 EST 2009
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
--- a/femtolisp/cps.lsp
+++ b/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)
- (cps- lbody k) ; ((lambda () x))
- (cps- (cadr form) `(lambda (,(car largs))
- ,(cps- `((lambda ,(cdr largs) ,lbody)
- ,@(cddr form))
- k))))))
+ (cond ((null largs) ; ((lambda () body))
+ (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)))))))
(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))
- (func (car (caddr form))))
+ (args (cadr form)))
(and (consp body)
(equal (cdr body) args)
- (constantp func))))
- (η-reduce (car (caddr form))))
+ (constantp (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 @@
#|
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
--- a/femtolisp/flisp.c
+++ b/femtolisp/flisp.c
@@ -71,7 +71,7 @@
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 @@
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;
--- a/femtolisp/print.c
+++ b/femtolisp/print.c
@@ -2,7 +2,6 @@
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 @@
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 @@
ios_putc(' ', f);n--;
}
+ return n0;
}
void fl_print_chr(char c, ios_t *f)
@@ -137,7 +141,9 @@
*/
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 @@
// 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 @@
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,17 +274,14 @@
else {est = lengthestimate(car_(cd));
nextsmall = smallp(car_(cd));
- ind = (((n > 0) &&
- ((!nextsmall && HPOS>C_MARGIN) || (VPOS > lastv))) ||
+ thistiny = tinyp(car_(v));
+ 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) ||
(n > 0 && always) ||
@@ -284,13 +288,17 @@
(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 @@
}
else {est = lengthestimate(vector_elt(v,i+1));
- if (HPOS > R_MARGIN ||
- (est!=-1 && (HPOS+est > R_EDGE)) ||
- (HPOS > C_MARGIN && !smallp(vector_elt(v,i+1))))
- outindent(newindent, f);
+ if (HPOS > SCR_WIDTH-4 ||
+ (est!=-1 && (HPOS+est > SCR_WIDTH-2)) ||
+ (HPOS > SCR_WIDTH/2 &&
+ !smallp(vector_elt(v,i+1)) &&
+ !tinyp(vector_elt(v,i))))
+ newindent = outindent(newindent, f);
else
outc(' ', f);}
@@ -610,11 +620,6 @@
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)
--- a/femtolisp/system.lsp
+++ b/femtolisp/system.lsp
@@ -293,6 +293,7 @@
first)))
(defun iota (n) (map-int identity n))
+(define ι iota)
(defun error args (raise (cons 'error args)))