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
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
|
#include "primitives.h"
#include "sexp.h"
SExpRef primitive_if(Interp *interp, SExpRef args) {
if (lisp_length(interp, args) != 3) goto error;
SExpRef cond = CAR(args);
SExpRef tb = CADR(args);
SExpRef fb = CADDR(args);
cond = EVAL(cond);
if (ERRORP(cond)) return cond;
if (TRUEP(cond)) return EVAL(tb);
else return EVAL(fb);
return NIL;
error:
return new_error(interp, "if: syntax error.\n");
}
SExpRef primitive_cond(Interp *interp, SExpRef args) {
if (lisp_length(interp, args) < 1) goto error;
SExpRef iter = args;
while (!NILP(iter)) {
SExpRef pair = CAR(iter);
if (!lisp_check_list(interp, pair)) goto error;
if (lisp_length(interp, pair) != 2) goto error;
SExpRef condition = CAR(pair);
SExpRef exp = CADR(pair);
condition = EVAL(condition);
if (ERRORP(condition)) return condition;
if (TRUEP(condition)) return EVAL(exp);
iter = CDR(iter);
}
return NIL;
error:
return new_error(interp, "cond: syntax error.\n");
}
SExpRef primitive_progn(Interp *interp, SExpRef args) {
SExpRef iter = args;
SExpRef ret;
while (!NILP(iter)) {
ret = EVAL(CAR(iter));
if (ERRORP(ret)) return ret;
iter = CDR(iter);
}
return ret;
}
SExpRef primitive_setq(Interp *interp, SExpRef args) {
if (lisp_length(interp, args) != 2) goto error;
SExpRef name = CAR(args);
SExpRef exp = CADR(args);
if (REF(name)->type != kSymbolSExp) goto error;
SExpRef value = EVAL(exp);
if (ERRORP(value)) return value;
return lisp_setq(interp, REF(name)->str, value);
error:
return new_error(interp, "setq: syntax error.\n");
}
static const char *binding_name(Interp *interp, SExpRef binding) {
SExpRef namesym = REF(binding)->binding.name;
return REF(namesym)->str;
}
static bool is_binding_repeat(Interp *interp, SExpRef sym, SExpRef env) {
SExpRef binding = REF(env)->env.bindings;
while (!NILP(binding)) {
if (strcmp(REF(sym)->str, binding_name(interp, binding)) == 0) return true;
binding = REF(binding)->binding.next;
}
return false;
}
SExpRef primitive_let(Interp *interp, SExpRef args) {
if (lisp_length(interp, args) < 1) goto error;
SExpRef bindings = CAR(args);
SExpRef env = new_env(interp);
REF(env)->env.parent = CAR(interp->stack);
SExpRef iter = bindings;
while (!NILP(iter)) {
SExpRef x = CAR(iter);
if (!lisp_check_list(interp, x)) goto error;
if (lisp_length(interp, x) != 2) goto error;
if (REF(CAR(x))->type != kSymbolSExp) goto error;
if (is_binding_repeat(interp, CAR(x), env)) goto error;
SExpRef binding = new_binding(interp, CAR(x), NIL);
REF(binding)->binding.next = REF(env)->env.bindings;
REF(env)->env.bindings = binding;
iter = CDR(iter);
}
interp->stack = CONS(env, interp->stack);
SExpRef ret = NIL;
iter = bindings;
while (!NILP(iter)) {
SExpRef x = CAR(iter);
SExpRef val = EVAL(CADR(x));
if (REF(val)->type == kErrSExp) goto end;
ret = lisp_setq(interp, REF(CAR(x))->str, val);
if (ERRORP(ret)) goto end;
iter = CDR(iter);
}
SExpRef body = CDR(args);
iter = body;
while (!NILP(iter)) {
SExpRef exp = CAR(iter);
ret = EVAL(exp);
if (REF(ret)->type == kErrSExp) goto end;
iter = CDR(iter);
}
end:
interp->stack = CDR(interp->stack);
return ret;
error:
return new_error(interp, "let: syntax error. \n");
}
SExpRef primitive_while(Interp *interp, SExpRef args) {
if (lisp_length(interp, args) < 2) goto error;
SExpRef ret = NIL;
SExpRef pred = CAR(args);
SExpRef body = CDR(args);
while (1) {
SExpRef cond = EVAL(pred);
if (ERRORP(cond)) return cond;
if (!TRUEP(cond)) return ret;
SExpRef iter = body;
while (!NILP(iter)) {
SExpRef x = CAR(iter);
ret = EVAL(x);
if (ERRORP(ret)) return ret;
iter = CDR(iter);
}
}
error:
return new_error(interp, "while: syntax error.\n");
}
// TODO:
// - while
// - lambda
// - defun
// - funcall
// - apply
// - defvar
// - defmacro
// - macroexpand-1
|
