ref: c8c59b1dfc38561e21a16e97bbf7325e62b1a0e1
parent: 6f934a817b7347109eb189f29c01cb48246c0b02
author: JeffBezanson <[email protected]>
date: Wed Sep 10 22:37:38 EDT 2008
added globals *install-dir* and *print-width*, parameterized prettyprinter by screen width decent accumulate-while and accumulate-for
--- a/femtolisp/builtins.c
+++ b/femtolisp/builtins.c
@@ -254,14 +254,6 @@
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);@@ -268,7 +260,7 @@
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 @@
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 @@
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)
--- a/femtolisp/cvalues.c
+++ b/femtolisp/cvalues.c
@@ -176,7 +176,7 @@
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 @@
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 @@
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))
--- a/femtolisp/flisp.c
+++ b/femtolisp/flisp.c
@@ -80,6 +80,7 @@
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 @@
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 @@
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 @@
extern void builtins_init();
extern void comparehash_init();
+static char *EXEDIR;
+
void lisp_init(void)
{int i;
@@ -1349,6 +1352,7 @@
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 @@
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 @@
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 @@
}
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; }--- a/femtolisp/flisp.h
+++ b/femtolisp/flisp.h
@@ -249,7 +249,8 @@
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);
--- 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 @@
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 @@
}
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 @@
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);
}
--- 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)))))))
--- a/femtolisp/todo
+++ b/femtolisp/todo
@@ -778,11 +778,12 @@
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
--- 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)
{@@ -44,6 +45,18 @@
return 1;
#endif
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
--- 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