Changeset 11676 for lang/c

Timestamp:

05/16/08 08:42:21 (6 months ago)

Author:

mokehehe

Message:

任意個の引数の受け取り
関数呼び出し時の引数の数のチェック

Location:

lang/c/misc/mlisp

Files:

• core/c_compiler.cpp (modified) (4 diffs)
• core/s_util.h (modified) (1 diff)
• core/sexp.cpp (modified) (3 diffs)
• core/v_vm.cpp (modified) (6 diffs)
• inc/sexp.h (modified) (1 diff)
• readme.txt (modified) (1 diff)

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

@@ -238 +238 @@
 }
 
-
+/// �h�b�g�̏o�Ă����u���
+static SExp dotted_pos(SExp ls) {
+        for (int pos = 0; ; ls = cdr(ls), ++pos) {
+                if (nilp(ls))   return nil;
+                if (!consp(ls)) return int2s(pos);
+        }
+}
+
+/// ���ŏ��ƍő����߂�static SExp get_var_min_max(SExp vars) {
+        SExp pos = dotted_pos(vars);
+        if (!nilp(pos)) {
+                return cons(pos, int2s(-1));
+        } else {
+                SExp l = int2s(length(vars));
+                return cons(l, l);
+        }
+}
+
+/// �h�b�g�΂𐳋K�`�ɒ���
+static SExp dotted2proper(SExp ls) {
+        if (consp(ls)) {
+                SExp last = last_pair(ls);
+                if (nilp(cdr(last))) {
+                        return ls;
+                } else {
+                        SExp copy = list_copy(ls);
+                        SExp last = last_pair(copy);
+                        rplacd(last, cons(cdr(last), nil));
+                        return copy;
+                }
+        } else {
+                return list(1, ls);
+        }
+}
+
+
+
+//=============================================================================
+
+/// ����void init_compile(void) {
+}
+
+SExp compile_block(SExp sexps, SExp e, SExp s, SExp next) {
+        SExp d = cdr(sexps);
+        SExp nx = nilp(d) ? next : compile_block(d, e, s, next);
+        return compile(car(sexps), e, s, nx);
+}
+
+static SExp compile_define(SExp var, SExp body, SExp e, SExp s, SExp next) {
+        while (consp(var)) {
+                body = list(1, append2(list(2, intern("lambda"), cdr(var)), body));
+                var = car(var);
+        }
+        return compile(car(body), e, s, list(3, DEFINE, var, next));
+}
 
 
@@ -252 +306 @@
                 return compile_pair_loop(cdr(args), compile(car(args), e, s, list(2, ARGUMENT, c)), e, s, next);
         }
-}
-
-
-//=============================================================================
-
-/// ����void init_compile(void) {
-}
-
-SExp compile_block(SExp sexps, SExp e, SExp s, SExp next) {
-        SExp d = cdr(sexps);
-        SExp nx = nilp(d) ? next : compile_block(d, e, s, next);
-        return compile(car(sexps), e, s, nx);
-}
-
-static SExp compile_define(SExp var, SExp body, SExp e, SExp s, SExp next) {
-        while (consp(var)) {
-                body = list(3, intern("lambda"), cdr(var), body);
-                var = car(var);
-        }
-        return compile(body, e, s, list(3, DEFINE, var, next));
 }
 
@@ -286 +320 @@
                         SExp vars = cadr(x);
                         SExp body = cddr(x);
-                        SExp non_local = find_free(body, vars);
+                        SExp var_min_max = get_var_min_max(vars);
+                        SExp mvars = dotted2proper(vars);
+                        SExp non_local = find_free(body, mvars);
                         SExp free = filter_member(append2(car(e), cdr(e)), non_local);
-                        SExp sets = find_sets(body, vars);
-
-                        SExp boxes = make_boxes(sets, vars, compile_block(body, cons(vars, free), set_union(sets, set_intersect(s, free)), list(1, RETURN)));
-                        return collect_free(free, e, list(4, CLOSE, int2s(length(free)), boxes, next));
+                        SExp sets = find_sets(body, mvars);
+                        SExp cbody = compile_block(body, cons(mvars, free), set_union(sets, set_intersect(s, free)), list(1, RETURN));
+
+                        SExp boxes = make_boxes(sets, mvars, cbody);
+                        return collect_free(free, e, list(5, CLOSE, int2s(length(free)), var_min_max, boxes, next));
                 } else if (eq(op, intern("if"))) {
                         SExp test = cadr(x);
@@ -325 +362 @@
                 } else if (eq(op, intern("define"))) {
                         SExp var = cadr(x);
-                        SExp body = caddr(x);
+                        SExp body = cddr(x);
                         return compile_define(var, body, e, s, next);
                 } else {

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

@@ -65 +65 @@
 __inline SExp cadddr(SExp s)    { return car(cdddr(s)); }
 __inline SExp cddddr(SExp s)    { return cdr(cdddr(s)); }
+__inline SExp caddddr(SExp s)   { return car(cddddr(s)); }
+__inline SExp cdddddr(SExp s)   { return cdr(cddddr(s)); }
 
 

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 b_macro, int minnarg, int maxnarg) {
         Procedure* p = (Procedure*)salloc(sizeof(Procedure), FALSE);
         p->type = tProc;
@@ -264 +263 @@
 
 
-SExp gen_closure(SExp body, SExp env)
-{
+SExp gen_closure(SExp body, SExp env, int minarg, int maxarg) {
         bool b_macro = false;
         Procedure* p = (Procedure*)salloc(sizeof(Procedure), FALSE);
@@ -272 +270 @@
         p->u.cell.s = body;
         p->u.cell.e = env;
-        p->minnarg = -1;
-        p->maxnarg = -1;
+        p->minnarg = minarg;
+        p->maxnarg = maxarg;
 
         SExp s;

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

@@ -106 +106 @@
 // �N���[�W��
 
-static SExp closure(SExp body, int n, int s) {
-#if 0
-        SExp v = make_vector(n + 1);
-        vector_set(v, 0, body);
-        for (int i=0; i<n; ++i) {
-                vector_set(v, i+1, index(s, i));
-        }
-        return v;
-#else
+static SExp closure(int minarg, int maxarg, SExp body, int n, int s) {
         SExp v = nil;
         if (n > 0) {
@@ -122 +114 @@
                 }
         }
-        return gen_closure(body, v);
-#endif
+        return gen_closure(body, v, minarg, maxarg);
 }
 
 static SExp closure_body(SExp c) {
-#if 0
-        return vector_ref(c, 0);
-#else
         Procedure* p = (Procedure*)c.ptr;
         assert(type_check(c, tProc));
         assert(p->get_func_type() == Procedure::Cell);
         return p->u.cell.s;
-#endif
 }
 
@@ -149 +136 @@
 
 
+
+/// ������F�b�N
+static bool check_arg_num(Procedure* proc, int n) {
+        if (proc->maxnarg >= proc->minnarg) {
+                return (proc->minnarg <= n && n <= proc->maxnarg);
+        } else {
+                return proc->minnarg <= n;
+        }
+}
+
+static void modify_args(Procedure* proc, int n, int s) {
+        if (proc->minnarg != proc->maxnarg) {
+                SExp rest = nil;
+                for (int i=n; --i >= proc->minnarg; ) {
+                        rest = cons(index(s, i), rest);
+                }
+                index_set(s, proc->minnarg, rest);
+        }
+}
+
+
 //=============================================================================
 
@@ -170 +178 @@
 
 static SExp continuation(int s) {
-        return closure(list(3, REFER_LOCAL, int2s(0), list(3, NUATE, save_stack(s), list(2, RETURN, int2s(0)))),
-                                   0,
-                                   0);
+        SExp body = list(3, REFER_LOCAL, int2s(0), list(3, NUATE, save_stack(s), list(2, RETURN, int2s(0))));
+        return closure(1, 1, body, 0, 0);
 }
 
@@ -243 +250 @@
                 } else if (op == CLOSE) {
                         sint n = s2int(cadr(x));
-                        SExp body = caddr(x);
-                        SExp xx = cadddr(x);
-                        a = closure(body, n, s);        x = xx; s -= n;
+                        SExp var_min_max = caddr(x);
+                        SExp body = cadddr(x);
+                        SExp xx = caddddr(x);
+
+                        int minarg = s2int(car(var_min_max));
+                        int maxarg = s2int(cdr(var_min_max));
+                        a = closure(minarg, maxarg, body, n, s);        x = xx; s -= n;
                 } else if (op == BOX) {
                         sint n = s2int(cadr(x));
@@ -262 +273 @@
                         x = xx;
                 } else if (op == APPLY) {
-                        SExp argnum = cadr(x);
-                        int ss = push(argnum, s);
                         if (type_of(a) == tProc) {
+                                SExp argnum = cadr(x);
+                                int ss = push(argnum, s);
+                                int n = s2int(argnum);
                                 Procedure* proc = (Procedure*)a.ptr;
-                                switch (proc->get_func_type()) {
-                                case Procedure::Builtin:
-                                        {
-                                                SCFunc cfunc = proc->u.cfunc;
-                                                SExp res = (*cfunc)(ss);
-                                                a = res;
-                                                s = vm_return(&x, &f, &c, ss);
+                                if (check_arg_num(proc, n)) {
+                                        modify_args(proc, n, s);
+                                        switch (proc->get_func_type()) {
+                                        case Procedure::Builtin:
+                                                {
+                                                        SCFunc cfunc = proc->u.cfunc;
+                                                        SExp res = (*cfunc)(ss);
+                                                        a = res;
+                                                        s = vm_return(&x, &f, &c, ss);
+                                                }
+                                                break;
+                                        case Procedure::Cell:
+                                                {
+                                                        x = closure_body(a);    f = ss; c = a;  s = ss;
+                                                }
+                                                break;
                                         }
-                                        break;
-                                case Procedure::Cell:
-                                        {
-                                                x = closure_body(a);    f = ss; c = a;  s = ss;
-                                        }
-                                        break;
+                                } else {
+                                        runtime_error("wrong number of argument");
                                 }
                         } else {

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

@@ -106 +106 @@
 SExp gen_cfunc(SCFunc cfunc, int b_macro, int minnarg, int maxnarg);
 
-SExp gen_closure(SExp body, SExp env);
+SExp gen_closure(SExp body, SExp env, int minarg, int maxarg);
 
 /// s���𐮐��ɕϊ�

lang/c/misc/mlisp/readme.txt

@@ -44 +44 @@
 
 * ToDo
--[v] �X�^�b�N�x�[�X�ɒu��������-[x] �C�ӌ‚̈��󂯎�
+-[v] �X�^�b�N�x�[�X�ɒu��������-[v] �C�ӌ‚̈��󂯎�
 -[x] �}�N�����
 --[x] macroexpand ��- C �������[�o���̊֐���яo�������ɂ���- �unil�v�ut�v���V���{���Ȃ̂ŁA�R���p�C�������V���{���Q�ƂɂȂ�Ă��܂�