www

commit 5416bb34d8e7cbbe6a45483e0540e747dffc19ec
parent cb07628ee8fb85745c46bfa793c824eeccbb425a
Author: Bertrand BRUN <bertrand.brun@me.com>
Date:   Fri, 12 Nov 2010 23:38:36 +0100

Ajout du cas du defmacro (pas encore fini)

Diffstat:
M
lisp2li.lisp
 | 
10
+++++++++-
M
meval.lisp
 | 
17
++++++++++++-----

2 files changed, 21 insertions(+), 6 deletions(-)
diff --git a/lisp2li.lisp b/lisp2li.lisp
@@ -160,7 +160,11 @@ par le compilateur et par l’interpréteur"
    ;; fonction meta-definie
    ((get (car expr) :defun)
     `(:mcall ,(car expr)
-          ,@(mapcar (lambda (x) (lisp2li x env)) (cdr expr))))
+             ,@(mapcar (lambda (x) (lisp2li x env)) (cdr expr))))
+   ;; macro meta-definie
+   ((get (car expr) :defmacro)
+    `(:mcall ,(car expr)
+             ,@(mapcar (lambda (x) (lisp2li x env)) (cdr expr))))
    ;; fonction inconnue
    ((and (not (fboundp (car expr)))
          (not (get (car expr) :defun)))
@@ -204,6 +208,10 @@ par le compilateur et par l’interpréteur"
    ((eq 'defun (car expr))
     `(:mcall set-defun (:const . ,(second expr))
                 ,(lisp2li `(lambda ,(third expr) ,@(cdddr expr)) env)))
+   ;; defmacro
+   ((eq 'defmacro (car expr))
+    `(:mcall set-defmacro (:const . ,(second expr))
+             ,(lisp2li `(lambda ,(third expr) ,@(cdddr expr)) env)))
    ;; apply
    ((eq 'apply (car expr))
     `(:sapply ,(second expr) ,@(cddr expr)))
diff --git a/meval.lisp b/meval.lisp
@@ -85,9 +85,6 @@ retourne la liste de leurs valeurs"
 (defun meval-lambda (lclosure args env)
   "Applique une λ-fonction quelconque à des valeurs
 d’arguments dans un certain environnement."
-  (print "meval-lambda")
-  (print env)
-  (print args)
   (match (:nil :lclosure :size (? integerp) :rest (? integerp)? :body _*) lclosure
          (meval lclosure
                 (make-env size args env rest))))
@@ -111,7 +108,6 @@ d’arguments dans un certain environnement."
 
 (defun meval (expr &optional (env #()))
   "Interprète le langage intermédiaire passé en paramètre."
-  (print expr)
   (cond-match expr
               ((:nil :const :val . _) expr val)
               ((:nil :cvar :num-env (? integerp) :index (? integerp))
@@ -129,13 +125,24 @@ d’arguments dans un certain environnement."
                (let ((name (meval func-name env)))
                  (setf (get name :defun) closure)
                  name))
-              ((:nil :mcall :func-name $ :params _*)
+              ((:nil :mcall set-defmacro :macro-name @. :closure _*)
+               (let ((name (meval macro-name env)))
+                 (setf (get name :defmacro) closure)
+                 name))
+              ((:nil :mcall :func-name (? (get x :defun)) :params _*)
                (let ((values (meval-args params env)))
                  (meval-lambda (car (get func-name :defun))
                                values
                                (make-env (length values)
                                        values
                                        env))))
+              ((:nil :mcall :macro-name (? (get x :defmacro)) :params _*)
+               (let ((values (meval-args params env)))
+                 (meval (lisp2li (meval-lambda (car (get macro-name :defmacro))
+                               params
+                               (make-env (length values)
+                                         values
+                                         env)) env) env)))
               ((:nil :mcall :lambda (:nil :lclosure (? integerp) (? integerp)? _*) :args _*)
                (meval-lambda lambda (meval-args args env) env))
               ((:nil :call :func-name _ :body _*)