Changeset 11144 for lang/c

Timestamp:

05/05/08 07:28:23 (7 months ago)

Author:

mokehehe

Message:

マクロ追加
関数をScheme寄りに

Location:

lang/c/misc/mlisp

Files:

• compiler/compiler.cpp (modified) (4 diffs)
• compiler/compiler.h (modified) (1 diff)
• sexp/inner.h (modified) (1 diff)
• sexp/sexp.cpp (modified) (1 diff)
• sexp/sprint.cpp (modified) (2 diffs)
• sexp/sutil.cpp (modified) (1 diff)
• sexp/sutil.h (modified) (1 diff)
• test/main.cpp (modified) (10 diffs)
• vm/op.h (modified) (1 diff)
• vm/vm.cpp (modified) (2 diffs)

lang/c/misc/mlisp/compiler/compiler.cpp

@@ -8 +8 @@
 #include "op.h"
 #include "inner.h"
+
+extern SExp evaluate(SExp code);
+
+
+static SExp s_macros;
 
 
@@ -75 +80 @@
                 }
         } else {
-                return compile_pair_loop(cdr(args), compile(car(args), e, list(2, intern("argument"), c)), e, next);
+                return compile_pair_loop(cdr(args), compile(car(args), e, list(2, ARGUMENT, c)), e, next);
         }
 }
@@ -127 +132 @@
 }
 
+
+
+/// �}�N����
+static void compile_defmacro(SExp name, SExp vars, SExp body) {
+        SExp mac = cons(name, cons(intern("lambda"), cons(vars, body)));
+        s_macros = cons(mac, s_macros);
+}
+
+SExp is_macro(SExp name) {
+        return assoc(name, s_macros);
+}
+
+/// �}�N���Ăяo���R�[�h�쐬
+static SExp quotize(SExp s) {
+        return list(2, intern("quote"), s);
+}
+static SExp gen_macro_call(SExp m, SExp x) {
+        return cons(cdr(m), mapcar(quotize, cdr(x)));
+}
+
+/// �}�N����i�W�J
+SExp macroexpand_1(SExp m, SExp x) {
+        SExp code = gen_macro_call(m, x);
+        return evaluate(code);
+}
+
+/// �}�N���K�p
+static SExp compile_macro_apply(SExp m, SExp x, SExp e, SExp next) {
+        SExp trans = macroexpand_1(m, x);
+        return compile(trans, e, next);
+}
+
+
+
+/// �o�b�N�N�H�[�g�̕ϊ�
+
+static SExp transform_quasiquote_loop(SExp x) {
+        if (!consp(x))                                                                          return list(2, intern("quote"), list(1, x));
+        else if (eq(car(x), intern("unquote")))                         return list(2, intern("list"), cadr(x));
+        else if (eq(car(x), intern("unquote-splicing")))        return cadr(x);
+        else                                                                                            return list(2, intern("list"), cons(intern("append"), mapcar(transform_quasiquote_loop, x)));
+}
+
+static SExp transform_quasiquote(SExp x) {
+        SExp res = transform_quasiquote_loop(x);
+        SExp hd = car(res);
+        if              (eq(hd, intern("list")))        return cadr(res);
+        else if (eq(hd, intern("quote")))       return list(2, intern("quote"), car(cadr(res)));
+        else    { assert(!"unexpected"); return nil; }
+}
+
+/// ����void init_compile(void) {
+        s_macros = nil;
+}
+
 /// �P�‚̎�����p�C��
 SExp compile(SExp x, SExp e, SExp next) {
@@ -136 +196 @@
                 return list(3, REFER, access, next);
         } else if (consp(x)) {
-                SExp op = car(x);
-                if (eq(op, intern("quote"))) {
-                        SExp obj = cadr(x);
-                        return list(3, CONSTANT, obj, next);
-                } else if (eq(op, intern("lambda"))) {
-                        SExp vars = cadr(x);
-                        SExp body = cddr(x);
-                        return list(3, CLOSE, compile_block(body, extend(e, vars), cons(RETURN, nil)), next);
-                } else if (eq(op, intern("if"))) {
-                        SExp test = cadr(x);
-                        SExp then = caddr(x);
-                        SExp thenc = compile(then, e, next);
-                        SExp els, elsec;
-                        SExp ddd = cdddr(x);
-                        if (!nilp(ddd))         els = cadddr(x);
-                        else                            els = nil;
-                        elsec = compile(els, e, next);
-                        return compile(test, e, list(3, TEST, thenc, elsec));
-                } else if (eq(op, intern("set!"))) {
-                        SExp var = cadr(x);
-                        SExp xx = caddr(x);
-                        return compile_set(ASSIGN, var, xx, e, next, false);
-                } else if (eq(op, intern("define"))) {
-                        SExp var = cadr(x);
-                        SExp body = cddr(x);
-                        return compile_define(var, body, e, next);
-                } else if (eq(op, intern("call/cc"))) {
-                        SExp xx = cadr(x);
-                        SExp c = list(2, CONTI, list(2, ARGUMENT, compile(xx, e, cons(APPLY, nil))));
-                        if (tailp(next))
-                                return c;
-                        else
-                                return list(3, FRAME, c, next);
+                SExp m = is_macro(car(x));
+                if (!nilp(m)) {
+                        return compile_macro_apply(m, x, e, next);
                 } else {
-                        return compile_pair_loop(cdr(x), compile(car(x), e, cons(APPLY, nil)), e, next);
+                        SExp op = car(x);
+                        if (eq(op, intern("quote"))) {
+                                SExp obj = cadr(x);
+                                return list(3, CONSTANT, obj, next);
+                        } else if (eq(op, intern("quasiquote"))) {
+                                SExp obj = cadr(x);
+                                SExp trans = transform_quasiquote(obj);
+                                return compile(trans, e, next);
+                        } else if (eq(op, intern("unquote"))) {
+                                compile_error(ERR_UNEXPECTED);
+                                return nil;
+                        } else if (eq(op, intern("unquote-splicing"))) {
+                                compile_error(ERR_UNEXPECTED);
+                                return nil;
+                        } else if (eq(op, intern("lambda"))) {
+                                SExp vars = cadr(x);
+                                SExp body = cddr(x);
+                                return list(3, CLOSE, compile_block(body, extend(e, vars), cons(RETURN, nil)), next);
+                        } else if (eq(op, intern("if"))) {
+                                SExp test = cadr(x);
+                                SExp then = caddr(x);
+                                SExp thenc = compile(then, e, next);
+                                SExp els, elsec;
+                                SExp ddd = cdddr(x);
+                                if (!nilp(ddd))         els = cadddr(x);
+                                else                            els = nil;
+                                elsec = compile(els, e, next);
+                                return compile(test, e, list(3, TEST, thenc, elsec));
+                        } else if (eq(op, intern("set!"))) {
+                                SExp var = cadr(x);
+                                SExp xx = caddr(x);
+                                return compile_set(ASSIGN, var, xx, e, next, false);
+                        } else if (eq(op, intern("define"))) {
+                                SExp var = cadr(x);
+                                SExp body = cddr(x);
+                                return compile_define(var, body, e, next);
+                        } else if (eq(op, intern("call/cc"))) {
+                                SExp xx = cadr(x);
+                                SExp c = list(2, CONTI, list(2, ARGUMENT, compile(xx, e, cons(APPLY, nil))));
+                                if (tailp(next))
+                                        return c;
+                                else
+                                        return list(3, FRAME, c, next);
+                        } else if (eq(op, intern("defmacro"))) {
+                                SExp name = cadr(x);
+                                SExp vars = caddr(x);
+                                SExp body = cdddr(x);
+                                compile_defmacro(name, vars, body);
+                                return next;
+                        } else {
+                                return compile_pair_loop(cdr(x), compile(car(x), e, cons(APPLY, nil)), e, next);
+                        }
                 }
         } else {

lang/c/misc/mlisp/compiler/compiler.h

@@ -11 +11 @@
 #endif
 
+void init_compile(void);
 SExp compile(SExp x, SExp e, SExp next);
 SExp compile_block(SExp sexps, SExp e, SExp next);
+
+SExp is_macro(SExp name);
+SExp macroexpand_1(SExp m, SExp x);
 
 #ifdef __cplusplus

lang/c/misc/mlisp/sexp/inner.h

@@ -25 +25 @@
         ERR_TYPE_REQUIRED,
         ERR_UNDEFINED_SYMBOL,
+        ERR_UNEXPECTED,
 };
 

lang/c/misc/mlisp/sexp/sexp.cpp

@@ -22 +22 @@
         "type required: %s",
         "undefined symbol",
+        "unexpected",
 };
 

lang/c/misc/mlisp/sexp/sprint.cpp

@@ -1 +1 @@
 #include "inner.h"
+#include "sutil.h"
 
 static void print_rec(SExp s);
@@ -30 +31 @@
                 {
                         SExp a = car(s);
-                        if (eq(a, intern("quote"))) {
+                        if (eq(a, intern("quote")) && singlep(cdr(s))) {
                                 printf("'");
                                 print_rec(car(cdr(s)));

lang/c/misc/mlisp/sexp/sutil.cpp

@@ -62 +62 @@
 }
 
+SExp mapcar(SExp (*fn)(SExp), SExp ls) {
+        SExp acc = nil;
+        for (; !nilp(ls); ls = cdr(ls)) {
+                acc = cons(fn(car(ls)), acc);
+        }
+        return nreverse(acc);
+}
+
+SExp assoc(SExp sym, SExp alist) {
+        for (; consp(alist); alist = cdr(alist)) {
+                SExp elem = car(alist);
+                if (eq(sym, car(elem))) return elem;
+        }
+        return nil;
+}
+
+
 
 int singlep(SExp ls) {

lang/c/misc/mlisp/sexp/sutil.h

@@ -29 +29 @@
 SExp nreverse(SExp s);
 
+/// ���X�g�̊e�v�f�Ɋ֐���p�i���X�g�͂P�Œ��
+SExp mapcar(SExp (*fn)(SExp), SExp ls);
+
+/// alist ((key . value) ...) ������
+SExp assoc(SExp sym, SExp alist);
+
+
 /// ���X�g�ŗv�f���ЂƂ‚����H
 int singlep(SExp ls);

lang/c/misc/mlisp/test/main.cpp

@@ -31 +31 @@
 
 
-SExp comp_env, run_env;
+SExp g_comp_env, g_run_env;
 
 int load(const char* fn);
@@ -41 +41 @@
 
 SExp run(SExp c) {
-        return vm(nil, c, run_env, nil, nil);
+        return vm(nil, c, g_run_env, nil, nil);
 }
 
 SExp evaluate(SExp code) {
         SExp halt_code = cons(HALT, nil);
-        SExp c = compile(code, comp_env, halt_code);
+        SExp c = compile(code, g_comp_env, halt_code);
         return run(c);
 }
@@ -86 +86 @@
         SExp d = cadr(arg);
         return eq(a, d) ? t : nil;
+}
+
+static SExp builtin_rplaca(SExp arg) {
+        SExp a = car(arg);
+        SExp d = cadr(arg);
+        rplaca(a, d);
+        return nil;
+}
+
+static SExp builtin_rplacd(SExp arg) {
+        SExp a = car(arg);
+        SExp d = cadr(arg);
+        rplacd(a, d);
+        return nil;
 }
 
@@ -210 +224 @@
         SExp code = car(arg);
         SExp halt_code = cons(HALT, nil);
-        return compile(code, comp_env, halt_code);
-}
+        return compile(code, g_comp_env, halt_code);
+}
+
+static SExp builtin_macroexpand_1(SExp arg) {
+        SExp code = car(arg);
+        if (consp(code)) {
+                SExp m = is_macro(car(code));
+                if (!nilp(m))   return macroexpand_1(m, code);
+                else                    return code;
+        } else {
+                return code;
+        }
+}
+
+
+
+static SExp builtin_list(SExp arg) {
+        // @todo: �j�󂵂Ă������m���߂�     return arg;
+}
+
+static SExp cat(SExp a, SExp b) {
+        if (!consp(a))  return b;
+        else                    return cons(car(a), cat(cdr(a), b));
+}
+
+static SExp builtin_append(SExp arg) {
+        if (!consp(arg))                        return arg;
+        else if (nilp(cdr(arg)))        return car(arg);
+        else                                            return cat(car(arg), builtin_append(cdr(arg)));
+}
+
+static SExp builtin_reverse(SExp arg) {
+        return reverse(car(arg));
+}
+
+static SExp builtin_nreverse(SExp arg) {
+        return nreverse(car(arg));
+}
+
+static SExp builtin_global_symbols(SExp arg) {
+        return car(g_comp_env);
+}
+
+
 
 static void add_proctbl(SExp* pcenv, SExp* prenv) {
@@ -227 +283 @@
                 {       "car",          builtin_car,            FALSE,  1,      1,      },
                 {       "cdr",          builtin_cdr,            FALSE,  1,      1,      },
-                {       "consp",        builtin_consp,          FALSE,  1,      1,      },
-                {       "eq",           builtin_eq,                     FALSE,  2,      2,      },
+                {       "pair?",        builtin_consp,          FALSE,  1,      1,      },
+                {       "eq?",          builtin_eq,                     FALSE,  2,      2,      },
+                {       "set-car!",     builtin_rplaca,         FALSE,  2,      2,      },
+                {       "set-cdr!",     builtin_rplacd,         FALSE,  2,      2,      },
                 {       "+",            builtin_plus,           FALSE,  0,      -1,     },
                 {       "-",            builtin_difference,     FALSE,  1, -1,  },
@@ -241 +299 @@
                 {       "eval",         builtin_eval,           FALSE,  1,      1,      },
 
+                {       "list",         builtin_list,           FALSE,  0,      -1,     },
+                {       "append",       builtin_append,         FALSE,  0,      -1,     },
+                {       "reverse",      builtin_reverse,        FALSE,  0,      -1,     },
+                {       "nreverse",     builtin_nreverse,       FALSE,  0,      -1,     },
+
                 {       "load",         builtin_load,           FALSE,  1,      1,      },
                 {       "compile",      builtin_compile,        FALSE,  1,      1,      },
+                {       "macroexpand-1",        builtin_macroexpand_1,  FALSE,  1,      1,      },
+
+                {       "global-symbols",       builtin_global_symbols, FALSE,  1,      1,      },
         };
         for (int i=0; i<sizeof(tbl)/sizeof(*tbl); ++i) {
@@ -282 +348 @@
         add_consttbl(&cenv, &renv);
 
-        comp_env = cons(cenv, nil);
-        run_env = cons(renv, nil);
+        g_comp_env = cons(cenv, nil);
+        g_run_env = cons(renv, nil);
 }
 
@@ -290 +356 @@
         FILE* fp = fopen(fn, "r");
         SExp code = nil;
-        if (fp != NULL) {
+        if (fp == NULL) {
 //              runtime_error();
         } else {
@@ -300 +366 @@
                 }
                 SExp halt_code = cons(HALT, nil);
-                code = compile_block(nreverse(acc), comp_env, halt_code);
+                code = compile_block(nreverse(acc), g_comp_env, halt_code);
 
                 fclose(fp);
@@ -347 +413 @@
 
         mlisp_new(&vtbl);
+        init_compile();
         init_env();
         if (argc >= 2) {

lang/c/misc/mlisp/vm/op.h

@@ -6 +6 @@
 
 #if 1
-#define HALT            intern("halt")
-#define REFER           intern("refer")
-#define CONSTANT        intern("constant")
-#define CLOSE           intern("close")
-#define TEST            intern("test")
-#define ASSIGN          intern("assign")
-#define DEFINE          intern("define")
-#define CONTI           intern("conti")
-#define NUATE           intern("nuate")
-#define FRAME           intern("frame")
-#define ARGUMENT        intern("argument")
-#define APPLY           intern("apply")
-#define RETURN          intern("return")
+#define HALT            intern("HALT")
+#define REFER           intern("REFER")
+#define CONSTANT        intern("CONSTANT")
+#define CLOSE           intern("CLOSE")
+#define TEST            intern("TEST")
+#define ASSIGN          intern("ASSIGN")
+#define DEFINE          intern("DEFINE")
+#define CONTI           intern("CONTI")
+#define NUATE           intern("NUATE")
+#define FRAME           intern("FRAME")
+#define ARGUMENT        intern("ARGUMENT")
+#define APPLY           intern("APPLY")
+#define RETURN          intern("RETURN")
 
 #else

lang/c/misc/mlisp/vm/vm.cpp

@@ -15 +15 @@
 
 static void runtime_error(const char* msg) {
-        assert(!msg);
+        printf("%s\n", msg);
+        error(ERR_UNEXPECTED);
 }
 
@@ -35 +36 @@
         for (int elt = s2int(cdr(access)); ; --elt) {
                 if (nilp(r)) {
-                        SExp le = car(e);
-                        if (!nilp(le)) {
-                                extend_run_env(car(e), elt + 1);
+                        if (!b_extend) {
+                                runtime_error("illegal access");
+                                return nil;
                         } else {
-                                rplaca(e, replicate(elt + 1, nil));
+                                SExp le = car(e);
+                                if (!nilp(le)) {
+                                        extend_run_env(car(e), elt + 1);
+                                } else {
+                                        rplaca(e, replicate(elt + 1, nil));
+                                }
+
+                                r = car(e);     elt = s2int(cdr(access));
                         }
-
-                        r = car(e);     elt = s2int(cdr(access));
                 }
                 if (elt == 0)   return r;