www

commit d10e571953adc1606884b639168372603a5a0d4d
parent b63aa7c261c795d4861de94f9a306fb0f5abae59
Author: Georges Dupéron <jahvascriptmaniac+github@free.fr>
Date:   Sun,  7 Nov 2010 05:46:06 +0100

Ajout de copy-all.

Diffstat:
M
test-unitaire.lisp
 | 
24
+++++++++++++++++++-----
M
util.lisp
 | 
33
++++++++++++++++++++++++++++++---

2 files changed, 49 insertions(+), 8 deletions(-)
diff --git a/test-unitaire.lisp b/test-unitaire.lisp
@@ -86,11 +86,8 @@
      ,expected))
 
 (defmacro deftestvar (module name value)
-  (if (arrayp value)
-      `(test-add-variable ',module
-                          (list ',name (list 'copy-seq ',value)))
-    `(test-add-variable ',module
-                        (list ',name (list 'copy-tree ',value)))))
+  `(test-add-variable ',module
+                      (list ',name (list 'copy-all ',value))))
 
 (defvar run-tests-counter 0)
 
@@ -133,6 +130,23 @@
   (unless (listp module) (setq module (list module)))
   `(test-remove-module ',module))
 
+(erase-tests test-unitaire)
+(deftest (test-unitaire copy-all)
+    (let ((foo #(a b (1 #(2 4 6) 3) c))
+          (copy-of-foo (copy-all foo)))
+      copy-of-foo
+      (setf (aref (cadr (aref copy-of-foo 2)) 1) (cons 'MODIFIED (random 42)))
+      (equalp foo #(a b (1 #(2 4 6) 3) c)))
+  t #'booleq)
+
+(deftest (test-unitaire copy-all)
+    (let ((foo #(a x (1 #(2 4 7) 5) c))
+          (copy-of-foo (copy-all foo)))
+      copy-of-foo
+      (setf (aref (cadr (aref foo 2)) 1) (cons 'MODIFIED (random 42)))
+      (equalp foo #(a x (1 #(2 4 7) 5) c)))
+  nil #'booleq)
+
 ;;; Exemples d'utilisation.
 
 ;; (erase-tests (a sub-1))
diff --git a/util.lisp b/util.lisp
@@ -1,4 +1,3 @@
-
 ;; Fonctions utiles
 ;; Liste de quelques fonctions pratiques de LISP :
 ;; (rplacd x val) = (setf (cdr x) val)
@@ -42,8 +41,8 @@
 
 (defun range (a &optional b)
   (cond ((null b) (range 0 a))
-        ((> a b) (loop for i from a above (- b 1) collect i))
-        (T (loop for i from a to b collect i))))
+        ((> a b) (loop for i from a above b collect i))
+        (T (loop for i from a below b collect i))))
 
 (defun shift (n l)
   (if (<= n 0)
@@ -99,3 +98,31 @@
           (T
            (mposition-t symb (cdr list) (+ 1 counter)))))
   (mposition-t symb list 0))
+
+;; TODO : ne copie pas les listes de propriétés des symboles.
+;; Vu que ce n'est techniquement pas réalisable, il faut en tenir
+;; compte dans les tests unitaires etc.
+(defun copy-all (data)
+  "Copie récursivement un arbre de listes et de tableaux."
+  (print data)
+  (cond 
+    ((consp data)
+     (cons (copy-all (car data))
+           (copy-all (cdr data))))
+    ((arrayp data)
+     (let ((res (make-array (array-dimensions data))))
+       (dotimes (i (array-total-size data)) 
+         (setf (row-major-aref res i) (copy-all (row-major-aref data i))))
+       res))
+    ((stringp data)
+     (copy-seq data))
+    ((null data)
+     nil)
+    ((symbolp data)
+     data)
+    ((numberp data)
+     data)
+    ((characterp data)
+     data)
+    (t
+     (warn "copy-all : Je ne sais pas copier ~w" data))))