adding with-bindings, with-output-to-file, with-output-to

simplifying printing. now based on standard function write,
  removing io.print and io.princ
using same top level exception handler for scripts as repl

femtolisp/flisp.c

@@ -1962,6 +1962,8 @@ static value_t fl_function(value_t *args, uint32_t nargs)
                 fn->name = args[3];
             }
         }
+        if (isgensym(fn->name))
+            lerror(ArgError, "function: name should not be a gensym");
     }
     return fv;
 }

femtolisp/iostream.c

@@ -179,28 +179,17 @@ value_t fl_iopos(value_t *args, u_int32_t nargs)
     return size_wrap((size_t)res);
 }
 
-static void do_ioprint(value_t *args, u_int32_t nargs, char *fname)
+value_t fl_write(value_t *args, u_int32_t nargs)
 {
-    if (nargs < 2)
+    if (nargs < 1 || nargs > 2)
-        argcount(fname, nargs, 2);
+        argcount("write", nargs, 1);
-    ios_t *s = toiostream(args[0], fname);
+    ios_t *s;
-    unsigned i;
+    if (nargs == 2)
-    for (i=1; i < nargs; i++) {
+        s = toiostream(args[1], "write");
-        print(s, args[i]);
+    else
-    }
+        s = toiostream(symbol_value(outstrsym), "write");
-}
+    print(s, args[0]);
-value_t fl_ioprint(value_t *args, u_int32_t nargs)
+    return args[0];
-{
-    do_ioprint(args, nargs, "io.print");
-    return args[nargs-1];
-}
-value_t fl_ioprinc(value_t *args, u_int32_t nargs)
-{
-    value_t oldpr = symbol_value(printreadablysym);
-    set(printreadablysym, FL_F);
-    do_ioprint(args, nargs, "io.princ");
-    set(printreadablysym, oldpr);
-    return args[nargs-1];
 }
 
 value_t fl_ioread(value_t *args, u_int32_t nargs)
@@ -344,8 +333,7 @@ static builtinspec_t iostreamfunc_info[] = {
     { "file", fl_file },
     { "buffer", fl_buffer },
     { "read", fl_read },
-    { "io.print", fl_ioprint },
+    { "write", fl_write },
-    { "io.princ", fl_ioprinc },
     { "io.flush", fl_ioflush },
     { "io.close", fl_ioclose },
     { "io.eof?" , fl_ioeof },

femtolisp/system.lsp

@@ -436,6 +436,16 @@
 	     (for-each f (cdr l)))
       #t))
 
+(define-macro (with-bindings binds . body)
+  (let ((vars (map car binds))
+	(vals (map cadr binds))
+	(olds (map (lambda (x) (gensym)) binds)))
+    `(let ,(map list olds vars)
+       ,@(map (lambda (v val) `(set! ,v ,val)) vars vals)
+       (unwind-protect
+	(begin ,@body)
+	(begin ,@(map (lambda (v old) `(set! ,v ,old)) vars olds))))))
+
 ; exceptions ------------------------------------------------------------------
 
 (define (error . args) (raise (cons 'error args)))
@@ -495,8 +505,10 @@
 
 ; text I/O --------------------------------------------------------------------
 
-(define (print . args) (apply io.print *output-stream* args))
+(define (print . args) (for-each write args))
-(define (princ . args) (apply io.princ *output-stream* args))
+(define (princ . args)
+  (with-bindings ((*print-readably* #f))
+		 (for-each write args)))
 
 (define (newline) (princ *linefeed*) #t)
 (define (display x) (princ x) #t)
@@ -515,6 +527,17 @@
 (define (io.readlines s) (read-all-of io.readline s))
 (define (read-all s) (read-all-of read s))
 
+(define-macro (with-output-to stream . body)
+  `(with-bindings ((*output-stream* ,stream))
+		  ,@body))
+
+(define (with-output-to-file name thunk)
+  (let ((f (file name :write :create :truncate)))
+    (unwind-protect
+     (with-bindings ((*output-stream* f))
+		    (thunk))
+     (io.close f))))
+
 ; vector functions ------------------------------------------------------------
 
 (define (list->vector l) (apply vector l))
@@ -606,7 +629,7 @@
 
 (define (print-to-string v)
   (let ((b (buffer)))
-    (io.print b v)
+    (write v b)
     (io.tostring! b)))
 
 (define (string.join strlist sep)
@@ -708,14 +731,18 @@
   (define (reploop)
     (when (trycatch (and (prompt) (newline))
 		    (lambda (e)
-		      (print-exception e)
+		      (top-level-exception-handler e)
-		      (print-stack-trace (stacktrace))
 		      #t))
 	  (begin (newline)
 		 (reploop))))
   (reploop)
   (newline))
 
+(define (top-level-exception-handler e)
+  (with-output-to *stderr*
+		  (print-exception e)
+		  (print-stack-trace (stacktrace))))
+
 (define (print-stack-trace st)
   (define (find-in-f f tgt path)
     (let ((path (cons (function:name f) path)))
@@ -750,48 +777,46 @@
      st)))
 
 (define (print-exception e)
-  (define (eprinc . args) (apply io.princ *error-stream* args))
-  (define (eprint . args) (apply io.print *error-stream* args))
   (cond ((and (pair? e)
 	      (eq? (car e) 'type-error)
 	      (length= e 4))
-	 (eprinc "type error: " (cadr e) ": expected " (caddr e) ", got ")
+	 (princ "type error: " (cadr e) ": expected " (caddr e) ", got ")
-	 (eprint (cadddr e)))
+	 (print (cadddr e)))
 
 	((and (pair? e)
 	      (eq? (car e) 'bounds-error)
 	      (length= e 4))
-	 (eprinc (cadr e) ": index " (cadddr e) " out of bounds for ")
+	 (princ (cadr e) ": index " (cadddr e) " out of bounds for ")
-	 (eprint (caddr e)))
+	 (print (caddr e)))
 
 	((and (pair? e)
 	      (eq? (car e) 'unbound-error)
 	      (pair? (cdr e)))
-	 (eprinc "eval: variable " (cadr e) " has no value"))
+	 (princ "eval: variable " (cadr e) " has no value"))
 
 	((and (pair? e)
 	      (eq? (car e) 'error))
-	 (eprinc "error: ")
+	 (princ "error: ")
-	 (apply eprinc (cdr e)))
+	 (apply princ (cdr e)))
 
 	((and (pair? e)
 	      (eq? (car e) 'load-error))
 	 (print-exception (caddr e))
-	 (eprinc "in file " (cadr e)))
+	 (princ "in file " (cadr e)))
 
 	((and (list? e)
 	      (length= e 2))
-	 (eprint (car e))
+	 (print (car e))
-	 (eprinc ": ")
+	 (princ ": ")
 	 (let ((msg (cadr e)))
 	   ((if (or (string? msg) (symbol? msg))
-		eprinc eprint)
+		princ print)
 	    msg)))
 
-	(else (eprinc "*** Unhandled exception: ")
+	(else (princ "*** Unhandled exception: ")
-	      (eprint e)))
+	      (print e)))
 
-  (eprinc *linefeed*))
+  (princ *linefeed*))
 
 (define (simple-sort l)
   (if (or (null? l) (null? (cdr l))) l
@@ -804,11 +829,11 @@
 (define (make-system-image fname)
   (let ((f (file fname :write :create :truncate))
 	(excludes '(*linefeed* *directory-separator* *argv* that
-		    *print-pretty* *print-width* *print-readably*))
+			       *print-pretty* *print-width* *print-readably*)))
-	(pp *print-pretty*))
+    (with-bindings ((*print-pretty* #f)
-    (set! *print-pretty* #f)
+		    (*print-readably* #t))
-    (unwind-protect
+      (let ((syms
-     (let ((syms (filter (lambda (s)
+	     (filter (lambda (s)
 		       (and (bound? s)
 			    (not (constant? s))
 			    (or (not (builtin? (top-level-value s)))
@@ -817,11 +842,9 @@
 			    (not (memq s excludes))
 			    (not (iostream? (top-level-value s)))))
 		     (simple-sort (environment)))))
-       (io.print f (apply nconc (map list syms (map top-level-value syms))))
+	(write (apply nconc (map list syms (map top-level-value syms))) f)
 	(io.write f *linefeed*))
-     (begin
+      (io.close f))))
-       (io.close f)
-       (set! *print-pretty* pp)))))
 
 ; initialize globals that need to be set at load time
 (define (__init_globals)
@@ -838,7 +861,7 @@
 
 (define (__script fname)
   (trycatch (load fname)
-	    (lambda (e) (begin (print-exception e)
+	    (lambda (e) (begin (top-level-exception-handler e)
 			       (exit 1)))))
 
 (define (__start argv)

femtolisp/todo

@@ -31,7 +31,7 @@
 * fix printing nan and inf
 * move to "2.5-bit" type tags
 ? builtin abs()
-- try adding optional arguments, (lambda (x (opt 0)) ...), see if performance
+* try adding optional arguments, (lambda (x (opt 0)) ...), see if performance
   is acceptable
 * (syntax-environment) to return it as an assoc list
 * (environment) for variables, constantp
@@ -110,7 +110,6 @@ possible optimizations:
 * represent lambda environment as a vector (in lispv)
 x setq builtin (didn't help)
 * list builtin, to use cons_reserve
-(- let builtin, to further avoid env consing)
 unconventional interpreter builtins that can be used as a compilation
 target without moving away from s-expressions:
 - (*global* . a)  ; special form, don't look in local env first
@@ -139,6 +138,7 @@ for internal use:
   . and/or add function array.alloc
 x preallocate all byte,int8,uint8 values, and some wchars (up to 0x31B7?)
   . this made no difference in a string.map microbenchmark
+- use faster hash/compare in tables where the keys are eq-comparable
 
 bugs:
 * with the fully recursive (simpler) relocate(), the size of cons chains
@@ -976,7 +976,7 @@ consolidated todo list as of 7/8:
 - remaining cvalues functions
 - finish ios
 * optional arguments
-- keyword arguments
+* keyword arguments
 - some kind of record, struct, or object system
 
 - special efficient reader for #array
@@ -1169,3 +1169,4 @@ what needs more test coverage:
 - typeof, copy, podp, builtin()
 - bitwise and logical ops
 - making a closure in a default value expression for an optional arg
+- gc during a catch block, then get stack trace