lassik
/
upscheme
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

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 2009-01-03 05:30:22 +00:00
parent d8132ad204
commit 209b77a534
4 changed files with 84 additions and 41 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

70
femtolisp/cps.lsp
View File

@ -15,6 +15,32 @@
(cps- (car forms) `(lambda (,_) (cps- (car forms) `(lambda (,_)
,(progn->cps (cdr forms) k))))))) ,(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) (define (rest->cps xformer form k argsyms)
(let ((el (car form))) (let ((el (car form)))
(if (or (atom el) (constantp el)) (if (or (atom el) (constantp el))
@ -23,11 +49,17 @@
(cps- el `(lambda (,g) (cps- el `(lambda (,g)
,(xformer (cdr form) k (cons g argsyms)))))))) ,(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))))) ; (f x) => (cps- f `(lambda (F) ,(cps- x `(lambda (X) (F ,k X)))))
(define (app->cps form k argsyms) (define (app->cps form k argsyms)
(cond ((atom form) (cond ((atom form)
(let ((r (reverse argsyms))) (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)))) (T (rest->cps app->cps form k argsyms))))
; (+ x) => (cps- x `(lambda (X) (,k (+ X)))) ; (+ x) => (cps- x `(lambda (X) (,k (+ X))))
@ -51,7 +83,7 @@
`(,k ,form)) `(,k ,form))
((eq (car form) 'lambda) ((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) ((eq (car form) 'progn)
(progn->cps (cdr form) k)) (progn->cps (cdr form) k))
@ -120,7 +152,7 @@
(let ((v (cadr form)) (let ((v (cadr form))
(E (caddr form)) (E (caddr form))
(val (gensym))) (val (gensym)))
`(let ((,v (lambda (,g ,val) (,g (,k ,val))))) `(let ((,v (lambda/cc (,g ,val) (,g (,k ,val)))))
,(cps- E *top-k*)))) ,(cps- E *top-k*))))
((and (constantp (car form)) ((and (constantp (car form))
@ -132,12 +164,15 @@
(eq (caar form) 'lambda)) (eq (caar form) 'lambda))
(let ((largs (cadr (car form))) (let ((largs (cadr (car form)))
(lbody (caddr (car form)))) (lbody (caddr (car form))))
(if (null largs) (cond ((null largs) ; ((lambda () body))
(cps- lbody k) ; ((lambda () x)) (cps- lbody k))
(cps- (cadr form) `(lambda (,(car largs)) ((symbolp largs) ; ((lambda x body) args...)
,(cps- `((lambda ,(cdr largs) ,lbody) (cps- `((lambda (,largs) ,lbody) (list ,@(cdr form))) k))
,@(cddr form)) (T
k)))))) (cps- (cadr form) `(lambda (,(car largs))
,(cps- `((lambda ,(cdr largs) ,lbody)
,@(cddr form))
k)))))))
(T (T
(app->cps form k ()))))) (app->cps form k ())))))
@ -148,12 +183,11 @@
(cond ((or (atom form) (constantp form)) form) (cond ((or (atom form) (constantp form)) form)
((and (eq (car form) 'lambda) ((and (eq (car form) 'lambda)
(let ((body (caddr form)) (let ((body (caddr form))
(args (cadr form)) (args (cadr form)))
(func (car (caddr form))))
(and (consp body) (and (consp body)
(equal (cdr body) args) (equal (cdr body) args)
(constantp func)))) (constantp (car (caddr form))))))
(η-reduce (car (caddr form)))) (car (caddr form)))
(T (map η-reduce form)))) (T (map η-reduce form))))
(define (contains x form) (define (contains x form)
@ -172,7 +206,7 @@
(eq (caar form) 'lambda) (eq (caar form) 'lambda)
(let ((args (cadr (car form))) (let ((args (cadr (car form)))
(body (caddr (car form)))) (body (caddr (car form))))
(and (consp body) (and (consp body) (consp args)
(= (length body) 2) (= (length body) 2)
(= (length args) 1) (= (length args) 1)
(eq (car body) (car args)) (eq (car body) (car args))
@ -196,7 +230,7 @@
(let ((args (cadr (car form))) (let ((args (cadr (car form)))
(s (cadr form)) (s (cadr form))
(body (caddr (car form)))) (body (caddr (car form))))
(and (= (length args) 1) (and (consp args) (= (length args) 1)
(consp body) (consp body)
(consp (car body)) (consp (car body))
(eq (caar body) 'lambda) (eq (caar body) 'lambda)
@ -250,11 +284,13 @@ T
#| #|
todo: 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 calls to calls to funcall/cc that does the right thing for both
cc-lambdas and normal lambdas cc-lambdas and normal lambdas
- handle dotted arglists in lambda * handle dotted arglists in lambda
- implement CPS version of apply
- use fewer gensyms - use fewer gensyms

3
femtolisp/flisp.c
View File

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

51
femtolisp/print.c
View File

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

1
femtolisp/system.lsp
View File

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