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

*** empty log message ***

Browse Source
This commit is contained in:
hyung-hwan 2005-09-20 12:06:51 +00:00
parent add76da3fa
commit b5cbca0e8d
14 changed files with 473 additions and 168 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
ase/lsp/eval.c
View File

@ -1,5 +1,5 @@
/*
* $Id: eval.c,v 1.11 2005-09-20 09:17:06 bacon Exp $
* $Id: eval.c,v 1.12 2005-09-20 12:06:51 bacon Exp $
*/
#include <xp/lsp/lsp.h>
@ -31,7 +31,8 @@ xp_lsp_obj_t* xp_lsp_eval (xp_lsp_t* lsp, xp_lsp_obj_t* obj)
}
*/
if ((assoc = xp_lsp_lookup(lsp->mem, obj)) == XP_NULL) {
assoc = xp_lsp_lookup(lsp->mem, obj);
if (assoc == XP_NULL || assoc->value == XP_NULL) {
if (lsp->opt_undef_symbol) {
lsp->errnum = XP_LSP_ERR_UNDEF_SYMBOL;
return XP_NULL;
@ -121,8 +122,8 @@ static xp_lsp_obj_t* eval_cons (xp_lsp_t* lsp, xp_lsp_obj_t* cons)
return apply (lsp, func, cdr);
}
else if (XP_LSP_TYPE(func) == XP_LSP_OBJ_PRIM) {
// primitive function
return XP_LSP_PIMPL(func) (lsp, cdr);
/* primitive function */
return XP_LSP_PRIM(func) (lsp, cdr);
}
else {
//TODO: emit the name for debugging

6
ase/lsp/init.c
View File

@ -1,5 +1,5 @@
/*
* $Id: init.c,v 1.8 2005-09-20 11:19:15 bacon Exp $
* $Id: init.c,v 1.9 2005-09-20 12:06:51 bacon Exp $
*/
#include <xp/lsp/lsp.h>
@ -150,11 +150,15 @@ static int __add_builtin_prims (xp_lsp_t* lsp)
ADD_PRIM (lsp, XP_TEXT("let"), xp_lsp_prim_let);
ADD_PRIM (lsp, XP_TEXT("let*"), xp_lsp_prim_letx);
ADD_PRIM (lsp, XP_TEXT("="), xp_lsp_prim_eq);
ADD_PRIM (lsp, XP_TEXT(">"), xp_lsp_prim_gt);
ADD_PRIM (lsp, XP_TEXT("<"), xp_lsp_prim_lt);
ADD_PRIM (lsp, XP_TEXT("+"), xp_lsp_prim_plus);
ADD_PRIM (lsp, XP_TEXT("-"), xp_lsp_prim_minus);
ADD_PRIM (lsp, XP_TEXT("*"), xp_lsp_prim_multiply);
ADD_PRIM (lsp, XP_TEXT("/"), xp_lsp_prim_divide);
ADD_PRIM (lsp, XP_TEXT("%"), xp_lsp_prim_modulus);
return 0;
}

2
ase/lsp/makefile.cl
View File

@ -1,6 +1,6 @@
SRCS = name.c token.c array.c mem.c env.c error.c \
init.c read.c eval.c print.c \
prim.c prim_prog.c prim_let.c
prim.c prim_prog.c prim_let.c prim_compar.c prim_math.c
OBJS = $(SRCS:.c=.obj)
OUT = xplsp.lib

2
ase/lsp/makefile.in
View File

@ -1,6 +1,6 @@
SRCS = name.c token.c array.c mem.c env.c error.c \
init.c read.c eval.c print.c \
prim.c prim_prog.c prim_let.c prim_math.c
prim.c prim_prog.c prim_let.c prim_compar.c prim_math.c
OBJS = $(SRCS:.c=.o)
OUT = libxplsp.a

4
ase/lsp/mem.c
View File

@ -1,5 +1,5 @@
/*
* $Id: mem.c,v 1.6 2005-09-20 11:19:15 bacon Exp $
* $Id: mem.c,v 1.7 2005-09-20 12:06:51 bacon Exp $
*/
#include <xp/lsp/mem.h>
@ -536,7 +536,7 @@ xp_lsp_obj_t* xp_lsp_make_prim (xp_lsp_mem_t* mem, void* impl)
obj = xp_lsp_alloc (mem, XP_LSP_OBJ_PRIM, xp_sizeof(xp_lsp_obj_prim_t));
if (obj == XP_NULL) return XP_NULL;
XP_LSP_PIMPL(obj) = impl;
XP_LSP_PRIM(obj) = impl;
return obj;
}

6
ase/lsp/obj.h
View File

@ -1,5 +1,5 @@
/*
* $Id: obj.h,v 1.2 2005-09-20 11:19:15 bacon Exp $
* $Id: obj.h,v 1.3 2005-09-20 12:06:51 bacon Exp $
*/
#ifndef _XP_LSP_OBJ_H_
@ -100,7 +100,7 @@ struct xp_lsp_obj_macro_t
struct xp_lsp_obj_prim_t
{
XP_LSP_OBJ_HEADER;
void* impl; // xp_lsp_prim_t
void* impl; /* xp_lsp_prim_t */
};
typedef struct xp_lsp_obj_t xp_lsp_obj_t;
@ -146,6 +146,6 @@ typedef struct xp_lsp_obj_prim_t xp_lsp_obj_prim_t;
#define XP_LSP_FBODY(x) (((xp_lsp_obj_func_t*)x)->body)
#define XP_LSP_MFORMAL(x) (((xp_lsp_obj_macro_t*)x)->formal)
#define XP_LSP_MBODY(x) (((xp_lsp_obj_macro_t*)x)->body)
#define XP_LSP_PIMPL(x) ((xp_lsp_prim_t)(((xp_lsp_obj_prim_t*)x)->impl))
#define XP_LSP_PRIM(x) ((xp_lsp_prim_t)(((xp_lsp_obj_prim_t*)x)->impl))
#endif

142
ase/lsp/prim.c
View File

@ -1,5 +1,5 @@
/*
* $Id: prim.c,v 1.6 2005-09-20 11:19:15 bacon Exp $
* $Id: prim.c,v 1.7 2005-09-20 12:06:51 bacon Exp $
*/
#include <xp/lsp/lsp.h>
@ -44,8 +44,6 @@ static int __add_prim (xp_lsp_mem_t* mem,
return 0;
}
xp_lsp_obj_t* xp_lsp_prim_abort (xp_lsp_t* lsp, xp_lsp_obj_t* args)
{
XP_LSP_PRIM_CHECK_ARG_COUNT (lsp, args, 0, 0);
@ -173,9 +171,11 @@ xp_lsp_obj_t* xp_lsp_prim_while (xp_lsp_t* lsp, xp_lsp_obj_t* args)
tmp = XP_LSP_CDR(args);
while (XP_LSP_TYPE(tmp) == XP_LSP_OBJ_CONS) {
if (xp_lsp_eval(lsp, XP_LSP_CAR(tmp)) == XP_NULL) return XP_NULL;
if (xp_lsp_eval(lsp, XP_LSP_CAR(tmp)) == XP_NULL)
return XP_NULL;
tmp = XP_LSP_CDR(tmp);
}
if (tmp != lsp->mem->nil) {
lsp->errnum = XP_LSP_ERR_BAD_ARG;
return XP_NULL;
@ -397,137 +397,3 @@ xp_lsp_obj_t* xp_lsp_prim_demac (xp_lsp_t* lsp, xp_lsp_obj_t* args)
}
return mac;
}
xp_lsp_obj_t* xp_lsp_prim_gt (xp_lsp_t* lsp, xp_lsp_obj_t* args)
{
xp_lsp_obj_t* p1, * p2;
int res;
XP_LSP_PRIM_CHECK_ARG_COUNT (lsp, args, 2, 2);
xp_assert (XP_LSP_TYPE(args) == XP_LSP_OBJ_CONS);
p1 = xp_lsp_eval (lsp, XP_LSP_CAR(args));
if (p1 == XP_NULL) return XP_NULL;
// TODO: lock p1....
p2 = xp_lsp_eval (lsp, XP_LSP_CAR(XP_LSP_CDR(args)));
if (p2 == XP_NULL) return XP_NULL;
if (XP_LSP_TYPE(p1) == XP_LSP_OBJ_INT) {
if (XP_LSP_TYPE(p2) == XP_LSP_OBJ_INT) {
res = XP_LSP_IVALUE(p1) > XP_LSP_IVALUE(p2);
}
else if (XP_LSP_TYPE(p2) == XP_LSP_OBJ_REAL) {
res = XP_LSP_IVALUE(p1) > XP_LSP_RVALUE(p2);
}
else {
lsp->errnum = XP_LSP_ERR_BAD_VALUE;
return XP_NULL;
}
}
else if (XP_LSP_TYPE(p1) == XP_LSP_OBJ_REAL) {
if (XP_LSP_TYPE(p2) == XP_LSP_OBJ_INT) {
res = XP_LSP_RVALUE(p1) > XP_LSP_IVALUE(p2);
}
else if (XP_LSP_TYPE(p2) == XP_LSP_OBJ_REAL) {
res = XP_LSP_RVALUE(p1) > XP_LSP_RVALUE(p2);
}
else {
lsp->errnum = XP_LSP_ERR_BAD_VALUE;
return XP_NULL;
}
}
else if (XP_LSP_TYPE(p1) == XP_LSP_OBJ_SYMBOL) {
if (XP_LSP_TYPE(p2) == XP_LSP_OBJ_SYMBOL) {
res = xp_lsp_comp_symbol2 (
p1, XP_LSP_SYMVALUE(p2), XP_LSP_SYMLEN(p2)) > 0;
}
else {
lsp->errnum = XP_LSP_ERR_BAD_VALUE;
return XP_NULL;
}
}
else if (XP_LSP_TYPE(p1) == XP_LSP_OBJ_STRING) {
if (XP_LSP_TYPE(p2) == XP_LSP_OBJ_STRING) {
res = xp_lsp_comp_string2 (
p1, XP_LSP_STRVALUE(p2), XP_LSP_STRLEN(p2)) > 0;
}
else {
lsp->errnum = XP_LSP_ERR_BAD_VALUE;
return XP_NULL;
}
}
else {
lsp->errnum = XP_LSP_ERR_BAD_VALUE;
return XP_NULL;
}
return (res)? lsp->mem->t: lsp->mem->nil;
}
xp_lsp_obj_t* xp_lsp_prim_lt (xp_lsp_t* lsp, xp_lsp_obj_t* args)
{
xp_lsp_obj_t* p1, * p2;
int res;
XP_LSP_PRIM_CHECK_ARG_COUNT (lsp, args, 2, 2);
xp_assert (XP_LSP_TYPE(args) == XP_LSP_OBJ_CONS);
p1 = xp_lsp_eval (lsp, XP_LSP_CAR(args));
if (p1 == XP_NULL) return XP_NULL;
// TODO: lock p1....
p2 = xp_lsp_eval (lsp, XP_LSP_CAR(XP_LSP_CDR(args)));
if (p2 == XP_NULL) return XP_NULL;
if (XP_LSP_TYPE(p1) == XP_LSP_OBJ_INT) {
if (XP_LSP_TYPE(p2) == XP_LSP_OBJ_INT) {
res = XP_LSP_IVALUE(p1) < XP_LSP_IVALUE(p2);
}
else if (XP_LSP_TYPE(p2) == XP_LSP_OBJ_REAL) {
res = XP_LSP_IVALUE(p1) < XP_LSP_RVALUE(p2);
}
else {
lsp->errnum = XP_LSP_ERR_BAD_VALUE;
return XP_NULL;
}
}
else if (XP_LSP_TYPE(p1) == XP_LSP_OBJ_REAL) {
if (XP_LSP_TYPE(p2) == XP_LSP_OBJ_INT) {
res = XP_LSP_RVALUE(p1) < XP_LSP_IVALUE(p2);
}
else if (XP_LSP_TYPE(p2) == XP_LSP_OBJ_REAL) {
res = XP_LSP_RVALUE(p1) < XP_LSP_RVALUE(p2);
}
else {
lsp->errnum = XP_LSP_ERR_BAD_VALUE;
return XP_NULL;
}
}
else if (XP_LSP_TYPE(p1) == XP_LSP_OBJ_SYMBOL) {
if (XP_LSP_TYPE(p2) == XP_LSP_OBJ_SYMBOL) {
res = xp_lsp_comp_symbol2 (
p1, XP_LSP_SYMVALUE(p2), XP_LSP_SYMLEN(p2)) < 0;
}
else {
lsp->errnum = XP_LSP_ERR_BAD_VALUE;
return XP_NULL;
}
}
else if (XP_LSP_TYPE(p1) == XP_LSP_OBJ_STRING) {
if (XP_LSP_TYPE(p2) == XP_LSP_OBJ_STRING) {
res = xp_lsp_comp_string2 (
p1, XP_LSP_STRVALUE(p2), XP_LSP_STRLEN(p2)) < 0;
}
else {
lsp->errnum = XP_LSP_ERR_BAD_VALUE;
return XP_NULL;
}
}
else {
lsp->errnum = XP_LSP_ERR_BAD_VALUE;
return XP_NULL;
}
return (res)? lsp->mem->t: lsp->mem->nil;
}

12
ase/lsp/prim.h
View File

@ -1,5 +1,5 @@
/*
* $Id: prim.h,v 1.3 2005-09-20 11:19:15 bacon Exp $
* $Id: prim.h,v 1.4 2005-09-20 12:06:51 bacon Exp $
*/
#ifndef _XP_LSP_PRIM_H_
@ -32,11 +32,21 @@ xp_lsp_obj_t* xp_lsp_prim_demac (xp_lsp_t* lsp, xp_lsp_obj_t* args);
xp_lsp_obj_t* xp_lsp_prim_let (xp_lsp_t* lsp, xp_lsp_obj_t* args);
xp_lsp_obj_t* xp_lsp_prim_letx (xp_lsp_t* lsp, xp_lsp_obj_t* args);
/*---------------------
prim_compar.c
---------------------*/
xp_lsp_obj_t* xp_lsp_prim_eq (xp_lsp_t* lsp, xp_lsp_obj_t* args);
xp_lsp_obj_t* xp_lsp_prim_gt (xp_lsp_t* lsp, xp_lsp_obj_t* args);
xp_lsp_obj_t* xp_lsp_prim_lt (xp_lsp_t* lsp, xp_lsp_obj_t* args);
/*---------------------
prim_math.c
---------------------*/
xp_lsp_obj_t* xp_lsp_prim_plus (xp_lsp_t* lsp, xp_lsp_obj_t* args);
xp_lsp_obj_t* xp_lsp_prim_minus (xp_lsp_t* lsp, xp_lsp_obj_t* args);
xp_lsp_obj_t* xp_lsp_prim_multiply (xp_lsp_t* lsp, xp_lsp_obj_t* args);
xp_lsp_obj_t* xp_lsp_prim_divide (xp_lsp_t* lsp, xp_lsp_obj_t* args);
xp_lsp_obj_t* xp_lsp_prim_modulus (xp_lsp_t* lsp, xp_lsp_obj_t* args);
#ifdef __cplusplus
}

207
ase/lsp/prim_compar.c Normal file
View File

@ -0,0 +1,207 @@
/*
* $Id: prim_compar.c,v 1.1 2005-09-20 12:06:51 bacon Exp $
*/
#include <xp/lsp/prim.h>
#include <xp/bas/assert.h>
xp_lsp_obj_t* xp_lsp_prim_eq (xp_lsp_t* lsp, xp_lsp_obj_t* args)
{
xp_lsp_obj_t* p1, * p2;
int res;
XP_LSP_PRIM_CHECK_ARG_COUNT (lsp, args, 2, 2);
xp_assert (XP_LSP_TYPE(args) == XP_LSP_OBJ_CONS);
p1 = xp_lsp_eval (lsp, XP_LSP_CAR(args));
if (p1 == XP_NULL) return XP_NULL;
// TODO: lock p1....
p2 = xp_lsp_eval (lsp, XP_LSP_CAR(XP_LSP_CDR(args)));
if (p2 == XP_NULL) return XP_NULL;
if (XP_LSP_TYPE(p1) == XP_LSP_OBJ_INT) {
if (XP_LSP_TYPE(p2) == XP_LSP_OBJ_INT) {
res = XP_LSP_IVALUE(p1) == XP_LSP_IVALUE(p2);
}
else if (XP_LSP_TYPE(p2) == XP_LSP_OBJ_REAL) {
res = XP_LSP_IVALUE(p1) == XP_LSP_RVALUE(p2);
}
else {
lsp->errnum = XP_LSP_ERR_BAD_VALUE;
return XP_NULL;
}
}
else if (XP_LSP_TYPE(p1) == XP_LSP_OBJ_REAL) {
if (XP_LSP_TYPE(p2) == XP_LSP_OBJ_INT) {
res = XP_LSP_RVALUE(p1) == XP_LSP_IVALUE(p2);
}
else if (XP_LSP_TYPE(p2) == XP_LSP_OBJ_REAL) {
res = XP_LSP_RVALUE(p1) == XP_LSP_RVALUE(p2);
}
else {
lsp->errnum = XP_LSP_ERR_BAD_VALUE;
return XP_NULL;
}
}
else if (XP_LSP_TYPE(p1) == XP_LSP_OBJ_SYMBOL) {
if (XP_LSP_TYPE(p2) == XP_LSP_OBJ_SYMBOL) {
res = xp_lsp_comp_symbol2 (
p1, XP_LSP_SYMVALUE(p2), XP_LSP_SYMLEN(p2)) == 0;
}
else {
lsp->errnum = XP_LSP_ERR_BAD_VALUE;
return XP_NULL;
}
}
else if (XP_LSP_TYPE(p1) == XP_LSP_OBJ_STRING) {
if (XP_LSP_TYPE(p2) == XP_LSP_OBJ_STRING) {
res = xp_lsp_comp_string2 (
p1, XP_LSP_STRVALUE(p2), XP_LSP_STRLEN(p2)) == 0;
}
else {
lsp->errnum = XP_LSP_ERR_BAD_VALUE;
return XP_NULL;
}
}
else {
lsp->errnum = XP_LSP_ERR_BAD_VALUE;
return XP_NULL;
}
return (res)? lsp->mem->t: lsp->mem->nil;
}
xp_lsp_obj_t* xp_lsp_prim_gt (xp_lsp_t* lsp, xp_lsp_obj_t* args)
{
xp_lsp_obj_t* p1, * p2;
int res;
XP_LSP_PRIM_CHECK_ARG_COUNT (lsp, args, 2, 2);
xp_assert (XP_LSP_TYPE(args) == XP_LSP_OBJ_CONS);
p1 = xp_lsp_eval (lsp, XP_LSP_CAR(args));
if (p1 == XP_NULL) return XP_NULL;
// TODO: lock p1....
p2 = xp_lsp_eval (lsp, XP_LSP_CAR(XP_LSP_CDR(args)));
if (p2 == XP_NULL) return XP_NULL;
if (XP_LSP_TYPE(p1) == XP_LSP_OBJ_INT) {
if (XP_LSP_TYPE(p2) == XP_LSP_OBJ_INT) {
res = XP_LSP_IVALUE(p1) > XP_LSP_IVALUE(p2);
}
else if (XP_LSP_TYPE(p2) == XP_LSP_OBJ_REAL) {
res = XP_LSP_IVALUE(p1) > XP_LSP_RVALUE(p2);
}
else {
lsp->errnum = XP_LSP_ERR_BAD_VALUE;
return XP_NULL;
}
}
else if (XP_LSP_TYPE(p1) == XP_LSP_OBJ_REAL) {
if (XP_LSP_TYPE(p2) == XP_LSP_OBJ_INT) {
res = XP_LSP_RVALUE(p1) > XP_LSP_IVALUE(p2);
}
else if (XP_LSP_TYPE(p2) == XP_LSP_OBJ_REAL) {
res = XP_LSP_RVALUE(p1) > XP_LSP_RVALUE(p2);
}
else {
lsp->errnum = XP_LSP_ERR_BAD_VALUE;
return XP_NULL;
}
}
else if (XP_LSP_TYPE(p1) == XP_LSP_OBJ_SYMBOL) {
if (XP_LSP_TYPE(p2) == XP_LSP_OBJ_SYMBOL) {
res = xp_lsp_comp_symbol2 (
p1, XP_LSP_SYMVALUE(p2), XP_LSP_SYMLEN(p2)) > 0;
}
else {
lsp->errnum = XP_LSP_ERR_BAD_VALUE;
return XP_NULL;
}
}
else if (XP_LSP_TYPE(p1) == XP_LSP_OBJ_STRING) {
if (XP_LSP_TYPE(p2) == XP_LSP_OBJ_STRING) {
res = xp_lsp_comp_string2 (
p1, XP_LSP_STRVALUE(p2), XP_LSP_STRLEN(p2)) > 0;
}
else {
lsp->errnum = XP_LSP_ERR_BAD_VALUE;
return XP_NULL;
}
}
else {
lsp->errnum = XP_LSP_ERR_BAD_VALUE;
return XP_NULL;
}
return (res)? lsp->mem->t: lsp->mem->nil;
}
xp_lsp_obj_t* xp_lsp_prim_lt (xp_lsp_t* lsp, xp_lsp_obj_t* args)
{
xp_lsp_obj_t* p1, * p2;
int res;
XP_LSP_PRIM_CHECK_ARG_COUNT (lsp, args, 2, 2);
xp_assert (XP_LSP_TYPE(args) == XP_LSP_OBJ_CONS);
p1 = xp_lsp_eval (lsp, XP_LSP_CAR(args));
if (p1 == XP_NULL) return XP_NULL;
// TODO: lock p1....
p2 = xp_lsp_eval (lsp, XP_LSP_CAR(XP_LSP_CDR(args)));
if (p2 == XP_NULL) return XP_NULL;
if (XP_LSP_TYPE(p1) == XP_LSP_OBJ_INT) {
if (XP_LSP_TYPE(p2) == XP_LSP_OBJ_INT) {
res = XP_LSP_IVALUE(p1) < XP_LSP_IVALUE(p2);
}
else if (XP_LSP_TYPE(p2) == XP_LSP_OBJ_REAL) {
res = XP_LSP_IVALUE(p1) < XP_LSP_RVALUE(p2);
}
else {
lsp->errnum = XP_LSP_ERR_BAD_VALUE;
return XP_NULL;
}
}
else if (XP_LSP_TYPE(p1) == XP_LSP_OBJ_REAL) {
if (XP_LSP_TYPE(p2) == XP_LSP_OBJ_INT) {
res = XP_LSP_RVALUE(p1) < XP_LSP_IVALUE(p2);
}
else if (XP_LSP_TYPE(p2) == XP_LSP_OBJ_REAL) {
res = XP_LSP_RVALUE(p1) < XP_LSP_RVALUE(p2);
}
else {
lsp->errnum = XP_LSP_ERR_BAD_VALUE;
return XP_NULL;
}
}
else if (XP_LSP_TYPE(p1) == XP_LSP_OBJ_SYMBOL) {
if (XP_LSP_TYPE(p2) == XP_LSP_OBJ_SYMBOL) {
res = xp_lsp_comp_symbol2 (
p1, XP_LSP_SYMVALUE(p2), XP_LSP_SYMLEN(p2)) < 0;
}
else {
lsp->errnum = XP_LSP_ERR_BAD_VALUE;
return XP_NULL;
}
}
else if (XP_LSP_TYPE(p1) == XP_LSP_OBJ_STRING) {
if (XP_LSP_TYPE(p2) == XP_LSP_OBJ_STRING) {
res = xp_lsp_comp_string2 (
p1, XP_LSP_STRVALUE(p2), XP_LSP_STRLEN(p2)) < 0;
}
else {
lsp->errnum = XP_LSP_ERR_BAD_VALUE;
return XP_NULL;
}
}
else {
lsp->errnum = XP_LSP_ERR_BAD_VALUE;
return XP_NULL;
}
return (res)? lsp->mem->t: lsp->mem->nil;
}

206
ase/lsp/prim_math.c
View File

@ -1,5 +1,5 @@
/*
* $Id: prim_math.c,v 1.3 2005-09-20 11:19:15 bacon Exp $
* $Id: prim_math.c,v 1.4 2005-09-20 12:06:51 bacon Exp $
*/
#include <xp/lsp/prim.h>
@ -9,38 +9,53 @@ xp_lsp_obj_t* xp_lsp_prim_plus (xp_lsp_t* lsp, xp_lsp_obj_t* args)
{
xp_lsp_obj_t* body, * tmp;
xp_lsp_int_t ivalue = 0;
xp_lsp_real_t rvalue = 0.;
xp_lsp_real_t rvalue = .0;
xp_bool_t realnum = xp_false;
XP_LSP_PRIM_CHECK_ARG_COUNT (lsp, args, 1, XP_LSP_PRIM_MAX_ARG_COUNT);
xp_assert (XP_LSP_TYPE(args) == XP_LSP_OBJ_CONS);
body = args;
//while (body != lsp->mem->nil) {
while (XP_LSP_TYPE(body) == XP_LSP_OBJ_CONS) {
tmp = xp_lsp_eval (lsp, XP_LSP_CAR(body));
if (tmp == XP_NULL) return XP_NULL;
if (tmp == XP_NULL) {
/*lsp->errnum = XP_LSP_ERR_BAD_VALUE; */
return XP_NULL;
}
if (XP_LSP_TYPE(tmp) == XP_LSP_OBJ_INT) {
if (body == args) {
xp_assert (realnum == xp_false);
ivalue = XP_LSP_IVALUE(tmp);
}
else {
if (!realnum)
ivalue = ivalue + XP_LSP_IVALUE(tmp);
else
rvalue = rvalue + XP_LSP_IVALUE(tmp);
}
}
else if (XP_LSP_TYPE(tmp) == XP_LSP_OBJ_REAL) {
if (body == args) {
xp_assert (realnum == xp_false);
realnum = xp_true;
rvalue = XP_LSP_RVALUE(tmp);
}
else {
if (!realnum) {
realnum = xp_true;
rvalue = (xp_lsp_real_t)ivalue;
}
rvalue = rvalue + XP_LSP_RVALUE(tmp);
}
}
else {
lsp->errnum = XP_LSP_ERR_BAD_VALUE;
return XP_NULL;
}
body = XP_LSP_CDR(body);
}
@ -61,7 +76,7 @@ xp_lsp_obj_t* xp_lsp_prim_minus (xp_lsp_t* lsp, xp_lsp_obj_t* args)
{
xp_lsp_obj_t* body, * tmp;
xp_lsp_int_t ivalue = 0;
xp_lsp_real_t rvalue = 0.;
xp_lsp_real_t rvalue = .0;
xp_bool_t realnum = xp_false;
XP_LSP_PRIM_CHECK_ARG_COUNT (lsp, args, 1, XP_LSP_PRIM_MAX_ARG_COUNT);
@ -122,3 +137,182 @@ xp_lsp_obj_t* xp_lsp_prim_minus (xp_lsp_t* lsp, xp_lsp_obj_t* args)
return tmp;
}
xp_lsp_obj_t* xp_lsp_prim_multiply (xp_lsp_t* lsp, xp_lsp_obj_t* args)
{
xp_lsp_obj_t* body, * tmp;
xp_lsp_int_t ivalue = 0;
xp_lsp_real_t rvalue = .0;
xp_bool_t realnum = xp_false;
XP_LSP_PRIM_CHECK_ARG_COUNT (lsp, args, 1, XP_LSP_PRIM_MAX_ARG_COUNT);
xp_assert (XP_LSP_TYPE(args) == XP_LSP_OBJ_CONS);
body = args;
//while (body != lsp->mem->nil) {
while (XP_LSP_TYPE(body) == XP_LSP_OBJ_CONS) {
tmp = xp_lsp_eval (lsp, XP_LSP_CAR(body));
if (tmp == XP_NULL) return XP_NULL;
if (XP_LSP_TYPE(tmp) == XP_LSP_OBJ_INT) {
if (body == args) {
xp_assert (realnum == xp_false);
ivalue = XP_LSP_IVALUE(tmp);
}
else {
if (!realnum)
ivalue = ivalue * XP_LSP_IVALUE(tmp);
else
rvalue = rvalue * XP_LSP_IVALUE(tmp);
}
}
else if (XP_LSP_TYPE(tmp) == XP_LSP_OBJ_REAL) {
if (body == args) {
xp_assert (realnum == xp_false);
realnum = xp_true;
rvalue = XP_LSP_RVALUE(tmp);
}
else {
if (!realnum) {
realnum = xp_true;
rvalue = (xp_lsp_real_t)ivalue;
}
rvalue = rvalue * XP_LSP_RVALUE(tmp);
}
}
else {
lsp->errnum = XP_LSP_ERR_BAD_VALUE;
return XP_NULL;
}
body = XP_LSP_CDR(body);
}
xp_assert (body == lsp->mem->nil);
tmp = (realnum)?
xp_lsp_make_real (lsp->mem, rvalue):
xp_lsp_make_int (lsp->mem, ivalue);
if (tmp == XP_NULL) {
lsp->errnum = XP_LSP_ERR_MEM;
return XP_NULL;
}
return tmp;
}
xp_lsp_obj_t* xp_lsp_prim_divide (xp_lsp_t* lsp, xp_lsp_obj_t* args)
{
xp_lsp_obj_t* body, * tmp;
xp_lsp_int_t ivalue = 0;
xp_lsp_real_t rvalue = .0;
xp_bool_t realnum = xp_false;
XP_LSP_PRIM_CHECK_ARG_COUNT (lsp, args, 1, XP_LSP_PRIM_MAX_ARG_COUNT);
xp_assert (XP_LSP_TYPE(args) == XP_LSP_OBJ_CONS);
body = args;
//while (body != lsp->mem->nil) {
while (XP_LSP_TYPE(body) == XP_LSP_OBJ_CONS) {
tmp = xp_lsp_eval (lsp, XP_LSP_CAR(body));
if (tmp == XP_NULL) return XP_NULL;
if (XP_LSP_TYPE(tmp) == XP_LSP_OBJ_INT) {
if (body == args) {
xp_assert (realnum == xp_false);
ivalue = XP_LSP_IVALUE(tmp);
}
else {
if (!realnum)
ivalue = ivalue / XP_LSP_IVALUE(tmp);
else
rvalue = rvalue / XP_LSP_IVALUE(tmp);
}
}
else if (XP_LSP_TYPE(tmp) == XP_LSP_OBJ_REAL) {
if (body == args) {
xp_assert (realnum == xp_false);
realnum = xp_true;
rvalue = XP_LSP_RVALUE(tmp);
}
else {
if (!realnum) {
realnum = xp_true;
rvalue = (xp_lsp_real_t)ivalue;
}
rvalue = rvalue / XP_LSP_RVALUE(tmp);
}
}
else {
lsp->errnum = XP_LSP_ERR_BAD_VALUE;
return XP_NULL;
}
body = XP_LSP_CDR(body);
}
xp_assert (body == lsp->mem->nil);
tmp = (realnum)?
xp_lsp_make_real (lsp->mem, rvalue):
xp_lsp_make_int (lsp->mem, ivalue);
if (tmp == XP_NULL) {
lsp->errnum = XP_LSP_ERR_MEM;
return XP_NULL;
}
return tmp;
}
xp_lsp_obj_t* xp_lsp_prim_modulus (xp_lsp_t* lsp, xp_lsp_obj_t* args)
{
xp_lsp_obj_t* body, * tmp;
xp_lsp_int_t ivalue = 0;
XP_LSP_PRIM_CHECK_ARG_COUNT (lsp, args, 1, XP_LSP_PRIM_MAX_ARG_COUNT);
xp_assert (XP_LSP_TYPE(args) == XP_LSP_OBJ_CONS);
body = args;
//while (body != lsp->mem->nil) {
while (XP_LSP_TYPE(body) == XP_LSP_OBJ_CONS) {
tmp = xp_lsp_eval (lsp, XP_LSP_CAR(body));
if (tmp == XP_NULL) return XP_NULL;
if (XP_LSP_TYPE(tmp) == XP_LSP_OBJ_INT) {
if (body == args) {
ivalue = XP_LSP_IVALUE(tmp);
}
else {
ivalue = ivalue % XP_LSP_IVALUE(tmp);
}
}
else if (XP_LSP_TYPE(tmp) == XP_LSP_OBJ_REAL) {
if (body == args) {
ivalue = (xp_lsp_int_t)XP_LSP_RVALUE(tmp);
}
else {
ivalue = ivalue % (xp_lsp_int_t)XP_LSP_RVALUE(tmp);
}
}
else {
lsp->errnum = XP_LSP_ERR_BAD_VALUE;
return XP_NULL;
}
body = XP_LSP_CDR(body);
}
xp_assert (body == lsp->mem->nil);
tmp = xp_lsp_make_int (lsp->mem, ivalue);
if (tmp == XP_NULL) {
lsp->errnum = XP_LSP_ERR_MEM;
return XP_NULL;
}
return tmp;
}

3
ase/test/lsp/t2.lsp
View File

@ -1,4 +1,5 @@
(setq x (lambda (x) (+ x 20 30 40)))
;(setq x (lambda (x) (+ x 20 30 40)))
(defun x(x) (+ x 20 30 40))
(x 100)
(x 100)
(x 100)

8
ase/test/lsp/t3.lsp Normal file
View File

@ -0,0 +1,8 @@
; test while
(setq x 10)
(setq y 10)
(while (< x 100) (setq y (+ x y)) (setq x (+ x 1)))
x
y

7
ase/test/lsp/t4.lsp Normal file
View File

@ -0,0 +1,7 @@
;Compute the factorial of N.
(defun factorial (N)
(if (= N 1)
1
(* N (factorial (- N 1)))))
(factorial 10)

7
ase/test/lsp/t5.lsp Normal file
View File

@ -0,0 +1,7 @@
; Compute the N'th Fibonacci number.
(defun fibonacci (N)
(if (or (zerop N) (= N 1))
1
(+ (fibonacci (- N 1)) (fibonacci (- N 2)))))
(fibonacci 5)