added globals *install-dir* and *print-width*, parameterized

prettyprinter by screen width

decent accumulate-while and accumulate-for

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)

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))

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; }

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);

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)) ||
+                        if (HPOS > R_MARGIN ||
-                            (HPOS > 40 && !smallp(vector_elt(v,i+1))))
+                            (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);
 }

femtolisp/test.lsp

@@ -205,27 +205,41 @@
 ;(tt)
 ;(tt)
 
-(defmacro delay (expr)
 (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))
+        (acc   (gensym)))
-        (forms (f-body body)))
+    `(let ((,first nil)
-    `(let ((,first (prog1 (cons ,what nil) ,forms))
+           (,acc (list nil)))
-           (,acc nil))
+       (setq ,first ,acc)
-       (setq ,acc ,first)
        (while ,cnd
-         (progn (rplacd ,acc (cons ,what nil))
+         (progn (setq ,acc
-                (setq ,acc (cdr ,acc))
+                      (cdr (rplacd ,acc (cons ,what nil))))
-                ,forms))
+                ,@body))
-       ,first)))
+       (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))
+                        (progn (setq lst (cdr lst))
-                        (setq i (1+ i))))))
+                               (setq i (1+ i)))))))

femtolisp/todo

@@ -778,11 +778,12 @@ identical to
 
 design of new toplevel
 
-system.lsp is compiled into the executable, and contains definitions of
+system.lsp contains definitions of (load) and (toplevel) and is loaded
-(load) and (repl).
+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)
+(toplevel) either runs a script or a repl using (while T (trycatch ...))
-on startup we call load on system, then call it again afterwards
 
 (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

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)
 {

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