suzanne.soy/2010-m1s1-compilation
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Ajout de 2 environnements pour la fonction lisp2li, env-var (pour les variables) et env-fun (pour les fonctions)

Browse Source
This commit is contained in:
Bertrand BRUN 2010-11-02 18:03:42 +01:00
parent ac8f7a1953
commit 0885bc5a6e
2 changed files with 100 additions and 80 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

19
environnement.lisp
View File

@ -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))

161
lisp2li.lisp
View File

@ -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)