From cff8072df5daba2c38ae2765af36cbb09da358f1 Mon Sep 17 00:00:00 2001 From: Teddy Date: Thu, 8 Aug 2013 11:01:11 +0800 Subject: `lambda` and `define` are fully supported now --- builtin.cpp | 76 +++++++++++++++++++++++++++++++++++++++++++++++++------------ builtin.h | 4 ++++ eval.cpp | 2 ++ model.cpp | 23 ++++++++++--------- model.h | 6 ++--- 5 files changed, 82 insertions(+), 29 deletions(-) diff --git a/builtin.cpp b/builtin.cpp index b3ba376..573159a 100644 --- a/builtin.cpp +++ b/builtin.cpp @@ -469,6 +469,7 @@ IntNumObj *IntNumObj::from_string(string repr) { } return new IntNumObj(val); } +int IntNumObj::get_i() { return val; } #else IntNumObj::IntNumObj(mpz_class _val) : ExactNumObj(NUM_LVL_INT), val(_val) {} IntNumObj *IntNumObj::from_string(string repr) { @@ -482,6 +483,7 @@ IntNumObj *IntNumObj::from_string(string repr) { return NULL; } } +int IntNumObj::get_i() { return val.get_si(); } #endif IntNumObj *IntNumObj::convert(NumObj *obj) { @@ -630,18 +632,25 @@ do \ { \ EvalObj *nptr; \ Cons *ptr; \ - for (ptr = TO_CONS(pc->cdr);;) \ + for (ptr = pc;;) \ { \ - ptr->skip = flag; \ if ((nptr = ptr->cdr)->is_cons_obj()) \ ptr = TO_CONS(nptr); \ else break; \ + ptr->skip = flag; \ } \ if (ptr->cdr != empty_list) \ throw TokenError(name, RUN_ERR_WRONG_NUM_OF_ARGS); \ } \ while (0) +#define CHECK_SYMBOL(ptr) \ +do \ +{ \ + if (!(ptr)->is_sym_obj()) \ + throw TokenError("a symbol", RUN_ERR_WRONG_TYPE); \ +} while (0) + #define CHECK_PARA_LIST(p) \ do \ { \ @@ -650,14 +659,13 @@ do \ Cons *ptr; \ for (ptr = TO_CONS(p);;) \ { \ - if (!ptr->car->is_sym_obj()) \ - throw TokenError(ptr->car->ext_repr(), RUN_ERR_WRONG_TYPE); \ if ((nptr = ptr->cdr)->is_cons_obj()) \ ptr = TO_CONS(nptr); \ else break; \ + CHECK_SYMBOL(ptr->car); \ } \ if (ptr->cdr != empty_list) \ - throw TokenError(name, RUN_ERR_WRONG_NUM_OF_ARGS); \ + CHECK_SYMBOL(ptr->cdr); \ } \ while (0) @@ -681,9 +689,12 @@ Cons *SpecialOptLambda::call(ArgList *args, Environment * &envt, // Clear the flag to avoid side-effects (e.g. proc calling) FILL_MARKS(pc, false); - pc = TO_CONS(pc->cdr); - CHECK_PARA_LIST(pc->car); - SymbolList *para_list = static_cast(pc->car); + pc = TO_CONS(pc->cdr); // Now pointintg to params + if (pc->car->is_simple_obj()) + CHECK_SYMBOL(pc->car); + else + CHECK_PARA_LIST(pc->car); + EvalObj *params = pc->car; // store a list of expressions inside @@ -691,7 +702,7 @@ Cons *SpecialOptLambda::call(ArgList *args, Environment * &envt, for (Cons *ptr = body; ptr != empty_list; ptr = TO_CONS(ptr->cdr)) ptr->next = NULL; // Make each expression an orphan - *top_ptr++ = new ProcObj(body, envt, para_list); + *top_ptr++ = new ProcObj(body, envt, params); return ret_addr->next; // Move to the next instruction } @@ -736,12 +747,14 @@ Cons *SpecialOptDefine::call(ArgList *args, Environment * &envt, if (plst == empty_list) throw TokenError(name, SYN_ERR_EMPTY_PARA_LIST); - if (!plst->car->is_sym_obj()) - throw TokenError(first->ext_repr(), SYN_ERR_NOT_AN_ID); - CHECK_PARA_LIST(plst->cdr); + CHECK_SYMBOL(plst->car); + if (plst->cdr->is_simple_obj()) + CHECK_SYMBOL(plst->cdr); + else + CHECK_PARA_LIST(plst->cdr); id = static_cast(plst->car); - ArgList *para_list = TO_CONS(plst->cdr); + EvalObj *params = plst->cdr; // Clear the flag to avoid side-effects (e.g. proc calling) FILL_MARKS(pc, false); @@ -753,7 +766,7 @@ Cons *SpecialOptDefine::call(ArgList *args, Environment * &envt, for (Cons *ptr = body; ptr != empty_list; ptr = TO_CONS(ptr->cdr)) ptr->next = NULL; // Make each expression a orphan - obj = new ProcObj(body, envt, para_list); + obj = new ProcObj(body, envt, params); } envt->add_binding(id, obj); *top_ptr++ = new UnspecObj(); @@ -1123,7 +1136,7 @@ Cons *copy_list(Cons *src, EvalObj * &tail) { EvalObj* nptr; Cons head(NULL, NULL); tail = &head; - for (; src != empty_list;) + for (;;) { TO_CONS(tail)->cdr = new Cons(*src); tail = TO_CONS(TO_CONS(tail)->cdr); @@ -1164,6 +1177,39 @@ BUILTIN_PROC_DEF(append) { return head; } +BUILTIN_PROC_DEF(reverse) { + ARGS_EXACTLY_ONE; + Cons *tail = empty_list; + EvalObj *ptr; + for (ptr = args->car; + ptr->is_cons_obj(); ptr = TO_CONS(ptr)->cdr) + tail = new Cons(TO_CONS(ptr)->car, tail); + if (ptr != empty_list) + throw TokenError("a list", RUN_ERR_WRONG_TYPE); + return tail; +} + +BUILTIN_PROC_DEF(list_tail) { + ARGS_EXACTLY_TWO; + EvalObj *sec = TO_CONS(args->cdr)->car; + if (!sec->is_num_obj() || + static_cast(sec)->level != NUM_LVL_INT) + throw TokenError("an exact integer", RUN_ERR_WRONG_TYPE); + int i, k = static_cast(sec)->get_i(); + if (k < 0) + throw TokenError("a non-negative integer", RUN_ERR_WRONG_TYPE); + EvalObj *ptr; + for (i = 0, ptr = args->car; + ptr->is_cons_obj(); ptr = TO_CONS(ptr)->cdr, i++) + if (i == k) break; + if (i != k) + throw TokenError("a pair", RUN_ERR_WRONG_TYPE); + EvalObj *tail; + if (ptr->is_cons_obj()) + return copy_list(TO_CONS(ptr), tail); + else + return ptr; +} BUILTIN_PROC_DEF(display) { ARGS_EXACTLY_ONE; diff --git a/builtin.h b/builtin.h index fe1c925..2756d18 100644 --- a/builtin.h +++ b/builtin.h @@ -117,10 +117,12 @@ class IntNumObj: public ExactNumObj { int val; /** Construct a integer */ IntNumObj(int val); + int get_i(); #else mpz_class val; /** Construct a integer */ IntNumObj(mpz_class val); + int get_i(); #endif /** Try to construct an IntNumObj object * @return NULL if failed @@ -260,6 +262,8 @@ BUILTIN_PROC_DEF(is_list); BUILTIN_PROC_DEF(make_list); BUILTIN_PROC_DEF(length); BUILTIN_PROC_DEF(append); +BUILTIN_PROC_DEF(reverse); +BUILTIN_PROC_DEF(list_tail); BUILTIN_PROC_DEF(display); diff --git a/eval.cpp b/eval.cpp index 244ac9c..50f14bf 100644 --- a/eval.cpp +++ b/eval.cpp @@ -49,6 +49,8 @@ void Evaluator::add_builtin_routines() { ADD_BUILTIN_PROC("list", make_list); ADD_BUILTIN_PROC("length", length); ADD_BUILTIN_PROC("append", append); + ADD_BUILTIN_PROC("reverse", reverse); + ADD_BUILTIN_PROC("list-tail", list_tail); ADD_BUILTIN_PROC("display", display); } diff --git a/model.cpp b/model.cpp index 89849ca..8ffc019 100644 --- a/model.cpp +++ b/model.cpp @@ -133,8 +133,8 @@ OptObj::OptObj() : EvalObj(CLS_SIM_OBJ | CLS_OPT_OBJ) {} ProcObj::ProcObj(ASTList *_body, Environment *_envt, - SymbolList *_para_list) : - OptObj(), body(_body), envt(_envt), para_list(_para_list) {} + EvalObj *_params) : + OptObj(), body(_body), envt(_envt), params(_params) {} Cons *ProcObj::call(ArgList *args, Environment * &genvt, Continuation * &cont, FrameObj ** &top_ptr) { @@ -144,20 +144,21 @@ Cons *ProcObj::call(ArgList *args, Environment * &genvt, Continuation *_cont = new Continuation(genvt, ret_addr, cont, body); // Create local env and recall the closure Environment *_envt = new Environment(envt); - // static_cast because the para_list is already checked - Cons *ppar; - EvalObj *nptr; - for (ppar = para_list; - ppar != empty_list; - ppar = TO_CONS(ppar->cdr)) + // static_cast because the params is already checked + EvalObj *ppar, *nptr; + for (ppar = params; + ppar->is_cons_obj(); + ppar = TO_CONS(ppar)->cdr) { - if ((nptr = args->cdr)->is_cons_obj()) + if ((nptr = args->cdr) != empty_list) args = TO_CONS(nptr); else break; - _envt->add_binding(static_cast(ppar->car), args->car); + _envt->add_binding(static_cast(TO_CONS(ppar)->car), args->car); } - if (args->cdr != empty_list || ppar != empty_list) + if (!ppar->is_cons_obj()) + _envt->add_binding(static_cast(ppar), args->cdr); // (... . var_n) + else if (args->cdr != empty_list || ppar != empty_list) throw TokenError("", RUN_ERR_WRONG_NUM_OF_ARGS); genvt = _envt; diff --git a/model.h b/model.h index 4522b89..9de41fc 100644 --- a/model.h +++ b/model.h @@ -227,13 +227,13 @@ class ProcObj: public OptObj { public: /** The procedure body, a list of expressions to be evaluated */ ASTList *body; - /** The arguments, a list of Symbols */ - SymbolList *para_list; + /** The arguments: | var1 ... | var1 var2 ... . varn */ + EvalObj *params; /** Pointer to the environment */ Environment *envt; /** Conctructs a ProcObj */ - ProcObj(ASTList *body, Environment *envt, SymbolList *para_list); + ProcObj(ASTList *body, Environment *envt, EvalObj *params); Cons *call(ArgList *args, Environment * &envt, Continuation * &cont, FrameObj ** &top_ptr); #ifdef DEBUG -- cgit v1.2.3-70-g09d2