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-21 11:52:36 +00:00
parent ae6f64ce37
commit 3edaeb4f9f
3 changed files with 213 additions and 6 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
ase/lsp/init.c
View File

@ -1,5 +1,5 @@
/*
* $Id: init.c,v 1.9 2005-09-20 12:06:51 bacon Exp $
* $Id: init.c,v 1.10 2005-09-21 11:52:36 bacon Exp $
*/
#include <xp/lsp/lsp.h>
@ -151,8 +151,11 @@ static int __add_builtin_prims (xp_lsp_t* lsp)
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_ne);
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_ge);
ADD_PRIM (lsp, XP_TEXT("<="), xp_lsp_prim_le);
ADD_PRIM (lsp, XP_TEXT("+"), xp_lsp_prim_plus);
ADD_PRIM (lsp, XP_TEXT("-"), xp_lsp_prim_minus);

11
ase/lsp/prim.h
View File

@ -1,5 +1,5 @@
/*
* $Id: prim.h,v 1.4 2005-09-20 12:06:51 bacon Exp $
* $Id: prim.h,v 1.5 2005-09-21 11:52:36 bacon Exp $
*/
#ifndef _XP_LSP_PRIM_H_
@ -35,9 +35,12 @@ 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);
xp_lsp_obj_t* xp_lsp_prim_eq (xp_lsp_t* lsp, xp_lsp_obj_t* args);
xp_lsp_obj_t* xp_lsp_prim_ne (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);
xp_lsp_obj_t* xp_lsp_prim_ge (xp_lsp_t* lsp, xp_lsp_obj_t* args);
xp_lsp_obj_t* xp_lsp_prim_le (xp_lsp_t* lsp, xp_lsp_obj_t* args);
/*---------------------
prim_math.c

203
ase/lsp/prim_compar.c
View File

@ -1,5 +1,5 @@
/*
* $Id: prim_compar.c,v 1.1 2005-09-20 12:06:51 bacon Exp $
* $Id: prim_compar.c,v 1.2 2005-09-21 11:52:36 bacon Exp $
*/
#include <xp/lsp/prim.h>
@ -72,6 +72,73 @@ xp_lsp_obj_t* xp_lsp_prim_eq (xp_lsp_t* lsp, xp_lsp_obj_t* args)
return (res)? lsp->mem->t: lsp->mem->nil;
}
xp_lsp_obj_t* xp_lsp_prim_ne (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;
@ -205,3 +272,137 @@ xp_lsp_obj_t* xp_lsp_prim_lt (xp_lsp_t* lsp, xp_lsp_obj_t* args)
return (res)? lsp->mem->t: lsp->mem->nil;
}
xp_lsp_obj_t* xp_lsp_prim_ge (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_le (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;
}