commit 85196b56f6593eb4e49fb1bb1585519031e6fdcf
parent 2140eeca89d8229ff78ca935d6e54a591ae6b044
Author: Georges Dupéron <jahvascriptmaniac+github@free.fr>
Date: Sun, 9 Jan 2011 18:28:06 +0100
squash-lisp-1 : 100% + tests d'équivalence du code + tous les tests passent.
Diffstat:
5 files changed, 206 insertions(+), 196 deletions(-)
diff --git a/lisp/equiv-tests.lisp b/lisp/equiv-tests.lisp
@@ -1,225 +1,213 @@
(require 'squash-lisp "squash-lisp")
(require 'mini-meval "mini-meval")
-
-(defun expr-equiv-p (expr &optional (expected nil expected-p))
- (let ((res-eval (eval expr))
- (temp nil))
- (setq temp (mini-meval expr))
- (unless (equalp res-eval temp)
- (return-from expr-equiv-p (format nil "mini-meval differs from eval : ~a vs ~a" res-eval temp)))
- (when expected-p
- (unless (equalp expected temp)
- (return-from expr-equiv-p "mini-meval differs from expected value")))
- (setq temp (squash-lisp-1 expr))
- (unless (squash-lisp-1-check temp)
- (return-from expr-equiv-p "squash-lisp-1-check failed"))
- (unless (equalp res-eval (eval (squash-lisp-1-wrap temp)))
- (return-from expr-equiv-p "squash-lisp-1 differs from eval"))
- ;; (setq temp (squash-lisp-2 (squash-lisp-1 expr)))
- ;; (unless (squash-lisp-2-check temp)
- ;; (return-from expr-equiv-p "squash-lisp-2-check failed"))
- ;; (unless (equalp res-eval (eval (squash-lisp-2-wrap temp)))
- ;; (return-from expr-equiv-p "squash-lisp-2 differs from eval"))
- t))
-
-(defmacro deftest-equiv (module test &optional (expected nil expected-p))
- `(deftest ,module (expr-equiv-p ,test . ,(if expected-p (list expected) nil))
- t))
-
-(deftest-equiv (mini-meval constante)
- (mini-meval 42 etat)
+(require 'test-unitaire "test-unitaire")
+
+(defmacro deftest-equiv (module test expected)
+ `(progn
+ (deftest ,(append '(equiv expected/eval) module) (eval ,test) ,expected)
+ (deftest ,(append '(equiv expected/mini-meval) module) (mini-meval ,test etat) ,expected)
+ (deftest ,(append '(equiv squash-lisp-1-check) module) (squash-lisp-1-check (squash-lisp-1 ,test t etat)) t) ;; etat -> pour les macros
+ (deftest ,(append '(equiv expected/squash-lisp-1) module) (eval (squash-lisp-1-wrap (squash-lisp-1 ,test t etat))) ,expected) ;; etat -> pour les macros
+ ;; (deftest ,(append '(equiv squash-lisp-2-check) module) (squash-lisp-2-check (squash-lisp-2 ,test)) t)
+ ;; (deftest ,(append '(equiv expected/squash-lisp-2) module) (eval (squash-lisp-2-wrap (squash-lisp-2 ,test))) ,expected)
+ ))
+
+(erase-tests equiv)
+
+(deftestvar (equiv) etat (push-local (make-etat list + - cons car cdr < > <= >= =) '*test-equiv-var-x* 'variable 42))
+(defvar *test-equiv-var-x* 42)
+
+(deftest-equiv (constante)
+ 42
42)
-(deftest (mini-meval appel-fonction)
- (mini-meval '(+ 2 3) etat)
+(deftest-equiv (appel-fonction)
+ '(+ 2 3)
5)
-(deftest (mini-meval appel-fonction)
- (mini-meval '(+ 2 (+ 3 4)) etat)
+(deftest-equiv (appel-fonction)
+ '(+ 2 (+ 3 4))
9)
-(deftest (mini-meval variable)
- (mini-meval 'x (push-local etat 'x 'variable 42))
+(deftest-equiv (variable)
+ '*test-equiv-var-x*
42)
-(deftest (mini-meval appel-fonction-et-variable)
- (mini-meval '(+ x x 3) (push-local etat 'x 'variable 42))
+(deftest-equiv (appel-fonction-et-variable)
+ '(+ *test-equiv-var-x* *test-equiv-var-x* 3)
87)
-(deftest (mini-meval appel-fonction-et-variable)
- (mini-meval '(+ x (+ 3 x)) (push-local etat 'x 'variable 42))
+(deftest-equiv (appel-fonction-et-variable)
+ '(+ *test-equiv-var-x* (+ 3 *test-equiv-var-x*))
87)
-(deftest (mini-meval lambda extérieur)
- (funcall (mini-meval '(lambda (x) x) etat) 3)
- 3)
-
-(deftest (mini-meval lambda extérieur)
- (funcall (mini-meval '(lambda (x) (+ x 3)) etat) 4)
- 7)
-
-(deftest (mini-meval lambda immédiat)
- (mini-meval '((lambda (x) (+ x 3)) 4) etat)
+(deftest-equiv (lambda immédiat)
+ '((lambda (x) (+ x 3)) 4)
7)
-(deftest (mini-meval let)
- (mini-meval '(let ((x 3) (y 4)) (+ x y)) etat)
+(deftest-equiv (let)
+ '(let ((x 3) (y 4)) (+ x y))
7)
-(deftest (mini-meval let)
- (mini-meval '(let ((x 3) (y 4) (z 5)) (let ((z (+ x y)) (w z)) (list x y z w))) etat)
+(deftest-equiv (let)
+ '(let ((x 3) (y 4) (z 5)) (let ((z (+ x y)) (w z)) (list x y z w)))
'(3 4 7 5))
-(deftest (mini-meval let*)
- (mini-meval '(let ((x 3) (y 4) (z 5)) (let* ((z (+ x y)) (w z)) (list x y z w))) etat)
+(deftest-equiv (let*)
+ '(let ((x 3) (y 4) (z 5)) (let* ((z (+ x y)) (w z)) (list x y z w)))
'(3 4 7 7))
;; TODO
-;; (deftest (mini-meval let-nil)
-;; (mini-meval '(let (a (x 3) y) (list a x y)) etat)
+;; (deftest-equiv (let-nil)
+;; '(let (a (x 3) y) (list a x y))
;; '(nil 3 nil))
-;; (deftest (mini-meval let-nil)
-;; (mini-meval '(let* ((x 4) y (z 5)) (list a x y)) etat)
+;; (deftest-equiv (let-nil)
+;; '(let* ((x 4) y (z 5)) (list a x y))
;; '(4 nil 5))
-(deftest (mini-meval progn)
- (mini-meval '(progn 1 2 3 4) etat)
+(deftest-equiv (progn)
+ '(progn 1 2 3 4)
4)
-(deftest (mini-meval quote)
- (mini-meval ''x etat)
+(deftest-equiv (quote)
+ ''x
'x)
-(deftest (mini-meval macrolet)
- (mini-meval '(labels ((qlist (a b) (list a b)))
- (list
- (qlist 'a 'b)
- (macrolet ((qlist (x y) (list 'list (list 'quote x) (list 'quote y))))
- (qlist 'a 'b))
- (qlist 'a 'b)))
- etat)
+(deftest-equiv (macrolet)
+ '(labels ((qlist (a b) (list a b)))
+ (list
+ (qlist 'a 'b)
+ (macrolet ((qlist (x y) (list 'list (list 'quote x) (list 'quote y))))
+ (qlist 'a 'b))
+ (qlist 'a 'b)))
'((a b) ('a 'b) (a b)))
-(deftest (mini-meval setf setq)
- (mini-meval '(let ((x 42)) (list x (setq x 123) x) etat))
+(deftest-equiv (setf setq)
+ '(let ((x 42)) (list x (setq x 123) x))
'(42 123 123))
-(deftest (mini-meval funcall)
- (mini-meval '(funcall #'+ 1 2 3) etat)
+(deftest-equiv (funcall)
+ '(funcall #'+ 1 2 3)
'6)
-(deftest (mini-meval apply)
- (mini-meval '(apply #'+ 1 2 (list (+ 1 2) 4)) etat)
+(deftest-equiv (apply)
+ '(apply #'+ 1 2 (list (+ 1 2) 4))
'10)
-(deftest (mini-meval function external)
- (mini-meval '#'+ etat)
- #'+)
-
-(deftest (mini-meval function external)
- (mini-meval '(funcall #'+ 1 2 3) etat)
+(deftest-equiv (function extérieur)
+ '(funcall #'+ 1 2 3)
'6)
-(deftest (mini-meval call-function external)
- (mini-meval '(#'+ 2 3) etat)
- 5)
-
-(deftest (mini-meval call-function lambda)
- (mini-meval '(#'(lambda (x) (+ x 40)) 2) etat)
- 42)
-
-(deftest (mini-meval lambda optional)
- (mini-meval '((lambda (x &optional (y 2)) (list x y)) 1) etat)
+(deftest-equiv (lambda optional)
+ '((lambda (x &optional (y 2)) (list x y)) 1)
'(1 2))
-(deftest (mini-meval lambda closure single-instance)
- (mini-meval '(let ((foo (let ((y 1)) (cons (lambda (x) (list x y)) (lambda (z) (setq y (+ y z)) nil)))))
- (list (funcall (car foo) 4) (funcall (cdr foo) 5) (funcall (car foo) 4))) etat)
+(deftest-equiv (lambda closure single-instance)
+ '(let ((foo (let ((y 1)) (cons (lambda (x) (list x y)) (lambda (z) (setq y (+ y z)) nil)))))
+ (list (funcall (car foo) 4) (funcall (cdr foo) 5) (funcall (car foo) 4)))
'((4 1) nil (4 6)))
-(deftest (mini-meval lambda closure multiple-instances)
- (mini-meval '(labels ((counter (&optional (ctr 0)) (cons (lambda () ctr) (lambda (&optional (x 1)) (setq ctr (+ ctr x)) nil))))
- (let ((foo0 (counter))
- (foo42 (counter 42)))
- (list
- (funcall (car foo0)) ;; show 0
- (funcall (car foo42)) ;; show 42
- (funcall (cdr foo0)) ;; add 0
- (funcall (car foo0)) ;; show 0
- (funcall (cdr foo42)) ;; add 42
- (funcall (car foo42)) ;; show 42
- (funcall (car foo0)) ;; shwo 0
- (funcall (car foo42)) ;; show 42
- (funcall (cdr foo42) 6) ;; add 42 (+ 6)
- (funcall (cdr foo0) 5) ;; add 0 (+ 5)
- (funcall (car foo42)) ;; show 42
- (funcall (car foo0))))) ;; show 0
- etat)
+(deftest-equiv (lambda closure multiple-instances)
+ '(labels ((counter (&optional (ctr 0)) (cons (lambda () ctr) (lambda (&optional (x 1)) (setq ctr (+ ctr x)) nil))))
+ (let ((foo0 (counter))
+ (foo42 (counter 42)))
+ (list
+ (funcall (car foo0)) ;; show 0
+ (funcall (car foo42)) ;; show 42
+ (funcall (cdr foo0)) ;; add 0
+ (funcall (car foo0)) ;; show 0
+ (funcall (cdr foo42)) ;; add 42
+ (funcall (car foo42)) ;; show 42
+ (funcall (car foo0)) ;; shwo 0
+ (funcall (car foo42)) ;; show 42
+ (funcall (cdr foo42) 6) ;; add 42 (+ 6)
+ (funcall (cdr foo0) 5) ;; add 0 (+ 5)
+ (funcall (car foo42)) ;; show 42
+ (funcall (car foo0))))) ;; show 0
'(0 42 nil 1 nil 43 1 43 nil nil 49 6))
-(deftest (mini-meval labels)
- (mini-meval '(labels ((foo (x) (+ x 1)))
- (list
- (foo 3)
- (labels ((foo (x) (+ x 3)))
- (foo 3))))
- etat)
+(deftest-equiv (labels)
+ '(labels ((foo (x) (+ x 1)))
+ (list
+ (foo 3)
+ (labels ((foo (x) (+ x 3)))
+ (foo 3))))
'(4 6))
-(deftest (mini-meval labels)
- (mini-meval '(< 2 3) etat)
+(deftest-equiv (labels)
+ '(< 2 3)
t)
-(deftest (mini-meval flet)
- (mini-meval '(labels ((foo (x) (+ x 1)))
- (list
- (foo 3)
- (flet ((foo (x) (+ x 3)))
- (foo 3))))
- etat)
- '(foo 4 6))
-
-(deftest (mini-meval labels)
- (mini-meval '(labels ((fibo (n) (if (< n 2) 1 (+ (fibo (- n 1)) (fibo (- n 2)))))) ;; fibo 0 -> 1; 1 -> 1; 2 -> 2 ...
- (list
- (fibo 5)
- (labels ((fibo (n) (if (< n 3) 1 (+ (fibo (- n 1)) (fibo (- n 2)))))) ;; fibo 1 -> 1; 2 -> 1; 3 -> 2 ...
- (fibo 5))
- (fibo 5)))
- etat)
- '(fibo 8 5 8))
-
-(deftest (mini-meval flet)
- (mini-meval '(labels ((fibo (n) (if (< n 2) 1 (+ (fibo (- n 1)) (fibo (- n 2)))))) ;; fibo 0 -> 1; 1 -> 1; 2 -> 2 ...
- (list
- (fibo 5)
- (flet ((fibo (n) (if (< n 3) 1 (+ (fibo (- n 1)) (fibo (- n 2)))))) ;; fibo 1 -> 1; 2 -> 1; 3 -> 2 ...
- (fibo 5))))
- etat)
+(deftest-equiv (flet)
+ '(labels ((foo (x) (+ x 1)))
+ (list
+ (foo 3)
+ (flet ((foo (x) (+ x 3)))
+ (foo 3))))
+ '(4 6))
+
+(deftest-equiv (labels)
+ '(labels ((fibo (n) (if (< n 2) 1 (+ (fibo (- n 1)) (fibo (- n 2)))))) ;; fibo 0 -> 1; 1 -> 1; 2 -> 2 ...
+ (list
+ (fibo 5)
+ (labels ((fibo (n) (if (< n 3) 1 (+ (fibo (- n 1)) (fibo (- n 2)))))) ;; fibo 1 -> 1; 2 -> 1; 3 -> 2 ...
+ (fibo 5))
+ (fibo 5)))
+ '(8 5 8))
+
+(deftest-equiv (flet)
+ '(labels ((fibo (n) (if (< n 2) 1 (+ (fibo (- n 1)) (fibo (- n 2)))))) ;; fibo 0 -> 1; 1 -> 1; 2 -> 2 ...
+ (list
+ (fibo 5)
+ (flet ((fibo (n) (if (< n 3) 1 (+ (fibo (- n 1)) (fibo (- n 2)))))) ;; fibo 1 -> 1; 2 -> 1; 3 -> 2 ...
+ (fibo 5))))
;; Le flet ne permet pas les définitions récursives, donc le fibo
;; de l'extérieur est appellé après le 1er niveau de récursion.
- '(fibo 8 8))
+ '(8 8))
-(deftest (mini-meval tagbody)
- (mini-meval '(let ((x 0)) (tagbody foo (setq x 1) (go baz) bar (setq x 2) baz) x))
+(deftest-equiv (tagbody)
+ '(let ((x 0)) (tagbody foo (setq x 1) (go baz) bar (setq x 2) baz) x)
1)
-(deftest (mini-meval tagbody)
- (mini-meval '(let ((x 0)) (tagbody foo (setq x 1) (go 42) bar (setq x 2) 42) x))
+(deftest-equiv (tagbody)
+ '(let ((x 0)) (tagbody foo (setq x 1) (go 42) bar (setq x 2) 42) x)
1)
-(deftest (mini-meval tagbody)
- (mini-meval '(tagbody foo (list 1) 42 (list 2) baz (list 3)) etat)
+(deftest-equiv (tagbody)
+ '(tagbody foo (list 1) 42 (list 2) baz (list 3))
nil)
-(deftest (mini-meval block)
- (mini-meval '(block foo 1 (return-from foo 4) 2))
+(deftest-equiv (block)
+ '(block foo 1 (return-from foo 4) 2)
4)
-(deftest (mini-meval block)
- (mini-meval '(block foo 1 2))
+(deftest-equiv (block)
+ '(block foo 1 2)
2)
+(deftest-equiv (tagbody)
+ '(let ((res nil))
+ (tagbody
+ a
+ 1
+ (setq res (cons 'x res))
+ b
+ (setq res (cons 'y res))
+ (go 3)
+ d
+ (setq res (cons 'z res))
+ 3
+ (setq res (cons 'f res)))
+ res)
+ '(f y x))
+
+(deftest-equiv (flet)
+ '(flet ((foo (x) (+ x 1)) (bar (y z) (cons y z))) (list (foo 3) (bar 4 5)))
+ '(4 (4 . 5)))
+
+(deftest-equiv (function extérieur)
+ '#'+
+ #'+)
(provide 'equiv-tests)
diff --git a/lisp/main.lisp b/lisp/main.lisp
@@ -9,6 +9,8 @@
(load "match")
(load "mini-meval")
(load "squash-lisp")
+(load "squash-lisp-1")
+(load "squash-lisp-2")
(load "equiv-tests")
(provide 'main)
diff --git a/lisp/mini-meval.lisp b/lisp/mini-meval.lisp
@@ -290,7 +290,6 @@ Mini-meval est un meval très simple destiné à évaluer les macros et les autr
Mini-meval sera appellé sur des morceaux spécifiques du fichier source. Il faut donc qu'il puisse maintenir son état entre les appels.
|#
(defun mini-meval (expr &optional (etat (list nil nil nil)))
- (print etat)
#|
L'algorithme d'évaluation est très simple et suit le schéma donné dans CLTL 5.1.3 :
1) Si l'expression est une forme spéciale, on la traite de manière particulière
@@ -514,10 +513,28 @@ Mini-meval sera appellé sur des morceaux spécifiques du fichier source. Il fau
;; La plupart des tests sont dans eqiv-tests.lisp
+(deftest (mini-meval lambda extérieur)
+ (funcall (mini-meval '(lambda (x) x) etat) 3)
+ 3)
+
+(deftest (mini-meval lambda extérieur)
+ (funcall (mini-meval '(lambda (x) (+ x 3)) etat) 4)
+ 7)
+
(deftest (mini-meval defvar)
(mini-meval '(progn (defvar x 42) x) etat)
42)
+;; Syntaxe supplémentaire non reconnue par le standard : (#'fun param*)
+(deftest (mini-meval call-function extérieur)
+ (mini-meval '(#'+ 2 3) etat)
+ 5)
+
+;; Syntaxe supplémentaire non reconnue par le standard : (#'(lambda ...) param*)
+(deftest (mini-meval call-function lambda)
+ (mini-meval '(#'(lambda (x) (+ x 40)) 2) etat)
+ 42)
+
(deftest (mini-meval defvar special)
(mini-meval '(progn
(defun foo1 () var)
@@ -547,9 +564,11 @@ Mini-meval sera appellé sur des morceaux spécifiques du fichier source. Il fau
'((a b) ('a 'b) (a b)))
(deftest (mini-meval setf setq)
- (mini-meval '(progn (debug 'a) (print etat) (list (defvar x 42) x (setq x 123) x) etat))
+ (mini-meval '(list (defvar x 42) x (setq x 123) x) etat)
'(x 42 123 123))
+;; TODO : tests setf
+
(deftest (mini-meval function internal)
(funcall (mini-meval '(progn (defun foo (x) (+ x 40)) #'foo) etat) 2)
'42)
diff --git a/lisp/squash-lisp-1.lisp b/lisp/squash-lisp-1.lisp
@@ -100,8 +100,7 @@
(,block-id-sym (cons nil nil)))
(unwind-catch ,block-id-sym
(progn ,@body)
- nil)
- ,retval-sym)
+ ,retval-sym))
nil
(push-local etat block-name 'squash-block-catch (cons block-id-sym retval-sym)))))
@@ -112,7 +111,7 @@
((return-from :block-name $$ :value _)
(let ((association (assoc-etat block-name 'squash-block-catch etat)))
(unless association (error "Squash-Lisp-1 : Can't return from block ~w, it is inexistant or not lexically apparent." block-name))
- (squash-lisp-1 `(progn (setq ,(cddr association) value)
+ (squash-lisp-1 `(progn (setq ,(cddr association) ,value)
(unwind ,(cadr association)))
nil etat)))
@@ -158,8 +157,8 @@
((throw :tag _ :result _)
(squash-lisp-1
- `(progn (setq singleton-catch-retval value)
- (unwind ,tag (progn ,@result)))
+ `(progn (setq singleton-catch-retval ,result)
+ (unwind ,tag))
nil etat))
;; Simplification du unwind-protect
@@ -190,13 +189,13 @@
;; Transformation des (let[*] (var1 var2 var3) …) en (let[*] ((var1 nil) (var2 nil) (var3 nil)) …)
((:type (? or (eq x 'let) (eq x 'let*)) :bindings (? and consp (find-if #'symbolp x)) :body . _)
- (squash-lisp-1 `(,type ,(mapcar (lambda (b) (if (consp b) b `(b nil))) bindings) ,@body)))
+ (squash-lisp-1 `(,type ,(mapcar (lambda (b) (if (consp b) b `(b nil))) bindings) ,@body) nil etat))
((let ((:name $$ :value _)*) :body _*)
`(let ,(mapcar (lambda (n v) `(,n ,(squash-lisp-1 v nil etat))) name value)
,(squash-lisp-1 `(progn ,@body) nil etat)))
- ((let* ((:name $$ :value _)*) :body _*)
+ (((? (eq x 'let*)) ((:name $$ :value _)*) :body _*)
`(let* ,(mapcar (lambda (n v) `(,n ,(squash-lisp-1 v nil etat))) name value)
,(squash-lisp-1 `(progn ,@body) nil etat)))
@@ -239,7 +238,7 @@
;; => TODO : définir la fonction apply : (funcall #'apply #'cons '(1 2))
((setq :name $$ :value _)
- `(setq ,name ,(squash-lisp-1 value)))
+ `(setq ,name ,(squash-lisp-1 value nil etat)))
((quote _)
expr)
@@ -250,7 +249,7 @@
;; TODO : nil et t devraient être des defconst
;; Doit être avant les symboles
(nil
- (quote nil))
+ ''nil)
($$
`(get-var ,expr))
@@ -258,16 +257,16 @@
;; Appels de fonction
;; Doivent être après tout le monde.
((:fun $$ :params _*)
- (squash-lisp-1 `(funcall (function ,fun) ,@params)))
+ (squash-lisp-1 `(funcall (function ,fun) ,@params) nil etat))
((:lambda (lambda . _) :params _*)
- (squash-lisp-1 `(funcall ,lambda ,@params)))
+ (squash-lisp-1 `(funcall ,lambda ,@params) nil etat))
(((function :lambda (lambda . _)) :params . _)
- (squash-lisp-1 `(funcall ,lambda ,@params)))
+ (squash-lisp-1 `(funcall ,lambda ,@params) nil etat))
(((function :name $$) :params _*)
- (squash-lisp-1 `(funcall (function ,name) ,@params)))
+ (squash-lisp-1 `(funcall (function ,name) ,@params) nil etat))
(_
(error "squash-lisp-1: Not implemented yet : ~a" expr))))
@@ -277,8 +276,7 @@
(let ((bname (make-symbol "block")))
`(block ,bname
(catch ,object (return-from ,bname ,body))
- ,catch-code
- nil)))
+ ,catch-code)))
(tagbody-unwind-catch (object body catch-code)
catch-code ;; unused variable
;; les (progn object) et (progn x) sert à permettre l'expansion des macros sur x
@@ -305,21 +303,6 @@
x))
,expr))
-(eval (squash-lisp-1-wrap
- '(unwind-catch 'foo
- (progn (print 1)
- (unwind 'foo)
- (print 2))
- (print 3))))
-
-(eval (squash-lisp-1-wrap (squash-lisp-1 '(flet ((foo (x) (+ x 1)) (bar (y z) (cons y z))) (list (foo 3) (bar 4 5))))))
-
-(eval (squash-lisp-1-wrap (squash-lisp-1 '(tagbody a 1 (print 'x) b (print 'y) (go 3) d (print 'z) 3 (print 'f)))))
-
-;;
-;; (squash-lisp-1 '(flet ((foo (x) (+ x 1)) (bar (y z) (cons y z))) (list (foo 3) (bar 4 5))))
-
-
(defun squash-lisp-1-check (expr)
"Vérifie si expr est bien un résultat valable de squash-lisp-1.
Permet aussi d'avoir une «grammaire» du simple-lisp niveau 1.
@@ -328,6 +311,10 @@ Attention : il y a quelques invariants qui ne sont pas présents dans cette vér
expr
((progn :body _*)
(every #'squash-lisp-1-check body))
+ ((if :condition _ :si-vrai _ :si-faux _)
+ (and (squash-lisp-1-check condition)
+ (squash-lisp-1-check si-vrai)
+ (squash-lisp-1-check si-faux)))
((unwind-protect :body _ :cleanup _)
(and (squash-lisp-1-check body)
(squash-lisp-1-check cleanup)))
@@ -347,7 +334,7 @@ Attention : il y a quelques invariants qui ne sont pas présents dans cette vér
t)
(((? (member x '(let let* simple-flet simple-labels))) ((:name $$ :value _)*) :body _)
(every #'squash-lisp-1-check (cons body value)))
- ((lambda :params ($$*) :body _)
+ ((lambda :params @ :body _)
(squash-lisp-1-check body))
((function :fun $$)
t)
@@ -363,6 +350,19 @@ Attention : il y a quelques invariants qui ne sont pas présents dans cette vér
(warn "squash-lisp-1-check: Assertion failed ! This should not be here : ~a" expr)
nil)))
+(require 'test-unitaire "test-unitaire")
+(erase-tests squash-lisp-1)
+(deftest (squash-lisp-1 wrap unwind)
+ (eval (squash-lisp-1-wrap
+ '(let ((foo nil))
+ (unwind-catch 'foo
+ (progn (push 1 foo)
+ (unwind 'foo)
+ (push 2 foo))
+ (push 3 foo))
+ foo)))
+ '(3 1))
+
#|
Notes sur l'implémentation d'unwind.
Tous les lets qui aparaissent dans un appel de fonction sont regrouppés en un seul. Donc à un appel de fonction correspond un "gros" segment de pile.
diff --git a/lisp/squash-lisp-2.lisp b/lisp/squash-lisp-2.lisp
@@ -9,9 +9,10 @@
expr
((progn :body _*)
`(progn ,@(mapcar (lambda (x) (squash-lisp-2 x env-var env-fun globals)) body)))
- ;; simple-tagbody est équivalent à un progn, mais nécessaire pour les macrolet.
- ((simple-tagbody :body _*)
- `(simple-tagbody ,@(mapcar (lambda (x) (squash-lisp-2 x env-var env-fun globals)) body)))
+ ((if :condition _ :si-vrai _ :si-faux _)
+ `(if ,(squash-lisp-2 condition env-var env-fun globals)
+ ,(squash-lisp-2 si-vrai env-var env-fun globals)
+ ,(squash-lisp-2 si-faux env-var env-fun globals)))
((unwind-protect :body _ :cleanup _)
`(unwind-protect ,(squash-lisp-2 body env-var env-fun globals)
,(squash-lisp-2 cleanup env-var env-fun globals)))
@@ -62,7 +63,7 @@
name value)
,(squash-lisp-2 body env-var new-env-fun globals))))) ;; env-var -> env-fun
;; TODO
- ((lambda :params ($$*) :body _)
+ ((lambda :params @ :body _)
;; TODO : simplifier la lambda-list
(squash-lisp-1-check body))
;; TODO
