added and restructured built-in procedures

6 files changed, 169 insertions, 79 deletions

diff --git a/TODO.rst b/TODO.rst
index 69a9c43..26daef7 100644
--- a/TODO.rst
+++ b/TODO.rst
@@ -1,4 +1,3 @@
-- More sophisticated parser
 - GMP
-- Quotation
+- Pair literal parsing
 - Add macro support
diff --git a/builtin.cpp b/builtin.cpp
index a0b3830..9d25644 100644
--- a/builtin.cpp
+++ b/builtin.cpp
@@ -623,41 +623,47 @@ Cons *SpecialOptQuote::call(ArgList *args, Environment * &envt,
 
 string SpecialOptQuote::ext_repr() { return string("#<Builtin Macro: quote>"); }
 
-
-EvalObj *builtin_cons(ArgList *args) {
-    if (args == empty_list ||
-        args->cdr == empty_list ||
-        TO_CONS(args->cdr)->cdr != empty_list)
-        throw TokenError("cons", RUN_ERR_WRONG_NUM_OF_ARGS);
-
+#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;
     return new Cons(args->car, TO_CONS(args->cdr)->car);
 }
 
-EvalObj *builtin_car(ArgList *args) {
-    if (args == empty_list ||
-        args->cdr != empty_list)
-        throw TokenError("car", RUN_ERR_WRONG_NUM_OF_ARGS);
+BUILTIN_PROC_DEF(pair_car) {
+    ARGS_EXACTLY_ONE;
     if (args->car == empty_list || !args->car->is_cons_obj())
-        throw TokenError("pair", RUN_ERR_WRONG_TYPE);
+        throw TokenError(name, RUN_ERR_WRONG_TYPE);
 
     return TO_CONS(args->car)->car;
 }
 
-EvalObj *builtin_cdr(ArgList *args) {
-    if (args == empty_list ||
-        args->cdr != empty_list)
-        throw TokenError("cdr", RUN_ERR_WRONG_NUM_OF_ARGS);
+BUILTIN_PROC_DEF(pair_cdr) {
+    ARGS_EXACTLY_ONE;
     if (args->car == empty_list || !args->car->is_cons_obj())
-        throw TokenError("pair", RUN_ERR_WRONG_TYPE);
+        throw TokenError(name, RUN_ERR_WRONG_TYPE);
 
     return TO_CONS(args->car)->cdr;
 }
 
-EvalObj *builtin_list(ArgList *args) {
+BUILTIN_PROC_DEF(make_list) {
     return args;
 }
 
-EvalObj *builtin_plus(ArgList *args) {
+BUILTIN_PROC_DEF(num_add) {
     NumObj *res = new IntNumObj(0), *opr; // the most accurate type
     for (Cons *ptr = args; ptr != empty_list; ptr = TO_CONS(ptr->cdr))
     {
@@ -674,9 +680,9 @@ EvalObj *builtin_plus(ArgList *args) {
     return res; 
 }
 
-EvalObj *builtin_minus(ArgList *args) {
+BUILTIN_PROC_DEF(num_sub) {
     if (args == empty_list)
-        throw TokenError("-", RUN_ERR_WRONG_NUM_OF_ARGS);
+        throw TokenError(name, RUN_ERR_WRONG_NUM_OF_ARGS);
     if (!args->car->is_num_obj())
         throw TokenError("a number", RUN_ERR_WRONG_TYPE);
 
@@ -698,7 +704,7 @@ EvalObj *builtin_minus(ArgList *args) {
     return res; 
 }
 
-EvalObj *builtin_multi(ArgList *args) {
+BUILTIN_PROC_DEF(num_multi) {
     NumObj *res = new IntNumObj(1), *opr; // the most accurate type
     for (Cons *ptr = args; ptr != empty_list; ptr = TO_CONS(ptr->cdr))
     {
@@ -715,9 +721,9 @@ EvalObj *builtin_multi(ArgList *args) {
     return res; 
 }
 
-EvalObj *builtin_div(ArgList *args) {
+BUILTIN_PROC_DEF(num_div) {
     if (args == empty_list)
-        throw TokenError("/", RUN_ERR_WRONG_NUM_OF_ARGS);
+        throw TokenError(name, RUN_ERR_WRONG_NUM_OF_ARGS);
     if (!args->car->is_num_obj())
         throw TokenError("a number", RUN_ERR_WRONG_TYPE);
 
@@ -739,9 +745,8 @@ EvalObj *builtin_div(ArgList *args) {
     return res; 
 }
 
-EvalObj *builtin_lt(ArgList *args) {
-    if (args == empty_list)
-        throw TokenError("<", RUN_ERR_WRONG_NUM_OF_ARGS);
+BUILTIN_PROC_DEF(num_lt) {
+    ARGS_AT_LEAST_ONE;
     if (!args->car->is_num_obj())
         throw TokenError("a number", RUN_ERR_WRONG_TYPE);
        
@@ -764,9 +769,8 @@ EvalObj *builtin_lt(ArgList *args) {
     return new BoolObj(true);
 }
 
-EvalObj *builtin_gt(ArgList *args) {
-    if (args == empty_list)
-        throw TokenError(">", RUN_ERR_WRONG_NUM_OF_ARGS);
+BUILTIN_PROC_DEF(num_gt) {
+    ARGS_AT_LEAST_ONE;
     if (!args->car->is_num_obj())
         throw TokenError("a number", RUN_ERR_WRONG_TYPE);
        
@@ -789,9 +793,8 @@ EvalObj *builtin_gt(ArgList *args) {
     return new BoolObj(true);
 }
 
-EvalObj *builtin_arithmetic_eq(ArgList *args) {
-    if (args == empty_list)
-        throw TokenError("=", RUN_ERR_WRONG_NUM_OF_ARGS);
+BUILTIN_PROC_DEF(num_eq) {
+    ARGS_AT_LEAST_ONE;
     if (!args->car->is_num_obj())
         throw TokenError("a number", RUN_ERR_WRONG_TYPE);
        
@@ -814,24 +817,73 @@ EvalObj *builtin_arithmetic_eq(ArgList *args) {
     return new BoolObj(true);
 }
 
+BUILTIN_PROC_DEF(bool_not) {
+    ARGS_EXACTLY_ONE;
+    return new BoolObj(!args->car->is_true());
+}
+
+BUILTIN_PROC_DEF(is_boolean) {
+    ARGS_EXACTLY_ONE;
+    return new BoolObj(args->car->is_bool_obj());
+}
 
-EvalObj *builtin_exact(ArgList *args) {
-    if (args == empty_list ||
-        args->cdr != empty_list)
-        throw TokenError("(in)exact?", RUN_ERR_WRONG_NUM_OF_ARGS);
+BUILTIN_PROC_DEF(is_pair) {
+    ARGS_EXACTLY_ONE;
+    return new BoolObj(args->car->is_cons_obj());
+}
+
+BUILTIN_PROC_DEF(pair_set_car) {
+    ARGS_EXACTLY_TWO;
+    if (args->car == empty_list || !args->car->is_cons_obj())
+        throw TokenError(name, RUN_ERR_WRONG_TYPE);
+    TO_CONS(args->car)->car = TO_CONS(args->cdr)->car;
+    return new UnspecObj();
+}
+
+BUILTIN_PROC_DEF(pair_set_cdr) {
+    ARGS_EXACTLY_TWO;
+    if (args->car == empty_list || !args->car->is_cons_obj())
+        throw TokenError(name, RUN_ERR_WRONG_TYPE);
+    TO_CONS(args->car)->cdr = TO_CONS(args->cdr)->car;
+    return new UnspecObj();
+}
+
+BUILTIN_PROC_DEF(is_null) {
+    ARGS_EXACTLY_ONE;
+    return new BoolObj(args->car == empty_list);
+}
+
+BUILTIN_PROC_DEF(is_list) {
+    ARGS_EXACTLY_ONE;
+    if (!args->car->is_cons_obj())
+        return new BoolObj(false);
+    for (Cons *ptr = TO_CONS(args->car); ptr != empty_list;)
+    {
+        EvalObj *cdr = ptr->cdr;
+        if (!cdr->is_cons_obj())
+            return new BoolObj(false);
+        else
+            ptr = TO_CONS(cdr);
+    }
+    return new BoolObj(true);
+}
+
+BUILTIN_PROC_DEF(num_exact) {
+    ARGS_EXACTLY_ONE;
     if (!args->car->is_num_obj())
         throw TokenError("a number", RUN_ERR_WRONG_TYPE);
     return new BoolObj(static_cast<NumObj*>(args->car)->is_exact()); 
 }
 
-EvalObj *builtin_inexact(ArgList *args) {
-    BoolObj *ret = static_cast<BoolObj*>(builtin_exact(args));
-    ret->val = !ret->val;
-    return ret;
+BUILTIN_PROC_DEF(num_inexact) {
+    ARGS_EXACTLY_ONE;
+    if (!args->car->is_num_obj())
+        throw TokenError("a number", RUN_ERR_WRONG_TYPE);
+    return new BoolObj(!static_cast<NumObj*>(args->car)->is_exact()); 
 }
 
 
-EvalObj *builtin_display(ArgList *args) {
+BUILTIN_PROC_DEF(display) {
     printf("%s\n", args->car->ext_repr().c_str());
     return new UnspecObj();
 }
diff --git a/builtin.h b/builtin.h
index 8ef026e..c1a38bd 100644
--- a/builtin.h
+++ b/builtin.h
@@ -204,20 +204,35 @@ class SpecialOptQuote: public SpecialOptObj {
         string ext_repr();
 };
 
-EvalObj *builtin_plus(ArgList *);
-EvalObj *builtin_minus(ArgList *);
-EvalObj *builtin_multi(ArgList *);
-EvalObj *builtin_div(ArgList *);
-EvalObj *builtin_exact(ArgList *);
-EvalObj *builtin_inexact(ArgList *);
-EvalObj *builtin_lt(ArgList *);
-EvalObj *builtin_gt(ArgList *);
-EvalObj *builtin_arithmetic_eq(ArgList *);
-
-EvalObj *builtin_display(ArgList *);
-EvalObj *builtin_cons(ArgList *);
-EvalObj *builtin_car(ArgList *);
-EvalObj *builtin_cdr(ArgList *);
-EvalObj *builtin_list(ArgList *);
+#define BUILTIN_PROC_DEF(func)\
+    EvalObj *(func)(ArgList *args, const string &name)
+
+BUILTIN_PROC_DEF(num_add);
+BUILTIN_PROC_DEF(num_sub);
+BUILTIN_PROC_DEF(num_multi);
+BUILTIN_PROC_DEF(num_div);
+
+BUILTIN_PROC_DEF(num_lt);
+BUILTIN_PROC_DEF(num_gt);
+BUILTIN_PROC_DEF(num_eq);
+
+BUILTIN_PROC_DEF(num_exact);
+BUILTIN_PROC_DEF(num_inexact);
+
+BUILTIN_PROC_DEF(bool_not);
+BUILTIN_PROC_DEF(is_boolean);
+
+BUILTIN_PROC_DEF(is_pair);
+BUILTIN_PROC_DEF(make_pair);
+BUILTIN_PROC_DEF(pair_car);
+BUILTIN_PROC_DEF(pair_cdr);
+BUILTIN_PROC_DEF(pair_set_car);
+BUILTIN_PROC_DEF(pair_set_cdr);
+BUILTIN_PROC_DEF(is_null);
+BUILTIN_PROC_DEF(is_list);
+
+BUILTIN_PROC_DEF(display);
+BUILTIN_PROC_DEF(make_list);
+
 
 #endif
diff --git a/eval.cpp b/eval.cpp
index add754f..6196e34 100644
--- a/eval.cpp
+++ b/eval.cpp
@@ -9,29 +9,46 @@ const int EVAL_STACK_SIZE = 65536;
 FrameObj *eval_stack[EVAL_STACK_SIZE];
 
 void Evaluator::add_builtin_routines() {
-    
+
 #define ADD_ENTRY(name, rout) \
     envt->add_binding(new SymObj(name), rout)
 
-    ADD_ENTRY("+", new BuiltinProcObj(builtin_plus, "+"));
-    ADD_ENTRY("-", new BuiltinProcObj(builtin_minus, "-"));
-    ADD_ENTRY("*", new BuiltinProcObj(builtin_multi, "*"));
-    ADD_ENTRY("/", new BuiltinProcObj(builtin_div, "/"));
-    ADD_ENTRY(">", new BuiltinProcObj(builtin_gt, ">"));
-    ADD_ENTRY("<", new BuiltinProcObj(builtin_lt, "<"));
-    ADD_ENTRY("=", new BuiltinProcObj(builtin_arithmetic_eq, "="));
-    ADD_ENTRY("display", new BuiltinProcObj(builtin_display, "display"));
-    ADD_ENTRY("cons", new BuiltinProcObj(builtin_cons, "cons"));
-    ADD_ENTRY("car", new BuiltinProcObj(builtin_car, "car"));
-    ADD_ENTRY("cdr", new BuiltinProcObj(builtin_cdr, "cdr"));
-    ADD_ENTRY("list", new BuiltinProcObj(builtin_list, "list"));
-    ADD_ENTRY("exact?", new BuiltinProcObj(builtin_exact, "exact?"));
-    ADD_ENTRY("inexact?", new BuiltinProcObj(builtin_inexact, "inexact?"));
+#define ADD_BUILTIN_PROC(name, rout) \
+    ADD_ENTRY(name, new BuiltinProcObj(rout, name))
+
     ADD_ENTRY("if", new SpecialOptIf());
     ADD_ENTRY("lambda", new SpecialOptLambda());
     ADD_ENTRY("define", new SpecialOptDefine());
     ADD_ENTRY("set!", new SpecialOptSet());
     ADD_ENTRY("quote", new SpecialOptQuote());
+
+    ADD_BUILTIN_PROC("+", num_add);
+    ADD_BUILTIN_PROC("-", num_sub);
+    ADD_BUILTIN_PROC("*", num_multi);
+    ADD_BUILTIN_PROC("/", num_div);
+
+    ADD_BUILTIN_PROC("<", num_lt);
+    ADD_BUILTIN_PROC(">", num_gt);
+    ADD_BUILTIN_PROC("=", num_eq);
+
+    ADD_BUILTIN_PROC("exact?", num_exact);
+    ADD_BUILTIN_PROC("inexact?", num_inexact);
+
+    ADD_BUILTIN_PROC("not", bool_not);
+    ADD_BUILTIN_PROC("boolean?", is_boolean);
+
+    ADD_BUILTIN_PROC("pair?", is_pair);
+    ADD_BUILTIN_PROC("pair", make_pair);
+    ADD_BUILTIN_PROC("car", pair_car);
+    ADD_BUILTIN_PROC("cdr", pair_cdr);
+    ADD_BUILTIN_PROC("set-car!", pair_set_car);
+    ADD_BUILTIN_PROC("set-cdr!", pair_set_cdr);
+    ADD_BUILTIN_PROC("null?", is_null);
+    ADD_BUILTIN_PROC("list?", is_list);
+
+    ADD_BUILTIN_PROC("display", display);
+    ADD_BUILTIN_PROC("list", make_list);
+
 }
 
 Evaluator::Evaluator() {
@@ -71,7 +88,7 @@ EvalObj *Evaluator::run_expr(Cons *prog) {
     Continuation *cont = NULL;
     // envt is this->envt
     push(pc, top_ptr, envt);   
-    
+
     while((*eval_stack)->is_ret_addr())
     {
         for (; pc && pc->skip; pc = pc->next);
@@ -82,7 +99,7 @@ EvalObj *Evaluator::run_expr(Cons *prog) {
             Cons *args = empty_list;
             while (!(*(--top_ptr))->is_ret_addr())
                 args = new Cons(static_cast<EvalObj*>(*top_ptr), args);
-                //< static_cast because the while condition
+            //< static_cast because the while condition
             RetAddr *ret_addr = static_cast<RetAddr*>(*top_ptr);
             if (!ret_addr->addr)
             {
diff --git a/model.cpp b/model.cpp
index 4a3c22a..287c20a 100644
--- a/model.cpp
+++ b/model.cpp
@@ -47,6 +47,10 @@ bool EvalObj::is_num_obj() {
     return otype & CLS_NUM_OBJ;
 }
 
+bool EvalObj::is_bool_obj() {
+    return otype & CLS_BOOL_OBJ;
+}
+
 #ifdef DEBUG
 string EvalObj::_debug_repr() {
     return ext_repr();
@@ -163,7 +167,7 @@ string ProcObj::_debug_repr() { return ext_repr(); }
 
 SpecialOptObj::SpecialOptObj() : OptObj() {}
 
-BoolObj::BoolObj(bool _val) : EvalObj(CLS_SIM_OBJ), val(_val) {}
+BoolObj::BoolObj(bool _val) : EvalObj(CLS_SIM_OBJ | CLS_BOOL_OBJ), val(_val) {}
 
 bool BoolObj::is_true() { return val; }
 
@@ -242,7 +246,7 @@ Cons *BuiltinProcObj::call(ArgList *args, Environment * &envt,
                                 Continuation * &cont, FrameObj ** &top_ptr) {
 
     Cons *ret_addr = static_cast<RetAddr*>(*top_ptr)->addr;
-    *top_ptr++ = handler(TO_CONS(args->cdr));
+    *top_ptr++ = handler(TO_CONS(args->cdr), name);
     return ret_addr->next;          // Move to the next instruction
 }
 
diff --git a/model.h b/model.h
index 0fcf5d3..8a8fc61 100644
--- a/model.h
+++ b/model.h
@@ -24,6 +24,7 @@ const int CLS_CONS_OBJ = 1 << 1;
 const int CLS_SYM_OBJ = 1 << 2;
 const int CLS_OPT_OBJ = 1 << 3;
 const int CLS_NUM_OBJ = 1 << 4;
+const int CLS_BOOL_OBJ = 1 << 5;
 
 
 #define TO_CONS(ptr) \
@@ -96,6 +97,8 @@ class EvalObj : public FrameObj {
         bool is_cons_obj();
         /** Check if the object is a number */
         bool is_num_obj();
+        /** Check if the object is a boolean */
+        bool is_bool_obj();
         virtual void prepare(Cons *pc);
         /** Any EvalObj has its external representation */
         virtual string ext_repr() = 0;  
@@ -247,7 +250,7 @@ class SpecialOptObj: public OptObj {
         SpecialOptObj();
 };
 
-typedef EvalObj* (*BuiltinProc)(ArgList *);
+typedef EvalObj* (*BuiltinProc)(ArgList *, const string &);
 /** @class BuiltinProcObj
  * Wrapping class for builtin procedures (arithmetic operators, etc.)
  */