diff --git a/femtolisp/builtins.c b/femtolisp/builtins.c index 4931ac4..b76f78d 100644 --- a/femtolisp/builtins.c +++ b/femtolisp/builtins.c @@ -254,21 +254,13 @@ static double value_to_double(value_t a, char *fname) type_error(fname, "number", a); } -static value_t return_from_cstr(char *str) -{ - size_t n = strlen(str); - value_t v = cvalue_string(n); - memcpy(cvalue_data(v), str, n); - return v; -} - value_t fl_time_string(value_t *args, uint32_t nargs) { argcount("time.string", nargs, 1); double t = value_to_double(args[0], "time.string"); char buf[64]; timestring(t, buf, sizeof(buf)); - return return_from_cstr(buf); + return string_from_cstr(buf); } value_t fl_path_cwd(value_t *args, uint32_t nargs) @@ -278,7 +270,7 @@ value_t fl_path_cwd(value_t *args, uint32_t nargs) if (nargs == 0) { char buf[1024]; get_cwd(buf, sizeof(buf)); - return return_from_cstr(buf); + return string_from_cstr(buf); } char *ptr = tostring(args[0], "path.cwd"); if (set_cwd(ptr)) @@ -294,7 +286,7 @@ value_t fl_os_getenv(value_t *args, uint32_t nargs) if (val == NULL) return NIL; if (*val == 0) return symbol_value(emptystringsym); - return cvalue_pinned_cstring(val); + return cvalue_static_cstring(val); } value_t fl_os_setenv(value_t *args, uint32_t nargs) diff --git a/femtolisp/cvalues.c b/femtolisp/cvalues.c index 97ab4b1..5c23bef 100644 --- a/femtolisp/cvalues.c +++ b/femtolisp/cvalues.c @@ -176,7 +176,7 @@ value_t cvalue_string(size_t sz) return cv; } -value_t cvalue_pinned_cstring(char *str) +value_t cvalue_static_cstring(char *str) { value_t v = cvalue_from_ref(symbol_value(stringtypesym), str, strlen(str), NIL); @@ -184,6 +184,14 @@ value_t cvalue_pinned_cstring(char *str) return v; } +value_t string_from_cstr(char *str) +{ + size_t n = strlen(str); + value_t v = cvalue_string(n); + memcpy(cvalue_data(v), str, n); + return v; +} + int isstring(value_t v) { return (iscvalue(v) && ((cvalue_t*)ptr(v))->flags.cstring); @@ -956,7 +964,7 @@ void cvalues_init() setc(wcstringtypesym, list2(arraysym, wcharsym)); emptystringsym = symbol("*empty-string*"); - setc(emptystringsym, cvalue_pinned_cstring("")); + setc(emptystringsym, cvalue_static_cstring("")); } #define RETURN_NUM_AS(var, type) return(mk_##type((type##_t)var)) diff --git a/femtolisp/flisp.c b/femtolisp/flisp.c index 13834e1..22c220c 100644 --- a/femtolisp/flisp.c +++ b/femtolisp/flisp.c @@ -80,6 +80,7 @@ value_t IOError, ParseError, TypeError, ArgError, UnboundError, MemoryError; value_t DivideError, BoundsError, Error; value_t conssym, symbolsym, fixnumsym, vectorsym, builtinsym; value_t defunsym, defmacrosym, forsym, labelsym, printprettysym; +value_t printwidthsym; static value_t eval_sexpr(value_t e, uint32_t penv, int tail); static value_t *alloc_words(int n); @@ -826,14 +827,15 @@ static value_t eval_sexpr(value_t e, uint32_t penv, int tail) break; case F_PROGN: // return last arg - pv = &Stack[saveSP]; v = NIL; + pv = &Stack[saveSP]; if (iscons(*pv)) { while (iscons(cdr_(*pv))) { - v = eval(car_(*pv)); + (void)eval(car_(*pv)); *pv = cdr_(*pv); } tail_eval(car_(*pv)); } + v = NIL; break; case F_TRYCATCH: v = do_trycatch(car(Stack[saveSP]), penv); @@ -1124,7 +1126,6 @@ static value_t eval_sexpr(value_t e, uint32_t penv, int tail) if (selfevaluating(e)) { SP=saveSP; return e; } SP = penv+2; goto eval_top; - break; case F_RAISE: argcount("raise", nargs, 1); raise(Stack[SP-1]); @@ -1307,6 +1308,8 @@ static value_t eval_sexpr(value_t e, uint32_t penv, int tail) extern void builtins_init(); extern void comparehash_init(); +static char *EXEDIR; + void lisp_init(void) { int i; @@ -1349,6 +1352,7 @@ void lisp_init(void) forsym = symbol("for"); labelsym = symbol("label"); set(printprettysym=symbol("*print-pretty*"), T); + set(printwidthsym=symbol("*print-width*"), fixnum(SCR_WIDTH)); lasterror = NIL; lerrorbuf[0] = '\0'; special_apply_form = fl_cons(builtin(F_SPECIAL_APPLY), NIL); @@ -1374,6 +1378,15 @@ void lisp_init(void) cvalues_init(); set(symbol("gensym"), guestfunc(gensym)); + + char buf[1024]; + char *exename = get_exename(buf, sizeof(buf)); + if (exename != NULL) { + path_to_dirname(exename); + EXEDIR = strdup(exename); + setc(symbol("*install-dir*"), cvalue_static_cstring(EXEDIR)); + } + builtins_init(); } @@ -1462,7 +1475,7 @@ static value_t argv_list(int argc, char *argv[]) PUSH(NIL); if (argc > 1) { argc--; argv++; } for(i=argc-1; i >= 0; i--) - Stack[SP-1] = fl_cons(cvalue_pinned_cstring(argv[i]), Stack[SP-1]); + Stack[SP-1] = fl_cons(cvalue_static_cstring(argv[i]), Stack[SP-1]); return POP(); } @@ -1482,11 +1495,11 @@ int main(int argc, char *argv[]) } FL_CATCH { print_toplevel_exception(); - lerrorbuf[0] = '\0'; lasterror = NIL; ios_puts("\n\n", ios_stderr); - goto repl; + if (argc > 1) return 1; + else goto repl; } load_file("system.lsp"); if (argc > 1) { load_file(argv[1]); return 0; } diff --git a/femtolisp/flisp.h b/femtolisp/flisp.h index 866afb7..ac01c2b 100644 --- a/femtolisp/flisp.h +++ b/femtolisp/flisp.h @@ -249,7 +249,8 @@ size_t cvalue_arraylen(value_t v); value_t size_wrap(size_t sz); size_t toulong(value_t n, char *fname); value_t cvalue_string(size_t sz); -value_t cvalue_pinned_cstring(char *str); +value_t cvalue_static_cstring(char *str); +value_t string_from_cstr(char *str); int isstring(value_t v); int isnumber(value_t v); value_t cvalue_compare(value_t a, value_t b); diff --git a/femtolisp/print.c b/femtolisp/print.c index 54292d7..749ca7a 100644 --- a/femtolisp/print.c +++ b/femtolisp/print.c @@ -1,6 +1,8 @@ static ptrhash_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) @@ -250,15 +252,15 @@ static void print_pair(ios_t *f, value_t v, int princ) est = lengthestimate(car_(cd)); nextsmall = smallp(car_(cd)); ind = (((n > 0) && - ((!nextsmall && HPOS>28) || (VPOS > lastv))) || + ((!nextsmall && HPOS>L_PAD) || (VPOS > lastv))) || ((VPOS > lastv) && (!nextsmall || n==0)) || - (HPOS > 50 && !nextsmall) || + (HPOS > R_PAD && !nextsmall) || - (HPOS > 74) || + (HPOS > R_MARGIN) || - (est!=-1 && (HPOS+est > 78)) || + (est!=-1 && (HPOS+est > R_EDGE)) || ((head == LAMBDA || head == labelsym) && !nextsmall) || @@ -341,8 +343,9 @@ static void do_print(ios_t *f, value_t v, int princ) } else { est = lengthestimate(vector_elt(v,i+1)); - if (HPOS > 74 || (est!=-1 && (HPOS+est > 78)) || - (HPOS > 40 && !smallp(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); else outc(' ', f); @@ -580,12 +583,28 @@ void cvalue_print(ios_t *f, value_t v, int princ) cvalue_printdata(f, data, cv_len(cv), cv_type(cv), princ, 0); } +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) { print_pretty = (symbol_value(printprettysym) != NIL); - ptrhash_reset(&printconses, 32); + if (print_pretty) + set_print_width(); printlabel = 0; print_traverse(v); HPOS = VPOS = 0; + do_print(f, v, princ); + + ptrhash_reset(&printconses, 32); } diff --git a/femtolisp/test.lsp b/femtolisp/test.lsp index 727723a..daf1f0f 100644 --- a/femtolisp/test.lsp +++ b/femtolisp/test.lsp @@ -205,27 +205,41 @@ ;(tt) ;(tt) -(defmacro delay (expr) - (let ((g (gensym))) +(let ((g (gensym))) + (defmacro delay (expr) `(let ((,g ',g)) (lambda () (if (eq ,g ',g) (setq ,g ,expr) ,g))))) +(defun force (p) (p)) + (defmacro accumulate-while (cnd what . body) (let ((first (gensym)) - (acc (gensym)) - (forms (f-body body))) - `(let ((,first (prog1 (cons ,what nil) ,forms)) - (,acc nil)) - (setq ,acc ,first) + (acc (gensym))) + `(let ((,first nil) + (,acc (list nil))) + (setq ,first ,acc) (while ,cnd - (progn (rplacd ,acc (cons ,what nil)) - (setq ,acc (cdr ,acc)) - ,forms)) - ,first))) + (progn (setq ,acc + (cdr (rplacd ,acc (cons ,what nil)))) + ,@body)) + (cdr ,first)))) + +(defmacro accumulate-for (var lo hi what . body) + (let ((first (gensym)) + (acc (gensym))) + `(let ((,first nil) + (,acc (list nil))) + (setq ,first ,acc) + (for ,lo ,hi + (lambda (,var) + (progn (setq ,acc + (cdr (rplacd ,acc (cons ,what nil)))) + ,@body))) + (cdr ,first)))) (defun map-indexed (f lst) (if (atom lst) lst (let ((i 0)) (accumulate-while (consp lst) (f (car lst) i) - (setq lst (cdr lst)) - (setq i (1+ i)))))) + (progn (setq lst (cdr lst)) + (setq i (1+ i))))))) diff --git a/femtolisp/todo b/femtolisp/todo index a28e22a..353358f 100644 --- a/femtolisp/todo +++ b/femtolisp/todo @@ -778,11 +778,12 @@ identical to design of new toplevel -system.lsp is compiled into the executable, and contains definitions of -(load) and (repl). +system.lsp contains definitions of (load) and (toplevel) and is loaded +from *install-dir* by a bootstrap loader in C. at the end of system.lsp, +we check whether (load) is builtin. if it is, we redefine it and reload +system.lsp with the new loader. the C code then invokes (toplevel). -start with load bound to bootstrap_load (in C) -on startup we call load on system, then call it again afterwards +(toplevel) either runs a script or a repl using (while T (trycatch ...)) (load) reads and evaluates every form, keeping track of defined functions and macros (at the top level), and grabs a (main ...) form if it sees diff --git a/llt/dirpath.c b/llt/dirpath.c index 4e76b5e..2c91a75 100644 --- a/llt/dirpath.c +++ b/llt/dirpath.c @@ -24,6 +24,7 @@ #endif #include "dtypes.h" +#include "dirpath.h" void get_cwd(char *buf, size_t size) { @@ -46,6 +47,18 @@ int set_cwd(char *buf) return 0; } +// destructively convert path to directory part +void path_to_dirname(char *path) +{ + char *sep = strrchr(path, PATHSEP); + if (sep != NULL) { + *sep = '\0'; + } + else { + path[0] = '\0'; + } +} + #ifdef LINUX char *get_exename(char *buf, size_t size) { diff --git a/llt/dirpath.h b/llt/dirpath.h index adb3c3a..6f661c0 100644 --- a/llt/dirpath.h +++ b/llt/dirpath.h @@ -19,5 +19,6 @@ void get_cwd(char *buf, size_t size); int set_cwd(char *buf); char *get_exename(char *buf, size_t size); +void path_to_dirname(char *path); #endif