conservatory
/
femtolisp
4
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

fixing some bugs in lerror and read 

making memory errors non-consing (duh)
cleaning up main() a bit
adding case macro, moving other stuff around a bit
This commit is contained in:
JeffBezanson 2009-02-20 05:11:05 +00:00
parent f1927a3b57
commit 3aad0bd6be
4 changed files with 109 additions and 71 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

54
femtolisp/flisp.c
View File

@ -148,10 +148,12 @@ static value_t make_error_msg(char *format, va_list args)
void lerror(value_t e, char *format, ...)
{
va_list args;
PUSH(e);
va_start(args, format);
value_t msg = make_error_msg(format, args);
va_end(args);
e = POP();
raise(list2(e, msg));
}
@ -446,6 +448,7 @@ static void trace_globals(symbol_t *root)
}
static value_t special_apply_form;
static value_t memory_exception_value;
void gc(int mustgrow)
{
@ -471,6 +474,7 @@ void gc(int mustgrow)
}
lasterror = relocate(lasterror);
special_apply_form = relocate(special_apply_form);
memory_exception_value = relocate(memory_exception_value);
sweep_finalizers();
@ -488,7 +492,7 @@ void gc(int mustgrow)
if (grew || ((lim-curheap) < (int)(heapsize/5)) || mustgrow) {
temp = realloc_aligned(tospace, grew ? heapsize : heapsize*2, 16);
if (temp == NULL)
lerror(MemoryError, "out of memory");
raise(memory_exception_value);
tospace = temp;
if (!grew) {
heapsize*=2;
@ -496,7 +500,7 @@ void gc(int mustgrow)
else {
temp = bitvector_resize(consflags, heapsize/sizeof(cons_t), 1);
if (temp == NULL)
lerror(MemoryError, "out of memory");
raise(memory_exception_value);
consflags = (uint32_t*)temp;
}
grew = !grew;
@ -1505,6 +1509,9 @@ void lisp_init(void)
setc(symbol("*install-dir*"), cvalue_static_cstring(EXEDIR));
}
memory_exception_value = list2(MemoryError,
cvalue_static_cstring("out of memory"));
builtins_init();
}
@ -1545,15 +1552,6 @@ int main(int argc, char *argv[])
lisp_init();
FL_TRY {
// install toplevel exception handler
}
FL_CATCH {
ios_printf(ios_stderr, "fatal error during bootstrap:\n");
print(ios_stderr, lasterror, 0);
ios_putc('\n', ios_stderr);
exit(1);
}
fname_buf[0] = '\0';
if (EXEDIR != NULL) {
strcat(fname_buf, EXEDIR);
@ -1561,18 +1559,28 @@ int main(int argc, char *argv[])
}
strcat(fname_buf, "system.lsp");
ios_t fi;
ios_t *f = &fi; f = ios_file(f, fname_buf, 1, 0, 0, 0);
if (f == NULL) lerror(IOError, "file \"%s\" not found", fname_buf);
while (1) {
e = read_sexpr(f);
if (ios_eof(f)) break;
v = toplevel_eval(e);
}
ios_close(f);
ios_t fi; ios_t *f = &fi;
FL_TRY {
// install toplevel exception handler
f = ios_file(f, fname_buf, 1, 0, 0, 0);
if (f == NULL) lerror(IOError, "file \"%s\" not found", fname_buf);
while (1) {
e = read_sexpr(f);
if (ios_eof(f)) break;
v = toplevel_eval(e);
}
ios_close(f);
PUSH(symbol_value(symbol("__start")));
PUSH(argv_list(argc, argv));
(void)toplevel_eval(special_apply_form);
}
FL_CATCH {
ios_printf(ios_stderr, "fatal error during bootstrap:\n");
print(ios_stderr, lasterror, 0);
ios_putc('\n', ios_stderr);
return 1;
}
PUSH(symbol_value(symbol("__start")));
PUSH(argv_list(argc, argv));
(void)toplevel_eval(special_apply_form);
return 0;
}

23
femtolisp/iostream.c
View File

@ -61,7 +61,6 @@ value_t fl_file(value_t *args, uint32_t nargs)
if (nargs < 1)
argcount("file", nargs, 1);
int i, r=1, w=0, c=0, t=0, a=0;
char *fname = tostring(args[0], "file");
for(i=1; i < (int)nargs; i++) {
if (args[i] == wrsym) w = 1;
else if (args[i] == apsym) a = 1;
@ -69,6 +68,7 @@ value_t fl_file(value_t *args, uint32_t nargs)
else if (args[i] == truncsym) t = 1;
}
value_t f = cvalue(iostreamtype, sizeof(ios_t));
char *fname = tostring(args[0], "file");
ios_t *s = value2c(ios_t*, f);
if (ios_file(s, fname, r, w, c, t) == NULL)
lerror(IOError, "file: could not open \"%s\"", fname);
@ -78,14 +78,21 @@ value_t fl_file(value_t *args, uint32_t nargs)
value_t fl_read(value_t *args, u_int32_t nargs)
{
if (nargs > 1)
if (nargs > 1) {
argcount("read", nargs, 1);
ios_t *s;
if (nargs > 0)
s = toiostream(args[0], "read");
else
s = toiostream(symbol_value(instrsym), "read");
value_t v = read_sexpr(s);
}
else if (nargs == 0) {
PUSH(symbol_value(instrsym));
args = &Stack[SP-1];
}
ios_t *s = toiostream(args[0], "read");
// temporarily pin the stream while reading
ios_t temp = *s;
if (s->buf == &s->local[0])
temp.buf = &temp.local[0];
value_t v = read_sexpr(&temp);
s = value2c(ios_t*, args[0]);
*s = temp;
return v;
}

97
femtolisp/system.lsp
View File

@ -337,45 +337,6 @@
(define-macro (when c . body) (list 'if c (f-body body) #f))
(define-macro (unless c . body) (list 'if c #f (f-body body)))
(define-macro (dotimes var . body)
(let ((v (car var))
(cnt (cadr var)))
`(for 0 (- ,cnt 1)
(lambda (,v) ,(f-body body)))))
(define (map-int f n)
(if (<= n 0)
()
(let ((first (cons (f 0) ()))
(acc ()))
(set! acc first)
(for 1 (- n 1)
(lambda (i)
(begin (rplacd acc (cons (f i) ()))
(set! acc (cdr acc)))))
first)))
(define (iota n) (map-int identity n))
(define ι iota)
(define (error . args) (raise (cons 'error args)))
(define-macro (throw tag value) `(raise (list 'thrown-value ,tag ,value)))
(define-macro (catch tag expr)
(let ((e (gensym)))
`(trycatch ,expr
(lambda (,e) (if (and (pair? ,e)
(eq (car ,e) 'thrown-value)
(eq (cadr ,e) ,tag))
(caddr ,e)
(raise ,e))))))
(define-macro (unwind-protect expr finally)
(let ((e (gensym)))
`(prog1 (trycatch ,expr
(lambda (,e) (begin ,finally (raise ,e))))
,finally)))
(define (revappend l1 l2) (nconc (reverse l1) l2))
(define (nreconc l1 l2) (nconc (nreverse l1) l2))
@ -445,6 +406,63 @@
(cadr x)
(bq-process x)))
(define (quote-value v)
(if (self-evaluating? v)
v
(list 'quote v)))
(define-macro (case key . clauses)
(define (vals-to-cond key v)
(cond ((eq? v 'else) 'else)
((null? v) #f)
((null? (cdr v)) `(eqv? ,key ,(quote-value (car v))))
(else `(memv ,key ',v))))
(let ((g (gensym)))
`(let ((,g ,key))
(cond ,@(map (lambda (clause)
(cons (vals-to-cond g (car clause))
(cdr clause)))
clauses)))))
(define-macro (dotimes var . body)
(let ((v (car var))
(cnt (cadr var)))
`(for 0 (- ,cnt 1)
(lambda (,v) ,(f-body body)))))
(define (map-int f n)
(if (<= n 0)
()
(let ((first (cons (f 0) ()))
(acc ()))
(set! acc first)
(for 1 (- n 1)
(lambda (i)
(begin (rplacd acc (cons (f i) ()))
(set! acc (cdr acc)))))
first)))
(define (iota n) (map-int identity n))
(define ι iota)
(define (error . args) (raise (cons 'error args)))
(define-macro (throw tag value) `(raise (list 'thrown-value ,tag ,value)))
(define-macro (catch tag expr)
(let ((e (gensym)))
`(trycatch ,expr
(lambda (,e) (if (and (pair? ,e)
(eq (car ,e) 'thrown-value)
(eq (cadr ,e) ,tag))
(caddr ,e)
(raise ,e))))))
(define-macro (unwind-protect expr finally)
(let ((e (gensym)))
`(prog1 (trycatch ,expr
(lambda (,e) (begin ,finally (raise ,e))))
,finally)))
(define-macro (assert expr) `(if ,expr #t (raise '(assert-failed ,expr))))
(define-macro (time expr)
@ -455,6 +473,7 @@
(princ "Elapsed time: " (- (time.now) ,t0) " seconds\n")))))
(define (display x) (princ x) #t)
(define (println . args) (prog1 (apply print args) (princ "\n")))
(define (vu8 . elts) (apply array (cons 'uint8 elts)))

6
femtolisp/todo
View File

@ -935,7 +935,11 @@ consolidated todo list as of 8/30:
* hashtable
* generic aref/aset
- expose io stream object
- new toplevel
* new toplevel
* make raising a memory error non-consing
- eliminate string copy in lerror() when possible
- fix printing lists of short strings
- remaining c types
- remaining cvalues functions