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 2006-10-29 13:00:39 +00:00
parent ca2e588244
commit 4c57a641d5
18 changed files with 417 additions and 429 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
ase/awk/awk.dsp
View File

@ -45,7 +45,7 @@ MTL=midl.exe
# ADD BASE MTL /nologo /D "NDEBUG" /mktyplib203 /win32 # ADD BASE MTL /nologo /D "NDEBUG" /mktyplib203 /win32
# ADD MTL /nologo /D "NDEBUG" /mktyplib203 /win32 # ADD MTL /nologo /D "NDEBUG" /mktyplib203 /win32
# ADD BASE CPP /nologo /MT /W3 /GX /O2 /D "WIN32" /D "NDEBUG" /D "_WINDOWS" /D "_UNICODE" /D "_USRDLL" /Yu"stdafx.h" /FD /c # ADD BASE CPP /nologo /MT /W3 /GX /O2 /D "WIN32" /D "NDEBUG" /D "_WINDOWS" /D "_UNICODE" /D "_USRDLL" /Yu"stdafx.h" /FD /c
# ADD CPP /nologo /MT /Za /W3 /GX /O2 /I "..\.." /D "NDEBUG" /D "WIN32" /D "_WINDOWS" /D "_UNICODE" /FD /c # ADD CPP /nologo /MT /Za /W3 /GX /O2 /I "..\.." /D "NDEBUG" /D "WIN32" /D "_UNICODE" /FD /c
# SUBTRACT CPP /YX /Yc /Yu # SUBTRACT CPP /YX /Yc /Yu
# ADD BASE RSC /l 0x409 /d "NDEBUG" # ADD BASE RSC /l 0x409 /d "NDEBUG"
# ADD RSC /l 0x409 /d "NDEBUG" # ADD RSC /l 0x409 /d "NDEBUG"
@ -73,7 +73,7 @@ MTL=midl.exe
# ADD BASE MTL /nologo /D "_DEBUG" /mktyplib203 /win32 # ADD BASE MTL /nologo /D "_DEBUG" /mktyplib203 /win32
# ADD MTL /nologo /D "_DEBUG" /mktyplib203 /win32 # ADD MTL /nologo /D "_DEBUG" /mktyplib203 /win32
# ADD BASE CPP /nologo /MTd /W3 /Gm /GX /ZI /Od /D "WIN32" /D "_DEBUG" /D "_WINDOWS" /D "_UNICODE" /D "_USRDLL" /Yu"stdafx.h" /FD /GZ /c # ADD BASE CPP /nologo /MTd /W3 /Gm /GX /ZI /Od /D "WIN32" /D "_DEBUG" /D "_WINDOWS" /D "_UNICODE" /D "_USRDLL" /Yu"stdafx.h" /FD /GZ /c
# ADD CPP /nologo /MTd /Za /W3 /Gm /GX /ZI /Od /I "..\.." /D "_DEBUG" /D "WIN32" /D "_WINDOWS" /D "_UNICODE" /FD /GZ /c # ADD CPP /nologo /MTd /Za /W3 /Gm /GX /ZI /Od /I "..\.." /D "_DEBUG" /D "WIN32" /D "_UNICODE" /FD /GZ /c
# SUBTRACT CPP /YX /Yc /Yu # SUBTRACT CPP /YX /Yc /Yu
# ADD BASE RSC /l 0x409 /d "_DEBUG" # ADD BASE RSC /l 0x409 /d "_DEBUG"
# ADD RSC /l 0x409 /d "_DEBUG" # ADD RSC /l 0x409 /d "_DEBUG"

104
ase/awk/val.c
View File

@ -1,5 +1,5 @@
/* /*
* $Id: val.c,v 1.78 2006-10-28 05:24:08 bacon Exp $ * $Id: val.c,v 1.79 2006-10-29 13:00:39 bacon Exp $
*/ */
#include <ase/awk/awk_i.h> #include <ase/awk/awk_i.h>
@ -352,20 +352,20 @@ ase_bool_t ase_awk_valtobool (ase_awk_run_t* run, ase_awk_val_t* val)
switch (val->type) switch (val->type)
{ {
case ASE_AWK_VAL_NIL: case ASE_AWK_VAL_NIL:
return ase_false; return ase_false;
case ASE_AWK_VAL_INT: case ASE_AWK_VAL_INT:
return ((ase_awk_val_int_t*)val)->val != 0; return ((ase_awk_val_int_t*)val)->val != 0;
case ASE_AWK_VAL_REAL: case ASE_AWK_VAL_REAL:
return ((ase_awk_val_real_t*)val)->val != 0.0; return ((ase_awk_val_real_t*)val)->val != 0.0;
case ASE_AWK_VAL_STR: case ASE_AWK_VAL_STR:
return ((ase_awk_val_str_t*)val)->len > 0; return ((ase_awk_val_str_t*)val)->len > 0;
case ASE_AWK_VAL_REX: /* TODO: is this correct? */ case ASE_AWK_VAL_REX: /* TODO: is this correct? */
return ((ase_awk_val_rex_t*)val)->len > 0; return ((ase_awk_val_rex_t*)val)->len > 0;
case ASE_AWK_VAL_MAP: case ASE_AWK_VAL_MAP:
return ase_false; /* TODO: is this correct? */ return ase_false; /* TODO: is this correct? */
case ASE_AWK_VAL_REF: case ASE_AWK_VAL_REF:
return ase_false; /* TODO: is this correct? */ return ase_false; /* TODO: is this correct? */
} }
ASE_AWK_ASSERT (run->awk, !"should never happen - invalid value type"); ASE_AWK_ASSERT (run->awk, !"should never happen - invalid value type");
@ -666,49 +666,49 @@ void ase_awk_dprintval (ase_awk_run_t* run, ase_awk_val_t* val)
switch (val->type) switch (val->type)
{ {
case ASE_AWK_VAL_NIL: case ASE_AWK_VAL_NIL:
__DPRINTF (ASE_T("nil")); __DPRINTF (ASE_T("nil"));
break; break;
case ASE_AWK_VAL_INT: case ASE_AWK_VAL_INT:
#if defined(__BORLANDC__) || defined(_MSC_VER) #if defined(__BORLANDC__) || defined(_MSC_VER)
__DPRINTF (ASE_T("%I64d"), __DPRINTF (ASE_T("%I64d"),
(__int64)((ase_awk_nde_int_t*)val)->val); (__int64)((ase_awk_nde_int_t*)val)->val);
#elif defined(vax) || defined(__vax) || defined(_SCO_DS) #elif defined(vax) || defined(__vax) || defined(_SCO_DS)
__DPRINTF (ASE_T("%ld"), __DPRINTF (ASE_T("%ld"),
(long)((ase_awk_val_int_t*)val)->val); (long)((ase_awk_val_int_t*)val)->val);
#else #else
__DPRINTF (ASE_T("%lld"), __DPRINTF (ASE_T("%lld"),
(long long)((ase_awk_val_int_t*)val)->val); (long long)((ase_awk_val_int_t*)val)->val);
#endif #endif
break; break;
case ASE_AWK_VAL_REAL: case ASE_AWK_VAL_REAL:
__DPRINTF (ASE_T("%Lf"), __DPRINTF (ASE_T("%Lf"),
(long double)((ase_awk_val_real_t*)val)->val); (long double)((ase_awk_val_real_t*)val)->val);
break; break;
case ASE_AWK_VAL_STR: case ASE_AWK_VAL_STR:
__DPRINTF (ASE_T("%s"), ((ase_awk_val_str_t*)val)->buf); __DPRINTF (ASE_T("%s"), ((ase_awk_val_str_t*)val)->buf);
break; break;
case ASE_AWK_VAL_REX: case ASE_AWK_VAL_REX:
__DPRINTF (ASE_T("REX[%s]"), ((ase_awk_val_rex_t*)val)->buf); __DPRINTF (ASE_T("REX[%s]"), ((ase_awk_val_rex_t*)val)->buf);
break; break;
case ASE_AWK_VAL_MAP: case ASE_AWK_VAL_MAP:
__DPRINTF (ASE_T("MAP[")); __DPRINTF (ASE_T("MAP["));
ase_awk_map_walk (((ase_awk_val_map_t*)val)->map, __print_pair, run); ase_awk_map_walk (((ase_awk_val_map_t*)val)->map, __print_pair, run);
__DPRINTF (ASE_T("]")); __DPRINTF (ASE_T("]"));
break; break;
case ASE_AWK_VAL_REF: case ASE_AWK_VAL_REF:
__DPRINTF (ASE_T("REF[id=%d,val="), ((ase_awk_val_ref_t*)val)->id); __DPRINTF (ASE_T("REF[id=%d,val="), ((ase_awk_val_ref_t*)val)->id);
ase_awk_dprintval (run, *((ase_awk_val_ref_t*)val)->adr); ase_awk_dprintval (run, *((ase_awk_val_ref_t*)val)->adr);
__DPRINTF (ASE_T("]")); __DPRINTF (ASE_T("]"));
break; break;
default: default:
__DPRINTF (ASE_T("**** INTERNAL ERROR - INVALID VALUE TYPE ****\n")); __DPRINTF (ASE_T("**** INTERNAL ERROR - INVALID VALUE TYPE ****\n"));
} }
} }

52
ase/lsp/err.c
View File

@ -1,34 +1,9 @@
/* /*
* $Id: err.c,v 1.4 2006-10-25 13:42:31 bacon Exp $ * $Id: err.c,v 1.5 2006-10-29 13:00:39 bacon Exp $
*/ */
#include <ase/lsp/lsp_i.h> #include <ase/lsp/lsp_i.h>
static const ase_char_t* __errstr[] =
{
ASE_T("no error"),
ASE_T("out of memory"),
ASE_T("abort"),
ASE_T("end"),
ASE_T("input not attached"),
ASE_T("input"),
ASE_T("output not attached"),
ASE_T("output"),
ASE_T("syntax"),
ASE_T("bad arguments"),
ASE_T("wrong arguments"),
ASE_T("too few arguments"),
ASE_T("too many arguments"),
ASE_T("undefined function"),
ASE_T("bad function"),
ASE_T("duplicate formal"),
ASE_T("bad symbol"),
ASE_T("undefined symbol"),
ASE_T("empty body"),
ASE_T("bad value"),
ASE_T("divide by zero")
};
int ase_lsp_geterrnum (ase_lsp_t* lsp) int ase_lsp_geterrnum (ase_lsp_t* lsp)
{ {
return lsp->errnum; return lsp->errnum;
@ -36,6 +11,31 @@ int ase_lsp_geterrnum (ase_lsp_t* lsp)
const ase_char_t* ase_lsp_geterrstr (int errnum) const ase_char_t* ase_lsp_geterrstr (int errnum)
{ {
static const ase_char_t* __errstr[] =
{
ASE_T("no error"),
ASE_T("out of memory"),
ASE_T("abort"),
ASE_T("end"),
ASE_T("input not attached"),
ASE_T("input"),
ASE_T("output not attached"),
ASE_T("output"),
ASE_T("syntax"),
ASE_T("bad arguments"),
ASE_T("wrong arguments"),
ASE_T("too few arguments"),
ASE_T("too many arguments"),
ASE_T("undefined function"),
ASE_T("bad function"),
ASE_T("duplicate formal"),
ASE_T("bad symbol"),
ASE_T("undefined symbol"),
ASE_T("empty body"),
ASE_T("bad value"),
ASE_T("divide by zero")
};
if (errnum >= 0 && errnum < ase_countof(__errstr)) if (errnum >= 0 && errnum < ase_countof(__errstr))
{ {
return __errstr[errnum]; return __errstr[errnum];

53
ase/lsp/eval.c
View File

@ -1,5 +1,5 @@
/* /*
* $Id: eval.c,v 1.18 2006-10-26 09:31:28 bacon Exp $ * $Id: eval.c,v 1.19 2006-10-29 13:00:39 bacon Exp $
*/ */
#include <ase/lsp/lsp_i.h> #include <ase/lsp/lsp_i.h>
@ -16,8 +16,11 @@ ase_lsp_obj_t* ase_lsp_eval (ase_lsp_t* lsp, ase_lsp_obj_t* obj)
lsp->errnum = ASE_LSP_ENOERR; lsp->errnum = ASE_LSP_ENOERR;
if (ASE_LSP_TYPE(obj) == ASE_LSP_OBJ_CONS) if (ASE_LSP_TYPE(obj) == ASE_LSP_OBJ_CONS)
{
return eval_cons (lsp, obj); return eval_cons (lsp, obj);
else if (ASE_LSP_TYPE(obj) == ASE_LSP_OBJ_SYM) { }
else if (ASE_LSP_TYPE(obj) == ASE_LSP_OBJ_SYM)
{
ase_lsp_assoc_t* assoc; ase_lsp_assoc_t* assoc;
/* /*
@ -29,8 +32,10 @@ ase_lsp_obj_t* ase_lsp_eval (ase_lsp_t* lsp, ase_lsp_obj_t* obj)
*/ */
assoc = ase_lsp_lookup(lsp->mem, obj); assoc = ase_lsp_lookup(lsp->mem, obj);
if (assoc == ASE_NULL || assoc->value == ASE_NULL) { if (assoc == ASE_NULL || assoc->value == ASE_NULL)
if (lsp->opt_undef_symbol) { {
if (lsp->opt_undef_symbol)
{
lsp->errnum = ASE_LSP_ERR_UNDEF_SYMBOL; lsp->errnum = ASE_LSP_ERR_UNDEF_SYMBOL;
return ASE_NULL; return ASE_NULL;
} }
@ -47,12 +52,14 @@ static ase_lsp_obj_t* make_func (ase_lsp_t* lsp, ase_lsp_obj_t* cdr, int is_macr
{ {
ase_lsp_obj_t* func, * formal, * body, * p; ase_lsp_obj_t* func, * formal, * body, * p;
if (cdr == lsp->mem->nil) { if (cdr == lsp->mem->nil)
{
lsp->errnum = ASE_LSP_ERR_TOO_FEW_ARGS; lsp->errnum = ASE_LSP_ERR_TOO_FEW_ARGS;
return ASE_NULL; return ASE_NULL;
} }
if (ASE_LSP_TYPE(cdr) != ASE_LSP_OBJ_CONS) { if (ASE_LSP_TYPE(cdr) != ASE_LSP_OBJ_CONS)
{
lsp->errnum = ASE_LSP_ERR_BAD_ARG; lsp->errnum = ASE_LSP_ERR_BAD_ARG;
return ASE_NULL; return ASE_NULL;
} }
@ -60,7 +67,8 @@ static ase_lsp_obj_t* make_func (ase_lsp_t* lsp, ase_lsp_obj_t* cdr, int is_macr
formal = ASE_LSP_CAR(cdr); formal = ASE_LSP_CAR(cdr);
body = ASE_LSP_CDR(cdr); body = ASE_LSP_CDR(cdr);
if (body == lsp->mem->nil) { if (body == lsp->mem->nil)
{
lsp->errnum = ASE_LSP_ERR_EMPTY_BODY; lsp->errnum = ASE_LSP_ERR_EMPTY_BODY;
return ASE_NULL; return ASE_NULL;
} }
@ -70,7 +78,8 @@ static ase_lsp_obj_t* make_func (ase_lsp_t* lsp, ase_lsp_obj_t* cdr, int is_macr
/* check if the lambda express has non-nil value /* check if the lambda express has non-nil value
* at the terminating cdr */ * at the terminating cdr */
for (p = body; ASE_LSP_TYPE(p) == ASE_LSP_OBJ_CONS; p = ASE_LSP_CDR(p)); for (p = body; ASE_LSP_TYPE(p) == ASE_LSP_OBJ_CONS; p = ASE_LSP_CDR(p));
if (p != lsp->mem->nil) { if (p != lsp->mem->nil)
{
/* like in (lambda (x) (+ x 10) . 4) */ /* like in (lambda (x) (+ x 10) . 4) */
lsp->errnum = ASE_LSP_ERR_BAD_ARG; lsp->errnum = ASE_LSP_ERR_BAD_ARG;
return ASE_NULL; return ASE_NULL;
@ -79,7 +88,8 @@ static ase_lsp_obj_t* make_func (ase_lsp_t* lsp, ase_lsp_obj_t* cdr, int is_macr
func = (is_macro)? func = (is_macro)?
ase_lsp_makemacro (lsp->mem, formal, body): ase_lsp_makemacro (lsp->mem, formal, body):
ase_lsp_makefunc (lsp->mem, formal, body); ase_lsp_makefunc (lsp->mem, formal, body);
if (func == ASE_NULL) { if (func == ASE_NULL)
{
lsp->errnum = ASE_LSP_ENOMEM; lsp->errnum = ASE_LSP_ENOMEM;
return ASE_NULL; return ASE_NULL;
} }
@ -98,10 +108,12 @@ static ase_lsp_obj_t* eval_cons (ase_lsp_t* lsp, ase_lsp_obj_t* cons)
if (car == lsp->mem->lambda) if (car == lsp->mem->lambda)
{ {
/* (lambda (x) (+ x 20)) */
return make_func (lsp, cdr, 0); return make_func (lsp, cdr, 0);
} }
else if (car == lsp->mem->macro) else if (car == lsp->mem->macro)
{ {
/* (macro (x) (+ x 20)) */
return make_func (lsp, cdr, 1); return make_func (lsp, cdr, 1);
} }
else if (ASE_LSP_TYPE(car) == ASE_LSP_OBJ_SYM) else if (ASE_LSP_TYPE(car) == ASE_LSP_OBJ_SYM)
@ -110,9 +122,10 @@ static ase_lsp_obj_t* eval_cons (ase_lsp_t* lsp, ase_lsp_obj_t* cons)
if ((assoc = ase_lsp_lookup(lsp->mem, car)) != ASE_NULL) if ((assoc = ase_lsp_lookup(lsp->mem, car)) != ASE_NULL)
{ {
//ase_lsp_obj_t* func = assoc->value; /*ase_lsp_obj_t* func = assoc->value;*/
ase_lsp_obj_t* func = assoc->func; ase_lsp_obj_t* func = assoc->func;
if (func == ASE_NULL) { if (func == ASE_NULL)
{
/* the symbol's function definition is void */ /* the symbol's function definition is void */
lsp->errnum = ASE_LSP_ERR_UNDEF_FUNC; lsp->errnum = ASE_LSP_ERR_UNDEF_FUNC;
return ASE_NULL; return ASE_NULL;
@ -126,7 +139,7 @@ static ase_lsp_obj_t* eval_cons (ase_lsp_t* lsp, ase_lsp_obj_t* cons)
else if (ASE_LSP_TYPE(func) == ASE_LSP_OBJ_PRIM) else if (ASE_LSP_TYPE(func) == ASE_LSP_OBJ_PRIM)
{ {
/* primitive function */ /* primitive function */
return ASE_LSP_PRIM(func) (lsp, cdr); return ASE_LSP_PIMPL(func) (lsp, cdr);
} }
else else
{ {
@ -143,16 +156,22 @@ static ase_lsp_obj_t* eval_cons (ase_lsp_t* lsp, ase_lsp_obj_t* cons)
} }
} }
else if (ASE_LSP_TYPE(car) == ASE_LSP_OBJ_FUNC || else if (ASE_LSP_TYPE(car) == ASE_LSP_OBJ_FUNC ||
ASE_LSP_TYPE(car) == ASE_LSP_OBJ_MACRO) { ASE_LSP_TYPE(car) == ASE_LSP_OBJ_MACRO)
{
return apply (lsp, car, cdr); return apply (lsp, car, cdr);
} }
else if (ASE_LSP_TYPE(car) == ASE_LSP_OBJ_CONS) { else if (ASE_LSP_TYPE(car) == ASE_LSP_OBJ_CONS)
if (ASE_LSP_CAR(car) == lsp->mem->lambda) { {
/* anonymous function or macros
* ((lambda (x) (+ x 10)) 50) */
if (ASE_LSP_CAR(car) == lsp->mem->lambda)
{
ase_lsp_obj_t* func = make_func (lsp, ASE_LSP_CDR(car), 0); ase_lsp_obj_t* func = make_func (lsp, ASE_LSP_CDR(car), 0);
if (func == ASE_NULL) return ASE_NULL; if (func == ASE_NULL) return ASE_NULL;
return apply (lsp, func, cdr); return apply (lsp, func, cdr);
} }
else if (ASE_LSP_CAR(car) == lsp->mem->macro) { else if (ASE_LSP_CAR(car) == lsp->mem->macro)
{
ase_lsp_obj_t* func = make_func (lsp, ASE_LSP_CDR(car), 1); ase_lsp_obj_t* func = make_func (lsp, ASE_LSP_CDR(car), 1);
if (func == ASE_NULL) return ASE_NULL; if (func == ASE_NULL) return ASE_NULL;
return apply (lsp, func, cdr); return apply (lsp, func, cdr);
@ -292,7 +311,7 @@ static ase_lsp_obj_t* apply (
/* destroy the frame. */ /* destroy the frame. */
ase_lsp_freeframe (lsp, frame); ase_lsp_freeframe (lsp, frame);
//if (ASE_LSP_CAR(func) == mem->macro) { /*if (ASE_LSP_CAR(func) == mem->macro) {*/
if (ASE_LSP_TYPE(func) == ASE_LSP_OBJ_MACRO) if (ASE_LSP_TYPE(func) == ASE_LSP_OBJ_MACRO)
{ {
value = ase_lsp_eval(lsp, value); value = ase_lsp_eval(lsp, value);

66
ase/lsp/lsp.c
View File

@ -1,5 +1,5 @@
/* /*
* $Id: lsp.c,v 1.12 2006-10-28 16:24:40 bacon Exp $ * $Id: lsp.c,v 1.13 2006-10-29 13:00:39 bacon Exp $
*/ */
#if defined(__BORLANDC__) #if defined(__BORLANDC__)
@ -26,7 +26,7 @@ ase_lsp_t* ase_lsp_open (
if (syscas->is_upper == ASE_NULL || if (syscas->is_upper == ASE_NULL ||
syscas->is_lower == ASE_NULL || syscas->is_lower == ASE_NULL ||
syscas->is_alpha == ASE_NULL || syscas->is_alpha == ASE_NULL ||
syscas->is_digit == ASE_NULL || syscas->is_digit == ASE_NULL ||
syscas->is_xdigit == ASE_NULL || syscas->is_xdigit == ASE_NULL ||
syscas->is_alnum == ASE_NULL || syscas->is_alnum == ASE_NULL ||
syscas->is_space == ASE_NULL || syscas->is_space == ASE_NULL ||
@ -171,42 +171,42 @@ int ase_lsp_detach_output (ase_lsp_t* lsp)
static int __add_builtin_prims (ase_lsp_t* lsp) static int __add_builtin_prims (ase_lsp_t* lsp)
{ {
#define ADD_PRIM(mem,name,prim) \ #define ADD_PRIM(mem,name,name_len,pimpl,min_args,max_args) \
if (ase_lsp_add_prim(mem,name,prim) == -1) return -1; if (ase_lsp_addprim(mem,name,name_len,pimpl,min_args,max_args) == -1) return -1;
ADD_PRIM (lsp, ASE_T("abort"), ase_lsp_prim_abort); ADD_PRIM (lsp, ASE_T("abort"), 5, ase_lsp_prim_abort, 0, 0);
ADD_PRIM (lsp, ASE_T("eval"), ase_lsp_prim_eval); ADD_PRIM (lsp, ASE_T("eval"), 4, ase_lsp_prim_eval, 1, 1);
ADD_PRIM (lsp, ASE_T("prog1"), ase_lsp_prim_prog1); ADD_PRIM (lsp, ASE_T("prog1"), 5, ase_lsp_prim_prog1, 1, ASE_TYPE_MAX(ase_size_t));
ADD_PRIM (lsp, ASE_T("progn"), ase_lsp_prim_progn); ADD_PRIM (lsp, ASE_T("progn"), 5, ase_lsp_prim_progn, 1, ASE_TYPE_MAX(ase_size_t));
ADD_PRIM (lsp, ASE_T("gc"), ase_lsp_prim_gc); ADD_PRIM (lsp, ASE_T("gc"), 2, ase_lsp_prim_gc, 0, 0);
ADD_PRIM (lsp, ASE_T("cond"), ase_lsp_prim_cond); ADD_PRIM (lsp, ASE_T("cond"), 4, ase_lsp_prim_cond, 0, ASE_TYPE_MAX(ase_size_t));
ADD_PRIM (lsp, ASE_T("if"), ase_lsp_prim_if); ADD_PRIM (lsp, ASE_T("if"), 2, ase_lsp_prim_if, 2, ASE_TYPE_MAX(ase_size_t));
ADD_PRIM (lsp, ASE_T("while"), ase_lsp_prim_while); ADD_PRIM (lsp, ASE_T("while"), 5, ase_lsp_prim_while, 1, ASE_TYPE_MAX(ase_size_t));
ADD_PRIM (lsp, ASE_T("car"), ase_lsp_prim_car); ADD_PRIM (lsp, ASE_T("car"), 3, ase_lsp_prim_car, 1, 1);
ADD_PRIM (lsp, ASE_T("cdr"), ase_lsp_prim_cdr); ADD_PRIM (lsp, ASE_T("cdr"), 3, ase_lsp_prim_cdr, 1, 1);
ADD_PRIM (lsp, ASE_T("cons"), ase_lsp_prim_cons); ADD_PRIM (lsp, ASE_T("cons"), 4, ase_lsp_prim_cons, 2, 2);
ADD_PRIM (lsp, ASE_T("set"), ase_lsp_prim_set); ADD_PRIM (lsp, ASE_T("set"), 3, ase_lsp_prim_set, 2, 2);
ADD_PRIM (lsp, ASE_T("setq"), ase_lsp_prim_setq); ADD_PRIM (lsp, ASE_T("setq"), 4, ase_lsp_prim_setq, 1, ASE_TYPE_MAX(ase_size_t));
ADD_PRIM (lsp, ASE_T("quote"), ase_lsp_prim_quote); ADD_PRIM (lsp, ASE_T("quote"), 5, ase_lsp_prim_quote, 1, 1);
ADD_PRIM (lsp, ASE_T("defun"), ase_lsp_prim_defun); ADD_PRIM (lsp, ASE_T("defun"), 5, ase_lsp_prim_defun, 3, ASE_TYPE_MAX(ase_size_t));
ADD_PRIM (lsp, ASE_T("demac"), ase_lsp_prim_demac); ADD_PRIM (lsp, ASE_T("demac"), 5, ase_lsp_prim_demac, 3, ASE_TYPE_MAX(ase_size_t));
ADD_PRIM (lsp, ASE_T("let"), ase_lsp_prim_let); ADD_PRIM (lsp, ASE_T("let"), 3, ase_lsp_prim_let, 1, ASE_TYPE_MAX(ase_size_t));
ADD_PRIM (lsp, ASE_T("let*"), ase_lsp_prim_letx); ADD_PRIM (lsp, ASE_T("let*"), 4, ase_lsp_prim_letx, 1, ASE_TYPE_MAX(ase_size_t));
ADD_PRIM (lsp, ASE_T("="), ase_lsp_prim_eq); ADD_PRIM (lsp, ASE_T("="), 1, ase_lsp_prim_eq, 2, 2);
ADD_PRIM (lsp, ASE_T("/="), ase_lsp_prim_ne); ADD_PRIM (lsp, ASE_T("/="), 2, ase_lsp_prim_ne, 2, 2);
ADD_PRIM (lsp, ASE_T(">"), ase_lsp_prim_gt); ADD_PRIM (lsp, ASE_T(">"), 1, ase_lsp_prim_gt, 2, 2);
ADD_PRIM (lsp, ASE_T("<"), ase_lsp_prim_lt); ADD_PRIM (lsp, ASE_T("<"), 1, ase_lsp_prim_lt, 2, 2);
ADD_PRIM (lsp, ASE_T(">="), ase_lsp_prim_ge); ADD_PRIM (lsp, ASE_T(">="), 2, ase_lsp_prim_ge, 2, 2);
ADD_PRIM (lsp, ASE_T("<="), ase_lsp_prim_le); ADD_PRIM (lsp, ASE_T("<="), 2, ase_lsp_prim_le, 2, 2);
ADD_PRIM (lsp, ASE_T("+"), ase_lsp_prim_plus); ADD_PRIM (lsp, ASE_T("+"), 1, ase_lsp_prim_plus,, 1, ASE_TYPE_MAX(ase_size_t));
ADD_PRIM (lsp, ASE_T("-"), ase_lsp_prim_minus); ADD_PRIM (lsp, ASE_T("-"), 1, ase_lsp_prim_minus, 1, ASE_TYPE_MAX(ase_size_t));
ADD_PRIM (lsp, ASE_T("*"), ase_lsp_prim_multiply); ADD_PRIM (lsp, ASE_T("*"), 1, ase_lsp_prim_mul, 1, ASE_TYPE_MAX(ase_size_t));
ADD_PRIM (lsp, ASE_T("/"), ase_lsp_prim_divide); ADD_PRIM (lsp, ASE_T("/"), 1, ase_lsp_prim_div, 1, ASE_TYPE_MAX(ase_size_t));
ADD_PRIM (lsp, ASE_T("%"), ase_lsp_prim_modulus); ADD_PRIM (lsp, ASE_T("%"), 1, ase_lsp_prim_mod , 1, ASE_TYPE_MAX(ase_size_t));
return 0; return 0;
} }

4
ase/lsp/lsp.dsp
View File

@ -42,7 +42,7 @@ RSC=rc.exe
# PROP Target_Dir "" # PROP Target_Dir ""
MTL=midl.exe MTL=midl.exe
# ADD BASE CPP /nologo /W3 /GX /O2 /D "WIN32" /D "NDEBUG" /D "_MBCS" /D "_LIB" /YX /FD /c # ADD BASE CPP /nologo /W3 /GX /O2 /D "WIN32" /D "NDEBUG" /D "_MBCS" /D "_LIB" /YX /FD /c
# ADD CPP /nologo /MT /W3 /GX /O2 /I "../.." /D "WIN32" /D "NDEBUG" /D "_MBCS" /D "_LIB" /YX /FD /c # ADD CPP /nologo /MT /W3 /GX /O2 /I "../.." /D "NDEBUG" /D "WIN32" /D "_UNICODE" /YX /FD /c
# ADD BASE RSC /l 0x409 /d "NDEBUG" # ADD BASE RSC /l 0x409 /d "NDEBUG"
# ADD RSC /l 0x409 /d "NDEBUG" # ADD RSC /l 0x409 /d "NDEBUG"
BSC32=bscmake.exe BSC32=bscmake.exe
@ -66,7 +66,7 @@ LIB32=link.exe -lib
# PROP Target_Dir "" # PROP Target_Dir ""
MTL=midl.exe MTL=midl.exe
# ADD BASE CPP /nologo /W3 /Gm /GX /ZI /Od /D "WIN32" /D "_DEBUG" /D "_MBCS" /D "_LIB" /YX /FD /GZ /c # ADD BASE CPP /nologo /W3 /Gm /GX /ZI /Od /D "WIN32" /D "_DEBUG" /D "_MBCS" /D "_LIB" /YX /FD /GZ /c
# ADD CPP /nologo /MTd /W3 /Gm /GX /ZI /Od /I "../.." /D "WIN32" /D "_DEBUG" /D "_MBCS" /D "_LIB" /YX /FD /GZ /c # ADD CPP /nologo /MTd /W3 /Gm /GX /ZI /Od /I "../.." /D "_DEBUG" /D "WIN32" /D "_UNICODE" /YX /FD /GZ /c
# ADD BASE RSC /l 0x409 /d "_DEBUG" # ADD BASE RSC /l 0x409 /d "_DEBUG"
# ADD RSC /l 0x409 /d "_DEBUG" # ADD RSC /l 0x409 /d "_DEBUG"
BSC32=bscmake.exe BSC32=bscmake.exe

8
ase/lsp/lsp.h
View File

@ -1,5 +1,5 @@
/* /*
* $Id: lsp.h,v 1.28 2006-10-28 16:08:34 bacon Exp $ * $Id: lsp.h,v 1.29 2006-10-29 13:00:39 bacon Exp $
*/ */
#ifndef _ASE_LSP_LSP_H_ #ifndef _ASE_LSP_LSP_H_
@ -124,8 +124,10 @@ ase_lsp_obj_t* ase_lsp_read (ase_lsp_t* lsp);
ase_lsp_obj_t* ase_lsp_eval (ase_lsp_t* lsp, ase_lsp_obj_t* obj); ase_lsp_obj_t* ase_lsp_eval (ase_lsp_t* lsp, ase_lsp_obj_t* obj);
int ase_lsp_print (ase_lsp_t* lsp, const ase_lsp_obj_t* obj); int ase_lsp_print (ase_lsp_t* lsp, const ase_lsp_obj_t* obj);
int ase_lsp_add_prim (ase_lsp_t* lsp, const ase_char_t* name, ase_lsp_prim_t prim); int ase_lsp_addprim (
int ase_lsp_remove_prim (ase_lsp_t* lsp, const ase_char_t* name); ase_lsp_t* lsp, const ase_char_t* name, ase_size_t name_len,
ase_lsp_prim_t prim, ase_size_t min_args, ase_size_t max_args);
int ase_lsp_removeprim (ase_lsp_t* lsp, const ase_char_t* name);
/* string functions exported by lsp.h */ /* string functions exported by lsp.h */
ase_char_t* ase_lsp_strdup (ase_lsp_t* lsp, const ase_char_t* str); ase_char_t* ase_lsp_strdup (ase_lsp_t* lsp, const ase_char_t* str);

6
ase/lsp/lsp_i.h
View File

@ -1,5 +1,5 @@
/* /*
* $Id: lsp_i.h,v 1.3 2006-10-26 09:31:28 bacon Exp $ * $Id: lsp_i.h,v 1.4 2006-10-29 13:00:39 bacon Exp $
*/ */
#ifndef _ASE_LSP_LSPI_H_ #ifndef _ASE_LSP_LSPI_H_
@ -63,8 +63,8 @@ struct ase_lsp_t
struct struct
{ {
int type; int type;
ase_long_t ivalue; ase_long_t ival;
ase_real_t rvalue; ase_real_t rval;
ase_lsp_name_t name; ase_lsp_name_t name;
} token; } token;

61
ase/lsp/mem.c
View File

@ -1,5 +1,5 @@
/* /*
* $Id: mem.c,v 1.16 2006-10-26 09:31:28 bacon Exp $ * $Id: mem.c,v 1.17 2006-10-29 13:00:39 bacon Exp $
*/ */
#include <ase/lsp/lsp_i.h> #include <ase/lsp/lsp_i.h>
@ -95,17 +95,18 @@ void ase_lsp_closemem (ase_lsp_mem_t* mem)
ASE_LSP_FREE (mem->lsp, mem); ASE_LSP_FREE (mem->lsp, mem);
} }
static int __add_prim (ase_lsp_mem_t* mem, static int __add_prim (
const ase_char_t* name, ase_size_t len, ase_lsp_prim_t prim) ase_lsp_mem_t* mem, const ase_char_t* name, ase_size_t name_len,
ase_lsp_prim_t pimpl, ase_size_t min_args, ase_size_t max_args)
{ {
ase_lsp_obj_t* n, * p; ase_lsp_obj_t* n, * p;
n = ase_lsp_makesymobj (mem, name, len); n = ase_lsp_makesymobj (mem, name, name_len);
if (n == ASE_NULL) return -1; if (n == ASE_NULL) return -1;
ase_lsp_lockobj (mem->lsp, n); ase_lsp_lockobj (mem->lsp, n);
p = ase_lsp_makeprim (mem, prim); p = ase_lsp_makeprim (mem, pimpl, min_args, max_args);
if (p == ASE_NULL) return -1; if (p == ASE_NULL) return -1;
ase_lsp_unlockobj (mem->lsp, n); ase_lsp_unlockobj (mem->lsp, n);
@ -115,44 +116,6 @@ static int __add_prim (ase_lsp_mem_t* mem,
return 0; return 0;
} }
int ase_lsp_add_builtin_prims (ase_lsp_mem_t* mem)
{
#define ADD_PRIM(mem,name,len,prim) \
if (__add_prim(mem,name,len,prim) == -1) return -1;
ADD_PRIM (mem, ASE_T("abort"), 5, ase_lsp_prim_abort);
ADD_PRIM (mem, ASE_T("eval"), 4, ase_lsp_prim_eval);
ADD_PRIM (mem, ASE_T("prog1"), 5, ase_lsp_prim_prog1);
ADD_PRIM (mem, ASE_T("progn"), 5, ase_lsp_prim_progn);
ADD_PRIM (mem, ASE_T("gc"), 2, ase_lsp_prim_gc);
ADD_PRIM (mem, ASE_T("cond"), 4, ase_lsp_prim_cond);
ADD_PRIM (mem, ASE_T("if"), 2, ase_lsp_prim_if);
ADD_PRIM (mem, ASE_T("while"), 5, ase_lsp_prim_while);
ADD_PRIM (mem, ASE_T("car"), 3, ase_lsp_prim_car);
ADD_PRIM (mem, ASE_T("cdr"), 3, ase_lsp_prim_cdr);
ADD_PRIM (mem, ASE_T("cons"), 4, ase_lsp_prim_cons);
ADD_PRIM (mem, ASE_T("set"), 3, ase_lsp_prim_set);
ADD_PRIM (mem, ASE_T("setq"), 4, ase_lsp_prim_setq);
ADD_PRIM (mem, ASE_T("quote"), 5, ase_lsp_prim_quote);
ADD_PRIM (mem, ASE_T("defun"), 5, ase_lsp_prim_defun);
ADD_PRIM (mem, ASE_T("demac"), 5, ase_lsp_prim_demac);
ADD_PRIM (mem, ASE_T("let"), 3, ase_lsp_prim_let);
ADD_PRIM (mem, ASE_T("let*"), 4, ase_lsp_prim_letx);
ADD_PRIM (mem, ASE_T(">"), 1, ase_lsp_prim_gt);
ADD_PRIM (mem, ASE_T("<"), 1, ase_lsp_prim_lt);
ADD_PRIM (mem, ASE_T("+"), 1, ase_lsp_prim_plus);
ADD_PRIM (mem, ASE_T("-"), 1, ase_lsp_prim_minus);
return 0;
}
ase_lsp_obj_t* ase_lsp_alloc (ase_lsp_mem_t* mem, int type, ase_size_t size) ase_lsp_obj_t* ase_lsp_alloc (ase_lsp_mem_t* mem, int type, ase_size_t size)
{ {
ase_lsp_obj_t* obj; ase_lsp_obj_t* obj;
@ -541,7 +504,8 @@ ase_lsp_obj_t* ase_lsp_makemacro (
return obj; return obj;
} }
ase_lsp_obj_t* ase_lsp_makeprim (ase_lsp_mem_t* mem, void* impl) ase_lsp_obj_t* ase_lsp_makeprim (ase_lsp_mem_t* mem,
ase_lsp_prim_t impl, ase_size_t min_args, ase_size_t max_args)
{ {
ase_lsp_obj_t* obj; ase_lsp_obj_t* obj;
@ -549,8 +513,9 @@ ase_lsp_obj_t* ase_lsp_makeprim (ase_lsp_mem_t* mem, void* impl)
mem, ASE_LSP_OBJ_PRIM, ase_sizeof(ase_lsp_obj_prim_t)); mem, ASE_LSP_OBJ_PRIM, ase_sizeof(ase_lsp_obj_prim_t));
if (obj == ASE_NULL) return ASE_NULL; if (obj == ASE_NULL) return ASE_NULL;
/*ASE_LSP_PRIM(obj) = (ase_lsp_prim_t)impl;*/ ASE_LSP_PIMPL(obj) = impl;
((ase_lsp_obj_prim_t*)obj)->impl = impl; ASE_LSP_PMINARGS(obj) = min_args;
ASE_LSP_PMAXARGS(obj) = max_args;
return obj; return obj;
} }
@ -607,7 +572,7 @@ ase_lsp_assoc_t* ase_lsp_setfunc (
return assoc; return assoc;
} }
ase_size_t ase_lsp_cons_len (ase_lsp_mem_t* mem, ase_lsp_obj_t* obj) ase_size_t ase_lsp_conslen (ase_lsp_mem_t* mem, ase_lsp_obj_t* obj)
{ {
ase_size_t count; ase_size_t count;
@ -615,7 +580,7 @@ ase_size_t ase_lsp_cons_len (ase_lsp_mem_t* mem, ase_lsp_obj_t* obj)
obj == mem->nil || ASE_LSP_TYPE(obj) == ASE_LSP_OBJ_CONS); obj == mem->nil || ASE_LSP_TYPE(obj) == ASE_LSP_OBJ_CONS);
count = 0; count = 0;
//while (obj != mem->nil) { /*while (obj != mem->nil) {*/
while (ASE_LSP_TYPE(obj) == ASE_LSP_OBJ_CONS) while (ASE_LSP_TYPE(obj) == ASE_LSP_OBJ_CONS)
{ {
count++; count++;

9
ase/lsp/mem.h
View File

@ -1,5 +1,5 @@
/* /*
* $Id: mem.h,v 1.12 2006-10-26 08:17:37 bacon Exp $ * $Id: mem.h,v 1.13 2006-10-29 13:00:39 bacon Exp $
*/ */
#ifndef _ASE_LSP_MEM_H_ #ifndef _ASE_LSP_MEM_H_
@ -58,8 +58,6 @@ ase_lsp_mem_t* ase_lsp_openmem (
ase_lsp_t* lsp, ase_size_t ubound, ase_size_t ubound_inc); ase_lsp_t* lsp, ase_size_t ubound, ase_size_t ubound_inc);
void ase_lsp_closemem (ase_lsp_mem_t* mem); void ase_lsp_closemem (ase_lsp_mem_t* mem);
int ase_lsp_add_builtin_prims (ase_lsp_mem_t* mem);
ase_lsp_obj_t* ase_lsp_alloc (ase_lsp_mem_t* mem, int type, ase_size_t size); ase_lsp_obj_t* ase_lsp_alloc (ase_lsp_mem_t* mem, int type, ase_size_t size);
void ase_lsp_dispose (ase_lsp_mem_t* mem, ase_lsp_obj_t* prev, ase_lsp_obj_t* obj); void ase_lsp_dispose (ase_lsp_mem_t* mem, ase_lsp_obj_t* prev, ase_lsp_obj_t* obj);
void ase_lsp_dispose_all (ase_lsp_mem_t* mem); void ase_lsp_dispose_all (ase_lsp_mem_t* mem);
@ -87,7 +85,8 @@ ase_lsp_obj_t* ase_lsp_makefunc (
ase_lsp_obj_t* ase_lsp_makemacro ( ase_lsp_obj_t* ase_lsp_makemacro (
ase_lsp_mem_t* mem, ase_lsp_obj_t* formal, ase_lsp_obj_t* body); ase_lsp_mem_t* mem, ase_lsp_obj_t* formal, ase_lsp_obj_t* body);
ase_lsp_obj_t* ase_lsp_makeprim (ase_lsp_mem_t* mem, void* impl); ase_lsp_obj_t* ase_lsp_makeprim (ase_lsp_mem_t* mem,
ase_lsp_prim_t impl, ase_size_t min_args, ase_size_t max_args);
// frame lookup // frame lookup
ase_lsp_assoc_t* ase_lsp_lookup (ase_lsp_mem_t* mem, ase_lsp_obj_t* name); ase_lsp_assoc_t* ase_lsp_lookup (ase_lsp_mem_t* mem, ase_lsp_obj_t* name);
@ -97,7 +96,7 @@ ase_lsp_assoc_t* ase_lsp_setfunc (
ase_lsp_mem_t* mem, ase_lsp_obj_t* name, ase_lsp_obj_t* func); ase_lsp_mem_t* mem, ase_lsp_obj_t* name, ase_lsp_obj_t* func);
// cons operations // cons operations
ase_size_t ase_lsp_cons_len (ase_lsp_mem_t* mem, ase_lsp_obj_t* obj); ase_size_t ase_lsp_conslen (ase_lsp_mem_t* mem, ase_lsp_obj_t* obj);
int ase_lsp_probeargs (ase_lsp_mem_t* mem, ase_lsp_obj_t* obj, ase_size_t* len); int ase_lsp_probeargs (ase_lsp_mem_t* mem, ase_lsp_obj_t* obj, ase_size_t* len);
#ifdef __cplusplus #ifdef __cplusplus

5
ase/lsp/name.c
View File

@ -1,5 +1,5 @@
/* /*
* $Id: name.c,v 1.9 2006-10-26 09:31:28 bacon Exp $ * $Id: name.c,v 1.10 2006-10-29 13:00:39 bacon Exp $
*/ */
#include <ase/lsp/lsp_i.h> #include <ase/lsp/lsp_i.h>
@ -7,8 +7,7 @@
ase_lsp_name_t* ase_lsp_name_open ( ase_lsp_name_t* ase_lsp_name_open (
ase_lsp_name_t* name, ase_size_t capa, ase_lsp_t* lsp) ase_lsp_name_t* name, ase_size_t capa, ase_lsp_t* lsp)
{ {
if (capa == 0) if (capa == 0) capa = ase_countof(name->static_buf) - 1;
capa = ase_countof(name->static_buf) - 1;
if (name == ASE_NULL) if (name == ASE_NULL)
{ {

10
ase/lsp/obj.h
View File

@ -1,5 +1,5 @@
/* /*
* $Id: obj.h,v 1.10 2006-10-26 09:25:03 bacon Exp $ * $Id: obj.h,v 1.11 2006-10-29 13:00:39 bacon Exp $
*/ */
#ifndef _ASE_LSP_OBJ_H_ #ifndef _ASE_LSP_OBJ_H_
@ -116,7 +116,9 @@ struct ase_lsp_obj_macro_t
struct ase_lsp_obj_prim_t struct ase_lsp_obj_prim_t
{ {
ase_lsp_objhdr_t hdr; ase_lsp_objhdr_t hdr;
void* impl; /* ase_lsp_prim_t */ ase_lsp_prim_t impl;
ase_size_t min_args;
ase_size_t max_args;
}; };
/* header access */ /* header access */
@ -150,6 +152,8 @@ struct ase_lsp_obj_prim_t
#define ASE_LSP_FBODY(x) (((ase_lsp_obj_func_t*)x)->body) #define ASE_LSP_FBODY(x) (((ase_lsp_obj_func_t*)x)->body)
#define ASE_LSP_MFORMAL(x) (((ase_lsp_obj_macro_t*)x)->formal) #define ASE_LSP_MFORMAL(x) (((ase_lsp_obj_macro_t*)x)->formal)
#define ASE_LSP_MBODY(x) (((ase_lsp_obj_macro_t*)x)->body) #define ASE_LSP_MBODY(x) (((ase_lsp_obj_macro_t*)x)->body)
#define ASE_LSP_PRIM(x) ((ase_lsp_prim_t)(((ase_lsp_obj_prim_t*)x)->impl)) #define ASE_LSP_PIMPL(x) (((ase_lsp_obj_prim_t*)x)->impl)
#define ASE_LSP_PMINARGS(x) (((ase_lsp_obj_prim_t*)x)->min_args)
#define ASE_LSP_PMAXARGS(x) (((ase_lsp_obj_prim_t*)x)->max_args)
#endif #endif

78
ase/lsp/prim.c
View File

@ -1,35 +1,38 @@
/* /*
* $Id: prim.c,v 1.13 2006-10-26 09:31:28 bacon Exp $ * $Id: prim.c,v 1.14 2006-10-29 13:00:39 bacon Exp $
*/ */
#include <ase/lsp/lsp_i.h> #include <ase/lsp/lsp_i.h>
static int __add_prim (ase_lsp_mem_t* mem, static int __add_prim (ase_lsp_mem_t* mem,
const ase_char_t* name, ase_size_t len, ase_lsp_prim_t prim); const ase_char_t* name, ase_size_t len,
ase_lsp_prim_t pimpl, ase_size_t min_args, ase_size_t max_args);
int ase_lsp_add_prim ( int ase_lsp_addprim (
ase_lsp_t* lsp, const ase_char_t* name, ase_lsp_prim_t prim) ase_lsp_t* lsp, const ase_char_t* name, ase_size_t name_len,
ase_lsp_prim_t prim, ase_size_t min_args, ase_size_t max_args)
{ {
return __add_prim (lsp->mem, name, ase_lsp_strlen(name), prim); return __add_prim (lsp->mem, name, name_len, prim, min_args, max_args);
} }
int ase_lsp_remove_prim (ase_lsp_t* lsp, const ase_char_t* name) int ase_lsp_removeprim (ase_lsp_t* lsp, const ase_char_t* name)
{ {
// TODO: // TODO:
return -1; return -1;
} }
static int __add_prim (ase_lsp_mem_t* mem, static int __add_prim (ase_lsp_mem_t* mem,
const ase_char_t* name, ase_size_t len, ase_lsp_prim_t prim) const ase_char_t* name, ase_size_t name_len,
ase_lsp_prim_t pimpl, ase_size_t min_args, ase_size_t max_args)
{ {
ase_lsp_obj_t* n, * p; ase_lsp_obj_t* n, * p;
n = ase_lsp_makesymobj (mem, name, len); n = ase_lsp_makesymobj (mem, name, name_len);
if (n == ASE_NULL) return -1; if (n == ASE_NULL) return -1;
ase_lsp_lockobj (mem->lsp, n); ase_lsp_lockobj (mem->lsp, n);
p = ase_lsp_makeprim (mem, prim); p = ase_lsp_makeprim (mem, pimpl, min_args, max_args);
if (p == ASE_NULL) return -1; if (p == ASE_NULL) return -1;
ase_lsp_unlockobj (mem->lsp, n); ase_lsp_unlockobj (mem->lsp, n);
@ -83,8 +86,10 @@ ase_lsp_obj_t* ase_lsp_prim_cond (ase_lsp_t* lsp, ase_lsp_obj_t* args)
ASE_LSP_PRIM_CHECK_ARG_COUNT (lsp, args, 0, ASE_LSP_PRIM_MAX_ARG_COUNT); ASE_LSP_PRIM_CHECK_ARG_COUNT (lsp, args, 0, ASE_LSP_PRIM_MAX_ARG_COUNT);
while (ASE_LSP_TYPE(args) == ASE_LSP_OBJ_CONS) { while (ASE_LSP_TYPE(args) == ASE_LSP_OBJ_CONS)
if (ASE_LSP_TYPE(ASE_LSP_CAR(args)) != ASE_LSP_OBJ_CONS) { {
if (ASE_LSP_TYPE(ASE_LSP_CAR(args)) != ASE_LSP_OBJ_CONS)
{
lsp->errnum = ASE_LSP_ERR_BAD_ARG; lsp->errnum = ASE_LSP_ERR_BAD_ARG;
return ASE_NULL; return ASE_NULL;
} }
@ -92,15 +97,18 @@ ase_lsp_obj_t* ase_lsp_prim_cond (ase_lsp_t* lsp, ase_lsp_obj_t* args)
tmp = ase_lsp_eval (lsp, ASE_LSP_CAR(ASE_LSP_CAR(args))); tmp = ase_lsp_eval (lsp, ASE_LSP_CAR(ASE_LSP_CAR(args)));
if (tmp == ASE_NULL) return ASE_NULL; if (tmp == ASE_NULL) return ASE_NULL;
if (tmp != lsp->mem->nil) { if (tmp != lsp->mem->nil)
{
tmp = ASE_LSP_CDR(ASE_LSP_CAR(args)); tmp = ASE_LSP_CDR(ASE_LSP_CAR(args));
ret = lsp->mem->nil; ret = lsp->mem->nil;
while (ASE_LSP_TYPE(tmp) == ASE_LSP_OBJ_CONS) { while (ASE_LSP_TYPE(tmp) == ASE_LSP_OBJ_CONS)
{
ret = ase_lsp_eval (lsp, ASE_LSP_CAR(tmp)); ret = ase_lsp_eval (lsp, ASE_LSP_CAR(tmp));
if (ret == ASE_NULL) return ASE_NULL; if (ret == ASE_NULL) return ASE_NULL;
tmp = ASE_LSP_CDR(tmp); tmp = ASE_LSP_CDR(tmp);
} }
if (tmp != lsp->mem->nil) { if (tmp != lsp->mem->nil)
{
lsp->errnum = ASE_LSP_ERR_BAD_ARG; lsp->errnum = ASE_LSP_ERR_BAD_ARG;
return ASE_NULL; return ASE_NULL;
} }
@ -123,22 +131,26 @@ ase_lsp_obj_t* ase_lsp_prim_if (ase_lsp_t* lsp, ase_lsp_obj_t* args)
tmp = ase_lsp_eval (lsp, ASE_LSP_CAR(args)); tmp = ase_lsp_eval (lsp, ASE_LSP_CAR(args));
if (tmp == ASE_NULL) return ASE_NULL; if (tmp == ASE_NULL) return ASE_NULL;
if (tmp != lsp->mem->nil) { if (tmp != lsp->mem->nil)
{
tmp = ase_lsp_eval (lsp, ASE_LSP_CAR(ASE_LSP_CDR(args))); tmp = ase_lsp_eval (lsp, ASE_LSP_CAR(ASE_LSP_CDR(args)));
if (tmp == ASE_NULL) return ASE_NULL; if (tmp == ASE_NULL) return ASE_NULL;
return tmp; return tmp;
} }
else { else
{
ase_lsp_obj_t* res = lsp->mem->nil; ase_lsp_obj_t* res = lsp->mem->nil;
tmp = ASE_LSP_CDR(ASE_LSP_CDR(args)); tmp = ASE_LSP_CDR(ASE_LSP_CDR(args));
while (ASE_LSP_TYPE(tmp) == ASE_LSP_OBJ_CONS) { while (ASE_LSP_TYPE(tmp) == ASE_LSP_OBJ_CONS)
{
res = ase_lsp_eval (lsp, ASE_LSP_CAR(tmp)); res = ase_lsp_eval (lsp, ASE_LSP_CAR(tmp));
if (res == ASE_NULL) return ASE_NULL; if (res == ASE_NULL) return ASE_NULL;
tmp = ASE_LSP_CDR(tmp); tmp = ASE_LSP_CDR(tmp);
} }
if (tmp != lsp->mem->nil) { if (tmp != lsp->mem->nil)
{
lsp->errnum = ASE_LSP_ERR_BAD_ARG; lsp->errnum = ASE_LSP_ERR_BAD_ARG;
return ASE_NULL; return ASE_NULL;
} }
@ -165,13 +177,15 @@ ase_lsp_obj_t* ase_lsp_prim_while (ase_lsp_t* lsp, ase_lsp_obj_t* args)
if (tmp == lsp->mem->nil) break; if (tmp == lsp->mem->nil) break;
tmp = ASE_LSP_CDR(args); tmp = ASE_LSP_CDR(args);
while (ASE_LSP_TYPE(tmp) == ASE_LSP_OBJ_CONS) { while (ASE_LSP_TYPE(tmp) == ASE_LSP_OBJ_CONS)
{
if (ase_lsp_eval(lsp, ASE_LSP_CAR(tmp)) == ASE_NULL) if (ase_lsp_eval(lsp, ASE_LSP_CAR(tmp)) == ASE_NULL)
return ASE_NULL; return ASE_NULL;
tmp = ASE_LSP_CDR(tmp); tmp = ASE_LSP_CDR(tmp);
} }
if (tmp != lsp->mem->nil) { if (tmp != lsp->mem->nil)
{
lsp->errnum = ASE_LSP_ERR_BAD_ARG; lsp->errnum = ASE_LSP_ERR_BAD_ARG;
return ASE_NULL; return ASE_NULL;
} }
@ -195,7 +209,8 @@ ase_lsp_obj_t* ase_lsp_prim_car (ase_lsp_t* lsp, ase_lsp_obj_t* args)
if (tmp == ASE_NULL) return ASE_NULL; if (tmp == ASE_NULL) return ASE_NULL;
if (tmp == lsp->mem->nil) return lsp->mem->nil; if (tmp == lsp->mem->nil) return lsp->mem->nil;
if (ASE_LSP_TYPE(tmp) != ASE_LSP_OBJ_CONS) { if (ASE_LSP_TYPE(tmp) != ASE_LSP_OBJ_CONS)
{
lsp->errnum = ASE_LSP_ERR_BAD_ARG; lsp->errnum = ASE_LSP_ERR_BAD_ARG;
return ASE_NULL; return ASE_NULL;
} }
@ -218,7 +233,8 @@ ase_lsp_obj_t* ase_lsp_prim_cdr (ase_lsp_t* lsp, ase_lsp_obj_t* args)
if (tmp == ASE_NULL) return ASE_NULL; if (tmp == ASE_NULL) return ASE_NULL;
if (tmp == lsp->mem->nil) return lsp->mem->nil; if (tmp == lsp->mem->nil) return lsp->mem->nil;
if (ASE_LSP_TYPE(tmp) != ASE_LSP_OBJ_CONS) { if (ASE_LSP_TYPE(tmp) != ASE_LSP_OBJ_CONS)
{
lsp->errnum = ASE_LSP_ERR_BAD_ARG; lsp->errnum = ASE_LSP_ERR_BAD_ARG;
return ASE_NULL; return ASE_NULL;
} }
@ -270,7 +286,8 @@ ase_lsp_obj_t* ase_lsp_prim_set (ase_lsp_t* lsp, ase_lsp_obj_t* args)
p1 = ase_lsp_eval (lsp, ASE_LSP_CAR(args)); p1 = ase_lsp_eval (lsp, ASE_LSP_CAR(args));
if (p1 == ASE_NULL) return ASE_NULL; if (p1 == ASE_NULL) return ASE_NULL;
if (ASE_LSP_TYPE(p1) != ASE_LSP_OBJ_SYM) { if (ASE_LSP_TYPE(p1) != ASE_LSP_OBJ_SYM)
{
lsp->errnum = ASE_LSP_ERR_BAD_ARG; lsp->errnum = ASE_LSP_ERR_BAD_ARG;
return ASE_NULL; return ASE_NULL;
} }
@ -278,7 +295,8 @@ ase_lsp_obj_t* ase_lsp_prim_set (ase_lsp_t* lsp, ase_lsp_obj_t* args)
p2 = ase_lsp_eval (lsp, ASE_LSP_CAR(ASE_LSP_CDR(args))); p2 = ase_lsp_eval (lsp, ASE_LSP_CAR(ASE_LSP_CDR(args)));
if (p2 == ASE_NULL) return ASE_NULL; if (p2 == ASE_NULL) return ASE_NULL;
if (ase_lsp_setvalue (lsp->mem, p1, p2) == ASE_NULL) { if (ase_lsp_setvalue (lsp->mem, p1, p2) == ASE_NULL)
{
lsp->errnum = ASE_LSP_ENOMEM; lsp->errnum = ASE_LSP_ENOMEM;
return ASE_NULL; return ASE_NULL;
} }
@ -295,16 +313,19 @@ ase_lsp_obj_t* ase_lsp_prim_setq (ase_lsp_t* lsp, ase_lsp_obj_t* args)
ase_lsp_obj_t* p = args, * p1, * p2 = lsp->mem->nil; ase_lsp_obj_t* p = args, * p1, * p2 = lsp->mem->nil;
while (p != lsp->mem->nil) { while (p != lsp->mem->nil)
{
ASE_LSP_ASSERT (lsp, ASE_LSP_TYPE(p) == ASE_LSP_OBJ_CONS); ASE_LSP_ASSERT (lsp, ASE_LSP_TYPE(p) == ASE_LSP_OBJ_CONS);
p1 = ASE_LSP_CAR(p); p1 = ASE_LSP_CAR(p);
if (ASE_LSP_TYPE(p1) != ASE_LSP_OBJ_SYM) { if (ASE_LSP_TYPE(p1) != ASE_LSP_OBJ_SYM)
{
lsp->errnum = ASE_LSP_ERR_BAD_ARG; lsp->errnum = ASE_LSP_ERR_BAD_ARG;
return ASE_NULL; return ASE_NULL;
} }
if (ASE_LSP_TYPE(ASE_LSP_CDR(p)) != ASE_LSP_OBJ_CONS) { if (ASE_LSP_TYPE(ASE_LSP_CDR(p)) != ASE_LSP_OBJ_CONS)
{
lsp->errnum = ASE_LSP_ERR_TOO_FEW_ARGS; lsp->errnum = ASE_LSP_ERR_TOO_FEW_ARGS;
return ASE_NULL; return ASE_NULL;
} }
@ -312,7 +333,8 @@ ase_lsp_obj_t* ase_lsp_prim_setq (ase_lsp_t* lsp, ase_lsp_obj_t* args)
p2 = ase_lsp_eval (lsp, ASE_LSP_CAR(ASE_LSP_CDR(p))); p2 = ase_lsp_eval (lsp, ASE_LSP_CAR(ASE_LSP_CDR(p)));
if (p2 == ASE_NULL) return ASE_NULL; if (p2 == ASE_NULL) return ASE_NULL;
if (ase_lsp_setvalue (lsp->mem, p1, p2) == ASE_NULL) { if (ase_lsp_setvalue (lsp->mem, p1, p2) == ASE_NULL)
{
lsp->errnum = ASE_LSP_ENOMEM; lsp->errnum = ASE_LSP_ENOMEM;
return ASE_NULL; return ASE_NULL;
} }

12
ase/lsp/prim.h
View File

@ -1,5 +1,5 @@
/* /*
* $Id: prim.h,v 1.9 2006-10-25 13:42:31 bacon Exp $ * $Id: prim.h,v 1.10 2006-10-29 13:00:39 bacon Exp $
*/ */
#ifndef _ASE_LSP_PRIM_H_ #ifndef _ASE_LSP_PRIM_H_
@ -44,11 +44,11 @@ ase_lsp_obj_t* ase_lsp_prim_le (ase_lsp_t* lsp, ase_lsp_obj_t* args);
/*--------------------- /*---------------------
prim_math.c prim_math.c
---------------------*/ ---------------------*/
ase_lsp_obj_t* ase_lsp_prim_plus (ase_lsp_t* lsp, ase_lsp_obj_t* args); ase_lsp_obj_t* ase_lsp_prim_plus (ase_lsp_t* lsp, ase_lsp_obj_t* args);
ase_lsp_obj_t* ase_lsp_prim_minus (ase_lsp_t* lsp, ase_lsp_obj_t* args); ase_lsp_obj_t* ase_lsp_prim_minus (ase_lsp_t* lsp, ase_lsp_obj_t* args);
ase_lsp_obj_t* ase_lsp_prim_multiply (ase_lsp_t* lsp, ase_lsp_obj_t* args); ase_lsp_obj_t* ase_lsp_prim_mul (ase_lsp_t* lsp, ase_lsp_obj_t* args);
ase_lsp_obj_t* ase_lsp_prim_divide (ase_lsp_t* lsp, ase_lsp_obj_t* args); ase_lsp_obj_t* ase_lsp_prim_div (ase_lsp_t* lsp, ase_lsp_obj_t* args);
ase_lsp_obj_t* ase_lsp_prim_modulus (ase_lsp_t* lsp, ase_lsp_obj_t* args); ase_lsp_obj_t* ase_lsp_prim_mod (ase_lsp_t* lsp, ase_lsp_obj_t* args);
#ifdef __cplusplus #ifdef __cplusplus
} }

8
ase/lsp/prim_math.c
View File

@ -1,5 +1,5 @@
/* /*
* $Id: prim_math.c,v 1.11 2006-10-26 09:31:28 bacon Exp $ * $Id: prim_math.c,v 1.12 2006-10-29 13:00:39 bacon Exp $
*/ */
#include <ase/lsp/lsp_i.h> #include <ase/lsp/lsp_i.h>
@ -136,7 +136,7 @@ ase_lsp_obj_t* ase_lsp_prim_minus (ase_lsp_t* lsp, ase_lsp_obj_t* args)
return tmp; return tmp;
} }
ase_lsp_obj_t* ase_lsp_prim_multiply (ase_lsp_t* lsp, ase_lsp_obj_t* args) ase_lsp_obj_t* ase_lsp_prim_mul (ase_lsp_t* lsp, ase_lsp_obj_t* args)
{ {
ase_lsp_obj_t* body, * tmp; ase_lsp_obj_t* body, * tmp;
ase_long_t ivalue = 0; ase_long_t ivalue = 0;
@ -201,7 +201,7 @@ ase_lsp_obj_t* ase_lsp_prim_multiply (ase_lsp_t* lsp, ase_lsp_obj_t* args)
return tmp; return tmp;
} }
ase_lsp_obj_t* ase_lsp_prim_divide (ase_lsp_t* lsp, ase_lsp_obj_t* args) ase_lsp_obj_t* ase_lsp_prim_div (ase_lsp_t* lsp, ase_lsp_obj_t* args)
{ {
ase_lsp_obj_t* body, * tmp; ase_lsp_obj_t* body, * tmp;
ase_long_t ivalue = 0; ase_long_t ivalue = 0;
@ -272,7 +272,7 @@ ase_lsp_obj_t* ase_lsp_prim_divide (ase_lsp_t* lsp, ase_lsp_obj_t* args)
return tmp; return tmp;
} }
ase_lsp_obj_t* ase_lsp_prim_modulus (ase_lsp_t* lsp, ase_lsp_obj_t* args) ase_lsp_obj_t* ase_lsp_prim_mod (ase_lsp_t* lsp, ase_lsp_obj_t* args)
{ {
ase_lsp_obj_t* body, * tmp; ase_lsp_obj_t* body, * tmp;
ase_long_t ivalue = 0; ase_long_t ivalue = 0;

206
ase/lsp/print.c
View File

@ -1,64 +1,9 @@
/* /*
* $Id: print.c,v 1.16 2006-10-26 08:17:38 bacon Exp $ * $Id: print.c,v 1.17 2006-10-29 13:00:39 bacon Exp $
*/ */
#include <ase/lsp/lsp_i.h> #include <ase/lsp/lsp_i.h>
#if 0
void ase_lsp_print_debug (ase_lsp_obj_t* obj)
{
switch (ASE_LSP_TYPE(obj)) {
case ASE_LSP_OBJ_NIL:
ase_printf (ASE_T("nil"));
break;
case ASE_LSP_OBJ_TRUE:
ase_printf (ASE_T("t"));
break;
case ASE_LSP_OBJ_INT:
ase_printf (ASE_T("%d"), ASE_LSP_IVALUE(obj));
break;
case ASE_LSP_OBJ_REAL:
ase_printf (ASE_T("%f"), ASE_LSP_RVALUE(obj));
break;
case ASE_LSP_OBJ_SYM:
ase_printf (ASE_T("%s"), ASE_LSP_SYMPTR(obj));
break;
case ASE_LSP_OBJ_STR:
ase_printf (ASE_T("%s"), ASE_LSP_STRPTR(obj));
break;
case ASE_LSP_OBJ_CONS:
{
ase_lsp_obj_t* p = obj;
ase_printf (ASE_T("("));
do {
ase_lsp_print_debug (ASE_LSP_CAR(p));
p = ASE_LSP_CDR(p);
if (ASE_LSP_TYPE(p) != ASE_LSP_OBJ_NIL) {
ase_printf (ASE_T(" "));
if (ASE_LSP_TYPE(p) != ASE_LSP_OBJ_CONS) {
ase_printf (ASE_T(". "));
ase_lsp_print_debug (p);
}
}
} while (ASE_LSP_TYPE(p) != ASE_LSP_OBJ_NIL && ASE_LSP_TYPE(p) == ASE_LSP_OBJ_CONS);
ase_printf (ASE_T(")"));
}
break;
case ASE_LSP_OBJ_FUNC:
ase_printf (ASE_T("func"));
break;
case ASE_LSP_OBJ_MACRO:
ase_printf (ASE_T("macro"));
break;
case ASE_LSP_OBJ_PRIM:
ase_printf (ASE_T("prim"));
break;
default:
ase_printf (ASE_T("unknown object type: %d"), ASE_LSP_TYPE(obj));
}
}
#endif
#define OUTPUT_STR(lsp,str) \ #define OUTPUT_STR(lsp,str) \
do { \ do { \
if (lsp->output_func(ASE_LSP_IO_WRITE, lsp->output_arg, (ase_char_t*)str, ase_lsp_strlen(str)) == -1) { \ if (lsp->output_func(ASE_LSP_IO_WRITE, lsp->output_arg, (ase_char_t*)str, ase_lsp_strlen(str)) == -1) { \
@ -79,67 +24,55 @@ static int __print (ase_lsp_t* lsp, const ase_lsp_obj_t* obj, ase_bool_t prt_con
{ {
ase_char_t buf[256]; ase_char_t buf[256];
if (lsp->output_func == ASE_NULL) { if (lsp->output_func == ASE_NULL)
{
lsp->errnum = ASE_LSP_ERR_OUTPUT_NOT_ATTACHED; lsp->errnum = ASE_LSP_ERR_OUTPUT_NOT_ATTACHED;
return -1; return -1;
} }
switch (ASE_LSP_TYPE(obj)) { switch (ASE_LSP_TYPE(obj))
case ASE_LSP_OBJ_NIL: {
OUTPUT_STR (lsp, ASE_T("nil")); case ASE_LSP_OBJ_NIL:
break; OUTPUT_STR (lsp, ASE_T("nil"));
case ASE_LSP_OBJ_TRUE: break;
OUTPUT_STR (lsp, ASE_T("t"));
break;
case ASE_LSP_OBJ_INT:
if (ase_sizeof(ase_long_t) == ase_sizeof(int)) {
lsp->syscas.sprintf (
buf, ase_countof(buf),
ASE_T("%d"), ASE_LSP_IVALUE(obj));
}
else if (ase_sizeof(ase_long_t) == ase_sizeof(long))
{
lsp->syscas.sprintf (
buf, ase_countof(buf),
ASE_T("%ld"), ASE_LSP_IVALUE(obj));
}
#if defined(__BORLANDC__) || defined(_MSC_VER)
else if (ase_sizeof(ase_long_t) == ase_sizeof(__int64))
{
lsp->syscas.sprintf (
buf, ase_countof(buf),
ASE_T("%I64d"), ASE_LSP_IVALUE(obj));
}
#else
else if (ase_sizeof(ase_long_t) == ase_sizeof(long long))
{
lsp->syscas.sprintf (
buf, ase_countof(buf),
ASE_T("%lld"), ASE_LSP_IVALUE(obj));
}
#endif
OUTPUT_STR (lsp, buf); case ASE_LSP_OBJ_TRUE:
break; OUTPUT_STR (lsp, ASE_T("t"));
case ASE_LSP_OBJ_REAL: break;
if (ase_sizeof(ase_real_t) == ase_sizeof(double)) {
lsp->syscas.sprintf (buf, ase_countof(buf), ASE_T("%f"),
(double)ASE_LSP_RVALUE(obj));
}
else if (ase_sizeof(ase_real_t) == ase_sizeof(long double)) {
lsp->syscas.sprintf (buf, ase_countof(buf), ASE_T("%Lf"),
(long double)ASE_LSP_RVALUE(obj));
}
OUTPUT_STR (lsp, buf); case ASE_LSP_OBJ_INT:
break; #if defined(__BORLANDC__) || defined(_MSC_VER)
case ASE_LSP_OBJ_SYM: lsp->syscas.sprintf (
OUTPUT_STR (lsp, ASE_LSP_SYMPTR(obj)); buf, ase_countof(buf),
break; ASE_T("%I64d"), (__int64)ASE_LSP_IVALUE(obj));
case ASE_LSP_OBJ_STR: #elif defined(vax) || defined(__vax) || defined(_SCO_DS)
OUTPUT_STR (lsp, ASE_LSP_STRPTR(obj)); lsp->syscas.sprintf (
break; buf, ase_countof(buf),
case ASE_LSP_OBJ_CONS: ASE_T("%ld"), (long)ASE_LSP_IVALUE(obj));
#else
lsp->syscas.sprintf (
buf, ase_countof(buf),
ASE_T("%lld"), (long long)ASE_LSP_IVALUE(obj));
#endif
OUTPUT_STR (lsp, buf);
break;
case ASE_LSP_OBJ_REAL:
lsp->syscas.sprintf (buf, ase_countof(buf),
ASE_T("%Lf"), (long double)ASE_LSP_RVALUE(obj));
OUTPUT_STR (lsp, buf);
break;
case ASE_LSP_OBJ_SYM:
OUTPUT_STRX (lsp, ASE_LSP_SYMPTR(obj), ASE_LSP_SYMLEN(obj));
break;
case ASE_LSP_OBJ_STR:
OUTPUT_STRX (lsp, ASE_LSP_STRPTR(obj), ASE_LSP_STRLEN(obj));
break;
case ASE_LSP_OBJ_CONS:
{ {
const ase_lsp_obj_t* p = obj; const ase_lsp_obj_t* p = obj;
if (prt_cons_par) OUTPUT_STR (lsp, ASE_T("(")); if (prt_cons_par) OUTPUT_STR (lsp, ASE_T("("));
@ -159,31 +92,34 @@ static int __print (ase_lsp_t* lsp, const ase_lsp_obj_t* obj, ase_bool_t prt_con
} }
while (p != lsp->mem->nil && ASE_LSP_TYPE(p) == ASE_LSP_OBJ_CONS); while (p != lsp->mem->nil && ASE_LSP_TYPE(p) == ASE_LSP_OBJ_CONS);
if (prt_cons_par) OUTPUT_STR (lsp, ASE_T(")")); if (prt_cons_par) OUTPUT_STR (lsp, ASE_T(")"));
break;
} }
break;
case ASE_LSP_OBJ_FUNC: case ASE_LSP_OBJ_FUNC:
/*OUTPUT_STR (lsp, ASE_T("func"));*/ /*OUTPUT_STR (lsp, ASE_T("func"));*/
OUTPUT_STR (lsp, ASE_T("(lambda ")); OUTPUT_STR (lsp, ASE_T("(lambda "));
if (__print (lsp, ASE_LSP_FFORMAL(obj), ase_true) == -1) return -1; if (__print (lsp, ASE_LSP_FFORMAL(obj), ase_true) == -1) return -1;
OUTPUT_STR (lsp, ASE_T(" ")); OUTPUT_STR (lsp, ASE_T(" "));
if (__print (lsp, ASE_LSP_FBODY(obj), ase_false) == -1) return -1; if (__print (lsp, ASE_LSP_FBODY(obj), ase_false) == -1) return -1;
OUTPUT_STR (lsp, ASE_T(")")); OUTPUT_STR (lsp, ASE_T(")"));
break; break;
case ASE_LSP_OBJ_MACRO:
/*OUTPUT_STR (lsp, ASE_T("macro"));*/ case ASE_LSP_OBJ_MACRO:
OUTPUT_STR (lsp, ASE_T("(macro ")); OUTPUT_STR (lsp, ASE_T("(macro "));
if (__print (lsp, ASE_LSP_FFORMAL(obj), ase_true) == -1) return -1; if (__print (lsp, ASE_LSP_FFORMAL(obj), ase_true) == -1) return -1;
OUTPUT_STR (lsp, ASE_T(" ")); OUTPUT_STR (lsp, ASE_T(" "));
if (__print (lsp, ASE_LSP_FBODY(obj), ase_false) == -1) return -1; if (__print (lsp, ASE_LSP_FBODY(obj), ase_false) == -1) return -1;
OUTPUT_STR (lsp, ASE_T(")")); OUTPUT_STR (lsp, ASE_T(")"));
break; break;
case ASE_LSP_OBJ_PRIM: case ASE_LSP_OBJ_PRIM:
OUTPUT_STR (lsp, ASE_T("prim")); OUTPUT_STR (lsp, ASE_T("prim"));
break; break;
default:
lsp->syscas.sprintf (buf, ase_countof(buf), default:
ASE_T("unknown object type: %d"), ASE_LSP_TYPE(obj)); lsp->syscas.sprintf (buf, ase_countof(buf),
OUTPUT_STR (lsp, buf); ASE_T("unknown object type: %d"), ASE_LSP_TYPE(obj));
OUTPUT_STR (lsp, buf);
} }
return 0; return 0;

114
ase/lsp/read.c
View File

@ -1,5 +1,5 @@
/* /*
* $Id: read.c,v 1.26 2006-10-27 08:31:06 bacon Exp $ * $Id: read.c,v 1.27 2006-10-29 13:00:39 bacon Exp $
*/ */
#include <ase/lsp/lsp_i.h> #include <ase/lsp/lsp_i.h>
@ -12,12 +12,12 @@
(c) == ASE_T('=') || (c) == ASE_T('_') || \ (c) == ASE_T('=') || (c) == ASE_T('_') || \
(c) == ASE_T('?')) (c) == ASE_T('?'))
#define TOKEN_CLEAR(lsp) ase_lsp_name_clear (&(lsp)->token.name) #define TOKEN_CLEAR(lsp) ase_lsp_name_clear (&(lsp)->token.name)
#define TOKEN_TYPE(lsp) (lsp)->token.type #define TOKEN_TYPE(lsp) (lsp)->token.type
#define TOKEN_IVALUE(lsp) (lsp)->token.ivalue #define TOKEN_IVAL(lsp) (lsp)->token.ival
#define TOKEN_RVALUE(lsp) (lsp)->token.rvalue #define TOKEN_RVAL(lsp) (lsp)->token.rval
#define TOKEN_SVALUE(lsp) (lsp)->token.name.buf #define TOKEN_SVAL(lsp) (lsp)->token.name.buf
#define TOKEN_SLENGTH(lsp) (lsp)->token.name.size #define TOKEN_SLEN(lsp) (lsp)->token.name.size
#define TOKEN_ADD_CHAR(lsp,ch) do { \ #define TOKEN_ADD_CHAR(lsp,ch) do { \
if (ase_lsp_name_addc(&(lsp)->token.name, ch) == -1) { \ if (ase_lsp_name_addc(&(lsp)->token.name, ch) == -1) { \
@ -79,44 +79,50 @@ static ase_lsp_obj_t* read_obj (ase_lsp_t* lsp)
switch (TOKEN_TYPE(lsp)) switch (TOKEN_TYPE(lsp))
{ {
case TOKEN_END: case TOKEN_END:
lsp->errnum = ASE_LSP_ERR_END; lsp->errnum = ASE_LSP_ERR_END;
return ASE_NULL; return ASE_NULL;
case TOKEN_LPAREN:
NEXT_TOKEN (lsp); case TOKEN_LPAREN:
return read_list (lsp); NEXT_TOKEN (lsp);
case TOKEN_QUOTE: return read_list (lsp);
NEXT_TOKEN (lsp);
return read_quote (lsp); case TOKEN_QUOTE:
case TOKEN_INT: NEXT_TOKEN (lsp);
obj = ase_lsp_makeintobj (lsp->mem, TOKEN_IVALUE(lsp)); return read_quote (lsp);
if (obj == ASE_NULL) lsp->errnum = ASE_LSP_ENOMEM;
ase_lsp_lockobj (lsp, obj); case TOKEN_INT:
return obj; obj = ase_lsp_makeintobj (lsp->mem, TOKEN_IVAL(lsp));
case TOKEN_REAL:
obj = ase_lsp_makerealobj (lsp->mem, TOKEN_RVALUE(lsp));
if (obj == ASE_NULL) lsp->errnum = ASE_LSP_ENOMEM;
ase_lsp_lockobj (lsp, obj);
return obj;
case TOKEN_STRING:
obj = ase_lsp_makestrobj (
lsp->mem, TOKEN_SVALUE(lsp), TOKEN_SLENGTH(lsp));
if (obj == ASE_NULL) lsp->errnum = ASE_LSP_ENOMEM;
ase_lsp_lockobj (lsp, obj);
return obj;
case TOKEN_IDENT:
ASE_LSP_ASSERT (lsp,
lsp->mem->nil != ASE_NULL && lsp->mem->t != ASE_NULL);
if (TOKEN_COMPARE(lsp,ASE_T("nil")) == 0) obj = lsp->mem->nil;
else if (TOKEN_COMPARE(lsp,ASE_T("t")) == 0) obj = lsp->mem->t;
else
{
obj = ase_lsp_makesymobj (
lsp->mem, TOKEN_SVALUE(lsp), TOKEN_SLENGTH(lsp));
if (obj == ASE_NULL) lsp->errnum = ASE_LSP_ENOMEM; if (obj == ASE_NULL) lsp->errnum = ASE_LSP_ENOMEM;
ase_lsp_lockobj (lsp, obj); ase_lsp_lockobj (lsp, obj);
} return obj;
return obj;
case TOKEN_REAL:
obj = ase_lsp_makerealobj (lsp->mem, TOKEN_RVAL(lsp));
if (obj == ASE_NULL) lsp->errnum = ASE_LSP_ENOMEM;
ase_lsp_lockobj (lsp, obj);
return obj;
case TOKEN_STRING:
obj = ase_lsp_makestrobj (
lsp->mem, TOKEN_SVAL(lsp), TOKEN_SLEN(lsp));
if (obj == ASE_NULL) lsp->errnum = ASE_LSP_ENOMEM;
ase_lsp_lockobj (lsp, obj);
return obj;
case TOKEN_IDENT:
ASE_LSP_ASSERT (lsp,
lsp->mem->nil != ASE_NULL && lsp->mem->t != ASE_NULL);
if (TOKEN_COMPARE(lsp,ASE_T("nil")) == 0) obj = lsp->mem->nil;
else if (TOKEN_COMPARE(lsp,ASE_T("t")) == 0) obj = lsp->mem->t;
else
{
obj = ase_lsp_makesymobj (
lsp->mem, TOKEN_SVAL(lsp), TOKEN_SLEN(lsp));
if (obj == ASE_NULL) lsp->errnum = ASE_LSP_ENOMEM;
ase_lsp_lockobj (lsp, obj);
}
return obj;
} }
lsp->errnum = ASE_LSP_ERR_SYNTAX; lsp->errnum = ASE_LSP_ERR_SYNTAX;
@ -235,6 +241,7 @@ static ase_lsp_obj_t* read_quote (ase_lsp_t* lsp)
static int read_char (ase_lsp_t* lsp) static int read_char (ase_lsp_t* lsp)
{ {
ase_ssize_t n; ase_ssize_t n;
ase_char_t c;
if (lsp->input_func == ASE_NULL) if (lsp->input_func == ASE_NULL)
{ {
@ -242,7 +249,7 @@ static int read_char (ase_lsp_t* lsp)
return -1; return -1;
} }
n = lsp->input_func(ASE_LSP_IO_READ, lsp->input_arg, &lsp->curc, 1); n = lsp->input_func(ASE_LSP_IO_READ, lsp->input_arg, &c, 1);
if (n == -1) if (n == -1)
{ {
lsp->errnum = ASE_LSP_ERR_INPUT; lsp->errnum = ASE_LSP_ERR_INPUT;
@ -250,6 +257,7 @@ static int read_char (ase_lsp_t* lsp)
} }
if (n == 0) lsp->curc = ASE_CHAR_EOF; if (n == 0) lsp->curc = ASE_CHAR_EOF;
else lsp->curc = c;
return 0; return 0;
} }
@ -349,12 +357,12 @@ static int read_token (ase_lsp_t* lsp)
static int read_number (ase_lsp_t* lsp, int negative) static int read_number (ase_lsp_t* lsp, int negative)
{ {
ase_long_t ivalue = 0; ase_long_t ival = 0;
ase_real_t rvalue = 0.; ase_real_t rval = 0.;
do do
{ {
ivalue = ivalue * 10 + (lsp->curc - ASE_T('0')); ival = ival * 10 + (lsp->curc - ASE_T('0'));
TOKEN_ADD_CHAR (lsp, lsp->curc); TOKEN_ADD_CHAR (lsp, lsp->curc);
NEXT_CHAR (lsp); NEXT_CHAR (lsp);
} }
@ -366,23 +374,23 @@ static int read_number (ase_lsp_t* lsp, int negative)
ase_real_t fraction = 0.1; ase_real_t fraction = 0.1;
NEXT_CHAR (lsp); NEXT_CHAR (lsp);
rvalue = (ase_real_t)ivalue; rval = (ase_real_t)ival;
while (ASE_LSP_ISDIGIT(lsp, lsp->curc)) while (ASE_LSP_ISDIGIT(lsp, lsp->curc))
{ {
rvalue += (ase_real_t)(lsp->curc - ASE_T('0')) * fraction; rval += (ase_real_t)(lsp->curc - ASE_T('0')) * fraction;
fraction *= 0.1; fraction *= 0.1;
NEXT_CHAR (lsp); NEXT_CHAR (lsp);
} }
TOKEN_RVALUE(lsp) = rvalue; TOKEN_RVAL(lsp) = rval;
TOKEN_TYPE(lsp) = TOKEN_REAL; TOKEN_TYPE(lsp) = TOKEN_REAL;
if (negative) rvalue *= -1; if (negative) rval *= -1;
} }
else { else {
TOKEN_IVALUE(lsp) = ivalue; TOKEN_IVAL(lsp) = ival;
TOKEN_TYPE(lsp) = TOKEN_INT; TOKEN_TYPE(lsp) = TOKEN_INT;
if (negative) ivalue *= -1; if (negative) ival *= -1;
} }
return 0; return 0;

46
ase/test/lsp/lsp.c
View File

@ -5,14 +5,21 @@
#include <xp/bas/locale.h> #include <xp/bas/locale.h>
#include <xp/bas/sio.h> #include <xp/bas/sio.h>
#include <tchar.h>
#include <string.h> #include <string.h>
#include <wctype.h> #include <wctype.h>
#include <stdlib.h> #include <stdlib.h>
#if defined(_WIN32) && defined(_MSC_VER) && defined(_DEBUG)
#define _CRTDBG_MAP_ALLOC
#include <crtdbg.h>
#endif
#ifdef __linux #ifdef __linux
#include <mcheck.h> #include <mcheck.h>
#endif #endif
static xp_ssize_t get_input (int cmd, void* arg, xp_char_t* data, xp_size_t size) static xp_ssize_t get_input (int cmd, void* arg, xp_char_t* data, xp_size_t size)
{ {
xp_ssize_t n; xp_ssize_t n;
@ -207,13 +214,18 @@ int __main (int argc, xp_char_t* argv[])
xp_cli_t* cli; xp_cli_t* cli;
int mem, inc; int mem, inc;
ase_lsp_syscas_t syscas; ase_lsp_syscas_t syscas;
#ifdef _WIN32
syscas_data_t syscas_data;
#endif
/*
if (xp_setlocale () == -1) { if (xp_setlocale () == -1) {
xp_fprintf (xp_stderr, xp_fprintf (xp_stderr,
XP_T("error: cannot set locale\n")); XP_T("error: cannot set locale\n"));
return -1; return -1;
} }
*/
if ((cli = parse_cli (argc, argv)) == XP_NULL) return -1; if ((cli = parse_cli (argc, argv)) == XP_NULL) return -1;
mem = to_int(xp_getclioptval(cli, XP_T("memory"))); mem = to_int(xp_getclioptval(cli, XP_T("memory")));
@ -269,10 +281,25 @@ int __main (int argc, xp_char_t* argv[])
syscas.dprintf = __dprintf; syscas.dprintf = __dprintf;
syscas.abort = abort; syscas.abort = abort;
#ifdef _WIN32
syscas_data.heap = HeapCreate (0, 1000000, 1000000);
if (syscas_data.heap == NULL)
{
xp_printf (ASE_T("Error: cannot create an awk heap\n"));
return -1;
}
syscas.custom_data = &syscas_data;
#endif
lsp = ase_lsp_open (&syscas, mem, inc); lsp = ase_lsp_open (&syscas, mem, inc);
if (lsp == XP_NULL) if (lsp == XP_NULL)
{ {
#ifdef _WIN32
HeapDestroy (syscas_data.heap);
#endif
xp_fprintf (xp_stderr, xp_fprintf (xp_stderr,
XP_T("error: cannot create a lsp instance\n")); XP_T("error: cannot create a lsp instance\n"));
return -1; return -1;
@ -285,31 +312,36 @@ int __main (int argc, xp_char_t* argv[])
while (1) while (1)
{ {
xp_sio_puts (xp_sio_out, XP_T("["));
xp_sio_puts (xp_sio_out, argv[0]); xp_sio_puts (xp_sio_out, argv[0]);
xp_sio_puts (xp_sio_out, XP_T("> ")); xp_sio_puts (xp_sio_out, XP_T("]"));
xp_sio_flush (xp_sio_out); xp_sio_flush (xp_sio_out);
obj = ase_lsp_read (lsp); obj = ase_lsp_read (lsp);
if (obj == XP_NULL) if (obj == XP_NULL)
{ {
int errnum = ase_lsp_geterrnum(lsp); int errnum = ase_lsp_geterrnum(lsp);
const xp_char_t* errstr;
if (errnum != ASE_LSP_ERR_END && if (errnum != ASE_LSP_ERR_END &&
errnum != ASE_LSP_ERR_ABORT) errnum != ASE_LSP_ERR_ABORT)
{ {
errstr = ase_lsp_geterrstr(errnum);
xp_fprintf (xp_stderr, xp_fprintf (xp_stderr,
XP_T("error while reading: %d\n"), errnum); XP_T("error in read: [%d] %s\n"), errnum, errstr);
} }
if (errnum < ASE_LSP_ERR_SYNTAX) break; if (errnum < ASE_LSP_ERR_SYNTAX) break;
continue; continue;
} }
if ((obj = ase_lsp_eval (lsp, obj)) != XP_NULL) { if ((obj = ase_lsp_eval (lsp, obj)) != XP_NULL)
{
ase_lsp_print (lsp, obj); ase_lsp_print (lsp, obj);
xp_sio_puts (xp_sio_out, XP_T("\n")); xp_sio_puts (xp_sio_out, XP_T("\n"));
} }
else { else
{
int errnum; int errnum;
const xp_char_t* errstr; const xp_char_t* errstr;
@ -318,13 +350,15 @@ int __main (int argc, xp_char_t* argv[])
errstr = ase_lsp_geterrstr(errnum); errstr = ase_lsp_geterrstr(errnum);
xp_fprintf (xp_stderr, xp_fprintf (xp_stderr,
XP_T("error: [%d] %s\n"), errnum, errstr); XP_T("error in eval: [%d] %s\n"), errnum, errstr);
} }
} }
ase_lsp_close (lsp); ase_lsp_close (lsp);
#ifdef _WIN32
HeapDestroy (syscas_data.heap);
#endif
return 0; return 0;
} }