From 68fde07ef9d02fbd0031b4d80a8722a79eb49a63 Mon Sep 17 00:00:00 2001 From: hyung-hwan Date: Sun, 18 Sep 2005 11:34:35 +0000 Subject: [PATCH] *** empty log message *** --- ase/lsp/array.c | 20 +- ase/lsp/env.c | 38 +-- ase/lsp/env.h | 10 +- ase/lsp/lsp.h | 17 +- ase/lsp/mem.c | 662 ++++++++++++++++++++++++++++++++++++ ase/lsp/{memory.h => mem.h} | 2 +- ase/lsp/memory.c | 661 ----------------------------------- ase/lsp/name.c | 29 +- ase/lsp/prim.c | 4 +- ase/test/lsp/lisp.c | 45 +-- 10 files changed, 750 insertions(+), 738 deletions(-) create mode 100644 ase/lsp/mem.c rename ase/lsp/{memory.h => mem.h} (98%) delete mode 100644 ase/lsp/memory.c diff --git a/ase/lsp/array.c b/ase/lsp/array.c index eea70722..a75cdc92 100644 --- a/ase/lsp/array.c +++ b/ase/lsp/array.c @@ -1,17 +1,17 @@ /* - * $Id: array.c,v 1.6 2005-05-28 13:34:26 bacon Exp $ + * $Id: array.c,v 1.7 2005-09-18 11:34:35 bacon Exp $ */ #include #include #include -xp_lisp_array_t* xp_lisp_array_new (xp_size_t capacity) +xp_lsp_array_t* xp_lsp_array_new (xp_size_t capacity) { - xp_lisp_array_t* array; + xp_lsp_array_t* array; xp_assert (capacity > 0); - array = (xp_lisp_array_t*)malloc (sizeof(xp_lisp_array_t)); + array = (xp_lsp_array_t*)malloc (sizeof(xp_lsp_array_t)); if (array == XP_NULL) return XP_NULL; array->buffer = (void**)malloc (capacity + 1); @@ -26,7 +26,7 @@ xp_lisp_array_t* xp_lisp_array_new (xp_size_t capacity) return array; } -void xp_lisp_array_free (xp_lisp_array_t* array) +void xp_lsp_array_free (xp_lsp_array_t* array) { while (array->size > 0) free (array->buffer[--array->size]); @@ -36,7 +36,7 @@ void xp_lisp_array_free (xp_lisp_array_t* array) free (array); } -int xp_lisp_array_add_item (xp_lisp_array_t* array, void* item) +int xp_lsp_array_add_item (xp_lsp_array_t* array, void* item) { if (array->size >= array->capacity) { void* new_buffer = (void**)realloc ( @@ -51,7 +51,7 @@ int xp_lisp_array_add_item (xp_lisp_array_t* array, void* item) return 0; } -int xp_lisp_array_insert (xp_lisp_array_t* array, xp_size_t index, void* value) +int xp_lsp_array_insert (xp_lsp_array_t* array, xp_size_t index, void* value) { xp_size_t i; @@ -72,13 +72,13 @@ int xp_lisp_array_insert (xp_lisp_array_t* array, xp_size_t index, void* value) return 0; } -void xp_lisp_array_delete (xp_lisp_array_t* array, xp_size_t index) +void xp_lsp_array_delete (xp_lsp_array_t* array, xp_size_t index) { xp_assert (index < array->size); } -void xp_lisp_array_clear (xp_lisp_array_t* array) +void xp_lsp_array_clear (xp_lsp_array_t* array) { while (array->size > 0) free (array->buffer[--array->size]); @@ -86,7 +86,7 @@ void xp_lisp_array_clear (xp_lisp_array_t* array) array->buffer[0] = XP_NULL; } -void** xp_lisp_array_yield (xp_lisp_array_t* array, xp_size_t capacity) +void** xp_lsp_array_yield (xp_lsp_array_t* array, xp_size_t capacity) { void** old_buffer, ** new_buffer; diff --git a/ase/lsp/env.c b/ase/lsp/env.c index 5d3de790..054d4d1c 100644 --- a/ase/lsp/env.c +++ b/ase/lsp/env.c @@ -1,16 +1,16 @@ /* - * $Id: env.c,v 1.6 2005-05-28 13:34:26 bacon Exp $ + * $Id: env.c,v 1.7 2005-09-18 11:34:35 bacon Exp $ */ #include #include #include -xp_lisp_assoc_t* xp_lisp_assoc_new (xp_lisp_obj_t* name, xp_lisp_obj_t* value) +xp_lsp_assoc_t* xp_lsp_assoc_new (xp_lsp_obj_t* name, xp_lsp_obj_t* value) { - xp_lisp_assoc_t* assoc; + xp_lsp_assoc_t* assoc; - assoc = (xp_lisp_assoc_t*) xp_malloc (sizeof(xp_lisp_assoc_t)); + assoc = (xp_lsp_assoc_t*) xp_malloc (sizeof(xp_lsp_assoc_t)); if (assoc == XP_NULL) return XP_NULL; assoc->name = name; @@ -20,16 +20,16 @@ xp_lisp_assoc_t* xp_lisp_assoc_new (xp_lisp_obj_t* name, xp_lisp_obj_t* value) return assoc; } -void xp_lisp_assoc_free (xp_lisp_assoc_t* assoc) +void xp_lsp_assoc_free (xp_lsp_assoc_t* assoc) { xp_free (assoc); } -xp_lisp_frame_t* xp_lisp_frame_new (void) +xp_lsp_frame_t* xp_lsp_frame_new (void) { - xp_lisp_frame_t* frame; + xp_lsp_frame_t* frame; - frame = (xp_lisp_frame_t*) xp_malloc (sizeof(xp_lisp_frame_t)); + frame = (xp_lsp_frame_t*) xp_malloc (sizeof(xp_lsp_frame_t)); if (frame == XP_NULL) return XP_NULL; frame->assoc = XP_NULL; @@ -38,26 +38,26 @@ xp_lisp_frame_t* xp_lisp_frame_new (void) return frame; } -void xp_lisp_frame_free (xp_lisp_frame_t* frame) +void xp_lsp_frame_free (xp_lsp_frame_t* frame) { - xp_lisp_assoc_t* assoc, * link; + xp_lsp_assoc_t* assoc, * link; // destroy the associations assoc = frame->assoc; while (assoc != XP_NULL) { link = assoc->link; - xp_lisp_assoc_free (assoc); + xp_lsp_assoc_free (assoc); assoc = link; } xp_free (frame); } -xp_lisp_assoc_t* xp_lisp_frame_lookup (xp_lisp_frame_t* frame, xp_lisp_obj_t* name) +xp_lsp_assoc_t* xp_lsp_frame_lookup (xp_lsp_frame_t* frame, xp_lsp_obj_t* name) { - xp_lisp_assoc_t* assoc; + xp_lsp_assoc_t* assoc; - xp_assert (XP_LISP_TYPE(name) == XP_LISP_OBJ_SYMBOL); + xp_assert (XP_LSP_TYPE(name) == XP_LSP_OBJ_SYMBOL); assoc = frame->assoc; while (assoc != XP_NULL) { @@ -67,14 +67,14 @@ xp_lisp_assoc_t* xp_lisp_frame_lookup (xp_lisp_frame_t* frame, xp_lisp_obj_t* na return XP_NULL; } -xp_lisp_assoc_t* xp_lisp_frame_insert ( - xp_lisp_frame_t* frame, xp_lisp_obj_t* name, xp_lisp_obj_t* value) +xp_lsp_assoc_t* xp_lsp_frame_insert ( + xp_lsp_frame_t* frame, xp_lsp_obj_t* name, xp_lsp_obj_t* value) { - xp_lisp_assoc_t* assoc; + xp_lsp_assoc_t* assoc; - xp_assert (XP_LISP_TYPE(name) == XP_LISP_OBJ_SYMBOL); + xp_assert (XP_LSP_TYPE(name) == XP_LSP_OBJ_SYMBOL); - assoc = xp_lisp_assoc_new (name, value); + assoc = xp_lsp_assoc_new (name, value); if (assoc == XP_NULL) return XP_NULL; assoc->link = frame->assoc; frame->assoc = assoc; diff --git a/ase/lsp/env.h b/ase/lsp/env.h index 1b14111c..ce30191b 100644 --- a/ase/lsp/env.h +++ b/ase/lsp/env.h @@ -1,5 +1,5 @@ /* - * $Id: env.h,v 1.4 2005-09-18 08:10:50 bacon Exp $ + * $Id: env.h,v 1.5 2005-09-18 11:34:35 bacon Exp $ */ #ifndef _XP_LSP_ENV_H_ @@ -27,11 +27,11 @@ typedef struct xp_lsp_frame_t xp_lsp_frame_t; extern "C" { #endif -xp_lsp_assoc_t* xp_lsp_assoc_new (xp_lsp_obj_t* name, xp_lsp_obj_t* value); -void xp_lsp_assoc_free (xp_lsp_assoc_t* assoc); +xp_lsp_assoc_t* xp_lsp_assoc_new (xp_lsp_obj_t* name, xp_lsp_obj_t* value); +void xp_lsp_assoc_free (xp_lsp_assoc_t* assoc); -xp_lsp_frame_t* xp_lsp_frame_new (void); -void xp_lsp_frame_free (xp_lsp_frame_t* frame); +xp_lsp_frame_t* xp_lsp_frame_new (void); +void xp_lsp_frame_free (xp_lsp_frame_t* frame); xp_lsp_assoc_t* xp_lsp_frame_lookup (xp_lsp_frame_t* frame, xp_lsp_obj_t* name); xp_lsp_assoc_t* xp_lsp_frame_insert (xp_lsp_frame_t* frame, xp_lsp_obj_t* name, xp_lsp_obj_t* value); diff --git a/ase/lsp/lsp.h b/ase/lsp/lsp.h index ca13a551..ab3151aa 100644 --- a/ase/lsp/lsp.h +++ b/ase/lsp/lsp.h @@ -1,5 +1,5 @@ /* - * $Id: lsp.h,v 1.6 2005-09-18 10:23:19 bacon Exp $ + * $Id: lsp.h,v 1.7 2005-09-18 11:34:35 bacon Exp $ */ #ifndef _XP_LSP_LSP_H_ @@ -8,14 +8,14 @@ /* * HEADER: Lisp * A lisp-like embeddable language processor is provied for application - * development that requires scripting. + * development that requires simple scripting. * */ #include #include #include -#include +#include #define XP_LSP_ERR(lsp) ((lsp)->errnum) enum @@ -76,7 +76,7 @@ struct xp_lsp_t /* * TYPEDEF: xp_lsp_t - * Defines the lisp object + * Defines a lisp processor */ typedef struct xp_lsp_t xp_lsp_t; @@ -86,14 +86,19 @@ extern "C" { /* * FUNCTION: xp_lsp_open - * Instantiate the lisp object + * Instantiates a lisp processor + * + * PARAMETERS: + * lsp - pointer to lisp processor space or XP_NULL + * mem_ubound - memory upper bound + * mem_ubound_inc - memory increment */ xp_lsp_t* xp_lsp_open (xp_lsp_t* lisp, xp_size_t mem_ubound, xp_size_t mem_ubound_inc); /* * FUNCTION: xp_lsp_close - * Destroys the lisp object + * Destroys a lisp processor * * PARAMETERS: * lsp - the pointer to the lisp object diff --git a/ase/lsp/mem.c b/ase/lsp/mem.c new file mode 100644 index 00000000..fa62d67b --- /dev/null +++ b/ase/lsp/mem.c @@ -0,0 +1,662 @@ +/* + * $Id: mem.c,v 1.1 2005-09-18 11:34:35 bacon Exp $ + */ + +#include +#include + +#include +#include +#include + +xp_lsp_mem_t* xp_lsp_mem_new (xp_size_t ubound, xp_size_t ubound_inc) +{ + xp_lsp_mem_t* mem; + xp_size_t i; + + // allocate memory + mem = (xp_lsp_mem_t*)xp_malloc (sizeof(xp_lsp_mem_t)); + if (mem == XP_NULL) return XP_NULL; + + // create a new root environment frame + mem->frame = xp_lsp_frame_new (); + if (mem->frame == XP_NULL) { + xp_free (mem); + return XP_NULL; + } + mem->root_frame = mem->frame; + mem->brooding_frame = XP_NULL; + + // create an array to hold temporary objects + mem->temp_array = xp_lsp_array_new (512); + if (mem->temp_array == XP_NULL) { + xp_lsp_frame_free (mem->frame); + xp_free (mem); + return XP_NULL; + } + + // initialize object allocation list + mem->ubound = ubound; + mem->ubound_inc = ubound_inc; + mem->count = 0; + for (i = 0; i < XP_LSP_TYPE_COUNT; i++) { + mem->used[i] = XP_NULL; + mem->free[i] = XP_NULL; + } + mem->locked = XP_NULL; + + // when "ubound" is too small, the garbage collection can + // be performed while making the common objects. + mem->nil = XP_NULL; + mem->t = XP_NULL; + mem->quote = XP_NULL; + mem->lambda = XP_NULL; + mem->macro = XP_NULL; + + // initialize common object pointers + mem->nil = xp_lsp_make_nil (mem); + mem->t = xp_lsp_make_true (mem); + mem->quote = xp_lsp_make_symbol (mem, XP_TEXT("quote"), 5); + mem->lambda = xp_lsp_make_symbol (mem, XP_TEXT("lambda"), 6); + mem->macro = xp_lsp_make_symbol (mem, XP_TEXT("macro"), 5); + + if (mem->nil == XP_NULL || + mem->t == XP_NULL || + mem->quote == XP_NULL || + mem->lambda == XP_NULL || + mem->macro == XP_NULL) { + xp_lsp_dispose_all (mem); + xp_lsp_array_free (mem->temp_array); + xp_lsp_frame_free (mem->frame); + xp_free (mem); + return XP_NULL; + } + + return mem; +} + +void xp_lsp_mem_free (xp_lsp_mem_t* mem) +{ + xp_assert (mem != XP_NULL); + + // dispose of the allocated objects + xp_lsp_dispose_all (mem); + + // dispose of the temporary object arrays + xp_lsp_array_free (mem->temp_array); + + // dispose of environment frames + xp_lsp_frame_free (mem->frame); + + // free the memory + xp_free (mem); +} + +static int xp_lsp_add_prim ( + xp_lsp_mem_t* mem, const xp_char_t* name, xp_size_t len, xp_lsp_pimpl_t prim) +{ + xp_lsp_obj_t* n, * p; + + n = xp_lsp_make_symbol (mem, name, len); + if (n == XP_NULL) return -1; + + xp_lsp_lock (n); + + p = xp_lsp_make_prim (mem, prim); + if (p == XP_NULL) return -1; + + xp_lsp_unlock (n); + + if (xp_lsp_set (mem, n, p) == XP_NULL) return -1; + + return 0; +} + + +int xp_lsp_add_prims (xp_lsp_mem_t* mem) +{ + +#define ADD_PRIM(mem,name,len,prim) \ + if (xp_lsp_add_prim(mem,name,len,prim) == -1) return -1; + + ADD_PRIM (mem, XP_TEXT("abort"), 5, xp_lsp_prim_abort); + ADD_PRIM (mem, XP_TEXT("eval"), 4, xp_lsp_prim_eval); + ADD_PRIM (mem, XP_TEXT("prog1"), 5, xp_lsp_prim_prog1); + ADD_PRIM (mem, XP_TEXT("progn"), 5, xp_lsp_prim_progn); + ADD_PRIM (mem, XP_TEXT("gc"), 2, xp_lsp_prim_gc); + + ADD_PRIM (mem, XP_TEXT("cond"), 4, xp_lsp_prim_cond); + ADD_PRIM (mem, XP_TEXT("if"), 2, xp_lsp_prim_if); + ADD_PRIM (mem, XP_TEXT("while"), 5, xp_lsp_prim_while); + + ADD_PRIM (mem, XP_TEXT("car"), 3, xp_lsp_prim_car); + ADD_PRIM (mem, XP_TEXT("cdr"), 3, xp_lsp_prim_cdr); + ADD_PRIM (mem, XP_TEXT("cons"), 4, xp_lsp_prim_cons); + ADD_PRIM (mem, XP_TEXT("set"), 3, xp_lsp_prim_set); + ADD_PRIM (mem, XP_TEXT("setq"), 4, xp_lsp_prim_setq); + ADD_PRIM (mem, XP_TEXT("quote"), 5, xp_lsp_prim_quote); + ADD_PRIM (mem, XP_TEXT("defun"), 5, xp_lsp_prim_defun); + ADD_PRIM (mem, XP_TEXT("demac"), 5, xp_lsp_prim_demac); + ADD_PRIM (mem, XP_TEXT("let"), 3, xp_lsp_prim_let); + ADD_PRIM (mem, XP_TEXT("let*"), 4, xp_lsp_prim_letx); + + ADD_PRIM (mem, XP_TEXT("+"), 1, xp_lsp_prim_plus); + ADD_PRIM (mem, XP_TEXT(">"), 1, xp_lsp_prim_gt); + ADD_PRIM (mem, XP_TEXT("<"), 1, xp_lsp_prim_lt); + + return 0; +} + + +xp_lsp_obj_t* xp_lsp_allocate (xp_lsp_mem_t* mem, int type, xp_size_t size) +{ + xp_lsp_obj_t* obj; + + if (mem->count >= mem->ubound) xp_lsp_garbage_collect (mem); + if (mem->count >= mem->ubound) { + mem->ubound += mem->ubound_inc; + if (mem->count >= mem->ubound) return XP_NULL; + } + + obj = (xp_lsp_obj_t*)xp_malloc (size); + if (obj == XP_NULL) { + xp_lsp_garbage_collect (mem); + + obj = (xp_lsp_obj_t*)xp_malloc (size); + if (obj == XP_NULL) return XP_NULL; + } + + XP_LSP_TYPE(obj) = type; + XP_LSP_SIZE(obj) = size; + XP_LSP_MARK(obj) = 0; + XP_LSP_LOCK(obj) = 0; + + // insert the object at the head of the used list + XP_LSP_LINK(obj) = mem->used[type]; + mem->used[type] = obj; + mem->count++; + xp_dprint1 (XP_TEXT("mem->count: %u\n"), mem->count); + + return obj; +} + +void xp_lsp_dispose (xp_lsp_mem_t* mem, xp_lsp_obj_t* prev, xp_lsp_obj_t* obj) +{ + xp_assert (mem != XP_NULL); + xp_assert (obj != XP_NULL); + xp_assert (mem->count > 0); + + // TODO: push the object to the free list for more + // efficient memory management + + if (prev == XP_NULL) + mem->used[XP_LSP_TYPE(obj)] = XP_LSP_LINK(obj); + else XP_LSP_LINK(prev) = XP_LSP_LINK(obj); + + mem->count--; + xp_dprint1 (XP_TEXT("mem->count: %u\n"), mem->count); + + xp_free (obj); +} + +void xp_lsp_dispose_all (xp_lsp_mem_t* mem) +{ + xp_lsp_obj_t* obj, * next; + xp_size_t i; + + for (i = 0; i < XP_LSP_TYPE_COUNT; i++) { + obj = mem->used[i]; + + while (obj != XP_NULL) { + next = XP_LSP_LINK(obj); + xp_lsp_dispose (mem, XP_NULL, obj); + obj = next; + } + } +} + +static void xp_lsp_mark_obj (xp_lsp_obj_t* obj) +{ + xp_assert (obj != XP_NULL); + + // TODO:.... + // can it be recursive? + if (XP_LSP_MARK(obj) != 0) return; + + XP_LSP_MARK(obj) = 1; + + if (XP_LSP_TYPE(obj) == XP_LSP_OBJ_CONS) { + xp_lsp_mark_obj (XP_LSP_CAR(obj)); + xp_lsp_mark_obj (XP_LSP_CDR(obj)); + } + else if (XP_LSP_TYPE(obj) == XP_LSP_OBJ_FUNC) { + xp_lsp_mark_obj (XP_LSP_FFORMAL(obj)); + xp_lsp_mark_obj (XP_LSP_FBODY(obj)); + } + else if (XP_LSP_TYPE(obj) == XP_LSP_OBJ_MACRO) { + xp_lsp_mark_obj (XP_LSP_MFORMAL(obj)); + xp_lsp_mark_obj (XP_LSP_MBODY(obj)); + } +} + +/* + * xp_lsp_lock and xp_lsp_unlock_all are just called by xp_lsp_read. + */ +void xp_lsp_lock (xp_lsp_obj_t* obj) +{ + xp_assert (obj != XP_NULL); + XP_LSP_LOCK(obj) = 1; + //XP_LSP_MARK(obj) = 1; +} + +void xp_lsp_unlock (xp_lsp_obj_t* obj) +{ + xp_assert (obj != XP_NULL); + XP_LSP_LOCK(obj) = 0; +} + +void xp_lsp_unlock_all (xp_lsp_obj_t* obj) +{ + xp_assert (obj != XP_NULL); + + XP_LSP_LOCK(obj) = 0; + + if (XP_LSP_TYPE(obj) == XP_LSP_OBJ_CONS) { + xp_lsp_unlock_all (XP_LSP_CAR(obj)); + xp_lsp_unlock_all (XP_LSP_CDR(obj)); + } + else if (XP_LSP_TYPE(obj) == XP_LSP_OBJ_FUNC) { + xp_lsp_unlock_all (XP_LSP_FFORMAL(obj)); + xp_lsp_unlock_all (XP_LSP_FBODY(obj)); + } + else if (XP_LSP_TYPE(obj) == XP_LSP_OBJ_MACRO) { + xp_lsp_unlock_all (XP_LSP_MFORMAL(obj)); + xp_lsp_unlock_all (XP_LSP_MBODY(obj)); + } +} + +static void xp_lsp_mark (xp_lsp_mem_t* mem) +{ + xp_lsp_frame_t* frame; + xp_lsp_assoc_t* assoc; + xp_lsp_array_t* array; + xp_size_t i; + + xp_dprint0 (XP_TEXT("marking environment frames\n")); + // mark objects in the environment frames + frame = mem->frame; + while (frame != XP_NULL) { + assoc = frame->assoc; + while (assoc != XP_NULL) { + xp_lsp_mark_obj (assoc->name); + xp_lsp_mark_obj (assoc->value); + assoc = assoc->link; + } + + frame = frame->link; + } + + xp_dprint0 (XP_TEXT("marking interim frames\n")); + + // mark objects in the interim frames + frame = mem->brooding_frame; + while (frame != XP_NULL) { + + assoc = frame->assoc; + while (assoc != XP_NULL) { + xp_lsp_mark_obj (assoc->name); + xp_lsp_mark_obj (assoc->value); + assoc = assoc->link; + } + + frame = frame->link; + } + + /* + xp_dprint0 (XP_TEXT("marking the locked object\n")); + if (mem->locked != XP_NULL) xp_lsp_mark_obj (mem->locked); + */ + + xp_dprint0 (XP_TEXT("marking termporary objects\n")); + array = mem->temp_array; + for (i = 0; i < array->size; i++) { + xp_lsp_mark_obj (array->buffer[i]); + } + + xp_dprint0 (XP_TEXT("marking builtin objects\n")); + // mark common objects + if (mem->t != XP_NULL) xp_lsp_mark_obj (mem->t); + if (mem->nil != XP_NULL) xp_lsp_mark_obj (mem->nil); + if (mem->quote != XP_NULL) xp_lsp_mark_obj (mem->quote); + if (mem->lambda != XP_NULL) xp_lsp_mark_obj (mem->lambda); + if (mem->macro != XP_NULL) xp_lsp_mark_obj (mem->macro); +} + +static void xp_lsp_sweep (xp_lsp_mem_t* mem) +{ + xp_lsp_obj_t* obj, * prev, * next; + xp_size_t i; + + // scan all the allocated objects and get rid of unused objects + for (i = 0; i < XP_LSP_TYPE_COUNT; i++) { + //for (i = XP_LSP_TYPE_COUNT; i > 0; /*i--*/) { + prev = XP_NULL; + obj = mem->used[i]; + //obj = mem->used[--i]; + + xp_dprint1 (XP_TEXT("sweeping objects of type: %u\n"), i); + + while (obj != XP_NULL) { + next = XP_LSP_LINK(obj); + + if (XP_LSP_LOCK(obj) == 0 && XP_LSP_MARK(obj) == 0) { + // dispose of unused objects + xp_lsp_dispose (mem, prev, obj); + } + else { + // unmark the object in use + XP_LSP_MARK(obj) = 0; + prev = obj; + } + + obj = next; + } + } +} + +void xp_lsp_garbage_collect (xp_lsp_mem_t* mem) +{ + xp_lsp_mark (mem); + xp_lsp_sweep (mem); +} + +xp_lsp_obj_t* xp_lsp_make_nil (xp_lsp_mem_t* mem) +{ + if (mem->nil != XP_NULL) return mem->nil; + mem->nil = xp_lsp_allocate (mem, XP_LSP_OBJ_NIL, sizeof(xp_lsp_obj_nil_t)); + return mem->nil; +} + +xp_lsp_obj_t* xp_lsp_make_true (xp_lsp_mem_t* mem) +{ + if (mem->t != XP_NULL) return mem->t; + mem->t = xp_lsp_allocate (mem, XP_LSP_OBJ_TRUE, sizeof(xp_lsp_obj_true_t)); + return mem->t; +} + +xp_lsp_obj_t* xp_lsp_make_int (xp_lsp_mem_t* mem, xp_lsp_int_t value) +{ + xp_lsp_obj_t* obj; + + obj = xp_lsp_allocate (mem, XP_LSP_OBJ_INT, sizeof(xp_lsp_obj_int_t)); + if (obj == XP_NULL) return XP_NULL; + + XP_LSP_IVALUE(obj) = value; + + return obj; +} + +xp_lsp_obj_t* xp_lsp_make_float (xp_lsp_mem_t* mem, xp_lsp_real_t value) +{ + xp_lsp_obj_t* obj; + + obj = xp_lsp_allocate (mem, XP_LSP_OBJ_FLOAT, sizeof(xp_lsp_obj_float_t)); + if (obj == XP_NULL) return XP_NULL; + + XP_LSP_FVALUE(obj) = value; + + return obj; +} + +xp_lsp_obj_t* xp_lsp_make_symbol ( + xp_lsp_mem_t* mem, const xp_char_t* str, xp_size_t len) +{ + xp_lsp_obj_t* obj; + + // look for a sysmbol with the given name + obj = mem->used[XP_LSP_OBJ_SYMBOL]; + while (obj != XP_NULL) { + // if there is a symbol with the same name, it is just used. + if (xp_lsp_comp_symbol2 (obj, str, len) == 0) return obj; + obj = XP_LSP_LINK(obj); + } + + // no such symbol found. create a new one + obj = xp_lsp_allocate (mem, XP_LSP_OBJ_SYMBOL, + sizeof(xp_lsp_obj_symbol_t) + (len + 1) * sizeof(xp_char_t)); + if (obj == XP_NULL) return XP_NULL; + + // fill in the symbol buffer + xp_lsp_copy_string2 (XP_LSP_SYMVALUE(obj), str, len); + + return obj; +} + +xp_lsp_obj_t* xp_lsp_make_string (xp_lsp_mem_t* mem, const xp_char_t* str, xp_size_t len) +{ + xp_lsp_obj_t* obj; + + // allocate memory for the string + obj = xp_lsp_allocate (mem, XP_LSP_OBJ_STRING, + sizeof(xp_lsp_obj_string_t) + (len + 1) * sizeof(xp_char_t)); + if (obj == XP_NULL) return XP_NULL; + + // fill in the string buffer + xp_lsp_copy_string2 (XP_LSP_STRVALUE(obj), str, len); + + return obj; +} + +xp_lsp_obj_t* xp_lsp_make_cons (xp_lsp_mem_t* mem, xp_lsp_obj_t* car, xp_lsp_obj_t* cdr) +{ + xp_lsp_obj_t* obj; + + obj = xp_lsp_allocate (mem, XP_LSP_OBJ_CONS, sizeof(xp_lsp_obj_cons_t)); + if (obj == XP_NULL) return XP_NULL; + + XP_LSP_CAR(obj) = car; + XP_LSP_CDR(obj) = cdr; + + return obj; +} + +xp_lsp_obj_t* xp_lsp_make_func (xp_lsp_mem_t* mem, xp_lsp_obj_t* formal, xp_lsp_obj_t* body) +{ + xp_lsp_obj_t* obj; + + obj = xp_lsp_allocate (mem, XP_LSP_OBJ_FUNC, sizeof(xp_lsp_obj_func_t)); + if (obj == XP_NULL) return XP_NULL; + + XP_LSP_FFORMAL(obj) = formal; + XP_LSP_FBODY(obj) = body; + + return obj; +} + +xp_lsp_obj_t* xp_lsp_make_macro (xp_lsp_mem_t* mem, xp_lsp_obj_t* formal, xp_lsp_obj_t* body) +{ + xp_lsp_obj_t* obj; + + obj = xp_lsp_allocate (mem, XP_LSP_OBJ_MACRO, sizeof(xp_lsp_obj_macro_t)); + if (obj == XP_NULL) return XP_NULL; + + XP_LSP_MFORMAL(obj) = formal; + XP_LSP_MBODY(obj) = body; + + return obj; +} + +xp_lsp_obj_t* xp_lsp_make_prim (xp_lsp_mem_t* mem, void* impl) +{ + xp_lsp_obj_t* obj; + + obj = xp_lsp_allocate (mem, XP_LSP_OBJ_PRIM, sizeof(xp_lsp_obj_prim_t)); + if (obj == XP_NULL) return XP_NULL; + + XP_LSP_PIMPL(obj) = impl; + + return obj; +} + +xp_lsp_assoc_t* xp_lsp_lookup (xp_lsp_mem_t* mem, xp_lsp_obj_t* name) +{ + xp_lsp_frame_t* frame; + xp_lsp_assoc_t* assoc; + + xp_assert (XP_LSP_TYPE(name) == XP_LSP_OBJ_SYMBOL); + + frame = mem->frame; + + while (frame != XP_NULL) { + assoc = xp_lsp_frame_lookup (frame, name); + if (assoc != XP_NULL) return assoc; + frame = frame->link; + } + + return XP_NULL; +} + +xp_lsp_assoc_t* xp_lsp_set (xp_lsp_mem_t* mem, xp_lsp_obj_t* name, xp_lsp_obj_t* value) +{ + xp_lsp_assoc_t* assoc; + + assoc = xp_lsp_lookup (mem, name); + if (assoc == XP_NULL) { + assoc = xp_lsp_frame_insert (mem->root_frame, name, value); + if (assoc == XP_NULL) return XP_NULL; + } + else assoc->value = value; + + return assoc; +} + +xp_size_t xp_lsp_cons_len (xp_lsp_mem_t* mem, xp_lsp_obj_t* obj) +{ + xp_size_t count; + + xp_assert (obj == mem->nil || XP_LSP_TYPE(obj) == XP_LSP_OBJ_CONS); + + count = 0; + //while (obj != mem->nil) { + while (XP_LSP_TYPE(obj) == XP_LSP_OBJ_CONS) { + count++; + obj = XP_LSP_CDR(obj); + } + + return count; +} + +int xp_lsp_probe_args (xp_lsp_mem_t* mem, xp_lsp_obj_t* obj, xp_size_t* len) +{ + xp_size_t count = 0; + + while (XP_LSP_TYPE(obj) == XP_LSP_OBJ_CONS) { + count++; + obj = XP_LSP_CDR(obj); + } + + if (obj != mem->nil) return -1; + + *len = count; + return 0; +} + +int xp_lsp_comp_symbol (xp_lsp_obj_t* obj, const xp_char_t* str) +{ + xp_char_t* p; + xp_size_t index, length; + + xp_assert (XP_LSP_TYPE(obj) == XP_LSP_OBJ_SYMBOL); + + index = 0; + length = XP_LSP_SYMLEN(obj); + + p = XP_LSP_SYMVALUE(obj); + while (index < length) { + if (*p > *str) return 1; + if (*p < *str) return -1; + index++; p++; str++; + } + + return (*str == XP_CHAR('\0'))? 0: -1; +} + +int xp_lsp_comp_symbol2 (xp_lsp_obj_t* obj, const xp_char_t* str, xp_size_t len) +{ + xp_char_t* p; + xp_size_t index, length; + + xp_assert (XP_LSP_TYPE(obj) == XP_LSP_OBJ_SYMBOL); + + index = 0; + length = XP_LSP_SYMLEN(obj); + p = XP_LSP_SYMVALUE(obj); + + while (index < length && index < len) { + if (*p > *str) return 1; + if (*p < *str) return -1; + index++; p++; str++; + } + + return (length < len)? -1: + (length > len)? 1: 0; +} + +int xp_lsp_comp_string (xp_lsp_obj_t* obj, const xp_char_t* str) +{ + xp_char_t* p; + xp_size_t index, length; + + xp_assert (XP_LSP_TYPE(obj) == XP_LSP_OBJ_STRING); + + index = 0; + length = XP_LSP_STRLEN(obj); + + p = XP_LSP_STRVALUE(obj); + while (index < length) { + if (*p > *str) return 1; + if (*p < *str) return -1; + index++; p++; str++; + } + + return (*str == XP_CHAR('\0'))? 0: -1; +} + +int xp_lsp_comp_string2 (xp_lsp_obj_t* obj, const xp_char_t* str, xp_size_t len) +{ + xp_char_t* p; + xp_size_t index, length; + + xp_assert (XP_LSP_TYPE(obj) == XP_LSP_OBJ_STRING); + + index = 0; + length = XP_LSP_STRLEN(obj); + p = XP_LSP_STRVALUE(obj); + + while (index < length && index < len) { + if (*p > *str) return 1; + if (*p < *str) return -1; + index++; p++; str++; + } + + return (length < len)? -1: + (length > len)? 1: 0; +} + +void xp_lsp_copy_string (xp_char_t* dst, const xp_char_t* str) +{ + // the buffer pointed by dst should be big enough to hold str + while (*str != XP_CHAR('\0')) *dst++ = *str++; + *dst = XP_CHAR('\0'); +} + +void xp_lsp_copy_string2 (xp_char_t* dst, const xp_char_t* str, xp_size_t len) +{ + // the buffer pointed by dst should be big enough to hold str + while (len > 0) { + *dst++ = *str++; + len--; + } + *dst = XP_CHAR('\0'); +} + diff --git a/ase/lsp/memory.h b/ase/lsp/mem.h similarity index 98% rename from ase/lsp/memory.h rename to ase/lsp/mem.h index 44b8da22..a93fa84d 100644 --- a/ase/lsp/memory.h +++ b/ase/lsp/mem.h @@ -1,5 +1,5 @@ /* - * $Id: memory.h,v 1.6 2005-09-18 08:10:50 bacon Exp $ + * $Id: mem.h,v 1.1 2005-09-18 11:34:35 bacon Exp $ */ #ifndef _XP_LSP_MEM_H_ diff --git a/ase/lsp/memory.c b/ase/lsp/memory.c deleted file mode 100644 index ab98d35b..00000000 --- a/ase/lsp/memory.c +++ /dev/null @@ -1,661 +0,0 @@ -/* - * $Id: memory.c,v 1.11 2005-05-28 13:34:26 bacon Exp $ - */ - -#include -#include -#include -#include -#include - -xp_lisp_mem_t* xp_lisp_mem_new (xp_size_t ubound, xp_size_t ubound_inc) -{ - xp_lisp_mem_t* mem; - xp_size_t i; - - // allocate memory - mem = (xp_lisp_mem_t*)xp_malloc (sizeof(xp_lisp_mem_t)); - if (mem == XP_NULL) return XP_NULL; - - // create a new root environment frame - mem->frame = xp_lisp_frame_new (); - if (mem->frame == XP_NULL) { - xp_free (mem); - return XP_NULL; - } - mem->root_frame = mem->frame; - mem->brooding_frame = XP_NULL; - - // create an array to hold temporary objects - mem->temp_array = xp_lisp_array_new (512); - if (mem->temp_array == XP_NULL) { - xp_lisp_frame_free (mem->frame); - xp_free (mem); - return XP_NULL; - } - - // initialize object allocation list - mem->ubound = ubound; - mem->ubound_inc = ubound_inc; - mem->count = 0; - for (i = 0; i < XP_LISP_TYPE_COUNT; i++) { - mem->used[i] = XP_NULL; - mem->free[i] = XP_NULL; - } - mem->locked = XP_NULL; - - // when "ubound" is too small, the garbage collection can - // be performed while making the common objects. - mem->nil = XP_NULL; - mem->t = XP_NULL; - mem->quote = XP_NULL; - mem->lambda = XP_NULL; - mem->macro = XP_NULL; - - // initialize common object pointers - mem->nil = xp_lisp_make_nil (mem); - mem->t = xp_lisp_make_true (mem); - mem->quote = xp_lisp_make_symbol (mem, XP_TEXT("quote"), 5); - mem->lambda = xp_lisp_make_symbol (mem, XP_TEXT("lambda"), 6); - mem->macro = xp_lisp_make_symbol (mem, XP_TEXT("macro"), 5); - - if (mem->nil == XP_NULL || - mem->t == XP_NULL || - mem->quote == XP_NULL || - mem->lambda == XP_NULL || - mem->macro == XP_NULL) { - xp_lisp_dispose_all (mem); - xp_lisp_array_free (mem->temp_array); - xp_lisp_frame_free (mem->frame); - xp_free (mem); - return XP_NULL; - } - - return mem; -} - -void xp_lisp_mem_free (xp_lisp_mem_t* mem) -{ - xp_assert (mem != XP_NULL); - - // dispose of the allocated objects - xp_lisp_dispose_all (mem); - - // dispose of the temporary object arrays - xp_lisp_array_free (mem->temp_array); - - // dispose of environment frames - xp_lisp_frame_free (mem->frame); - - // free the memory - xp_free (mem); -} - -static int xp_lisp_add_prim ( - xp_lisp_mem_t* mem, const xp_char_t* name, xp_size_t len, xp_lisp_pimpl_t prim) -{ - xp_lisp_obj_t* n, * p; - - n = xp_lisp_make_symbol (mem, name, len); - if (n == XP_NULL) return -1; - - xp_lisp_lock (n); - - p = xp_lisp_make_prim (mem, prim); - if (p == XP_NULL) return -1; - - xp_lisp_unlock (n); - - if (xp_lisp_set (mem, n, p) == XP_NULL) return -1; - - return 0; -} - - -int xp_lisp_add_prims (xp_lisp_mem_t* mem) -{ - -#define ADD_PRIM(mem,name,len,prim) \ - if (xp_lisp_add_prim(mem,name,len,prim) == -1) return -1; - - ADD_PRIM (mem, XP_TEXT("abort"), 5, xp_lisp_prim_abort); - ADD_PRIM (mem, XP_TEXT("eval"), 4, xp_lisp_prim_eval); - ADD_PRIM (mem, XP_TEXT("prog1"), 5, xp_lisp_prim_prog1); - ADD_PRIM (mem, XP_TEXT("progn"), 5, xp_lisp_prim_progn); - ADD_PRIM (mem, XP_TEXT("gc"), 2, xp_lisp_prim_gc); - - ADD_PRIM (mem, XP_TEXT("cond"), 4, xp_lisp_prim_cond); - ADD_PRIM (mem, XP_TEXT("if"), 2, xp_lisp_prim_if); - ADD_PRIM (mem, XP_TEXT("while"), 5, xp_lisp_prim_while); - - ADD_PRIM (mem, XP_TEXT("car"), 3, xp_lisp_prim_car); - ADD_PRIM (mem, XP_TEXT("cdr"), 3, xp_lisp_prim_cdr); - ADD_PRIM (mem, XP_TEXT("cons"), 4, xp_lisp_prim_cons); - ADD_PRIM (mem, XP_TEXT("set"), 3, xp_lisp_prim_set); - ADD_PRIM (mem, XP_TEXT("setq"), 4, xp_lisp_prim_setq); - ADD_PRIM (mem, XP_TEXT("quote"), 5, xp_lisp_prim_quote); - ADD_PRIM (mem, XP_TEXT("defun"), 5, xp_lisp_prim_defun); - ADD_PRIM (mem, XP_TEXT("demac"), 5, xp_lisp_prim_demac); - ADD_PRIM (mem, XP_TEXT("let"), 3, xp_lisp_prim_let); - ADD_PRIM (mem, XP_TEXT("let*"), 4, xp_lisp_prim_letx); - - ADD_PRIM (mem, XP_TEXT("+"), 1, xp_lisp_prim_plus); - ADD_PRIM (mem, XP_TEXT(">"), 1, xp_lisp_prim_gt); - ADD_PRIM (mem, XP_TEXT("<"), 1, xp_lisp_prim_lt); - - return 0; -} - - -xp_lisp_obj_t* xp_lisp_allocate (xp_lisp_mem_t* mem, int type, xp_size_t size) -{ - xp_lisp_obj_t* obj; - - if (mem->count >= mem->ubound) xp_lisp_garbage_collect (mem); - if (mem->count >= mem->ubound) { - mem->ubound += mem->ubound_inc; - if (mem->count >= mem->ubound) return XP_NULL; - } - - obj = (xp_lisp_obj_t*)xp_malloc (size); - if (obj == XP_NULL) { - xp_lisp_garbage_collect (mem); - - obj = (xp_lisp_obj_t*)xp_malloc (size); - if (obj == XP_NULL) return XP_NULL; - } - - XP_LISP_TYPE(obj) = type; - XP_LISP_SIZE(obj) = size; - XP_LISP_MARK(obj) = 0; - XP_LISP_LOCK(obj) = 0; - - // insert the object at the head of the used list - XP_LISP_LINK(obj) = mem->used[type]; - mem->used[type] = obj; - mem->count++; - xp_dprint1 (XP_TEXT("mem->count: %u\n"), mem->count); - - return obj; -} - -void xp_lisp_dispose (xp_lisp_mem_t* mem, xp_lisp_obj_t* prev, xp_lisp_obj_t* obj) -{ - xp_assert (mem != XP_NULL); - xp_assert (obj != XP_NULL); - xp_assert (mem->count > 0); - - // TODO: push the object to the free list for more - // efficient memory management - - if (prev == XP_NULL) - mem->used[XP_LISP_TYPE(obj)] = XP_LISP_LINK(obj); - else XP_LISP_LINK(prev) = XP_LISP_LINK(obj); - - mem->count--; - xp_dprint1 (XP_TEXT("mem->count: %u\n"), mem->count); - - xp_free (obj); -} - -void xp_lisp_dispose_all (xp_lisp_mem_t* mem) -{ - xp_lisp_obj_t* obj, * next; - xp_size_t i; - - for (i = 0; i < XP_LISP_TYPE_COUNT; i++) { - obj = mem->used[i]; - - while (obj != XP_NULL) { - next = XP_LISP_LINK(obj); - xp_lisp_dispose (mem, XP_NULL, obj); - obj = next; - } - } -} - -static void xp_lisp_mark_obj (xp_lisp_obj_t* obj) -{ - xp_assert (obj != XP_NULL); - - // TODO:.... - // can it be recursive? - if (XP_LISP_MARK(obj) != 0) return; - - XP_LISP_MARK(obj) = 1; - - if (XP_LISP_TYPE(obj) == XP_LISP_OBJ_CONS) { - xp_lisp_mark_obj (XP_LISP_CAR(obj)); - xp_lisp_mark_obj (XP_LISP_CDR(obj)); - } - else if (XP_LISP_TYPE(obj) == XP_LISP_OBJ_FUNC) { - xp_lisp_mark_obj (XP_LISP_FFORMAL(obj)); - xp_lisp_mark_obj (XP_LISP_FBODY(obj)); - } - else if (XP_LISP_TYPE(obj) == XP_LISP_OBJ_MACRO) { - xp_lisp_mark_obj (XP_LISP_MFORMAL(obj)); - xp_lisp_mark_obj (XP_LISP_MBODY(obj)); - } -} - -/* - * xp_lisp_lock and xp_lisp_unlock_all are just called by xp_lisp_read. - */ -void xp_lisp_lock (xp_lisp_obj_t* obj) -{ - xp_assert (obj != XP_NULL); - XP_LISP_LOCK(obj) = 1; - //XP_LISP_MARK(obj) = 1; -} - -void xp_lisp_unlock (xp_lisp_obj_t* obj) -{ - xp_assert (obj != XP_NULL); - XP_LISP_LOCK(obj) = 0; -} - -void xp_lisp_unlock_all (xp_lisp_obj_t* obj) -{ - xp_assert (obj != XP_NULL); - - XP_LISP_LOCK(obj) = 0; - - if (XP_LISP_TYPE(obj) == XP_LISP_OBJ_CONS) { - xp_lisp_unlock_all (XP_LISP_CAR(obj)); - xp_lisp_unlock_all (XP_LISP_CDR(obj)); - } - else if (XP_LISP_TYPE(obj) == XP_LISP_OBJ_FUNC) { - xp_lisp_unlock_all (XP_LISP_FFORMAL(obj)); - xp_lisp_unlock_all (XP_LISP_FBODY(obj)); - } - else if (XP_LISP_TYPE(obj) == XP_LISP_OBJ_MACRO) { - xp_lisp_unlock_all (XP_LISP_MFORMAL(obj)); - xp_lisp_unlock_all (XP_LISP_MBODY(obj)); - } -} - -static void xp_lisp_mark (xp_lisp_mem_t* mem) -{ - xp_lisp_frame_t* frame; - xp_lisp_assoc_t* assoc; - xp_lisp_array_t* array; - xp_size_t i; - - xp_dprint0 (XP_TEXT("marking environment frames\n")); - // mark objects in the environment frames - frame = mem->frame; - while (frame != XP_NULL) { - assoc = frame->assoc; - while (assoc != XP_NULL) { - xp_lisp_mark_obj (assoc->name); - xp_lisp_mark_obj (assoc->value); - assoc = assoc->link; - } - - frame = frame->link; - } - - xp_dprint0 (XP_TEXT("marking interim frames\n")); - - // mark objects in the interim frames - frame = mem->brooding_frame; - while (frame != XP_NULL) { - - assoc = frame->assoc; - while (assoc != XP_NULL) { - xp_lisp_mark_obj (assoc->name); - xp_lisp_mark_obj (assoc->value); - assoc = assoc->link; - } - - frame = frame->link; - } - - /* - xp_dprint0 (XP_TEXT("marking the locked object\n")); - if (mem->locked != XP_NULL) xp_lisp_mark_obj (mem->locked); - */ - - xp_dprint0 (XP_TEXT("marking termporary objects\n")); - array = mem->temp_array; - for (i = 0; i < array->size; i++) { - xp_lisp_mark_obj (array->buffer[i]); - } - - xp_dprint0 (XP_TEXT("marking builtin objects\n")); - // mark common objects - if (mem->t != XP_NULL) xp_lisp_mark_obj (mem->t); - if (mem->nil != XP_NULL) xp_lisp_mark_obj (mem->nil); - if (mem->quote != XP_NULL) xp_lisp_mark_obj (mem->quote); - if (mem->lambda != XP_NULL) xp_lisp_mark_obj (mem->lambda); - if (mem->macro != XP_NULL) xp_lisp_mark_obj (mem->macro); -} - -static void xp_lisp_sweep (xp_lisp_mem_t* mem) -{ - xp_lisp_obj_t* obj, * prev, * next; - xp_size_t i; - - // scan all the allocated objects and get rid of unused objects - for (i = 0; i < XP_LISP_TYPE_COUNT; i++) { - //for (i = XP_LISP_TYPE_COUNT; i > 0; /*i--*/) { - prev = XP_NULL; - obj = mem->used[i]; - //obj = mem->used[--i]; - - xp_dprint1 (XP_TEXT("sweeping objects of type: %u\n"), i); - - while (obj != XP_NULL) { - next = XP_LISP_LINK(obj); - - if (XP_LISP_LOCK(obj) == 0 && XP_LISP_MARK(obj) == 0) { - // dispose of unused objects - xp_lisp_dispose (mem, prev, obj); - } - else { - // unmark the object in use - XP_LISP_MARK(obj) = 0; - prev = obj; - } - - obj = next; - } - } -} - -void xp_lisp_garbage_collect (xp_lisp_mem_t* mem) -{ - xp_lisp_mark (mem); - xp_lisp_sweep (mem); -} - -xp_lisp_obj_t* xp_lisp_make_nil (xp_lisp_mem_t* mem) -{ - if (mem->nil != XP_NULL) return mem->nil; - mem->nil = xp_lisp_allocate (mem, XP_LISP_OBJ_NIL, sizeof(xp_lisp_obj_nil_t)); - return mem->nil; -} - -xp_lisp_obj_t* xp_lisp_make_true (xp_lisp_mem_t* mem) -{ - if (mem->t != XP_NULL) return mem->t; - mem->t = xp_lisp_allocate (mem, XP_LISP_OBJ_TRUE, sizeof(xp_lisp_obj_true_t)); - return mem->t; -} - -xp_lisp_obj_t* xp_lisp_make_int (xp_lisp_mem_t* mem, xp_lisp_int_t value) -{ - xp_lisp_obj_t* obj; - - obj = xp_lisp_allocate (mem, XP_LISP_OBJ_INT, sizeof(xp_lisp_obj_int_t)); - if (obj == XP_NULL) return XP_NULL; - - XP_LISP_IVALUE(obj) = value; - - return obj; -} - -xp_lisp_obj_t* xp_lisp_make_float (xp_lisp_mem_t* mem, xp_lisp_real_t value) -{ - xp_lisp_obj_t* obj; - - obj = xp_lisp_allocate (mem, XP_LISP_OBJ_FLOAT, sizeof(xp_lisp_obj_float_t)); - if (obj == XP_NULL) return XP_NULL; - - XP_LISP_FVALUE(obj) = value; - - return obj; -} - -xp_lisp_obj_t* xp_lisp_make_symbol ( - xp_lisp_mem_t* mem, const xp_char_t* str, xp_size_t len) -{ - xp_lisp_obj_t* obj; - - // look for a sysmbol with the given name - obj = mem->used[XP_LISP_OBJ_SYMBOL]; - while (obj != XP_NULL) { - // if there is a symbol with the same name, it is just used. - if (xp_lisp_comp_symbol2 (obj, str, len) == 0) return obj; - obj = XP_LISP_LINK(obj); - } - - // no such symbol found. create a new one - obj = xp_lisp_allocate (mem, XP_LISP_OBJ_SYMBOL, - sizeof(xp_lisp_obj_symbol_t) + (len + 1) * sizeof(xp_char_t)); - if (obj == XP_NULL) return XP_NULL; - - // fill in the symbol buffer - xp_lisp_copy_string2 (XP_LISP_SYMVALUE(obj), str, len); - - return obj; -} - -xp_lisp_obj_t* xp_lisp_make_string (xp_lisp_mem_t* mem, const xp_char_t* str, xp_size_t len) -{ - xp_lisp_obj_t* obj; - - // allocate memory for the string - obj = xp_lisp_allocate (mem, XP_LISP_OBJ_STRING, - sizeof(xp_lisp_obj_string_t) + (len + 1) * sizeof(xp_char_t)); - if (obj == XP_NULL) return XP_NULL; - - // fill in the string buffer - xp_lisp_copy_string2 (XP_LISP_STRVALUE(obj), str, len); - - return obj; -} - -xp_lisp_obj_t* xp_lisp_make_cons (xp_lisp_mem_t* mem, xp_lisp_obj_t* car, xp_lisp_obj_t* cdr) -{ - xp_lisp_obj_t* obj; - - obj = xp_lisp_allocate (mem, XP_LISP_OBJ_CONS, sizeof(xp_lisp_obj_cons_t)); - if (obj == XP_NULL) return XP_NULL; - - XP_LISP_CAR(obj) = car; - XP_LISP_CDR(obj) = cdr; - - return obj; -} - -xp_lisp_obj_t* xp_lisp_make_func (xp_lisp_mem_t* mem, xp_lisp_obj_t* formal, xp_lisp_obj_t* body) -{ - xp_lisp_obj_t* obj; - - obj = xp_lisp_allocate (mem, XP_LISP_OBJ_FUNC, sizeof(xp_lisp_obj_func_t)); - if (obj == XP_NULL) return XP_NULL; - - XP_LISP_FFORMAL(obj) = formal; - XP_LISP_FBODY(obj) = body; - - return obj; -} - -xp_lisp_obj_t* xp_lisp_make_macro (xp_lisp_mem_t* mem, xp_lisp_obj_t* formal, xp_lisp_obj_t* body) -{ - xp_lisp_obj_t* obj; - - obj = xp_lisp_allocate (mem, XP_LISP_OBJ_MACRO, sizeof(xp_lisp_obj_macro_t)); - if (obj == XP_NULL) return XP_NULL; - - XP_LISP_MFORMAL(obj) = formal; - XP_LISP_MBODY(obj) = body; - - return obj; -} - -xp_lisp_obj_t* xp_lisp_make_prim (xp_lisp_mem_t* mem, void* impl) -{ - xp_lisp_obj_t* obj; - - obj = xp_lisp_allocate (mem, XP_LISP_OBJ_PRIM, sizeof(xp_lisp_obj_prim_t)); - if (obj == XP_NULL) return XP_NULL; - - XP_LISP_PIMPL(obj) = impl; - - return obj; -} - -xp_lisp_assoc_t* xp_lisp_lookup (xp_lisp_mem_t* mem, xp_lisp_obj_t* name) -{ - xp_lisp_frame_t* frame; - xp_lisp_assoc_t* assoc; - - xp_assert (XP_LISP_TYPE(name) == XP_LISP_OBJ_SYMBOL); - - frame = mem->frame; - - while (frame != XP_NULL) { - assoc = xp_lisp_frame_lookup (frame, name); - if (assoc != XP_NULL) return assoc; - frame = frame->link; - } - - return XP_NULL; -} - -xp_lisp_assoc_t* xp_lisp_set (xp_lisp_mem_t* mem, xp_lisp_obj_t* name, xp_lisp_obj_t* value) -{ - xp_lisp_assoc_t* assoc; - - assoc = xp_lisp_lookup (mem, name); - if (assoc == XP_NULL) { - assoc = xp_lisp_frame_insert (mem->root_frame, name, value); - if (assoc == XP_NULL) return XP_NULL; - } - else assoc->value = value; - - return assoc; -} - -xp_size_t xp_lisp_cons_len (xp_lisp_mem_t* mem, xp_lisp_obj_t* obj) -{ - xp_size_t count; - - xp_assert (obj == mem->nil || XP_LISP_TYPE(obj) == XP_LISP_OBJ_CONS); - - count = 0; - //while (obj != mem->nil) { - while (XP_LISP_TYPE(obj) == XP_LISP_OBJ_CONS) { - count++; - obj = XP_LISP_CDR(obj); - } - - return count; -} - -int xp_lisp_probe_args (xp_lisp_mem_t* mem, xp_lisp_obj_t* obj, xp_size_t* len) -{ - xp_size_t count = 0; - - while (XP_LISP_TYPE(obj) == XP_LISP_OBJ_CONS) { - count++; - obj = XP_LISP_CDR(obj); - } - - if (obj != mem->nil) return -1; - - *len = count; - return 0; -} - -int xp_lisp_comp_symbol (xp_lisp_obj_t* obj, const xp_char_t* str) -{ - xp_char_t* p; - xp_size_t index, length; - - xp_assert (XP_LISP_TYPE(obj) == XP_LISP_OBJ_SYMBOL); - - index = 0; - length = XP_LISP_SYMLEN(obj); - - p = XP_LISP_SYMVALUE(obj); - while (index < length) { - if (*p > *str) return 1; - if (*p < *str) return -1; - index++; p++; str++; - } - - return (*str == XP_CHAR('\0'))? 0: -1; -} - -int xp_lisp_comp_symbol2 (xp_lisp_obj_t* obj, const xp_char_t* str, xp_size_t len) -{ - xp_char_t* p; - xp_size_t index, length; - - xp_assert (XP_LISP_TYPE(obj) == XP_LISP_OBJ_SYMBOL); - - index = 0; - length = XP_LISP_SYMLEN(obj); - p = XP_LISP_SYMVALUE(obj); - - while (index < length && index < len) { - if (*p > *str) return 1; - if (*p < *str) return -1; - index++; p++; str++; - } - - return (length < len)? -1: - (length > len)? 1: 0; -} - -int xp_lisp_comp_string (xp_lisp_obj_t* obj, const xp_char_t* str) -{ - xp_char_t* p; - xp_size_t index, length; - - xp_assert (XP_LISP_TYPE(obj) == XP_LISP_OBJ_STRING); - - index = 0; - length = XP_LISP_STRLEN(obj); - - p = XP_LISP_STRVALUE(obj); - while (index < length) { - if (*p > *str) return 1; - if (*p < *str) return -1; - index++; p++; str++; - } - - return (*str == XP_CHAR('\0'))? 0: -1; -} - -int xp_lisp_comp_string2 (xp_lisp_obj_t* obj, const xp_char_t* str, xp_size_t len) -{ - xp_char_t* p; - xp_size_t index, length; - - xp_assert (XP_LISP_TYPE(obj) == XP_LISP_OBJ_STRING); - - index = 0; - length = XP_LISP_STRLEN(obj); - p = XP_LISP_STRVALUE(obj); - - while (index < length && index < len) { - if (*p > *str) return 1; - if (*p < *str) return -1; - index++; p++; str++; - } - - return (length < len)? -1: - (length > len)? 1: 0; -} - -void xp_lisp_copy_string (xp_char_t* dst, const xp_char_t* str) -{ - // the buffer pointed by dst should be big enough to hold str - while (*str != XP_CHAR('\0')) *dst++ = *str++; - *dst = XP_CHAR('\0'); -} - -void xp_lisp_copy_string2 (xp_char_t* dst, const xp_char_t* str, xp_size_t len) -{ - // the buffer pointed by dst should be big enough to hold str - while (len > 0) { - *dst++ = *str++; - len--; - } - *dst = XP_CHAR('\0'); -} - diff --git a/ase/lsp/name.c b/ase/lsp/name.c index 40277ea9..e89df7ee 100644 --- a/ase/lsp/name.c +++ b/ase/lsp/name.c @@ -1,19 +1,20 @@ /* - * $Id: name.c,v 1.1 2005-09-18 08:10:50 bacon Exp $ + * $Id: name.c,v 1.2 2005-09-18 11:34:35 bacon Exp $ */ -#include -#include +#include +#include +#include -xp_stx_name_t* xp_stx_name_open ( - xp_stx_name_t* name, xp_word_t capacity) +xp_lsp_name_t* xp_lsp_name_open ( + xp_lsp_name_t* name, xp_word_t capacity) { if (capacity == 0) capacity = xp_countof(name->static_buffer) - 1; if (name == XP_NULL) { - name = (xp_stx_name_t*) - xp_malloc (xp_sizeof(xp_stx_name_t)); + name = (xp_lsp_name_t*) + xp_malloc (xp_sizeof(xp_lsp_name_t)); if (name == XP_NULL) return XP_NULL; name->__malloced = xp_true; } @@ -38,7 +39,7 @@ xp_stx_name_t* xp_stx_name_open ( return name; } -void xp_stx_name_close (xp_stx_name_t* name) +void xp_lsp_name_close (xp_lsp_name_t* name) { if (name->capacity >= xp_countof(name->static_buffer)) { xp_assert (name->buffer != name->static_buffer); @@ -47,7 +48,7 @@ void xp_stx_name_close (xp_stx_name_t* name) if (name->__malloced) xp_free (name); } -int xp_stx_name_addc (xp_stx_name_t* name, xp_cint_t c) +int xp_lsp_name_addc (xp_lsp_name_t* name, xp_cint_t c) { if (name->size >= name->capacity) { /* double the capacity. */ @@ -82,23 +83,23 @@ int xp_stx_name_addc (xp_stx_name_t* name, xp_cint_t c) return 0; } -int xp_stx_name_adds (xp_stx_name_t* name, const xp_char_t* s) +int xp_lsp_name_adds (xp_lsp_name_t* name, const xp_char_t* s) { while (*s != XP_CHAR('\0')) { - if (xp_stx_name_addc(name, *s) == -1) return -1; + if (xp_lsp_name_addc(name, *s) == -1) return -1; s++; } return 0; } -void xp_stx_name_clear (xp_stx_name_t* name) +void xp_lsp_name_clear (xp_lsp_name_t* name) { name->size = 0; name->buffer[0] = XP_CHAR('\0'); } -xp_char_t* xp_stx_name_yield (xp_stx_name_t* name, xp_word_t capacity) +xp_char_t* xp_lsp_name_yield (xp_lsp_name_t* name, xp_word_t capacity) { xp_char_t* old_buffer, * new_buffer; @@ -131,7 +132,7 @@ xp_char_t* xp_stx_name_yield (xp_stx_name_t* name, xp_word_t capacity) return old_buffer; } -int xp_stx_name_compare (xp_stx_name_t* name, const xp_char_t* str) +int xp_lsp_name_compare (xp_lsp_name_t* name, const xp_char_t* str) { xp_char_t* p = name->buffer; xp_word_t index = 0; diff --git a/ase/lsp/prim.c b/ase/lsp/prim.c index 0c91b8ee..f7ba195e 100644 --- a/ase/lsp/prim.c +++ b/ase/lsp/prim.c @@ -1,9 +1,9 @@ /* - * $Id: prim.c,v 1.1 2005-09-18 10:18:35 bacon Exp $ + * $Id: prim.c,v 1.2 2005-09-18 11:34:35 bacon Exp $ */ #include -#include +#include #include #include diff --git a/ase/test/lsp/lisp.c b/ase/test/lsp/lisp.c index 7acddd15..edefc5b2 100644 --- a/ase/test/lsp/lisp.c +++ b/ase/test/lsp/lisp.c @@ -1,7 +1,8 @@ -#include +#include #include #include #include +#include #ifdef __linux #include @@ -91,8 +92,8 @@ xp_cli_t* parse_cli (int argc, xp_char_t* argv[]) int xp_main (int argc, xp_char_t* argv[]) { - xp_lisp_t* lisp; - xp_lisp_obj_t* obj; + xp_lsp_t* lsp; + xp_lsp_obj_t* obj; xp_cli_t* cli; int mem, inc; @@ -100,7 +101,11 @@ int xp_main (int argc, xp_char_t* argv[]) mtrace (); #endif -setlocale (LC_ALL, ""); + if (xp_setlocale () == -1) { + xp_fprintf (xp_stderr, + XP_TEXT("error: cannot set locale\n")); + return -1; + } if ((cli = parse_cli (argc, argv)) == XP_NULL) return -1; mem = to_int(xp_getclioptval(cli, XP_TEXT("memory"))); @@ -113,50 +118,50 @@ setlocale (LC_ALL, ""); return -1; } - lisp = xp_lisp_new (mem, inc); - if (lisp == XP_NULL) { + lsp = xp_lsp_open (XP_NULL, mem, inc); + if (lsp == XP_NULL) { xp_fprintf (xp_stderr, - XP_TEXT("error: cannot create a lisp instance\n")); + XP_TEXT("error: cannot create a lsp instance\n")); return -1; } - xp_printf (XP_TEXT("LISP 0.0001\n")); + xp_printf (XP_TEXT("LSP 0.0001\n")); - xp_lisp_set_creader (lisp, get_char, XP_NULL); + xp_lsp_attach_input (lsp, get_char); for (;;) { xp_printf (XP_TEXT("%s> "), argv[0]); - obj = xp_lisp_read (lisp); + obj = xp_lsp_read (lsp); if (obj == XP_NULL) { - if (lisp->error != XP_LISP_ERR_END && - lisp->error != XP_LISP_ERR_ABORT) { + if (lsp->errnum != XP_LSP_ERR_END && + lsp->errnum != XP_LSP_ERR_ABORT) { xp_fprintf (xp_stderr, - XP_TEXT("error while reading: %d\n"), lisp->error); + XP_TEXT("error while reading: %d\n"), lsp->errnum); } - if (lisp->error < XP_LISP_ERR_SYNTAX) break; + if (lsp->errnum < XP_LSP_ERR_SYNTAX) break; continue; } - if ((obj = xp_lisp_eval (lisp, obj)) != XP_NULL) { - xp_lisp_print (lisp, obj); + if ((obj = xp_lsp_eval (lsp, obj)) != XP_NULL) { + xp_lsp_print (lsp, obj); xp_printf (XP_TEXT("\n")); } else { - if (lisp->error == XP_LISP_ERR_ABORT) break; + if (lsp->errnum == XP_LSP_ERR_ABORT) break; xp_fprintf (xp_stderr, - XP_TEXT("error while reading: %d\n"), lisp->error); + XP_TEXT("error while reading: %d\n"), lsp->errnum); } /* printf ("-----------\n"); - xp_lisp_print (lisp, obj); + xp_lsp_print (lsp, obj); printf ("\n-----------\n"); */ } - xp_lisp_free (lisp); + xp_lsp_close (lsp); #ifdef __linux muntrace ();