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-18 10:23:19 +00:00
parent 250170a4f8
commit 432377371c
9 changed files with 936 additions and 921 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
ase/lsp/lsp.h
View File

@ -1,12 +1,12 @@
/*
* $Id: lsp.h,v 1.5 2005-09-18 10:18:35 bacon Exp $
* $Id: lsp.h,v 1.6 2005-09-18 10:23:19 bacon Exp $
*/
#ifndef _XP_LSP_LSP_H_
#define _XP_LSP_LSP_H_
/*
* HEADER: xp_lsp_t
* HEADER: Lisp
* A lisp-like embeddable language processor is provied for application
* development that requires scripting.
*
@ -51,10 +51,6 @@ enum
XP_LSP_IO_STR
};
/*
* STRUCT: xp_lsp_t
* Defines the lisp object
*/
struct xp_lsp_t
{
/* error number */
@ -78,6 +74,10 @@ struct xp_lsp_t
xp_bool_t __malloced;
};
/*
* TYPEDEF: xp_lsp_t
* Defines the lisp object
*/
typedef struct xp_lsp_t xp_lsp_t;
#ifdef __cplusplus

5
ase/lsp/name.h
View File

@ -1,11 +1,12 @@
/*
* $Id: name.h,v 1.1 2005-09-18 08:10:50 bacon Exp $
* $Id: name.h,v 1.2 2005-09-18 10:18:35 bacon Exp $
*/
#ifndef _XP_LSP_NAME_H_
#define _XP_LSP_NAME_H_
#include <xp/lsp/lsp.h>
#include <xp/types.h>
#include <xp/macros.h>
struct xp_lsp_name_t
{

687
ase/lsp/prim.c Normal file
View File

@ -0,0 +1,687 @@
/*
* $Id: prim.c,v 1.1 2005-09-18 10:18:35 bacon Exp $
*/
#include <xp/lsp/lsp.h>
#include <xp/lsp/memory.h>
#include <xp/lsp/prim.h>
#include <xp/bas/assert.h>
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);
lsp->errnum = XP_LSP_ERR_ABORT;
return XP_NULL;
}
xp_lsp_obj_t* xp_lsp_prim_eval (xp_lsp_t* lsp, xp_lsp_obj_t* args)
{
xp_lsp_obj_t* tmp;
XP_LSP_PRIM_CHECK_ARG_COUNT (lsp, args, 1, 1);
xp_assert (XP_LSP_TYPE(args) == XP_LSP_OBJ_CONS);
tmp = xp_lsp_eval (lsp, XP_LSP_CAR(args));
if (tmp == XP_NULL) return XP_NULL;
tmp = xp_lsp_eval (lsp, tmp);
if (tmp == XP_NULL) return XP_NULL;
return tmp;
}
xp_lsp_obj_t* xp_lsp_prim_prog1 (xp_lsp_t* lsp, xp_lsp_obj_t* args)
{
xp_lsp_obj_t* res = XP_NULL, * tmp;
XP_LSP_PRIM_CHECK_ARG_COUNT (lsp, args, 1, XP_LSP_PRIM_MAX_ARG_COUNT);
//while (args != lsp->mem->nil) {
while (XP_LSP_TYPE(args) == XP_LSP_OBJ_CONS) {
tmp = xp_lsp_eval (lsp, XP_LSP_CAR(args));
if (tmp == XP_NULL) return XP_NULL;
if (res == XP_NULL) {
/*
xp_lsp_array_t* ta = lsp->mem->temp_array;
xp_lsp_array_insert (ta, ta->size, tmp);
*/
res = tmp;
}
args = XP_LSP_CDR(args);
}
return res;
}
xp_lsp_obj_t* xp_lsp_prim_progn (xp_lsp_t* lsp, xp_lsp_obj_t* args)
{
xp_lsp_obj_t* res, * tmp;
XP_LSP_PRIM_CHECK_ARG_COUNT (lsp, args, 1, XP_LSP_PRIM_MAX_ARG_COUNT);
res = lsp->mem->nil;
//while (args != lsp->mem->nil) {
while (XP_LSP_TYPE(args) == XP_LSP_OBJ_CONS) {
tmp = xp_lsp_eval (lsp, XP_LSP_CAR(args));
if (tmp == XP_NULL) return XP_NULL;
res = tmp;
args = XP_LSP_CDR(args);
}
return res;
}
xp_lsp_obj_t* xp_lsp_prim_gc (xp_lsp_t* lsp, xp_lsp_obj_t* args)
{
XP_LSP_PRIM_CHECK_ARG_COUNT (lsp, args, 0, 0);
xp_lsp_garbage_collect (lsp->mem);
return lsp->mem->nil;
}
xp_lsp_obj_t* xp_lsp_prim_cond (xp_lsp_t* lsp, xp_lsp_obj_t* args)
{
/*
* (cond
* (condition1 result1)
* (consition2 result2)
* ...
* (t resultN))
*/
xp_lsp_obj_t* tmp, * ret;
XP_LSP_PRIM_CHECK_ARG_COUNT (lsp, args, 0, XP_LSP_PRIM_MAX_ARG_COUNT);
while (XP_LSP_TYPE(args) == XP_LSP_OBJ_CONS) {
if (XP_LSP_TYPE(XP_LSP_CAR(args)) != XP_LSP_OBJ_CONS) {
lsp->errnum = XP_LSP_ERR_BAD_ARG;
return XP_NULL;
}
tmp = xp_lsp_eval (lsp, XP_LSP_CAR(XP_LSP_CAR(args)));
if (tmp == XP_NULL) return XP_NULL;
if (tmp != lsp->mem->nil) {
tmp = XP_LSP_CDR(XP_LSP_CAR(args));
ret = lsp->mem->nil;
while (XP_LSP_TYPE(tmp) == XP_LSP_OBJ_CONS) {
ret = xp_lsp_eval (lsp, XP_LSP_CAR(tmp));
if (ret == 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;
}
return ret;
}
args = XP_LSP_CDR(args);
}
return lsp->mem->nil;
}
xp_lsp_obj_t* xp_lsp_prim_if (xp_lsp_t* lsp, xp_lsp_obj_t* args)
{
xp_lsp_obj_t* tmp;
XP_LSP_PRIM_CHECK_ARG_COUNT (lsp, args, 2, XP_LSP_PRIM_MAX_ARG_COUNT);
xp_assert (XP_LSP_TYPE(args) == XP_LSP_OBJ_CONS);
tmp = xp_lsp_eval (lsp, XP_LSP_CAR(args));
if (tmp == XP_NULL) return XP_NULL;
if (tmp != lsp->mem->nil) {
tmp = xp_lsp_eval (lsp, XP_LSP_CAR(XP_LSP_CDR(args)));
if (tmp == XP_NULL) return XP_NULL;
return tmp;
}
else {
xp_lsp_obj_t* res = lsp->mem->nil;
tmp = XP_LSP_CDR(XP_LSP_CDR(args));
while (XP_LSP_TYPE(tmp) == XP_LSP_OBJ_CONS) {
res = xp_lsp_eval (lsp, XP_LSP_CAR(tmp));
if (res == 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;
}
return res;
}
}
xp_lsp_obj_t* xp_lsp_prim_while (xp_lsp_t* lsp, xp_lsp_obj_t* args)
{
/*
* (setq a 1)
* (while (< a 100) (setq a (+ a 1)))
*/
xp_lsp_obj_t* tmp;
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);
for (;;) {
tmp = xp_lsp_eval (lsp, XP_LSP_CAR(args));
if (tmp == XP_NULL) return XP_NULL;
if (tmp == lsp->mem->nil) break;
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;
tmp = XP_LSP_CDR(tmp);
}
if (tmp != lsp->mem->nil) {
lsp->errnum = XP_LSP_ERR_BAD_ARG;
return XP_NULL;
}
}
return lsp->mem->nil;
}
xp_lsp_obj_t* xp_lsp_prim_car (xp_lsp_t* lsp, xp_lsp_obj_t* args)
{
xp_lsp_obj_t* tmp;
XP_LSP_PRIM_CHECK_ARG_COUNT (lsp, args, 1, 1);
xp_assert (XP_LSP_TYPE(args) == XP_LSP_OBJ_CONS);
tmp = xp_lsp_eval (lsp, XP_LSP_CAR(args));
if (tmp == XP_NULL) return XP_NULL;
if (tmp == lsp->mem->nil) return lsp->mem->nil;
if (XP_LSP_TYPE(tmp) != XP_LSP_OBJ_CONS) {
lsp->errnum = XP_LSP_ERR_BAD_ARG;
return XP_NULL;
}
return XP_LSP_CAR(tmp);
}
xp_lsp_obj_t* xp_lsp_prim_cdr (xp_lsp_t* lsp, xp_lsp_obj_t* args)
{
xp_lsp_obj_t* tmp;
XP_LSP_PRIM_CHECK_ARG_COUNT (lsp, args, 1, 1);
xp_assert (XP_LSP_TYPE(args) == XP_LSP_OBJ_CONS);
tmp = xp_lsp_eval (lsp, XP_LSP_CAR(args));
if (tmp == XP_NULL) return XP_NULL;
if (tmp == lsp->mem->nil) return lsp->mem->nil;
if (XP_LSP_TYPE(tmp) != XP_LSP_OBJ_CONS) {
lsp->errnum = XP_LSP_ERR_BAD_ARG;
return XP_NULL;
}
return XP_LSP_CDR(tmp);
}
xp_lsp_obj_t* xp_lsp_prim_cons (xp_lsp_t* lsp, xp_lsp_obj_t* args)
{
xp_lsp_obj_t* car, * cdr, * cons;
XP_LSP_PRIM_CHECK_ARG_COUNT (lsp, args, 2, 2);
xp_assert (XP_LSP_TYPE(args) == XP_LSP_OBJ_CONS);
car = xp_lsp_eval (lsp, XP_LSP_CAR(args));
if (car == XP_NULL) return XP_NULL;
cdr = xp_lsp_eval (lsp, XP_LSP_CAR(XP_LSP_CDR(args)));
if (cdr == XP_NULL) return XP_NULL;
cons = xp_lsp_make_cons (lsp->mem, car, cdr);
if (cons == XP_NULL) {
lsp->errnum = XP_LSP_ERR_MEM;
return XP_NULL;
}
return cons;
}
xp_lsp_obj_t* xp_lsp_prim_set (xp_lsp_t* lsp, xp_lsp_obj_t* args)
{
xp_lsp_obj_t* p1, * p2;
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;
if (XP_LSP_TYPE(p1) != XP_LSP_OBJ_SYMBOL) {
lsp->errnum = XP_LSP_ERR_BAD_ARG;
return XP_NULL;
}
p2 = xp_lsp_eval (lsp, XP_LSP_CAR(XP_LSP_CDR(args)));
if (p2 == XP_NULL) return XP_NULL;
if (xp_lsp_set (lsp->mem, p1, p2) == XP_NULL) {
lsp->errnum = XP_LSP_ERR_MEM;
return XP_NULL;
}
return p2;
}
xp_lsp_obj_t* xp_lsp_prim_setq (xp_lsp_t* lsp, xp_lsp_obj_t* args)
{
xp_lsp_obj_t* p = args, * p1, * p2 = lsp->mem->nil;
while (p != lsp->mem->nil) {
xp_assert (XP_LSP_TYPE(p) == XP_LSP_OBJ_CONS);
p1 = XP_LSP_CAR(p);
if (XP_LSP_TYPE(p1) != XP_LSP_OBJ_SYMBOL) {
lsp->errnum = XP_LSP_ERR_BAD_ARG;
return XP_NULL;
}
if (XP_LSP_TYPE(XP_LSP_CDR(p)) != XP_LSP_OBJ_CONS) {
lsp->errnum = XP_LSP_ERR_TOO_FEW_ARGS;
return XP_NULL;
}
p2 = xp_lsp_eval (lsp, XP_LSP_CAR(XP_LSP_CDR(p)));
if (p2 == XP_NULL) return XP_NULL;
if (xp_lsp_set (lsp->mem, p1, p2) == XP_NULL) {
lsp->errnum = XP_LSP_ERR_MEM;
return XP_NULL;
}
p = XP_LSP_CDR(XP_LSP_CDR(p));
}
return p2;
}
xp_lsp_obj_t* xp_lsp_prim_quote (xp_lsp_t* lsp, xp_lsp_obj_t* args)
{
XP_LSP_PRIM_CHECK_ARG_COUNT (lsp, args, 1, 1);
xp_assert (XP_LSP_TYPE(args) == XP_LSP_OBJ_CONS);
return XP_LSP_CAR(args);
}
xp_lsp_obj_t* xp_lsp_prim_defun (xp_lsp_t* lsp, xp_lsp_obj_t* args)
{
/*
* (defun x (abc) x y z)
* (setq x (lambda (abc) x y z))
*/
xp_lsp_obj_t* name, * fun;
XP_LSP_PRIM_CHECK_ARG_COUNT (lsp, args, 3, XP_LSP_PRIM_MAX_ARG_COUNT);
name = XP_LSP_CAR(args);
if (XP_LSP_TYPE(name) != XP_LSP_OBJ_SYMBOL) {
lsp->errnum = XP_LSP_ERR_BAD_ARG;
return XP_NULL;
}
fun = xp_lsp_make_func (lsp->mem,
XP_LSP_CAR(XP_LSP_CDR(args)), XP_LSP_CDR(XP_LSP_CDR(args)));
if (fun == XP_NULL) return XP_NULL;
if (xp_lsp_set (lsp->mem, XP_LSP_CAR(args), fun) == XP_NULL) {
lsp->errnum = XP_LSP_ERR_MEM;
return XP_NULL;
}
return fun;
}
xp_lsp_obj_t* xp_lsp_prim_demac (xp_lsp_t* lsp, xp_lsp_obj_t* args)
{
/*
* (demac x (abc) x y z)
*(setq x (macro (abc) x y z))
*/
xp_lsp_obj_t* name, * mac;
XP_LSP_PRIM_CHECK_ARG_COUNT (lsp, args, 3, XP_LSP_PRIM_MAX_ARG_COUNT);
name = XP_LSP_CAR(args);
if (XP_LSP_TYPE(name) != XP_LSP_OBJ_SYMBOL) {
lsp->errnum = XP_LSP_ERR_BAD_ARG;
return XP_NULL;
}
mac = xp_lsp_make_macro (lsp->mem,
XP_LSP_CAR(XP_LSP_CDR(args)), XP_LSP_CDR(XP_LSP_CDR(args)));
if (mac == XP_NULL) return XP_NULL;
if (xp_lsp_set (lsp->mem, XP_LSP_CAR(args), mac) == XP_NULL) {
lsp->errnum = XP_LSP_ERR_MEM;
return XP_NULL;
}
return mac;
}
static xp_lsp_obj_t* xp_lsp_prim_let_impl (
xp_lsp_t* lsp, xp_lsp_obj_t* args, int sequential)
{
xp_lsp_frame_t* frame;
xp_lsp_obj_t* assoc;
xp_lsp_obj_t* body;
xp_lsp_obj_t* value;
XP_LSP_PRIM_CHECK_ARG_COUNT (lsp, args, 1, XP_LSP_PRIM_MAX_ARG_COUNT);
// create a new frame
frame = xp_lsp_frame_new ();
if (frame == XP_NULL) {
lsp->errnum = XP_LSP_ERR_MEM;
return XP_NULL;
}
//frame->link = lsp->mem->frame;
if (sequential) {
frame->link = lsp->mem->frame;
lsp->mem->frame = frame;
}
else {
frame->link = lsp->mem->brooding_frame;
lsp->mem->brooding_frame = frame;
}
assoc = XP_LSP_CAR(args);
//while (assoc != lsp->mem->nil) {
while (XP_LSP_TYPE(assoc) == XP_LSP_OBJ_CONS) {
xp_lsp_obj_t* ass = XP_LSP_CAR(assoc);
if (XP_LSP_TYPE(ass) == XP_LSP_OBJ_CONS) {
xp_lsp_obj_t* n = XP_LSP_CAR(ass);
xp_lsp_obj_t* v = XP_LSP_CDR(ass);
if (XP_LSP_TYPE(n) != XP_LSP_OBJ_SYMBOL) {
lsp->errnum = XP_LSP_ERR_BAD_ARG; // must be a symbol
if (sequential) lsp->mem->frame = frame->link;
else lsp->mem->brooding_frame = frame->link;
xp_lsp_frame_free (frame);
return XP_NULL;
}
if (v != lsp->mem->nil) {
if (XP_LSP_CDR(v) != lsp->mem->nil) {
lsp->errnum = XP_LSP_ERR_TOO_MANY_ARGS; // must be a symbol
if (sequential) lsp->mem->frame = frame->link;
else lsp->mem->brooding_frame = frame->link;
xp_lsp_frame_free (frame);
return XP_NULL;
}
if ((v = xp_lsp_eval(lsp, XP_LSP_CAR(v))) == XP_NULL) {
if (sequential) lsp->mem->frame = frame->link;
else lsp->mem->brooding_frame = frame->link;
xp_lsp_frame_free (frame);
return XP_NULL;
}
}
if (xp_lsp_frame_lookup (frame, n) != XP_NULL) {
lsp->errnum = XP_LSP_ERR_DUP_FORMAL;
if (sequential) lsp->mem->frame = frame->link;
else lsp->mem->brooding_frame = frame->link;
xp_lsp_frame_free (frame);
return XP_NULL;
}
if (xp_lsp_frame_insert (frame, n, v) == XP_NULL) {
lsp->errnum = XP_LSP_ERR_MEM;
if (sequential) lsp->mem->frame = frame->link;
else lsp->mem->brooding_frame = frame->link;
xp_lsp_frame_free (frame);
return XP_NULL;
}
}
else if (XP_LSP_TYPE(ass) == XP_LSP_OBJ_SYMBOL) {
if (xp_lsp_frame_lookup (frame, ass) != XP_NULL) {
lsp->errnum = XP_LSP_ERR_DUP_FORMAL;
if (sequential) lsp->mem->frame = frame->link;
else lsp->mem->brooding_frame = frame->link;
xp_lsp_frame_free (frame);
return XP_NULL;
}
if (xp_lsp_frame_insert (frame, ass, lsp->mem->nil) == XP_NULL) {
lsp->errnum = XP_LSP_ERR_MEM;
if (sequential) lsp->mem->frame = frame->link;
else lsp->mem->brooding_frame = frame->link;
xp_lsp_frame_free (frame);
return XP_NULL;
}
}
else {
lsp->errnum = XP_LSP_ERR_BAD_ARG;
if (sequential) lsp->mem->frame = frame->link;
else lsp->mem->brooding_frame = frame->link;
xp_lsp_frame_free (frame);
return XP_NULL;
}
assoc = XP_LSP_CDR(assoc);
}
if (assoc != lsp->mem->nil) {
lsp->errnum = XP_LSP_ERR_BAD_ARG;
if (sequential) lsp->mem->frame = frame->link;
else lsp->mem->brooding_frame = frame->link;
xp_lsp_frame_free (frame);
return XP_NULL;
}
// push the frame
if (!sequential) {
lsp->mem->brooding_frame = frame->link;
frame->link = lsp->mem->frame;
lsp->mem->frame = frame;
}
// evaluate forms in the body
value = lsp->mem->nil;
body = XP_LSP_CDR(args);
while (body != lsp->mem->nil) {
value = xp_lsp_eval (lsp, XP_LSP_CAR(body));
if (value == XP_NULL) {
lsp->mem->frame = frame->link;
xp_lsp_frame_free (frame);
return XP_NULL;
}
body = XP_LSP_CDR(body);
}
// pop the frame
lsp->mem->frame = frame->link;
// destroy the frame
xp_lsp_frame_free (frame);
return value;
}
xp_lsp_obj_t* xp_lsp_prim_let (xp_lsp_t* lsp, xp_lsp_obj_t* args)
{
return xp_lsp_prim_let_impl (lsp, args, 0);
}
xp_lsp_obj_t* xp_lsp_prim_letx (xp_lsp_t* lsp, xp_lsp_obj_t* args)
{
return xp_lsp_prim_let_impl (lsp, args, 1);
}
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 value = 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) {
lsp->errnum = XP_LSP_ERR_BAD_VALUE;
return XP_NULL;
}
value = value + XP_LSP_IVALUE(tmp);
body = XP_LSP_CDR(body);
}
tmp = xp_lsp_make_int (lsp->mem, value);
if (tmp == XP_NULL) {
lsp->errnum = XP_LSP_ERR_MEM;
return XP_NULL;
}
return tmp;
}
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_FLOAT) {
res = XP_LSP_IVALUE(p1) > XP_LSP_FVALUE(p2);
}
else {
lsp->errnum = XP_LSP_ERR_BAD_VALUE;
return XP_NULL;
}
}
else if (XP_LSP_TYPE(p1) == XP_LSP_OBJ_FLOAT) {
if (XP_LSP_TYPE(p2) == XP_LSP_OBJ_INT) {
res = XP_LSP_FVALUE(p1) > XP_LSP_IVALUE(p2);
}
else if (XP_LSP_TYPE(p2) == XP_LSP_OBJ_FLOAT) {
res = XP_LSP_FVALUE(p1) > XP_LSP_FVALUE(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_FLOAT) {
res = XP_LSP_IVALUE(p1) < XP_LSP_FVALUE(p2);
}
else {
lsp->errnum = XP_LSP_ERR_BAD_VALUE;
return XP_NULL;
}
}
else if (XP_LSP_TYPE(p1) == XP_LSP_OBJ_FLOAT) {
if (XP_LSP_TYPE(p2) == XP_LSP_OBJ_INT) {
res = XP_LSP_FVALUE(p1) < XP_LSP_IVALUE(p2);
}
else if (XP_LSP_TYPE(p2) == XP_LSP_OBJ_FLOAT) {
res = XP_LSP_FVALUE(p1) < XP_LSP_FVALUE(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;
}

64
ase/lsp/prim.h Normal file
View File

@ -0,0 +1,64 @@
/*
* $Id: prim.h,v 1.1 2005-09-18 10:18:35 bacon Exp $
*/
#ifndef _XP_LSP_PRIM_H_
#define _XP_LSP_PRIM_H_
#include <xp/lsp/types.h>
#include <xp/lsp/lsp.h>
typedef xp_lsp_obj_t* (*xp_lsp_pimpl_t) (xp_lsp_t*, xp_lsp_obj_t*);
#ifdef __cplusplus
extern "C" {
#endif
xp_lsp_obj_t* xp_lsp_prim_abort (xp_lsp_t*, xp_lsp_obj_t* args);
xp_lsp_obj_t* xp_lsp_prim_eval (xp_lsp_t*, xp_lsp_obj_t* args);
xp_lsp_obj_t* xp_lsp_prim_prog1 (xp_lsp_t*, xp_lsp_obj_t* args);
xp_lsp_obj_t* xp_lsp_prim_progn (xp_lsp_t*, xp_lsp_obj_t* args);
xp_lsp_obj_t* xp_lsp_prim_gc (xp_lsp_t*, xp_lsp_obj_t* args);
xp_lsp_obj_t* xp_lsp_prim_cond (xp_lsp_t*, xp_lsp_obj_t* args);
xp_lsp_obj_t* xp_lsp_prim_if (xp_lsp_t*, xp_lsp_obj_t* args);
xp_lsp_obj_t* xp_lsp_prim_while (xp_lsp_t*, xp_lsp_obj_t* args);
xp_lsp_obj_t* xp_lsp_prim_car (xp_lsp_t*, xp_lsp_obj_t* args);
xp_lsp_obj_t* xp_lsp_prim_cdr (xp_lsp_t*, xp_lsp_obj_t* args);
xp_lsp_obj_t* xp_lsp_prim_cons (xp_lsp_t*, xp_lsp_obj_t* args);
xp_lsp_obj_t* xp_lsp_prim_set (xp_lsp_t*, xp_lsp_obj_t* args);
xp_lsp_obj_t* xp_lsp_prim_setq (xp_lsp_t*, xp_lsp_obj_t* args);
xp_lsp_obj_t* xp_lsp_prim_quote (xp_lsp_t*, xp_lsp_obj_t* args);
xp_lsp_obj_t* xp_lsp_prim_defun (xp_lsp_t*, xp_lsp_obj_t* args);
xp_lsp_obj_t* xp_lsp_prim_demac (xp_lsp_t*, xp_lsp_obj_t* args);
xp_lsp_obj_t* xp_lsp_prim_let (xp_lsp_t*, xp_lsp_obj_t* args);
xp_lsp_obj_t* xp_lsp_prim_letx (xp_lsp_t*, xp_lsp_obj_t* args);
xp_lsp_obj_t* xp_lsp_prim_plus (xp_lsp_t*, xp_lsp_obj_t* args);
xp_lsp_obj_t* xp_lsp_prim_gt (xp_lsp_t*, xp_lsp_obj_t* args);
xp_lsp_obj_t* xp_lsp_prim_lt (xp_lsp_t*, xp_lsp_obj_t* args);
#ifdef __cplusplus
}
#endif
#define XP_LSP_PRIM_CHECK_ARG_COUNT(lsp,args,min,max) \
{ \
xp_size_t count; \
if (xp_lsp_probe_args(lsp->mem, args, &count) == -1) { \
lsp->errnum = XP_LSP_ERR_BAD_ARG; \
return XP_NULL; \
} \
if (count < min) { \
lsp->errnum = XP_LSP_ERR_TOO_FEW_ARGS; \
return XP_NULL; \
} \
if (count > max) { \
lsp->errnum = XP_LSP_ERR_TOO_MANY_ARGS; \
return XP_NULL; \
} \
}
#define XP_LSP_PRIM_MAX_ARG_COUNT ((xp_size_t)~(xp_size_t)0)
#endif

687
ase/lsp/primitive.c
View File

@ -1,687 +0,0 @@
/*
* $Id: primitive.c,v 1.7 2005-05-28 13:34:26 bacon Exp $
*/
#include <xp/lsp/lisp.h>
#include <xp/lsp/memory.h>
#include <xp/lsp/primitive.h>
#include <xp/bas/assert.h>
xp_lisp_obj_t* xp_lisp_prim_abort (xp_lisp_t* lsp, xp_lisp_obj_t* args)
{
XP_LISP_PRIM_CHECK_ARG_COUNT (lsp, args, 0, 0);
lsp->error = XP_LISP_ERR_ABORT;
return XP_NULL;
}
xp_lisp_obj_t* xp_lisp_prim_eval (xp_lisp_t* lsp, xp_lisp_obj_t* args)
{
xp_lisp_obj_t* tmp;
XP_LISP_PRIM_CHECK_ARG_COUNT (lsp, args, 1, 1);
xp_assert (XP_LISP_TYPE(args) == XP_LISP_OBJ_CONS);
tmp = xp_lisp_eval (lsp, XP_LISP_CAR(args));
if (tmp == XP_NULL) return XP_NULL;
tmp = xp_lisp_eval (lsp, tmp);
if (tmp == XP_NULL) return XP_NULL;
return tmp;
}
xp_lisp_obj_t* xp_lisp_prim_prog1 (xp_lisp_t* lsp, xp_lisp_obj_t* args)
{
xp_lisp_obj_t* res = XP_NULL, * tmp;
XP_LISP_PRIM_CHECK_ARG_COUNT (lsp, args, 1, XP_LISP_PRIM_MAX_ARG_COUNT);
//while (args != lsp->mem->nil) {
while (XP_LISP_TYPE(args) == XP_LISP_OBJ_CONS) {
tmp = xp_lisp_eval (lsp, XP_LISP_CAR(args));
if (tmp == XP_NULL) return XP_NULL;
if (res == XP_NULL) {
/*
xp_lisp_array_t* ta = lsp->mem->temp_array;
xp_lisp_array_insert (ta, ta->size, tmp);
*/
res = tmp;
}
args = XP_LISP_CDR(args);
}
return res;
}
xp_lisp_obj_t* xp_lisp_prim_progn (xp_lisp_t* lsp, xp_lisp_obj_t* args)
{
xp_lisp_obj_t* res, * tmp;
XP_LISP_PRIM_CHECK_ARG_COUNT (lsp, args, 1, XP_LISP_PRIM_MAX_ARG_COUNT);
res = lsp->mem->nil;
//while (args != lsp->mem->nil) {
while (XP_LISP_TYPE(args) == XP_LISP_OBJ_CONS) {
tmp = xp_lisp_eval (lsp, XP_LISP_CAR(args));
if (tmp == XP_NULL) return XP_NULL;
res = tmp;
args = XP_LISP_CDR(args);
}
return res;
}
xp_lisp_obj_t* xp_lisp_prim_gc (xp_lisp_t* lsp, xp_lisp_obj_t* args)
{
XP_LISP_PRIM_CHECK_ARG_COUNT (lsp, args, 0, 0);
xp_lisp_garbage_collect (lsp->mem);
return lsp->mem->nil;
}
xp_lisp_obj_t* xp_lisp_prim_cond (xp_lisp_t* lsp, xp_lisp_obj_t* args)
{
/*
* (cond
* (condition1 result1)
* (consition2 result2)
* ...
* (t resultN))
*/
xp_lisp_obj_t* tmp, * ret;
XP_LISP_PRIM_CHECK_ARG_COUNT (lsp, args, 0, XP_LISP_PRIM_MAX_ARG_COUNT);
while (XP_LISP_TYPE(args) == XP_LISP_OBJ_CONS) {
if (XP_LISP_TYPE(XP_LISP_CAR(args)) != XP_LISP_OBJ_CONS) {
lsp->error = XP_LISP_ERR_BAD_ARG;
return XP_NULL;
}
tmp = xp_lisp_eval (lsp, XP_LISP_CAR(XP_LISP_CAR(args)));
if (tmp == XP_NULL) return XP_NULL;
if (tmp != lsp->mem->nil) {
tmp = XP_LISP_CDR(XP_LISP_CAR(args));
ret = lsp->mem->nil;
while (XP_LISP_TYPE(tmp) == XP_LISP_OBJ_CONS) {
ret = xp_lisp_eval (lsp, XP_LISP_CAR(tmp));
if (ret == XP_NULL) return XP_NULL;
tmp = XP_LISP_CDR(tmp);
}
if (tmp != lsp->mem->nil) {
lsp->error = XP_LISP_ERR_BAD_ARG;
return XP_NULL;
}
return ret;
}
args = XP_LISP_CDR(args);
}
return lsp->mem->nil;
}
xp_lisp_obj_t* xp_lisp_prim_if (xp_lisp_t* lsp, xp_lisp_obj_t* args)
{
xp_lisp_obj_t* tmp;
XP_LISP_PRIM_CHECK_ARG_COUNT (lsp, args, 2, XP_LISP_PRIM_MAX_ARG_COUNT);
xp_assert (XP_LISP_TYPE(args) == XP_LISP_OBJ_CONS);
tmp = xp_lisp_eval (lsp, XP_LISP_CAR(args));
if (tmp == XP_NULL) return XP_NULL;
if (tmp != lsp->mem->nil) {
tmp = xp_lisp_eval (lsp, XP_LISP_CAR(XP_LISP_CDR(args)));
if (tmp == XP_NULL) return XP_NULL;
return tmp;
}
else {
xp_lisp_obj_t* res = lsp->mem->nil;
tmp = XP_LISP_CDR(XP_LISP_CDR(args));
while (XP_LISP_TYPE(tmp) == XP_LISP_OBJ_CONS) {
res = xp_lisp_eval (lsp, XP_LISP_CAR(tmp));
if (res == XP_NULL) return XP_NULL;
tmp = XP_LISP_CDR(tmp);
}
if (tmp != lsp->mem->nil) {
lsp->error = XP_LISP_ERR_BAD_ARG;
return XP_NULL;
}
return res;
}
}
xp_lisp_obj_t* xp_lisp_prim_while (xp_lisp_t* lsp, xp_lisp_obj_t* args)
{
/*
* (setq a 1)
* (while (< a 100) (setq a (+ a 1)))
*/
xp_lisp_obj_t* tmp;
XP_LISP_PRIM_CHECK_ARG_COUNT (lsp, args, 1, XP_LISP_PRIM_MAX_ARG_COUNT);
xp_assert (XP_LISP_TYPE(args) == XP_LISP_OBJ_CONS);
for (;;) {
tmp = xp_lisp_eval (lsp, XP_LISP_CAR(args));
if (tmp == XP_NULL) return XP_NULL;
if (tmp == lsp->mem->nil) break;
tmp = XP_LISP_CDR(args);
while (XP_LISP_TYPE(tmp) == XP_LISP_OBJ_CONS) {
if (xp_lisp_eval (lsp, XP_LISP_CAR(tmp)) == XP_NULL) return XP_NULL;
tmp = XP_LISP_CDR(tmp);
}
if (tmp != lsp->mem->nil) {
lsp->error = XP_LISP_ERR_BAD_ARG;
return XP_NULL;
}
}
return lsp->mem->nil;
}
xp_lisp_obj_t* xp_lisp_prim_car (xp_lisp_t* lsp, xp_lisp_obj_t* args)
{
xp_lisp_obj_t* tmp;
XP_LISP_PRIM_CHECK_ARG_COUNT (lsp, args, 1, 1);
xp_assert (XP_LISP_TYPE(args) == XP_LISP_OBJ_CONS);
tmp = xp_lisp_eval (lsp, XP_LISP_CAR(args));
if (tmp == XP_NULL) return XP_NULL;
if (tmp == lsp->mem->nil) return lsp->mem->nil;
if (XP_LISP_TYPE(tmp) != XP_LISP_OBJ_CONS) {
lsp->error = XP_LISP_ERR_BAD_ARG;
return XP_NULL;
}
return XP_LISP_CAR(tmp);
}
xp_lisp_obj_t* xp_lisp_prim_cdr (xp_lisp_t* lsp, xp_lisp_obj_t* args)
{
xp_lisp_obj_t* tmp;
XP_LISP_PRIM_CHECK_ARG_COUNT (lsp, args, 1, 1);
xp_assert (XP_LISP_TYPE(args) == XP_LISP_OBJ_CONS);
tmp = xp_lisp_eval (lsp, XP_LISP_CAR(args));
if (tmp == XP_NULL) return XP_NULL;
if (tmp == lsp->mem->nil) return lsp->mem->nil;
if (XP_LISP_TYPE(tmp) != XP_LISP_OBJ_CONS) {
lsp->error = XP_LISP_ERR_BAD_ARG;
return XP_NULL;
}
return XP_LISP_CDR(tmp);
}
xp_lisp_obj_t* xp_lisp_prim_cons (xp_lisp_t* lsp, xp_lisp_obj_t* args)
{
xp_lisp_obj_t* car, * cdr, * cons;
XP_LISP_PRIM_CHECK_ARG_COUNT (lsp, args, 2, 2);
xp_assert (XP_LISP_TYPE(args) == XP_LISP_OBJ_CONS);
car = xp_lisp_eval (lsp, XP_LISP_CAR(args));
if (car == XP_NULL) return XP_NULL;
cdr = xp_lisp_eval (lsp, XP_LISP_CAR(XP_LISP_CDR(args)));
if (cdr == XP_NULL) return XP_NULL;
cons = xp_lisp_make_cons (lsp->mem, car, cdr);
if (cons == XP_NULL) {
lsp->error = XP_LISP_ERR_MEM;
return XP_NULL;
}
return cons;
}
xp_lisp_obj_t* xp_lisp_prim_set (xp_lisp_t* lsp, xp_lisp_obj_t* args)
{
xp_lisp_obj_t* p1, * p2;
XP_LISP_PRIM_CHECK_ARG_COUNT (lsp, args, 2, 2);
xp_assert (XP_LISP_TYPE(args) == XP_LISP_OBJ_CONS);
p1 = xp_lisp_eval (lsp, XP_LISP_CAR(args));
if (p1 == XP_NULL) return XP_NULL;
if (XP_LISP_TYPE(p1) != XP_LISP_OBJ_SYMBOL) {
lsp->error = XP_LISP_ERR_BAD_ARG;
return XP_NULL;
}
p2 = xp_lisp_eval (lsp, XP_LISP_CAR(XP_LISP_CDR(args)));
if (p2 == XP_NULL) return XP_NULL;
if (xp_lisp_set (lsp->mem, p1, p2) == XP_NULL) {
lsp->error = XP_LISP_ERR_MEM;
return XP_NULL;
}
return p2;
}
xp_lisp_obj_t* xp_lisp_prim_setq (xp_lisp_t* lsp, xp_lisp_obj_t* args)
{
xp_lisp_obj_t* p = args, * p1, * p2 = lsp->mem->nil;
while (p != lsp->mem->nil) {
xp_assert (XP_LISP_TYPE(p) == XP_LISP_OBJ_CONS);
p1 = XP_LISP_CAR(p);
if (XP_LISP_TYPE(p1) != XP_LISP_OBJ_SYMBOL) {
lsp->error = XP_LISP_ERR_BAD_ARG;
return XP_NULL;
}
if (XP_LISP_TYPE(XP_LISP_CDR(p)) != XP_LISP_OBJ_CONS) {
lsp->error = XP_LISP_ERR_TOO_FEW_ARGS;
return XP_NULL;
}
p2 = xp_lisp_eval (lsp, XP_LISP_CAR(XP_LISP_CDR(p)));
if (p2 == XP_NULL) return XP_NULL;
if (xp_lisp_set (lsp->mem, p1, p2) == XP_NULL) {
lsp->error = XP_LISP_ERR_MEM;
return XP_NULL;
}
p = XP_LISP_CDR(XP_LISP_CDR(p));
}
return p2;
}
xp_lisp_obj_t* xp_lisp_prim_quote (xp_lisp_t* lsp, xp_lisp_obj_t* args)
{
XP_LISP_PRIM_CHECK_ARG_COUNT (lsp, args, 1, 1);
xp_assert (XP_LISP_TYPE(args) == XP_LISP_OBJ_CONS);
return XP_LISP_CAR(args);
}
xp_lisp_obj_t* xp_lisp_prim_defun (xp_lisp_t* lsp, xp_lisp_obj_t* args)
{
/*
* (defun x (abc) x y z)
* (setq x (lambda (abc) x y z))
*/
xp_lisp_obj_t* name, * fun;
XP_LISP_PRIM_CHECK_ARG_COUNT (lsp, args, 3, XP_LISP_PRIM_MAX_ARG_COUNT);
name = XP_LISP_CAR(args);
if (XP_LISP_TYPE(name) != XP_LISP_OBJ_SYMBOL) {
lsp->error = XP_LISP_ERR_BAD_ARG;
return XP_NULL;
}
fun = xp_lisp_make_func (lsp->mem,
XP_LISP_CAR(XP_LISP_CDR(args)), XP_LISP_CDR(XP_LISP_CDR(args)));
if (fun == XP_NULL) return XP_NULL;
if (xp_lisp_set (lsp->mem, XP_LISP_CAR(args), fun) == XP_NULL) {
lsp->error = XP_LISP_ERR_MEM;
return XP_NULL;
}
return fun;
}
xp_lisp_obj_t* xp_lisp_prim_demac (xp_lisp_t* lsp, xp_lisp_obj_t* args)
{
/*
* (demac x (abc) x y z)
*(setq x (macro (abc) x y z))
*/
xp_lisp_obj_t* name, * mac;
XP_LISP_PRIM_CHECK_ARG_COUNT (lsp, args, 3, XP_LISP_PRIM_MAX_ARG_COUNT);
name = XP_LISP_CAR(args);
if (XP_LISP_TYPE(name) != XP_LISP_OBJ_SYMBOL) {
lsp->error = XP_LISP_ERR_BAD_ARG;
return XP_NULL;
}
mac = xp_lisp_make_macro (lsp->mem,
XP_LISP_CAR(XP_LISP_CDR(args)), XP_LISP_CDR(XP_LISP_CDR(args)));
if (mac == XP_NULL) return XP_NULL;
if (xp_lisp_set (lsp->mem, XP_LISP_CAR(args), mac) == XP_NULL) {
lsp->error = XP_LISP_ERR_MEM;
return XP_NULL;
}
return mac;
}
static xp_lisp_obj_t* xp_lisp_prim_let_impl (
xp_lisp_t* lsp, xp_lisp_obj_t* args, int sequential)
{
xp_lisp_frame_t* frame;
xp_lisp_obj_t* assoc;
xp_lisp_obj_t* body;
xp_lisp_obj_t* value;
XP_LISP_PRIM_CHECK_ARG_COUNT (lsp, args, 1, XP_LISP_PRIM_MAX_ARG_COUNT);
// create a new frame
frame = xp_lisp_frame_new ();
if (frame == XP_NULL) {
lsp->error = XP_LISP_ERR_MEM;
return XP_NULL;
}
//frame->link = lsp->mem->frame;
if (sequential) {
frame->link = lsp->mem->frame;
lsp->mem->frame = frame;
}
else {
frame->link = lsp->mem->brooding_frame;
lsp->mem->brooding_frame = frame;
}
assoc = XP_LISP_CAR(args);
//while (assoc != lsp->mem->nil) {
while (XP_LISP_TYPE(assoc) == XP_LISP_OBJ_CONS) {
xp_lisp_obj_t* ass = XP_LISP_CAR(assoc);
if (XP_LISP_TYPE(ass) == XP_LISP_OBJ_CONS) {
xp_lisp_obj_t* n = XP_LISP_CAR(ass);
xp_lisp_obj_t* v = XP_LISP_CDR(ass);
if (XP_LISP_TYPE(n) != XP_LISP_OBJ_SYMBOL) {
lsp->error = XP_LISP_ERR_BAD_ARG; // must be a symbol
if (sequential) lsp->mem->frame = frame->link;
else lsp->mem->brooding_frame = frame->link;
xp_lisp_frame_free (frame);
return XP_NULL;
}
if (v != lsp->mem->nil) {
if (XP_LISP_CDR(v) != lsp->mem->nil) {
lsp->error = XP_LISP_ERR_TOO_MANY_ARGS; // must be a symbol
if (sequential) lsp->mem->frame = frame->link;
else lsp->mem->brooding_frame = frame->link;
xp_lisp_frame_free (frame);
return XP_NULL;
}
if ((v = xp_lisp_eval(lsp, XP_LISP_CAR(v))) == XP_NULL) {
if (sequential) lsp->mem->frame = frame->link;
else lsp->mem->brooding_frame = frame->link;
xp_lisp_frame_free (frame);
return XP_NULL;
}
}
if (xp_lisp_frame_lookup (frame, n) != XP_NULL) {
lsp->error = XP_LISP_ERR_DUP_FORMAL;
if (sequential) lsp->mem->frame = frame->link;
else lsp->mem->brooding_frame = frame->link;
xp_lisp_frame_free (frame);
return XP_NULL;
}
if (xp_lisp_frame_insert (frame, n, v) == XP_NULL) {
lsp->error = XP_LISP_ERR_MEM;
if (sequential) lsp->mem->frame = frame->link;
else lsp->mem->brooding_frame = frame->link;
xp_lisp_frame_free (frame);
return XP_NULL;
}
}
else if (XP_LISP_TYPE(ass) == XP_LISP_OBJ_SYMBOL) {
if (xp_lisp_frame_lookup (frame, ass) != XP_NULL) {
lsp->error = XP_LISP_ERR_DUP_FORMAL;
if (sequential) lsp->mem->frame = frame->link;
else lsp->mem->brooding_frame = frame->link;
xp_lisp_frame_free (frame);
return XP_NULL;
}
if (xp_lisp_frame_insert (frame, ass, lsp->mem->nil) == XP_NULL) {
lsp->error = XP_LISP_ERR_MEM;
if (sequential) lsp->mem->frame = frame->link;
else lsp->mem->brooding_frame = frame->link;
xp_lisp_frame_free (frame);
return XP_NULL;
}
}
else {
lsp->error = XP_LISP_ERR_BAD_ARG;
if (sequential) lsp->mem->frame = frame->link;
else lsp->mem->brooding_frame = frame->link;
xp_lisp_frame_free (frame);
return XP_NULL;
}
assoc = XP_LISP_CDR(assoc);
}
if (assoc != lsp->mem->nil) {
lsp->error = XP_LISP_ERR_BAD_ARG;
if (sequential) lsp->mem->frame = frame->link;
else lsp->mem->brooding_frame = frame->link;
xp_lisp_frame_free (frame);
return XP_NULL;
}
// push the frame
if (!sequential) {
lsp->mem->brooding_frame = frame->link;
frame->link = lsp->mem->frame;
lsp->mem->frame = frame;
}
// evaluate forms in the body
value = lsp->mem->nil;
body = XP_LISP_CDR(args);
while (body != lsp->mem->nil) {
value = xp_lisp_eval (lsp, XP_LISP_CAR(body));
if (value == XP_NULL) {
lsp->mem->frame = frame->link;
xp_lisp_frame_free (frame);
return XP_NULL;
}
body = XP_LISP_CDR(body);
}
// pop the frame
lsp->mem->frame = frame->link;
// destroy the frame
xp_lisp_frame_free (frame);
return value;
}
xp_lisp_obj_t* xp_lisp_prim_let (xp_lisp_t* lsp, xp_lisp_obj_t* args)
{
return xp_lisp_prim_let_impl (lsp, args, 0);
}
xp_lisp_obj_t* xp_lisp_prim_letx (xp_lisp_t* lsp, xp_lisp_obj_t* args)
{
return xp_lisp_prim_let_impl (lsp, args, 1);
}
xp_lisp_obj_t* xp_lisp_prim_plus (xp_lisp_t* lsp, xp_lisp_obj_t* args)
{
xp_lisp_obj_t* body, * tmp;
xp_lisp_int_t value = 0;
XP_LISP_PRIM_CHECK_ARG_COUNT (lsp, args, 1, XP_LISP_PRIM_MAX_ARG_COUNT);
xp_assert (XP_LISP_TYPE(args) == XP_LISP_OBJ_CONS);
body = args;
//while (body != lsp->mem->nil) {
while (XP_LISP_TYPE(body) == XP_LISP_OBJ_CONS) {
tmp = xp_lisp_eval (lsp, XP_LISP_CAR(body));
if (tmp == XP_NULL) return XP_NULL;
if (XP_LISP_TYPE(tmp) != XP_LISP_OBJ_INT) {
lsp->error = XP_LISP_ERR_BAD_VALUE;
return XP_NULL;
}
value = value + XP_LISP_IVALUE(tmp);
body = XP_LISP_CDR(body);
}
tmp = xp_lisp_make_int (lsp->mem, value);
if (tmp == XP_NULL) {
lsp->error = XP_LISP_ERR_MEM;
return XP_NULL;
}
return tmp;
}
xp_lisp_obj_t* xp_lisp_prim_gt (xp_lisp_t* lsp, xp_lisp_obj_t* args)
{
xp_lisp_obj_t* p1, * p2;
int res;
XP_LISP_PRIM_CHECK_ARG_COUNT (lsp, args, 2, 2);
xp_assert (XP_LISP_TYPE(args) == XP_LISP_OBJ_CONS);
p1 = xp_lisp_eval (lsp, XP_LISP_CAR(args));
if (p1 == XP_NULL) return XP_NULL;
// TODO: lock p1....
p2 = xp_lisp_eval (lsp, XP_LISP_CAR(XP_LISP_CDR(args)));
if (p2 == XP_NULL) return XP_NULL;
if (XP_LISP_TYPE(p1) == XP_LISP_OBJ_INT) {
if (XP_LISP_TYPE(p2) == XP_LISP_OBJ_INT) {
res = XP_LISP_IVALUE(p1) > XP_LISP_IVALUE(p2);
}
else if (XP_LISP_TYPE(p2) == XP_LISP_OBJ_FLOAT) {
res = XP_LISP_IVALUE(p1) > XP_LISP_FVALUE(p2);
}
else {
lsp->error = XP_LISP_ERR_BAD_VALUE;
return XP_NULL;
}
}
else if (XP_LISP_TYPE(p1) == XP_LISP_OBJ_FLOAT) {
if (XP_LISP_TYPE(p2) == XP_LISP_OBJ_INT) {
res = XP_LISP_FVALUE(p1) > XP_LISP_IVALUE(p2);
}
else if (XP_LISP_TYPE(p2) == XP_LISP_OBJ_FLOAT) {
res = XP_LISP_FVALUE(p1) > XP_LISP_FVALUE(p2);
}
else {
lsp->error = XP_LISP_ERR_BAD_VALUE;
return XP_NULL;
}
}
else if (XP_LISP_TYPE(p1) == XP_LISP_OBJ_SYMBOL) {
if (XP_LISP_TYPE(p2) == XP_LISP_OBJ_SYMBOL) {
res = xp_lisp_comp_symbol2 (
p1, XP_LISP_SYMVALUE(p2), XP_LISP_SYMLEN(p2)) > 0;
}
else {
lsp->error = XP_LISP_ERR_BAD_VALUE;
return XP_NULL;
}
}
else if (XP_LISP_TYPE(p1) == XP_LISP_OBJ_STRING) {
if (XP_LISP_TYPE(p2) == XP_LISP_OBJ_STRING) {
res = xp_lisp_comp_string2 (
p1, XP_LISP_STRVALUE(p2), XP_LISP_STRLEN(p2)) > 0;
}
else {
lsp->error = XP_LISP_ERR_BAD_VALUE;
return XP_NULL;
}
}
else {
lsp->error = XP_LISP_ERR_BAD_VALUE;
return XP_NULL;
}
return (res)? lsp->mem->t: lsp->mem->nil;
}
xp_lisp_obj_t* xp_lisp_prim_lt (xp_lisp_t* lsp, xp_lisp_obj_t* args)
{
xp_lisp_obj_t* p1, * p2;
int res;
XP_LISP_PRIM_CHECK_ARG_COUNT (lsp, args, 2, 2);
xp_assert (XP_LISP_TYPE(args) == XP_LISP_OBJ_CONS);
p1 = xp_lisp_eval (lsp, XP_LISP_CAR(args));
if (p1 == XP_NULL) return XP_NULL;
// TODO: lock p1....
p2 = xp_lisp_eval (lsp, XP_LISP_CAR(XP_LISP_CDR(args)));
if (p2 == XP_NULL) return XP_NULL;
if (XP_LISP_TYPE(p1) == XP_LISP_OBJ_INT) {
if (XP_LISP_TYPE(p2) == XP_LISP_OBJ_INT) {
res = XP_LISP_IVALUE(p1) < XP_LISP_IVALUE(p2);
}
else if (XP_LISP_TYPE(p2) == XP_LISP_OBJ_FLOAT) {
res = XP_LISP_IVALUE(p1) < XP_LISP_FVALUE(p2);
}
else {
lsp->error = XP_LISP_ERR_BAD_VALUE;
return XP_NULL;
}
}
else if (XP_LISP_TYPE(p1) == XP_LISP_OBJ_FLOAT) {
if (XP_LISP_TYPE(p2) == XP_LISP_OBJ_INT) {
res = XP_LISP_FVALUE(p1) < XP_LISP_IVALUE(p2);
}
else if (XP_LISP_TYPE(p2) == XP_LISP_OBJ_FLOAT) {
res = XP_LISP_FVALUE(p1) < XP_LISP_FVALUE(p2);
}
else {
lsp->error = XP_LISP_ERR_BAD_VALUE;
return XP_NULL;
}
}
else if (XP_LISP_TYPE(p1) == XP_LISP_OBJ_SYMBOL) {
if (XP_LISP_TYPE(p2) == XP_LISP_OBJ_SYMBOL) {
res = xp_lisp_comp_symbol2 (
p1, XP_LISP_SYMVALUE(p2), XP_LISP_SYMLEN(p2)) < 0;
}
else {
lsp->error = XP_LISP_ERR_BAD_VALUE;
return XP_NULL;
}
}
else if (XP_LISP_TYPE(p1) == XP_LISP_OBJ_STRING) {
if (XP_LISP_TYPE(p2) == XP_LISP_OBJ_STRING) {
res = xp_lisp_comp_string2 (
p1, XP_LISP_STRVALUE(p2), XP_LISP_STRLEN(p2)) < 0;
}
else {
lsp->error = XP_LISP_ERR_BAD_VALUE;
return XP_NULL;
}
}
else {
lsp->error = XP_LISP_ERR_BAD_VALUE;
return XP_NULL;
}
return (res)? lsp->mem->t: lsp->mem->nil;
}

64
ase/lsp/primitive.h
View File

@ -1,64 +0,0 @@
/*
* $Id: primitive.h,v 1.3 2005-05-28 13:34:26 bacon Exp $
*/
#ifndef _XP_LSP_PRIM_H_
#define _XP_LSP_PRIM_H_
#include <xp/lsp/types.h>
#include <xp/lsp/lisp.h>
typedef xp_lisp_obj_t* (*xp_lisp_pimpl_t) (xp_lisp_t*, xp_lisp_obj_t*);
#ifdef __cplusplus
extern "C" {
#endif
xp_lisp_obj_t* xp_lisp_prim_abort (xp_lisp_t*, xp_lisp_obj_t* args);
xp_lisp_obj_t* xp_lisp_prim_eval (xp_lisp_t*, xp_lisp_obj_t* args);
xp_lisp_obj_t* xp_lisp_prim_prog1 (xp_lisp_t*, xp_lisp_obj_t* args);
xp_lisp_obj_t* xp_lisp_prim_progn (xp_lisp_t*, xp_lisp_obj_t* args);
xp_lisp_obj_t* xp_lisp_prim_gc (xp_lisp_t*, xp_lisp_obj_t* args);
xp_lisp_obj_t* xp_lisp_prim_cond (xp_lisp_t*, xp_lisp_obj_t* args);
xp_lisp_obj_t* xp_lisp_prim_if (xp_lisp_t*, xp_lisp_obj_t* args);
xp_lisp_obj_t* xp_lisp_prim_while (xp_lisp_t*, xp_lisp_obj_t* args);
xp_lisp_obj_t* xp_lisp_prim_car (xp_lisp_t*, xp_lisp_obj_t* args);
xp_lisp_obj_t* xp_lisp_prim_cdr (xp_lisp_t*, xp_lisp_obj_t* args);
xp_lisp_obj_t* xp_lisp_prim_cons (xp_lisp_t*, xp_lisp_obj_t* args);
xp_lisp_obj_t* xp_lisp_prim_set (xp_lisp_t*, xp_lisp_obj_t* args);
xp_lisp_obj_t* xp_lisp_prim_setq (xp_lisp_t*, xp_lisp_obj_t* args);
xp_lisp_obj_t* xp_lisp_prim_quote (xp_lisp_t*, xp_lisp_obj_t* args);
xp_lisp_obj_t* xp_lisp_prim_defun (xp_lisp_t*, xp_lisp_obj_t* args);
xp_lisp_obj_t* xp_lisp_prim_demac (xp_lisp_t*, xp_lisp_obj_t* args);
xp_lisp_obj_t* xp_lisp_prim_let (xp_lisp_t*, xp_lisp_obj_t* args);
xp_lisp_obj_t* xp_lisp_prim_letx (xp_lisp_t*, xp_lisp_obj_t* args);
xp_lisp_obj_t* xp_lisp_prim_plus (xp_lisp_t*, xp_lisp_obj_t* args);
xp_lisp_obj_t* xp_lisp_prim_gt (xp_lisp_t*, xp_lisp_obj_t* args);
xp_lisp_obj_t* xp_lisp_prim_lt (xp_lisp_t*, xp_lisp_obj_t* args);
#ifdef __cplusplus
}
#endif
#define XP_LISP_PRIM_CHECK_ARG_COUNT(lsp,args,min,max) \
{ \
xp_size_t count; \
if (xp_lisp_probe_args(lsp->mem, args, &count) == -1) { \
lsp->error = XP_LISP_ERR_BAD_ARG; \
return XP_NULL; \
} \
if (count < min) { \
lsp->error = XP_LISP_ERR_TOO_FEW_ARGS; \
return XP_NULL; \
} \
if (count > max) { \
lsp->error = XP_LISP_ERR_TOO_MANY_ARGS; \
return XP_NULL; \
} \
}
#define XP_LISP_PRIM_MAX_ARG_COUNT ((xp_size_t)~(xp_size_t)0)
#endif

154
ase/lsp/print.c
View File

@ -1,121 +1,143 @@
/*
* $Id: print.c,v 1.5 2005-05-28 13:34:26 bacon Exp $
* $Id: print.c,v 1.6 2005-09-18 10:18:35 bacon Exp $
*/
#include <xp/lsp/lisp.h>
#include <xp/lsp/lsp.h>
#include <xp/bas/stdio.h>
void xp_lisp_print_debug (xp_lisp_obj_t* obj)
void xp_lsp_print_debug (xp_lsp_obj_t* obj)
{
switch (XP_LISP_TYPE(obj)) {
case XP_LISP_OBJ_NIL:
switch (XP_LSP_TYPE(obj)) {
case XP_LSP_OBJ_NIL:
xp_printf (XP_TEXT("nil"));
break;
case XP_LISP_OBJ_TRUE:
case XP_LSP_OBJ_TRUE:
xp_printf (XP_TEXT("t"));
break;
case XP_LISP_OBJ_INT:
xp_printf (XP_TEXT("%d"), XP_LISP_IVALUE(obj));
case XP_LSP_OBJ_INT:
xp_printf (XP_TEXT("%d"), XP_LSP_IVALUE(obj));
break;
case XP_LISP_OBJ_FLOAT:
xp_printf (XP_TEXT("%f"), XP_LISP_FVALUE(obj));
case XP_LSP_OBJ_FLOAT:
xp_printf (XP_TEXT("%f"), XP_LSP_FVALUE(obj));
break;
case XP_LISP_OBJ_SYMBOL:
xp_printf (XP_TEXT("%s"), XP_LISP_SYMVALUE(obj));
case XP_LSP_OBJ_SYMBOL:
xp_printf (XP_TEXT("%s"), XP_LSP_SYMVALUE(obj));
break;
case XP_LISP_OBJ_STRING:
xp_printf (XP_TEXT("%s"), XP_LISP_STRVALUE(obj));
case XP_LSP_OBJ_STRING:
xp_printf (XP_TEXT("%s"), XP_LSP_STRVALUE(obj));
break;
case XP_LISP_OBJ_CONS:
case XP_LSP_OBJ_CONS:
{
xp_lisp_obj_t* p = obj;
xp_lsp_obj_t* p = obj;
xp_printf (XP_TEXT("("));
do {
xp_lisp_print_debug (XP_LISP_CAR(p));
p = XP_LISP_CDR(p);
if (XP_LISP_TYPE(p) != XP_LISP_OBJ_NIL) {
xp_lsp_print_debug (XP_LSP_CAR(p));
p = XP_LSP_CDR(p);
if (XP_LSP_TYPE(p) != XP_LSP_OBJ_NIL) {
xp_printf (XP_TEXT(" "));
if (XP_LISP_TYPE(p) != XP_LISP_OBJ_CONS) {
if (XP_LSP_TYPE(p) != XP_LSP_OBJ_CONS) {
xp_printf (XP_TEXT(". "));
xp_lisp_print_debug (p);
xp_lsp_print_debug (p);
}
}
} while (XP_LISP_TYPE(p) != XP_LISP_OBJ_NIL && XP_LISP_TYPE(p) == XP_LISP_OBJ_CONS);
} while (XP_LSP_TYPE(p) != XP_LSP_OBJ_NIL && XP_LSP_TYPE(p) == XP_LSP_OBJ_CONS);
xp_printf (XP_TEXT(")"));
}
break;
case XP_LISP_OBJ_FUNC:
case XP_LSP_OBJ_FUNC:
xp_printf (XP_TEXT("func"));
break;
case XP_LISP_OBJ_MACRO:
case XP_LSP_OBJ_MACRO:
xp_printf (XP_TEXT("macro"));
break;
case XP_LISP_OBJ_PRIM:
case XP_LSP_OBJ_PRIM:
xp_printf (XP_TEXT("prim"));
break;
default:
xp_printf (XP_TEXT("unknown object type: %d"), XP_LISP_TYPE(obj));
xp_printf (XP_TEXT("unknown object type: %d"), XP_LSP_TYPE(obj));
}
}
void xp_lisp_print (xp_lisp_t* lsp, xp_lisp_obj_t* obj)
#define OUTPUT_STR(lsp,str) \
do { \
if (lsp->output_func(XP_LSP_IO_STR, (void*)lsp, (void*)str) == -1) { \
lsp->errnum = XP_LSP_ERR_OUTPUT; \
return -1; \
} \
} while (0)
int xp_lsp_print (xp_lsp_t* lsp, const xp_lsp_obj_t* obj)
{
switch (XP_LISP_TYPE(obj)) {
case XP_LISP_OBJ_NIL:
xp_fprintf (lsp->outstream,XP_TEXT("nil"));
break;
case XP_LISP_OBJ_TRUE:
xp_fprintf (lsp->outstream,XP_TEXT("t"));
break;
case XP_LISP_OBJ_INT:
if (xp_sizeof(xp_lisp_int_t) == xp_sizeof(int)) {
xp_fprintf (lsp->outstream,XP_TEXT("%d"), XP_LISP_IVALUE(obj));
xp_char_t buf[256];
if (lsp->output_func != XP_NULL) {
lsp->errnum = XP_LSP_ERR_OUTPUT_NOT_ATTACHED;
return -1;
}
else if (xp_sizeof(xp_lisp_int_t) == xp_sizeof(long)) {
xp_fprintf (lsp->outstream,XP_TEXT("%ld"), XP_LISP_IVALUE(obj));
switch (XP_LSP_TYPE(obj)) {
case XP_LSP_OBJ_NIL:
OUTPUT_STR (lsp, XP_TEXT("nil"));
break;
case XP_LSP_OBJ_TRUE:
OUTPUT_STR (lsp, XP_TEXT("t"));
break;
case XP_LSP_OBJ_INT:
if (xp_sizeof(xp_lsp_int_t) == xp_sizeof(int)) {
xp_sprintf (buf, xp_countof(buf), XP_TEXT("%d"), XP_LSP_IVALUE(obj));
}
else if (xp_sizeof(xp_lisp_int_t) == xp_sizeof(long long)) {
xp_fprintf (lsp->outstream,XP_TEXT("%lld"), XP_LISP_IVALUE(obj));
else if (xp_sizeof(xp_lsp_int_t) == xp_sizeof(long)) {
xp_sprintf (buf, xp_countof(buf), XP_TEXT("%ld"), XP_LSP_IVALUE(obj));
}
else if (xp_sizeof(xp_lsp_int_t) == xp_sizeof(long long)) {
xp_sprintf (buf, xp_countof(buf), XP_TEXT("%lld"), XP_LSP_IVALUE(obj));
}
OUTPUT_STR (lsp, buf);
break;
case XP_LISP_OBJ_FLOAT:
xp_fprintf (lsp->outstream,XP_TEXT("%f"), XP_LISP_FVALUE(obj));
case XP_LSP_OBJ_FLOAT:
xp_sprintf (buf, xp_countof(buf), XP_TEXT("%f"), XP_LSP_FVALUE(obj));
OUTPUT_STR (lsp, buf);
break;
case XP_LISP_OBJ_SYMBOL:
xp_fprintf (lsp->outstream,XP_TEXT("%s"), XP_LISP_SYMVALUE(obj));
case XP_LSP_OBJ_SYMBOL:
OUTPUT_STR (lsp, XP_LSP_SYMVALUE(obj));
break;
case XP_LISP_OBJ_STRING:
xp_fprintf (lsp->outstream,XP_TEXT("\"%s\""), XP_LISP_STRVALUE(obj));
case XP_LSP_OBJ_STRING:
OUTPUT_STR (lsp, XP_LSP_STRVALUE(obj));
break;
case XP_LISP_OBJ_CONS:
case XP_LSP_OBJ_CONS:
{
xp_lisp_obj_t* p = obj;
xp_fprintf (lsp->outstream,XP_TEXT("("));
const xp_lsp_obj_t* p = obj;
OUTPUT_STR (lsp, XP_TEXT("("));
do {
xp_lisp_print (lsp, XP_LISP_CAR(p));
p = XP_LISP_CDR(p);
xp_lsp_print (lsp, XP_LSP_CAR(p));
p = XP_LSP_CDR(p);
if (p != lsp->mem->nil) {
xp_fprintf (lsp->outstream,XP_TEXT(" "));
if (XP_LISP_TYPE(p) != XP_LISP_OBJ_CONS) {
xp_fprintf (lsp->outstream,XP_TEXT(". "));
xp_lisp_print (lsp, p);
OUTPUT_STR (lsp, XP_TEXT(" "));
if (XP_LSP_TYPE(p) != XP_LSP_OBJ_CONS) {
OUTPUT_STR (lsp, XP_TEXT(". "));
xp_lsp_print (lsp, p);
}
}
} while (p != lsp->mem->nil && XP_LISP_TYPE(p) == XP_LISP_OBJ_CONS);
xp_fprintf (lsp->outstream,XP_TEXT(")"));
} while (p != lsp->mem->nil && XP_LSP_TYPE(p) == XP_LSP_OBJ_CONS);
OUTPUT_STR (lsp, XP_TEXT(")"));
}
break;
case XP_LISP_OBJ_FUNC:
xp_fprintf (lsp->outstream,XP_TEXT("func"));
case XP_LSP_OBJ_FUNC:
OUTPUT_STR (lsp, XP_TEXT("func"));
break;
case XP_LISP_OBJ_MACRO:
xp_fprintf (lsp->outstream,XP_TEXT("macro"));
case XP_LSP_OBJ_MACRO:
OUTPUT_STR (lsp, XP_TEXT("macro"));
break;
case XP_LISP_OBJ_PRIM:
xp_fprintf (lsp->outstream,XP_TEXT("prim"));
case XP_LSP_OBJ_PRIM:
OUTPUT_STR (lsp, XP_TEXT("prim"));
break;
default:
xp_fprintf (lsp->outstream,
XP_TEXT("unknown object type: %d"), XP_LISP_TYPE(obj));
xp_sprintf (buf, xp_countof(buf),
XP_TEXT("unknown object type: %d"), XP_LSP_TYPE(obj));
OUTPUT_STR (lsp, buf);
}
return 0;
}

168
ase/lsp/read.c
View File

@ -1,8 +1,8 @@
/*
* $Id: read.c,v 1.10 2005-06-06 16:04:18 bacon Exp $
* $Id: read.c,v 1.11 2005-09-18 10:18:35 bacon Exp $
*/
#include <xp/lsp/lisp.h>
#include <xp/lsp/lsp.h>
#include <xp/lsp/token.h>
#include <xp/bas/assert.h>
#include <xp/bas/ctype.h>
@ -20,21 +20,20 @@
(c) == XP_CHAR('=') || (c) == XP_CHAR('_') || \
(c) == XP_CHAR('?'))
#define TOKEN_CLEAR(lsp) xp_lisp_token_clear (lsp->token)
#define TOKEN_TYPE(lsp) lsp->token->type
#define TOKEN_IVALUE(lsp) lsp->token->ivalue
#define TOKEN_FVALUE(lsp) lsp->token->fvalue
#define TOKEN_SVALUE(lsp) lsp->token->buffer
#define TOKEN_SLENGTH(lsp) lsp->token->size
#define TOKEN_CLEAR(lsp) xp_lsp_token_clear (&(lsp)->token)
#define TOKEN_TYPE(lsp) (lsp)->token.type
#define TOKEN_IVALUE(lsp) (lsp)->token.ivalue
#define TOKEN_FVALUE(lsp) (lsp)->token.fvalue
#define TOKEN_SVALUE(lsp) (lsp)->token.name.buffer
#define TOKEN_SLENGTH(lsp) (lsp)->token.name.size
#define TOKEN_ADD_CHAR(lsp,ch) \
do { \
if (xp_lisp_token_addc (lsp->token, ch) == -1) { \
lsp->error = XP_LISP_ERR_MEM; \
if (xp_lsp_token_addc (&(lsp)->token, ch) == -1) { \
lsp->errnum = XP_LSP_ERR_MEM; \
return -1; \
} \
} while (0)
#define TOKEN_COMPARE(lsp,str) xp_lisp_token_compare (lsp->token, str)
#define TOKEN_COMPARE(lsp,str) xp_lsp_token_compare_name (&(lsp)->token, str)
#define TOKEN_END 0
#define TOKEN_INT 1
@ -52,14 +51,14 @@
extern "C" {
#endif
static xp_lisp_obj_t* read_obj (xp_lisp_t* lsp);
static xp_lisp_obj_t* read_list (xp_lisp_t* lsp);
static xp_lisp_obj_t* read_quote (xp_lisp_t* lsp);
static xp_lsp_obj_t* read_obj (xp_lsp_t* lsp);
static xp_lsp_obj_t* read_list (xp_lsp_t* lsp);
static xp_lsp_obj_t* read_quote (xp_lsp_t* lsp);
static int read_token (xp_lisp_t* lsp);
static int read_number (xp_lisp_t* lsp, int negative);
static int read_ident (xp_lisp_t* lsp);
static int read_string (xp_lisp_t* lsp);
static int read_token (xp_lsp_t* lsp);
static int read_number (xp_lsp_t* lsp, int negative);
static int read_ident (xp_lsp_t* lsp);
static int read_string (xp_lsp_t* lsp);
#ifdef __cplusplus
}
@ -67,8 +66,12 @@ static int read_string (xp_lisp_t* lsp);
#define NEXT_CHAR(lsp) \
do { \
if (lsp->creader (&lsp->curc, lsp->creader_extra) == -1) { \
lsp->error = XP_LISP_ERR_READ; \
if (lsp->input_func == XP_NULL) { \
lsp->errnum = XP_LSP_ERR_INPUT_NOT_ATTACHED; \
return -1; \
} \
else if (lsp->input_func(XP_LSP_IO_CHAR, lsp, XP_NULL) == -1) { \
lsp->errnum = XP_LSP_ERR_INPUT; \
return -1; \
} \
} while (0)
@ -78,47 +81,36 @@ static int read_string (xp_lisp_t* lsp);
if (read_token(lsp) == -1) return XP_NULL; \
} while (0)
void xp_lisp_set_creader (xp_lisp_t* lsp, xp_lisp_creader_t func, void* extra)
xp_lsp_obj_t* xp_lsp_read (xp_lsp_t* lsp)
{
xp_assert (lsp != XP_NULL);
lsp->creader = func;
lsp->creader_extra = extra;
lsp->creader_just_set = 1;
}
xp_lisp_obj_t* xp_lisp_read (xp_lisp_t* lsp)
{
xp_assert (lsp != XP_NULL && lsp->creader != XP_NULL);
if (lsp->creader_just_set) {
// NEXT_CHAR (lsp);
if (lsp->creader (&lsp->curc, lsp->creader_extra) == -1) {
lsp->error = XP_LISP_ERR_READ;
/*NEXT_CHAR (lsp);*/
if (lsp->input_func == XP_NULL) {
lsp->errnum = XP_LSP_ERR_INPUT_NOT_ATTACHED;
return XP_NULL;
}
lsp->creader_just_set = 0;
else if (lsp->input_func(XP_LSP_IO_CHAR, lsp, XP_NULL) == -1) {
lsp->errnum = XP_LSP_ERR_INPUT;
return XP_NULL;
}
lsp->error = XP_LISP_ERR_NONE;
lsp->errnum = XP_LSP_ERR_NONE;
NEXT_TOKEN (lsp);
if (lsp->mem->locked != XP_NULL) {
xp_lisp_unlock_all (lsp->mem->locked);
xp_lsp_unlock_all (lsp->mem->locked);
lsp->mem->locked = XP_NULL;
}
lsp->mem->locked = read_obj (lsp);
return lsp->mem->locked;
}
static xp_lisp_obj_t* read_obj (xp_lisp_t* lsp)
static xp_lsp_obj_t* read_obj (xp_lsp_t* lsp)
{
xp_lisp_obj_t* obj;
xp_lsp_obj_t* obj;
switch (TOKEN_TYPE(lsp)) {
case TOKEN_END:
lsp->error = XP_LISP_ERR_END;
lsp->errnum = XP_LSP_ERR_END;
return XP_NULL;
case TOKEN_LPAREN:
NEXT_TOKEN (lsp);
@ -127,61 +119,61 @@ static xp_lisp_obj_t* read_obj (xp_lisp_t* lsp)
NEXT_TOKEN (lsp);
return read_quote (lsp);
case TOKEN_INT:
obj = xp_lisp_make_int (lsp->mem, TOKEN_IVALUE(lsp));
if (obj == XP_NULL) lsp->error = XP_LISP_ERR_MEM;
xp_lisp_lock (obj);
obj = xp_lsp_make_int (lsp->mem, TOKEN_IVALUE(lsp));
if (obj == XP_NULL) lsp->errnum = XP_LSP_ERR_MEM;
xp_lsp_lock (obj);
return obj;
case TOKEN_FLOAT:
obj = xp_lisp_make_float (lsp->mem, TOKEN_FVALUE(lsp));
if (obj == XP_NULL) lsp->error = XP_LISP_ERR_MEM;
xp_lisp_lock (obj);
obj = xp_lsp_make_float (lsp->mem, TOKEN_FVALUE(lsp));
if (obj == XP_NULL) lsp->errnum = XP_LSP_ERR_MEM;
xp_lsp_lock (obj);
return obj;
case TOKEN_STRING:
obj = xp_lisp_make_string (
obj = xp_lsp_make_string (
lsp->mem, TOKEN_SVALUE(lsp), TOKEN_SLENGTH(lsp));
if (obj == XP_NULL) lsp->error = XP_LISP_ERR_MEM;
xp_lisp_lock (obj);
if (obj == XP_NULL) lsp->errnum = XP_LSP_ERR_MEM;
xp_lsp_lock (obj);
return obj;
case TOKEN_IDENT:
xp_assert (lsp->mem->nil != XP_NULL && lsp->mem->t != XP_NULL);
if (TOKEN_COMPARE(lsp,XP_TEXT("nil")) == 0) obj = lsp->mem->nil;
else if (TOKEN_COMPARE(lsp,XP_TEXT("t")) == 0) obj = lsp->mem->t;
else {
obj = xp_lisp_make_symbol (
obj = xp_lsp_make_symbol (
lsp->mem, TOKEN_SVALUE(lsp), TOKEN_SLENGTH(lsp));
if (obj == XP_NULL) lsp->error = XP_LISP_ERR_MEM;
xp_lisp_lock (obj);
if (obj == XP_NULL) lsp->errnum = XP_LSP_ERR_MEM;
xp_lsp_lock (obj);
}
return obj;
}
lsp->error = XP_LISP_ERR_SYNTAX;
lsp->errnum = XP_LSP_ERR_SYNTAX;
return XP_NULL;
}
static xp_lisp_obj_t* read_list (xp_lisp_t* lsp)
static xp_lsp_obj_t* read_list (xp_lsp_t* lsp)
{
xp_lisp_obj_t* obj;
xp_lisp_obj_cons_t* p, * first = XP_NULL, * prev = XP_NULL;
xp_lsp_obj_t* obj;
xp_lsp_obj_cons_t* p, * first = XP_NULL, * prev = XP_NULL;
while (TOKEN_TYPE(lsp) != TOKEN_RPAREN) {
if (TOKEN_TYPE(lsp) == TOKEN_END) {
lsp->error = XP_LISP_ERR_SYNTAX; // unexpected end of input
lsp->errnum = XP_LSP_ERR_SYNTAX; // unexpected end of input
return XP_NULL;
}
if (TOKEN_TYPE(lsp) == TOKEN_DOT) {
if (prev == XP_NULL) {
lsp->error = XP_LISP_ERR_SYNTAX; // unexpected .
lsp->errnum = XP_LSP_ERR_SYNTAX; // unexpected .
return XP_NULL;
}
NEXT_TOKEN (lsp);
obj = read_obj (lsp);
if (obj == XP_NULL) {
if (lsp->error == XP_LISP_ERR_END) {
if (lsp->errnum == XP_LSP_ERR_END) {
//unexpected end of input
lsp->error = XP_LISP_ERR_SYNTAX;
lsp->errnum = XP_LSP_ERR_SYNTAX;
}
return XP_NULL;
}
@ -189,7 +181,7 @@ static xp_lisp_obj_t* read_list (xp_lisp_t* lsp)
NEXT_TOKEN (lsp);
if (TOKEN_TYPE(lsp) != TOKEN_RPAREN) {
lsp->error = XP_LISP_ERR_SYNTAX; // ) expected
lsp->errnum = XP_LSP_ERR_SYNTAX; // ) expected
return XP_NULL;
}
@ -198,23 +190,23 @@ static xp_lisp_obj_t* read_list (xp_lisp_t* lsp)
obj = read_obj (lsp);
if (obj == XP_NULL) {
if (lsp->error == XP_LISP_ERR_END) {
if (lsp->errnum == XP_LSP_ERR_END) {
// unexpected end of input
lsp->error = XP_LISP_ERR_SYNTAX;
lsp->errnum = XP_LSP_ERR_SYNTAX;
}
return XP_NULL;
}
p = (xp_lisp_obj_cons_t*)xp_lisp_make_cons (
p = (xp_lsp_obj_cons_t*)xp_lsp_make_cons (
lsp->mem, lsp->mem->nil, lsp->mem->nil);
if (p == XP_NULL) {
lsp->error = XP_LISP_ERR_MEM;
lsp->errnum = XP_LSP_ERR_MEM;
return XP_NULL;
}
xp_lisp_lock ((xp_lisp_obj_t*)p);
xp_lsp_lock ((xp_lsp_obj_t*)p);
if (first == XP_NULL) first = p;
if (prev != XP_NULL) prev->cdr = (xp_lisp_obj_t*)p;
if (prev != XP_NULL) prev->cdr = (xp_lsp_obj_t*)p;
p->car = obj;
prev = p;
@ -222,42 +214,42 @@ static xp_lisp_obj_t* read_list (xp_lisp_t* lsp)
NEXT_TOKEN (lsp);
}
return (first == XP_NULL)? lsp->mem->nil: (xp_lisp_obj_t*)first;
return (first == XP_NULL)? lsp->mem->nil: (xp_lsp_obj_t*)first;
}
static xp_lisp_obj_t* read_quote (xp_lisp_t* lsp)
static xp_lsp_obj_t* read_quote (xp_lsp_t* lsp)
{
xp_lisp_obj_t* cons, * tmp;
xp_lsp_obj_t* cons, * tmp;
tmp = read_obj (lsp);
if (tmp == XP_NULL) {
if (lsp->error == XP_LISP_ERR_END) {
if (lsp->errnum == XP_LSP_ERR_END) {
// unexpected end of input
lsp->error = XP_LISP_ERR_SYNTAX;
lsp->errnum = XP_LSP_ERR_SYNTAX;
}
return XP_NULL;
}
cons = xp_lisp_make_cons (lsp->mem, tmp, lsp->mem->nil);
cons = xp_lsp_make_cons (lsp->mem, tmp, lsp->mem->nil);
if (cons == XP_NULL) {
lsp->error = XP_LISP_ERR_MEM;
lsp->errnum = XP_LSP_ERR_MEM;
return XP_NULL;
}
xp_lisp_lock (cons);
xp_lsp_lock (cons);
cons = xp_lisp_make_cons (lsp->mem, lsp->mem->quote, cons);
cons = xp_lsp_make_cons (lsp->mem, lsp->mem->quote, cons);
if (cons == XP_NULL) {
lsp->error = XP_LISP_ERR_MEM;
lsp->errnum = XP_LSP_ERR_MEM;
return XP_NULL;
}
xp_lisp_lock (cons);
xp_lsp_lock (cons);
return cons;
}
static int read_token (xp_lisp_t* lsp)
static int read_token (xp_lsp_t* lsp)
{
xp_assert (lsp->creader != XP_NULL);
xp_assert (lsp->input_func != XP_NULL);
TOKEN_CLEAR (lsp);
@ -324,9 +316,9 @@ static int read_token (xp_lisp_t* lsp)
return 0;
}
static int read_number (xp_lisp_t* lsp, int negative)
static int read_number (xp_lsp_t* lsp, int negative)
{
xp_lisp_int_t ivalue = 0;
xp_lsp_int_t ivalue = 0;
do {
ivalue = ivalue * 10 + (lsp->curc - XP_CHAR('0'));
@ -344,7 +336,7 @@ static int read_number (xp_lisp_t* lsp, int negative)
return 0;
}
static int read_ident (xp_lisp_t* lsp)
static int read_ident (xp_lsp_t* lsp)
{
do {
TOKEN_ADD_CHAR (lsp, lsp->curc);
@ -354,7 +346,7 @@ static int read_ident (xp_lisp_t* lsp)
return 0;
}
static int read_string (xp_lisp_t* lsp)
static int read_string (xp_lsp_t* lsp)
{
int escaped = 0;
xp_cint_t code = 0;

4
ase/lsp/token.h
View File

@ -1,11 +1,11 @@
/*
* $Id: token.h,v 1.8 2005-09-18 08:10:50 bacon Exp $
* $Id: token.h,v 1.9 2005-09-18 10:18:35 bacon Exp $
*/
#ifndef _XP_LSP_TOKEN_H_
#define _XP_LSP_TOKEN_H_
#include <xp/lsp/lsp.h>
#include <xp/lsp/types.h>
#include <xp/lsp/name.h>
enum