commit 6d3071d9e8ee1f0035fa15130e17846b8dca2483
parent 989d5b15245cf828f419150ac823f9102017ac32
Author: Bertrand BRUN <bertrand.brun@me.com>
Date: Tue, 26 Oct 2010 17:24:15 +0200
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
Diffstat:
| M | lisp2li.lisp | | | 52 | ++++++++++++++++++++++++++++++++++++++-------------- |
| M | main.lisp | | | 3 | ++- |
| M | meval.lisp | | | 95 | ++++++++++++++++++++++++++++++++++++++++++++++++++++++------------------------- |
3 files changed, 105 insertions(+), 45 deletions(-)
diff --git a/lisp2li.lisp b/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)
-\ No newline at end of file
+;(run-tests t)
+\ No newline at end of file
diff --git a/main.lisp b/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)
diff --git a/meval.lisp b/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))
-)
-\ No newline at end of file
+;; 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))
+;)
+\ No newline at end of file
