Changeset 12093 for lang/c

Timestamp:

05/21/08 08:27:12 (6 months ago)

Author:

mokehehe

Message:

fix a bug of continuation

Location:

lang/c/misc/mlisp

Files:

• core/c_compiler.cpp (modified) (1 diff)
• core/m_basic.cpp (modified) (3 diffs)
• core/v_vm.cpp (modified) (2 diffs)
• inc/mlisp.h (modified) (1 diff)
• inc/sexp.h (modified) (1 diff)
• proto/stackbased.scm (modified) (7 diffs)
• readme.txt (modified) (2 diffs)
• test/main.cpp (modified) (3 diffs)

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

@@ -422 +422 @@
                         SExp apply = list(2, APPLY, int2s(1));
                         SExp nx = is_tail ? list(3, SHIFT, int2s(1), apply) : apply;
-                        SExp c = list(2, CONTI, list(2, ARGUMENT, compile(xx, e, s, nx)));
+                        SExp c = list(3, CONTI, is_tail ? t : nil, list(2, ARGUMENT, compile(xx, e, s, nx)));
                         if (is_tail)
                                 return c;

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

@@ -8 +8 @@
 #include "s_util.h"
 #include "inner.h"
+#include <stdlib.h>     // for exit()
 
 
@@ -214 +215 @@
 }
 
+static SExp builtin_exit() {
+        sint n = get_arg_num();
+        int ret = 0;
+        if (n >= 1) {
+                SExp s = get_arg(0);
+                if (type_of(s) == tInt) {
+                        ret = s2int(s);
+                } else {
+                        ret = -1;
+                }
+        }
+        exit(ret);
+        return nil;
+}
+
 
 
@@ -294 +310 @@
                 {       "load",         builtin_load,           1,      1,      },
                 {       "compile",      builtin_compile,        1,      1,      },
+                {       "exit",         builtin_exit,           0,      1,      },
         };
         for (int i=0; i<sizeof(tbl)/sizeof(*tbl); ++i) {

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

@@ -205 +205 @@
 }
 
-static SExp continuation(int s) {
-        SExp body = list(3, REFER_LOCAL, int2s(0), list(3, NUATE, save_stack(s), list(1, RETURN)));
+static SExp continuation(int s, SExp tt) {
+        SExp body = list(3, REFER_LOCAL, int2s(0), list(4, NUATE, save_stack(s), tt, list(1, RETURN)));
         return closure(1, 1, body, 0, 0);
 }
@@ -389 +389 @@
                         x = xx;
                 } else if (op == CONTI) {
-                        SExp xx = cadr(x);
-                        a = continuation(g_sp); x = xx;
+                        SExp tt = cadr(x);
+                        SExp xx = caddr(x);
+                        a = continuation(g_sp, tt);     x = xx;
                 } else if (op == NUATE) {
                         SExp stack = cadr(x);
-                        SExp xx = caddr(x);
+                        SExp tt = caddr(x);
+                        SExp xx = cadddr(x);
 
                         restore_stack(stack);
+                        if (nilp(tt))   push(int2s(0));
                         x = xx;
                 } else if (op == DEFINE) {

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

@@ -23 +23 @@
 SExp evaluate(SExp code);
 
-// �\�[�X�̓ǂݍ��݁A�]��
+/// �\�[�X�̓ǂݍ��݁A�]��
 SExp load_eval(const char* fn);
 
 
+/// �O���[�o���Ȓl�̒�
+void define_global(SExp sym, SExp val);
 
+/// �O���[�o���̎Q��
+SExp refer_global(SExp sym);
 
-void define_global(SExp sym, SExp val);
-SExp refer_global(SExp sym);
+/// �O���[�o���ɒl�����݂��邩�H
 int exist_global(SExp sym);
 
+/// �Ăяo��
 SExp vm_apply(SExp fn, int narg, ...);
 

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

@@ -103 +103 @@
 void reset_error(void);
 
-SExp list(int n, ...);
-
 SExp gen_cfunc(SCFunc cfunc, int minnarg, int maxnarg);
 SExp gen_cmacro(SCFuncM mfunc, int minnarg, int maxnarg);

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

@@ -184 +184 @@
                                            (compile xx e s (list 'ASSIGN-GLOBAL var next)))))
                    (call/cc (x)
-                            (let ((c `(CONTI
-                                       (ARGUMENT
-                                        ,(compile x e s
-                                                  (if (tail? next)
-                                                      (list 'SHIFT
-                                                            1
-                                                            '(APPLY 1))
-                                                    '(APPLY 1)))))))
-                              (if (tail? next)
+                            (let* ((t? (tail? next))
+                                   (c `(CONTI
+                                        ,t?
+                                        (ARGUMENT
+                                         ,(compile x e s
+                                                   (if t?
+                                                       `(SHIFT
+                                                         1
+                                                         (APPLY 1))
+                                                     '(APPLY 1)))))))
+                              (if t?
                                   c
-                                (list 'FRAME c next))))
+                                `(FRAME ,c ,next))))
                    (define (var)
                      (let ((body (cddr x)))
@@ -353 +355 @@
 (define VM
   (lambda (a x f c)
-;    (write/ss (list (car x) a (dump-stack *sp*)))
-;    (newline)
+    (write/ss (list (car x) (dump-stack *sp*)))
+    (newline)
     (record-case x
                  (HALT () a)
@@ -380 +382 @@
                               (set-box! (index-closure c n) a)
                               (VM a x f c))
-                 (CONTI (x)
-                        (VM (continuation *sp*) x f c))
-                 (NUATE (stack x)
+                 (CONTI (t? x)
+                        (VM (continuation *sp* t?) x f c))
+                 (NUATE (stack t? x)
                         (begin
                           (restore-stack stack)
+                          (if (not t?) (push 0))
                           (VM a x f c)))
                  (FRAME (x ret)
@@ -452 +455 @@
 
 (define continuation
-  (lambda (s)
+  (lambda (s t?)
     (closure
      '(1 . 1)
-     (list 'REFER-LOCAL 0 (list 'NUATE (save-stack s) '(RETURN)))
+     (list 'REFER-LOCAL 0 (list 'NUATE (save-stack s) t? '(RETURN)))
      0
      0)))
@@ -463 +466 @@
     (let ((v (make-vector s)))
       (recur copy ((i 0))
-             (unless (= i s)
+             (unless (>= i s)
                (vector-set! v i (vector-ref *stack* i))
                (copy (+ i 1))))
@@ -811 +814 @@
 (load "./stackbased.scm")
 (repl)
-
+quit
 
 
@@ -841 +844 @@
 
 
-
+(call/cc (lambda (cc) (cc 1234)))
+
+
+1234
+
+(load "test_nondet.scm")
 
 

lang/c/misc/mlisp/readme.txt

@@ -41 +41 @@
                 Cygwin �p Rakefile
 
+        proto
+                Gauche �ɂ��v���g�^�C�v��
+
 
 
@@ -46 +49 @@
 -[v] �X�^�b�N�x�[�X�ɒu��������-[v] �C�ӌ‚̈��󂯎�
 -[v] �}�N�����
---[x] macroexpand ��-[v] C �������[�o���̊֐���яo�������ɂ���- �unil�v�ut�v���V���{���Ȃ̂ŁA�R���p�C�������V���{���Q�ƂɂȂ�Ă��܂�
+--[v] macroexpand ��-[v] C �������[�o���̊֐���яo�������ɂ���- �unil�v�ut�v���V���{���Ȃ̂ŁA�R���p�C�������V���{���Q�ƂɂȂ�Ă��܂�
 - ��s���ɕϐ�������������Ƃ��̎�����
 - ��������

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

@@ -6 +6 @@
 #include <gc/gc.h>
 #include <setjmp.h>
+
+#define MESSAGE         "To quit, type '(exit)'\n"
+
 
 static jmp_buf s_env;
@@ -29 +32 @@
 
 void repl() {
+        printf("%s", MESSAGE);
         for (;;) {
                 if (setjmp(s_env) == 0) {
@@ -34 +38 @@
                                 printf("> ");
                                 SExp s = read_from_file(stdin);
-                                if (eq(s, intern("quit"))) {
-                                        return;
-                                }
 
                                 SExp r = evaluate(s);