*** empty log message ***

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

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 <xp/lsp/lsp.h>
+#include <xp/types.h>
+#include <xp/macros.h>
 
 struct xp_lsp_name_t 
 {
-	xp_word_t   capacity;
+	xp_word_t capacity;
-	xp_word_t   size;
+	xp_word_t size;
-	xp_char_t*  buffer;
+	xp_char_t* buffer;
-	xp_char_t   static_buffer[128];
+	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
 }

ase/lsp/prim.c

@@ -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;
+}

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 <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

ase/lsp/primitive.c

@@ -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;
-}

ase/lsp/primitive.h

@@ -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

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 <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)) {
+	switch (XP_LSP_TYPE(obj)) {
-	case XP_LISP_OBJ_NIL:
+	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:
+	case XP_LSP_OBJ_INT:
-		xp_printf (XP_TEXT("%d"), XP_LISP_IVALUE(obj));
+		xp_printf (XP_TEXT("%d"), XP_LSP_IVALUE(obj));
 		break;
-	case XP_LISP_OBJ_FLOAT:
+	case XP_LSP_OBJ_FLOAT:
-		xp_printf (XP_TEXT("%f"), XP_LISP_FVALUE(obj));
+		xp_printf (XP_TEXT("%f"), XP_LSP_FVALUE(obj));
 		break;
-	case XP_LISP_OBJ_SYMBOL:
+	case XP_LSP_OBJ_SYMBOL:
-		xp_printf (XP_TEXT("%s"), XP_LISP_SYMVALUE(obj));
+		xp_printf (XP_TEXT("%s"), XP_LSP_SYMVALUE(obj));
 		break;
-	case XP_LISP_OBJ_STRING:
+	case XP_LSP_OBJ_STRING:
-		xp_printf (XP_TEXT("%s"), XP_LISP_STRVALUE(obj));
+		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));
+				xp_lsp_print_debug (XP_LSP_CAR(p));
-				p = XP_LISP_CDR(p);
+				p = XP_LSP_CDR(p);
-				if (XP_LISP_TYPE(p) != XP_LISP_OBJ_NIL) {
+				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)) {
+	xp_char_t buf[256];
-	case XP_LISP_OBJ_NIL:
+
-		xp_fprintf (lsp->outstream,XP_TEXT("nil"));
+	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:
+	case XP_LSP_OBJ_TRUE:
-		xp_fprintf (lsp->outstream,XP_TEXT("t"));
+		OUTPUT_STR (lsp, XP_TEXT("t"));
 		break;
-	case XP_LISP_OBJ_INT:
+	case XP_LSP_OBJ_INT:
-		if (xp_sizeof(xp_lisp_int_t) == xp_sizeof(int)) {
+		if (xp_sizeof(xp_lsp_int_t) == xp_sizeof(int)) {
-			xp_fprintf (lsp->outstream,XP_TEXT("%d"), XP_LISP_IVALUE(obj));
+			xp_sprintf (buf, xp_countof(buf), XP_TEXT("%d"), XP_LSP_IVALUE(obj));
 		}
-		else if (xp_sizeof(xp_lisp_int_t) == xp_sizeof(long)) {
+		else if (xp_sizeof(xp_lsp_int_t) == xp_sizeof(long)) {
-			xp_fprintf (lsp->outstream,XP_TEXT("%ld"), XP_LISP_IVALUE(obj));
+			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)) {
+		else if (xp_sizeof(xp_lsp_int_t) == xp_sizeof(long long)) {
-			xp_fprintf (lsp->outstream,XP_TEXT("%lld"), XP_LISP_IVALUE(obj));
+			xp_sprintf (buf, xp_countof(buf), XP_TEXT("%lld"), XP_LSP_IVALUE(obj));
 		}
+
+		OUTPUT_STR (lsp, buf);
 		break;
-	case XP_LISP_OBJ_FLOAT:
+	case XP_LSP_OBJ_FLOAT:
-		xp_fprintf (lsp->outstream,XP_TEXT("%f"), XP_LISP_FVALUE(obj));
+		xp_sprintf (buf, xp_countof(buf), XP_TEXT("%f"), XP_LSP_FVALUE(obj));
+		OUTPUT_STR (lsp, buf);
 		break;
-	case XP_LISP_OBJ_SYMBOL:
+	case XP_LSP_OBJ_SYMBOL:
-		xp_fprintf (lsp->outstream,XP_TEXT("%s"), XP_LISP_SYMVALUE(obj));
+		OUTPUT_STR (lsp, XP_LSP_SYMVALUE(obj));
 		break;
-	case XP_LISP_OBJ_STRING:
+	case XP_LSP_OBJ_STRING:
-		xp_fprintf (lsp->outstream,XP_TEXT("\"%s\""), XP_LISP_STRVALUE(obj));
+		OUTPUT_STR (lsp, XP_LSP_STRVALUE(obj));
 		break;
-	case XP_LISP_OBJ_CONS:
+	case XP_LSP_OBJ_CONS:
 		{
-			xp_lisp_obj_t* p = obj;
+			const xp_lsp_obj_t* p = obj;
-			xp_fprintf (lsp->outstream,XP_TEXT("("));
+			OUTPUT_STR (lsp, XP_TEXT("("));
 			do {
-				xp_lisp_print (lsp, XP_LISP_CAR(p));
+				xp_lsp_print (lsp, XP_LSP_CAR(p));
-				p = XP_LISP_CDR(p);
+				p = XP_LSP_CDR(p);
 				if (p != lsp->mem->nil) {
-					xp_fprintf (lsp->outstream,XP_TEXT(" "));
+					OUTPUT_STR (lsp, XP_TEXT(" "));
-					if (XP_LISP_TYPE(p) != XP_LISP_OBJ_CONS) {
+					if (XP_LSP_TYPE(p) != XP_LSP_OBJ_CONS) {
-						xp_fprintf (lsp->outstream,XP_TEXT(". "));
+						OUTPUT_STR (lsp, XP_TEXT(". "));
-						xp_lisp_print (lsp, p);
+						xp_lsp_print (lsp, p);
 					}
 				}
-			} while (p != lsp->mem->nil && XP_LISP_TYPE(p) == XP_LISP_OBJ_CONS);
+			} while (p != lsp->mem->nil && XP_LSP_TYPE(p) == XP_LSP_OBJ_CONS);
-			xp_fprintf (lsp->outstream,XP_TEXT(")"));
+			OUTPUT_STR (lsp, XP_TEXT(")"));
 		}
 		break;
-	case XP_LISP_OBJ_FUNC:
+	case XP_LSP_OBJ_FUNC:
-		xp_fprintf (lsp->outstream,XP_TEXT("func"));
+		OUTPUT_STR (lsp, XP_TEXT("func"));
 		break;
-	case XP_LISP_OBJ_MACRO:
+	case XP_LSP_OBJ_MACRO:
-		xp_fprintf (lsp->outstream,XP_TEXT("macro"));
+		OUTPUT_STR (lsp, XP_TEXT("macro"));
 		break;
-	case XP_LISP_OBJ_PRIM:
+	case XP_LSP_OBJ_PRIM:
-		xp_fprintf (lsp->outstream,XP_TEXT("prim"));
+		OUTPUT_STR (lsp, XP_TEXT("prim"));
 		break;
 	default:
-		xp_fprintf (lsp->outstream, 
+		xp_sprintf (buf, xp_countof(buf),
-			XP_TEXT("unknown object type: %d"), XP_LISP_TYPE(obj)); 
+			XP_TEXT("unknown object type: %d"), XP_LSP_TYPE(obj)); 
+		OUTPUT_STR (lsp, buf);
 	}
+
+	return 0;
 }
 

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 <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_CLEAR(lsp)   xp_lsp_token_clear (&(lsp)->token)
-#define TOKEN_TYPE(lsp)    lsp->token->type
+#define TOKEN_TYPE(lsp)    (lsp)->token.type
-#define TOKEN_IVALUE(lsp)  lsp->token->ivalue
+#define TOKEN_IVALUE(lsp)  (lsp)->token.ivalue
-#define TOKEN_FVALUE(lsp)  lsp->token->fvalue
+#define TOKEN_FVALUE(lsp)  (lsp)->token.fvalue
-#define TOKEN_SVALUE(lsp)  lsp->token->buffer
+#define TOKEN_SVALUE(lsp)  (lsp)->token.name.buffer
-#define TOKEN_SLENGTH(lsp) lsp->token->size
+#define TOKEN_SLENGTH(lsp) (lsp)->token.name.size
 #define TOKEN_ADD_CHAR(lsp,ch) \
 	do { \
-		if (xp_lisp_token_addc (lsp->token, ch) == -1) { \
+		if (xp_lsp_token_addc (&(lsp)->token, ch) == -1) { \
-			lsp->error = XP_LISP_ERR_MEM; \
+			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_lsp_obj_t* read_obj   (xp_lsp_t* lsp);
-static xp_lisp_obj_t* read_list  (xp_lisp_t* lsp);
+static xp_lsp_obj_t* read_list  (xp_lsp_t* lsp);
-static xp_lisp_obj_t* read_quote (xp_lisp_t* lsp);
+static xp_lsp_obj_t* read_quote (xp_lsp_t* lsp);
 
-static int read_token  (xp_lisp_t* lsp);
+static int read_token  (xp_lsp_t* lsp);
-static int read_number (xp_lisp_t* lsp, int negative);
+static int read_number (xp_lsp_t* lsp, int negative);
-static int read_ident  (xp_lisp_t* lsp);
+static int read_ident  (xp_lsp_t* lsp);
-static int read_string (xp_lisp_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) { \
+		if (lsp->input_func == XP_NULL) { \
-			lsp->error = XP_LISP_ERR_READ; \
+			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)
 
-
+xp_lsp_obj_t* xp_lsp_read (xp_lsp_t* lsp)
-void xp_lisp_set_creader (xp_lisp_t* lsp, xp_lisp_creader_t func, void* extra)
 {
-	xp_assert (lsp != XP_NULL);
+	/*NEXT_CHAR (lsp);*/
-
+	if (lsp->input_func == XP_NULL) {
-	lsp->creader          = func;
+		lsp->errnum = XP_LSP_ERR_INPUT_NOT_ATTACHED;
-	lsp->creader_extra    = extra;
+		return XP_NULL;
-	lsp->creader_just_set = 1;
+	}
-}
+	else if (lsp->input_func(XP_LSP_IO_CHAR, lsp, XP_NULL) == -1) {
-
+		lsp->errnum = XP_LSP_ERR_INPUT;
-xp_lisp_obj_t* xp_lisp_read (xp_lisp_t* lsp)
+		return XP_NULL;
-{
-	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;
 	}
 
-	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));
+		obj = xp_lsp_make_int (lsp->mem, TOKEN_IVALUE(lsp));
-		if (obj == XP_NULL) lsp->error = XP_LISP_ERR_MEM;
+		if (obj == XP_NULL) lsp->errnum = XP_LSP_ERR_MEM;
-		xp_lisp_lock (obj);
+		xp_lsp_lock (obj);
 		return obj;
 	case TOKEN_FLOAT:
-		obj = xp_lisp_make_float (lsp->mem, TOKEN_FVALUE(lsp));
+		obj = xp_lsp_make_float (lsp->mem, TOKEN_FVALUE(lsp));
-		if (obj == XP_NULL) lsp->error = XP_LISP_ERR_MEM;
+		if (obj == XP_NULL) lsp->errnum = XP_LSP_ERR_MEM;
-		xp_lisp_lock (obj);
+		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;
+		if (obj == XP_NULL) lsp->errnum = XP_LSP_ERR_MEM;
-		xp_lisp_lock (obj);
+		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;
+			if (obj == XP_NULL) lsp->errnum = XP_LSP_ERR_MEM;
-			xp_lisp_lock (obj);
+			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_lsp_obj_t* obj;
-	xp_lisp_obj_cons_t* p, * first = XP_NULL, * prev = XP_NULL;
+	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;

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 <xp/lsp/lsp.h>
+#include <xp/lsp/types.h>
 #include <xp/lsp/name.h>
 
 enum