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

@@ -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,8 +1559,10 @@ int main(int argc, char *argv[])
     }
     strcat(fname_buf, "system.lsp");
 
-    ios_t fi;
+    ios_t fi; ios_t *f = &fi;
-    ios_t *f = &fi; f = ios_file(f, fname_buf, 1, 0, 0, 0);
+    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);
@@ -1574,5 +1574,13 @@ int main(int argc, char *argv[])
         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;
+    }
+
     return 0;
 }

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)
+    else if (nargs == 0) {
-        s = toiostream(args[0], "read");
+        PUSH(symbol_value(instrsym));
-    else
+        args = &Stack[SP-1];
-        s = toiostream(symbol_value(instrsym), "read");
+    }
-    value_t v = read_sexpr(s);
+    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;
 }
 

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

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