diff --git a/femtolisp/cps.lsp b/femtolisp/cps.lsp index 57a7a23..ee92b0b 100644 --- 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 @@ 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 diff --git a/femtolisp/flisp.c b/femtolisp/flisp.c index 8a78e0f..9add97e 100644 --- a/femtolisp/flisp.c +++ b/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; diff --git a/femtolisp/print.c b/femtolisp/print.c index 896045d..37ed69f 100644 --- a/femtolisp/print.c +++ b/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) && - ((!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) diff --git a/femtolisp/system.lsp b/femtolisp/system.lsp index 8bf252b..7a61323 100644 --- 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)))