From cecd643ab2de3e4dbd69e76c58b928ab2aa2a80f Mon Sep 17 00:00:00 2001
From: Teddy <ted.sybil@gmail.com>
Date: Wed, 7 Aug 2013 00:56:37 +0800
Subject: list checking fix

---
 TODO.rst    |   1 -
 builtin.cpp | 157 ++++++++++++++++++++++++++++++++++++++++++------------------
 builtin.h   |   2 +-
 consts.cpp  |   3 +-
 consts.h    |   3 +-
 eval.cpp    |   2 +
 main.cpp    |   7 +--
 model.cpp   |  16 +++++--
 model.h     |   4 +-
 parser.cpp  |   6 ++-
 10 files changed, 139 insertions(+), 62 deletions(-)

diff --git a/TODO.rst b/TODO.rst
index 26daef7..b90ca50 100644
--- a/TODO.rst
+++ b/TODO.rst
@@ -1,3 +1,2 @@
 - GMP
-- Pair literal parsing
 - Add macro support
diff --git a/builtin.cpp b/builtin.cpp
index 0bbd67e..65c1109 100644
--- a/builtin.cpp
+++ b/builtin.cpp
@@ -16,6 +16,27 @@ static const int NUM_LVL_REAL = 1;
 static const int NUM_LVL_RAT = 2;
 static const int NUM_LVL_INT = 3;
 
+#define ARGS_EXACTLY_TWO \
+    if (args == empty_list || !args->cdr->is_cons_obj() || \
+            TO_CONS(args->cdr)->cdr != empty_list) \
+        throw TokenError(name, RUN_ERR_WRONG_NUM_OF_ARGS) \
+
+#define ARGS_EXACTLY_ONE \
+    if (args == empty_list || !args->cdr->is_cons_obj() ) \
+        throw TokenError(name, RUN_ERR_WRONG_NUM_OF_ARGS)
+
+#define ARGS_AT_LEAST_ONE \
+    if (args == empty_list) \
+        throw TokenError(name, RUN_ERR_WRONG_NUM_OF_ARGS)
+
+bool is_list(Cons *ptr) {
+    EvalObj *nptr; 
+    for (;;) 
+        if ((nptr = ptr->cdr)->is_cons_obj()) 
+            ptr = TO_CONS(nptr); 
+        else break; 
+    return ptr->cdr == empty_list;
+}
 
 string double_to_str(double val, bool force_sign = false) {
     stringstream ss;
@@ -397,23 +418,37 @@ string IntNumObj::ext_repr() {
     return int_to_str(val);
 }
 
-SpecialOptIf::SpecialOptIf() : SpecialOptObj() {}
+SpecialOptIf::SpecialOptIf() : SpecialOptObj("if") {}
 
 void SpecialOptIf::prepare(Cons *pc) {
+#define IF_EXP_ERR \
+        throw TokenError("if", RUN_ERR_WRONG_NUM_OF_ARGS)
     state = 0;  // Prepared
 
-    pc = TO_CONS(pc->cdr);
+    if (pc->cdr->is_cons_obj())
+        pc = TO_CONS(pc->cdr);
+    else 
+        IF_EXP_ERR;
     if (pc == empty_list)
-        throw TokenError("if", SYN_ERR_MISS_OR_EXTRA_EXP);
+        IF_EXP_ERR;
+
     pc->skip = false;
 
-    pc = TO_CONS(pc->cdr);
+    if (pc->cdr->is_cons_obj())
+        pc = TO_CONS(pc->cdr);
+    else
+        IF_EXP_ERR;
     if (pc == empty_list)
-        throw TokenError("if", SYN_ERR_MISS_OR_EXTRA_EXP);
+        IF_EXP_ERR;
 
     pc->skip = true;
     if (pc->cdr != empty_list)
-        TO_CONS(pc->cdr)->skip = true;
+    {
+        if (pc->cdr->is_cons_obj())
+            TO_CONS(pc->cdr)->skip = true;
+        else
+            IF_EXP_ERR;
+    }
 }
 
 void SpecialOptIf::pre_call(ArgList *args, Cons *pc,
@@ -468,11 +503,43 @@ Cons *SpecialOptIf::call(ArgList *args, Environment * &envt,
 
 string SpecialOptIf::ext_repr() { return string("#<Builtin Macro: if>"); }
 
-SpecialOptLambda::SpecialOptLambda() : SpecialOptObj() {}
-#define FILL_MARKS(pc, flag) \
-    for (Cons *ptr = TO_CONS(pc->cdr); \
-            ptr != empty_list; ptr = TO_CONS(ptr->cdr)) \
-ptr->skip = flag
+SpecialOptLambda::SpecialOptLambda() : SpecialOptObj("lambda") {}
+#define FILL_MARKS(pc, flag)  \
+do  \
+{ \
+    EvalObj *nptr; \
+    Cons *ptr; \
+    for (ptr = TO_CONS(pc->cdr);;)  \
+    { \
+        ptr->skip = flag; \
+        if ((nptr = ptr->cdr)->is_cons_obj()) \
+            ptr = TO_CONS(nptr); \
+        else break; \
+    } \
+    if (ptr->cdr != empty_list) \
+        throw TokenError(name, RUN_ERR_WRONG_NUM_OF_ARGS); \
+} \
+while (0)
+
+#define CHECK_PARA_LIST(p) \
+do  \
+{ \
+    if (p == empty_list) break; \
+    EvalObj *nptr; \
+    Cons *ptr; \
+    for (ptr = TO_CONS(p);;)  \
+    { \
+        if (!ptr->car->is_sym_obj()) \
+            throw TokenError(ptr->car->ext_repr(), RUN_ERR_WRONG_NUM_OF_ARGS); \
+        if ((nptr = ptr->cdr)->is_cons_obj()) \
+            ptr = TO_CONS(nptr); \
+        else break; \
+    } \
+    if (ptr->cdr != empty_list) \
+        throw TokenError(name, RUN_ERR_WRONG_NUM_OF_ARGS); \
+} \
+while (0)
+
 
 void SpecialOptLambda::prepare(Cons *pc) {
     // Do not evaluate anything
@@ -486,16 +553,20 @@ Cons *SpecialOptLambda::call(ArgList *args, Environment * &envt,
     Cons *pc = static_cast<Cons*>(ret_addr->car);
 
     if (pc->cdr == empty_list)
-        throw TokenError("lambda", SYN_ERR_EMPTY_PARA_LIST);
+        throw TokenError(name, SYN_ERR_EMPTY_PARA_LIST);
     if (TO_CONS(pc->cdr)->cdr == empty_list)
-        throw TokenError("lambda", SYN_ERR_MISS_OR_EXTRA_EXP);
+        throw TokenError(name, SYN_ERR_MISS_OR_EXTRA_EXP);
 
-    SymbolList *para_list = static_cast<SymbolList*>(TO_CONS(pc->cdr)->car); 
-    // Clear the flag to avoid side-effects (e.g. proc calling)
+     // 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); 
 
     // store a list of expressions inside <body>
-    ASTList *body = TO_CONS(TO_CONS(pc->cdr)->cdr);       // Truncate the expression list
+
+    ASTList *body = TO_CONS(pc->cdr);       // Truncate the expression list
     for (Cons *ptr = body; ptr != empty_list; ptr = TO_CONS(ptr->cdr))
         ptr->next = NULL;    // Make each expression an orphan
 
@@ -505,17 +576,17 @@ Cons *SpecialOptLambda::call(ArgList *args, Environment * &envt,
 
 string SpecialOptLambda::ext_repr() { return string("#<Builtin Macro: lambda>"); }
 
-SpecialOptDefine::SpecialOptDefine() : SpecialOptObj() {}
+SpecialOptDefine::SpecialOptDefine() : SpecialOptObj("define") {}
 
 void SpecialOptDefine::prepare(Cons *pc) {
-    if (pc->cdr == empty_list)
-        throw TokenError("define", SYN_ERR_MISS_OR_EXTRA_EXP);
+    if (!pc->cdr->is_cons_obj())
+        throw TokenError(name, RUN_ERR_WRONG_NUM_OF_ARGS);
 
-    if (TO_CONS(pc->cdr)->car->is_simple_obj())  // Simple value assignment
+    pc = TO_CONS(pc->cdr);
+    if (pc->car->is_simple_obj())  // Simple value assignment
     {
-        pc = TO_CONS(pc->cdr);
-        if (pc->cdr == empty_list)
-            throw TokenError("define", SYN_ERR_MISS_OR_EXTRA_EXP);
+        if (!pc->cdr->is_cons_obj())
+            throw TokenError(name, RUN_ERR_WRONG_NUM_OF_ARGS);
         pc->skip = true;           // Skip the identifier
         TO_CONS(pc->cdr)->skip = false; 
     }                                   // Procedure definition
@@ -533,19 +604,20 @@ Cons *SpecialOptDefine::call(ArgList *args, Environment * &envt,
     {
         if (!first->is_sym_obj())
             throw TokenError(first->ext_repr(), SYN_ERR_NOT_AN_ID);
-
+        ARGS_EXACTLY_TWO;
         id = static_cast<SymObj*>(first);
         obj = TO_CONS(args->cdr)->car;
     }
     else
     {
         // static_cast because of is_simple_obj() is false
-        Cons *plst = static_cast<Cons*>(TO_CONS(pc->cdr)->car);
+        Cons *plst = static_cast<Cons*>(first);
 
         if (plst == empty_list)
-            throw TokenError("if", SYN_ERR_EMPTY_PARA_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);
 
         id = static_cast<SymObj*>(plst->car);
         ArgList *para_list = TO_CONS(plst->cdr);
@@ -555,7 +627,7 @@ Cons *SpecialOptDefine::call(ArgList *args, Environment * &envt,
         ASTList *body = TO_CONS(TO_CONS(pc->cdr)->cdr);   // Truncate the expression list
 
         if (body == empty_list)
-            throw TokenError("define", SYN_ERR_MISS_OR_EXTRA_EXP);
+            throw TokenError(name, SYN_ERR_MISS_OR_EXTRA_EXP);
 
         for (Cons *ptr = body; ptr != empty_list; ptr = TO_CONS(ptr->cdr))
             ptr->next = NULL;           // Make each expression a orphan
@@ -570,15 +642,17 @@ Cons *SpecialOptDefine::call(ArgList *args, Environment * &envt,
 string SpecialOptDefine::ext_repr() { return string("#<Builtin Macro: define>"); }
 
 void SpecialOptSet::prepare(Cons *pc) {
+    if (!pc->cdr->is_cons_obj())
+        throw TokenError(name, RUN_ERR_WRONG_NUM_OF_ARGS);
+
     pc = TO_CONS(pc->cdr);
-    if (pc == empty_list)
-        throw TokenError("set!", SYN_ERR_MISS_OR_EXTRA_EXP);
 
     pc->skip = true;       // Skip the identifier
 
+    if (!pc->cdr->is_cons_obj())
+        throw TokenError(name, RUN_ERR_WRONG_NUM_OF_ARGS);
+
     pc = TO_CONS(pc->cdr);
-    if (pc == empty_list)
-        throw TokenError("set!", SYN_ERR_MISS_OR_EXTRA_EXP);
 
     pc->skip = false; 
 }
@@ -591,6 +665,7 @@ Cons *SpecialOptSet::call(ArgList *args, Environment * &envt,
 
     if (!first->is_sym_obj())
         throw TokenError(first->ext_repr(), SYN_ERR_NOT_AN_ID);
+    ARGS_EXACTLY_TWO;
 
     SymObj *id = static_cast<SymObj*>(first);
 
@@ -600,11 +675,11 @@ Cons *SpecialOptSet::call(ArgList *args, Environment * &envt,
     return ret_addr->next;
 }
 
-SpecialOptSet::SpecialOptSet() {}
+SpecialOptSet::SpecialOptSet() : SpecialOptObj("set!") {}
 
 string SpecialOptSet::ext_repr() { return string("#<Builtin Macro: set!>"); }
 
-SpecialOptQuote::SpecialOptQuote() {}
+SpecialOptQuote::SpecialOptQuote() : SpecialOptObj("quote") {}
 
 void SpecialOptQuote::prepare(Cons *pc) {
     // Do not evaluate anything
@@ -623,20 +698,6 @@ Cons *SpecialOptQuote::call(ArgList *args, Environment * &envt,
 
 string SpecialOptQuote::ext_repr() { return string("#<Builtin Macro: quote>"); }
 
-#define ARGS_EXACTLY_TWO \
-    if (args == empty_list || \
-            args->cdr == empty_list || \
-            TO_CONS(args->cdr)->cdr != empty_list) \
-throw TokenError(name, RUN_ERR_WRONG_NUM_OF_ARGS)
-
-#define ARGS_EXACTLY_ONE \
-    if (args == empty_list || \
-            args->cdr != empty_list) \
-throw TokenError(name, RUN_ERR_WRONG_NUM_OF_ARGS)
-
-#define ARGS_AT_LEAST_ONE \
-    if (args == empty_list) \
-throw TokenError(name, RUN_ERR_WRONG_NUM_OF_ARGS)
 
 BUILTIN_PROC_DEF(make_pair) {
     ARGS_EXACTLY_TWO;
@@ -660,6 +721,8 @@ BUILTIN_PROC_DEF(pair_cdr) {
 }
 
 BUILTIN_PROC_DEF(make_list) {
+    if (!is_list(args))
+        throw TokenError(name, RUN_ERR_WRONG_NUM_OF_ARGS); 
     return args;
 }
 
diff --git a/builtin.h b/builtin.h
index c1a38bd..a01c93e 100644
--- a/builtin.h
+++ b/builtin.h
@@ -6,7 +6,7 @@
 
 using std::string;
 
-
+bool is_list(Cons *ptr);
 
 /** @class InexactNumObj
  * Inexact number implementation (using doubles)
diff --git a/consts.cpp b/consts.cpp
index eb17eaa..ffa0b30 100644
--- a/consts.cpp
+++ b/consts.cpp
@@ -14,5 +14,6 @@ const char *ERR_MSG[] = {
     "Illegal character in escape sequence: #\\%s",
     "Unknown character name: %s",
     "Improper pair structure",
-    "Improper vector structure"
+    "Improper vector structure",
+    "Bad formal %s in expression"
 };
diff --git a/consts.h b/consts.h
index dc2c4f6..f9e2425 100644
--- a/consts.h
+++ b/consts.h
@@ -15,7 +15,8 @@ enum ErrCode {
     PAR_ERR_ILLEGAL_CHAR_IN_ESC,
     RUN_ERR_UNKNOWN_CHAR_NAME,
     PAR_ERR_IMPROPER_PAIR,
-    PAR_ERR_IMPROPER_VECT
+    PAR_ERR_IMPROPER_VECT,
+    SYN_ERR_BAD_FORMAL
 };
 
 extern const char *ERR_MSG[];
diff --git a/eval.cpp b/eval.cpp
index e6e6de1..de43fe8 100644
--- a/eval.cpp
+++ b/eval.cpp
@@ -71,6 +71,8 @@ void push(Cons * &pc, FrameObj ** &top_ptr, Environment *envt) {
             throw NormalError(SYN_ERR_EMPTY_COMB);
 
         *top_ptr++ = new RetAddr(pc);       // Push the return address
+        if (!is_list(TO_CONS(pc->car)))
+            throw TokenError(pc->car->ext_repr(), RUN_ERR_WRONG_NUM_OF_ARGS); 
         // static_cast because of is_simple_obj() is false
         pc = static_cast<Cons*>(pc->car);  // Go deeper to enter the call
     }
diff --git a/main.cpp b/main.cpp
index eae0597..68f6c33 100644
--- a/main.cpp
+++ b/main.cpp
@@ -8,10 +8,11 @@
 #ifdef DEBUG
 extern Cons *empty_list;
 void tree_print(Cons *ptr) {
-    if (!ptr || ptr == empty_list) return;
     ptr->_debug_print();
-    tree_print(dynamic_cast<Cons*>(ptr->car));
-    tree_print(TO_CONS(ptr->cdr));
+    if (ptr->car->is_cons_obj())
+        tree_print(TO_CONS(ptr->car));
+    if (ptr->cdr->is_cons_obj())
+        tree_print(TO_CONS(ptr->cdr));
 }
 #endif
 
diff --git a/model.cpp b/model.cpp
index 4cfdca0..67db5fe 100644
--- a/model.cpp
+++ b/model.cpp
@@ -146,12 +146,18 @@ Cons *ProcObj::call(ArgList *args, Environment * &genvt,
     Environment *_envt = new Environment(envt);   
     // static_cast<SymObj*> because the para_list is already checked
     Cons *ptr, *ppar;
-    for (ptr = TO_CONS(args->cdr), ppar = para_list; 
-            ptr != empty_list && ppar != empty_list; 
-            ptr = TO_CONS(ptr->cdr), ppar = TO_CONS(ppar->cdr))
+    EvalObj *nptr;
+    for (ptr = TO_CONS(args->cdr), ppar = para_list;
+            ppar != empty_list; 
+            ppar = TO_CONS(ppar->cdr))
+    {
         _envt->add_binding(static_cast<SymObj*>(ppar->car), ptr->car);
+        if ((nptr = ptr->cdr)->is_cons_obj())
+            ptr = TO_CONS(nptr);
+        else break;
+    }
 
-    if (ptr != empty_list || ppar != empty_list)
+    if (ptr->cdr != empty_list || ppar->cdr != empty_list)
         throw TokenError("", RUN_ERR_WRONG_NUM_OF_ARGS);
 
     genvt = _envt;
@@ -166,7 +172,7 @@ string ProcObj::ext_repr() { return string("#<Procedure>"); }
 string ProcObj::_debug_repr() { return ext_repr(); }
 #endif
 
-SpecialOptObj::SpecialOptObj() : OptObj() {}
+SpecialOptObj::SpecialOptObj(string _name) : OptObj(), name(_name) {}
 
 BoolObj::BoolObj(bool _val) : EvalObj(CLS_SIM_OBJ | CLS_BOOL_OBJ), val(_val) {}
 
diff --git a/model.h b/model.h
index 8a8fc61..5a4800c 100644
--- a/model.h
+++ b/model.h
@@ -246,8 +246,10 @@ class ProcObj: public OptObj {
  * Special builtin syntax (`if`, `define`, `lambda`, etc.)
  */
 class SpecialOptObj: public OptObj {
+    protected:
+        string name;
     public:
-        SpecialOptObj();
+        SpecialOptObj(string name);
 };
 
 typedef EvalObj* (*BuiltinProc)(ArgList *, const string &);
diff --git a/parser.cpp b/parser.cpp
index 56b3dd9..f667933 100644
--- a/parser.cpp
+++ b/parser.cpp
@@ -175,9 +175,11 @@ Cons *ASTGenerator::absorb(Tokenizor *tk) {
                 EvalObj *obj = TO_EVAL(*top_ptr);
                 if (obj->is_sym_obj() && static_cast<SymObj*>(obj)->val == ".")
                 {
-                    improper = true;
-                    if (lst == empty_list || TO_CONS(lst)->cdr != empty_list)
+                    if (improper || 
+                        lst == empty_list || 
+                        TO_CONS(lst)->cdr != empty_list)
                         throw NormalError(PAR_ERR_IMPROPER_PAIR);
+                    improper = true;
                     lst = TO_CONS(lst)->car;
                 }
                 else
-- 
cgit v1.2.3-70-g09d2