source: trunk/source/tests/ansi-tests/random-type-prop.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: 23.0 KB
Line 
1;-*- Mode:     Lisp -*-
2;;;; Author:   Paul Dietz
3;;;; Created:  Thu Dec 23 20:39:22 2004
4;;;; Contains: Randomized tests of type propagation in the compiler
5
6(in-package :cl-test)
7
8(eval-when (:compile-toplevel :load-toplevel)
9  (compile-and-load "random-aux.lsp")
10  (compile-and-load "random-int-form.lsp"))
11
12(defvar *print-random-type-prop-input* nil)
13(defparameter *random-type-prop-result* nil)
14
15(declaim (special *param-types* *params* *is-var?* *form*))
16(declaim (special *replicate-type*))
17
18(defparameter *default-reps* 1000)
19(defparameter *default-cell* nil)
20(defparameter *default-ignore* 'arithmetic-error)
21(defparameter *default-arg-the* t)
22
23;;;
24;;; The random type prop tester takes three required arguments:
25;;;
26;;;  operator  A lisp operator (either a symbol or a lambda form)
27;;;  arg-types A list consisting either of certain kinds of lisp types
28;;;            (that make-random-element-of-type understands) and/or
29;;;            functions that yield types.
30;;;  minargs   Minimum number of arguments to be given to the operator.
31;;;            Must be a positive integer <= maxargs.
32;;;
33;;; There are also keyword arguments, some with defaults given by special
34;;; variables.
35;;;
36;;; The random type prop tester generates between minargs and maxargs
37;;; (maxargs defaults to minargs) random arguments.  The type of each
38;;; argument is given by the corresponding type in arg-types (or by rest-type,
39;;; if there aren't enough elements of arg-types).  If the element of arg-types
40;;; is a function, the type for the parameter is produced by calling the function
41;;; with the previously generated actual parameters as its arguments.
42;;;
43;;; The list of parameters is stored into the special variable *params*.
44;;;
45;;; The tester evaluates (operator . arguments), and also builds a lambda
46;;; form to be compiled and called on (a subset of) the parameters.  The lambda
47;;; form is stored in the special variable *form*.
48;;;
49;;; The macro def-type-prop-test wraps a call to do-random-type-prop-tests
50;;; in a deftest form.  See random-type-prop-tests.lsp (and subfiles) for examples
51;;; of its use testing CL builtin operators.  To use it:
52;;;
53;;; (load "gclload1.lsp")
54;;; (compile-and-load "random-int-form.lsp") ;; do this on lisps not supporting recursive compiles
55;;; (compile-and-load "random-type-prop.lsp")
56;;; (in-package :cl-test)
57;;; (load "random-type-prop-tests.lsp")
58;;; (let (*catch-errors*) (do-test '<testname>))
59;;; or (let (*catch-errors*) (do-tests))
60;;;
61;;; Running all the tests may take a while, particularly on lisps with slow compilers.
62;;;
63;;;
64;;; Keyword arguments to do-random-type-prop-tests:
65;;;
66;;;  Argument    Default         Meaning
67;;;
68;;;  maxargs     minargs         Maximum number of actual parameters to generate (max 20).
69;;;  rest-type   t               Type of arguments beyond those specified in arg-types
70;;;  reps        *default-reps*  Number of repetitions to try before stopping.
71;;;                              The default is controlled by a special variable that
72;;;                              is initially 1000.
73;;;  enclosing-the nil           If true, with prob 1/2 randomly generate an enclosing
74;;;                              (THE ...) form around the form invoking the operator.
75;;;  arg-the     *default-arg-the*   If true (which is the initial value of the default
76;;;                              special variable), with probability 1/2 randomly generate
77;;;                              a (THE ...) form around each actual parameter.
78;;;  cell        *default-cell*  If true (default is NIL), store the result into a rank-0
79;;;                              array of specialized type.  This enables one to test
80;;;                              forms where the result will be unboxed.  Otherwise, just
81;;;                              return the values.
82;;;  ignore      *default-ignore*  Ignore conditions that are elements of IGNORE.  Default is
83;;;                              ARITHMETIC-ERROR.
84;;;  test        rt::equalp-with-case   The test function used to compare outputs.  It's
85;;;                              also handy to use #'approx= to handle approximate equality
86;;;                              when testing floating point computations, where compiled code
87;;;                              may have different roundoff errors.
88;;;  replicate   nil             Cause arguments to be copied (preserving sharing in conses
89;;;                              and arrays) before applying the operator.  This is used to test
90;;;                              destructive operators.
91;;;
92;;;
93                             
94(defun do-random-type-prop-tests
95  (operator arg-types minargs
96            &key
97            (maxargs minargs)
98            (rest-type t)
99            (reps *default-reps*)
100            (enclosing-the nil)
101            (arg-the *default-arg-the*)
102            (cell *default-cell*)
103            (ignore *default-ignore*)
104            (test #'regression-test::equalp-with-case)
105            (replicate nil replicate-p))
106  (assert (<= 1 minargs maxargs 20))
107(prog1
108  (dotimes (i reps)
109    again
110    (handler-bind
111     #-lispworks ((error #'(lambda (c) (when (typep c ignore) (go again)))))
112     #+lispworks ()
113    (let* ((param-names
114           '(p1 p2 p3 p4 p5 p6 p7 p8 p9 p10
115             p11 p12 p13 p14 p15 p16 p17 p18 p19 p20))
116          (nargs (+ minargs (random (- maxargs minargs -1))))
117          (types (subseq
118                  (append arg-types
119                          (make-list (max 0 (- nargs (length arg-types)))
120                                     :initial-element rest-type))
121                  0 nargs))
122          (replicate (if replicate-p replicate
123                       (mapcar (constantly nil) types)))
124          ; (vals (mapcar #'make-random-element-of-type types))
125          (vals (setq *params*
126                      (or (make-random-arguments types) (go again))))
127          (vals
128           (if replicate
129               (mapcar #'replicate vals)
130             vals))
131          (is-var? (if (consp replicate)
132                       (progn
133                         (assert (= (length replicate) (length vals)))
134                         (loop for x in replicate collect (or x (coin))))
135                     (loop repeat (length vals) collect (coin))))
136          (*is-var?* is-var?)
137          (params (loop for x in is-var?
138                        for p in param-names
139                        when x collect p))
140          (param-types (mapcar #'make-random-type-containing vals replicate))
141          (*param-types* param-types)
142          (type-decls (loop for x in is-var?
143                            for p in param-names
144                            for tp in param-types
145                            when x
146                            collect `(type ,tp ,p)))
147          (rval (cl:handler-bind
148                 (#+sbcl (sb-ext::compiler-note #'muffle-warning)
149                         (warning #'muffle-warning))
150                 (let* ((vals (if replicate (mapcar #'replicate vals) vals))
151                        (eval-form (cons operator (loop for v in vals
152                                                        collect `(quote ,v)))))
153                   ;; (print eval-form) (terpri)
154                   ;; (dotimes (i 100) (eval eval-form))
155                   (eval eval-form))))
156          (result-type (if (and enclosing-the (integerp rval))
157                           (make-random-type-containing rval)
158                         t))
159          (expr `(,operator ,@(loop for x in is-var?
160                                    for v in vals
161                                    for r in replicate
162                                    for p in param-names
163                                    collect (if x
164                                                (if (and arg-the (coin))
165                                                    (let ((tp (make-random-type-containing v r)))
166                                                      `(the ,tp ,p))
167                                                  p)
168                                              (if (or (consp v)
169                                                      (and (symbolp v) (not (or (keywordp v)
170                                                                                (member v '(nil t))))))
171                                                  `(quote ,v)
172                                                  v)))))
173          (speed (random 4))
174          (space (random 4))
175          (safety #-allegro (random 4)
176                  #+allegro (1+ (random 3)))
177          (debug (random 4))
178          (store-into-cell? (and cell (coin)))
179          (upgraded-result-type (and store-into-cell?
180                                     (upgraded-array-element-type `(eql ,rval))))
181          (form
182           (setq *form*
183                 `(lambda (,@(when store-into-cell? '(r)) ,@params)
184                    (declare (optimize (speed ,speed) (safety ,safety) (debug ,debug) (space ,space))
185                             ,@(when store-into-cell? `((type (simple-array ,upgraded-result-type nil) r)))
186                             ,@ type-decls)
187                    ,(let ((result-form
188                            (if enclosing-the `(the ,result-type ,expr) expr)))
189                       (if store-into-cell?
190                           `(setf (aref r) ,result-form)
191                         result-form)))))
192          )
193     (when *print-random-type-prop-input*
194       (let ((*print-pretty* t)
195             (*print-case* :downcase))
196         (print (list :form form :vals vals))))
197     (finish-output)
198     (let* ((param-vals (loop for x in is-var?
199                              for v in vals
200                              when x collect v))
201            (fn (cl:handler-bind
202                 (#+sbcl (sb-ext::compiler-note #'muffle-warning)
203                         (warning #'muffle-warning))
204                 (compile nil form)))
205            (result
206             (if store-into-cell?
207                 (let ((r (make-array nil :element-type upgraded-result-type)))
208                   (apply fn r param-vals)
209                   (aref r))
210               (apply fn param-vals))))
211       (setq *random-type-prop-result*
212             (list :upgraded-result-type upgraded-result-type
213                   :form form
214                   :vals vals
215                   :result result
216                   :rval rval))
217       (unless (funcall test result rval)
218         (return *random-type-prop-result*))))
219    ;; #+allegro (excl::gc t)
220  ))))
221
222(defun make-random-arguments (types-or-funs)
223  (let ((vals nil))
224    (loop for type-or-fun in types-or-funs
225          for type = (or (typecase type-or-fun
226                           ((and function (not symbol))
227                            (apply type-or-fun vals))
228                           (t type-or-fun))
229                         (return-from make-random-arguments nil) ;; null type
230                         )
231          for val = (make-random-element-of-type type)
232          do (setf vals (nconc vals (list val))))
233    ;; (dolist (v vals) (describe v))
234    vals))
235
236(defmacro defmethods (name &rest bodies)
237  `(progn
238     ,@(mapcar
239        #'(lambda (body) `(defmethod ,name ,@body))
240        bodies)))
241
242(defgeneric make-random-type-containing* (val)
243  (:method-combination randomized)
244  (:documentation "Produce a random type containing VAL.  If the special
245variable *REPLICATE-TYPE* is true, and the value is mutable, then do not
246use the value in MEMBER or EQL type specifiers."))
247
248(defun make-random-type-containing (type &optional *replicate-type*)
249  (declare (special *replicate-type*))
250  (make-random-type-containing* type))
251
252(defmethods make-random-type-containing*
253  (4 ((val t))
254     (declare (special *replicate-type*))
255     (rcase
256      (1 t)
257      (1 (if (consp val) 'cons 'atom))
258      (1 (if *replicate-type* (make-random-type-containing* val)
259           `(eql ,val)))
260      (1
261       (if *replicate-type* (make-random-type-containing* val)
262         (let* ((n1 (random 4))
263                (n2 (random 4))
264                ;; Replace these calls with (make-random-element-of-type t)
265                ;; at some point
266                (l1 (loop repeat n1 collect (random-leaf)))
267                (l2 (loop repeat n2 collect (random-leaf))))
268           `(member ,@l1 ,val ,@l2))))))
269
270  (1 ((val standard-object)) 'standard-object)
271  (1 ((val structure-object)) 'structure-object)
272  (1 ((val class)) 'class)
273  (1 ((val standard-class)) 'standard-class)
274  (1 ((val structure-class)) 'structure-class)
275  (1 ((val number)) 'number)
276  (1 ((val real)) 'real)
277  (1 ((val ratio)) 'ratio)
278
279  (1 ((val integer))
280     (rcase
281      (1 'integer)
282      (1 'signed-byte)
283      (1 (let* ((n1 (random 4))
284                (n2 (random 4))
285                (l1 (loop repeat n1 collect (make-random-integer)))
286                (l2 (loop repeat n2 collect (make-random-integer))))
287           `(member ,@l1 ,val ,@l2)))
288      (1 (let ((lo (abs (make-random-integer))))
289           `(integer ,(- val lo))))
290      (2 (let ((lo (abs (make-random-integer))))
291           `(integer ,(- val lo) *)))
292      (2 (let ((hi (abs (make-random-integer))))
293           `(integer * ,(+ val hi))))
294      (4 (let ((lo (abs (make-random-integer)))
295               (hi (abs (make-random-integer))))
296           `(integer ,(- val lo) ,(+ val hi))))
297      (1 (if (>= val 0) 'unsigned-byte (throw 'fail nil)))))
298
299  (2 ((val character))
300     (rcase
301      (1 'character)
302      (1 (if (typep val 'base-char) 'base-char
303           #-sbcl 'extended-char
304           #+sbcl (throw 'fail nil)
305           ))
306      (1 (if (typep val 'standard-char) 'standard-char (throw 'fail nil)))
307      (1 (let* ((n1 (random 4))
308                (n2 (random 4))
309                (l1 (loop repeat n1 collect (make-random-character)))
310                (l2 (loop repeat n2 collect (make-random-character))))
311           `(member ,@l1 ,val ,@l2)))))
312
313  (1 ((val null)) 'null)
314
315  (2 ((val symbol))
316     (rcase
317      (1 'symbol)
318      (1 (typecase val (boolean 'boolean) (keyword 'keyword) (otherwise (throw 'fail nil))))
319      (1 (let* ((n1 (random 4))
320                (n2 (random 4))
321                (l1 (loop repeat n1 collect (make-random-symbol)))
322                (l2 (loop repeat n2 collect (make-random-symbol))))
323           `(member ,@l1 ,val ,@l2)))))
324
325  (1 ((val rational))
326     (rcase
327      (1 'rational)
328      (1 (let* ((n1 (random 4))
329                (n2 (random 4))
330                (l1 (loop repeat n1 collect (make-random-element-of-type 'rational)))
331                (l2 (loop repeat n2 collect (make-random-element-of-type 'rational))))
332           `(member ,@l1 ,val ,@l2)))
333      (1 `(rational ,val))
334      (1 `(rational * ,val))
335      (1 (let ((v (make-random-element-of-type 'rational)))
336           (if (<= v val)
337               `(rational ,v ,val)
338             `(rational ,val ,v))))))
339 
340  (1 ((val float))
341     (rcase
342      (1 (let* ((n1 (random 4))
343                (n2 (random 4))
344                (l1 (loop repeat n1 collect (- 2 (random (float 1.0 val)))))
345                (l2 (loop repeat n2 collect (- 2 (random (float 1.0 val))))))
346           `(member ,@l1 ,val ,@l2)))
347      (1 (let ((names (float-types-containing val)))
348           (random-from-seq names)))
349      (1 (let ((name (random-from-seq (float-types-containing val))))
350           (if (>= val 0)
351               `(,name ,(coerce 0 name) ,val)
352             `(,name ,val ,(coerce 0 name)))))))
353  )
354
355(defun float-types-containing (val)
356  (loop for n in '(short-float single-float double-float long-float float)
357        when (typep val n)
358        collect n))     
359
360(defun make-random-array-dimension-spec (array dim-index)
361  (assert (<= 0 dim-index))
362  (assert (< dim-index (array-rank array)))
363  (let ((dim (array-dimension array dim-index)))
364    (rcase (1 '*) (1 dim))))
365
366;;; More methods
367(defmethods make-random-type-containing*
368  (3 ((val bit-vector))
369     (let ((root (if (and (coin)
370                          (typep val 'simple-bit-vector))
371                     'simple-bit-vector
372                   'bit-vector)))
373       (rcase (1 root)
374              (1 `(,root))
375              (3 `(,root ,(make-random-array-dimension-spec val 0))))))
376
377  (3 ((val vector))
378     (let ((root 'vector)
379            (alt-root (if (and (coin) (simple-vector-p val)) 'simple-vector 'vector))
380            (etype (rcase (1 '*)
381                          (1 (array-element-type val))
382                          ;; Add rule for creating new element types?
383                          )))
384        (rcase (1 alt-root)
385               (1 `(,alt-root))
386               (1 `(,root ,etype))
387               (2 (if (and (simple-vector-p val) (coin))
388                      `(simple-vector ,(make-random-array-dimension-spec val 0))
389                    `(,root ,etype ,(make-random-array-dimension-spec val 0)))))))
390
391  (3 ((val array))
392     (let ((root (if (and (coin) (typep val 'simple-array)) 'simple-array 'array))
393        (etype (rcase (1 (array-element-type val)) (1 '*)))
394        (rank (array-rank val)))
395       (rcase
396        (1 root)
397        (1 `(,root))
398        (1 `(,root ,etype))
399        (1 `(,root ,etype ,(loop for i below rank collect (make-random-array-dimension-spec val i))))
400        (1 `(,root ,etype ,(loop for i below rank collect (array-dimension val i))))
401        #-ecl (1 `(,root ,etype ,rank)))))
402
403  (3 ((val string))
404     (let ((root (cond
405                  ((and (coin)
406                        (typep val 'base-string))
407                   (cond
408                    ((and (coin) (typep val 'simple-base-string))
409                     'simple-base-string)
410                    (t 'base-string)))
411                  ((and (coin)
412                        (typep val 'simple-string))
413                   'simple-string)
414                  (t 'string))))
415       (rcase (1 root)
416              (1 `(,root))
417              (3 `(,root ,(make-random-array-dimension-spec val 0))))))
418
419  (1 ((val list)) 'list)
420
421  (1 ((val cons))
422     (rcase
423      (1 'cons)
424      (2 `(cons ,(make-random-type-containing* (car val))
425                ,(make-random-type-containing* (cdr val))))
426      (1 `(cons ,(make-random-type-containing* (car val))
427                ,(random-from-seq #(t *))))
428      (1 `(cons ,(make-random-type-containing* (car val))))
429      (1 `(cons ,(random-from-seq #(t *))
430                ,(make-random-type-containing* (cdr val))
431                ))))
432
433  (1 ((val complex))
434     (rcase
435      (1 'complex)
436      #-gcl
437      (1 (let* ((t1 (type-of (realpart val)))
438                (t2 (type-of (imagpart val)))
439                (part-type
440                 (cond
441                  ((subtypep t1 t2) (upgraded-complex-part-type t2))
442                  ((subtypep t2 t1) (upgraded-complex-part-type t1))
443                  ((and (subtypep t1 'rational)
444                        (subtypep t2 'rational))
445                   'rational)
446                  (t
447                   (upgraded-complex-part-type `(or ,t1 ,t2))))))
448           (if (subtypep 'real part-type)
449               '(complex real)
450             `(complex ,part-type))))))
451
452  (1 ((val generic-function)) 'generic-function)
453  (1 ((val function))
454     (rcase
455      (1 'function)
456      (1 (if (typep val 'compiled-function)
457             'compiled-function
458           'function))))
459  )
460
461;;; Macro for defining random type prop tests
462
463(defmacro def-type-prop-test (name &body args)
464  `(deftest ,(intern (concatenate 'string "RANDOM-TYPE-PROP."
465                                  (string name))
466                     (find-package :cl-test))
467     (do-random-type-prop-tests ,@args)
468     nil))
469
470;;; Function used in constructing list types for some random type prop tests
471
472(defun make-list-type (length &optional (rest-type 'null) (element-type t))
473  (let ((result rest-type))
474    (loop repeat length
475          do (setq result `(cons ,element-type ,result)))
476    result))
477
478(defun make-sequence-type (length &optional (element-type t))
479  (rcase
480   (1 `(vector ,element-type ,length))
481   (1 `(array ,element-type (,length)))
482   (1 `(simple-array ,element-type (,length)))
483   (2 (make-list-type length 'null element-type))))
484
485(defun make-random-sequence-type-containing (element &optional *replicate-type*)
486  (make-sequence-type (random 10) (make-random-type-containing* element)))
487
488(defun same-set-p (set1 set2 &rest args &key key test test-not)
489  (declare (ignorable key test test-not))
490  (and (apply #'subsetp set1 set2 args)
491       (apply #'subsetp set2 set2 args)
492       t))
493
494(defun index-type-for-dim (dim)
495  "Returns a function that computes integer type for valid indices
496   of an array dimension, or NIL if there are none."
497  #'(lambda (array &rest other)
498      (declare (ignore other))
499      (let ((d (array-dimension array dim)))
500        (and (> d 0) `(integer 0 (,d))))))
501
502(defun index-type-for-v1 (v1 &rest other)
503  "Computes integer type for valid indices for the first of two vectors"
504  (declare (ignore other))
505  (let ((d (length v1))) `(integer 0 ,d)))
506
507(defun index-type-for-v2 (v1 v2 &rest other)
508  "Computes integer type for valid indices for the second of two vectors"
509  (declare (ignore v1 other))
510  (let ((d (length v2))) `(integer 0 ,d)))
511
512(defun end-type-for-v1 (v1 v2 &rest other)
513  (declare (ignore v2))
514  (let ((d (length v1))
515        (start1 (or (cadr (member :start1 other)) 0)))
516    `(integer ,start1 ,d)))
517
518(defun end-type-for-v2 (v1 v2 &rest other)
519  (declare (ignore v1))
520  (let ((d (length v2))
521        (start2 (or (cadr (member :start2 other)) 0)))
522    `(integer ,start2 ,d)))
523
524
525;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
526
527(defgeneric replicate (obj)
528  (:documentation "Copies the structure of a lisp object recursively, preserving sharing."))
529
530(defmacro replicate-with ((source-obj dest-obj copy-form) &body body)
531  `(or (gethash ,source-obj *replicate-table*)
532       (let ((,dest-obj ,copy-form))
533         (setf (gethash ,source-obj *replicate-table*) ,dest-obj)
534         ,@body
535         ,dest-obj)))
536
537(declaim (special *replicate-table*))
538
539(defmethod replicate :around ((obj t))
540  "Wrapper to create a hash table for structure sharing, if none exists."
541  (if (boundp '*replicate-table*)
542      (call-next-method obj)
543    (let ((*replicate-table* (make-hash-table)))
544      (call-next-method obj))))
545
546(defmethod replicate ((obj cons))
547  (or (gethash obj *replicate-table*)
548      (let ((x (cons nil nil)))
549        (setf (gethash obj *replicate-table*) x)
550        (setf (car x) (replicate (car obj)))
551        (setf (cdr x) (replicate (cdr obj)))
552        x)))
553
554;;; Default method for objects without internal structure
555(defmethod replicate ((obj t)) obj)
556
557(defmethod replicate ((obj array))
558  (multiple-value-bind
559      (new-obj old-leaf new-leaf)
560      (replicate-displaced-array obj)
561    (when new-leaf
562      (loop for i below (array-total-size new-leaf)
563            do (setf (row-major-aref new-leaf i)
564                     (row-major-aref old-leaf i))))
565    new-obj))
566
567(defun replicate-displaced-array (obj)
568  "Replicate the non-terminal (and not already replicated) arrays
569   in a displaced array chain.  Return the new root array, the
570   old leaf array, and the new (but empty) leaf array.  The latter
571   two are NIL if the leaf did not have to be copied again."
572  (or (gethash obj *replicate-table*)
573      (multiple-value-bind
574          (displaced-to displaced-index-offset)
575          (array-displacement obj)
576        (let ((dims (array-dimensions obj))
577              (element-type (array-element-type obj))
578              (fill-pointer (and (array-has-fill-pointer-p obj)
579                                 (fill-pointer obj)))
580              (adj (adjustable-array-p obj)))
581          (if displaced-to
582              ;; The array is displaced
583              ;; Copy recursively
584              (multiple-value-bind
585                  (new-displaced-to old-leaf new-leaf)
586                  (replicate-displaced-array displaced-to)
587                (let ((new-obj (make-array dims :element-type element-type
588                                           :fill-pointer fill-pointer
589                                           :adjustable adj
590                                           :displaced-to new-displaced-to
591                                           :displaced-index-offset displaced-index-offset)))
592                  (setf (gethash obj *replicate-table*) new-obj)
593                  (values new-obj old-leaf new-leaf)))
594            ;; The array is not displaced
595            ;; This is the leaf array
596            (let ((new-obj (make-array dims :element-type element-type
597                                       :fill-pointer fill-pointer
598                                       :adjustable adj)))
599              (setf (gethash obj *replicate-table*) new-obj)
600              (values new-obj obj new-obj)))))))
601
602;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
603
604(declaim (special *isomorphism-table*))
605
606(defun isomorphic-p (obj1 obj2)
607  (let ((*isomorphism-table* (make-hash-table)))
608    (isomorphic-p* obj1 obj2)))
609
610(defgeneric isomorphic-p* (obj1 obj2)
611  (:documentation
612   "Returns true iff obj1 and obj2 are 'isomorphic' (that is, have the same structure,
613    including the same leaf values and the same pattern of sharing).  It should be
614    the case that (isomorphic-p obj (replicate obj)) is true."))
615
616(defmethod isomorphic-p* ((obj1 t) (obj2 t))
617  (eql obj1 obj2))
618
619(defmethod isomorphic-p* ((obj1 cons) (obj2 cons))
620  (let ((previous (gethash obj1 *isomorphism-table*)))
621    (cond
622     (previous
623      ;; If we've already produced a mapping from obj1 to something,
624      ;; isomorphism requires that obj2 be that object
625      (eq previous obj2))
626     ;; Otherwise, assume obj1 will map to obj2 and recurse
627     (t
628      (setf (gethash obj1  *isomorphism-table*) obj2)
629      (and (isomorphic-p* (car obj1) (car obj2))
630           (isomorphic-p* (cdr obj1) (cdr obj2)))))))
631
632(defmethod isomorphic-p* ((obj1 array) (obj2 array))
633  (let ((previous (gethash obj1 *isomorphism-table*)))
634    (cond
635     (previous
636      ;; If we've already produced a mapping from obj1 to something,
637      ;; isomorphism requires that obj2 be that object
638      (eq previous obj2))
639     (t
640      (setf (gethash obj1 *isomorphism-table*) obj2)
641      (and (equal (array-dimensions obj1) (array-dimensions obj2))
642           (equal (array-element-type obj1) (array-element-type obj2))
643           (if (array-has-fill-pointer-p obj1)
644               (and (array-has-fill-pointer-p obj2)
645                    (eql (fill-pointer obj1) (fill-pointer obj2)))
646             (not (array-has-fill-pointer-p obj2)))
647           (let (to-1 (index-1 0) to-2 (index-2 0))
648             (multiple-value-setq (to-1 index-1) (array-displacement obj1))
649             (multiple-value-setq (to-2 index-2) (array-displacement obj2))
650             (if to-1
651                 (and to-2
652                      (eql index-1 index-2)
653                      (isomorphic-p* to-1 to-2))
654               ;; Not displaced -- recurse on elements
655               (let ((total-size (array-total-size obj1)))
656                 (loop for i below total-size
657                       always (isomorphic-p* (row-major-aref obj1 i)
658                                             (row-major-aref obj2 i)))))))))))
659
660;;; Test that sequences have identical elements
661
662(defun equalp-and-eql-elements (s1 s2)
663  (and (equalp s1 s2)
664       (every #'eql s1 s2)))
Note: See TracBrowser for help on using the repository browser.