commit 77b3ec876cce0e742484556699cf64ad0e359dc6
parent 0da234492a7cc0c11add5314f76adc63605a0374
Author: SliTaz User <tux@slitaz.(none)>
Date: Thu, 28 Oct 2010 19:40:42 +0200
Merge branch 'master' of github.com:dumbs/2010-m1s1-compilation
Conflicts:
main.lisp
Diffstat:
5 files changed, 210 insertions(+), 42 deletions(-)
diff --git 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))
@@ -268,5 +268,3 @@ et termine par la liste APPEND."
(get-memory vm (get-register vm 'SP)))
(t-r1-value))
-
-(dump-vm vm)
diff --git a/lisp2li.lisp b/lisp2li.lisp
@@ -0,0 +1,131 @@
+;; 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)) ; literaux
+ (cons :lit expr))
+ ((symbolp expr) ; symboles
+ (let ((cell (get-binding env expr)))
+ (if cell
+ (cons :var (car cell))
+ (warn "Variable ~S unknown" (car expr)))))
+ ((and (consp (car expr)) ; λ-expressions
+ ; => recursion sur arguments
+ ; => construction environnement
+ ; => recursion sur corps de la λ-fonction
+ (eq 'lambda (caar expr)))
+ (error "Lambda expression NYI"))
+ ((not (symbolp (car expr)))
+ (warn "~S isn't a symbol" (car expr)))
+ ((not (fboundp (car expr)))
+ (list :unknown expr env))
+ ((eq 'if (car expr)) ; if
+ (list :if
+ (lisp2li (second expr) env)
+ (lisp2li (third expr) env)
+ (lisp2li (fourth expr) env)))
+ ((eq 'quote (car expr)) ;; quotes
+ (cons :lit (second expr)))
+ ((eq 'defun (car expr)) ;; TODO : a verifier que le cas de defun est bien gerer comme on le veux
+ (cons :call (cons 'add-binding (list (list :call 'push-new-env `(:lit . ,env) '(:lit . "DEFUN"))
+ (cons :lit (second expr))
+ (cons :lit (cons (length (third expr))
+ (lisp2li (fourth expr)
+ (make-stat-env env (third expr)))))))))
+ ((eq 'setq (car expr))
+ (cons :call (cons 'set-binding (list `(:lit . ,env)
+ (cons :lit (second expr))
+ (cons :lit (third expr))))))
+ ((macro-function (car expr))
+ (lisp2li (macroexpand-1 expr) env)) ; macros
+ ((not (special-operator-p (car expr))) ; fonctions normales. (Attention) sur sbcl special-form-p ne marche pas il faut utiliser special-operator-p
+ ; => recursion sur tous les arguments
+ ; => eventuellement construction d'environnement
+ ; => et analyse du corps de la fonction appelee
+ (cons :call (cons (first expr) (map-lisp2li (cdr expr) env))))
+ (T
+ (error "special forme NYI ~S" (car expr)))
+ ))
+
+(defun map-lisp2li (expr env)
+ (mapcar (lambda (x) (lisp2li x env)) expr))
+
+(defun make-stat-env (env params) ;; TODO : Verifier si on ne doit pas plutot chercher s'il existe pas deja un environnement avec la valeur et le mettre plutot que nil.
+ (mapcar (lambda (x) (add-binding env x nil)) params)
+ env)
+
+;; Test unitaire
+(load "test-unitaire")
+;(erase-tests)
+
+(deftest lisp2li
+ (lisp2li '3 ())
+ '(:lit . 3))
+
+(deftest lisp2li
+ (lisp2li ''x ())
+ '(:lit . x))
+
+(deftest lisp2li
+ (lisp2li ''(1 2 3) ())
+ '(:lit 1 2 3))
+
+;; 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) ())
+ '(:lit . 1))
+
+;; 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
+ (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 '(foo 1 1) ())
+ '(:unknown (foo 1 1) ()))
+
+(deftest lisp2li
+ (lisp2li '(if (and (eq 1 1) (= 2 2)) (foo 1 2) (bar 3 4)) ())
+ '(:IF (:CALL = (:LIT . 2) (:LIT . 2)) (:UNKNOWN (FOO 1 2) NIL) (:UNKNOWN (BAR 3 4) NIL)))
+
+;; Test sur le setq
+(deftestvar lisp2li env (add-binding (empty-env-stack) 'x 1))
+(deftest lisp2li
+ (lisp2li '(setq x 2) env)
+ '(:call set-binding (:lit (("TOP-LEVEL" (x . 1)))) (:lit . x) (:lit . 2)))
+
+;(run-tests t)
+\ No newline at end of file
diff --git a/main.lisp b/main.lisp
@@ -1,5 +1,8 @@
(load "environnement")
(load "instructions")
+(load "lisp2li")
+(load "meval")
;; ...
(run-tests)
+;(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
diff --git a/test-unitaire.lisp b/test-unitaire.lisp
@@ -70,12 +70,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))
