1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
|
#include "eval.h"
#include "builtin.h"
#include "exc.h"
#include "consts.h"
#include <cstdio>
extern Cons *empty_list;
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?"));
ADD_ENTRY("if", new SpecialOptIf());
ADD_ENTRY("lambda", new SpecialOptLambda());
ADD_ENTRY("define", new SpecialOptDefine());
ADD_ENTRY("set!", new SpecialOptSet());
}
Evaluator::Evaluator() {
envt = new Environment(NULL); // Top-level Environment
add_builtin_routines();
}
void push(Cons * &pc, FrameObj ** &top_ptr, Environment *envt) {
if (pc->car->is_simple_obj()) // Not an opt invocation
{
*top_ptr = envt->get_obj(pc->car); // Objectify the symbol
// static_cast because of is_simple_obj() is true
static_cast<EvalObj*>(*top_ptr)->prepare(pc);
top_ptr++;
pc = pc->next; // Move to the next instruction
}
else // Operational Invocation
{
if (pc->car == empty_list)
throw NormalError(SYN_ERR_EMPTY_COMB);
*top_ptr++ = new RetAddr(pc); // Push the return address
// static_cast because of is_simple_obj() is false
pc = static_cast<Cons*>(pc->car); // Go deeper to enter the call
}
}
void stack_print(FrameObj **top_ptr) {
for (FrameObj **ptr = eval_stack; ptr != top_ptr; ptr++)
printf("%s\n", (*ptr)->_debug_repr().c_str());
puts("");
}
EvalObj *Evaluator::run_expr(Cons *prog) {
FrameObj **top_ptr = eval_stack;
Cons *pc = 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);
if (pc)
push(pc, top_ptr, envt);
else
{
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
RetAddr *ret_addr = static_cast<RetAddr*>(*top_ptr);
if (!ret_addr->addr)
{
Cons *nexp = TO_CONS(cont->proc_body->cdr);
cont->proc_body = nexp;
if (nexp == empty_list)
{
*top_ptr = args->car;
envt = cont->envt;
pc = cont->pc->next;
cont = cont->prev_cont;
}
else pc = nexp;
top_ptr++;
}
else
{
EvalObj *opt = args->car;
if (opt->is_opt_obj())
pc = static_cast<OptObj*>(opt)->
call(args, envt, cont, top_ptr);
else
throw TokenError(opt->ext_repr(), SYN_ERR_CAN_NOT_APPLY);
}
}
}
// static_cast because the previous while condition
return static_cast<EvalObj*>(*(eval_stack));
}
|