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

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

prettyprinter by screen width

decent accumulate-while and accumulate-for
This commit is contained in:
JeffBezanson 2008-09-11 02:37:38 +00:00
parent 6f934a817b
commit c8c59b1dfc
9 changed files with 106 additions and 44 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

14
femtolisp/builtins.c
View File

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

12
femtolisp/cvalues.c
View File

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

25
femtolisp/flisp.c
View File

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

3
femtolisp/flisp.h
View File

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

33
femtolisp/print.c
View File

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

40
femtolisp/test.lsp
View File

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

9
femtolisp/todo
View File

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

13
llt/dirpath.c
View File

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

1
llt/dirpath.h
View File

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