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 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 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
# ADD BASE 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 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 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
# ADD BASE 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>
@ -352,20 +352,20 @@ ase_bool_t ase_awk_valtobool (ase_awk_run_t* run, ase_awk_val_t* val)
switch (val->type)
{
case ASE_AWK_VAL_NIL:
return ase_false;
case ASE_AWK_VAL_INT:
return ((ase_awk_val_int_t*)val)->val != 0;
case ASE_AWK_VAL_REAL:
return ((ase_awk_val_real_t*)val)->val != 0.0;
case ASE_AWK_VAL_STR:
return ((ase_awk_val_str_t*)val)->len > 0;
case ASE_AWK_VAL_REX: /* TODO: is this correct? */
return ((ase_awk_val_rex_t*)val)->len > 0;
case ASE_AWK_VAL_MAP:
return ase_false; /* TODO: is this correct? */
case ASE_AWK_VAL_REF:
return ase_false; /* TODO: is this correct? */
case ASE_AWK_VAL_NIL:
return ase_false;
case ASE_AWK_VAL_INT:
return ((ase_awk_val_int_t*)val)->val != 0;
case ASE_AWK_VAL_REAL:
return ((ase_awk_val_real_t*)val)->val != 0.0;
case ASE_AWK_VAL_STR:
return ((ase_awk_val_str_t*)val)->len > 0;
case ASE_AWK_VAL_REX: /* TODO: is this correct? */
return ((ase_awk_val_rex_t*)val)->len > 0;
case ASE_AWK_VAL_MAP:
return ase_false; /* TODO: is this correct? */
case ASE_AWK_VAL_REF:
return ase_false; /* TODO: is this correct? */
}
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)
{
case ASE_AWK_VAL_NIL:
__DPRINTF (ASE_T("nil"));
break;
case ASE_AWK_VAL_NIL:
__DPRINTF (ASE_T("nil"));
break;
case ASE_AWK_VAL_INT:
#if defined(__BORLANDC__) || defined(_MSC_VER)
__DPRINTF (ASE_T("%I64d"),
(__int64)((ase_awk_nde_int_t*)val)->val);
#elif defined(vax) || defined(__vax) || defined(_SCO_DS)
__DPRINTF (ASE_T("%ld"),
(long)((ase_awk_val_int_t*)val)->val);
#else
__DPRINTF (ASE_T("%lld"),
(long long)((ase_awk_val_int_t*)val)->val);
#endif
break;
case ASE_AWK_VAL_INT:
#if defined(__BORLANDC__) || defined(_MSC_VER)
__DPRINTF (ASE_T("%I64d"),
(__int64)((ase_awk_nde_int_t*)val)->val);
#elif defined(vax) || defined(__vax) || defined(_SCO_DS)
__DPRINTF (ASE_T("%ld"),
(long)((ase_awk_val_int_t*)val)->val);
#else
__DPRINTF (ASE_T("%lld"),
(long long)((ase_awk_val_int_t*)val)->val);
#endif
break;
case ASE_AWK_VAL_REAL:
__DPRINTF (ASE_T("%Lf"),
(long double)((ase_awk_val_real_t*)val)->val);
break;
case ASE_AWK_VAL_REAL:
__DPRINTF (ASE_T("%Lf"),
(long double)((ase_awk_val_real_t*)val)->val);
break;
case ASE_AWK_VAL_STR:
__DPRINTF (ASE_T("%s"), ((ase_awk_val_str_t*)val)->buf);
break;
case ASE_AWK_VAL_STR:
__DPRINTF (ASE_T("%s"), ((ase_awk_val_str_t*)val)->buf);
break;
case ASE_AWK_VAL_REX:
__DPRINTF (ASE_T("REX[%s]"), ((ase_awk_val_rex_t*)val)->buf);
break;
case ASE_AWK_VAL_REX:
__DPRINTF (ASE_T("REX[%s]"), ((ase_awk_val_rex_t*)val)->buf);
break;
case ASE_AWK_VAL_MAP:
__DPRINTF (ASE_T("MAP["));
ase_awk_map_walk (((ase_awk_val_map_t*)val)->map, __print_pair, run);
__DPRINTF (ASE_T("]"));
break;
case ASE_AWK_VAL_MAP:
__DPRINTF (ASE_T("MAP["));
ase_awk_map_walk (((ase_awk_val_map_t*)val)->map, __print_pair, run);
__DPRINTF (ASE_T("]"));
break;
case ASE_AWK_VAL_REF:
__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);
__DPRINTF (ASE_T("]"));
break;
case ASE_AWK_VAL_REF:
__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);
__DPRINTF (ASE_T("]"));
break;
default:
__DPRINTF (ASE_T("**** INTERNAL ERROR - INVALID VALUE TYPE ****\n"));
default:
__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>
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)
{
return lsp->errnum;
@ -36,6 +11,31 @@ int ase_lsp_geterrnum (ase_lsp_t* lsp)
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))
{
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>
@ -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;
if (ASE_LSP_TYPE(obj) == ASE_LSP_OBJ_CONS)
{
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;
/*
@ -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);
if (assoc == ASE_NULL || assoc->value == ASE_NULL) {
if (lsp->opt_undef_symbol) {
if (assoc == ASE_NULL || assoc->value == ASE_NULL)
{
if (lsp->opt_undef_symbol)
{
lsp->errnum = ASE_LSP_ERR_UNDEF_SYMBOL;
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;
if (cdr == lsp->mem->nil) {
if (cdr == lsp->mem->nil)
{
lsp->errnum = ASE_LSP_ERR_TOO_FEW_ARGS;
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;
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);
body = ASE_LSP_CDR(cdr);
if (body == lsp->mem->nil) {
if (body == lsp->mem->nil)
{
lsp->errnum = ASE_LSP_ERR_EMPTY_BODY;
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
* at the terminating cdr */
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) */
lsp->errnum = ASE_LSP_ERR_BAD_ARG;
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)?
ase_lsp_makemacro (lsp->mem, formal, body):
ase_lsp_makefunc (lsp->mem, formal, body);
if (func == ASE_NULL) {
if (func == ASE_NULL)
{
lsp->errnum = ASE_LSP_ENOMEM;
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)
{
/* (lambda (x) (+ x 20)) */
return make_func (lsp, cdr, 0);
}
else if (car == lsp->mem->macro)
{
/* (macro (x) (+ x 20)) */
return make_func (lsp, cdr, 1);
}
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)
{
//ase_lsp_obj_t* func = assoc->value;
/*ase_lsp_obj_t* func = assoc->value;*/
ase_lsp_obj_t* func = assoc->func;
if (func == ASE_NULL) {
if (func == ASE_NULL)
{
/* the symbol's function definition is void */
lsp->errnum = ASE_LSP_ERR_UNDEF_FUNC;
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)
{
/* primitive function */
return ASE_LSP_PRIM(func) (lsp, cdr);
return ASE_LSP_PIMPL(func) (lsp, cdr);
}
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 ||
ASE_LSP_TYPE(car) == ASE_LSP_OBJ_MACRO) {
ASE_LSP_TYPE(car) == ASE_LSP_OBJ_MACRO)
{
return apply (lsp, car, cdr);
}
else if (ASE_LSP_TYPE(car) == ASE_LSP_OBJ_CONS) {
if (ASE_LSP_CAR(car) == lsp->mem->lambda) {
else if (ASE_LSP_TYPE(car) == ASE_LSP_OBJ_CONS)
{
/* 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);
if (func == ASE_NULL) return ASE_NULL;
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);
if (func == ASE_NULL) return ASE_NULL;
return apply (lsp, func, cdr);
@ -292,7 +311,7 @@ static ase_lsp_obj_t* apply (
/* destroy the 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)
{
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__)
@ -26,7 +26,7 @@ ase_lsp_t* ase_lsp_open (
if (syscas->is_upper == ASE_NULL ||
syscas->is_lower == ASE_NULL ||
syscas->is_alpha == ASE_NULL ||
syscas->is_digit == ASE_NULL ||
syscas->is_digit == ASE_NULL ||
syscas->is_xdigit == ASE_NULL ||
syscas->is_alnum == 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)
{
#define ADD_PRIM(mem,name,prim) \
if (ase_lsp_add_prim(mem,name,prim) == -1) return -1;
#define ADD_PRIM(mem,name,name_len,pimpl,min_args,max_args) \
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("eval"), ase_lsp_prim_eval);
ADD_PRIM (lsp, ASE_T("prog1"), ase_lsp_prim_prog1);
ADD_PRIM (lsp, ASE_T("progn"), ase_lsp_prim_progn);
ADD_PRIM (lsp, ASE_T("gc"), ase_lsp_prim_gc);
ADD_PRIM (lsp, ASE_T("abort"), 5, ase_lsp_prim_abort, 0, 0);
ADD_PRIM (lsp, ASE_T("eval"), 4, ase_lsp_prim_eval, 1, 1);
ADD_PRIM (lsp, ASE_T("prog1"), 5, ase_lsp_prim_prog1, 1, ASE_TYPE_MAX(ase_size_t));
ADD_PRIM (lsp, ASE_T("progn"), 5, ase_lsp_prim_progn, 1, ASE_TYPE_MAX(ase_size_t));
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("if"), ase_lsp_prim_if);
ADD_PRIM (lsp, ASE_T("while"), ase_lsp_prim_while);
ADD_PRIM (lsp, ASE_T("cond"), 4, ase_lsp_prim_cond, 0, ASE_TYPE_MAX(ase_size_t));
ADD_PRIM (lsp, ASE_T("if"), 2, ase_lsp_prim_if, 2, ASE_TYPE_MAX(ase_size_t));
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("cdr"), ase_lsp_prim_cdr);
ADD_PRIM (lsp, ASE_T("cons"), ase_lsp_prim_cons);
ADD_PRIM (lsp, ASE_T("set"), ase_lsp_prim_set);
ADD_PRIM (lsp, ASE_T("setq"), ase_lsp_prim_setq);
ADD_PRIM (lsp, ASE_T("quote"), ase_lsp_prim_quote);
ADD_PRIM (lsp, ASE_T("defun"), ase_lsp_prim_defun);
ADD_PRIM (lsp, ASE_T("demac"), ase_lsp_prim_demac);
ADD_PRIM (lsp, ASE_T("let"), ase_lsp_prim_let);
ADD_PRIM (lsp, ASE_T("let*"), ase_lsp_prim_letx);
ADD_PRIM (lsp, ASE_T("car"), 3, ase_lsp_prim_car, 1, 1);
ADD_PRIM (lsp, ASE_T("cdr"), 3, ase_lsp_prim_cdr, 1, 1);
ADD_PRIM (lsp, ASE_T("cons"), 4, ase_lsp_prim_cons, 2, 2);
ADD_PRIM (lsp, ASE_T("set"), 3, ase_lsp_prim_set, 2, 2);
ADD_PRIM (lsp, ASE_T("setq"), 4, ase_lsp_prim_setq, 1, ASE_TYPE_MAX(ase_size_t));
ADD_PRIM (lsp, ASE_T("quote"), 5, ase_lsp_prim_quote, 1, 1);
ADD_PRIM (lsp, ASE_T("defun"), 5, ase_lsp_prim_defun, 3, ASE_TYPE_MAX(ase_size_t));
ADD_PRIM (lsp, ASE_T("demac"), 5, ase_lsp_prim_demac, 3, ASE_TYPE_MAX(ase_size_t));
ADD_PRIM (lsp, ASE_T("let"), 3, ase_lsp_prim_let, 1, ASE_TYPE_MAX(ase_size_t));
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("/="), ase_lsp_prim_ne);
ADD_PRIM (lsp, ASE_T(">"), ase_lsp_prim_gt);
ADD_PRIM (lsp, ASE_T("<"), ase_lsp_prim_lt);
ADD_PRIM (lsp, ASE_T(">="), ase_lsp_prim_ge);
ADD_PRIM (lsp, ASE_T("<="), ase_lsp_prim_le);
ADD_PRIM (lsp, ASE_T("="), 1, ase_lsp_prim_eq, 2, 2);
ADD_PRIM (lsp, ASE_T("/="), 2, ase_lsp_prim_ne, 2, 2);
ADD_PRIM (lsp, ASE_T(">"), 1, ase_lsp_prim_gt, 2, 2);
ADD_PRIM (lsp, ASE_T("<"), 1, ase_lsp_prim_lt, 2, 2);
ADD_PRIM (lsp, ASE_T(">="), 2, ase_lsp_prim_ge, 2, 2);
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("-"), ase_lsp_prim_minus);
ADD_PRIM (lsp, ASE_T("*"), ase_lsp_prim_multiply);
ADD_PRIM (lsp, ASE_T("/"), ase_lsp_prim_divide);
ADD_PRIM (lsp, ASE_T("%"), ase_lsp_prim_modulus);
ADD_PRIM (lsp, ASE_T("+"), 1, ase_lsp_prim_plus,, 1, ASE_TYPE_MAX(ase_size_t));
ADD_PRIM (lsp, ASE_T("-"), 1, ase_lsp_prim_minus, 1, ASE_TYPE_MAX(ase_size_t));
ADD_PRIM (lsp, ASE_T("*"), 1, ase_lsp_prim_mul, 1, ASE_TYPE_MAX(ase_size_t));
ADD_PRIM (lsp, ASE_T("/"), 1, ase_lsp_prim_div, 1, ASE_TYPE_MAX(ase_size_t));
ADD_PRIM (lsp, ASE_T("%"), 1, ase_lsp_prim_mod , 1, ASE_TYPE_MAX(ase_size_t));
return 0;
}

4
ase/lsp/lsp.dsp
View File

@ -42,7 +42,7 @@ RSC=rc.exe
# PROP Target_Dir ""
MTL=midl.exe
# 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 RSC /l 0x409 /d "NDEBUG"
BSC32=bscmake.exe
@ -66,7 +66,7 @@ LIB32=link.exe -lib
# PROP Target_Dir ""
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 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 RSC /l 0x409 /d "_DEBUG"
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_
@ -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);
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_remove_prim (ase_lsp_t* lsp, const ase_char_t* name);
int ase_lsp_addprim (
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 */
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_
@ -63,8 +63,8 @@ struct ase_lsp_t
struct
{
int type;
ase_long_t ivalue;
ase_real_t rvalue;
ase_long_t ival;
ase_real_t rval;
ase_lsp_name_t name;
} 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>
@ -95,17 +95,18 @@ void ase_lsp_closemem (ase_lsp_mem_t* mem)
ASE_LSP_FREE (mem->lsp, mem);
}
static int __add_prim (ase_lsp_mem_t* mem,
const ase_char_t* name, ase_size_t len, ase_lsp_prim_t prim)
static int __add_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;
n = ase_lsp_makesymobj (mem, name, len);
n = ase_lsp_makesymobj (mem, name, name_len);
if (n == ASE_NULL) return -1;
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;
ase_lsp_unlockobj (mem->lsp, n);
@ -115,44 +116,6 @@ static int __add_prim (ase_lsp_mem_t* mem,
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* obj;
@ -541,7 +504,8 @@ ase_lsp_obj_t* ase_lsp_makemacro (
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;
@ -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));
if (obj == ASE_NULL) return ASE_NULL;
/*ASE_LSP_PRIM(obj) = (ase_lsp_prim_t)impl;*/
((ase_lsp_obj_prim_t*)obj)->impl = impl;
ASE_LSP_PIMPL(obj) = impl;
ASE_LSP_PMINARGS(obj) = min_args;
ASE_LSP_PMAXARGS(obj) = max_args;
return obj;
}
@ -607,7 +572,7 @@ ase_lsp_assoc_t* ase_lsp_setfunc (
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;
@ -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);
count = 0;
//while (obj != mem->nil) {
/*while (obj != mem->nil) {*/
while (ASE_LSP_TYPE(obj) == ASE_LSP_OBJ_CONS)
{
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_
@ -58,8 +58,6 @@ ase_lsp_mem_t* ase_lsp_openmem (
ase_lsp_t* lsp, ase_size_t ubound, ase_size_t ubound_inc);
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);
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);
@ -87,7 +85,8 @@ ase_lsp_obj_t* ase_lsp_makefunc (
ase_lsp_obj_t* ase_lsp_makemacro (
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
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);
// 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);
#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>
@ -7,8 +7,7 @@
ase_lsp_name_t* ase_lsp_name_open (
ase_lsp_name_t* name, ase_size_t capa, ase_lsp_t* lsp)
{
if (capa == 0)
capa = ase_countof(name->static_buf) - 1;
if (capa == 0) capa = ase_countof(name->static_buf) - 1;
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_
@ -116,7 +116,9 @@ struct ase_lsp_obj_macro_t
struct ase_lsp_obj_prim_t
{
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 */
@ -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_MFORMAL(x) (((ase_lsp_obj_macro_t*)x)->formal)
#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

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>
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 (
ase_lsp_t* lsp, const ase_char_t* name, ase_lsp_prim_t prim)
int ase_lsp_addprim (
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:
return -1;
}
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;
n = ase_lsp_makesymobj (mem, name, len);
n = ase_lsp_makesymobj (mem, name, name_len);
if (n == ASE_NULL) return -1;
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;
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);
while (ASE_LSP_TYPE(args) == ASE_LSP_OBJ_CONS) {
if (ASE_LSP_TYPE(ASE_LSP_CAR(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)
{
lsp->errnum = ASE_LSP_ERR_BAD_ARG;
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)));
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));
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));
if (ret == ASE_NULL) return ASE_NULL;
tmp = ASE_LSP_CDR(tmp);
}
if (tmp != lsp->mem->nil) {
if (tmp != lsp->mem->nil)
{
lsp->errnum = ASE_LSP_ERR_BAD_ARG;
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));
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)));
if (tmp == ASE_NULL) return ASE_NULL;
return tmp;
}
else {
else
{
ase_lsp_obj_t* res = lsp->mem->nil;
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));
if (res == ASE_NULL) return ASE_NULL;
tmp = ASE_LSP_CDR(tmp);
}
if (tmp != lsp->mem->nil) {
if (tmp != lsp->mem->nil)
{
lsp->errnum = ASE_LSP_ERR_BAD_ARG;
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;
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)
return ASE_NULL;
tmp = ASE_LSP_CDR(tmp);
}
if (tmp != lsp->mem->nil) {
if (tmp != lsp->mem->nil)
{
lsp->errnum = ASE_LSP_ERR_BAD_ARG;
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 == 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;
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 == 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;
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));
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;
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)));
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;
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;
while (p != lsp->mem->nil) {
while (p != lsp->mem->nil)
{
ASE_LSP_ASSERT (lsp, ASE_LSP_TYPE(p) == ASE_LSP_OBJ_CONS);
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;
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;
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)));
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;
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_
@ -44,11 +44,11 @@ ase_lsp_obj_t* ase_lsp_prim_le (ase_lsp_t* lsp, ase_lsp_obj_t* args);
/*---------------------
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_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_divide (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_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_mul (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_mod (ase_lsp_t* lsp, ase_lsp_obj_t* args);
#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>
@ -136,7 +136,7 @@ ase_lsp_obj_t* ase_lsp_prim_minus (ase_lsp_t* lsp, ase_lsp_obj_t* args)
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_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;
}
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_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;
}
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_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>
#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) \
do { \
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];
if (lsp->output_func == ASE_NULL) {
if (lsp->output_func == ASE_NULL)
{
lsp->errnum = ASE_LSP_ERR_OUTPUT_NOT_ATTACHED;
return -1;
}
switch (ASE_LSP_TYPE(obj)) {
case ASE_LSP_OBJ_NIL:
OUTPUT_STR (lsp, ASE_T("nil"));
break;
case ASE_LSP_OBJ_TRUE:
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
switch (ASE_LSP_TYPE(obj))
{
case ASE_LSP_OBJ_NIL:
OUTPUT_STR (lsp, ASE_T("nil"));
break;
OUTPUT_STR (lsp, buf);
break;
case ASE_LSP_OBJ_REAL:
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));
}
case ASE_LSP_OBJ_TRUE:
OUTPUT_STR (lsp, ASE_T("t"));
break;
OUTPUT_STR (lsp, buf);
break;
case ASE_LSP_OBJ_SYM:
OUTPUT_STR (lsp, ASE_LSP_SYMPTR(obj));
break;
case ASE_LSP_OBJ_STR:
OUTPUT_STR (lsp, ASE_LSP_STRPTR(obj));
break;
case ASE_LSP_OBJ_CONS:
case ASE_LSP_OBJ_INT:
#if defined(__BORLANDC__) || defined(_MSC_VER)
lsp->syscas.sprintf (
buf, ase_countof(buf),
ASE_T("%I64d"), (__int64)ASE_LSP_IVALUE(obj));
#elif defined(vax) || defined(__vax) || defined(_SCO_DS)
lsp->syscas.sprintf (
buf, ase_countof(buf),
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;
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);
if (prt_cons_par) OUTPUT_STR (lsp, ASE_T(")"));
break;
}
break;
case ASE_LSP_OBJ_FUNC:
/*OUTPUT_STR (lsp, ASE_T("func"));*/
OUTPUT_STR (lsp, ASE_T("(lambda "));
if (__print (lsp, ASE_LSP_FFORMAL(obj), ase_true) == -1) return -1;
OUTPUT_STR (lsp, ASE_T(" "));
if (__print (lsp, ASE_LSP_FBODY(obj), ase_false) == -1) return -1;
OUTPUT_STR (lsp, ASE_T(")"));
break;
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;
OUTPUT_STR (lsp, ASE_T(" "));
if (__print (lsp, ASE_LSP_FBODY(obj), ase_false) == -1) return -1;
OUTPUT_STR (lsp, ASE_T(")"));
break;
case ASE_LSP_OBJ_PRIM:
OUTPUT_STR (lsp, ASE_T("prim"));
break;
default:
lsp->syscas.sprintf (buf, ase_countof(buf),
ASE_T("unknown object type: %d"), ASE_LSP_TYPE(obj));
OUTPUT_STR (lsp, buf);
case ASE_LSP_OBJ_FUNC:
/*OUTPUT_STR (lsp, ASE_T("func"));*/
OUTPUT_STR (lsp, ASE_T("(lambda "));
if (__print (lsp, ASE_LSP_FFORMAL(obj), ase_true) == -1) return -1;
OUTPUT_STR (lsp, ASE_T(" "));
if (__print (lsp, ASE_LSP_FBODY(obj), ase_false) == -1) return -1;
OUTPUT_STR (lsp, ASE_T(")"));
break;
case ASE_LSP_OBJ_MACRO:
OUTPUT_STR (lsp, ASE_T("(macro "));
if (__print (lsp, ASE_LSP_FFORMAL(obj), ase_true) == -1) return -1;
OUTPUT_STR (lsp, ASE_T(" "));
if (__print (lsp, ASE_LSP_FBODY(obj), ase_false) == -1) return -1;
OUTPUT_STR (lsp, ASE_T(")"));
break;
case ASE_LSP_OBJ_PRIM:
OUTPUT_STR (lsp, ASE_T("prim"));
break;
default:
lsp->syscas.sprintf (buf, ase_countof(buf),
ASE_T("unknown object type: %d"), ASE_LSP_TYPE(obj));
OUTPUT_STR (lsp, buf);
}
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>
@ -12,12 +12,12 @@
(c) == ASE_T('=') || (c) == ASE_T('_') || \
(c) == ASE_T('?'))
#define TOKEN_CLEAR(lsp) ase_lsp_name_clear (&(lsp)->token.name)
#define TOKEN_TYPE(lsp) (lsp)->token.type
#define TOKEN_IVALUE(lsp) (lsp)->token.ivalue
#define TOKEN_RVALUE(lsp) (lsp)->token.rvalue
#define TOKEN_SVALUE(lsp) (lsp)->token.name.buf
#define TOKEN_SLENGTH(lsp) (lsp)->token.name.size
#define TOKEN_CLEAR(lsp) ase_lsp_name_clear (&(lsp)->token.name)
#define TOKEN_TYPE(lsp) (lsp)->token.type
#define TOKEN_IVAL(lsp) (lsp)->token.ival
#define TOKEN_RVAL(lsp) (lsp)->token.rval
#define TOKEN_SVAL(lsp) (lsp)->token.name.buf
#define TOKEN_SLEN(lsp) (lsp)->token.name.size
#define TOKEN_ADD_CHAR(lsp,ch) do { \
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))
{
case TOKEN_END:
lsp->errnum = ASE_LSP_ERR_END;
return ASE_NULL;
case TOKEN_LPAREN:
NEXT_TOKEN (lsp);
return read_list (lsp);
case TOKEN_QUOTE:
NEXT_TOKEN (lsp);
return read_quote (lsp);
case TOKEN_INT:
obj = ase_lsp_makeintobj (lsp->mem, TOKEN_IVALUE(lsp));
if (obj == ASE_NULL) lsp->errnum = ASE_LSP_ENOMEM;
ase_lsp_lockobj (lsp, obj);
return obj;
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));
case TOKEN_END:
lsp->errnum = ASE_LSP_ERR_END;
return ASE_NULL;
case TOKEN_LPAREN:
NEXT_TOKEN (lsp);
return read_list (lsp);
case TOKEN_QUOTE:
NEXT_TOKEN (lsp);
return read_quote (lsp);
case TOKEN_INT:
obj = ase_lsp_makeintobj (lsp->mem, TOKEN_IVAL(lsp));
if (obj == ASE_NULL) lsp->errnum = ASE_LSP_ENOMEM;
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;
@ -235,6 +241,7 @@ static ase_lsp_obj_t* read_quote (ase_lsp_t* lsp)
static int read_char (ase_lsp_t* lsp)
{
ase_ssize_t n;
ase_char_t c;
if (lsp->input_func == ASE_NULL)
{
@ -242,7 +249,7 @@ static int read_char (ase_lsp_t* lsp)
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)
{
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;
else lsp->curc = c;
return 0;
}
@ -349,12 +357,12 @@ static int read_token (ase_lsp_t* lsp)
static int read_number (ase_lsp_t* lsp, int negative)
{
ase_long_t ivalue = 0;
ase_real_t rvalue = 0.;
ase_long_t ival = 0;
ase_real_t rval = 0.;
do
{
ivalue = ivalue * 10 + (lsp->curc - ASE_T('0'));
ival = ival * 10 + (lsp->curc - ASE_T('0'));
TOKEN_ADD_CHAR (lsp, lsp->curc);
NEXT_CHAR (lsp);
}
@ -366,23 +374,23 @@ static int read_number (ase_lsp_t* lsp, int negative)
ase_real_t fraction = 0.1;
NEXT_CHAR (lsp);
rvalue = (ase_real_t)ivalue;
rval = (ase_real_t)ival;
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;
NEXT_CHAR (lsp);
}
TOKEN_RVALUE(lsp) = rvalue;
TOKEN_RVAL(lsp) = rval;
TOKEN_TYPE(lsp) = TOKEN_REAL;
if (negative) rvalue *= -1;
if (negative) rval *= -1;
}
else {
TOKEN_IVALUE(lsp) = ivalue;
TOKEN_IVAL(lsp) = ival;
TOKEN_TYPE(lsp) = TOKEN_INT;
if (negative) ivalue *= -1;
if (negative) ival *= -1;
}
return 0;

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

@ -5,14 +5,21 @@
#include <xp/bas/locale.h>
#include <xp/bas/sio.h>
#include <tchar.h>
#include <string.h>
#include <wctype.h>
#include <stdlib.h>
#if defined(_WIN32) && defined(_MSC_VER) && defined(_DEBUG)
#define _CRTDBG_MAP_ALLOC
#include <crtdbg.h>
#endif
#ifdef __linux
#include <mcheck.h>
#endif
static xp_ssize_t get_input (int cmd, void* arg, xp_char_t* data, xp_size_t size)
{
xp_ssize_t n;
@ -207,13 +214,18 @@ int __main (int argc, xp_char_t* argv[])
xp_cli_t* cli;
int mem, inc;
ase_lsp_syscas_t syscas;
#ifdef _WIN32
syscas_data_t syscas_data;
#endif
/*
if (xp_setlocale () == -1) {
xp_fprintf (xp_stderr,
XP_T("error: cannot set locale\n"));
return -1;
}
*/
if ((cli = parse_cli (argc, argv)) == XP_NULL) return -1;
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.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);
if (lsp == XP_NULL)
{
#ifdef _WIN32
HeapDestroy (syscas_data.heap);
#endif
xp_fprintf (xp_stderr,
XP_T("error: cannot create a lsp instance\n"));
return -1;
@ -285,31 +312,36 @@ int __main (int argc, xp_char_t* argv[])
while (1)
{
xp_sio_puts (xp_sio_out, XP_T("["));
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);
obj = ase_lsp_read (lsp);
if (obj == XP_NULL)
{
int errnum = ase_lsp_geterrnum(lsp);
const xp_char_t* errstr;
if (errnum != ASE_LSP_ERR_END &&
errnum != ASE_LSP_ERR_ABORT)
{
errstr = ase_lsp_geterrstr(errnum);
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;
continue;
}
if ((obj = ase_lsp_eval (lsp, obj)) != XP_NULL) {
if ((obj = ase_lsp_eval (lsp, obj)) != XP_NULL)
{
ase_lsp_print (lsp, obj);
xp_sio_puts (xp_sio_out, XP_T("\n"));
}
else {
else
{
int errnum;
const xp_char_t* errstr;
@ -318,13 +350,15 @@ int __main (int argc, xp_char_t* argv[])
errstr = ase_lsp_geterrstr(errnum);
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);
#ifdef _WIN32
HeapDestroy (syscas_data.heap);
#endif
return 0;
}