diff --git a/ase/lsp/eval.c b/ase/lsp/eval.c index 45a0cd72..aa804b7c 100644 --- a/ase/lsp/eval.c +++ b/ase/lsp/eval.c @@ -1,9 +1,10 @@ /* - * $Id: eval.c,v 1.22 2006-11-02 10:30:28 bacon Exp $ + * $Id: eval.c,v 1.23 2006-11-02 11:10:12 bacon Exp $ */ #include +static ase_lsp_obj_t* __eval (ase_lsp_t* lsp, ase_lsp_obj_t* obj); static ase_lsp_obj_t* make_func ( ase_lsp_t* lsp, ase_lsp_obj_t* cdr, int is_macro); static ase_lsp_obj_t* eval_cons ( @@ -14,6 +15,18 @@ static ase_lsp_obj_t* apply_to_prim ( ase_lsp_t* lsp, ase_lsp_obj_t* func, ase_lsp_obj_t* actual); ase_lsp_obj_t* ase_lsp_eval (ase_lsp_t* lsp, ase_lsp_obj_t* obj) +{ + ase_lsp_obj_t* ret; + + //push_to_eval_stack (obj); + + ret = __eval (lsp, obj); + //pop (); + + return ret; +} + +static ase_lsp_obj_t* __eval (ase_lsp_t* lsp, ase_lsp_obj_t* obj) { lsp->errnum = ASE_LSP_ENOERR; diff --git a/ase/lsp/lsp.c b/ase/lsp/lsp.c index 72b5977b..42efabad 100644 --- a/ase/lsp/lsp.c +++ b/ase/lsp/lsp.c @@ -1,5 +1,5 @@ /* - * $Id: lsp.c,v 1.16 2006-11-02 10:12:01 bacon Exp $ + * $Id: lsp.c,v 1.17 2006-11-02 11:10:12 bacon Exp $ */ #if defined(__BORLANDC__) @@ -203,6 +203,7 @@ static int __add_builtin_prims (ase_lsp_t* lsp) ADD_PRIM (lsp, ASE_T("demac"), 5, ase_lsp_prim_demac, 3, MAX_ARGS); ADD_PRIM (lsp, ASE_T("let"), 3, ase_lsp_prim_let, 1, MAX_ARGS); ADD_PRIM (lsp, ASE_T("let*"), 4, ase_lsp_prim_letx, 1, MAX_ARGS); + ADD_PRIM (lsp, ASE_T("or"), 2, ase_lsp_prim_or, 2, MAX_ARGS); ADD_PRIM (lsp, ASE_T("="), 1, ase_lsp_prim_eq, 2, 2); ADD_PRIM (lsp, ASE_T("/="), 2, ase_lsp_prim_ne, 2, 2); diff --git a/ase/lsp/mem.c b/ase/lsp/mem.c index f7112915..0d37edc3 100644 --- a/ase/lsp/mem.c +++ b/ase/lsp/mem.c @@ -1,5 +1,5 @@ /* - * $Id: mem.c,v 1.23 2006-11-02 10:12:01 bacon Exp $ + * $Id: mem.c,v 1.24 2006-11-02 11:10:12 bacon Exp $ */ #include @@ -90,6 +90,7 @@ ase_lsp_obj_t* ase_lsp_alloc (ase_lsp_mem_t* mem, int type, ase_size_t size) { ase_lsp_obj_t* obj; +ase_lsp_collectgarbage(mem); if (mem->count >= mem->ubound) ase_lsp_collectgarbage (mem); if (mem->count >= mem->ubound) { diff --git a/ase/lsp/prim.c b/ase/lsp/prim.c index f6dae8ed..d7f8f661 100644 --- a/ase/lsp/prim.c +++ b/ase/lsp/prim.c @@ -1,5 +1,5 @@ /* - * $Id: prim.c,v 1.17 2006-11-02 10:12:01 bacon Exp $ + * $Id: prim.c,v 1.18 2006-11-02 11:10:12 bacon Exp $ */ #include @@ -404,3 +404,26 @@ ase_lsp_obj_t* ase_lsp_prim_demac (ase_lsp_t* lsp, ase_lsp_obj_t* args) } return mac; } + +ase_lsp_obj_t* ase_lsp_prim_or (ase_lsp_t* lsp, ase_lsp_obj_t* args) +{ + /* + * (or 10 20 30 40) + * (or (= n 20) (= n 30)) + */ + ase_lsp_obj_t* tmp; + +/* TODO: this is wrong. redo the work */ + while (ASE_LSP_TYPE(args) == ASE_LSP_OBJ_CONS) + { + tmp = ase_lsp_eval (lsp, ASE_LSP_CAR(args)); + if (tmp == ASE_NULL) return ASE_NULL; + + if (ASE_LSP_TYPE(args) == ASE_LSP_OBJ_INT) + if (tmp != lsp->mem->nil) return lsp->mem->t; + args = ASE_LSP_CDR(args); + } + + return lsp->mem->nil; +} + diff --git a/ase/lsp/prim.h b/ase/lsp/prim.h index 051fc8b2..a3828fcf 100644 --- a/ase/lsp/prim.h +++ b/ase/lsp/prim.h @@ -1,5 +1,5 @@ /* - * $Id: prim.h,v 1.12 2006-11-02 06:46:31 bacon Exp $ + * $Id: prim.h,v 1.13 2006-11-02 11:10:12 bacon Exp $ */ #ifndef _ASE_LSP_PRIM_H_ @@ -32,6 +32,7 @@ ase_lsp_obj_t* ase_lsp_prim_defun (ase_lsp_t* lsp, ase_lsp_obj_t* args); ase_lsp_obj_t* ase_lsp_prim_demac (ase_lsp_t* lsp, ase_lsp_obj_t* args); ase_lsp_obj_t* ase_lsp_prim_let (ase_lsp_t* lsp, ase_lsp_obj_t* args); ase_lsp_obj_t* ase_lsp_prim_letx (ase_lsp_t* lsp, ase_lsp_obj_t* args); +ase_lsp_obj_t* ase_lsp_prim_or (ase_lsp_t* lsp, ase_lsp_obj_t* args); /*--------------------- prim_compar.c diff --git a/ase/test/lsp/t5.lsp b/ase/test/lsp/t5.lsp index 01f2c56b..066dbf60 100644 --- a/ase/test/lsp/t5.lsp +++ b/ase/test/lsp/t5.lsp @@ -1,6 +1,7 @@ ; Compute the N'th Fibonacci number. (defun fibonacci (N) - (if (or (zerop N) (= N 1)) + ;(if (or (zerop N) (= N 1)) + (if (or (= N 0) (= N 1)) 1 (+ (fibonacci (- N 1)) (fibonacci (- N 2))))) diff --git a/ase/test/lsp/t6.lsp b/ase/test/lsp/t6.lsp new file mode 100644 index 00000000..a411e278 --- /dev/null +++ b/ase/test/lsp/t6.lsp @@ -0,0 +1,9 @@ + + +(setq x '(a b c)) +(setq y '(x y z)) +(setcar x y) +(setcar y x) +x +y +