Changeset 12180 for lang/c

Timestamp:

05/22/08 08:41:22 (6 months ago)

Author:

mokehehe

Message:

Expand all macro at begining of compilation.
Add 'macroexpand-1'.

Location:

lang/c/misc/mlisp

Files:

• core/c_compiler.cpp (modified) (4 diffs)
• core/c_compiler.h (modified) (1 diff)
• core/inner.h (modified) (1 diff)
• core/m_basic.cpp (modified) (5 diffs)
• core/mlisp.cpp (modified) (1 diff)
• core/s_util.cpp (modified) (1 diff)
• core/s_util.h (modified) (1 diff)
• proto/stackbased.scm (modified) (5 diffs)
• readme.txt (modified) (2 diffs)

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

@@ -310 +310 @@
 }
 
-static SExp quote(SExp s)       { return list(2, intern("quote"), s); }
+static SExp quote(SExp s, void*)        { return list(2, intern("quote"), s); }
 
 static SExp gen_macro_call(Procedure* p, SExp args) {
-        SExp qargs = mapcar(quote, args);
+        SExp qargs = mapcar(quote, args, NULL);
         return cons(p->u.cell.s, qargs);
 }
@@ -323 +323 @@
         } else {
                 return evaluate(gen_macro_call(p, args));
+        }
+}
+
+
+/// �}�N����ēW�J
+static SExp compile_macroexpand_all_compound(int n, SExp x, SExp e);
+static SExp compile_macroexpand_all(SExp x, SExp e) {
+        if (consp(x)) {
+                SExp op = car(x);
+                if (eq(op, intern("quote"))) {
+                        return x;
+                } else if (eq(op, intern("lambda"))) {
+                        SExp vars = cadr(x);
+                        SExp newe = append2(dotted2proper(vars), e);
+                        return compile_macroexpand_all_compound(2, x, newe);
+                } else if (eq(op, intern("if"))) {
+                        return compile_macroexpand_all_compound(1, x, e);
+                } else if (eq(op, intern("set!"))) {
+                        return compile_macroexpand_all_compound(2, x, e);
+                } else if (eq(op, intern("call/cc"))) {
+                        return compile_macroexpand_all_compound(1, x, e);
+                } else if (eq(op, intern("define"))) {
+                        SExp var_body = cdr(x);
+                        for (;;) {
+                                SExp var = car(var_body);
+                                if (consp(var)) {
+                                        SExp body = cdr(var_body);
+                                        var_body = list(2, car(var), cons(intern("lambda"), cons(cdr(var), body)));
+                                } else {
+                                        return compile_macroexpand_all_compound(2, cons(intern("define"), var_body), e);
+                                }
+                        }
+                } else if (eq(op, intern("defmacro"))) {
+                        return x;
+                } else {
+                        SExp fn = car(x);
+                        SExp args = cdr(x);
+                        SExp gval = (symbolp(fn) && exist_global(fn)) ? refer_global(fn) : nil;
+                        if (macrop(gval)) {
+                                return compile_macroexpand_all(transform_macro(gval, args), e);
+                        } else {
+                                return compile_macroexpand_all_compound(0, x, e);
+                        }
+                }
+        } else {
+                return x;
+        }
+}
+
+static SExp compile_macroexpand_all_compound(int n, SExp x, SExp e) {
+        if (n > 0) {
+                return cons(car(x), compile_macroexpand_all_compound(n-1, cdr(x), e));
+        } else {
+                struct Local {
+                        SExp e;
+                        static SExp cb(SExp x, void* param) {
+                                Local* l = (Local*)param;
+                                return compile_macroexpand_all(x, l->e);
+                        }
+                };
+                Local l = { e };
+                return mapcar(Local::cb, x, &l);
         }
 }
@@ -359 +421 @@
 }
 
+// �}�N����i�W�J
+SExp macroexpand_1(SExp x) {
+        SExp fn = car(x);
+        SExp gval = (symbolp(fn) && exist_global(fn)) ? refer_global(fn) : nil;
+        if (macrop(gval)) {
+                SExp args = cdr(x);
+                return transform_macro(gval, args);
+        } else {
+                return x;
+        }
+}
+
 // �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) && exist_global(fn)) ? refer_global(fn) : nil;
-        if (macrop(gval)) {
-                return compile(transform_macro(gval, args), e, s, next);
-        } else {
+        SExp expanded = macroexpand_1(x);
+        if (!eq(expanded, x)) {
+                return compile(expanded, e, s, next);
+        } else {
+                SExp args = cdr(x);
                 int argnum = length(args);
                 SExp apply = list(2, APPLY, int2s(argnum));
@@ -445 +518 @@
         return nil;
 }
+
+
+/// �g�b�v���x���ŃR���p�C��
+SExp compile_ontop(SExp code) {
+        SExp halt_code = cons(HALT, nil);
+        SExp expanded = compile_macroexpand_all(code, nil);
+        return compile(expanded, list(1, nil), nil, halt_code);
+}

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

@@ -15 +15 @@
 
 SExp is_macro(SExp name);
-SExp macroexpand_1(SExp m, SExp x);
 
 #ifdef __cplusplus

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

@@ -111 +111 @@
 sint get_arg_num(void);
 SExp get_arg(int idx);
+
+SExp macroexpand_1(SExp x);

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

@@ -210 +210 @@
 }
 
+static SExp builtin_macroexpand_1() {
+        SExp a = get_arg(0);
+        return macroexpand_1(a);
+}
+
 static SExp builtin_load() {
         SExp a = get_arg(0);
@@ -244 +249 @@
 //=============================================================================
 
-static SExp transform_quasiquote_loop(SExp x) {
+static SExp transform_quasiquote_loop(SExp x, void*) {
         if (!consp(x))
                 return list(2, intern("quote"), list(1, x));
@@ -252 +257 @@
                 return cadr(x);
         else {
-                SExp sub = mapcar(transform_quasiquote_loop, x);
+                SExp sub = mapcar(transform_quasiquote_loop, x, NULL);
                 return list(2, intern("list"), cons(intern("append"), sub));
         }
@@ -258 +263 @@
 
 static SExp builtin_quasiquote(SExp args) {
-        SExp res = transform_quasiquote_loop(car(args));
+        SExp res = transform_quasiquote_loop(car(args), NULL);
         SExp h = car(res);
         if (eq(h, intern("list")))
@@ -321 +326 @@
                 {       "print",        builtin_print,          1,      1,      },
                 {       "eval",         builtin_eval,           1,      1,      },
+                {       "macroexpand-1",        builtin_macroexpand_1,          1,      1,      },
 
                 {       "load",         builtin_load,           1,      1,      },

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

@@ -14 +14 @@
 SExp run(SExp c) {
         return vm(nil, c, 0, nil);
-}
-
-/// �g�b�v���x���ŃR���p�C��
-SExp compile_ontop(SExp code) {
-        SExp halt_code = cons(HALT, nil);
-        return compile(code, list(1, nil), nil, halt_code);
 }
 

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

@@ -63 +63 @@
 }
 
-SExp mapcar(SExp (*fn)(SExp), SExp ls) {
+SExp mapcar(SExp (*fn)(SExp, void*), SExp ls, void* param) {
         SExp acc = nil;
         for (; !nilp(ls); ls = cdr(ls)) {
-                acc = cons(fn(car(ls)), acc);
+                acc = cons(fn(car(ls), param), acc);
         }
         return nreverse(acc);

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

@@ -30 +30 @@
 
 /// ���X�g�̊e�v�f�Ɋ֐���p�i���X�g�͂P�Œ��
-SExp mapcar(SExp (*fn)(SExp), SExp ls);
+SExp mapcar(SExp (*fn)(SExp, void*), SExp ls, void* param);
 
 /// alist ((key . value) ...) ������

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

@@ -62 +62 @@
 ;; マクロ
 
-
 (define (compile-defmacro name vars body)
   (define-global name (gen-macro vars body)))
@@ -89 +88 @@
 
 
+;; マクロの全展開、文法に従って修正する必要あり
+(define (compile-macroexpand-all x e)
+  ; ドット対も処理する map
+  (define (mapd fn ls)
+    (cond ((pair? ls) (cons (fn (car ls)) (mapd fn (cdr ls))))
+          ((null? ls) ls)
+          (else (fn ls))))
+  (define (expand-compound n x e)
+    (cond ((null? x) x)
+          ; 頭の n 個は展開せず、
+          ((> n 0) (cons (car x)
+                         (expand-compound (-1+ n) (cdr x) e)))
+          ; n 個以降は展開
+          (else (mapd (lambda (s) (compile-macroexpand-all s e)) x))))
+  (cond
+   ((pair? x)
+    (case x
+      ((quote) x)
+      ((lambda) (let* ((vars (cadr x))
+                       (newe (append (dotted->proper vars) e)))
+                  (expand-compound 2 x newe)))
+      ((if) (expand-compound 1 x e))
+      ((set!) (expand-compound 2 x e))
+      ((call/cc) (expand-compound 1 x e))
+      ((define) (recur loop ((var-body (cdr x)))
+                       (let ((var (car var-body))
+                             (body (cdr var-body)))
+                         (if (pair? var)
+                             (loop `(,(car var) (lambda ,(cdr var) ,@body)))
+                           (expand-compound 2 `(define ,@var-body) e)))))
+      ((defmacro) x)
+      (else
+       (let* ((fn (car x))
+              (args (cdr x))
+              (gval (and (symbol? fn)
+                         (exist-global? fn)
+                         (refer-global fn))))
+         (if (macro? gval)
+             (compile-macroexpand-all (transform-macro gval args) e)
+           (expand-compound 0 x e))))))
+   (else x)))
+
+
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; compiler
@@ -94 +136 @@
 ;; トップレベルでコンパイル
 (define (compile-top x)
-  (compile x '(()) '() '(HALT)))
+  (compile (compile-macroexpand-all x '())
+           '(())
+           '()
+           '(HALT)))
 
 ;; 複文をコンパイル
@@ -355 +400 @@
 (define VM
   (lambda (a x f c)
-    (write/ss (list (car x) (dump-stack *sp*)))
-    (newline)
+;    (write/ss (list (car x) (dump-stack *sp*)))
+;    (newline)
     (record-case x
                  (HALT () a)
@@ -609 +654 @@
 
 
+
+
+
+
+
 (define (dump-stack s)
   (subseq *stack* 0 s))

lang/c/misc/mlisp/readme.txt

@@ -7 +7 @@
 
 * �m�[�g
-- repl ����quit�v�Ƒł����ނƔ�����- �V���{���̑啶���Ə�������ʂ���
+- repl ����(exit)�v�Ƒł����ނƔ�����- �V���{���̑啶���Ə�������ʂ���
 - ������
 -- ����
@@ -52 +52 @@
 - ��s���ɕϐ�������������Ƃ��̎�����
 - ��������
-- �}�N�����g�����Ƃ��́A���R�ϐ���t!�̎g�p�̃`�F�b�N
+-[v] �}�N�����g�����Ƃ��́A���R�ϐ���t!�̎g�p�̃`�F�b�N