Ajout de la fonction meval. Pour l'instant la fonction meval gerer les variables, les if, les litteraux, les macros predefinie et les fonctions predefinie. Attention la macro 'OR' n'est pas gerer car elle utilise un let qui n'est pas encore implemente

lisp2li.lisp

@@ -1,17 +1,23 @@
-
-;; TODO : reste a gere les variables, les macros predefinies, les defuns.
+;; TODO : reste a gerer les defuns, les let, les lambda expression, les setf, les progn, ...
 (defun lisp2li (expr env)
-  (cond ((and (atom expr) (constantp expr))
+  (cond ((and (atom expr) (constantp expr)) ;;cas des litteraux
          (cons :lit expr))
-        ((eq 'if (car expr))
+        ((atom expr) ;;cas des variables
+         (let ((cell (get-binding env expr)))
+           (if cell
+               (cons :var (car cell))
+             (warn "Variable ~S unknown" (car expr)))))
+        ((eq 'if (car expr)) ;;cas des if
          (list :if
                (lisp2li (second expr) env)
                (lisp2li (third expr) env)
                (lisp2li (fourth expr) env)))
-        ((eq 'quote (car expr))
+        ((eq 'quote (car expr)) ;;cas des quotes
          (cons :lit (second expr)))
-        ((fboundp (car expr))
+        ((and (fboundp (car expr)) (eq (macroexpand-1 expr) expr)) ;;cas des fonctions
          (cons :call (cons (first expr) (map-lisp2li (cdr expr) env))))
+        ((and (fboundp (car expr)) (not (eq (macroexpand-1 expr) expr))) ;;cas des macros
+         (lisp2li (macroexpand-1 expr) env))
         (T (list :unknown expr env))
         ))
 
@@ -58,7 +64,26 @@
 
 (deftest lisp2li
   (lisp2li '(and 1 1) ())
-  '(:call and (:lit . 1) (:lit . 1)))
+  '(:if (:lit . 1) (:call the (:lit . T) (:lit . 1)) (:lit . nil)))
+
+;; test des variables
+(deftest lisp2li
+  (lisp2li 'x '(("TOP-LEVEL" (x . 1) (y . 2))))
+  '(:var . x))
+
+(deftest lisp2li
+  (lisp2li '(if (eq x 3) (- x 3) (+ x 3)) '(("TOP-LEVEL" (x . 3))))
+  '(:if (:call eq (:var . x) (:lit . 3))
+        (:call - (:var . x) (:lit . 3))
+        (:call + (:var . x) (:lit . 3))))
+
+(deftest lisp2li
+  (lisp2li '(if (eq x 3)
+                (- z 3)
+              (- x 5))
+           '(("TEST" (z . 5)) ("TOP-LEVEL" (x . 4))))
+  '(:IF (:CALL EQ (:VAR . X) (:LIT . 3)) (:CALL - (:VAR . Z) (:LIT . 3))
+        (:CALL - (:VAR . X) (:LIT . 5))))
 
 ;; Test avec des expression plus complexe
 (deftest lisp2li
@@ -70,14 +95,13 @@
   '(:IF (:CALL EQ (:LIT . "abc") (:LIT . 1)) (:LIT . "abc") (:LIT . 2)))
 
 (deftest lisp2li
-  (lisp2li '(if (and (eq 1 1) (= 2 2)) (or 1 2) (and 1 2)) ())
-  '(:if (:call and (:call eq (:lit . 1) (:lit . 1))
-               (:call = (:lit . 2) (:lit . 2)))
-        (:call or (:lit . 1) (:lit . 2))
-        (:call and (:lit . 1) (:lit . 2))))
+  (lisp2li '(if (and (eq 1 1) (= 2 2)) (foo 1 2) (bar 3 4)) ())
+  '(:if (:if (:call eq (:lit . 1) (:lit . 1))
+             (:call the (:lit . T) (:call = (:lit . 2) (:lit . 2))) (:lit . nil))
+        (:unknown (foo 1 2) nil) (:unknown (bar 3 4) nil)))
 
 (deftest lisp2li
   (lisp2li '(foo 1 1) ())
   '(:unknown (foo 1 1) ()))
 
-(run-tests t)
+;(run-tests t)

main.lisp

@@ -7,6 +7,7 @@
 (load "environnement")
 (load "instructions")
 (load "lisp2li")
+(load "meval")
 ;; ...
-(run-tests t)
+;(run-tests t)
 ;(print-env-stack exemple-env-stack)

meval.lisp

@@ -1,37 +1,72 @@
-;; meval donnee en cours
-
 (defun meval (expr env)
-  (cond ((and (atom expr) (constantp expr)) expr) ;; Literal
-        ((atom expr) ;; symboles
-         (let ((cell (assoc expr env)))
-           (if cell (cdr cell)
-             (error ""))))
-        ;; .
-        ;; .
-        ;; .
-        ((eq 'quote (car expr)) (cadr expr)) ;;Quote (' ou quote)
-        ((and (consp (car expr)) (eq 'lambda (caar expr)))
-         (meval-lambda (car expr) (cdr expr) env env)) ;; TODO : a remplir
-        ((eq 'defun (car expr))
-         (set-defun (cadr expr) (cons 'lambda (cddr expr))) ;; TODO : sera remplacer par add-top-level-binding
-         (get-defun (car expr))
-         (meval-lambda (get-defun (car expr)) (cdr expr) env ()))
-        ((eq 'if (car expr))
+  (cond ((eq ':lit (first expr))
+         (cdr expr))
+        ((eq ':var (first expr))
+         (let ((cell (get-binding env (cdr expr))))
+           (if cell
+                (cdr cell)
+               (error "The variable ~S is unbound" (cdr expr)))))
+        ((eq ':if (car expr))
          (if (meval (second expr) env)
              (meval (third expr) env)
            (meval (fourth expr) env)))
-        ;;cas des marcros/forme speciale deja traiter
-        ((fboundp (car expr)) ;;denier cas vrais fonctin globale predefinie
-         (apply (car expr) (map-meval (cdr expr) env))
-        )
-  ))
+        ((eq ':call (first expr))
+         (apply (second expr) (map-meval (cddr expr) env)))
+        ))
 
 (defun map-meval (list env)
   (mapcar (lambda (x) (meval x env)) list))
 
-(defun meval-lambda (lbd args env-args old-env)
- (meval (third (car lbd))
-        (make-env (second (car lbd))
-                  (map-meval args env-args)
-                  old-env))
-)
+;; Test unitaire
+(deftest meval
+  (meval '(:lit . 3) ())
+  3)
+
+(deftest meval
+  (meval '(:var . x) '(("TEST" (s . ()) (z . 4) (x . 5) (u . 6))))
+  5)
+
+(deftest meval
+  (meval '(:var . s2) '(("TEST" (s . ()) (s1 . 7) (s2 . 8))
+                       ("TOP-LEVEL" (x . 4) (x1 . 5) (x2 . 6))))
+  8)
+
+(deftest meval
+  (meval '(:call + (:lit . 3) (:var . x)) '(("TOP-LEVEL" (x1 . 4) (x . 5) (z . 6))))
+  8)
+
+
+;; meval donnee en cours
+
+;(defun meval (expr env)
+;  (cond ((and (atom expr) (constantp expr)) expr) ;; Literal
+;        ((atom expr) ;; symboles
+;         (let ((cell (assoc expr env)))
+;           (if cell (cdr cell)
+;             (error ""))))
+        ;; .
+        ;; .
+        ;; .
+;        ((eq 'quote (car expr)) (cadr expr)) ;;Quote (' ou quote)
+;        ((and (consp (car expr)) (eq 'lambda (caar expr)))
+;         (meval-lambda (car expr) (cdr expr) env env)) ;; TODO : a remplir
+;        ((eq 'defun (car expr))
+;         (set-defun (cadr expr) (cons 'lambda (cddr expr))) ;; TODO : sera remplacer par add-top-level-binding
+;         (get-defun (car expr))
+;         (meval-lambda (get-defun (car expr)) (cdr expr) env ()))
+;        ((eq 'if (car expr))
+;         (if (meval (second expr) env)
+;             (meval (third expr) env)
+;           (meval (fourth expr) env)))
+;        ;;cas des marcros/forme speciale deja traiter
+;        ((fboundp (car expr)) ;;denier cas vrais fonctin globale predefinie
+;         (apply (car expr) (map-meval (cdr expr) env))
+;        )
+;  ))
+
+;(defun meval-lambda (lbd args env-args old-env)
+; (meval (third (car lbd))
+;        (make-env (second (car lbd))
+;                  (map-meval args env-args)
+;                  old-env))
+;)