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
This commit is contained in:
JeffBezanson
parent
d8132ad204
commit
209b77a534
|
|
@ -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))
|
||||
(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))))))
|
||||
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 @@ 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
|
||||
|
||||
|
|
|
|||
|
|
@ -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;
|
||||
|
|
|
|||
|
|
@ -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) &&
|
||||
((!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) ||
|
||||
|
||||
(HPOS > R_MARGIN) ||
|
||||
|
||||
(est!=-1 && (HPOS+est > R_EDGE)) ||
|
||||
(est!=-1 && (HPOS+est > SCR_WIDTH-2)) ||
|
||||
|
||||
((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 ||
|
||||
(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 @@ 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)
|
||||
|
|
|
|||
|
|
@ -293,6 +293,7 @@
|
|||
first)))
|
||||
|
||||
(defun iota (n) (map-int identity n))
|
||||
(define ι iota)
|
||||
|
||||
(defun error args (raise (cons 'error args)))
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue