squash-lisp-1 : 100% + tests d'équivalence du code + tous les tests passent.
This commit is contained in:
Georges Dupéron
parent
2140eeca89
commit
85196b56f6
|
|
@ -1,225 +1,213 @@
|
|||
(require 'squash-lisp "squash-lisp")
|
||||
(require 'mini-meval "mini-meval")
|
||||
(require 'test-unitaire "test-unitaire")
|
||||
|
||||
(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 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)
|
||||
))
|
||||
|
||||
(defmacro deftest-equiv (module test &optional (expected nil expected-p))
|
||||
`(deftest ,module (expr-equiv-p ,test . ,(if expected-p (list expected) nil))
|
||||
t))
|
||||
(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 (mini-meval constante)
|
||||
(mini-meval 42 etat)
|
||||
(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)
|
||||
(deftest-equiv (lambda immédiat)
|
||||
'((lambda (x) (+ x 3)) 4)
|
||||
7)
|
||||
|
||||
(deftest (mini-meval lambda immédiat)
|
||||
(mini-meval '((lambda (x) (+ x 3)) 4) etat)
|
||||
(deftest-equiv (let)
|
||||
'(let ((x 3) (y 4)) (+ x y))
|
||||
7)
|
||||
|
||||
(deftest (mini-meval let)
|
||||
(mini-meval '(let ((x 3) (y 4)) (+ x y)) etat)
|
||||
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-equiv (flet)
|
||||
'(labels ((foo (x) (+ x 1)))
|
||||
(list
|
||||
(foo 3)
|
||||
(flet ((foo (x) (+ x 3)))
|
||||
(foo 3))))
|
||||
'(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-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 (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 ((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)
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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.
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user