fully separating femtolisp into library core and main program

femtolisp/Makefile

@@ -5,6 +5,7 @@ SRCS = $(NAME).c builtins.c string.c equalhash.c table.c iostream.c
 OBJS = $(SRCS:%.c=%.o)
 DOBJS = $(SRCS:%.c=%.do)
 EXENAME = $(NAME)
+LIBTARGET = lib$(NAME)
 LLTDIR = ../llt
 LLT = $(LLTDIR)/libllt.a
 
@@ -27,16 +28,26 @@ test:
 
 flisp.o:  flisp.c cvalues.c types.c flisp.h print.c read.c equal.c
 flisp.do: flisp.c cvalues.c types.c flisp.h print.c read.c equal.c
+flmain.o: flmain.c flisp.h
+flmain.do: flmain.c flisp.h
 
 $(LLT):
 	cd $(LLTDIR) && make
 
-debug: $(DOBJS) $(LIBFILES)
+$(LIBTARGET).da: $(DOBJS)
-	$(CC) $(DEBUGFLAGS) $(DOBJS) -o $(EXENAME) $(LIBS)
+	rm -rf $@
+	ar rs $@ $(DOBJS)
+
+$(LIBTARGET).a: $(OBJS)
+	rm -rf $@
+	ar rs $@ $(OBJS)
+
+debug: $(DOBJS) $(LIBFILES) $(LIBTARGET).da flmain.do
+	$(CC) $(DEBUGFLAGS) $(DOBJS) flmain.do -o $(EXENAME) $(LIBS) $(LIBTARGET).da
 	make test
 
-release: $(OBJS) $(LIBFILES)
+release: $(OBJS) $(LIBFILES) $(LIBTARGET).a flmain.o
-	$(CC) $(SHIPFLAGS) $(OBJS) -o $(EXENAME) $(LIBS)
+	$(CC) $(SHIPFLAGS) $(OBJS) flmain.o -o $(EXENAME) $(LIBS) $(LIBTARGET).a
 
 clean:
 	rm -f *.o

femtolisp/cvalues.c

@@ -762,7 +762,7 @@ static numerictype_t sym_to_numtype(value_t type)
         return T_FLOAT;
     else if (type == doublesym)
         return T_DOUBLE;
-    assert(false);
+    assert(0);
     return N_NUMTYPES;
 }
 

femtolisp/equalhash.c

@@ -3,6 +3,7 @@
 #include <string.h>
 #include <assert.h>
 #include <limits.h>
+#include <setjmp.h>
 
 #include "llt.h"
 #include "flisp.h"

femtolisp/flisp.c

@@ -109,15 +109,9 @@ static value_t apply_cl(uint32_t nargs);
 static value_t *alloc_words(int n);
 static value_t relocate(value_t v);
 
-typedef struct _readstate_t {
+static fl_readstate_t *readstate = NULL;
-    htable_t backrefs;
-    htable_t gensyms;
-    value_t source;
-    struct _readstate_t *prev;
-} readstate_t;
-static readstate_t *readstate = NULL;
 
-static void free_readstate(readstate_t *rs)
+static void free_readstate(fl_readstate_t *rs)
 {
     htable_free(&rs->backrefs);
     htable_free(&rs->gensyms);
@@ -133,45 +127,53 @@ static uint32_t *consflags;
 // error utilities ------------------------------------------------------------
 
 // saved execution state for an unwind target
-typedef struct _ectx_t {
+fl_exception_context_t *fl_ctx = NULL;
-    jmp_buf buf;
+uint32_t fl_throwing_frame=0;  // active frame when exception was thrown
-    uint32_t sp;
+value_t fl_lasterror;
-    uint32_t frame;
-    uint32_t ngchnd;
-    readstate_t *rdst;
-    struct _ectx_t *prev;
-} exception_context_t;
-
-static exception_context_t *ctx = NULL;
-static value_t lasterror;
-static uint32_t throwing_frame=0;  // active frame when exception was thrown
 
 #define FL_TRY \
-  exception_context_t _ctx; int l__tr, l__ca; \
+  fl_exception_context_t _ctx; int l__tr, l__ca; \
-  _ctx.sp=SP; _ctx.frame=curr_frame; _ctx.rdst=readstate; _ctx.prev=ctx; \
+  _ctx.sp=SP; _ctx.frame=curr_frame; _ctx.rdst=readstate; _ctx.prev=fl_ctx; \
-  _ctx.ngchnd = N_GCHND; ctx = &_ctx;                                    \
+  _ctx.ngchnd = N_GCHND; fl_ctx = &_ctx;                                    \
   if (!setjmp(_ctx.buf)) \
-      for (l__tr=1; l__tr; l__tr=0, (void)(ctx->prev && (ctx=ctx->prev)))
+    for (l__tr=1; l__tr; l__tr=0, (void)(fl_ctx->prev&&(fl_ctx=fl_ctx->prev)))
 
 #define FL_CATCH \
   else \
-      for (l__ca=1; l__ca; l__ca=0, \
+    for(l__ca=1; l__ca; l__ca=0, \
-           lasterror=NIL, throwing_frame=0, SP=_ctx.sp, curr_frame=_ctx.frame)
+      fl_lasterror=FL_NIL,fl_throwing_frame=0,SP=_ctx.sp,curr_frame=_ctx.frame)
+
+void fl_savestate(fl_exception_context_t *_ctx)
+{
+    _ctx->sp = SP;
+    _ctx->frame = curr_frame;
+    _ctx->rdst = readstate;
+    _ctx->prev = fl_ctx;
+    _ctx->ngchnd = N_GCHND;
+}
+
+void fl_restorestate(fl_exception_context_t *_ctx)
+{
+    fl_lasterror = FL_NIL;
+    fl_throwing_frame = 0;
+    SP = _ctx->sp;
+    curr_frame = _ctx->frame;
+}
 
 void fl_raise(value_t e)
 {
-    lasterror = e;
+    fl_lasterror = e;
     // unwind read state
-    while (readstate != ctx->rdst) {
+    while (readstate != fl_ctx->rdst) {
         free_readstate(readstate);
         readstate = readstate->prev;
     }
-    if (throwing_frame == 0)
+    if (fl_throwing_frame == 0)
-        throwing_frame = curr_frame;
+        fl_throwing_frame = curr_frame;
-    N_GCHND = ctx->ngchnd;
+    N_GCHND = fl_ctx->ngchnd;
-    exception_context_t *thisctx = ctx;
+    fl_exception_context_t *thisctx = fl_ctx;
-    if (ctx->prev)   // don't throw past toplevel
+    if (fl_ctx->prev)   // don't throw past toplevel
-        ctx = ctx->prev;
+        fl_ctx = fl_ctx->prev;
     longjmp(thisctx->buf, 1);
 }
 
@@ -525,14 +527,14 @@ void gc(int mustgrow)
     static int grew = 0;
     void *temp;
     uint32_t i, f, top;
-    readstate_t *rs;
+    fl_readstate_t *rs;
 
     curheap = tospace;
     lim = curheap+heapsize-sizeof(cons_t);
 
-    if (throwing_frame > curr_frame) {
+    if (fl_throwing_frame > curr_frame) {
-        top = throwing_frame - 4;
+        top = fl_throwing_frame - 4;
-        f = Stack[throwing_frame-4];
+        f = Stack[fl_throwing_frame-4];
     }
     else {
         top = SP;
@@ -558,7 +560,7 @@ void gc(int mustgrow)
         rs->source = relocate(rs->source);
         rs = rs->prev;
     }
-    lasterror = relocate(lasterror);
+    fl_lasterror = relocate(fl_lasterror);
     memory_exception_value = relocate(memory_exception_value);
     the_empty_vector = relocate(the_empty_vector);
 
@@ -796,7 +798,7 @@ static value_t do_trycatch()
     FL_CATCH {
         v = Stack[saveSP-2];
         PUSH(v);
-        PUSH(lasterror);
+        PUSH(fl_lasterror);
         v = apply_cl(1);
     }
     SP = saveSP;
@@ -2119,7 +2121,7 @@ value_t fl_stacktrace(value_t *args, u_int32_t nargs)
 {
     (void)args;
     argcount("stacktrace", nargs, 0);
-    return _stacktrace(throwing_frame ? throwing_frame : curr_frame);
+    return _stacktrace(fl_throwing_frame ? fl_throwing_frame : curr_frame);
 }
 
 static builtinspec_t core_builtin_info[] = {
@@ -2143,8 +2145,6 @@ static builtinspec_t core_builtin_info[] = {
 extern void builtins_init();
 extern void comparehash_init();
 
-static char *EXEDIR = NULL;
-
 static void lisp_init(void)
 {
     int i;
@@ -2197,7 +2197,7 @@ static void lisp_init(void)
     set(printwidthsym=symbol("*print-width*"), fixnum(SCR_WIDTH));
     set(printlengthsym=symbol("*print-length*"), FL_F);
     set(printlevelsym=symbol("*print-level*"), FL_F);
-    lasterror = NIL;
+    fl_lasterror = NIL;
     i = 0;
     for (i=OP_EQ; i <= OP_ASET; i++) {
         setc(symbol(builtin_names[i]), builtin(i));
@@ -2225,8 +2225,7 @@ static void lisp_init(void)
     char *exename = get_exename(buf, sizeof(buf));
     if (exename != NULL) {
         path_to_dirname(exename);
-        EXEDIR = strdup(exename);
+        setc(symbol("*install-dir*"), cvalue_static_cstring(strdup(exename)));
-        setc(symbol("*install-dir*"), cvalue_static_cstring(EXEDIR));
     }
 
     memory_exception_value = fl_list2(MemoryError,
@@ -2237,49 +2236,27 @@ static void lisp_init(void)
     builtins_init();
 }
 
-// repl -----------------------------------------------------------------------
+// top level ------------------------------------------------------------------
 
 value_t fl_toplevel_eval(value_t expr)
 {
     return fl_applyn(1, symbol_value(evalsym), expr);
 }
 
-static value_t argv_list(int argc, char *argv[])
+void fl_init()
 {
-    int i;
+    lisp_init();
-    PUSH(NIL);
-    for(i=argc-1; i >= 0; i--) {
-        PUSH(cvalue_static_cstring(argv[i]));
-        Stack[SP-2] = fl_cons(Stack[SP-1], Stack[SP-2]);
-        POPN(1);
-    }
-    return POP();
 }
 
-extern value_t fl_file(value_t *args, uint32_t nargs);
+int fl_load_system_image(value_t sys_image_iostream)
-
-int fl_startup()
 {
     value_t e;
     int saveSP;
     symbol_t *sym;
-    char fname_buf[1024];
 
-    lisp_init();
+    PUSH(sys_image_iostream);
-
+    saveSP = SP;
-    fname_buf[0] = '\0';
+    FL_TRY {
-    if (EXEDIR != NULL) {
-        strcat(fname_buf, EXEDIR);
-        strcat(fname_buf, PATHSEPSTRING);
-    }
-    strcat(fname_buf, "flisp.boot");
-
-    FL_TRY {    // toplevel exception handler
-        PUSH(cvalue_static_cstring(fname_buf));
-        PUSH(symbol(":read"));
-        value_t f = fl_file(&Stack[SP-2], 2);
-        POPN(2);
-        PUSH(f); saveSP = SP;
         while (1) {
             e = fl_read_sexpr(Stack[SP-1]);
             if (ios_eof(value2c(ios_t*,Stack[SP-1]))) break;
@@ -2301,33 +2278,14 @@ int fl_startup()
                 break;
             }
         }
-        ios_close(value2c(ios_t*,Stack[SP-1]));
-        POPN(1);
     }
     FL_CATCH {
         ios_puts("fatal error during bootstrap:\n", ios_stderr);
-        fl_print(ios_stderr, lasterror);
+        fl_print(ios_stderr, fl_lasterror);
-        ios_putc('\n', ios_stderr);
-        return 1;
-    }
-    return 0;
-}
-
-int main(int argc, char *argv[])
-{
-    if (fl_startup())
-        return 1;
-
-    FL_TRY {
-        PUSH(symbol_value(symbol("__start")));
-        PUSH(argv_list(argc, argv));
-        (void)_applyn(1);
-    }
-    FL_CATCH {
-        ios_puts("fatal error:\n", ios_stderr);
-        fl_print(ios_stderr, lasterror);
         ios_putc('\n', ios_stderr);
         return 1;
     }
+    ios_close(value2c(ios_t*,Stack[SP-1]));
+    POPN(1);
     return 0;
 }

femtolisp/flisp.h

@@ -148,8 +148,40 @@ fixnum_t tofixnum(value_t v, char *fname);
 char *tostring(value_t v, char *fname);
 
 /* error handling */
+typedef struct _fl_readstate_t {
+    htable_t backrefs;
+    htable_t gensyms;
+    value_t source;
+    struct _fl_readstate_t *prev;
+} fl_readstate_t;
+
+typedef struct _ectx_t {
+    jmp_buf buf;
+    uint32_t sp;
+    uint32_t frame;
+    uint32_t ngchnd;
+    fl_readstate_t *rdst;
+    struct _ectx_t *prev;
+} fl_exception_context_t;
+
+extern fl_exception_context_t *fl_ctx;
+extern uint32_t fl_throwing_frame;
+extern value_t fl_lasterror;
+
+#define FL_TRY_EXTERN                                                   \
+  fl_exception_context_t _ctx; int l__tr, l__ca;                        \
+  fl_savestate(&_ctx); fl_ctx = &_ctx;                                  \
+  if (!setjmp(_ctx.buf))                                                \
+    for (l__tr=1; l__tr; l__tr=0, (void)(fl_ctx->prev&&(fl_ctx=fl_ctx->prev)))
+
+#define FL_CATCH_EXTERN \
+  else \
+    for(l__ca=1; l__ca; l__ca=0, fl_restorestate(&_ctx))
+
 void lerrorf(value_t e, char *format, ...) __attribute__ ((__noreturn__));
 void lerror(value_t e, const char *msg) __attribute__ ((__noreturn__));
+void fl_savestate(fl_exception_context_t *_ctx);
+void fl_restorestate(fl_exception_context_t *_ctx);
 void fl_raise(value_t e) __attribute__ ((__noreturn__));
 void type_error(char *fname, char *expected, value_t got) __attribute__ ((__noreturn__));
 void bounds_error(char *fname, value_t arr, value_t ind) __attribute__ ((__noreturn__));
@@ -322,6 +354,7 @@ value_t fl_hash(value_t *args, u_int32_t nargs);
 value_t cvalue_byte(value_t *args, uint32_t nargs);
 value_t cvalue_wchar(value_t *args, uint32_t nargs);
 
-int fl_startup();
+void fl_init();
+int fl_load_system_image(value_t ios);
 
 #endif

femtolisp/flmain.c

@@ -0,0 +1,71 @@
+#include <stdlib.h>
+#include <stdio.h>
+#include <string.h>
+#include <setjmp.h>
+#include <stdarg.h>
+#include <assert.h>
+#include <ctype.h>
+#include <wctype.h>
+#include <sys/types.h>
+#include <locale.h>
+#include <limits.h>
+#include <errno.h>
+#include <math.h>
+#include "llt.h"
+#include "flisp.h"
+#include "opcodes.h"
+
+static value_t argv_list(int argc, char *argv[])
+{
+    int i;
+    value_t lst, temp;
+    fl_gc_handle(&lst);
+    fl_gc_handle(&temp);
+    for(i=argc-1; i >= 0; i--) {
+        temp = cvalue_static_cstring(argv[i]);
+        lst = fl_cons(temp, lst);
+    }
+    fl_free_gc_handles(2);
+    return lst;
+}
+
+extern value_t fl_file(value_t *args, uint32_t nargs);
+
+int main(int argc, char *argv[])
+{
+    char fname_buf[1024];
+
+    fl_init();
+
+    fname_buf[0] = '\0';
+    value_t str = symbol_value(symbol("*install-dir*"));
+    char *exedir = (str == UNBOUND ? NULL : cvalue_data(str));
+    if (exedir != NULL) {
+        strcat(fname_buf, exedir);
+        strcat(fname_buf, PATHSEPSTRING);
+    }
+    strcat(fname_buf, "flisp.boot");
+
+    value_t args[2];
+    fl_gc_handle(&args[0]);
+    fl_gc_handle(&args[1]);
+    FL_TRY_EXTERN {
+        args[0] = cvalue_static_cstring(fname_buf);
+        args[1] = symbol(":read");
+        value_t f = fl_file(&args[0], 2);
+        fl_free_gc_handles(2);
+
+        if (fl_load_system_image(f))
+            return 1;
+
+        (void)fl_applyn(1, symbol_value(symbol("__start")),
+                        argv_list(argc, argv));
+    }
+    FL_CATCH_EXTERN {
+        ios_puts("fatal error:\n", ios_stderr);
+        fl_print(ios_stderr, fl_lasterror);
+        ios_putc('\n', ios_stderr);
+        return 1;
+    }
+    return 0;
+}

femtolisp/iostream.c

@@ -4,6 +4,7 @@
 #include <string.h>
 #include <assert.h>
 #include <sys/types.h>
+#include <setjmp.h>
 #include "llt.h"
 #include "flisp.h"
 

femtolisp/read.c

@@ -659,7 +659,7 @@ static value_t do_read_sexpr(value_t label)
 value_t fl_read_sexpr(value_t f)
 {
     value_t v;
-    readstate_t state;
+    fl_readstate_t state;
     state.prev = readstate;
     htable_new(&state.backrefs, 8);
     htable_new(&state.gensyms, 8);

femtolisp/table.c

@@ -4,6 +4,7 @@
 #include <string.h>
 #include <assert.h>
 #include <sys/types.h>
+#include <setjmp.h>
 #include "llt.h"
 #include "flisp.h"
 #include "equalhash.h"