root/lang/c/misc/mlisp/core/m_basic.cpp @ 12358

Revision 12358, 7.7 kB (checked in by mokehehe, 7 years ago)

Add 'begin' syntax.
Add 'gensym' for macro.

Line 
1//=============================================================================
2/// �W�����W���[��
3//=============================================================================
4
5#include "m_basic.h"
6#include "v_vm.h"
7#include "mlisp_dev.h"
8#include "s_util.h"
9#include "inner.h"
10#include <stdlib.h>     // for exit()
11
12
13//=============================================================================
14static SExp builtin_cons() {
15        SExp a = get_arg(0);
16        SExp d = get_arg(1);
17        return cons(a, d);
18}
19
20static SExp builtin_car() {
21        SExp a = get_arg(0);
22        return car(a);
23}
24
25static SExp builtin_cdr() {
26        SExp a = get_arg(0);
27        return cdr(a);
28}
29
30static SExp builtin_consp() {
31        SExp v = get_arg(0);
32        return consp(v) ? t : nil;
33}
34
35static SExp builtin_eq() {
36        SExp a = get_arg(0);
37        SExp d = get_arg(1);
38        return eq(a, d) ? t : nil;
39}
40
41static SExp builtin_rplaca() {
42        SExp a = get_arg(0);
43        SExp d = get_arg(1);
44        rplaca(a, d);
45        return nil;
46}
47
48static SExp builtin_rplacd() {
49        SExp a = get_arg(0);
50        SExp d = get_arg(1);
51        rplacd(a, d);
52        return nil;
53}
54
55static SExp builtin_symbolp() {
56        SExp a = get_arg(0);
57        return symbolp(a) ? t : nil;
58}
59
60static SExp builtin_numberp() {
61        SExp a = get_arg(0);
62        return numberp(a) ? t : nil;
63}
64
65static SExp builtin_list() {
66        sint n = get_arg_num();
67        SExp ls = nil;
68        for (int i=n; --i>=0; ) {
69                SExp a = get_arg(i);
70                ls = cons(a, ls);
71        }
72        return ls;
73}
74
75static SExp builtin_append() {
76        sint n = get_arg_num();
77        if (n == 0) {
78                return nil;
79        } else {
80                SExp ls = get_arg(n - 1);
81                for (int i=n-1; --i>=0; ) {
82                        ls = append2(get_arg(i), ls);
83                }
84                return ls;
85        }
86}
87
88static SExp builtin_plus() {
89        sint n = get_arg_num();
90        sint x = 0;
91        for (int i=0; i<n; ++i) {
92                SExp a = get_arg(i);
93                type_check(a, tInt);
94                x += s2int(a);
95        }
96        return int2s(x);
97}
98
99static SExp builtin_difference() {
100        sint n = get_arg_num();
101        SExp a = get_arg(0);
102        type_check(a, tInt);
103        sint x = s2int(a);
104        if (n == 1) {
105                x = -x;
106        } else {
107                for (int i=1; i<n; ++i) {
108                        SExp a = get_arg(i);
109                        type_check(a, tInt);
110                        x -= s2int(a);
111                }
112        }
113        return int2s(x);
114}
115
116static SExp builtin_times() {
117        sint n = get_arg_num();
118        sint x = 1;
119        for (int i=0; i<n; ++i) {
120                SExp a = get_arg(i);
121                type_check(a, tInt);
122                x *= s2int(a);
123        }
124        return int2s(x);
125}
126
127static SExp builtin_quotient() {
128        sint n = get_arg_num();
129        SExp a = get_arg(0);
130        type_check(a, tInt);
131        sint x = s2int(a);
132        if (n == 1) {
133                x = 1 / x;
134        } else {
135                for (int i=1; i<n; ++i) {
136                        SExp a = get_arg(i);
137                        type_check(a, tInt);
138                        sint d = s2int(a);
139                        if (d == 0) {
140//                              error(ERR_ZERO_DIVIDE);
141                                assert(!"zero divide");
142                        } else {
143                                x /= d;
144                        }
145                }
146        }
147        return int2s(x);
148}
149
150static SExp num_predicate(int n, bool (*p)(sint, sint)) {
151        SExp a = get_arg(0);
152        type_check(a, tInt);
153        sint x = s2int(a);
154
155        for (int i=1; i<n; ++i) {
156                SExp b = get_arg(i);
157                type_check(b, tInt);
158                sint y = s2int(b);
159                if (!p(x, y))   return nil;
160                x = y;
161        }
162        return t;
163}
164
165static bool numeq(sint a, sint b)       { return a == b; }
166static SExp builtin_numeq() {
167        sint n = get_arg_num();
168        return num_predicate(n, numeq);
169}
170
171static bool numlt(sint a, sint b)       { return a < b; }
172static SExp builtin_lt() {
173        sint n = get_arg_num();
174        return num_predicate(n, numlt);
175}
176
177static bool numgt(sint a, sint b)       { return a > b; }
178static SExp builtin_gt() {
179        sint n = get_arg_num();
180        return num_predicate(n, numgt);
181}
182
183static bool numle(sint a, sint b)       { return a <= b; }
184static SExp builtin_le() {
185        sint n = get_arg_num();
186        return num_predicate(n, numle);
187}
188
189static bool numge(sint a, sint b)       { return a >= b; }
190static SExp builtin_ge() {
191        sint n = get_arg_num();
192        return num_predicate(n, numge);
193}
194
195
196static SExp builtin_read() {
197        return read_from_file(stdin);
198}
199
200static SExp builtin_print() {
201        SExp a = get_arg(0);
202        print(a);
203        return nil;
204}
205
206static SExp builtin_eval() {
207        SExp code = get_arg(0);
208
209        return evaluate(code);
210}
211
212static SExp builtin_macroexpand_1() {
213        SExp a = get_arg(0);
214        return macroexpand_1(a);
215}
216
217static SExp builtin_load() {
218        SExp a = get_arg(0);
219        const char* fn = s2str(a);
220        if (fn != NULL) {
221                SExp r = load_eval(fn);
222                return r;
223        }
224        return nil;
225}
226
227static SExp builtin_compile() {
228        SExp code = get_arg(0);
229        return compile_ontop(code);
230}
231
232static SExp builtin_exit() {
233        sint n = get_arg_num();
234        int ret = 0;
235        if (n >= 1) {
236                SExp s = get_arg(0);
237                if (type_of(s) == tInt) {
238                        ret = s2int(s);
239                } else {
240                        ret = -1;
241                }
242        }
243        exit(ret);
244        return nil;
245}
246
247static SExp builtin_gensym() {
248        static int cnt;
249        char buf[16];
250        sprintf(buf, "G:%d", ++cnt);
251        return intern(buf);
252}
253
254
255
256//=============================================================================
257
258static SExp transform_quasiquote_loop(SExp x, void*) {
259        if (!consp(x))
260                return list(2, intern("quote"), list(1, x));
261        else if (eq(car(x), intern("unquote")))
262                return list(2, intern("list"), cadr(x));
263        else if (eq(car(x), intern("unquote-splicing")))
264                return cadr(x);
265        else {
266                SExp sub = mapcar(transform_quasiquote_loop, x, NULL);
267                return list(2, intern("list"), cons(intern("append"), sub));
268        }
269}
270
271static SExp builtin_quasiquote(SExp args) {
272        SExp res = transform_quasiquote_loop(car(args), NULL);
273        SExp h = car(res);
274        if (eq(h, intern("list")))
275                return cadr(res);
276        else if (eq(h, intern("quote")))
277                return list(2, intern("quote"), list(1, car(cadr(res))));
278        else {
279                error(ERR_UNEXPECTED, 0, NULL);
280                return nil;
281        }
282}
283
284
285//=============================================================================
286
287static void define_basic_const() {
288        struct {
289                const char* name;
290        } static const tbl[] = {
291                "t",
292                "nil",
293        };
294        for (int i=0; i<sizeof(tbl)/sizeof(*tbl); ++i) {
295                SExp sym = intern(tbl[i].name);
296                define_global(sym, sym);
297        }
298}
299
300
301static void define_basic_proc() {
302        struct {
303                const char* name;
304                SCFunc func;
305                int minarg;
306                int maxarg;
307        } static const tbl[] = {
308                {       "cons",         builtin_cons,           2,      2,      },
309                {       "car",          builtin_car,            1,      1,      },
310                {       "cdr",          builtin_cdr,            1,      1,      },
311                {       "pair?",        builtin_consp,          1,      1,      },
312                {       "eq?",          builtin_eq,                     2,      2,      },
313                {       "set-car!",     builtin_rplaca,         2,      2,      },
314                {       "set-cdr!",     builtin_rplacd,         2,      2,      },
315
316                {       "symbol?",      builtin_symbolp,        1,      1,      },
317                {       "number?",      builtin_numberp,        1,      1,      },
318
319                {       "list",         builtin_list,           0,      -1,     },
320                {       "append",       builtin_append,         0,      -1,     },
321
322                {       "+",            builtin_plus,           0,      -1,     },
323                {       "-",            builtin_difference,     1, -1,  },
324                {       "*",            builtin_times,          0,      -1,     },
325                {       "/",            builtin_quotient,       1, -1,  },
326                {       "=",            builtin_numeq,          1, -1,  },
327                {       "<",            builtin_lt,                     1, -1,  },
328                {       ">",            builtin_gt,                     1, -1,  },
329                {       "<=",           builtin_le,                     1, -1,  },
330                {       ">=",           builtin_ge,                     1, -1,  },
331
332                {       "read",         builtin_read,           0,      0,      },
333                {       "print",        builtin_print,          1,      1,      },
334                {       "eval",         builtin_eval,           1,      1,      },
335                {       "macroexpand-1",        builtin_macroexpand_1,          1,      1,      },
336
337                {       "load",         builtin_load,           1,      1,      },
338                {       "compile",      builtin_compile,        1,      1,      },
339                {       "exit",         builtin_exit,           0,      1,      },
340
341                {       "gensym",       builtin_gensym,         0,      0,      },
342        };
343        for (int i=0; i<sizeof(tbl)/sizeof(*tbl); ++i) {
344                SExp sym = intern(tbl[i].name);
345                SExp fn = gen_cfunc(tbl[i].func, tbl[i].minarg, tbl[i].maxarg);
346                define_global(sym, fn);
347        }
348}
349
350
351static void define_basic_macro() {
352        struct {
353                const char* name;
354                SCFuncM func;
355                int minarg;
356                int maxarg;
357        } static const tbl[] = {
358                {       "quasiquote",   builtin_quasiquote,             1,      1,      },
359        };
360        for (int i=0; i<sizeof(tbl)/sizeof(*tbl); ++i) {
361                SExp sym = intern(tbl[i].name);
362                SExp fn = gen_cmacro(tbl[i].func, tbl[i].minarg, tbl[i].maxarg);
363                define_global(sym, fn);
364        }
365}
366
367
368//=============================================================================
369
370void define_basic_lib(void) {
371        define_basic_const();
372        define_basic_proc();
373        define_basic_macro();
374}
Note: See TracBrowser for help on using the browser.