From 645549b8a42844fc5a8042a4808c8ebf5050d7da Mon Sep 17 00:00:00 2001
From: Teddy <ted.sybil@gmail.com>
Date: Sun, 4 Aug 2013 23:35:59 +0800
Subject: added support for `cons`, `car`, `cdr`
---
builtin.cpp | 103 +++++++++++++++++++++++++++++++++++++++---------------------
builtin.h | 3 ++
consts.cpp | 3 +-
consts.h | 3 +-
eval.cpp | 5 ++-
main.cpp | 2 +-
model.cpp | 18 +++++++----
model.h | 9 ++++--
parser.cpp | 6 +++-
9 files changed, 103 insertions(+), 49 deletions(-)
diff --git a/builtin.cpp b/builtin.cpp
index 374f3f2..f1b518f 100644
--- a/builtin.cpp
+++ b/builtin.cpp
@@ -47,50 +47,50 @@ SpecialOptIf::SpecialOptIf() : SpecialOptObj() {}
void SpecialOptIf::prepare(Cons *pc) {
state = 0; // Prepared
- pc = pc->cdr;
+ pc = TO_CONS(pc->cdr);
if (pc == empty_list)
throw TokenError("if", SYN_ERR_MISS_OR_EXTRA_EXP);
pc->skip = false;
- pc = pc->cdr;
+ pc = TO_CONS(pc->cdr);
if (pc == empty_list)
throw TokenError("if", SYN_ERR_MISS_OR_EXTRA_EXP);
pc->skip = true;
if (pc->cdr != empty_list)
- pc->cdr->skip = true;
+ TO_CONS(pc->cdr)->skip = true;
}
void SpecialOptIf::pre_call(ArgList *args, Cons *pc,
Environment *envt) {
// static_cast because it's a call invocation
- pc = static_cast<Cons*>(pc->car)->cdr;
+ pc = TO_CONS(TO_CONS(pc->car)->cdr);
// Condition evaluated and the decision is made
state = 1;
- if (args->cdr->car->is_true())
+ if (TO_CONS(args->cdr)->car->is_true())
{
pc->skip = true;
- pc = pc->cdr;
+ pc = TO_CONS(pc->cdr);
pc->skip = false;
if (pc->cdr != empty_list)
- pc->cdr->skip = true; // Eval the former
+ TO_CONS(pc->cdr)->skip = true; // Eval the former
}
else
{
pc->skip = true;
- pc = pc->cdr;
- pc->cdr->skip = true;
+ pc = TO_CONS(pc->cdr);
+ TO_CONS(pc->cdr)->skip = true;
if (pc->cdr != empty_list)
- pc->cdr->skip = false; //Eval the latter
+ TO_CONS(pc->cdr)->skip = false; //Eval the latter
}
}
EvalObj *SpecialOptIf::post_call(ArgList *args, Cons *pc,
Environment *envt) {
// Value already evaluated, so just return it
- return args->cdr->car;
+ return TO_CONS(args->cdr)->car;
}
Cons *SpecialOptIf::call(ArgList *args, Environment * &envt,
@@ -119,7 +119,8 @@ string SpecialOptIf::_debug_repr() { return ext_repr(); }
SpecialOptLambda::SpecialOptLambda() : SpecialOptObj() {}
#define FILL_MARKS(pc, flag) \
- for (Cons *ptr = pc->cdr; ptr != empty_list; ptr = ptr->cdr) \
+ for (Cons *ptr = TO_CONS(pc->cdr); \
+ ptr != empty_list; ptr = TO_CONS(ptr->cdr)) \
ptr->skip = flag
void SpecialOptLambda::prepare(Cons *pc) {
@@ -136,16 +137,16 @@ Cons *SpecialOptLambda::call(ArgList *args, Environment * &envt,
if (pc->cdr == empty_list)
throw TokenError("lambda", SYN_ERR_EMPTY_PARA_LIST);
- if (pc->cdr->cdr == empty_list)
+ if (TO_CONS(pc->cdr)->cdr == empty_list)
throw TokenError("lambda", SYN_ERR_MISS_OR_EXTRA_EXP);
- SymbolList *para_list = static_cast<SymbolList*>(pc->cdr->car);
+ SymbolList *para_list = static_cast<SymbolList*>(TO_CONS(pc->cdr)->car);
// Clear the flag to avoid side-effects (e.g. proc calling)
FILL_MARKS(pc, false);
// store a list of expressions inside <body>
- ASTList *body = pc->cdr->cdr; // Truncate the expression list
- for (Cons *ptr = body; ptr != empty_list; ptr = ptr->cdr)
+ ASTList *body = TO_CONS(TO_CONS(pc->cdr)->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
*top_ptr++ = new ProcObj(body, envt, para_list);
@@ -164,13 +165,13 @@ void SpecialOptDefine::prepare(Cons *pc) {
if (pc->cdr == empty_list)
throw TokenError("define", SYN_ERR_MISS_OR_EXTRA_EXP);
- if (pc->cdr->car->is_simple_obj()) // Simple value assignment
+ if (TO_CONS(pc->cdr)->car->is_simple_obj()) // Simple value assignment
{
- pc = pc->cdr;
+ pc = TO_CONS(pc->cdr);
if (pc->cdr == empty_list)
throw TokenError("define", SYN_ERR_MISS_OR_EXTRA_EXP);
pc->skip = true; // Skip the identifier
- pc->cdr->skip = false;
+ TO_CONS(pc->cdr)->skip = false;
} // Procedure definition
else FILL_MARKS(pc, true); // Skip all parts
}
@@ -182,19 +183,19 @@ Cons *SpecialOptDefine::call(ArgList *args, Environment * &envt,
EvalObj *obj;
SymObj *id;
// TODO: check identifier
- EvalObj *first = pc->cdr->car;
+ EvalObj *first = TO_CONS(pc->cdr)->car;
if (first->is_simple_obj())
{
if (!first->is_sym_obj())
throw TokenError(first->ext_repr(), SYN_ERR_NOT_AN_ID);
id = static_cast<SymObj*>(first);
- obj = args->cdr->car;
+ obj = TO_CONS(args->cdr)->car;
}
else
{
// static_cast because of is_simple_obj() is false
- Cons *plst = static_cast<Cons*>(pc->cdr->car);
+ Cons *plst = static_cast<Cons*>(TO_CONS(pc->cdr)->car);
if (plst == empty_list)
throw TokenError("if", SYN_ERR_EMPTY_PARA_LIST);
@@ -202,16 +203,16 @@ Cons *SpecialOptDefine::call(ArgList *args, Environment * &envt,
throw TokenError(first->ext_repr(), SYN_ERR_NOT_AN_ID);
id = static_cast<SymObj*>(plst->car);
- ArgList *para_list = plst->cdr;
+ ArgList *para_list = TO_CONS(plst->cdr);
// Clear the flag to avoid side-effects (e.g. proc calling)
FILL_MARKS(pc, false);
- ASTList *body = pc->cdr->cdr; // Truncate the expression list
+ 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);
- for (Cons *ptr = body; ptr != empty_list; ptr = ptr->cdr)
+ 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);
@@ -228,13 +229,13 @@ string SpecialOptDefine::_debug_repr() { return ext_repr(); }
#endif
void SpecialOptSet::prepare(Cons *pc) {
- pc = pc->cdr;
+ pc = TO_CONS(pc->cdr);
if (pc == empty_list)
throw TokenError("set!", SYN_ERR_MISS_OR_EXTRA_EXP);
pc->skip = true; // Skip the identifier
- pc = pc->cdr;
+ pc = TO_CONS(pc->cdr);
if (pc == empty_list)
throw TokenError("set!", SYN_ERR_MISS_OR_EXTRA_EXP);
@@ -245,14 +246,14 @@ Cons *SpecialOptSet::call(ArgList *args, Environment * &envt,
Continuation * &cont, FrameObj ** &top_ptr) {
Cons *ret_addr = static_cast<RetAddr*>(*top_ptr)->addr;
Cons *pc = static_cast<Cons*>(ret_addr->car);
- EvalObj *first = pc->cdr->car;
+ EvalObj *first = TO_CONS(pc->cdr)->car;
if (!first->is_sym_obj())
throw TokenError(first->ext_repr(), SYN_ERR_NOT_AN_ID);
SymObj *id = static_cast<SymObj*>(first);
- bool flag = envt->add_binding(id, args->cdr->car, false);
+ bool flag = envt->add_binding(id, TO_CONS(args->cdr)->car, false);
if (!flag) throw TokenError(id->ext_repr(), RUN_ERR_UNBOUND_VAR);
*top_ptr++ = new UnspecObj();
return ret_addr->next;
@@ -266,10 +267,39 @@ string SpecialOptSet::ext_repr() { return string("#<Builtin Macro: set!>"); }
string SpecialOptSet::_debug_repr() { return ext_repr(); }
#endif
+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);
+
+ 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);
+ if (!args->car->is_cons_obj())
+ throw TokenError("pair", 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);
+ if (!args->car->is_cons_obj())
+ throw TokenError("pair", RUN_ERR_WRONG_TYPE);
+
+ return TO_CONS(args->car)->cdr;
+}
+
EvalObj *builtin_plus(ArgList *args) {
// TODO: type conversion and proper arithmetic
int res = 0;
- for (Cons *ptr = args; ptr != empty_list; ptr = ptr->cdr)
+ for (Cons *ptr = args; ptr != empty_list; ptr = TO_CONS(ptr->cdr))
res += dynamic_cast<IntObj*>(ptr->car)->val;
return new IntObj(res);
}
@@ -277,7 +307,8 @@ EvalObj *builtin_plus(ArgList *args) {
EvalObj *builtin_minus(ArgList *args) {
// TODO: type conversion and proper arithmetic
int res = dynamic_cast<IntObj*>(args->car)->val;
- for (Cons *ptr = args->cdr; ptr != empty_list; ptr = ptr->cdr)
+ for (Cons *ptr = TO_CONS(args->cdr);
+ ptr != empty_list; ptr = TO_CONS(ptr->cdr))
res -= dynamic_cast<IntObj*>(ptr->car)->val;
return new IntObj(res);
}
@@ -285,7 +316,7 @@ EvalObj *builtin_minus(ArgList *args) {
EvalObj *builtin_times(ArgList *args) {
// TODO: type conversion and proper arithmetic
int res = 1;
- for (Cons *ptr = args; ptr != empty_list; ptr = ptr->cdr)
+ for (Cons *ptr = args; ptr != empty_list; ptr = TO_CONS(ptr->cdr))
res *= dynamic_cast<IntObj*>(ptr->car)->val;
return new IntObj(res);
}
@@ -293,24 +324,24 @@ EvalObj *builtin_times(ArgList *args) {
EvalObj *builtin_div(ArgList *args) {
// TODO: type conversion and proper arithmetic
int res = dynamic_cast<IntObj*>(args->car)->val;
- for (Cons *ptr = args->cdr; ptr != empty_list; ptr = ptr->cdr)
+ for (Cons *ptr = TO_CONS(args->cdr); ptr != empty_list; ptr = TO_CONS(ptr->cdr))
res /= dynamic_cast<IntObj*>(ptr->car)->val;
return new IntObj(res);
}
EvalObj *builtin_lt(ArgList *args) {
return new BoolObj(dynamic_cast<IntObj*>(args->car)->val <
- dynamic_cast<IntObj*>(args->cdr->car)->val);
+ dynamic_cast<IntObj*>(TO_CONS(args->cdr)->car)->val);
}
EvalObj *builtin_gt(ArgList *args) {
return new BoolObj(dynamic_cast<IntObj*>(args->car)->val >
- dynamic_cast<IntObj*>(args->cdr->car)->val);
+ dynamic_cast<IntObj*>(TO_CONS(args->cdr)->car)->val);
}
EvalObj *builtin_arithmetic_eq(ArgList *args) {
return new BoolObj(dynamic_cast<IntObj*>(args->car)->val ==
- dynamic_cast<IntObj*>(args->cdr->car)->val);
+ dynamic_cast<IntObj*>(TO_CONS(args->cdr)->car)->val);
}
EvalObj *builtin_display(ArgList *args) {
diff --git a/builtin.h b/builtin.h
index 92b2fe0..8d2a6a0 100644
--- a/builtin.h
+++ b/builtin.h
@@ -133,5 +133,8 @@ 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 *);
#endif
diff --git a/consts.cpp b/consts.cpp
index c7058b0..ec3ed01 100644
--- a/consts.cpp
+++ b/consts.cpp
@@ -8,5 +8,6 @@ const char *SYN_ERR_MSG[] = {
"Empty parameter list in (%s)",
"Wrong number of arguments to procedure (%s)",
"Illegal empty combination ()",
- "Unexpected \")\""
+ "Unexpected \")\"",
+ "Wrong type (expecting %s)"
};
diff --git a/consts.h b/consts.h
index 5e3f43d..5991317 100644
--- a/consts.h
+++ b/consts.h
@@ -9,7 +9,8 @@ enum ErrCode {
SYN_ERR_EMPTY_PARA_LIST,
RUN_ERR_WRONG_NUM_OF_ARGS,
SYN_ERR_EMPTY_COMB,
- READ_ERR_UNEXPECTED_RIGHT_BRACKET
+ READ_ERR_UNEXPECTED_RIGHT_BRACKET,
+ RUN_ERR_WRONG_TYPE
};
extern const char *SYN_ERR_MSG[];
diff --git a/eval.cpp b/eval.cpp
index efd1114..de06209 100644
--- a/eval.cpp
+++ b/eval.cpp
@@ -21,6 +21,9 @@ void Evaluator::add_builtin_routines() {
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("if", new SpecialOptIf());
ADD_ENTRY("lambda", new SpecialOptLambda());
ADD_ENTRY("define", new SpecialOptDefine());
@@ -79,7 +82,7 @@ EvalObj *Evaluator::run_expr(Cons *prog) {
RetAddr *ret_addr = static_cast<RetAddr*>(*top_ptr);
if (!ret_addr->addr)
{
- Cons *nexp = cont->proc_body->cdr;
+ Cons *nexp = TO_CONS(cont->proc_body->cdr);
cont->proc_body = nexp;
if (nexp == empty_list)
{
diff --git a/main.cpp b/main.cpp
index e8fe418..230d077 100644
--- a/main.cpp
+++ b/main.cpp
@@ -11,7 +11,7 @@ void tree_print(Cons *ptr) {
if (!ptr || ptr == empty_list) return;
ptr->_debug_print();
tree_print(dynamic_cast<Cons*>(ptr->car));
- tree_print(ptr->cdr);
+ tree_print(TO_CONS(ptr->cdr));
}
#endif
diff --git a/model.cpp b/model.cpp
index 2132d1f..fab17d6 100644
--- a/model.cpp
+++ b/model.cpp
@@ -35,6 +35,10 @@ bool EvalObj::is_opt_obj() {
return otype & CLS_OPT_OBJ;
}
+bool EvalObj::is_cons_obj() {
+ return otype & CLS_CONS_OBJ;
+}
+
#ifdef DEBUG
void EvalObj::_debug_print() {
printf("mem: 0x%llX\n%s\n\n", (unsigned long long)this,
@@ -46,11 +50,13 @@ bool EvalObj::is_true() {
return true;
}
-Cons::Cons(EvalObj *_car, Cons *_cdr) :
+Cons::Cons(EvalObj *_car, EvalObj *_cdr) :
EvalObj(CLS_CONS_OBJ), car(_car), cdr(_cdr), skip(false),
- next(cdr == empty_list ? NULL : cdr) {}
+ next(NULL) {}
-string Cons::ext_repr() { return string("#<Cons>"); }
+string Cons::ext_repr() {
+ return "(" + car->ext_repr() + " . " + cdr->ext_repr() + ")";
+}
#ifdef DEBUG
string Cons::_debug_repr() { return ext_repr(); }
@@ -106,9 +112,9 @@ 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 = args->cdr, ppar = para_list;
+ for (ptr = TO_CONS(args->cdr), ppar = para_list;
ptr != empty_list && ppar != empty_list;
- ptr = ptr->cdr, ppar = ppar->cdr)
+ ptr = TO_CONS(ptr->cdr), ppar = TO_CONS(ppar->cdr))
_envt->add_binding(static_cast<SymObj*>(ppar->car), ptr->car);
if (ptr != empty_list || ppar != empty_list)
@@ -137,7 +143,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(args->cdr);
+ *top_ptr++ = handler(TO_CONS(args->cdr));
return ret_addr->next; // Move to the next instruction
}
diff --git a/model.h b/model.h
index ebae3d6..a98a475 100644
--- a/model.h
+++ b/model.h
@@ -19,6 +19,9 @@ static const int CLS_CONS_OBJ = 1 << 1;
static const int CLS_SYM_OBJ = 1 << 2;
static const int CLS_OPT_OBJ = 1 << 3;
+#define TO_CONS(ptr) \
+ (static_cast<Cons*>(ptr))
+
/** @class FrameObj
* Objects that can be held in the evaluation stack
*/
@@ -76,6 +79,8 @@ class EvalObj : public FrameObj {
bool is_sym_obj();
/** Check if the object is an operator */
bool is_opt_obj();
+ /** Check if the object is a Cons */
+ bool is_cons_obj();
virtual void prepare(Cons *pc);
/** Any EvalObj has its external representation */
virtual string ext_repr() = 0;
@@ -94,11 +99,11 @@ class EvalObj : public FrameObj {
class Cons : public EvalObj {
public:
EvalObj *car; /**< car (as in Scheme) */
- Cons *cdr; /**< cdr (as in Scheme) */
+ EvalObj *cdr; /**< cdr (as in Scheme) */
bool skip; /**< Wether to skip the current branch */
Cons* next; /**< The next branch in effect */
- Cons(EvalObj *car, Cons *cdr); /**< Create a Cons (car . cdr) */
+ Cons(EvalObj *car, EvalObj *cdr); /**< Create a Cons (car . cdr) */
#ifdef DEBUG
void _debug_print();
string _debug_repr();
diff --git a/parser.cpp b/parser.cpp
index 8de812f..f4de5a2 100644
--- a/parser.cpp
+++ b/parser.cpp
@@ -103,7 +103,11 @@ Cons *ASTGenerator::absorb(Tokenizor *tk) {
{
Cons *lst = empty_list;
while (top_ptr >= parse_stack && *(--top_ptr))
- lst = new Cons(*top_ptr, lst); // Collect the list
+ {
+ Cons *_lst = new Cons(*top_ptr, lst); // Collect the list
+ _lst->next = lst == empty_list ? NULL : lst;
+ lst = _lst;
+ }
if (top_ptr < parse_stack)
throw NormalError(READ_ERR_UNEXPECTED_RIGHT_BRACKET);
*top_ptr++ = lst;
--
cgit v1.2.3-70-g09d2