aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorTeddy <ted.sybil@gmail.com>2013-08-06 19:11:22 +0800
committerTeddy <ted.sybil@gmail.com>2013-08-06 19:11:22 +0800
commit3406f0a979e2465a993b20c2eb1033729c6a787c (patch)
treed37e6148a211732fc3d59ca428d2bef7309736b8
parent033b938b22c7947992195e380fb2f7d1ca200f05 (diff)
added and restructured built-in procedures
-rw-r--r--TODO.rst3
-rw-r--r--builtin.cpp136
-rw-r--r--builtin.h45
-rw-r--r--eval.cpp51
-rw-r--r--model.cpp8
-rw-r--r--model.h5
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.)
*/