Changeset 11750 for lang/c

Timestamp:

05/17/08 17:24:24 (5 years ago)

Author:

mokehehe

Message:

マクロ組込み

Location:

lang/c/misc/mlisp

Files:

• core/c_compiler.cpp (modified) (3 diffs)
• core/inner.h (modified) (2 diffs)
• core/m_basic.cpp (modified) (2 diffs)
• core/sexp.cpp (modified) (3 diffs)
• core/v_vm.cpp (modified) (2 diffs)
• inc/sexp.h (modified) (2 diffs)

lang/c/misc/mlisp/core/c_compiler.cpp

@@ -276 +276 @@
 
 //=============================================================================
+// �}�N��
+
+static SExp gen_macro_from_sexp(SExp vars, SExp body) {
+        SExp var_min_max = get_var_min_max(vars);
+        sint minnarg = s2int(car(var_min_max));
+        sint maxnarg = s2int(cdr(var_min_max));
+        SExp code = cons(intern("lambda"), cons(vars, body));
+        return gen_macro(code, minnarg, maxnarg);
+}
+
+static void compile_defmacro(SExp name, SExp vars, SExp body) {
+        define_global(name, gen_macro_from_sexp(vars, body));
+}
+
+static bool macrop(SExp fn) {
+        if (type_of(fn) == tProc) {
+                Procedure* p = (Procedure*)fn.ptr;
+                if (p->get_proc_type() == Procedure::Macro) {
+                        return true;
+                }
+        }
+        return false;
+}
+
+static SExp quote(SExp s)       { return list(2, intern("quote"), s); }
+
+static SExp gen_macro_call(Procedure* p, SExp args) {
+        SExp qargs = mapcar(quote, args);
+        return cons(p->u.cell.s, qargs);
+}
+
+static SExp compile_macroexpand_1(SExp m, SExp args) {
+        Procedure* p = (Procedure*)m.ptr;
+        if (p->get_func_type() == Procedure::Builtin) {
+                return p->u.mfunc(args);
+        } else {
+                return gen_macro_call(p, args);
+        }
+}
+
+static SExp transform_macro(SExp m, SExp args) {
+        return compile_macroexpand_1(m, args);
+}
+
+//=============================================================================
 
 /// ����void init_compile(void) {
@@ -305 +350 @@
         } else {
                 return compile_pair_loop(cdr(args), compile(car(args), e, s, list(2, ARGUMENT, c)), e, s, next);
+        }
+}
+
+// �K�p����p�C��
+static SExp compile_apply(SExp x, SExp e, SExp s, SExp next) {
+        SExp fn = car(x);
+        SExp args = cdr(x);
+        SExp gval = symbolp(fn) ? refer_global(fn) : nil;
+        if (macrop(gval)) {
+                return compile(transform_macro(gval, args), e, s, next);
+        } else {
+                int argnum = length(args);
+                SExp apply = list(2, APPLY, int2s(argnum));
+                SExp nx = tailp(next) ? list(3, SHIFT, int2s(argnum), apply) : apply;
+                SExp c = compile(car(x), e, s, nx);
+                return compile_pair_loop(args, c, e, s, next);
         }
 }
@@ -364 +425 @@
                         SExp body = cddr(x);
                         return compile_define(var, body, e, s, next);
-                } else {
-                        SExp args = cdr(x);
-                        int argnum = length(args);
-                        SExp apply = list(2, APPLY, int2s(argnum));
-                        SExp nx = tailp(next) ? list(3, SHIFT, int2s(argnum), apply) : apply;
-                        SExp c = compile(car(x), e, s, nx);
-                        return compile_pair_loop(args, c, e, s, 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_apply(x, e, s, next);
                 }
         } else {

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

@@ -69 +69 @@
         union {
                 SCFunc cfunc;
+                SCFuncM mfunc;
                 struct {
                         SExp s;                 ///< ��
@@ -77 +78 @@
 
         int get_func_type() const               { return flag & FuncType; }
+        int get_proc_type() const               { return flag & ProcType; }
 };
 

lang/c/misc/mlisp/core/m_basic.cpp

@@ -50 +50 @@
         rplacd(a, d);
         return nil;
+}
+
+static SExp builtin_list(int s) {
+        sint n = get_arg_num(s);
+        SExp ls = nil;
+        for (int i=n; --i>=0; ) {
+                SExp a = get_arg(s, i);
+                ls = cons(a, ls);
+        }
+        return ls;
 }
 
@@ -199 +209 @@
                 const char* name;
                 SCFunc func;
-                int b_macro;
                 int minarg;
                 int maxarg;
         } static const tbl[] = {
-                {       "cons",         builtin_cons,           FALSE,  2,      2,      },
-                {       "car",          builtin_car,            FALSE,  1,      1,      },
-                {       "cdr",          builtin_cdr,            FALSE,  1,      1,      },
-                {       "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,  },
-                {       "*",            builtin_times,          FALSE,  0,      -1,     },
-                {       "/",            builtin_quotient,       FALSE,  1, -1,  },
-                {       "=",            builtin_numeq,          FALSE,  1, -1,  },
-                {       "<",            builtin_lt,                     FALSE,  1, -1,  },
-                {       ">",            builtin_gt,                     FALSE,  1, -1,  },
-                {       "<=",           builtin_le,                     FALSE,  1, -1,  },
-                {       ">=",           builtin_ge,                     FALSE,  1, -1,  },
-
-                {       "read",         builtin_read,           FALSE,  0,      0,      },
-                {       "print",        builtin_print,          FALSE,  1,      1,      },
-                {       "eval",         builtin_eval,           FALSE,  1,      1,      },
-
-                {       "load",         builtin_load,           FALSE,  1,      1,      },
-                {       "compile",      builtin_compile,        FALSE,  1,      1,      },
+                {       "cons",         builtin_cons,           2,      2,      },
+                {       "car",          builtin_car,            1,      1,      },
+                {       "cdr",          builtin_cdr,            1,      1,      },
+                {       "pair?",        builtin_consp,          1,      1,      },
+                {       "eq?",          builtin_eq,                     2,      2,      },
+                {       "set-car!",     builtin_rplaca,         2,      2,      },
+                {       "set-cdr!",     builtin_rplacd,         2,      2,      },
+                {       "list",         builtin_list,           0,      -1,     },
+
+                {       "+",            builtin_plus,           0,      -1,     },
+                {       "-",            builtin_difference,     1, -1,  },
+                {       "*",            builtin_times,          0,      -1,     },
+                {       "/",            builtin_quotient,       1, -1,  },
+                {       "=",            builtin_numeq,          1, -1,  },
+                {       "<",            builtin_lt,                     1, -1,  },
+                {       ">",            builtin_gt,                     1, -1,  },
+                {       "<=",           builtin_le,                     1, -1,  },
+                {       ">=",           builtin_ge,                     1, -1,  },
+
+                {       "read",         builtin_read,           0,      0,      },
+                {       "print",        builtin_print,          1,      1,      },
+                {       "eval",         builtin_eval,           1,      1,      },
+
+                {       "load",         builtin_load,           1,      1,      },
+                {       "compile",      builtin_compile,        1,      1,      },
         };
         for (int i=0; i<sizeof(tbl)/sizeof(*tbl); ++i) {
                 SExp sym = intern(tbl[i].name);
-                SExp fn = gen_cfunc(tbl[i].func, tbl[i].b_macro, tbl[i].minarg, tbl[i].maxarg);
+                SExp fn = gen_cfunc(tbl[i].func, tbl[i].minarg, tbl[i].maxarg);
                 define_global(sym, fn);
         }

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

@@ -248 +248 @@
 
 
-SExp gen_cfunc(SCFunc cfunc, int b_macro, int minnarg, int maxnarg) {
+SExp gen_cfunc(SCFunc cfunc, int minnarg, int maxnarg) {
+        const bool b_macro = false;
         Procedure* p = (Procedure*)salloc(sizeof(Procedure), FALSE);
         p->type = tProc;
@@ -262 +263 @@
 }
 
-
-SExp gen_closure(SExp body, SExp env, int minarg, int maxarg) {
-        bool b_macro = false;
+SExp gen_cmacro(SCFuncM mfunc, int minnarg, int maxnarg) {
+        const bool b_macro = true;
+        Procedure* p = (Procedure*)salloc(sizeof(Procedure), FALSE);
+        p->type = tProc;
+        p->flag = Procedure::Builtin | (b_macro ? Procedure::Macro : Procedure::Lambda);
+        p->u.mfunc = mfunc;
+        p->minnarg = minnarg;
+        p->maxnarg = maxnarg;
+
+        SExp s;
+        s.ptr = (SExpExtU*)p;
+
+        return s;
+}
+
+
+SExp gen_closure(SExp body, SExp env, int minnarg, int maxnarg) {
+        const bool b_macro = false;
         Procedure* p = (Procedure*)salloc(sizeof(Procedure), FALSE);
         p->type = tProc;
@@ -270 +286 @@
         p->u.cell.s = body;
         p->u.cell.e = env;
-        p->minnarg = minarg;
-        p->maxnarg = maxarg;
+        p->minnarg = minnarg;
+        p->maxnarg = maxnarg;
+
+        SExp s;
+        s.ptr = (SExpExtU*)p;
+
+        return s;
+}
+
+
+SExp gen_macro(SExp body, int minnarg, int maxnarg) {
+        const bool b_macro = true;
+        Procedure* p = (Procedure*)salloc(sizeof(Procedure), FALSE);
+        p->type = tProc;
+        p->flag = Procedure::Cell | (b_macro ? Procedure::Macro : Procedure::Lambda);
+        p->u.cell.s = body;
+        p->u.cell.e = nil;
+        p->minnarg = minnarg;
+        p->maxnarg = maxnarg;
 
         SExp s;

lang/c/misc/mlisp/core/v_vm.cpp

@@ -212 +212 @@
         int r = 0;
         if (type_of(fn) == tProc) {
-                int ss = push(argnum, s);
                 int n = s2int(argnum);
                 Procedure* proc = (Procedure*)fn.ptr;
                 if (check_arg_num(proc, n)) {
+                        int ss = push(argnum, s);
                         switch (proc->get_func_type()) {
                         case Procedure::Builtin:
@@ -238 +238 @@
                 }
         } else {
-                runtime_error("can't call");
+                runtime_error("can't apply");
                 r = -1;
         }

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

@@ -48 +48 @@
 /// �g���݊֐��̌^
 typedef SExp (*SCFunc)(int stack);
+typedef SExp (*SCFuncM)(SExp args);
 
 
@@ -104 +105 @@
 SExp list(int n, ...);
 
-SExp gen_cfunc(SCFunc cfunc, int b_macro, int minnarg, int maxnarg);
+SExp gen_cfunc(SCFunc cfunc, int minnarg, int maxnarg);
+SExp gen_cmacro(SCFuncM mfunc, int minnarg, int maxnarg);
 
-SExp gen_closure(SExp body, SExp env, int minarg, int maxarg);
+SExp gen_closure(SExp body, SExp env, int minnarg, int maxnarg);
+
+SExp gen_macro(SExp body, int minnarg, int maxnarg);
 
 /// s���𐮐��ɕϊ�