source: trunk/source/tests/ansi-tests/cons-aux.lsp @ 8991

Last change on this file since 8991 was 8991, checked in by gz, 11 years ago

Check in the gcl ansi test suite (original, in preparation for making local changes)

File size: 18.6 KB
Line 
1;-*- Mode:     Lisp -*-
2;;;; Author:   Paul Dietz
3;;;; Created:  Thu Mar  6 17:45:42 2003
4;;;; Contains: Auxiliary functions for cons-related tests
5
6(in-package :cl-test)
7
8;;;
9;;; A scaffold is a structure that is used to remember the object
10;;; identities of the cons cells in a (noncircular) data structure.
11;;; This lets us check if the data structure has been changed by
12;;; an operation.
13;;;
14
15(defstruct scaffold
16  node
17  car
18  cdr)
19
20(defun make-scaffold-copy (x)
21  "Make a tree that will be used to check if a tree has been changed."
22  (if
23      (consp x)
24      (make-scaffold :node x
25                     :car (make-scaffold-copy (car x))
26                     :cdr (make-scaffold-copy (cdr x)))
27    (make-scaffold :node x
28                   :car nil
29                   :cdr nil)))
30
31(defun check-scaffold-copy (x xcopy)
32  "Return t if xcopy were produced from x by make-scaffold-copy,
33   and none of the cons cells in the tree rooted at x have been
34   changed."
35
36  (and (eq x (scaffold-node xcopy))
37       (or
38        (not (consp x))
39        (and
40         (check-scaffold-copy (car x) (scaffold-car xcopy))
41         (check-scaffold-copy (cdr x) (scaffold-cdr xcopy))))))
42
43(defun create-c*r-test (n)
44  (cond
45   ((<= n 0) 'none)
46   (t
47    (cons (create-c*r-test (1- n))
48          (create-c*r-test (1- n))))))
49
50(defun nth-1-body (x)
51  (loop
52      for e in x
53       and i from 0
54       count (not (eqt e (nth i x)))))
55
56(defun check-cons-copy (x y)
57  "Check that the tree x is a copy of the tree y,
58   returning t if it is, nil if not."
59  (cond
60   ((consp x)
61    (and (consp y)
62         (not (eqt x y))
63         (check-cons-copy (car x) (car y))
64         (check-cons-copy (cdr x) (cdr y))))
65   ((eqt x y) t)
66   (t nil)))
67
68(defun check-sublis (a al &key (key 'no-key) test test-not)
69  "Apply sublis al a with various keys.  Check that
70   the arguments are not themselves changed.  Return nil
71   if the arguments do get changed."
72  (setf a (copy-tree a))
73  (setf al (copy-tree al))
74  (let ((acopy (make-scaffold-copy a))
75        (alcopy (make-scaffold-copy al)))
76    (let ((as
77           (apply #'sublis al a
78                  `(,@(when test `(:test ,test))
79                    ,@(when test-not `(:test-not ,test-not))
80                    ,@(unless (eqt key 'no-key) `(:key ,key))))))
81      (and
82       (check-scaffold-copy a acopy)
83       (check-scaffold-copy al alcopy)
84       as))))
85
86(defun check-nsublis (a al &key (key 'no-key) test test-not)
87  "Apply nsublis al a, copying these arguments first."
88  (setf a (copy-tree a))
89  (setf al (copy-tree al))
90  (let ((as
91         (apply #'sublis (copy-tree al) (copy-tree a)
92                `(,@(when test `(:test ,test))
93                    ,@(when test-not `(:test-not ,test-not))
94                    ,@(unless (eqt key 'no-key) `(:key ,key))))))
95    as))
96
97(defun check-subst (new old tree &key (key 'no-key) test test-not)
98  "Call subst new old tree, with keyword arguments if present.
99   Check that the arguments are not changed."
100  (setf new (copy-tree new))
101  (setf old (copy-tree old))
102  (setf tree (copy-tree tree))
103  (let ((newcopy (make-scaffold-copy new))
104        (oldcopy (make-scaffold-copy old))
105        (treecopy (make-scaffold-copy tree)))
106    (let ((result
107           (apply #'subst new old tree
108                  `(,@(unless (eqt key 'no-key) `(:key ,key))
109                    ,@(when test `(:test ,test))
110                    ,@(when test-not `(:test-not ,test-not))))))
111      (and (check-scaffold-copy new newcopy)
112           (check-scaffold-copy old oldcopy)
113           (check-scaffold-copy tree treecopy)
114           result))))
115
116
117(defun check-subst-if (new pred tree &key (key 'no-key))
118  "Call subst-if new pred tree, with various keyword arguments
119   if present.  Check that the arguments are not changed."
120  (setf new (copy-tree new))
121  (setf tree (copy-tree tree))
122  (let ((newcopy (make-scaffold-copy new))
123        (predcopy (make-scaffold-copy pred))
124        (treecopy (make-scaffold-copy tree)))
125    (let ((result
126           (apply #'subst-if new pred tree
127                  (unless (eqt key 'no-key) `(:key ,key)))))
128      (and (check-scaffold-copy new newcopy)
129           (check-scaffold-copy pred predcopy)
130           (check-scaffold-copy tree treecopy)
131           result))))
132
133(defun check-subst-if-not (new pred tree &key (key 'no-key))
134  "Call subst-if-not new pred tree, with various keyword arguments
135   if present.  Check that the arguments are not changed."
136  (setf new (copy-tree new))
137  (setf tree (copy-tree tree))
138  (let ((newcopy (make-scaffold-copy new))
139        (predcopy (make-scaffold-copy pred))
140        (treecopy (make-scaffold-copy tree)))
141    (let ((result
142           (apply #'subst-if-not new pred tree
143                  (unless (eqt key 'no-key) `(:key ,key)))))
144      (and (check-scaffold-copy new newcopy)
145           (check-scaffold-copy pred predcopy)
146           (check-scaffold-copy tree treecopy)
147           result))))
148
149(defun check-nsubst (new old tree &key (key 'no-key) test test-not)
150  "Call nsubst new old tree, with keyword arguments if present."
151  (setf new (copy-tree new))
152  (setf old (copy-tree old))
153  (setf tree (copy-tree tree))
154  (apply #'nsubst new old tree
155         `(,@(unless (eqt key 'no-key) `(:key ,key))
156             ,@(when test `(:test ,test))
157             ,@(when test-not `(:test-not ,test-not)))))
158
159(defun check-nsubst-if (new pred tree &key (key 'no-key))
160  "Call nsubst-if new pred tree, with keyword arguments if present."
161  (setf new (copy-tree new))
162  (setf tree (copy-tree tree))
163  (apply #'nsubst-if new pred tree
164         (unless (eqt key 'no-key) `(:key ,key))))
165
166(defun check-nsubst-if-not (new pred tree &key (key 'no-key))
167  "Call nsubst-if-not new pred tree, with keyword arguments if present."
168  (setf new (copy-tree new))
169  (setf tree (copy-tree tree))
170  (apply #'nsubst-if-not new pred tree
171                  (unless (eqt key 'no-key) `(:key ,key))))
172
173(defun check-copy-list-copy (x y)
174  "Check that y is a copy of the list x."
175  (if
176      (consp x)
177      (and (consp y)
178           (not (eqt x y))
179           (eqt (car x) (car y))
180           (check-copy-list-copy (cdr x) (cdr y)))
181    (and (eqt x y) t)))
182
183(defun check-copy-list (x)
184  "Apply copy-list, checking that it properly copies,
185   and checking that it does not change its argument."
186  (let ((xcopy (make-scaffold-copy x)))
187    (let ((y (copy-list x)))
188      (and
189       (check-scaffold-copy x xcopy)
190       (check-copy-list-copy x y)
191       y))))
192
193(defun append-6-body ()
194  (let* ((cal (min 2048 call-arguments-limit))
195         (step (max 1 (floor (/ cal) 64))))
196    (loop
197     for n from 0
198     below cal
199     by step
200     count
201     (not
202      (equal
203       (apply #'append (loop for i from 1 to n
204                             collect '(a)))
205       (make-list n :initial-element 'a))))))
206
207(defun is-intersection (x y z)
208  "Check that z is the intersection of x and y."
209  (and
210   (listp x)
211   (listp y)
212   (listp z)
213   (loop for e in x
214         always (or (not (member e y))
215                    (member e z)))
216   (loop for e in y
217         always (or (not (member e x))
218                    (member e z)))
219   (loop for e in z
220         always (and (member e x) (member e y)))
221   t))
222
223(defun shuffle (x)
224  (cond
225   ((null x) nil)
226   ((null (cdr x)) x)
227   (t
228    (multiple-value-bind
229        (y z)
230        (split-list x)
231      (append (shuffle y) (shuffle z))))))
232
233(defun split-list (x)
234  (cond
235   ((null x) (values nil nil))
236   ((null (cdr x)) (values x nil))
237   (t
238    (multiple-value-bind
239        (y z)
240        (split-list (cddr x))
241      (values (cons (car x) y) (cons (cadr x) z))))))
242
243(defun intersection-12-body (size niters &optional (maxelem (* 2 size)))
244  (let ((state (make-random-state)))
245    (loop
246     for i from 1 to niters do
247     (let ((x (shuffle (loop for j from 1 to size
248                             collect (random maxelem state))))
249           (y (shuffle (loop for j from 1 to size
250                             collect (random maxelem state)))))
251       (let ((z (intersection x y)))
252         (let ((is-good (is-intersection x y z)))
253           (unless is-good (return (values x y z)))))))
254    nil))
255
256(defun nintersection-with-check (x y &key test)
257  (let ((ycopy (make-scaffold-copy y)))
258    (let ((result (if test
259                      (nintersection x y :test test)
260                    (nintersection x y))))
261      (if (check-scaffold-copy y ycopy)
262          result
263        'failed))))
264
265(defun nintersection-12-body (size niters &optional (maxelem (* 2 size)))
266  (let ((state (make-random-state t)))
267    (loop
268     for i from 1 to niters do
269     (let ((x (shuffle (loop for j from 1 to size
270                             collect (random maxelem state))))
271           (y (shuffle (loop for j from 1 to size
272                             collect (random maxelem state)))))
273       (let ((z (nintersection-with-check (copy-list x) y)))
274         (when (eqt z 'failed) (return (values x y z)))
275         (let ((is-good (is-intersection x y z)))
276           (unless is-good (return (values x y z)))))))
277    nil))
278
279
280(defun union-with-check (x y &key test test-not)
281  (let ((xcopy (make-scaffold-copy x))
282        (ycopy (make-scaffold-copy y)))
283    (let ((result (cond
284                   (test (union x y :test test))
285                   (test-not (union x y :test-not test-not))
286                   (t (union x y)))))
287      (if (and (check-scaffold-copy x xcopy)
288               (check-scaffold-copy y ycopy))
289          result
290        'failed))))
291
292(defun union-with-check-and-key (x y key &key test test-not)
293  (let ((xcopy (make-scaffold-copy x))
294        (ycopy (make-scaffold-copy y)))
295    (let ((result  (cond
296                   (test (union x y :key key :test test))
297                   (test-not (union x y :key key :test-not test-not))
298                   (t (union x y :key key)))))
299      (if (and (check-scaffold-copy x xcopy)
300               (check-scaffold-copy y ycopy))
301          result
302        'failed))))
303
304(defun check-union (x y z)
305  (and (listp x)
306       (listp y)
307       (listp z)
308       (loop for e in z always (or (member e x) (member e y)))
309       (loop for e in x always (member e z))
310       (loop for e in y always (member e z))
311       t))
312
313(defun do-random-unions (size niters &optional (maxelem (* 2 size)))
314  (let ((state (make-random-state)))
315    (loop
316       for i from 1 to niters do
317          (let ((x (shuffle (loop for j from 1 to size collect
318                                  (random maxelem state))))
319                (y (shuffle (loop for j from 1 to size collect
320                                  (random maxelem state)))))
321            (let ((z (union x y)))
322              (let ((is-good (check-union x y z)))
323                (unless is-good (return (values x y z)))))))
324    nil))
325
326(defun nunion-with-copy (x y &key test test-not)
327  (setf x (copy-list x))
328  (setf y (copy-list y))
329  (cond
330   (test (nunion x y :test test))
331   (test-not (nunion x y :test-not test-not))
332   (t (nunion x y))))
333
334(defun nunion-with-copy-and-key (x y key &key test test-not)
335  (setf x (copy-list x))
336  (setf y (copy-list y))
337  (cond
338   (test (nunion x y :key key :test test))
339   (test-not (nunion x y :key key :test-not test-not))
340   (t (nunion x y :key key))))
341
342(defun do-random-nunions (size niters &optional (maxelem (* 2 size)))
343  (let ((state (make-random-state)))
344    (loop
345       for i from 1 to niters do
346          (let ((x (shuffle (loop for j from 1 to size collect
347                                  (random maxelem state))))
348                (y (shuffle (loop for j from 1 to size collect
349                                  (random maxelem state)))))
350            (let ((z (nunion-with-copy x y)))
351              (let ((is-good (check-union x y z)))
352                (unless is-good (return (values x y z)))))))
353    nil))
354
355(defun set-difference-with-check (x y &key (key 'no-key)
356                                           test test-not)
357  (setf x (copy-list x))
358  (setf y (copy-list y))
359  (let ((xcopy (make-scaffold-copy x))
360        (ycopy (make-scaffold-copy y)))
361    (let ((result (apply #'set-difference
362                         x y
363                         `(,@(unless (eqt key 'no-key) `(:key ,key))
364                           ,@(when test `(:test ,test))
365                           ,@(when test-not `(:test-not ,test-not)))))) 
366      (cond
367       ((and (check-scaffold-copy x xcopy)
368             (check-scaffold-copy y ycopy))
369        result)
370       (t
371        'failed)))))
372
373(defun check-set-difference (x y z &key (key #'identity)
374                                        (test #'eql))
375  (and
376   ;; (not (eqt 'failed z))
377   (listp x)
378   (listp y)
379   (listp z)
380   (loop for e in z always (member e x :key key :test test))
381   (loop for e in x always (or (member e y :key key :test test)
382                               (member e z :key key :test test)))
383   (loop for e in y never  (member e z :key key :test test))
384   t))
385
386(defun do-random-set-differences (size niters &optional (maxelem (* 2 size)))
387  (let ((state (make-random-state)))
388    (loop
389     for i from 1 to niters do
390     (let ((x (shuffle (loop for j from 1 to size collect
391                             (random maxelem state))))
392           (y (shuffle (loop for j from 1 to size collect
393                             (random maxelem state)))))
394       (let ((z (set-difference-with-check x y)))
395         (let ((is-good (check-set-difference x y z)))
396           (unless is-good (return (values x y z)))))))
397    nil))
398(defun nset-difference-with-check (x y &key (key 'no-key)
399                                     test test-not)
400  (setf x (copy-list x))
401  (setf y (copy-list y))
402  (apply #'nset-difference
403         x y
404         `(,@(unless (eqt key 'no-key) `(:key ,key))
405             ,@(when test `(:test ,test))
406             ,@(when test-not `(:test-not ,test-not)))))
407
408(defun check-nset-difference (x y z &key (key #'identity)
409                                (test #'eql))
410  (and
411   (listp x)
412   (listp y)
413   (listp z)
414   (loop for e in z always (member e x :key key :test test))
415   (loop for e in x always (or (member e y :key key :test test)
416                               (member e z :key key :test test)))
417   (loop for e in y never  (member e z :key key :test test))
418   t))
419
420(defun do-random-nset-differences (size niters &optional (maxelem (* 2 size)))
421  (let ((state (make-random-state)))
422    (loop
423     for i from 1 to niters do
424     (let ((x (shuffle (loop for j from 1 to size collect
425                             (random maxelem state))))
426           (y (shuffle (loop for j from 1 to size collect
427                             (random maxelem state)))))
428       (let ((z (nset-difference-with-check x y)))
429         (let ((is-good (check-nset-difference x y z)))
430           (unless is-good (return (values x y z)))))))
431    nil))
432
433(defun set-exclusive-or-with-check (x y &key (key 'no-key)
434                                      test test-not)
435  (setf x (copy-list x))
436  (setf y (copy-list y))
437  (let ((xcopy (make-scaffold-copy x))
438        (ycopy (make-scaffold-copy y)))
439    (let ((result (apply #'set-exclusive-or
440                         x y
441                         `(,@(unless (eqt key 'no-key) `(:key ,key))
442                             ,@(when test `(:test ,test))
443                             ,@(when test-not `(:test-not ,test-not)))))) 
444      (cond
445       ((and (check-scaffold-copy x xcopy)
446             (check-scaffold-copy y ycopy))
447        result)
448       (t
449        'failed)))))
450
451(defun check-set-exclusive-or (x y z &key (key #'identity)
452                                 (test #'eql))
453  (and
454   ;; (not (eqt 'failed z))
455   (listp x)
456   (listp y)
457   (listp z)
458   (loop for e in z always (or (member e x :key key :test test)
459                               (member e y :key key :test test)))
460   (loop for e in x always (if (member e y :key key :test test)
461                               (not (member e z :key key :test test))
462                             (member e z :key key :test test)))
463   (loop for e in y always (if (member e x :key key :test test)
464                               (not (member e z :key key :test test))
465                             (member e z :key key :test test)))
466   t))
467
468#|
469(defun do-random-set-exclusive-ors (size niters &optional (maxelem (* 2 size)))
470  (let ((state (make-random-state)))
471    (loop
472     for i from 1 to niters do
473     (let ((x (shuffle (loop for j from 1 to size collect
474                             (random maxelem state))))
475           (y (shuffle (loop for j from 1 to size collect
476                             (random maxelem state)))))
477       (let ((z (set-exclusive-or-with-check x y)))
478         (let ((is-good (check-set-exclusive-or x y z)))
479           (unless is-good (return (values x y z)))))))
480    nil))
481|#
482
483(defun nset-exclusive-or-with-check (x y &key (key 'no-key)
484                                       test test-not)
485  (setf x (copy-list x))
486  (setf y (copy-list y))
487  (apply #'nset-exclusive-or
488         x y
489         `(,@(unless (eqt key 'no-key) `(:key ,key))
490             ,@(when test `(:test ,test))
491             ,@(when test-not `(:test-not ,test-not)))))
492
493#|
494(defun do-random-nset-exclusive-ors (size niters &optional (maxelem (* 2 size)))
495  (let ((state (make-random-state)))
496    (loop
497     for i from 1 to niters do
498     (let ((x (shuffle (loop for j from 1 to size collect
499                             (random maxelem state))))
500           (y (shuffle (loop for j from 1 to size collect
501                             (random maxelem state)))))
502       (let ((z (nset-exclusive-or-with-check x y)))
503         (let ((is-good (check-set-exclusive-or x y z)))
504           (unless is-good (return (values x y z)))))))
505    nil))
506|#
507
508(defun subsetp-with-check (x y &key (key 'no-key) test test-not)
509  (let ((xcopy (make-scaffold-copy x))
510        (ycopy (make-scaffold-copy y)))
511    (let ((result
512           (apply #'subsetp x y
513                  `(,@(unless (eqt key 'no-key)
514                        `(:key ,key))
515                      ,@(when test `(:test ,test))
516                      ,@(when test-not `(:test-not ,test-not))))))
517      (cond
518       ((and (check-scaffold-copy x xcopy)
519             (check-scaffold-copy y ycopy))
520        (not (not result)))
521       (t 'failed)))))
522
523(defun my-set-exclusive-or (set1 set2 &key key test test-not)
524
525  (assert (not (and test test-not)))
526
527  (cond
528   (test-not (when (symbolp test-not)
529               (setq test-not (symbol-function test-not)))
530             (setq test (complement test-not)))
531   ((not test) (setq test #'eql)))
532
533  ;;; (when (symbolp test) (setq test (symbol-function test)))
534  (etypecase test
535    (symbol (setq test (symbol-function test)))
536    (function nil))
537
538  (etypecase key
539    (null nil)
540    (symbol (setq key (symbol-function key)))
541    (function nil))
542
543  (let* ((keys1 (if key (mapcar (the function key) set1) set1))
544         (keys2 (if key (mapcar (the function key) set2) set2))
545         (mask1 (make-array (length set1) :element-type 'bit
546                            :initial-element 0))
547         (mask2 (make-array (length set2) :element-type 'bit
548                            :initial-element 0)))
549    (loop for i1 from 0
550          for k1 in keys1
551          do
552          (loop for i2 from 0
553                for k2 in keys2
554                when (funcall (the function test) k1 k2)
555                do (setf (sbit mask1 i1) 1
556                         (sbit mask2 i2) 1)))
557    (nconc
558     (loop for e in set1
559           for i across mask1
560           when (= i 0)
561           collect e)
562     (loop for e in set2
563           for i across mask2
564           when (= i 0)
565           collect e))))
566
567(defun make-random-set-exclusive-or-input (n)
568  (let* ((set1 (loop for i from 1 to n collect (random n)))
569         (set2 (loop for i from 1 to n collect (random n)))
570         (test-args
571          (random-case nil nil nil
572                       (list :test 'eql)
573                       (list :test #'eql)
574                       (list :test (complement #'eql))))
575         (test-not-args
576          (and (not test-args)
577               (random-case nil nil (list :test-not 'eql)
578                            (list :test-not #'eql)
579                            (list :test-not (complement #'eql)))))
580         (key-args
581          (random-case nil nil nil nil
582                       (list :key nil)
583                       (list :key 'identity)
584                       (list :key 'not))))
585    (list* set1 set2
586          (reduce #'append (random-permute
587                            (list test-args test-not-args key-args))))))
588
589(defun random-set-exclusive-or-test (n reps &optional (fn 'set-exclusive-or))
590  (let ((actual-fn (etypecase fn
591                     (symbol (symbol-function fn))
592                     (function fn))))
593    (declare (type function actual-fn))
594    (loop for i below reps
595          for args = (make-random-set-exclusive-or-input n)
596          for set1 = (car args)
597          for set2 = (cadr args)
598          for result1 = (apply #'remove-duplicates
599                               (sort (copy-list (apply #'my-set-exclusive-or args))
600                                     #'<)
601                               (cddr args))
602          for result2 = (apply #'remove-duplicates
603                               (sort (copy-list (apply actual-fn
604                                                       (copy-list set1)
605                                                       (copy-list set2)
606                                                       (cddr args)))
607                                     #'<)
608                               (cddr args))
609          unless (equal result1 result2)
610          return (list (list 'remove-duplicates (list 'sort (cons fn args) '<) "...")
611                       "actual: " result2 "should be: " result1))))
612
613(defun rev-assoc-list (x)
614  (cond
615   ((null x) nil)
616   ((null (car x))
617    (cons nil (rev-assoc-list (cdr x))))
618   (t
619    (acons (cdar x) (caar x) (rev-assoc-list (cdr x))))))
620
621(defvar *mapc.6-var* nil)
622(defun mapc.6-fun (x)
623  (push x *mapc.6-var*)
624  x)
Note: See TracBrowser for help on using the repository browser.