moving implementation of startup, repl, load, and top-level

exception handler into system.lsp

adding several iostream functions

adding support for internal define

femtolisp/ast/rpasses.lsp

@@ -20,8 +20,9 @@
 ; transformations
 
 (let ((ctr 0))
-  (define (r-gensym) (prog1 (intern (string "%r:" ctr))
+  (set! r-gensym (lambda ()
-			    (set! ctr (+ ctr 1)))))
+		   (prog1 (intern (string "%r:" ctr))
+			  (set! ctr (+ ctr 1))))))
 
 (define (dollarsign-transform e)
   (pattern-expand

femtolisp/builtins.c

@@ -35,12 +35,6 @@ value_t list_nth(value_t l, size_t n)
     return NIL;
 }
 
-value_t fl_load(value_t *args, u_int32_t nargs)
-{
-    argcount("load", nargs, 1);
-    return load_file(tostring(args[0], "load"));
-}
-
 value_t fl_exit(value_t *args, u_int32_t nargs)
 {
     if (nargs > 0)
@@ -375,7 +369,6 @@ static builtinspec_t builtin_info[] = {
     { "environment", fl_global_env },
     { "constant?", fl_constantp },
 
-    { "load", fl_load },
     { "exit", fl_exit },
     { "intern", fl_intern },
     { "fixnum", fl_fixnum },

femtolisp/flisp.c

@@ -111,7 +111,6 @@ typedef struct _ectx_t {
 
 static exception_context_t *ctx = NULL;
 static value_t lasterror;
-static char lerrorbuf[512];
 
 #define FL_TRY \
   exception_context_t _ctx; int l__tr, l__ca; \
@@ -122,14 +121,11 @@ static char lerrorbuf[512];
 
 #define FL_CATCH \
   else \
-      for (l__ca=1; l__ca; l__ca=0, lerrorbuf[0]='\0', lasterror=NIL)
+      for (l__ca=1; l__ca; l__ca=0, lasterror=NIL)
 
 void raise(value_t e)
 {
-    if (e != lasterror) {
+    lasterror = e;
-        lasterror = e;
-        lerrorbuf[0] = '\0';  // overwriting exception; clear error buf
-    }
     // unwind read state
     while (readstate != ctx->rdst) {
         free_readstate(readstate);
@@ -142,15 +138,21 @@ void raise(value_t e)
     longjmp(thisctx->buf, 1);
 }
 
+static value_t make_error_msg(char *format, va_list args)
+{
+    char msgbuf[512];
+    vsnprintf(msgbuf, sizeof(msgbuf), format, args);
+    return string_from_cstr(msgbuf);
+}
+
 void lerror(value_t e, char *format, ...)
 {
     va_list args;
     va_start(args, format);
-    vsnprintf(lerrorbuf, sizeof(lerrorbuf), format, args);
+    value_t msg = make_error_msg(format, args);
     va_end(args);
 
-    lasterror = e;
+    raise(list2(e, msg));
-    raise(e);
 }
 
 void type_error(char *fname, char *expected, value_t got)
@@ -1470,7 +1472,6 @@ void lisp_init(void)
     set(printprettysym=symbol("*print-pretty*"), FL_T);
     set(printwidthsym=symbol("*print-width*"), fixnum(SCR_WIDTH));
     lasterror = NIL;
-    lerrorbuf[0] = '\0';
     special_apply_form = fl_cons(builtin(F_SPECIAL_APPLY), NIL);
     i = 0;
     while (isspecial(builtin(i))) {
@@ -1483,13 +1484,13 @@ void lisp_init(void)
     }
 
 #ifdef LINUX
-    set(symbol("os.name"), symbol("linux"));
+    set(symbol("*os-name*"), symbol("linux"));
 #elif defined(WIN32) || defined(WIN64)
-    set(symbol("os.name"), symbol("win32"));
+    set(symbol("*os-name*"), symbol("win32"));
 #elif defined(MACOSX)
-    set(symbol("os.name"), symbol("macos"));
+    set(symbol("*os-name*"), symbol("macos"));
 #else
-    set(symbol("os.name"), symbol("unknown"));
+    set(symbol("*os-name*"), symbol("unknown"));
 #endif
 
     cvalues_init();
@@ -1521,81 +1522,15 @@ value_t toplevel_eval(value_t expr)
     return v;
 }
 
-static void print_toplevel_exception()
-{
-    if (iscons(lasterror) && car_(lasterror) == TypeError &&
-        llength(lasterror) == 4) {
-        ios_printf(ios_stderr, "type-error: ");
-        print(ios_stderr, car_(cdr_(lasterror)), 1);
-        ios_printf(ios_stderr, ": expected ");
-        print(ios_stderr, car_(cdr_(cdr_(lasterror))), 1);
-        ios_printf(ios_stderr, ", got ");
-        print(ios_stderr, car_(cdr_(cdr_(cdr_(lasterror)))), 0);
-    }
-    else if (iscons(lasterror) && car_(lasterror) == UnboundError &&
-             iscons(cdr_(lasterror))) {
-        ios_printf(ios_stderr, "unbound-error: eval: variable %s has no value",
-                   (symbol_name(car_(cdr_(lasterror)))));
-    }
-    else if (iscons(lasterror) && car_(lasterror) == Error) {
-        value_t v = cdr_(lasterror);
-        ios_printf(ios_stderr, "error: ");
-        while (iscons(v)) {
-            print(ios_stderr, car_(v), 1);
-            v = cdr_(v);
-        }
-    }
-    else {
-        if (lasterror != NIL) {
-            if (!lerrorbuf[0])
-                ios_printf(ios_stderr, "*** Unhandled exception: ");
-            print(ios_stderr, lasterror, 0);
-            if (lerrorbuf[0])
-                ios_printf(ios_stderr, ": ");
-        }
-    }
-
-    if (lerrorbuf[0])
-        ios_printf(ios_stderr, "%s", lerrorbuf);
-}
-
-value_t load_file(char *fname)
-{
-    value_t volatile e, v=NIL;
-    ios_t fi;
-    ios_t * volatile f;
-    fname = strdup(fname);
-    f = &fi; f = ios_file(f, fname, 1, 0, 0, 0);
-    if (f == NULL) lerror(IOError, "file \"%s\" not found", fname);
-    FL_TRY {
-        while (1) {
-            e = read_sexpr(f);
-            //print(ios_stdout,e,0); ios_putc('\n', ios_stdout);
-            if (ios_eof(f)) break;
-            v = toplevel_eval(e);
-        }
-    }
-    FL_CATCH {
-        ios_close(f);
-        size_t msglen = strlen(lerrorbuf);
-        snprintf(&lerrorbuf[msglen], sizeof(lerrorbuf)-msglen,
-                 "\nin file \"%s\"", fname);
-        lerrorbuf[sizeof(lerrorbuf)-1] = '\0';
-        free(fname);
-        raise(lasterror);
-    }
-    free(fname);
-    ios_close(f);
-    return v;
-}
-
 static value_t argv_list(int argc, char *argv[])
 {
     int i;
     PUSH(NIL);
-    if (argc > 1) { argc--; argv++; }
+    for(i=argc-1; i >= 0; i--) {
-    for(i=argc-1; i >= 0; i--)
+        PUSH(cvalue_static_cstring(argv[i]));
-        Stack[SP-1] = fl_cons(cvalue_static_cstring(argv[i]), Stack[SP-1]);
+        Stack[SP-2] = fl_cons(Stack[SP-1], Stack[SP-2]);
+        (void)POP();
+    }
     return POP();
 }
 
@@ -1603,23 +1538,21 @@ int locale_is_utf8;
 
 int main(int argc, char *argv[])
 {
-    value_t v;
+    value_t e, v;
     char fname_buf[1024];
 
     locale_is_utf8 = u8_is_locale_utf8(setlocale(LC_ALL, ""));
 
     lisp_init();
-    set(symbol("argv"), argv_list(argc, argv));
+
     FL_TRY {
         // install toplevel exception handler
     }
     FL_CATCH {
-        print_toplevel_exception();
+        ios_printf(ios_stderr, "fatal error during bootstrap:\n");
-        lerrorbuf[0] = '\0';
+        print(ios_stderr, lasterror, 0);
-        lasterror = NIL;
+        ios_putc('\n', ios_stderr);
-        ios_puts("\n\n", ios_stderr);
+        exit(1);
-        if (argc > 1) return 1;
-        else goto repl;
     }
     fname_buf[0] = '\0';
     if (EXEDIR != NULL) {
@@ -1627,27 +1560,19 @@ int main(int argc, char *argv[])
         strcat(fname_buf, PATHSEPSTRING);
     }
     strcat(fname_buf, "system.lsp");
-    load_file(fname_buf);
+
-    if (argc > 1) { load_file(argv[1]); return 0; }
+    ios_t fi;
-    printf(";  _                   \n");
+    ios_t *f = &fi; f = ios_file(f, fname_buf, 1, 0, 0, 0);
-    printf("; |_ _ _ |_ _ |  . _ _\n");
+    if (f == NULL) lerror(IOError, "file \"%s\" not found", fname_buf);
-    printf("; | (-||||_(_)|__|_)|_)\n");
-    printf(";-------------------|----------------------------------------------------------\n\n");
- repl:
     while (1) {
-        ios_puts("> ", ios_stdout); ios_flush(ios_stdout);
+        e = read_sexpr(f);
-        FL_TRY {
+        if (ios_eof(f)) break;
-            v = read_sexpr(ios_stdin);
+        v = toplevel_eval(e);
-        }
-        FL_CATCH {
-            ios_purge(ios_stdin);
-            raise(lasterror);
-        }
-        if (ios_eof(ios_stdin)) break;
-        print(ios_stdout, v=toplevel_eval(v), 0);
-        set(symbol("that"), v);
-        ios_puts("\n\n", ios_stdout);
     }
-    ios_putc('\n', ios_stdout);
+    ios_close(f);
+
+    PUSH(symbol_value(symbol("__start")));
+    PUSH(argv_list(argc, argv));
+    (void)toplevel_eval(special_apply_form);
     return 0;
 }

femtolisp/iostream.c

@@ -86,11 +86,51 @@ value_t fl_read(value_t *args, u_int32_t nargs)
     else
         s = toiostream(symbol_value(instrsym), "read");
     value_t v = read_sexpr(s);
-    if (ios_eof(s))
-        lerror(IOError, "read: end of file reached");
     return v;
 }
 
+value_t fl_iogetc(value_t *args, u_int32_t nargs)
+{
+    argcount("io.getc", nargs, 1);
+    ios_t *s = toiostream(args[0], "io.getc");
+    uint32_t wc;
+    if (ios_getutf8(s, &wc) == IOS_EOF)
+        lerror(IOError, "io.getc: end of file reached");
+    return mk_wchar(wc);
+}
+
+value_t fl_ioflush(value_t *args, u_int32_t nargs)
+{
+    argcount("io.flush", nargs, 1);
+    ios_t *s = toiostream(args[0], "io.flush");
+    if (ios_flush(s) != 0)
+        return FL_F;
+    return FL_T;
+}
+
+value_t fl_ioclose(value_t *args, u_int32_t nargs)
+{
+    argcount("io.close", nargs, 1);
+    ios_t *s = toiostream(args[0], "io.close");
+    ios_close(s);
+    return FL_T;
+}
+
+value_t fl_iopurge(value_t *args, u_int32_t nargs)
+{
+    argcount("io.discardbuffer", nargs, 1);
+    ios_t *s = toiostream(args[0], "io.discardbuffer");
+    ios_purge(s);
+    return FL_T;
+}
+
+value_t fl_ioeof(value_t *args, u_int32_t nargs)
+{
+    argcount("io.eof?", nargs, 1);
+    ios_t *s = toiostream(args[0], "io.eof?");
+    return (ios_eof(s) ? FL_T : FL_F);
+}
+
 static void do_ioprint(value_t *args, u_int32_t nargs, int princ, char *fname)
 {
     if (nargs < 2)
@@ -99,7 +139,6 @@ static void do_ioprint(value_t *args, u_int32_t nargs, int princ, char *fname)
     unsigned i;
     for (i=1; i < nargs; i++) {
         print(s, args[i], princ);
-        if (!princ) ios_putc('\n', s);
     }
 }
 value_t fl_ioprint(value_t *args, u_int32_t nargs)
@@ -119,6 +158,11 @@ static builtinspec_t iostreamfunc_info[] = {
     { "read", fl_read },
     { "io.print", fl_ioprint },
     { "io.princ", fl_ioprinc },
+    { "io.flush", fl_ioflush },
+    { "io.close", fl_ioclose },
+    { "io.eof?" , fl_ioeof },
+    { "io.getc" , fl_iogetc },
+    { "io.discardbuffer", fl_iopurge },
     { NULL, NULL }
 };
 

femtolisp/system.lsp

@@ -101,6 +101,43 @@
 	((eqv        (caar lst) item) (car lst))
 	(#t          (assv item (cdr lst)))))
 
+(define (delete-duplicates lst)
+  (if (atom? lst)
+      lst
+      (let ((elt  (car lst))
+	    (tail (cdr lst)))
+	(if (member elt tail)
+	    (delete-duplicates tail)
+	    (cons elt
+		  (delete-duplicates tail))))))
+
+(define (get-defined-vars- expr)
+  (cond ((atom? expr) ())
+	((and (eq? (car expr) 'define)
+	      (pair? (cdr expr)))
+	 (or (and (symbol? (cadr expr))
+		  (list (cadr expr)))
+	     (and (pair? (cadr expr))
+		  (symbol? (caadr expr))
+		  (list (caadr expr)))
+	     ()))
+	((eq? (car expr) 'begin)
+	 (apply append (map get-defined-vars- (cdr expr))))
+	(else ())))
+(define (get-defined-vars expr)
+  (delete-duplicates (get-defined-vars- expr)))
+
+; redefine f-body to support internal defines
+(define f-body- f-body)
+(define (f-body e)
+  ((lambda (B)
+     ((lambda (V)
+	(if (null? V)
+	    B
+	    (cons (list 'lambda V B) (map (lambda (x) #f) V))))
+      (get-defined-vars B)))
+   (f-body- e)))
+
 (define (macrocall? e) (and (symbol? (car e))
 			    (symbol-syntax (car e))))
 
@@ -173,6 +210,7 @@
 (define (abs x)   (if (< x 0) (- x) x))
 (define (identity x) x)
 (define K prog1)  ; K combinator ;)
+(define begin0 prog1)
 
 (define (caar x) (car (car x)))
 (define (cdar x) (cdr (car x)))
@@ -290,18 +328,19 @@
 
 (define-macro (let* binds . body)
   (cons (list 'lambda (map car binds)
-              (cons 'begin
+              (f-body
-                    (nconc (map (lambda (b) (cons 'set! b)) binds)
+	       (nconc (map (lambda (b) (cons 'set! b)) binds)
-                           body)))
+		      body)))
         (map (lambda (x) #f) binds)))
+(set-syntax! 'letrec (symbol-syntax 'let*))
 
 (define-macro (labels binds . body)
   (cons (list 'lambda (map car binds)
-              (cons 'begin
+              (f-body
-                    (nconc (map (lambda (b)
+	       (nconc (map (lambda (b)
-                                  (list 'set! (car b) (cons 'lambda (cdr b))))
+			     (list 'set! (car b) (cons 'lambda (cdr b))))
-                                binds)
+			   binds)
-                           body)))
+		      body)))
         (map (lambda (x) #f) binds)))
 
 (define-macro (when   c . body) (list 'if c (f-body body) #f))
@@ -545,3 +584,97 @@
   (string.encode #array(wchar 9 10 11 12 13 32 133 160 5760 6158 8192
 			      8193 8194 8195 8196 8197 8198 8199 8200
 			      8201 8202 8232 8233 8239 8287 12288)))
+
+(define (load filename)
+  (let ((F (file filename :read)))
+    (trycatch
+     (prog1
+      (let next (E v)
+	(if (not (io.eof? F))
+	    (next (read F)
+		  (eval E))
+	    v))
+      (io.close F))
+     (lambda (e)
+       (begin
+	 (io.close F)
+	 (raise `(load-error ,filename ,e)))))))
+
+(define *banner*
+";  _
+; |_ _ _ |_ _ |  . _ _
+; | (-||||_(_)|__|_)|_)
+;-------------------|----------------------------------------------------------
+
+")
+
+(define (repl)
+  (define (prompt)
+    (princ "> ") (io.flush *output-stream*)
+    (let ((v (trycatch (read)
+		       (lambda (e) (begin (io.discardbuffer *input-stream*)
+					  (raise e))))))
+      (and (not (io.eof? *input-stream*))
+	   (let ((V (eval v)))
+	     (print V)
+	     (set! that V)
+	     #t))))
+  (define (reploop)
+    (when (trycatch (and (prompt) (princ "\n"))
+		    print-exception)
+	  (begin (princ "\n")
+		 (reploop))))
+  (reploop)
+  (princ "\n"))
+
+(define (print-exception e)
+  (cond ((and (pair? e)
+	      (eq? (car e) 'type-error)
+	      (= (length e) 4))
+	 (io.princ *stderr* "type-error: ")
+	 (io.print *stderr* (cadr e))
+	 (io.princ *stderr* ": expected ")
+	 (io.print *stderr* (caddr e))
+	 (io.princ *stderr* ", got ")
+	 (io.print *stderr* (cadddr e)))
+
+	((and (pair? e)
+	      (eq? (car e) 'unbound-error)
+	      (pair? (cdr e)))
+	 (io.princ *stderr*
+		   "unbound-error: eval: variable " (cadr e)
+		   " has no value"))
+
+	((and (pair? e)
+	      (eq? (car e) 'error))
+	 (io.princ *stderr* "error: ")
+	 (apply io.princ (cons *stderr* (cdr e))))
+
+	((and (pair? e)
+	      (eq? (car e) 'load-error))
+	 (print-exception (caddr e))
+	 (io.princ *stderr* "in file " (cadr e)))
+
+	((and (list? e)
+	      (= (length e) 2))
+	 (io.princ *stderr* (car e) ": " (cadr e)))
+
+	(else (io.princ *stderr* "*** Unhandled exception: ")
+	      (io.print *stderr* e)))
+
+  (io.princ *stderr* "\n")
+  #t)
+
+(define (__script fname)
+  (trycatch (load fname)
+	    (lambda (e) (begin (print-exception e)
+			       (exit 1)))))
+
+(define (__start . argv)
+  (if (pair? (cdr argv))
+      (begin (set! *argv* (cdr argv))
+	     (__script (cadr argv)))
+      (begin (set! *argv* argv)
+	     (princ *banner*)
+	     (repl)))
+  (exit 0))

femtolisp/todo

@@ -833,22 +833,23 @@ IOStream API
 *read             - (read[ stream]) ; get next sexpr from stream
 *print
 *princ
+*file
  iostream         - (stream[ cvalue-as-bytestream])
  memstream
-*file
+ fifo
- io.eof
+ socket
+*io.eof
+*io.flush
+*io.close
+*io.discardbuffer
  io.write     - (io.write s cvalue)
  io.read      - (io.read s ctype [len])
- io.flush
- io.close
- io.pos       - (io.pos s [set-pos])
- io.seek      - (io.seek s offset)
  io.getc      - get utf8 character(s)
  io.readline
  io.copy      - (io.copy to from [nbytes])
  io.copyuntil - (io.copy to from byte)
- fifo
+ io.pos       - (io.pos s [set-pos])
- socket
+ io.seek      - (io.seek s offset)
  io.seekend   - move to end of stream
  io.trunc
  io.tostring! - destructively convert stringstream to string

llt/ios.c

@@ -516,6 +516,8 @@ void ios_close(ios_t *s)
     s->fd = -1;
     if (s->buf!=NULL && s->ownbuf && s->buf!=&s->local[0])
         free(s->buf);
+    s->buf = NULL;
+    s->size = s->maxsize = s->bpos = 0;
 }
 
 static void _buf_init(ios_t *s, bufmode_t bm)