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

*** empty log message ***

Browse Source
This commit is contained in:
hyung-hwan 2005-09-19 12:04:00 +00:00
parent 6e6d3f0fa9
commit 324676bbe1
9 changed files with 300 additions and 219 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

38
ase/lsp/error.c Normal file
View File

@ -0,0 +1,38 @@
/*
* $Id: error.c,v 1.1 2005-09-19 12:04:00 bacon Exp $
*/
#include <xp/lsp/lsp.h>
#include <xp/bas/string.h>
static const xp_char_t* __errstr[] =
{
XP_TEXT("no error"),
XP_TEXT("abort"),
XP_TEXT("end"),
XP_TEXT("memory"),
XP_TEXT("input not attached"),
XP_TEXT("input"),
XP_TEXT("output not attached"),
XP_TEXT("output"),
XP_TEXT("syntax"),
XP_TEXT("bad arguments"),
XP_TEXT("wrong arguments"),
XP_TEXT("too few arguments"),
XP_TEXT("too many arguments"),
XP_TEXT("undefined function"),
XP_TEXT("bad function"),
XP_TEXT("duplicate formal"),
XP_TEXT("bad symbol"),
XP_TEXT("undefined symbol"),
XP_TEXT("empty body"),
XP_TEXT("bad value")
};
int xp_lsp_error (xp_lsp_t* lsp, xp_char_t* buf, xp_size_t size)
{
if (buf == XP_NULL || size == 0) return lsp->errnum;
xp_strxcpy (buf, size, __errstr[lsp->errnum]);
return lsp->errnum;
}

18
ase/lsp/init.c
View File

@ -1,5 +1,5 @@
/* /*
* $Id: init.c,v 1.4 2005-09-19 03:05:37 bacon Exp $ * $Id: init.c,v 1.5 2005-09-19 12:04:00 bacon Exp $
*/ */
#include <xp/lsp/lsp.h> #include <xp/lsp/lsp.h>
@ -56,22 +56,6 @@ void xp_lsp_close (xp_lsp_t* lsp)
if (lsp->__malloced) xp_free (lsp); if (lsp->__malloced) xp_free (lsp);
} }
int xp_lsp_error (xp_lsp_t* lsp, xp_char_t* buf, xp_size_t size)
{
if (buf != XP_NULL || size == 0) return lsp->errnum;
// TODO:...
/*
switch (lsp->errnum) {
default:
xp_lsp_copy_string (buf, size, "unknown error");
}
*/
return lsp->errnum;
}
int xp_lsp_attach_input (xp_lsp_t* lsp, xp_lsp_io_t input, void* arg) int xp_lsp_attach_input (xp_lsp_t* lsp, xp_lsp_io_t input, void* arg)
{ {
if (xp_lsp_detach_input(lsp) == -1) return -1; if (xp_lsp_detach_input(lsp) == -1) return -1;

4
ase/lsp/makefile.in
View File

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

5
ase/lsp/mem.c
View File

@ -1,5 +1,5 @@
/* /*
* $Id: mem.c,v 1.2 2005-09-19 03:05:37 bacon Exp $ * $Id: mem.c,v 1.3 2005-09-19 12:04:00 bacon Exp $
*/ */
#include <xp/lsp/mem.h> #include <xp/lsp/mem.h>
@ -175,7 +175,10 @@ xp_lsp_obj_t* xp_lsp_allocate (xp_lsp_mem_t* mem, int type, xp_size_t size)
XP_LSP_LINK(obj) = mem->used[type]; XP_LSP_LINK(obj) = mem->used[type];
mem->used[type] = obj; mem->used[type] = obj;
mem->count++; mem->count++;
#if 0
xp_dprint1 (XP_TEXT("mem->count: %u\n"), mem->count); xp_dprint1 (XP_TEXT("mem->count: %u\n"), mem->count);
#endif
return obj; return obj;
} }

233
ase/lsp/prim.c
View File

@ -1,5 +1,5 @@
/* /*
* $Id: prim.c,v 1.2 2005-09-18 11:34:35 bacon Exp $ * $Id: prim.c,v 1.3 2005-09-19 12:04:00 bacon Exp $
*/ */
#include <xp/lsp/lsp.h> #include <xp/lsp/lsp.h>
@ -30,51 +30,6 @@ xp_lsp_obj_t* xp_lsp_prim_eval (xp_lsp_t* lsp, xp_lsp_obj_t* args)
return tmp; 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_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_PRIM_CHECK_ARG_COUNT (lsp, args, 0, 0);
@ -179,7 +134,7 @@ xp_lsp_obj_t* xp_lsp_prim_while (xp_lsp_t* lsp, xp_lsp_obj_t* args)
tmp = XP_LSP_CDR(args); tmp = XP_LSP_CDR(args);
while (XP_LSP_TYPE(tmp) == XP_LSP_OBJ_CONS) { while (XP_LSP_TYPE(tmp) == XP_LSP_OBJ_CONS) {
if (xp_lsp_eval (lsp, XP_LSP_CAR(tmp)) == XP_NULL) return XP_NULL; if (xp_lsp_eval(lsp, XP_LSP_CAR(tmp)) == XP_NULL) return XP_NULL;
tmp = XP_LSP_CDR(tmp); tmp = XP_LSP_CDR(tmp);
} }
if (tmp != lsp->mem->nil) { if (tmp != lsp->mem->nil) {
@ -193,6 +148,10 @@ xp_lsp_obj_t* xp_lsp_prim_while (xp_lsp_t* lsp, xp_lsp_obj_t* args)
xp_lsp_obj_t* xp_lsp_prim_car (xp_lsp_t* lsp, xp_lsp_obj_t* args) xp_lsp_obj_t* xp_lsp_prim_car (xp_lsp_t* lsp, xp_lsp_obj_t* args)
{ {
/*
* (car '(10 20 30))
*/
xp_lsp_obj_t* tmp; xp_lsp_obj_t* tmp;
XP_LSP_PRIM_CHECK_ARG_COUNT (lsp, args, 1, 1); XP_LSP_PRIM_CHECK_ARG_COUNT (lsp, args, 1, 1);
@ -212,6 +171,10 @@ xp_lsp_obj_t* xp_lsp_prim_car (xp_lsp_t* lsp, xp_lsp_obj_t* args)
xp_lsp_obj_t* xp_lsp_prim_cdr (xp_lsp_t* lsp, xp_lsp_obj_t* args) xp_lsp_obj_t* xp_lsp_prim_cdr (xp_lsp_t* lsp, xp_lsp_obj_t* args)
{ {
/*
* (cdr '(10 20 30))
*/
xp_lsp_obj_t* tmp; xp_lsp_obj_t* tmp;
XP_LSP_PRIM_CHECK_ARG_COUNT (lsp, args, 1, 1); XP_LSP_PRIM_CHECK_ARG_COUNT (lsp, args, 1, 1);
@ -231,6 +194,11 @@ xp_lsp_obj_t* xp_lsp_prim_cdr (xp_lsp_t* lsp, xp_lsp_obj_t* args)
xp_lsp_obj_t* xp_lsp_prim_cons (xp_lsp_t* lsp, xp_lsp_obj_t* args) xp_lsp_obj_t* xp_lsp_prim_cons (xp_lsp_t* lsp, xp_lsp_obj_t* args)
{ {
/*
* (cons 10 20)
* (cons '(10 20) 30)
*/
xp_lsp_obj_t* car, * cdr, * cons; xp_lsp_obj_t* car, * cdr, * cons;
XP_LSP_PRIM_CHECK_ARG_COUNT (lsp, args, 2, 2); XP_LSP_PRIM_CHECK_ARG_COUNT (lsp, args, 2, 2);
@ -253,6 +221,12 @@ xp_lsp_obj_t* xp_lsp_prim_cons (xp_lsp_t* lsp, xp_lsp_obj_t* args)
xp_lsp_obj_t* xp_lsp_prim_set (xp_lsp_t* lsp, xp_lsp_obj_t* args) xp_lsp_obj_t* xp_lsp_prim_set (xp_lsp_t* lsp, xp_lsp_obj_t* args)
{ {
/*
* (set 'flowers 'rose)
* (set flowers 20)
* (rose)
*/
xp_lsp_obj_t* p1, * p2; xp_lsp_obj_t* p1, * p2;
XP_LSP_PRIM_CHECK_ARG_COUNT (lsp, args, 2, 2); XP_LSP_PRIM_CHECK_ARG_COUNT (lsp, args, 2, 2);
@ -279,6 +253,11 @@ xp_lsp_obj_t* xp_lsp_prim_set (xp_lsp_t* lsp, xp_lsp_obj_t* args)
xp_lsp_obj_t* xp_lsp_prim_setq (xp_lsp_t* lsp, xp_lsp_obj_t* args) xp_lsp_obj_t* xp_lsp_prim_setq (xp_lsp_t* lsp, xp_lsp_obj_t* args)
{ {
/*
* (setq x 10)
* (setq x "stirng")
*/
xp_lsp_obj_t* p = args, * p1, * p2 = lsp->mem->nil; xp_lsp_obj_t* p = args, * p1, * p2 = lsp->mem->nil;
while (p != lsp->mem->nil) { while (p != lsp->mem->nil) {
@ -311,6 +290,10 @@ xp_lsp_obj_t* xp_lsp_prim_setq (xp_lsp_t* lsp, xp_lsp_obj_t* args)
xp_lsp_obj_t* xp_lsp_prim_quote (xp_lsp_t* lsp, xp_lsp_obj_t* args) xp_lsp_obj_t* xp_lsp_prim_quote (xp_lsp_t* lsp, xp_lsp_obj_t* args)
{ {
/*
* (quote (10 20 30 50))
*/
XP_LSP_PRIM_CHECK_ARG_COUNT (lsp, args, 1, 1); XP_LSP_PRIM_CHECK_ARG_COUNT (lsp, args, 1, 1);
xp_assert (XP_LSP_TYPE(args) == XP_LSP_OBJ_CONS); xp_assert (XP_LSP_TYPE(args) == XP_LSP_OBJ_CONS);
return XP_LSP_CAR(args); return XP_LSP_CAR(args);
@ -319,8 +302,12 @@ xp_lsp_obj_t* xp_lsp_prim_quote (xp_lsp_t* lsp, xp_lsp_obj_t* args)
xp_lsp_obj_t* xp_lsp_prim_defun (xp_lsp_t* lsp, xp_lsp_obj_t* args) xp_lsp_obj_t* xp_lsp_prim_defun (xp_lsp_t* lsp, xp_lsp_obj_t* args)
{ {
/* /*
* (defun x (abc) x y z) * (defun x (a b) (+ a b 100))
* (setq x (lambda (abc) x y z)) * (x 40 50)
*
* (setq x (lambda (x y) (setq temp 10) (+ x y temp)))
* (x 40 50)
* temp
*/ */
xp_lsp_obj_t* name, * fun; xp_lsp_obj_t* name, * fun;
@ -372,154 +359,6 @@ xp_lsp_obj_t* xp_lsp_prim_demac (xp_lsp_t* lsp, xp_lsp_obj_t* args)
return mac; 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* xp_lsp_prim_plus (xp_lsp_t* lsp, xp_lsp_obj_t* args)
{ {
xp_lsp_obj_t* body, * tmp; xp_lsp_obj_t* body, * tmp;

160
ase/lsp/prim_let.c Normal file
View File

@ -0,0 +1,160 @@
/*
* $Id: prim_let.c,v 1.1 2005-09-19 12:04:00 bacon Exp $
*/
#include <xp/lsp/prim.h>
static xp_lsp_obj_t* __prim_let (
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)
{
/*
* (defun x (x y)
* (let ((temp1 10) (temp2 20))
* (+ x y temp1 temp2)))
* (x 40 50)
* temp1
*/
return __prim_let (lsp, args, 0);
}
xp_lsp_obj_t* xp_lsp_prim_letx (xp_lsp_t* lsp, xp_lsp_obj_t* args)
{
return __prim_let (lsp, args, 1);
}

50
ase/lsp/prim_prog.c Normal file
View File

@ -0,0 +1,50 @@
/*
* $Id: prim_prog.c,v 1.1 2005-09-19 12:04:00 bacon Exp $
*/
#include <xp/lsp/prim.h>
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;
}

9
ase/test/lsp/lisp.c
View File

@ -176,9 +176,14 @@ int xp_main (int argc, xp_char_t* argv[])
xp_sio_puts (xp_sio_out, XP_TEXT("\n")); xp_sio_puts (xp_sio_out, XP_TEXT("\n"));
} }
else { else {
if (lsp->errnum == XP_LSP_ERR_ABORT) break; int errnum;
xp_char_t errstr[256];
errnum = xp_lsp_error (lsp, errstr, xp_countof(errstr));
if (errnum == XP_LSP_ERR_ABORT) break;
xp_fprintf (xp_stderr, xp_fprintf (xp_stderr,
XP_TEXT("error while evaluating: %d\n"), lsp->errnum); XP_TEXT("error: [%d] %s\n"),
errnum, errstr);
} }
} }

2
ase/test/lsp/t1.lsp
View File

@ -11,6 +11,6 @@
;;;;;;; ;;;;;;;
(setq init-rand (macro (seed) (lambda () (setq seed (+ seed 1))))) (setq init-rand (macro (seed) (lambda () (setq seed (+ seed 1)))))
(setq init-rand (lambda (seed) (lambda () (setq seed (+ seed 1))))) (setq init-rand (lambda (seed) (lambda () (setq seed (+ seed 1)))))
(setq rand (init-rand 1)) (set 'rand (init-rand 1))
(rand) (rand)