/[gcl]/gcl/ansi-tests/cons-aux.lsp
ViewVC logotype

Diff of /gcl/ansi-tests/cons-aux.lsp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.3 by pfdietz, Sun Apr 20 13:17:45 2003 UTC revision 1.4 by pfdietz, Sat Jul 12 13:46:01 2003 UTC
# Line 15  Line 15 
15               (setq test (complement test-not)))               (setq test (complement test-not)))
16     ((not test) (setq test #'eql)))     ((not test) (setq test #'eql)))
17    
18    (when (symbolp test) (setq test (symbol-function test)))            ;;; (when (symbolp test) (setq test (symbol-function test)))
19      (etypecase test
20        (symbol (setq test (symbol-function test)))
21        (function nil))
22    
23    (let* ((keys1 (if key (mapcar key set1) set1))    (etypecase key
24           (keys2 (if key (mapcar key set2) set2))      (null nil)
25        (symbol (setq key (symbol-function key)))
26        (function nil))
27    
28      (let* ((keys1 (if key (mapcar (the function key) set1) set1))
29             (keys2 (if key (mapcar (the function key) set2) set2))
30           (mask1 (make-array (length set1) :element-type 'bit           (mask1 (make-array (length set1) :element-type 'bit
31                              :initial-element 0))                              :initial-element 0))
32           (mask2 (make-array (length set2) :element-type 'bit           (mask2 (make-array (length set2) :element-type 'bit
# Line 28  Line 36 
36            do            do
37            (loop for i2 from 0            (loop for i2 from 0
38                  for k2 in keys2                  for k2 in keys2
39                  when (funcall test k1 k2)                  when (funcall (the function test) k1 k2)
40                  do (setf (sbit mask1 i1) 1                  do (setf (sbit mask1 i1) 1
41                           (sbit mask2 i2) 1)))                           (sbit mask2 i2) 1)))
42      (nconc      (nconc
# Line 64  Line 72 
72                              (list test-args test-not-args key-args))))))                              (list test-args test-not-args key-args))))))
73    
74  (defun random-set-exclusive-or-test (n reps &optional (fn 'set-exclusive-or))  (defun random-set-exclusive-or-test (n reps &optional (fn 'set-exclusive-or))
75    (loop for i below reps    (let ((actual-fn (etypecase fn
76          for args = (make-random-set-exclusive-or-input n)                       (symbol (symbol-function fn))
77          for set1 = (car args)                       (function fn))))
78          for set2 = (cadr args)      (declare (type function actual-fn))
79          for result1 = (apply #'remove-duplicates      (loop for i below reps
80                               (sort (copy-list (apply #'my-set-exclusive-or args))            for args = (make-random-set-exclusive-or-input n)
81                                     #'<)            for set1 = (car args)
82                               (cddr args))            for set2 = (cadr args)
83          for result2 = (apply #'remove-duplicates            for result1 = (apply #'remove-duplicates
84                               (sort (copy-list (apply fn                                 (sort (copy-list (apply #'my-set-exclusive-or args))
85                                                       (copy-list set1)                                       #'<)
86                                                       (copy-list set2)                                 (cddr args))
87                                                       (cddr args)))            for result2 = (apply #'remove-duplicates
88                                     #'<)                                 (sort (copy-list (apply actual-fn
89                               (cddr args))                                                         (copy-list set1)
90          unless (equal result1 result2)                                                         (copy-list set2)
91          return (list (list 'remove-duplicates (list 'sort (cons fn args) '<) "...")                                                         (cddr args)))
92                       "actual: " result2 "should be: " result1)))                                       #'<)
93                                   (cddr args))
94              unless (equal result1 result2)
95              return (list (list 'remove-duplicates (list 'sort (cons fn args) '<) "...")
96                           "actual: " result2 "should be: " result1))))
97    
98  (defun rev-assoc-list (x)  (defun rev-assoc-list (x)
99    (cond    (cond

Legend:
Removed from v.1.3  
changed lines
  Added in v.1.4

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26