`lambda` and `define` are fully supported now

author: Teddy <ted.sybil@gmail.com> 2013-08-08 11:01:11 +0800
committer: Teddy <ted.sybil@gmail.com> 2013-08-08 11:01:11 +0800
commit: cff8072df5daba2c38ae2765af36cbb09da358f1 (patch)
tree: 31ea2b425342c2de43fa6d58125f9ea995948452
parent: 56a85b5111751f5947579b5ee5cc92bdebb799c4 (diff)
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<SymbolList*>(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 <body>
 
@@ -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<SymObj*>(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<NumObj*>(sec)->level != NUM_LVL_INT)
+        throw TokenError("an exact integer", RUN_ERR_WRONG_TYPE);
+    int i, k = static_cast<IntNumObj*>(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<SymObj*> 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<SymObj*> 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<SymObj*>(ppar->car), args->car);
+        _envt->add_binding(static_cast<SymObj*>(TO_CONS(ppar)->car), args->car);
     }
 
-    if (args->cdr != empty_list || ppar != empty_list)
+    if (!ppar->is_cons_obj())
+        _envt->add_binding(static_cast<SymObj*>(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: <list> | 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
author	Teddy <ted.sybil@gmail.com>	2013-08-08 11:01:11 +0800
committer	Teddy <ted.sybil@gmail.com>	2013-08-08 11:01:11 +0800
commit	cff8072df5daba2c38ae2765af36cbb09da358f1 (patch)
tree	31ea2b425342c2de43fa6d58125f9ea995948452
parent	56a85b5111751f5947579b5ee5cc92bdebb799c4 (diff)