commit 35b54fe1da4aa7de7aa190f72dab8c37433a7c31
parent 8642e2cf466644a32340423713a83d6c594892e0
Author: Bertrand BRUN <bertrand.brun@me.com>
Date: Sat, 6 Nov 2010 01:28:34 +0100
Commencement de la fonction meval. Pour l'instant elle n'evalue que les contantes :D
Diffstat:
3 files changed, 64 insertions(+), 26 deletions(-)
diff --git a/lisp2li.lisp b/lisp2li.lisp
@@ -89,7 +89,7 @@ par le compilateur et par l’interpréteur"
((eq 'lambda (car expr)) ;; TODO : ameliorer le cas du lambda
(if (member '&rest (second expr))
`(:lclosure . (,(get-nb-params (second expr))
- ,(+ 1 (position '&rest (second expr)))
+ ,(+ 1 (mposition '&rest (second expr)))
,(lisp2li (caddr expr)
(make-stat-env (second expr)))))
`(:lclosure . ,(cons (get-nb-params (second expr))
@@ -204,8 +204,8 @@ par le compilateur et par l’interpréteur"
'(:if (:const . T) (:const . T) (:const . nil)))
(deftest (lisp2li defun)
- (lisp2li '(defun foo (x) x) ())
- '(:mcall set-defun (:const . foo) (:lclosure 1 :cvar 0 1)))
+ (lisp2li '(defun bar (x) x) ())
+ '(:mcall set-defun (:const . bar) (:lclosure 1 :cvar 0 1)))
(deftest (lisp2li defun)
(lisp2li '(defun foo (x y z) (list x y z)) ())
diff --git a/meval.lisp b/meval.lisp
@@ -1,39 +1,65 @@
-(defun meval (expr env)
+(load "match")
+(defun meval (expr &optional env)
"Interprète le langage intermédiaire passé en paramètre."
- (cond ((eq ':lit (first expr))
+ (cond ((match :const (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)))
- ((eq ':call (first expr))
- (apply (second expr) (map-meval (cddr expr) env)))
- ))
+ ((match :cvar (first expr))
+ )
+ ((match :lclosure (first expr))
+ )
+ (T
+ (error "form special ~S not yet implemented" expr))))
+
+;; (cond ((eq ':const (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)))
+;; ((eq ':call (first expr))
+;; (apply (second expr) (map-meval (cddr expr) env)))
+;; ))
(defun map-meval (list env)
(mapcar (lambda (x) (meval x env)) list))
;; Test unitaire
(load "test-unitaire")
+(load "lisp2li")
(erase-tests meval)
-(deftest meval
- (meval '(:lit . 3) ())
+(deftest (meval :const)
+ (meval (lisp2li 3 ()))
+ 3)
+
+(deftest (meval quote)
+ (meval (lisp2li '3 ()))
3)
-(deftest meval
- (meval '(:var . x) '(("TEST" (s . ()) (z . 4) (x . 5) (u . 6))))
+(deftest (meval quote)
+ (meval (lisp2li ''3 ()))
+ 3)
+
+(deftest (meval quote)
+ (meval (lisp2li '''3 ()))
+ '3)
+
+(deftest (meval :cvar)
+ (meval (lisp2li 'x '((x 0 2))) #(() 4 5 6))
5)
-(deftest meval
- (meval '(:var . s2) '(("TEST" (s . ()) (s1 . 7) (s2 . 8))
- ("TOP-LEVEL" (x . 4) (x1 . 5) (x2 . 6))))
+(deftest (meval :cvar)
+ (meval '(:cvar 1 2) #(#(() 7 8) 4 5 6))
8)
-(deftest meval
- (meval '(:call + (:lit . 3) (:var . x)) '(("TOP-LEVEL" (x1 . 4) (x . 5) (z . 6))))
+(deftest (meval :call)
+ (meval '(:call + (:const . 3) (:cvar 0 1)) #(() 4 5 6))
8)
+
+(deftest (meval defun)
+ (meval '(defun foo (x) x))
+ foo)
+\ No newline at end of file
diff --git a/util.lisp b/util.lisp
@@ -84,3 +84,13 @@
(setf (get-defmacro (cdaddr li))
(cdddr li)))
+(defun mposition (symb list)
+ (defun mposition-t (symb list counter)
+ (cond ((endp list) nil)
+ ((eq symb (car list)) counter)
+ ((or (eq (car list) '&optional)
+ (eq (car list) '&rest))
+ (mposition-t symb (cdr list) counter))
+ (T
+ (mposition-t symb (cdr list) (+ 1 counter)))))
+ (mposition-t symb list 0))
+\ No newline at end of file
