hyung-hwan/qse
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

*** empty log message ***

Browse Source
This commit is contained in:
hyung-hwan 2005-09-18 11:34:35 +00:00
parent 432377371c
commit 68fde07ef9
10 changed files with 750 additions and 738 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

20
ase/lsp/array.c
View File

@ -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 <xp/lsp/array.h>
#include <xp/bas/memory.h>
#include <xp/bas/assert.h>
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;

38
ase/lsp/env.c
View File

@ -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 <xp/lsp/env.h>
#include <xp/bas/memory.h>
#include <xp/bas/assert.h>
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;

2
ase/lsp/env.h
View File

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

17
ase/lsp/lsp.h
View File

@ -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 <xp/lsp/types.h>
#include <xp/lsp/token.h>
#include <xp/lsp/object.h>
#include <xp/lsp/memory.h>
#include <xp/lsp/mem.h>
#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

662
ase/lsp/mem.c Normal file
View File

@ -0,0 +1,662 @@
/*
* $Id: mem.c,v 1.1 2005-09-18 11:34:35 bacon Exp $
*/
#include <xp/lsp/mem.h>
#include <xp/lsp/prim.h>
#include <xp/bas/memory.h>
#include <xp/bas/assert.h>
#include <xp/bas/dprint.h>
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');
}

2
ase/lsp/memory.h → ase/lsp/mem.h
View File

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

661
ase/lsp/memory.c
View File

@ -1,661 +0,0 @@
/*
* $Id: memory.c,v 1.11 2005-05-28 13:34:26 bacon Exp $
*/
#include <xp/lsp/memory.h>
#include <xp/lsp/primitive.h>
#include <xp/bas/memory.h>
#include <xp/bas/assert.h>
#include <xp/bas/dprint.h>
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');
}

29
ase/lsp/name.c
View File

@ -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 <xp/stx/name.h>
#include <xp/stx/misc.h>
#include <xp/lsp/name.h>
#include <xp/bas/memory.h>
#include <xp/bas/assert.h>
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;

4
ase/lsp/prim.c
View File

@ -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 <xp/lsp/lsp.h>
#include <xp/lsp/memory.h>
#include <xp/lsp/mem.h>
#include <xp/lsp/prim.h>
#include <xp/bas/assert.h>

45
ase/test/lsp/lisp.c
View File

@ -1,7 +1,8 @@
#include <xp/lisp/lisp.h>
#include <xp/lsp/lsp.h>
#include <xp/bas/stdio.h>
#include <xp/bas/ctype.h>
#include <xp/bas/stdcli.h>
#include <xp/bas/locale.h>
#ifdef __linux
#include <mcheck.h>
@ -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 ();