diff --git a/ase/lsp/lsp.h b/ase/lsp/lsp.h index 1401fb1e..ca13a551 100644 --- a/ase/lsp/lsp.h +++ b/ase/lsp/lsp.h @@ -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 diff --git a/ase/lsp/name.h b/ase/lsp/name.h index ef0caebf..5cfc196b 100644 --- a/ase/lsp/name.h +++ b/ase/lsp/name.h @@ -1,18 +1,19 @@ /* - * $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 +#include +#include struct xp_lsp_name_t { - xp_word_t capacity; - xp_word_t size; - xp_char_t* buffer; - xp_char_t static_buffer[128]; + xp_word_t capacity; + xp_word_t size; + xp_char_t* buffer; + xp_char_t static_buffer[128]; xp_bool_t __malloced; }; @@ -30,7 +31,7 @@ int xp_lsp_name_addc (xp_lsp_name_t* name, xp_cint_t c); int xp_lsp_name_adds (xp_lsp_name_t* name, const xp_char_t* s); void xp_lsp_name_clear (xp_lsp_name_t* name); xp_char_t* xp_lsp_name_yield (xp_lsp_name_t* name, xp_word_t capacity); -int xp_lsp_name_compare (xp_lsp_name_t* name, const xp_char_t* str); +int xp_lsp_name_compare (xp_lsp_name_t* name, const xp_char_t* str); #ifdef __cplusplus } diff --git a/ase/lsp/prim.c b/ase/lsp/prim.c new file mode 100644 index 00000000..0c91b8ee --- /dev/null +++ b/ase/lsp/prim.c @@ -0,0 +1,687 @@ +/* + * $Id: prim.c,v 1.1 2005-09-18 10:18:35 bacon Exp $ + */ + +#include +#include +#include +#include + +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; +} diff --git a/ase/lsp/prim.h b/ase/lsp/prim.h new file mode 100644 index 00000000..2d74c20c --- /dev/null +++ b/ase/lsp/prim.h @@ -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 +#include + +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 diff --git a/ase/lsp/primitive.c b/ase/lsp/primitive.c deleted file mode 100644 index 33cafbc3..00000000 --- a/ase/lsp/primitive.c +++ /dev/null @@ -1,687 +0,0 @@ -/* - * $Id: primitive.c,v 1.7 2005-05-28 13:34:26 bacon Exp $ - */ - -#include -#include -#include -#include - -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; -} diff --git a/ase/lsp/primitive.h b/ase/lsp/primitive.h deleted file mode 100644 index 445c8909..00000000 --- a/ase/lsp/primitive.h +++ /dev/null @@ -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 -#include - -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 diff --git a/ase/lsp/print.c b/ase/lsp/print.c index fa67211b..d1390108 100644 --- a/ase/lsp/print.c +++ b/ase/lsp/print.c @@ -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 +#include +#include -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")); + xp_char_t buf[256]; + + if (lsp->output_func != XP_NULL) { + lsp->errnum = XP_LSP_ERR_OUTPUT_NOT_ATTACHED; + return -1; + } + + switch (XP_LSP_TYPE(obj)) { + case XP_LSP_OBJ_NIL: + OUTPUT_STR (lsp, XP_TEXT("nil")); break; - case XP_LISP_OBJ_TRUE: - xp_fprintf (lsp->outstream,XP_TEXT("t")); + case XP_LSP_OBJ_TRUE: + OUTPUT_STR (lsp, 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)); + 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)) { - xp_fprintf (lsp->outstream,XP_TEXT("%ld"), 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_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 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; } diff --git a/ase/lsp/read.c b/ase/lsp/read.c index 30b8ca03..e11ead74 100644 --- a/ase/lsp/read.c +++ b/ase/lsp/read.c @@ -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 +#include #include #include #include @@ -20,22 +20,21 @@ (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 #define TOKEN_FLOAT 2 @@ -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,58 +66,51 @@ 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; \ } \ - } while (0) + else if (lsp->input_func(XP_LSP_IO_CHAR, lsp, XP_NULL) == -1) { \ + lsp->errnum = XP_LSP_ERR_INPUT; \ + return -1; \ + } \ + } while (0) #define NEXT_TOKEN(lsp) \ do { \ 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; - return XP_NULL; - } - lsp->creader_just_set = 0; + /*NEXT_CHAR (lsp);*/ + if (lsp->input_func == XP_NULL) { + lsp->errnum = XP_LSP_ERR_INPUT_NOT_ATTACHED; + return XP_NULL; + } + 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; diff --git a/ase/lsp/token.h b/ase/lsp/token.h index 3f227783..3af278d9 100644 --- a/ase/lsp/token.h +++ b/ase/lsp/token.h @@ -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 +#include #include enum