commit 5747936c8f2161ef6627c5940898a5b0582065f6
parent 27eb8532d6e1f58b8b730ddac5436f30b17a6217
Author: Bertrand BRUN <bertrand.brun@me.com>
Date: Fri, 5 Nov 2010 18:15:22 +0100
Recodage de la fonction lisp2li, car le langage intermediaire genere par la fonction ne correspondait pas au attente du prof
Diffstat:
2 files changed, 144 insertions(+), 264 deletions(-)
diff --git a/lisp2li.lisp b/lisp2li.lisp
@@ -1,24 +1,25 @@
-(load "environnement")
-(erase-tests lisp2li)
-
+(load "util.lisp")
;; `
-(defvar my-quasiquote (car '`(,foo)))
+(defvar my-quasiquote (car '`(,a)))
;; ,
-(defvar my-unquote (caaadr '`(,foo)))
+(defvar my-unquote (caaadr '`(,a)))
;; ,@
-(defvar my-unquote-unsplice (caaadr '`(,@foo)))
+(defvar my-unquote-unsplice (caaadr '`(,@a)))
-(defun map-lisp2li (expr env-var env-fun)
- (mapcar (lambda (x) (lisp2li x env-var env-fun)) expr))
+(defun map-lisp2li (expr env)
+ (mapcar (lambda (x) (lisp2li x env)) expr))
-(defun map-lisp2li-let (expr env)
- (mapcar (lambda (x) (add-binding env (car x) (lisp2li (cadr x) env))) (cadr expr)))
-
-(defun make-stat-env (env params)
- (mapcar (lambda (x) (add-binding env x nil)) params)
- env)
+(defun make-stat-env (params &optional env)
+ (append
+ (loop
+ for var in params
+ for j = 1 then (+ j 1)
+ for num-env = (+ (or (second (first env)) -1) 1)
+ collect (list var num-env j)
+ )
+ env))
(defun transform-quasiquote (expr)
(cond
@@ -43,259 +44,138 @@
(T
`(cons ,(transform-quasiquote (car expr))
,(transform-quasiquote (cdr expr))))))
+
+(defmacro get-defun (symb)
+ `(get ,symb :defun))
+
+(defun set-defun (li)
+ (setf (get-defun (cdaddr li)) (cdddr li)))
-(defun lisp2li (expr env-var env-fun)
+(defun lisp2li (expr env)
"Convertit le code LISP en un code intermédiaire reconnu
par le compilateur et par l’interpréteur"
- (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))
- ;; symboles
- ((symbolp expr)
- (let ((cell (get-binding env-var expr)))
- (if cell
- (cons :var (car cell))
- (error "Variable ~S unknown" expr))))
- ;; 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-fun))))
- ;; lambda ex: ((lambda (x) x) 1)
- ((and (consp (car expr))
- (eq 'lambda (caar expr)))
- `(:call ,(lisp2li (car expr) env-var env-fun)
- ,@(mapcar (lambda (param)
- (lisp2li param env-var env-fun))
- (cdr expr))))
- ;; (not-symbol ...)
- ((not (symbolp (car expr)))
- (warn "~S isn't a symbol" (car expr)))
- ;; 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-var env-fun)
- (lisp2li (third expr) env-var env-fun)
- (lisp2li (fourth expr) env-var env-fun)))
- ;; quote
- ((eq 'quote (car expr))
- (cons :lit (second expr)))
- ;; quasiquote `
- ((eq my-quasiquote (car expr))
- (lisp2li (transform-quasiquote (cadr expr)) env-var env-fun))
- ;; #'fn (FUNCTION fn)
- ((eq 'function (car expr))
- (list :call 'function (car expr)))
- ;; 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 (cons env-bis env-fun)
- (map-lisp2li (cdddr expr)
- env-bis env-fun)))))
- (cons :lit (second expr)))
- ;; defvar
- ((eq 'defvar (car expr))
- (add-top-level-binding env-var
- (second expr)
- (lisp2li (third expr) env-var env-fun)))
- ;; setq/setf
- ((eq 'setq (car expr))
- (cons :call (cons 'set-binding (list `(:lit . ,env-var)
- (cons :lit (second expr))
- (cons :lit (third expr))))))
- ;; let
- ((eq 'let (car expr))
- (let ((bindings (cadr expr))
- (body (cddr expr)))
- (lisp2li `((lambda ,(mapcar #'car bindings)
- ,@body)
- ,@(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-var env-fun)))
- ;; labels
- ((eq 'labels (car expr))
- (let ((bindings (cadr expr))
- (body (cddr expr)))
- (lisp2li `((lambda ,(mapcar #'car bindings)
- ,@body)
- ,@(mapcar #'cadr bindings)) env-var env-fun)))
- ;; `
- ((eq '` (car expr))
- (print "Ca marche"))
- ;; 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-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
- (print expr)
- (error "special form not yet implemented ~S" (car expr)))
- ))
-
-(defun map-lisp2li (expr env-var env-fun)
- (mapcar (curry #'lisp2li :skip 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)))
-
-(defun make-stat-env (env params)
- (mapcar (lambda (x) (add-binding env x nil)) params)
- env)
+ (cond
+ ;; literaux
+ ((and (atom expr) (constantp expr))
+ (cons :const expr))
+ ;; symboles
+ ((symbolp expr)
+ (let ((cell (assoc expr env)))
+ (if cell
+ `(:cvar ,(cadr cell) ,(caddr cell))
+ (error "Variable ~S unknown" expr))))
+ ;; lambda solitaire ex: (lambda (x) x)
+ ((eq 'lambda (car expr))
+ `(:lclosure . ,(cons (length (second expr))
+ (lisp2li (third expr)
+ (make-stat-env (second expr))))))
+ ;; lambda ex: ((lambda (x) x) 1)
+ ((and (consp (car expr))
+ (eq 'lambda (caar expr)))
+ `(:mcall ,(lisp2li (car expr) env)
+ ,@(mapcar (lambda (param)
+ (lisp2li param env))
+ (cdr expr))))
+ ;; (not-symbol ...)
+ ((not (symbolp (car expr)))
+ (warn "~S isn't a symbol" (car expr)))
+ ;; fonction inconnue
+ ((and (not (fboundp (car expr)))
+ (not (get-defun (car expr))))
+ `(:unknown ,expr ,env))
+ ;; if
+ ((eq 'if (car expr))
+ (list :if
+ (lisp2li (second expr) env)
+ (lisp2li (third expr) env)
+ (lisp2li (fourth expr) env)))
+ ;; quote
+ ((eq 'quote (car expr))
+ (cons :const (second expr)))
+ ;; quasiquote `
+ ((eq my-quasiquote (car expr))
+ (lisp2li (transform-quasiquote (cadr expr)) env))
+ ;; #'fn (FUNCTION fn)
+ ((eq 'function (car expr))
+ `(:sclosure (cadr expr)))
+ ;; defun
+ ((eq 'defun (car expr))
+ `(:mcall set-defun (:const . ,(second expr))
+ ,(lisp2li `(lambda ,(third expr) ,@(cdddr expr)) env)))
+ ;; apply
+ ((eq 'apply (car expr))
+ `(:sapply ,(second expr) (cddr expr)))
+ ;; setf
+ ((eq 'setf (car expr))
+ (if (symbolp (cadr expr))
+ (let ((cell (assoc (cadr expr) env)))
+ `(:set-var (,(second cell) ,(third cell)) ,(third expr)))
+ `(:set-fun ,(caadr expr) ,@(last expr) ,@(cdadr expr))))
+ ;; progn
+ ((eq 'progn (car expr))
+ (cons :progn (map-lisp2li (cdr expr) env)))
+ ;; macros
+ ((macro-function (car expr))
+ (lisp2li (macroexpand-1 expr) env))
+ ;; foctions normales
+ ((not (special-operator-p (car expr)))
+ `(:call ,(first expr) ,@(map-lisp2li (cdr expr) env)))
+ (T
+ (print expr)
+ (error "special form not yet implemented ~S" (car expr)))))
;; Test unitaire
(load "test-unitaire")
(erase-tests lisp2li)
-(deftest (lisp2li :lit)
- (lisp2li '3 () ())
- '(:lit . 3))
-
-(deftest (lisp2li :lit)
- (lisp2li ''x () ())
- '(:lit . x))
-
-(deftest (lisp2li :lit)
- (lisp2li ''(1 2 3) () ())
- '(:lit 1 2 3))
-
-;; test des if
-(deftest (lisp2li :if)
- (lisp2li '(if T T nil) () ())
- '(:if (:lit . T) (:lit . T) (:lit . nil)))
-
-(deftest (lisp2li :if)
- (lisp2li '(if T nil T) () ())
- '(:if (:lit . T) (:lit . nil) (:lit . T)))
-
-;; test des fonctions predefinies
-(deftest (lisp2li :call)
- (lisp2li '(eq 1 1) () ())
- '(:call eq (:lit . 1) (:lit . 1)))
-
-(deftest (lisp2li macros)
- (lisp2li '(and 1 1) () ())
- '(:lit . 1))
-
-;; test des variables
-(deftest (lisp2li :var)
- (lisp2li 'x '(("TOP-LEVEL" (x . 1) (y . 2))) ())
- '(:var . x))
-
-(deftest (lisp2li :var)
- (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 :var)
- (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 complexe)
- (lisp2li '(if (eq 1 1) 2 2) () ())
- '(:if (:call eq (:lit . 1) (:lit . 1)) (:lit . 2) (:lit . 2)))
-
-(deftest (lisp2li complexe)
- (lisp2li '(if (eq "abc" 1) "abc" 2) () ())
- '(:IF (:CALL EQ (:LIT . "abc") (:LIT . 1)) (:LIT . "abc") (:LIT . 2)))
-
-(deftest (lisp2li :unknown)
- (lisp2li '(foo 1 1) () ())
- '(:unknown (foo 1 1) ((("TOP-LEVEL")) ("TOP-LEVEL"))))
-
-(deftest (lisp2li :unknown)
- (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 setq) env (add-binding (empty-env-stack) 'x 1))
-(deftest (lisp2li setq)
- (lisp2li '(setq x 2) env ())
- '(:call set-binding (:lit . (("TOP-LEVEL" (x . 1)))) (:lit . x) (:lit . 2)))
-
-;; Test sur le defun
-(deftest (lisp2li defun valeur-de-retour)
- (lisp2li '(defun fact (n r)
- (if (= n 0)
- r
- (fact (- n 1) (* n r))))
- () ())
- '(:lit . fact))
-
-(deftestvar (lisp2li defun environnement) env (empty-env-stack))
-(deftest (lisp2li defun environnement)
- (progn
- (lisp2li '(defun fact (n r)
- (if (= n 0)
- r
- (fact (- n 1) (* n r))))
- () env)
- env)
- '#1=(("TOP-LEVEL"
- (FACT :LCLOSURE (#2=(("DEFUN" (R) (N)) ("TOP-LEVEL")) . #1#)
- (:IF (:CALL = (:VAR . N) (:LIT . 0)) (:VAR . R)
- (:UNKNOWN (FACT (- N 1) (* N R)) (#2# . #1#)))))))
-
-;; Test sur la lambda expression
-(deftest lisp2li
- (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")) ("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")) ("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))) ("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")) ("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
+(deftest (lisp2li make-stat-env)
+ (make-stat-env '(x y z))
+ '((x 0 1) (y 0 2) (z 0 3)))
+
+(deftest (lisp2li make-stat-env)
+ (make-stat-env '(a b c d))
+ '((a 0 1) (b 0 2) (c 0 3) (d 0 4)))
+
+(deftest (lisp2li make-stat-env)
+ (make-stat-env '(a b) '((x 0 1) (y 0 2)))
+ '((a 1 1) (b 1 2) (x 0 1) (y 0 2)))
+
+(deftest (lisp2li constante)
+ (lisp2li '3 ())
+ '(:const . 3))
+
+(deftest (lisp2li constante)
+ (lisp2li ''x ())
+ '(:const . x))
+
+(deftest (lisp2li constante)
+ (lisp2li ''(1 2 3) ())
+ '(:const 1 2 3))
+
+(deftest (lisp2li defun)
+ (lisp2li '(defun foo (x) x) ())
+ '(:mcall set-defun (:const . foo) (:lclosure 1 :cvar 0 1)))
+
+(deftest (lisp2li defun)
+ (lisp2li '(defun foo (x y z) (list x y z)) ())
+ '(:mcall set-defun (:const . foo)
+ (:lclosure 3 :call list
+ (:cvar 0 1)
+ (:cvar 0 2)
+ (:cvar 0 3))))
+
+(deftest (lisp2li setf)
+ (lisp2li '(setf y 42) '((x 0 1) (y 0 2)))
+ '(:set-var (0 2) 42))
+
+(deftest (lisp2li setf)
+ (lisp2li '(setf (cdr '(1 2 3)) 42) ())
+ '(:set-fun cdr 42 '(1 2 3)))
+
+(deftest (lisp2li lambda)
+ (lisp2li '(mapcar (lambda (x y z) (list x y z)) '(1 2 3)) ())
+ '(:call mapcar (:lclosure 3 :call list
+ (:cvar 0 1)
+ (:cvar 0 2)
+ (:cvar 0 3))
+ (:const 1 2 3)))
+\ No newline at end of file
diff --git a/test-unitaire.lisp b/test-unitaire.lisp
@@ -40,7 +40,7 @@
(setf all-tests (list nil nil nil nil))
(let ((from (test-get-module (butlast module))))
(setf (first from)
- (delete (last module)
+ (delete (car (last module))
(first from)
:key #'car)))))
