lassik
/
upscheme
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

fully separating femtolisp into library core and main program

This commit is contained in:
JeffBezanson 2010-05-02 18:17:47 +00:00
parent 1dcc71ec82
commit b7f08e854f
9 changed files with 180 additions and 104 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

19
femtolisp/Makefile
View File

@ -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)
$(CC) $(DEBUGFLAGS) $(DOBJS) -o $(EXENAME) $(LIBS)
$(LIBTARGET).da: $(DOBJS)
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)
$(CC) $(SHIPFLAGS) $(OBJS) -o $(EXENAME) $(LIBS)
release: $(OBJS) $(LIBFILES) $(LIBTARGET).a flmain.o
$(CC) $(SHIPFLAGS) $(OBJS) flmain.o -o $(EXENAME) $(LIBS) $(LIBTARGET).a
clean:
rm -f *.o

2
femtolisp/cvalues.c
View File

@ -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;
}

1
femtolisp/equalhash.c
View File

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

150
femtolisp/flisp.c
View File

@ -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 {
htable_t backrefs;
htable_t gensyms;
value_t source;
struct _readstate_t *prev;
} readstate_t;
static readstate_t *readstate = NULL;
static fl_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 {
jmp_buf buf;
uint32_t sp;
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
fl_exception_context_t *fl_ctx = NULL;
uint32_t fl_throwing_frame=0; // active frame when exception was thrown
value_t fl_lasterror;
#define FL_TRY \
exception_context_t _ctx; int l__tr, l__ca; \
_ctx.sp=SP; _ctx.frame=curr_frame; _ctx.rdst=readstate; _ctx.prev=ctx; \
_ctx.ngchnd = N_GCHND; ctx = &_ctx; \
fl_exception_context_t _ctx; int l__tr, l__ca; \
_ctx.sp=SP; _ctx.frame=curr_frame; _ctx.rdst=readstate; _ctx.prev=fl_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, \
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)
throwing_frame = curr_frame;
N_GCHND = ctx->ngchnd;
exception_context_t *thisctx = ctx;
if (ctx->prev) // don't throw past toplevel
ctx = ctx->prev;
if (fl_throwing_frame == 0)
fl_throwing_frame = curr_frame;
N_GCHND = fl_ctx->ngchnd;
fl_exception_context_t *thisctx = fl_ctx;
if (fl_ctx->prev) // don't throw past toplevel
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) {
top = throwing_frame - 4;
f = Stack[throwing_frame-4];
if (fl_throwing_frame > curr_frame) {
top = fl_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(EXEDIR));
setc(symbol("*install-dir*"), cvalue_static_cstring(strdup(exename)));
}
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;
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();
lisp_init();
}
extern value_t fl_file(value_t *args, uint32_t nargs);
int fl_startup()
int fl_load_system_image(value_t sys_image_iostream)
{
value_t e;
int saveSP;
symbol_t *sym;
char fname_buf[1024];
lisp_init();
fname_buf[0] = '\0';
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;
PUSH(sys_image_iostream);
saveSP = SP;
FL_TRY {
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);
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);
fl_print(ios_stderr, fl_lasterror);
ios_putc('\n', ios_stderr);
return 1;
}
ios_close(value2c(ios_t*,Stack[SP-1]));
POPN(1);
return 0;
}

35
femtolisp/flisp.h
View File

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

71
femtolisp/flmain.c Normal file
View File

@ -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;
}

1
femtolisp/iostream.c
View File

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

2
femtolisp/read.c
View File

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

1
femtolisp/table.c
View File

@ -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"