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-20 11:19:15 +00:00
parent fe556e6bbc
commit 84409ba713
10 changed files with 276 additions and 79 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

43
ase/lsp/init.c
View File

@ -1,11 +1,14 @@
/* /*
* $Id: init.c,v 1.7 2005-09-20 09:17:06 bacon Exp $ * $Id: init.c,v 1.8 2005-09-20 11:19:15 bacon Exp $
*/ */
#include <xp/lsp/lsp.h> #include <xp/lsp/lsp.h>
#include <xp/lsp/prim.h>
#include <xp/bas/memory.h> #include <xp/bas/memory.h>
#include <xp/bas/assert.h> #include <xp/bas/assert.h>
static int __add_builtin_prims (xp_lsp_t* lsp);
xp_lsp_t* xp_lsp_open (xp_lsp_t* lsp, xp_lsp_t* xp_lsp_open (xp_lsp_t* lsp,
xp_size_t mem_ubound, xp_size_t mem_ubound_inc) xp_size_t mem_ubound, xp_size_t mem_ubound_inc)
{ {
@ -38,7 +41,7 @@ xp_lsp_t* xp_lsp_open (xp_lsp_t* lsp,
return XP_NULL; return XP_NULL;
} }
if (xp_lsp_add_builtin_prims (lsp->mem) == -1) { if (__add_builtin_prims(lsp) == -1) {
xp_lsp_mem_free (lsp->mem); xp_lsp_mem_free (lsp->mem);
xp_lsp_token_close (&lsp->token); xp_lsp_token_close (&lsp->token);
if (lsp->__malloced) xp_free (lsp); if (lsp->__malloced) xp_free (lsp);
@ -119,3 +122,39 @@ int xp_lsp_detach_output (xp_lsp_t* lsp)
return 0; return 0;
} }
static int __add_builtin_prims (xp_lsp_t* lsp)
{
#define ADD_PRIM(mem,name,prim) \
if (xp_lsp_add_prim(mem,name,prim) == -1) return -1;
ADD_PRIM (lsp, XP_TEXT("abort"), xp_lsp_prim_abort);
ADD_PRIM (lsp, XP_TEXT("eval"), xp_lsp_prim_eval);
ADD_PRIM (lsp, XP_TEXT("prog1"), xp_lsp_prim_prog1);
ADD_PRIM (lsp, XP_TEXT("progn"), xp_lsp_prim_progn);
ADD_PRIM (lsp, XP_TEXT("gc"), xp_lsp_prim_gc);
ADD_PRIM (lsp, XP_TEXT("cond"), xp_lsp_prim_cond);
ADD_PRIM (lsp, XP_TEXT("if"), xp_lsp_prim_if);
ADD_PRIM (lsp, XP_TEXT("while"), xp_lsp_prim_while);
ADD_PRIM (lsp, XP_TEXT("car"), xp_lsp_prim_car);
ADD_PRIM (lsp, XP_TEXT("cdr"), xp_lsp_prim_cdr);
ADD_PRIM (lsp, XP_TEXT("cons"), xp_lsp_prim_cons);
ADD_PRIM (lsp, XP_TEXT("set"), xp_lsp_prim_set);
ADD_PRIM (lsp, XP_TEXT("setq"), xp_lsp_prim_setq);
ADD_PRIM (lsp, XP_TEXT("quote"), xp_lsp_prim_quote);
ADD_PRIM (lsp, XP_TEXT("defun"), xp_lsp_prim_defun);
ADD_PRIM (lsp, XP_TEXT("demac"), xp_lsp_prim_demac);
ADD_PRIM (lsp, XP_TEXT("let"), xp_lsp_prim_let);
ADD_PRIM (lsp, XP_TEXT("let*"), xp_lsp_prim_letx);
ADD_PRIM (lsp, XP_TEXT(">"), xp_lsp_prim_gt);
ADD_PRIM (lsp, XP_TEXT("<"), xp_lsp_prim_lt);
ADD_PRIM (lsp, XP_TEXT("+"), xp_lsp_prim_plus);
ADD_PRIM (lsp, XP_TEXT("-"), xp_lsp_prim_minus);
return 0;
}

70
ase/lsp/mem.c
View File

@ -1,13 +1,13 @@
/* /*
* $Id: mem.c,v 1.5 2005-09-20 09:17:06 bacon Exp $ * $Id: mem.c,v 1.6 2005-09-20 11:19:15 bacon Exp $
*/ */
#include <xp/lsp/mem.h> #include <xp/lsp/mem.h>
#include <xp/lsp/prim.h> #include <xp/lsp/prim.h>
#include <xp/bas/memory.h> #include <xp/bas/memory.h>
#include <xp/bas/string.h>
#include <xp/bas/assert.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* xp_lsp_mem_new (xp_size_t ubound, xp_size_t ubound_inc)
{ {
@ -56,9 +56,9 @@ xp_lsp_mem_t* xp_lsp_mem_new (xp_size_t ubound, xp_size_t ubound_inc)
// initialize common object pointers // initialize common object pointers
mem->nil = xp_lsp_make_nil (mem); mem->nil = xp_lsp_make_nil (mem);
mem->t = xp_lsp_make_true (mem); mem->t = xp_lsp_make_true (mem);
mem->quote = xp_lsp_make_symbol (mem, XP_TEXT("quote"), 5); mem->quote = xp_lsp_make_symbol (mem, XP_TEXT("quote"));
mem->lambda = xp_lsp_make_symbol (mem, XP_TEXT("lambda"), 6); mem->lambda = xp_lsp_make_symbol (mem, XP_TEXT("lambda"));
mem->macro = xp_lsp_make_symbol (mem, XP_TEXT("macro"), 5); mem->macro = xp_lsp_make_symbol (mem, XP_TEXT("macro"));
if (mem->nil == XP_NULL || if (mem->nil == XP_NULL ||
mem->t == XP_NULL || mem->t == XP_NULL ||
@ -93,11 +93,11 @@ void xp_lsp_mem_free (xp_lsp_mem_t* mem)
} }
static int __add_prim (xp_lsp_mem_t* mem, static int __add_prim (xp_lsp_mem_t* mem,
const xp_char_t* name, xp_size_t len, xp_lsp_pimpl_t prim) const xp_char_t* name, xp_size_t len, xp_lsp_prim_t prim)
{ {
xp_lsp_obj_t* n, * p; xp_lsp_obj_t* n, * p;
n = xp_lsp_make_symbol (mem, name, len); n = xp_lsp_make_symbolx (mem, name, len);
if (n == XP_NULL) return -1; if (n == XP_NULL) return -1;
xp_lsp_lock (n); xp_lsp_lock (n);
@ -199,7 +199,9 @@ void xp_lsp_dispose (xp_lsp_mem_t* mem, xp_lsp_obj_t* prev, xp_lsp_obj_t* obj)
else XP_LSP_LINK(prev) = XP_LSP_LINK(obj); else XP_LSP_LINK(prev) = XP_LSP_LINK(obj);
mem->count--; mem->count--;
#if 0
xp_dprint1 (XP_TEXT("mem->count: %u\n"), mem->count); xp_dprint1 (XP_TEXT("mem->count: %u\n"), mem->count);
#endif
xp_free (obj); xp_free (obj);
} }
@ -287,21 +289,30 @@ static void xp_lsp_mark (xp_lsp_mem_t* mem)
xp_lsp_array_t* array; xp_lsp_array_t* array;
xp_size_t i; xp_size_t i;
#if 0
xp_dprint0 (XP_TEXT("marking environment frames\n")); xp_dprint0 (XP_TEXT("marking environment frames\n"));
#endif
// mark objects in the environment frames // mark objects in the environment frames
frame = mem->frame; frame = mem->frame;
while (frame != XP_NULL) { while (frame != XP_NULL) {
assoc = frame->assoc; assoc = frame->assoc;
while (assoc != XP_NULL) { while (assoc != XP_NULL) {
xp_lsp_mark_obj (assoc->name); xp_lsp_mark_obj (assoc->name);
if (assoc->value != XP_NULL)
xp_lsp_mark_obj (assoc->value); xp_lsp_mark_obj (assoc->value);
if (assoc->func != XP_NULL)
xp_lsp_mark_obj (assoc->func);
assoc = assoc->link; assoc = assoc->link;
} }
frame = frame->link; frame = frame->link;
} }
#if 0
xp_dprint0 (XP_TEXT("marking interim frames\n")); xp_dprint0 (XP_TEXT("marking interim frames\n"));
#endif
// mark objects in the interim frames // mark objects in the interim frames
frame = mem->brooding_frame; frame = mem->brooding_frame;
@ -310,7 +321,12 @@ static void xp_lsp_mark (xp_lsp_mem_t* mem)
assoc = frame->assoc; assoc = frame->assoc;
while (assoc != XP_NULL) { while (assoc != XP_NULL) {
xp_lsp_mark_obj (assoc->name); xp_lsp_mark_obj (assoc->name);
if (assoc->value != XP_NULL)
xp_lsp_mark_obj (assoc->value); xp_lsp_mark_obj (assoc->value);
if (assoc->func != XP_NULL)
xp_lsp_mark_obj (assoc->func);
assoc = assoc->link; assoc = assoc->link;
} }
@ -322,13 +338,17 @@ static void xp_lsp_mark (xp_lsp_mem_t* mem)
if (mem->locked != XP_NULL) xp_lsp_mark_obj (mem->locked); if (mem->locked != XP_NULL) xp_lsp_mark_obj (mem->locked);
*/ */
#if 0
xp_dprint0 (XP_TEXT("marking termporary objects\n")); xp_dprint0 (XP_TEXT("marking termporary objects\n"));
#endif
array = mem->temp_array; array = mem->temp_array;
for (i = 0; i < array->size; i++) { for (i = 0; i < array->size; i++) {
xp_lsp_mark_obj (array->buffer[i]); xp_lsp_mark_obj (array->buffer[i]);
} }
#if 0
xp_dprint0 (XP_TEXT("marking builtin objects\n")); xp_dprint0 (XP_TEXT("marking builtin objects\n"));
#endif
// mark common objects // mark common objects
if (mem->t != XP_NULL) xp_lsp_mark_obj (mem->t); if (mem->t != XP_NULL) xp_lsp_mark_obj (mem->t);
if (mem->nil != XP_NULL) xp_lsp_mark_obj (mem->nil); if (mem->nil != XP_NULL) xp_lsp_mark_obj (mem->nil);
@ -349,7 +369,9 @@ static void xp_lsp_sweep (xp_lsp_mem_t* mem)
obj = mem->used[i]; obj = mem->used[i];
//obj = mem->used[--i]; //obj = mem->used[--i];
#if 0
xp_dprint1 (XP_TEXT("sweeping objects of type: %u\n"), i); xp_dprint1 (XP_TEXT("sweeping objects of type: %u\n"), i);
#endif
while (obj != XP_NULL) { while (obj != XP_NULL) {
next = XP_LSP_LINK(obj); next = XP_LSP_LINK(obj);
@ -393,7 +415,8 @@ xp_lsp_obj_t* xp_lsp_make_int (xp_lsp_mem_t* mem, xp_lsp_int_t value)
{ {
xp_lsp_obj_t* obj; xp_lsp_obj_t* obj;
obj = xp_lsp_alloc (mem, XP_LSP_OBJ_INT, xp_sizeof(xp_lsp_obj_int_t)); obj = xp_lsp_alloc (mem,
XP_LSP_OBJ_INT, xp_sizeof(xp_lsp_obj_int_t));
if (obj == XP_NULL) return XP_NULL; if (obj == XP_NULL) return XP_NULL;
XP_LSP_IVALUE(obj) = value; XP_LSP_IVALUE(obj) = value;
@ -401,19 +424,25 @@ xp_lsp_obj_t* xp_lsp_make_int (xp_lsp_mem_t* mem, xp_lsp_int_t value)
return obj; return obj;
} }
xp_lsp_obj_t* xp_lsp_make_float (xp_lsp_mem_t* mem, xp_lsp_real_t value) xp_lsp_obj_t* xp_lsp_make_real (xp_lsp_mem_t* mem, xp_lsp_real_t value)
{ {
xp_lsp_obj_t* obj; xp_lsp_obj_t* obj;
obj = xp_lsp_alloc (mem, XP_LSP_OBJ_FLOAT, xp_sizeof(xp_lsp_obj_float_t)); obj = xp_lsp_alloc (mem,
XP_LSP_OBJ_REAL, xp_sizeof(xp_lsp_obj_real_t));
if (obj == XP_NULL) return XP_NULL; if (obj == XP_NULL) return XP_NULL;
XP_LSP_FVALUE(obj) = value; XP_LSP_RVALUE(obj) = value;
return obj; return obj;
} }
xp_lsp_obj_t* xp_lsp_make_symbol ( xp_lsp_obj_t* xp_lsp_make_symbol (xp_lsp_mem_t* mem, const xp_char_t* str)
{
return xp_lsp_make_symbolx (mem, str, xp_strlen(str));
}
xp_lsp_obj_t* xp_lsp_make_symbolx (
xp_lsp_mem_t* mem, const xp_char_t* str, xp_size_t len) xp_lsp_mem_t* mem, const xp_char_t* str, xp_size_t len)
{ {
xp_lsp_obj_t* obj; xp_lsp_obj_t* obj;
@ -437,7 +466,13 @@ xp_lsp_obj_t* xp_lsp_make_symbol (
return obj; 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* xp_lsp_make_string (xp_lsp_mem_t* mem, const xp_char_t* str)
{
return xp_lsp_make_stringx (mem, str, xp_strlen(str));
}
xp_lsp_obj_t* xp_lsp_make_stringx (
xp_lsp_mem_t* mem, const xp_char_t* str, xp_size_t len)
{ {
xp_lsp_obj_t* obj; xp_lsp_obj_t* obj;
@ -452,7 +487,8 @@ xp_lsp_obj_t* xp_lsp_make_string (xp_lsp_mem_t* mem, const xp_char_t* str, xp_si
return obj; 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* xp_lsp_make_cons (
xp_lsp_mem_t* mem, xp_lsp_obj_t* car, xp_lsp_obj_t* cdr)
{ {
xp_lsp_obj_t* obj; xp_lsp_obj_t* obj;
@ -465,7 +501,8 @@ xp_lsp_obj_t* xp_lsp_make_cons (xp_lsp_mem_t* mem, xp_lsp_obj_t* car, xp_lsp_obj
return obj; 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* xp_lsp_make_func (
xp_lsp_mem_t* mem, xp_lsp_obj_t* formal, xp_lsp_obj_t* body)
{ {
xp_lsp_obj_t* obj; xp_lsp_obj_t* obj;
@ -478,7 +515,8 @@ xp_lsp_obj_t* xp_lsp_make_func (xp_lsp_mem_t* mem, xp_lsp_obj_t* formal, xp_lsp_
return obj; 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* xp_lsp_make_macro (
xp_lsp_mem_t* mem, xp_lsp_obj_t* formal, xp_lsp_obj_t* body)
{ {
xp_lsp_obj_t* obj; xp_lsp_obj_t* obj;

25
ase/lsp/mem.h
View File

@ -1,5 +1,5 @@
/* /*
* $Id: mem.h,v 1.5 2005-09-20 09:17:06 bacon Exp $ * $Id: mem.h,v 1.6 2005-09-20 11:19:15 bacon Exp $
*/ */
#ifndef _XP_LSP_MEM_H_ #ifndef _XP_LSP_MEM_H_
@ -69,12 +69,23 @@ void xp_lsp_unlock_all (xp_lsp_obj_t* obj);
xp_lsp_obj_t* xp_lsp_make_nil (xp_lsp_mem_t* mem); xp_lsp_obj_t* xp_lsp_make_nil (xp_lsp_mem_t* mem);
xp_lsp_obj_t* xp_lsp_make_true (xp_lsp_mem_t* mem); xp_lsp_obj_t* xp_lsp_make_true (xp_lsp_mem_t* mem);
xp_lsp_obj_t* xp_lsp_make_int (xp_lsp_mem_t* mem, xp_lsp_int_t value); xp_lsp_obj_t* xp_lsp_make_int (xp_lsp_mem_t* mem, xp_lsp_int_t value);
xp_lsp_obj_t* xp_lsp_make_float (xp_lsp_mem_t* mem, xp_lsp_real_t value); xp_lsp_obj_t* xp_lsp_make_real (xp_lsp_mem_t* mem, xp_lsp_real_t value);
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* xp_lsp_make_string (xp_lsp_mem_t* mem, const xp_char_t* str, xp_size_t len); xp_lsp_obj_t* xp_lsp_make_symbol (
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_mem_t* mem, const xp_char_t* str);
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* xp_lsp_make_symbolx (
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_mem_t* mem, const xp_char_t* str, xp_size_t len);
xp_lsp_obj_t* xp_lsp_make_string (
xp_lsp_mem_t* mem, const xp_char_t* str);
xp_lsp_obj_t* xp_lsp_make_stringx (
xp_lsp_mem_t* mem, const xp_char_t* str, xp_size_t len);
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* xp_lsp_make_func (
xp_lsp_mem_t* mem, xp_lsp_obj_t* formal, xp_lsp_obj_t* body);
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* xp_lsp_make_prim (xp_lsp_mem_t* mem, void* impl); xp_lsp_obj_t* xp_lsp_make_prim (xp_lsp_mem_t* mem, void* impl);
// frame lookup // frame lookup

12
ase/lsp/obj.h
View File

@ -1,5 +1,5 @@
/* /*
* $Id: obj.h,v 1.1 2005-09-18 11:54:23 bacon Exp $ * $Id: obj.h,v 1.2 2005-09-20 11:19:15 bacon Exp $
*/ */
#ifndef _XP_LSP_OBJ_H_ #ifndef _XP_LSP_OBJ_H_
@ -13,7 +13,7 @@ enum
XP_LSP_OBJ_NIL = 0, XP_LSP_OBJ_NIL = 0,
XP_LSP_OBJ_TRUE, XP_LSP_OBJ_TRUE,
XP_LSP_OBJ_INT, XP_LSP_OBJ_INT,
XP_LSP_OBJ_FLOAT, XP_LSP_OBJ_REAL,
XP_LSP_OBJ_SYMBOL, XP_LSP_OBJ_SYMBOL,
XP_LSP_OBJ_STRING, XP_LSP_OBJ_STRING,
XP_LSP_OBJ_CONS, XP_LSP_OBJ_CONS,
@ -52,7 +52,7 @@ struct xp_lsp_obj_int_t
xp_lsp_int_t value; xp_lsp_int_t value;
}; };
struct xp_lsp_obj_float_t struct xp_lsp_obj_real_t
{ {
XP_LSP_OBJ_HEADER; XP_LSP_OBJ_HEADER;
xp_lsp_real_t value; xp_lsp_real_t value;
@ -107,7 +107,7 @@ typedef struct xp_lsp_obj_t xp_lsp_obj_t;
typedef struct xp_lsp_obj_nil_t xp_lsp_obj_nil_t; typedef struct xp_lsp_obj_nil_t xp_lsp_obj_nil_t;
typedef struct xp_lsp_obj_true_t xp_lsp_obj_true_t; typedef struct xp_lsp_obj_true_t xp_lsp_obj_true_t;
typedef struct xp_lsp_obj_int_t xp_lsp_obj_int_t; typedef struct xp_lsp_obj_int_t xp_lsp_obj_int_t;
typedef struct xp_lsp_obj_float_t xp_lsp_obj_float_t; typedef struct xp_lsp_obj_real_t xp_lsp_obj_real_t;
typedef struct xp_lsp_obj_symbol_t xp_lsp_obj_symbol_t; typedef struct xp_lsp_obj_symbol_t xp_lsp_obj_symbol_t;
typedef struct xp_lsp_obj_string_t xp_lsp_obj_string_t; typedef struct xp_lsp_obj_string_t xp_lsp_obj_string_t;
typedef struct xp_lsp_obj_cons_t xp_lsp_obj_cons_t; typedef struct xp_lsp_obj_cons_t xp_lsp_obj_cons_t;
@ -124,7 +124,7 @@ typedef struct xp_lsp_obj_prim_t xp_lsp_obj_prim_t;
// value access // value access
#define XP_LSP_IVALUE(x) (((xp_lsp_obj_int_t*)x)->value) #define XP_LSP_IVALUE(x) (((xp_lsp_obj_int_t*)x)->value)
#define XP_LSP_FVALUE(x) (((xp_lsp_obj_float_t*)x)->value) #define XP_LSP_RVALUE(x) (((xp_lsp_obj_real_t*)x)->value)
#ifdef __BORLANDC__ #ifdef __BORLANDC__
#define XP_LSP_SYMVALUE(x) ((xp_char_t*)(((xp_lsp_obj_symbol_t*)x) + 1)) #define XP_LSP_SYMVALUE(x) ((xp_char_t*)(((xp_lsp_obj_symbol_t*)x) + 1))
@ -146,6 +146,6 @@ typedef struct xp_lsp_obj_prim_t xp_lsp_obj_prim_t;
#define XP_LSP_FBODY(x) (((xp_lsp_obj_func_t*)x)->body) #define XP_LSP_FBODY(x) (((xp_lsp_obj_func_t*)x)->body)
#define XP_LSP_MFORMAL(x) (((xp_lsp_obj_macro_t*)x)->formal) #define XP_LSP_MFORMAL(x) (((xp_lsp_obj_macro_t*)x)->formal)
#define XP_LSP_MBODY(x) (((xp_lsp_obj_macro_t*)x)->body) #define XP_LSP_MBODY(x) (((xp_lsp_obj_macro_t*)x)->body)
#define XP_LSP_PIMPL(x) ((xp_lsp_pimpl_t)(((xp_lsp_obj_prim_t*)x)->impl)) #define XP_LSP_PIMPL(x) ((xp_lsp_prim_t)(((xp_lsp_obj_prim_t*)x)->impl))
#endif #endif

65
ase/lsp/prim.c
View File

@ -1,12 +1,51 @@
/* /*
* $Id: prim.c,v 1.5 2005-09-20 09:17:06 bacon Exp $ * $Id: prim.c,v 1.6 2005-09-20 11:19:15 bacon Exp $
*/ */
#include <xp/lsp/lsp.h> #include <xp/lsp/lsp.h>
#include <xp/lsp/mem.h> #include <xp/lsp/mem.h>
#include <xp/lsp/prim.h> #include <xp/lsp/prim.h>
#include <xp/bas/string.h>
#include <xp/bas/assert.h> #include <xp/bas/assert.h>
static int __add_prim (xp_lsp_mem_t* mem,
const xp_char_t* name, xp_size_t len, xp_lsp_prim_t prim);
int xp_lsp_add_prim (
xp_lsp_t* lsp, const xp_char_t* name, xp_lsp_prim_t prim)
{
return __add_prim (lsp->mem, name, xp_strlen(name), prim);
}
int xp_lsp_remove_prim (xp_lsp_t* lsp, const xp_char_t* name)
{
// TODO:
return -1;
}
static int __add_prim (xp_lsp_mem_t* mem,
const xp_char_t* name, xp_size_t len, xp_lsp_prim_t prim)
{
xp_lsp_obj_t* n, * p;
n = xp_lsp_make_symbolx (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_func(mem, n, p) == XP_NULL) return -1;
return 0;
}
xp_lsp_obj_t* xp_lsp_prim_abort (xp_lsp_t* lsp, xp_lsp_obj_t* args) xp_lsp_obj_t* xp_lsp_prim_abort (xp_lsp_t* lsp, xp_lsp_obj_t* args)
{ {
XP_LSP_PRIM_CHECK_ARG_COUNT (lsp, args, 0, 0); XP_LSP_PRIM_CHECK_ARG_COUNT (lsp, args, 0, 0);
@ -378,20 +417,20 @@ xp_lsp_obj_t* xp_lsp_prim_gt (xp_lsp_t* lsp, xp_lsp_obj_t* args)
if (XP_LSP_TYPE(p2) == XP_LSP_OBJ_INT) { if (XP_LSP_TYPE(p2) == XP_LSP_OBJ_INT) {
res = XP_LSP_IVALUE(p1) > XP_LSP_IVALUE(p2); res = XP_LSP_IVALUE(p1) > XP_LSP_IVALUE(p2);
} }
else if (XP_LSP_TYPE(p2) == XP_LSP_OBJ_FLOAT) { else if (XP_LSP_TYPE(p2) == XP_LSP_OBJ_REAL) {
res = XP_LSP_IVALUE(p1) > XP_LSP_FVALUE(p2); res = XP_LSP_IVALUE(p1) > XP_LSP_RVALUE(p2);
} }
else { else {
lsp->errnum = XP_LSP_ERR_BAD_VALUE; lsp->errnum = XP_LSP_ERR_BAD_VALUE;
return XP_NULL; return XP_NULL;
} }
} }
else if (XP_LSP_TYPE(p1) == XP_LSP_OBJ_FLOAT) { else if (XP_LSP_TYPE(p1) == XP_LSP_OBJ_REAL) {
if (XP_LSP_TYPE(p2) == XP_LSP_OBJ_INT) { if (XP_LSP_TYPE(p2) == XP_LSP_OBJ_INT) {
res = XP_LSP_FVALUE(p1) > XP_LSP_IVALUE(p2); res = XP_LSP_RVALUE(p1) > XP_LSP_IVALUE(p2);
} }
else if (XP_LSP_TYPE(p2) == XP_LSP_OBJ_FLOAT) { else if (XP_LSP_TYPE(p2) == XP_LSP_OBJ_REAL) {
res = XP_LSP_FVALUE(p1) > XP_LSP_FVALUE(p2); res = XP_LSP_RVALUE(p1) > XP_LSP_RVALUE(p2);
} }
else { else {
lsp->errnum = XP_LSP_ERR_BAD_VALUE; lsp->errnum = XP_LSP_ERR_BAD_VALUE;
@ -445,20 +484,20 @@ xp_lsp_obj_t* xp_lsp_prim_lt (xp_lsp_t* lsp, xp_lsp_obj_t* args)
if (XP_LSP_TYPE(p2) == XP_LSP_OBJ_INT) { if (XP_LSP_TYPE(p2) == XP_LSP_OBJ_INT) {
res = XP_LSP_IVALUE(p1) < XP_LSP_IVALUE(p2); res = XP_LSP_IVALUE(p1) < XP_LSP_IVALUE(p2);
} }
else if (XP_LSP_TYPE(p2) == XP_LSP_OBJ_FLOAT) { else if (XP_LSP_TYPE(p2) == XP_LSP_OBJ_REAL) {
res = XP_LSP_IVALUE(p1) < XP_LSP_FVALUE(p2); res = XP_LSP_IVALUE(p1) < XP_LSP_RVALUE(p2);
} }
else { else {
lsp->errnum = XP_LSP_ERR_BAD_VALUE; lsp->errnum = XP_LSP_ERR_BAD_VALUE;
return XP_NULL; return XP_NULL;
} }
} }
else if (XP_LSP_TYPE(p1) == XP_LSP_OBJ_FLOAT) { else if (XP_LSP_TYPE(p1) == XP_LSP_OBJ_REAL) {
if (XP_LSP_TYPE(p2) == XP_LSP_OBJ_INT) { if (XP_LSP_TYPE(p2) == XP_LSP_OBJ_INT) {
res = XP_LSP_FVALUE(p1) < XP_LSP_IVALUE(p2); res = XP_LSP_RVALUE(p1) < XP_LSP_IVALUE(p2);
} }
else if (XP_LSP_TYPE(p2) == XP_LSP_OBJ_FLOAT) { else if (XP_LSP_TYPE(p2) == XP_LSP_OBJ_REAL) {
res = XP_LSP_FVALUE(p1) < XP_LSP_FVALUE(p2); res = XP_LSP_RVALUE(p1) < XP_LSP_RVALUE(p2);
} }
else { else {
lsp->errnum = XP_LSP_ERR_BAD_VALUE; lsp->errnum = XP_LSP_ERR_BAD_VALUE;

4
ase/lsp/prim.h
View File

@ -1,5 +1,5 @@
/* /*
* $Id: prim.h,v 1.2 2005-09-20 08:05:32 bacon Exp $ * $Id: prim.h,v 1.3 2005-09-20 11:19:15 bacon Exp $
*/ */
#ifndef _XP_LSP_PRIM_H_ #ifndef _XP_LSP_PRIM_H_
@ -8,8 +8,6 @@
#include <xp/lsp/types.h> #include <xp/lsp/types.h>
#include <xp/lsp/lsp.h> #include <xp/lsp/lsp.h>
typedef xp_lsp_obj_t* (*xp_lsp_pimpl_t) (xp_lsp_t*, xp_lsp_obj_t*);
#ifdef __cplusplus #ifdef __cplusplus
extern "C" { extern "C" {
#endif #endif

69
ase/lsp/prim_math.c
View File

@ -1,5 +1,5 @@
/* /*
* $Id: prim_math.c,v 1.2 2005-09-20 09:17:06 bacon Exp $ * $Id: prim_math.c,v 1.3 2005-09-20 11:19:15 bacon Exp $
*/ */
#include <xp/lsp/prim.h> #include <xp/lsp/prim.h>
@ -8,29 +8,47 @@
xp_lsp_obj_t* xp_lsp_prim_plus (xp_lsp_t* lsp, xp_lsp_obj_t* args) xp_lsp_obj_t* xp_lsp_prim_plus (xp_lsp_t* lsp, xp_lsp_obj_t* args)
{ {
xp_lsp_obj_t* body, * tmp; xp_lsp_obj_t* body, * tmp;
xp_lsp_int_t value = 0; xp_lsp_int_t ivalue = 0;
xp_lsp_real_t rvalue = 0.;
xp_bool_t realnum = xp_false;
XP_LSP_PRIM_CHECK_ARG_COUNT (lsp, args, 1, XP_LSP_PRIM_MAX_ARG_COUNT); XP_LSP_PRIM_CHECK_ARG_COUNT (lsp, args, 1, XP_LSP_PRIM_MAX_ARG_COUNT);
xp_assert (XP_LSP_TYPE(args) == XP_LSP_OBJ_CONS); xp_assert (XP_LSP_TYPE(args) == XP_LSP_OBJ_CONS);
body = args; body = args;
//while (body != lsp->mem->nil) { //while (body != lsp->mem->nil) {
while (XP_LSP_TYPE(body) == XP_LSP_OBJ_CONS) { while (XP_LSP_TYPE(body) == XP_LSP_OBJ_CONS) {
tmp = xp_lsp_eval (lsp, XP_LSP_CAR(body)); tmp = xp_lsp_eval (lsp, XP_LSP_CAR(body));
if (tmp == XP_NULL) return XP_NULL; if (tmp == XP_NULL) return XP_NULL;
if (XP_LSP_TYPE(tmp) != XP_LSP_OBJ_INT) { if (XP_LSP_TYPE(tmp) == XP_LSP_OBJ_INT) {
if (!realnum)
ivalue = ivalue + XP_LSP_IVALUE(tmp);
else
rvalue = rvalue + XP_LSP_IVALUE(tmp);
}
else if (XP_LSP_TYPE(tmp) == XP_LSP_OBJ_REAL) {
if (!realnum) {
realnum = xp_true;
rvalue = (xp_lsp_real_t)ivalue;
}
rvalue = rvalue + XP_LSP_RVALUE(tmp);
}
else {
lsp->errnum = XP_LSP_ERR_BAD_VALUE; lsp->errnum = XP_LSP_ERR_BAD_VALUE;
return XP_NULL; return XP_NULL;
} }
value = value + XP_LSP_IVALUE(tmp);
body = XP_LSP_CDR(body); body = XP_LSP_CDR(body);
} }
xp_assert (body == lsp->mem->nil); xp_assert (body == lsp->mem->nil);
tmp = xp_lsp_make_int (lsp->mem, value); tmp = (realnum)?
xp_lsp_make_real (lsp->mem, rvalue):
xp_lsp_make_int (lsp->mem, ivalue);
if (tmp == XP_NULL) { if (tmp == XP_NULL) {
lsp->errnum = XP_LSP_ERR_MEM; lsp->errnum = XP_LSP_ERR_MEM;
return XP_NULL; return XP_NULL;
@ -42,7 +60,9 @@ xp_lsp_obj_t* xp_lsp_prim_plus (xp_lsp_t* lsp, xp_lsp_obj_t* args)
xp_lsp_obj_t* xp_lsp_prim_minus (xp_lsp_t* lsp, xp_lsp_obj_t* args) xp_lsp_obj_t* xp_lsp_prim_minus (xp_lsp_t* lsp, xp_lsp_obj_t* args)
{ {
xp_lsp_obj_t* body, * tmp; xp_lsp_obj_t* body, * tmp;
xp_lsp_int_t value = 0; xp_lsp_int_t ivalue = 0;
xp_lsp_real_t rvalue = 0.;
xp_bool_t realnum = xp_false;
XP_LSP_PRIM_CHECK_ARG_COUNT (lsp, args, 1, XP_LSP_PRIM_MAX_ARG_COUNT); XP_LSP_PRIM_CHECK_ARG_COUNT (lsp, args, 1, XP_LSP_PRIM_MAX_ARG_COUNT);
xp_assert (XP_LSP_TYPE(args) == XP_LSP_OBJ_CONS); xp_assert (XP_LSP_TYPE(args) == XP_LSP_OBJ_CONS);
@ -53,21 +73,47 @@ xp_lsp_obj_t* xp_lsp_prim_minus (xp_lsp_t* lsp, xp_lsp_obj_t* args)
tmp = xp_lsp_eval (lsp, XP_LSP_CAR(body)); tmp = xp_lsp_eval (lsp, XP_LSP_CAR(body));
if (tmp == XP_NULL) return XP_NULL; if (tmp == XP_NULL) return XP_NULL;
if (XP_LSP_TYPE(tmp) != XP_LSP_OBJ_INT) {
if (XP_LSP_TYPE(tmp) == XP_LSP_OBJ_INT) {
if (body == args) {
xp_assert (realnum == xp_false);
ivalue = XP_LSP_IVALUE(tmp);
}
else {
if (!realnum)
ivalue = ivalue - XP_LSP_IVALUE(tmp);
else
rvalue = rvalue - XP_LSP_IVALUE(tmp);
}
}
else if (XP_LSP_TYPE(tmp) == XP_LSP_OBJ_REAL) {
if (body == args) {
xp_assert (realnum == xp_false);
realnum = xp_true;
rvalue = XP_LSP_RVALUE(tmp);
}
else {
if (!realnum) {
realnum = xp_true;
rvalue = (xp_lsp_real_t)ivalue;
}
rvalue = rvalue - XP_LSP_RVALUE(tmp);
}
}
else {
lsp->errnum = XP_LSP_ERR_BAD_VALUE; lsp->errnum = XP_LSP_ERR_BAD_VALUE;
return XP_NULL; return XP_NULL;
} }
if (body == args)
value = XP_LSP_IVALUE(tmp);
else value = value - XP_LSP_IVALUE(tmp);
body = XP_LSP_CDR(body); body = XP_LSP_CDR(body);
} }
xp_assert (body == lsp->mem->nil); xp_assert (body == lsp->mem->nil);
tmp = xp_lsp_make_int (lsp->mem, value); tmp = (realnum)?
xp_lsp_make_real (lsp->mem, rvalue):
xp_lsp_make_int (lsp->mem, ivalue);
if (tmp == XP_NULL) { if (tmp == XP_NULL) {
lsp->errnum = XP_LSP_ERR_MEM; lsp->errnum = XP_LSP_ERR_MEM;
return XP_NULL; return XP_NULL;
@ -75,3 +121,4 @@ xp_lsp_obj_t* xp_lsp_prim_minus (xp_lsp_t* lsp, xp_lsp_obj_t* args)
return tmp; return tmp;
} }

18
ase/lsp/print.c
View File

@ -1,5 +1,5 @@
/* /*
* $Id: print.c,v 1.11 2005-09-20 08:05:32 bacon Exp $ * $Id: print.c,v 1.12 2005-09-20 11:19:15 bacon Exp $
*/ */
#include <xp/lsp/lsp.h> #include <xp/lsp/lsp.h>
@ -18,8 +18,8 @@ void xp_lsp_print_debug (xp_lsp_obj_t* obj)
case XP_LSP_OBJ_INT: case XP_LSP_OBJ_INT:
xp_printf (XP_TEXT("%d"), XP_LSP_IVALUE(obj)); xp_printf (XP_TEXT("%d"), XP_LSP_IVALUE(obj));
break; break;
case XP_LSP_OBJ_FLOAT: case XP_LSP_OBJ_REAL:
xp_printf (XP_TEXT("%f"), XP_LSP_FVALUE(obj)); xp_printf (XP_TEXT("%f"), XP_LSP_RVALUE(obj));
break; break;
case XP_LSP_OBJ_SYMBOL: case XP_LSP_OBJ_SYMBOL:
xp_printf (XP_TEXT("%s"), XP_LSP_SYMVALUE(obj)); xp_printf (XP_TEXT("%s"), XP_LSP_SYMVALUE(obj));
@ -104,8 +104,16 @@ static int __print (xp_lsp_t* lsp, const xp_lsp_obj_t* obj, xp_bool_t prt_cons_p
OUTPUT_STR (lsp, buf); OUTPUT_STR (lsp, buf);
break; break;
case XP_LSP_OBJ_FLOAT: case XP_LSP_OBJ_REAL:
xp_sprintf (buf, xp_countof(buf), XP_TEXT("%f"), XP_LSP_FVALUE(obj)); if (xp_sizeof(xp_lsp_real_t) == xp_sizeof(double)) {
xp_sprintf (buf, xp_countof(buf), XP_TEXT("%f"),
(double)XP_LSP_RVALUE(obj));
}
else if (xp_sizeof(xp_lsp_real_t) == xp_sizeof(long double)) {
xp_sprintf (buf, xp_countof(buf), XP_TEXT("%Lf"),
(long double)XP_LSP_RVALUE(obj));
}
OUTPUT_STR (lsp, buf); OUTPUT_STR (lsp, buf);
break; break;
case XP_LSP_OBJ_SYMBOL: case XP_LSP_OBJ_SYMBOL:

37
ase/lsp/read.c
View File

@ -1,5 +1,5 @@
/* /*
* $Id: read.c,v 1.14 2005-09-20 08:05:32 bacon Exp $ * $Id: read.c,v 1.15 2005-09-20 11:19:15 bacon Exp $
*/ */
#include <xp/lsp/lsp.h> #include <xp/lsp/lsp.h>
@ -23,7 +23,7 @@
#define TOKEN_CLEAR(lsp) xp_lsp_token_clear (&(lsp)->token) #define TOKEN_CLEAR(lsp) xp_lsp_token_clear (&(lsp)->token)
#define TOKEN_TYPE(lsp) (lsp)->token.type #define TOKEN_TYPE(lsp) (lsp)->token.type
#define TOKEN_IVALUE(lsp) (lsp)->token.ivalue #define TOKEN_IVALUE(lsp) (lsp)->token.ivalue
#define TOKEN_FVALUE(lsp) (lsp)->token.fvalue #define TOKEN_RVALUE(lsp) (lsp)->token.rvalue
#define TOKEN_SVALUE(lsp) (lsp)->token.name.buffer #define TOKEN_SVALUE(lsp) (lsp)->token.name.buffer
#define TOKEN_SLENGTH(lsp) (lsp)->token.name.size #define TOKEN_SLENGTH(lsp) (lsp)->token.name.size
#define TOKEN_ADD_CHAR(lsp,ch) \ #define TOKEN_ADD_CHAR(lsp,ch) \
@ -37,7 +37,7 @@
#define TOKEN_END 0 #define TOKEN_END 0
#define TOKEN_INT 1 #define TOKEN_INT 1
#define TOKEN_FLOAT 2 #define TOKEN_REAL 2
#define TOKEN_STRING 3 #define TOKEN_STRING 3
#define TOKEN_LPAREN 4 #define TOKEN_LPAREN 4
#define TOKEN_RPAREN 5 #define TOKEN_RPAREN 5
@ -98,13 +98,13 @@ static xp_lsp_obj_t* read_obj (xp_lsp_t* lsp)
if (obj == XP_NULL) lsp->errnum = XP_LSP_ERR_MEM; if (obj == XP_NULL) lsp->errnum = XP_LSP_ERR_MEM;
xp_lsp_lock (obj); xp_lsp_lock (obj);
return obj; return obj;
case TOKEN_FLOAT: case TOKEN_REAL:
obj = xp_lsp_make_float (lsp->mem, TOKEN_FVALUE(lsp)); obj = xp_lsp_make_real (lsp->mem, TOKEN_RVALUE(lsp));
if (obj == XP_NULL) lsp->errnum = XP_LSP_ERR_MEM; if (obj == XP_NULL) lsp->errnum = XP_LSP_ERR_MEM;
xp_lsp_lock (obj); xp_lsp_lock (obj);
return obj; return obj;
case TOKEN_STRING: case TOKEN_STRING:
obj = xp_lsp_make_string ( obj = xp_lsp_make_stringx (
lsp->mem, TOKEN_SVALUE(lsp), TOKEN_SLENGTH(lsp)); lsp->mem, TOKEN_SVALUE(lsp), TOKEN_SLENGTH(lsp));
if (obj == XP_NULL) lsp->errnum = XP_LSP_ERR_MEM; if (obj == XP_NULL) lsp->errnum = XP_LSP_ERR_MEM;
xp_lsp_lock (obj); xp_lsp_lock (obj);
@ -114,7 +114,7 @@ static xp_lsp_obj_t* read_obj (xp_lsp_t* lsp)
if (TOKEN_COMPARE(lsp,XP_TEXT("nil")) == 0) obj = lsp->mem->nil; if (TOKEN_COMPARE(lsp,XP_TEXT("nil")) == 0) obj = lsp->mem->nil;
else if (TOKEN_COMPARE(lsp,XP_TEXT("t")) == 0) obj = lsp->mem->t; else if (TOKEN_COMPARE(lsp,XP_TEXT("t")) == 0) obj = lsp->mem->t;
else { else {
obj = xp_lsp_make_symbol ( obj = xp_lsp_make_symbolx (
lsp->mem, TOKEN_SVALUE(lsp), TOKEN_SLENGTH(lsp)); lsp->mem, TOKEN_SVALUE(lsp), TOKEN_SLENGTH(lsp));
if (obj == XP_NULL) lsp->errnum = XP_LSP_ERR_MEM; if (obj == XP_NULL) lsp->errnum = XP_LSP_ERR_MEM;
xp_lsp_lock (obj); xp_lsp_lock (obj);
@ -321,6 +321,7 @@ static int read_token (xp_lsp_t* lsp)
static int read_number (xp_lsp_t* lsp, int negative) static int read_number (xp_lsp_t* lsp, int negative)
{ {
xp_lsp_int_t ivalue = 0; xp_lsp_int_t ivalue = 0;
xp_lsp_real_t rvalue = 0.;
do { do {
ivalue = ivalue * 10 + (lsp->curc - XP_CHAR('0')); ivalue = ivalue * 10 + (lsp->curc - XP_CHAR('0'));
@ -328,12 +329,28 @@ static int read_number (xp_lsp_t* lsp, int negative)
NEXT_CHAR (lsp); NEXT_CHAR (lsp);
} while (IS_DIGIT(lsp->curc)); } while (IS_DIGIT(lsp->curc));
if (negative) ivalue *= -1; /* TODO: extend parsing floating point number */
if (lsp->curc == XP_CHAR('.')) {
xp_lsp_real_t fraction = 0.1;
NEXT_CHAR (lsp);
rvalue = (xp_lsp_real_t)ivalue;
while (IS_DIGIT(lsp->curc)) {
rvalue += (xp_lsp_real_t)(lsp->curc - XP_CHAR('0')) * fraction;
fraction *= 0.1;
NEXT_CHAR (lsp);
}
TOKEN_RVALUE(lsp) = rvalue;
TOKEN_TYPE(lsp) = TOKEN_REAL;
if (negative) rvalue *= -1;
}
else {
TOKEN_IVALUE(lsp) = ivalue; TOKEN_IVALUE(lsp) = ivalue;
TOKEN_TYPE(lsp) = TOKEN_INT; TOKEN_TYPE(lsp) = TOKEN_INT;
if (negative) ivalue *= -1;
/* TODO: read floating point numbers */ }
return 0; return 0;
} }

4
ase/lsp/token.h
View File

@ -1,5 +1,5 @@
/* /*
* $Id: token.h,v 1.9 2005-09-18 10:18:35 bacon Exp $ * $Id: token.h,v 1.10 2005-09-20 11:19:15 bacon Exp $
*/ */
#ifndef _XP_LSP_TOKEN_H_ #ifndef _XP_LSP_TOKEN_H_
@ -18,7 +18,7 @@ struct xp_lsp_token_t
int type; int type;
xp_lsp_int_t ivalue; xp_lsp_int_t ivalue;
xp_lsp_real_t fvalue; xp_lsp_real_t rvalue;
xp_lsp_name_t name; xp_lsp_name_t name;
xp_bool_t __malloced; xp_bool_t __malloced;