ref: 3aad0bd6bed1e0d7e137709fb41393066af448be
parent: f1927a3b57f5fe4001297f44045e2b06f8cd3942
author: JeffBezanson <jeff.bezanson@gmail.com>
date: Fri Feb 20 00:11:05 EST 2009
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
--- a/femtolisp/flisp.c
+++ b/femtolisp/flisp.c
@@ -148,10 +148,12 @@
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 value_t special_apply_form;
+static value_t memory_exception_value;
void gc(int mustgrow)
{@@ -471,6 +474,7 @@
}
lasterror = relocate(lasterror);
special_apply_form = relocate(special_apply_form);
+ memory_exception_value = relocate(memory_exception_value);
sweep_finalizers();
@@ -488,7 +492,7 @@
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 @@
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 @@
setc(symbol("*install-dir*"), cvalue_static_cstring(EXEDIR));}
+ memory_exception_value = list2(MemoryError,
+ cvalue_static_cstring("out of memory"));+
builtins_init();
}
@@ -1545,34 +1552,35 @@
lisp_init();
+ fname_buf[0] = '\0';
+ if (EXEDIR != NULL) {+ strcat(fname_buf, EXEDIR);
+ strcat(fname_buf, PATHSEPSTRING);
+ }
+ strcat(fname_buf, "system.lsp");
+
+ 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);- exit(1);
+ return 1;
}
- fname_buf[0] = '\0';
- if (EXEDIR != NULL) {- strcat(fname_buf, EXEDIR);
- strcat(fname_buf, PATHSEPSTRING);
- }
- 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);
-
- PUSH(symbol_value(symbol("__start")));- PUSH(argv_list(argc, argv));
- (void)toplevel_eval(special_apply_form);
return 0;
}
--- a/femtolisp/iostream.c
+++ b/femtolisp/iostream.c
@@ -61,7 +61,6 @@
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 @@
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_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;
}
--- 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)))
--- a/femtolisp/todo
+++ b/femtolisp/todo
@@ -935,7 +935,11 @@
* 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