Ajout du cas du :set-var + utilisation du cond-match dans meval

lisp2li.lisp

@@ -140,7 +140,8 @@ par le compilateur et par l’interpréteur"
    ((eq 'setf (car expr))
     (if (symbolp (cadr expr))
         (let ((cell (assoc (cadr expr) env)))
-          `(:set-var (,(second cell) ,(third cell)) ,(third expr)))
+          `(:set-var (,(second cell) ,(third cell))
+                     ,(lisp2li (third expr) env)))
       `(:set-fun ,(caadr expr) ,@(last expr) ,@(cdadr expr))))
    ;; progn
    ((eq 'progn (car expr))

meval.lisp

@@ -100,35 +100,43 @@ d’arguments dans un certain environnement."
          (meval lclosure
                 (make-env size args env rest))))
 
+(defun msetf (place val env)
+  (let ((sub-env (get-env-num (first place) env)))
+    (if sub-env
+        (setf (aref sub-env (second place))
+              (meval val env)))))
+
+(defun make-closure (lmbd env)
+  `(,lmbd . ,env))
+
+(defun meval-closure (clos args)
+  (meval-lambda (cadr clos) args (cddr clos)))
+
 (defun meval (expr &optional (env #()))
   "Interprète le langage intermédiaire passé en paramètre."
-  (cond ((eq ':const (first expr))
+  (cond-match expr
-         (match (:nil :const :val . _) expr val))
+              ((:nil :const :val . _) expr val)
-        ((eq ':cvar (first expr))
+              ((:nil :cvar :num-env (? integerp) :index (? integerp))
-         (match (:nil :cvar :num-env (? integerp) :index (? integerp)) expr
                 (let ((sub-env (get-env-num num-env env)))
                 (if sub-env
                     (aref sub-env index)
-                  (error "The variable unbound" expr)))))
+                  (error "The variable unbound" expr))))
-        ((eq ':if (first expr))
+              ((:nil :if :predicat @. :expr1 @. :expr2 @.)
-         (match (:nil :if :predicat @. :expr1 @. :expr2 @.) expr
                 (if (meval predicat env)
                     (meval expr1 env)
-                  (meval expr2 env))))
+                  (meval expr2 env)))
-        ((eq ':call (first expr))
+              ((:nil :call :func-name _ :body _*)
-         (match (:nil :call :func-name _ :body _*) expr
+               (apply (symbol-function func-name) (map-meval body env)))
-                (apply (symbol-function func-name) (map-meval body env))))
+              ((:nil :mcall :lambda (:nil :lclosure (? integerp) (? integerp)? _*) :args _*)
-        ((eq ':mcall (first expr))
+               (meval-lambda lambda (meval-args args env) env))
-         (match (:nil :mcall :lambda (:nil :lclosure (? integerp) (? integerp)? _*) :args _*) expr
+              (match (:nil :progn :body @.+)
-                (meval-lambda lambda (meval-args args env) env)))
+                     (meval-body body env))
-        ((eq ':progn (first expr))
+              ((:nil :lclosure (? integerp) (? integerp)? :body _*)
-         (match (:nil :progn :body @.+) expr
+                (meval-body `(,body) env))
-                (meval-body body env)))
+              ((:nil :set-var :place @. :value _)
-        ((eq ':lclosure (first expr))
+               (msetf place value env))
-         (match (:nil :lclosure (? integerp) (? integerp)? :body _*) expr
+              (_*
-                (meval-body `(,body) env)))
+               (error "form special ~S not yet implemented" expr))))
-        (T
-         (error "form special ~S not yet implemented" (car expr)))))
 
         
 ;; Test unitaire
@@ -244,3 +252,10 @@ d’arguments dans un certain environnement."
 (deftest (meval :mcall :lclosure)
   (meval (lisp2li '((lambda (x &rest y) (cons x y)) 1 2 3 4) ()))
   '(1 2 3 4))
+
+(deftestvar (meval :set-var) env #(() 2))
+(deftest (meval :set-var)
+  (progn
+    (meval (lisp2li '(setf x 42) ()) env)
+    env)
+  #(() 42))

util.lisp

@@ -108,7 +108,6 @@
 ;; compte dans les tests unitaires etc.
 (defun copy-all (data)
   "Copie récursivement un arbre de listes et de tableaux."
-  (print data)
   (cond 
     ((consp data)
      (cons (copy-all (car data))