From 3aad0bd6bed1e0d7e137709fb41393066af448be Mon Sep 17 00:00:00 2001 From: JeffBezanson Date: Fri, 20 Feb 2009 05:11:05 +0000 Subject: [PATCH] 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 --- femtolisp/flisp.c | 54 +++++++++++++----------- femtolisp/iostream.c | 23 +++++++---- femtolisp/system.lsp | 97 ++++++++++++++++++++++++++------------------ femtolisp/todo | 6 ++- 4 files changed, 109 insertions(+), 71 deletions(-) diff --git a/femtolisp/flisp.c b/femtolisp/flisp.c index 2b11e49..25e60a9 100644 --- a/femtolisp/flisp.c +++ b/femtolisp/flisp.c @@ -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; } diff --git a/femtolisp/iostream.c b/femtolisp/iostream.c index c1a0b7c..90d4296 100644 --- a/femtolisp/iostream.c +++ b/femtolisp/iostream.c @@ -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; } diff --git a/femtolisp/system.lsp b/femtolisp/system.lsp index 0cfb2a5..03da0d3 100644 --- a/femtolisp/system.lsp +++ b/femtolisp/system.lsp @@ -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))) diff --git a/femtolisp/todo b/femtolisp/todo index fad99d9..0c0b44a 100644 --- a/femtolisp/todo +++ b/femtolisp/todo @@ -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