commit 0885bc5a6e7af734b78e6c5bfa1718d479119e0b
parent ac8f7a19538ef4284a9ae73daeca9a61e496295c
Author: Bertrand BRUN <bertrand.brun@me.com>
Date: Tue, 2 Nov 2010 18:03:42 +0100
Ajout de 2 environnements pour la fonction lisp2li, env-var (pour les variables) et env-fun (pour les fonctions)
Diffstat:
2 files changed, 100 insertions(+), 80 deletions(-)
diff --git a/environnement.lisp b/environnement.lisp
@@ -42,7 +42,7 @@
(defun empty-env-stack ()
"Constructeur de la pile d'environnements."
- (list (list "TOP-LEVEL")))
+ (list (list (copy-seq "TOP-LEVEL"))))
(defun push-new-env (env-stack name)
"Crée un nouvel environnement, l'ajoute à ENV-STACK et renvoie la
@@ -82,6 +82,11 @@ l'environnement top-level"
env-stack
(top-level-env-stack (cdr env-stack))))
+(defun get-top-level-binding (env-stack name)
+ "Récupère la liaison au top-level correspondant à NAME ."
+ (get-binding (top-level-env-stack env-stack) name))
+
+
(defun add-top-level-binding (env-stack name value)
"Ajoute une liaison \"globale\" à l'environnement top-level."
(add-binding (top-level-env-stack env-stack) name value)
@@ -102,18 +107,10 @@ l'environnement top-level."
(cdar env-stack))
(print-env-stack (cdr env-stack))))))
-;(defun print-env-stack (env-stack)
-; (if (atom env-stack)
-; nil
-; (progn (format t "~&~a: " (caar env-stack))
-; (mapcar (lambda (b) (format t "~& ~w = ~w" (car b) (cdr b)))
-; (cdar env-stack))
-; (print-env-stack (cdr env-stack)))))
-
;;Test Unitaire
(deftest environnement
- (push-new-env (empty-env-stack) "TEST")
- '(("TEST") ("TOP-LEVEL")))
+ (push-new-env (env-var (empty-env-stack)) "TEST")
+ '(("TEST") "TOP-LEVEL"))
(deftest environnement
(push-new-env exemple-env-stack "TEST")
(cons '("TEST") exemple-env-stack))
diff --git a/lisp2li.lisp b/lisp2li.lisp
@@ -1,79 +1,92 @@
(load "environnement")
-(erase-tests)
-(defun lisp2li (expr env)
+(erase-tests lisp2li)
+(defun lisp2li (expr env-var env-fun)
"Convertit le code LISP en un code intermédiaire reconnu
par le compilateur et par l’interpréteur"
- (cond ((null env) (lisp2li expr (empty-env-stack)))
- ((and (atom expr) (constantp expr)) ; literaux
+ (cond ((null env-var) (lisp2li expr (empty-env-stack) env-fun))
+ ((null env-fun) (lisp2li expr env-var (empty-env-stack)))
+ ;; literaux
+ ((and (atom expr) (constantp expr))
(cons :lit expr))
- ((symbolp expr) ; symboles
- (let ((cell (get-binding env expr)))
+ ;; symboles
+ ((symbolp expr)
+ (let ((cell (get-binding env-var expr)))
(if cell
(cons :var (car cell))
(error "Variable ~S unknown" expr))))
- ((eq 'lambda (car expr)) ; lambda solitaire ex: (lambda (x) x)
- (let ((env-bis (make-stat-env (push-new-env env "LAMBDA") (second expr))))
- `(:lclosure ,env-bis
+ ;; lambda solitaire ex: (lambda (x) x)
+ ((eq 'lambda (car expr))
+ (let ((env-bis (make-stat-env (push-new-env env-var "LAMBDA") (second expr))))
+ `(:lclosure (,env-bis . ,env-fun)
,(lisp2li (third expr)
- env-bis))))
+ env-bis env-fun))))
+ ;; lambda ex: ((lambda (x) x) 1)
((and (consp (car expr))
- (eq 'lambda (caar expr))) ;lambda ex: ((lambda (x) x) 1)
- `(:call ,(lisp2li (car expr) env)
+ (eq 'lambda (caar expr)))
+ `(:call ,(lisp2li (car expr) env-var env-fun)
,@(mapcar (lambda (param)
- (lisp2li param env))
+ (lisp2li param env-var env-fun))
(cdr expr))))
+ ;; (not-symbol ...)
((not (symbolp (car expr)))
(warn "~S isn't a symbol" (car expr)))
- ((and (not (fboundp (car expr))) (not (get-binding env (car expr))))
- (list :unknown expr env))
- ((eq 'if (car expr)) ; if
+ ;; fonction inconnue
+ ((and (not (fboundp (car expr))) (not (get-binding env-fun (car expr))))
+ `(:unknown ,expr (,env-var . ,env-fun)))
+ ;; if
+ ((eq 'if (car expr))
(list :if
- (lisp2li (second expr) env)
- (lisp2li (third expr) env)
- (lisp2li (fourth expr) env)))
- ((eq 'quote (car expr)) ;; quotes
+ (lisp2li (second expr) env-var env-fun)
+ (lisp2li (third expr) env-var env-fun)
+ (lisp2li (fourth expr) env-var env-fun)))
+ ;; quotes
+ ((eq 'quote (car expr))
(cons :lit (second expr)))
- ((eq 'defun (car expr)) ;; TODO : a verifier que le cas de defun est bien gerer comme on le veux
- (let ((env-bis (make-stat-env (push-new-env env "DEFUN") (third expr))))
- (add-top-level-binding env
+ ;; defun
+ ((eq 'defun (car expr))
+ (let ((env-bis (make-stat-env (push-new-env env-var "DEFUN") (third expr))))
+ (add-top-level-binding env-fun
(second expr)
- (cons :lclosure (cons env-bis
+ (cons :lclosure (cons (cons env-bis env-fun)
(map-lisp2li (cdddr expr)
- env-bis)))))
+ env-bis env-fun)))))
(cons :lit (second expr)))
+ ;; setq/setf
((eq 'setq (car expr))
- (cons :call (cons 'set-binding (list `(:lit . ,env)
+ (cons :call (cons 'set-binding (list `(:lit . ,env-var)
(cons :lit (second expr))
(cons :lit (third expr))))))
- ((eq 'let (car expr)) ; LET
- ; Premiere Version
- ; (push-new-env env "LET")
- ; (map-lisp2li-let expr env))
+ ;; let
+ ((eq 'let (car expr))
(let ((bindings (cadr expr))
(body (cddr expr)))
(lisp2li `((lambda ,(mapcar #'car bindings)
,@body)
- ,@(mapcar #'cadr bindings)) env)))
- ((eq 'let* (car expr)) ; LET*
+ ,@(mapcar #'cadr bindings)) env-var env-fun)))
+ ;; let*
+ ((eq 'let* (car expr))
(let ((bindings (cadr expr))
(body (caddr expr)))
(lisp2li (if (endp bindings)
body
`(let (,(car bindings))
(let* ,(cdr bindings)
- ,body))) env)))
- ((eq 'progn (car expr)) ; PROGN
- (cons :progn (map-lisp2li (cdr expr) env)))
+ ,body))) env-var env-fun)))
+ ;; progn
+ ((eq 'progn (car expr))
+ (cons :progn (map-lisp2li (cdr expr) env-var env-fun)))
+ ;; macros
((macro-function (car expr))
- (lisp2li (macroexpand-1 expr) env)) ; macros
- ((not (special-operator-p (car expr))) ; fonctions normales.
- (cons :call (cons (first expr) (map-lisp2li (cdr expr) env))))
+ (lisp2li (macroexpand-1 expr) env-var env-fun))
+ ;; fonctions normales
+ ((not (special-operator-p (car expr)))
+ (cons :call (cons (first expr) (map-lisp2li (cdr expr) env-var env-fun))))
(T
(error "special form not yet implemented ~S" (car expr)))
))
-(defun map-lisp2li (expr env)
- (mapcar (lambda (x) (lisp2li x env)) expr))
+(defun map-lisp2li (expr env-var env-fun)
+ (mapcar (lambda (x) (lisp2li x env-var env-fun)) expr))
(defun map-lisp2li-let (expr env)
(mapcar (lambda (x) (add-binding env (car x) (lisp2li (cadr x) env))) (cadr expr)))
@@ -87,42 +100,42 @@ par le compilateur et par l’interpréteur"
(erase-tests lisp2li)
(deftest lisp2li
- (lisp2li '3 ())
+ (lisp2li '3 () ())
'(:lit . 3))
(deftest lisp2li
- (lisp2li ''x ())
+ (lisp2li ''x () ())
'(:lit . x))
(deftest lisp2li
- (lisp2li ''(1 2 3) ())
+ (lisp2li ''(1 2 3) () ())
'(:lit 1 2 3))
;; test des if
(deftest lisp2li
- (lisp2li '(if T T nil) ())
+ (lisp2li '(if T T nil) () ())
'(:if (:lit . T) (:lit . T) (:lit . nil)))
(deftest lisp2li
- (lisp2li '(if T nil T) ())
+ (lisp2li '(if T nil T) () ())
'(:if (:lit . T) (:lit . nil) (:lit . T)))
;; test des fonctions predefinies
(deftest lisp2li
- (lisp2li '(eq 1 1) ())
+ (lisp2li '(eq 1 1) () ())
'(:call eq (:lit . 1) (:lit . 1)))
(deftest lisp2li
- (lisp2li '(and 1 1) ())
+ (lisp2li '(and 1 1) () ())
'(:lit . 1))
;; test des variables
(deftest lisp2li
- (lisp2li 'x '(("TOP-LEVEL" (x . 1) (y . 2))))
+ (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))))
+ (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))))
@@ -131,68 +144,78 @@ par le compilateur et par l’interpréteur"
(lisp2li '(if (eq x 3)
(- z 3)
(- x 5))
- '(("TEST" (z . 5)) ("TOP-LEVEL" (x . 4))))
+ '(("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) ())
+ (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) ())
+ (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) (("TOP-LEVEL"))))
+ (lisp2li '(foo 1 1) () ())
+ '(:unknown (foo 1 1) ((("TOP-LEVEL")) ("TOP-LEVEL"))))
(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) (("TOP-LEVEL"))) (:UNKNOWN (BAR 3 4) (("TOP-LEVEL")))))
+ (lisp2li '(if (and (eq 1 1) (= 2 2)) (foo 1 2) (bar 3 4)) () ())
+ '(:IF (:CALL = (:LIT . 2)
+ (:LIT . 2))
+ (:UNKNOWN (FOO 1 2) ((("TOP-LEVEL")) ("TOP-LEVEL")))
+ (:UNKNOWN (BAR 3 4) ((("TOP-LEVEL")) ("TOP-LEVEL")))))
;; Test sur le setq
(deftestvar lisp2li env (add-binding (empty-env-stack) 'x 1))
(deftest lisp2li
- (lisp2li '(setq x 2) env)
+ (lisp2li '(setq x 2) env ())
'(:call set-binding (:lit . (("TOP-LEVEL" (x . 1)))) (:lit . x) (:lit . 2)))
;; Test sur le defun
(deftest lisp2li
- (lisp2li '(defun fact (n r) (if (= n 0) r (fact (- n 1) (* n r)))) ())
+ (lisp2li '(defun fact (n r)
+ (if (= n 0)
+ r
+ (fact (- n 1) (* n r))))
+ () ())
'(:lit . fact))
;; Test sur la lambda expression
(deftest lisp2li
- (lisp2li '(mapcar (lambda (x) x) '(1 2 3)) ())
- '(:call mapcar (:lclosure (("LAMBDA" (X)) ("TOP-LEVEL"))
+ (lisp2li '(mapcar (lambda (x) x) '(1 2 3))
+ () ())
+ '(:call mapcar (:lclosure ((("LAMBDA" (X)) ("TOP-LEVEL")) ("TOP-LEVEL"))
(:var . x)) (:lit 1 2 3)))
(deftest lisp2li
- (lisp2li '((lambda (x y z) (list x y z)) 1 2 3) ())
- '(:call (:lclosure (("LAMBDA" (Z) (Y) (X)) ("TOP-LEVEL"))
+ (lisp2li '((lambda (x y z) (list x y z)) 1 2 3) () ())
+ '(:call (:lclosure ((("LAMBDA" (Z) (Y) (X)) ("TOP-LEVEL")) ("TOP-LEVEL"))
(:call list (:var . x) (:var . y) (:var . z)))
(:lit . 1) (:lit . 2) (:lit . 3)))
;; Test sur le LET
(deftest lisp2li
- (lisp2li '(let ((x 1) (y 2)) (list x y)) ())
- '(:call (:lclosure (("LAMBDA" (Y) (X)) ("TOP-LEVEL"))
+ (lisp2li '(let ((x 1) (y 2)) (list x y)) () ())
+ '(:call (:lclosure ((("LAMBDA" (Y) (X)) ("TOP-LEVEL")) ("TOP-LEVEL"))
(:call list (:var . x) (:var . y)))
(:lit . 1) (:lit . 2)))
(deftest lisp2li
- (lisp2li '(let ((x 1) (y (+ x 2))) (list x y)) '(("TOP-LEVEL" (x . 1))))
- '(:call (:lclosure (("LAMBDA" (Y) (X)) ("TOP-LEVEL" (x . 1)))
+ (lisp2li '(let ((x 1) (y (+ x 2))) (list x y)) '(("TOP-LEVEL" (x . 1))) ())
+ '(:call (:lclosure ((("LAMBDA" (Y) (X)) ("TOP-LEVEL" (x . 1))) ("TOP-LEVEL"))
(:call list (:var . x) (:var . y)))
(:lit . 1) (:call + (:var . x) (:lit . 2))))
;; Test sur le LET*
(deftest lisp2li
- (lisp2li '(let* ((x 1) (y (+ x 2))) (list x y)) ())
- '(:CALL (:LCLOSURE (("LAMBDA" (X)) ("TOP-LEVEL"))
- (:CALL (:LCLOSURE (("LAMBDA" (Y)) ("LAMBDA" (X)) ("TOP-LEVEL")) (:CALL LIST (:VAR . X) (:VAR . Y))) (:CALL + (:VAR . X) (:LIT . 2))))
+ (lisp2li '(let* ((x 1) (y (+ x 2))) (list x y)) () ())
+ '(:CALL (:LCLOSURE ((("LAMBDA" (X)) ("TOP-LEVEL")) ("TOP-LEVEL"))
+ (:CALL (:LCLOSURE ((("LAMBDA" (Y)) ("LAMBDA" (X)) ("TOP-LEVEL")) ("TOP-LEVEL"))
+ (:CALL LIST (:VAR . X) (:VAR . Y)))
+ (:CALL + (:VAR . X) (:LIT . 2))))
(:LIT . 1)))
;(run-tests t)
\ No newline at end of file
