Changeset 11789 for lang/c

Timestamp:

05/17/08 22:52:26 (6 months ago)

Author:

mokehehe

Message:

fix bug on 'find-free' and 'find-sets', lambda's syntax for compound expression.

Location:

lang/c/misc/mlisp

Files:

• core/c_compiler.cpp (modified) (4 diffs)
• core/m_basic.cpp (modified) (5 diffs)
• core/mlisp.cpp (modified) (2 diffs)
• core/v_vm.cpp (modified) (4 diffs)
• proto/stackbased.scm (modified) (11 diffs)

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

@@ -78 +78 @@
                 } else if (eq(op, intern("lambda"))) {
                         SExp vars = cadr(x);
-                        SExp body = caddr(x);
-                        return find_sets(body, set_minus(v, vars));
+                        SExp body = cddr(x);
+                        SExp sets = set_minus(v, vars);
+                        for (SExp p = body; !nilp(p); p = cdr(p)) {
+                                SExp x = car(p);
+                                sets = find_sets(x, sets);
+                        }
+                        return sets;
                 } else if (eq(op, intern("if"))) {
                         SExp test = cadr(x);
@@ -190 +195 @@
                 } else if (eq(op, intern("lambda"))) {
                         SExp vars = cadr(x);
-                        SExp body = caddr(x);
-                        return find_free(body, set_union(vars, b));
+                        SExp body = cddr(x);
+                        SExp free = set_union(vars, b);
+                        for (SExp p = body; !nilp(p); p = cdr(p)) {
+                                SExp x = car(p);
+                                free = find_free(x, free);
+                        }
+                        return free;
                 } else if (eq(op, intern("if"))) {
                         SExp test = cadr(x);
@@ -307 +317 @@
 }
 
-static SExp compile_macroexpand_1(SExp m, SExp args) {
+static SExp transform_macro(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);
+                return evaluate(gen_macro_call(p, args));
+        }
 }
 
@@ -415 +421 @@
                         SExp xx = cadr(x);
                         SExp apply = list(2, APPLY, int2s(1));
-                        SExp nx = is_tail ? list(3, SHIFT, 1, apply) : apply;
+                        SExp nx = is_tail ? list(3, SHIFT, int2s(1), apply) : apply;
                         SExp c = list(2, CONTI, list(2, ARGUMENT, compile(xx, e, s, nx)));
                         if (is_tail)

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

@@ -60 +60 @@
         }
         return ls;
+}
+
+static SExp builtin_append() {
+        sint n = get_arg_num();
+        if (n == 0) {
+                return nil;
+        } else {
+                SExp ls = get_arg(n - 1);
+                for (int i=n-1; --i>=0; ) {
+                        ls = append2(get_arg(i), ls);
+                }
+                return ls;
+        }
 }
 
@@ -205 +218 @@
 //=============================================================================
 
+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 {
+                SExp sub = mapcar(transform_quasiquote_loop, x);
+                return list(2, intern("list"), cons(intern("append"), sub));
+        }
+}
+
+static SExp builtin_quasiquote(SExp args) {
+        SExp res = transform_quasiquote_loop(car(args));
+        SExp h = car(res);
+        if (eq(h, intern("list")))
+                return cadr(res);
+        else if (eq(h, intern("quote")))
+                return list(2, intern("quote"), list(1, car(cadr(res))));
+        else {
+                error(ERR_UNEXPECTED);
+                return nil;
+        }
+}
+
+
+//=============================================================================
+
+static void define_basic_const() {
+        struct {
+                const char* name;
+        } static const tbl[] = {
+                "t",
+                "nil",
+        };
+        for (int i=0; i<sizeof(tbl)/sizeof(*tbl); ++i) {
+                SExp sym = intern(tbl[i].name);
+                define_global(sym, sym);
+        }
+}
+
+
 static void define_basic_proc() {
         struct {
@@ -220 +276 @@
                 {       "set-cdr!",     builtin_rplacd,         2,      2,      },
                 {       "list",         builtin_list,           0,      -1,     },
+                {       "append",       builtin_append,         0,      -1,     },
 
                 {       "+",            builtin_plus,           0,      -1,     },
@@ -246 +303 @@
 
 
-static void define_basic_const() {
+static void define_basic_macro() {
         struct {
                 const char* name;
+                SCFuncM func;
+                int minarg;
+                int maxarg;
         } static const tbl[] = {
-                "t",
-                "nil",
+                {       "quasiquote",   builtin_quasiquote,             1,      1,      },
         };
         for (int i=0; i<sizeof(tbl)/sizeof(*tbl); ++i) {
                 SExp sym = intern(tbl[i].name);
-                define_global(sym, sym);
+                SExp fn = gen_cmacro(tbl[i].func, tbl[i].minarg, tbl[i].maxarg);
+                define_global(sym, fn);
         }
 }
@@ -263 +323 @@
 
 void define_basic_lib(void) {
+        define_basic_const();
         define_basic_proc();
-        define_basic_const();
-}
+        define_basic_macro();
+}

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

@@ -25 +25 @@
 SExp evaluate(SExp code) {
         SExp c = compile_ontop(code);
-print(c);
+//print(c);
         return run(c);
 }
@@ -37 +37 @@
                 return nil;
         } else {
-                SExp res;
                 for (;;) {
                         SExp sexp = read_from_file(fp);
                         if (nilp(sexp)) break;          // @todo: EOF�̈���
-                        res = run(compile_ontop(sexp));
+                        run(compile_ontop(sexp));
                 }
                 fclose(fp);
-                return res;
+                return t;
         }
 }

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

@@ -197 +197 @@
 
 static int restore_stack(SExp v) {
+        clear_stack();
         int s = vector_length(v);
-        clear_stack();
-        for (int i=0; i<s; ) {
+        for (int i=0; i<s; ++i) {
                 push(vector_ref(v, i));
         }
@@ -257 +257 @@
                         case Procedure::Cell:
                                 {
-                                        modify_args(proc, n, g_sp);
+                                        modify_args(proc, n, ss - 1);
                                         *px = closure_body(fn); *pf = ss;       *pc = fn;
                                 }
@@ -318 +318 @@
                 SExp op = car(x);
 
-                dump_stack(g_sp);
-                print(op);
+//              dump_stack(g_sp);
+//              print(op);
 
                 if (op == HALT) {
@@ -396 +396 @@
 
                         restore_stack(stack);
-                        push(int2s(0));
                         x = xx;
                 } else if (op == DEFINE) {

lang/c/misc/mlisp/proto/stackbased.scm

@@ -82 +82 @@
         (map (lambda (s) (list 'quote s)) args)))  ; 引数を全てクォートでくくる
 
-(define (compile-macroexpand-1 m args)
+(define (transform-macro m args)
   (let ((body (slot-ref m 'body)))
     (if (procedure? body)
         (apply body args)
-      (gen-macro-call m args))))
-
-(define (transform-macro m args)
-  (evaluate (compile-macroexpand-1 m args)))
+      (evaluate (gen-macro-call m args)))))
 
 
@@ -247 +244 @@
       (record-case x
                    (quote (obj) '())
-                   (lambda (vars body)
-                     (find-free body (set-union vars b)))
+                   (lambda (vars)
+                     (let ((body (cddr x)))
+                       (fold (lambda (x r) (find-free x r))
+                             (set-union vars b)
+                             body)))
                    (if (test then else)
                        (set-union (find-free test b)
@@ -272 +272 @@
       (record-case x
                    (quote (obj) '())
-                   (lambda (vars body)
-                     (find-sets body (set-minus v vars)))
+                   (lambda (vars)
+                     (let ((body (cddr x)))
+                       (fold (lambda (x r) (find-sets x r))
+                             (set-minus v vars)
+                             body)))
                    (if (test then else)
                        (set-union (find-sets test v)
@@ -314 +317 @@
 (define *sp* 0)
 
+(define (clear-stack)
+  (set! *sp* 0))
+
 (define (init-stack)
   (set! *stack* (make-vector 1000))
-  (set! *sp* 0))
+  (clear-stack))
 
 (define push
@@ -379 +385 @@
                         (begin
                           (restore-stack stack)
-                          (push 0)
                           (VM a x f c)))
                  (FRAME (x ret)
@@ -406 +411 @@
                                         (VM res ret f c))
                                     (begin
-                                      (modify-args a n *sp*)
+                                      (modify-args a n (- ss 1))
                                       (VM a body ss a))))
                               (error "wrong number of argument"))
@@ -449 +454 @@
   (lambda (s)
     (closure
-     '(cc)
+     '(1 . 1)
      (list 'REFER-LOCAL 0 (list 'NUATE (save-stack s) '(RETURN)))
      0
@@ -465 +470 @@
 (define restore-stack
   (lambda (v)
+    (clear-stack)
     (let ((s (vector-length v)))
       (recur copy ((i 0))
              (unless (= i s)
-               (vector-set! *stack* i (vector-ref v i))
+               (push (vector-ref v i))
                (copy (+ i 1))))
       s)))
@@ -707 +713 @@
                      'proc 2 2
                      (lambda () (< (get-arg 0) (get-arg 1)))))
+              (cons '>
+                    (gen-builtin
+                     'proc 2 2
+                     (lambda () (> (get-arg 0) (get-arg 1)))))
+              (cons '=
+                    (gen-builtin
+                     'proc 2 2
+                     (lambda () (= (get-arg 0) (get-arg 1)))))
               (cons 'read
                     (gen-builtin
@@ -727 +741 @@
                      'proc 1 1
                      (lambda () (load-file (get-arg 0)))))
+              (cons 'macroexpand-1
+                    (gen-builtin
+                     'proc 1 1
+                     (lambda ()
+                       (let ((sexp (get-arg 0)))
+                         (if (pair? sexp)
+                             (let* ((fn (car sexp))
+                                    (m (and (exist-global? fn)
+                                            (refer-global fn))))
+                               (if (macro? m)
+                                   (transform-macro m (cdr sexp))
+                                 sexp))
+                           sexp)))))
               
               
@@ -778 +805 @@
     (let ((srcfn (cadr args)))
       (load-file srcfn))))
+
+
+
+#|
+(load "./stackbased.scm")
+(repl)
+
+
+
+(load "test_macro.scm")
+
+
+
+
+(macroexpand-1 '(let ((x 1) (y 2)) (+ x y)))
+
+
+
+(defmacro test (a . b) (list 'list a b))
+
+
+(test 1 2)
+
+
+
+(evaluate '((lambda (a b . c) (list a b c)) 1 2 3 4))
+
+
+
+
+(compile-top '((lambda (a . b) (list 'list a b)) '1 '2))
+
+
+(let ((x 1) (y 2)) (cons x y))
+
+
+
+
+
+
+
+
+|#