From 989d5b15245cf828f419150ac823f9102017ac32 Mon Sep 17 00:00:00 2001
From: Bertrand BRUN <bertrand.brun@me.com>
Date: Tue, 26 Oct 2010 13:33:31 +0200
Subject: [PATCH] Ajout de la fonction lisp2li et de ces tests unitaire. Manque
 quelques cas a gerer (voir git grep TODO -- lisp2li.lisp)

---
 instructions.lisp  |  3 +-
 lisp2li.lisp       | 83 ++++++++++++++++++++++++++++++++++++++++++++++
 main.lisp          |  3 +-
 test-unitaire.lisp | 18 +++++-----
 4 files changed, 95 insertions(+), 12 deletions(-)
 create mode 100644 lisp2li.lisp

diff --git a/instructions.lisp b/instructions.lisp
index c960702..f838f74 100644
--- a/instructions.lisp
+++ b/instructions.lisp
@@ -156,7 +156,7 @@ et termine par la liste APPEND."
 (defun ISN-JMP (vm dst)
   (set-register vm 'PC (- dst 1)))
 
-(defun JSR (vm dst)
+(defun ISN-JSR (vm dst)
   (ISN-PUSH vm 'PC)
   (ISN-JMP vm dst))
 
@@ -273,5 +273,4 @@ et termine par la liste APPEND."
   42)
 
 
-
 (dump-vm vm)
diff --git a/lisp2li.lisp b/lisp2li.lisp
new file mode 100644
index 0000000..bfefd38
--- /dev/null
+++ b/lisp2li.lisp
@@ -0,0 +1,83 @@
+
+;; TODO : reste a gere les variables, les macros predefinies, les defuns.
+(defun lisp2li (expr env)
+  (cond ((and (atom expr) (constantp expr))
+         (cons :lit expr))
+        ((eq 'if (car expr))
+         (list :if
+               (lisp2li (second expr) env)
+               (lisp2li (third expr) env)
+               (lisp2li (fourth expr) env)))
+        ((eq 'quote (car expr))
+         (cons :lit (second expr)))
+        ((fboundp (car expr))
+         (cons :call (cons (first expr) (map-lisp2li (cdr expr) env))))
+        (T (list :unknown expr env))
+        ))
+
+(defun map-lisp2li (expr env)
+  (mapcar (lambda (x) (lisp2li x env)) expr))
+
+;; Test unitaire
+(load "test-unitaire")
+;(erase-tests)
+;; test des litteraux
+(deftest lisp2li
+  (lisp2li 1 ())
+  '(:lit . 1))
+
+(deftest lisp2li
+  (lisp2li 2.3 ())
+  '(:lit . 2.3))
+
+(deftest lisp2li
+  (lisp2li "abc" ())
+  '(:lit . "abc"))
+
+(deftest lisp2li
+  (lisp2li T ())
+  '(:lit . T))
+
+(deftest lisp2li
+  (lisp2li nil ())
+  '(:lit . nil))
+
+;; test des if
+(deftest lisp2li
+  (lisp2li '(if T T nil) ())
+  '(:if (:lit . T) (:lit . T) (:lit . nil)))
+
+(deftest lisp2li
+  (lisp2li '(if T nil T) ())
+  '(:if (:lit . T) (:lit . nil) (:lit . T)))
+
+;; test des fonctions predefinies
+(deftest lisp2li
+  (lisp2li '(eq 1 1) ())
+  '(:call eq (:lit . 1) (:lit . 1)))
+
+(deftest lisp2li
+  (lisp2li '(and 1 1) ())
+  '(:call and (:lit . 1) (:lit . 1)))
+
+;; Test avec des expression plus complexe
+(deftest lisp2li
+  (lisp2li '(if (eq 1 1) 2 2) ())
+  '(:if (:call eq (:lit . 1) (:lit . 1)) (:lit . 2) (:lit . 2)))
+
+(deftest lisp2li
+  (lisp2li '(if (eq "abc" 1) "abc" 2) ())
+  '(: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))))
+
+(deftest lisp2li
+  (lisp2li '(foo 1 1) ())
+  '(:unknown (foo 1 1) ()))
+
+(run-tests t)
\ No newline at end of file
diff --git a/main.lisp b/main.lisp
index 53aa9a1..193e125 100644
--- a/main.lisp
+++ b/main.lisp
@@ -6,6 +6,7 @@
           (copytree (cdr l)))))
 (load "environnement")
 (load "instructions")
+(load "lisp2li")
 ;; ...
-(run-test t)
+(run-tests t)
 ;(print-env-stack exemple-env-stack)
diff --git a/test-unitaire.lisp b/test-unitaire.lisp
index 0a818e3..b98fb33 100644
--- a/test-unitaire.lisp
+++ b/test-unitaire.lisp
@@ -69,12 +69,12 @@
 (defun erase-tests ()
   (setf all-tests nil))
 
-(deftest moda nil nil)
-(deftest moda (eq 42 42) t)
-(deftest modb (eq 'a 'a) t)
-(deftest modb (eq 'a 'b) nil)
-(deftest modb (eq 'a 'c) t)
-(deftest modb 1 1)
-(deftest modc (+ 1 2) (+ 2 1))
-(deftestvar modc x 1)
-(deftest modc (+ x 2) (+ 2 1))
+;(deftest moda nil nil)
+;(deftest moda (eq 42 42) t)
+;(deftest modb (eq 'a 'a) t)
+;(deftest modb (eq 'a 'b) nil)
+;(deftest modb (eq 'a 'c) t)
+;(deftest modb 1 1)
+;(deftest modc (+ 1 2) (+ 2 1))
+;(deftestvar modc x 1)
+;(deftest modc (+ x 2) (+ 2 1))