random-type-prop.lsp 26.6 KB
Newer Older
1 2 3 4 5 6 7
;-*- Mode:     Lisp -*-
;;;; Author:   Paul Dietz
;;;; Created:  Thu Dec 23 20:39:22 2004
;;;; Contains: Randomized tests of type propagation in the compiler

(in-package :cl-test)

8 9
(eval-when (:compile-toplevel :load-toplevel)
  (compile-and-load "random-aux.lsp")
10 11
  (compile-and-load "random-int-form.lsp"))

12 13 14
(defvar *print-random-type-prop-input* nil)
(defparameter *random-type-prop-result* nil)

15
(declaim (special *param-types* *params* *is-var?* *form*))
pfdietz's avatar
pfdietz committed
16
(declaim (special *replicate-type*))
17

18 19
(defparameter *default-reps* 1000)
(defparameter *default-cell* nil)
pfdietz's avatar
pfdietz committed
20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56
(defparameter *default-ignore* 'arithmetic-error)
(defparameter *default-arg-the* t)

;;;
;;; The random type prop tester takes three required arguments:
;;;
;;;  operator  A lisp operator (either a symbol or a lambda form)
;;;  arg-types A list consisting either of certain kinds of lisp types
;;;            (that make-random-element-of-type understands) and/or
;;;            functions that yield types.
;;;  minargs   Minimum number of arguments to be given to the operator.
;;;            Must be a positive integer <= maxargs.
;;;
;;; There are also keyword arguments, some with defaults given by special
;;; variables.
;;;
;;; The random type prop tester generates between minargs and maxargs
;;; (maxargs defaults to minargs) random arguments.  The type of each
;;; argument is given by the corresponding type in arg-types (or by rest-type,
;;; if there aren't enough elements of arg-types).  If the element of arg-types
;;; is a function, the type for the parameter is produced by calling the function
;;; with the previously generated actual parameters as its arguments.
;;;
;;; The list of parameters is stored into the special variable *params*.
;;;
;;; The tester evaluates (operator . arguments), and also builds a lambda
;;; form to be compiled and called on (a subset of) the parameters.  The lambda
;;; form is stored in the special variable *form*.
;;;
;;; The macro def-type-prop-test wraps a call to do-random-type-prop-tests
;;; in a deftest form.  See random-type-prop-tests.lsp (and subfiles) for examples
;;; of its use testing CL builtin operators.  To use it:
;;;
;;; (load "gclload1.lsp")
;;; (compile-and-load "random-int-form.lsp") ;; do this on lisps not supporting recursive compiles
;;; (compile-and-load "random-type-prop.lsp")
;;; (in-package :cl-test)
pfdietz's avatar
pfdietz committed
57
;;; (load "random-type-prop-tests.lsp")
pfdietz's avatar
pfdietz committed
58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81
;;; (let (*catch-errors*) (do-test '<testname>))
;;; or (let (*catch-errors*) (do-tests))
;;;
;;; Running all the tests may take a while, particularly on lisps with slow compilers.
;;;
;;;
;;; Keyword arguments to do-random-type-prop-tests:
;;;
;;;  Argument    Default         Meaning
;;;
;;;  maxargs     minargs         Maximum number of actual parameters to generate (max 20).
;;;  rest-type   t               Type of arguments beyond those specified in arg-types
;;;  reps        *default-reps*  Number of repetitions to try before stopping.
;;;                              The default is controlled by a special variable that
;;;                              is initially 1000.
;;;  enclosing-the nil           If true, with prob 1/2 randomly generate an enclosing
;;;                              (THE ...) form around the form invoking the operator.
;;;  arg-the     *default-arg-the*   If true (which is the initial value of the default
;;;                              special variable), with probability 1/2 randomly generate
;;;                              a (THE ...) form around each actual parameter.
;;;  cell        *default-cell*  If true (default is NIL), store the result into a rank-0
;;;                              array of specialized type.  This enables one to test
;;;                              forms where the result will be unboxed.  Otherwise, just
;;;                              return the values.
82 83
;;;  ignore      *default-ignore*  Ignore conditions that are elements of IGNORE.  Default is
;;;                              ARITHMETIC-ERROR.
pfdietz's avatar
pfdietz committed
84 85 86 87 88 89 90 91 92
;;;  test        rt::equalp-with-case   The test function used to compare outputs.  It's
;;;                              also handy to use #'approx= to handle approximate equality
;;;                              when testing floating point computations, where compiled code
;;;                              may have different roundoff errors.
;;;  replicate   nil             Cause arguments to be copied (preserving sharing in conses
;;;                              and arrays) before applying the operator.  This is used to test
;;;                              destructive operators.
;;;
;;;
sds's avatar
sds committed
93

94
(defun do-random-type-prop-tests
95
  (operator arg-types minargs
sds's avatar
sds committed
96 97 98 99 100 101 102 103 104 105
            &key
            (maxargs minargs)
            (rest-type t)
            (reps *default-reps*)
            (enclosing-the nil)
            (arg-the *default-arg-the*)
            (cell *default-cell*)
            (ignore *default-ignore*)
            (test #'regression-test::equalp-with-case)
            (replicate nil replicate-p))
106
  (assert (<= 1 minargs maxargs 20))
107
(prog1
108 109
  (dotimes (i reps)
    again
110 111 112
    (handler-bind
     #-lispworks ((error #'(lambda (c) (when (typep c ignore) (go again)))))
     #+lispworks ()
113
    (let* ((param-names
sds's avatar
sds committed
114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192
           '(p1 p2 p3 p4 p5 p6 p7 p8 p9 p10
             p11 p12 p13 p14 p15 p16 p17 p18 p19 p20))
          (nargs (+ minargs (random (- maxargs minargs -1))))
          (types (subseq
                  (append arg-types
                          (make-list (max 0 (- nargs (length arg-types)))
                                     :initial-element rest-type))
                  0 nargs))
          (replicate (if replicate-p replicate
                       (mapcar (constantly nil) types)))
          ; (vals (mapcar #'make-random-element-of-type types))
          (vals (setq *params*
                      (or (make-random-arguments types) (go again))))
          (vals
           (if replicate
               (mapcar #'replicate vals)
             vals))
          (is-var? (if (consp replicate)
                       (progn
                         (assert (= (length replicate) (length vals)))
                         (loop for x in replicate collect (or x (coin))))
                     (loop repeat (length vals) collect (coin))))
          (*is-var?* is-var?)
          (params (loop for x in is-var?
                        for p in param-names
                        when x collect p))
          (param-types (mapcar #'make-random-type-containing vals replicate))
          (*param-types* param-types)
          (type-decls (loop for x in is-var?
                            for p in param-names
                            for tp in param-types
                            when x
                            collect `(type ,tp ,p)))
          (rval (cl:handler-bind
                 (#+sbcl (sb-ext::compiler-note #'muffle-warning)
                         (warning #'muffle-warning))
                 (let* ((vals (if replicate (mapcar #'replicate vals) vals))
                        (eval-form (cons operator (loop for v in vals
                                                        collect `(quote ,v)))))
                   ;; (print eval-form) (terpri)
                   ;; (dotimes (i 100) (eval eval-form))
                   (eval eval-form))))
          (result-type (if (and enclosing-the (integerp rval))
                           (make-random-type-containing rval)
                         t))
          (expr `(,operator ,@(loop for x in is-var?
                                    for v in vals
                                    for r in replicate
                                    for p in param-names
                                    collect (if x
                                                (if (and arg-the (coin))
                                                    (let ((tp (make-random-type-containing v r)))
                                                      `(the ,tp ,p))
                                                  p)
                                              (if (or (consp v)
                                                      (and (symbolp v) (not (or (keywordp v)
                                                                                (member v '(nil t))))))
                                                  `(quote ,v)
                                                  v)))))
          (speed (random 4))
          (space (random 4))
          (safety #-allegro (random 4)
                  #+allegro (1+ (random 3)))
          (debug (random 4))
          (store-into-cell? (and cell (coin)))
          (upgraded-result-type (and store-into-cell?
                                     (upgraded-array-element-type `(eql ,rval))))
          (form
           (setq *form*
                 `(lambda (,@(when store-into-cell? '(r)) ,@params)
                    (declare (optimize (speed ,speed) (safety ,safety) (debug ,debug) (space ,space))
                             ,@(when store-into-cell? `((type (simple-array ,upgraded-result-type nil) r)))
                             ,@ type-decls)
                    ,(let ((result-form
                            (if enclosing-the `(the ,result-type ,expr) expr)))
                       (if store-into-cell?
                           `(setf (aref r) ,result-form)
                         result-form)))))
          )
193 194
     (when *print-random-type-prop-input*
       (let ((*print-pretty* t)
sds's avatar
sds committed
195 196
             (*print-case* :downcase))
         (print (list :form form :vals vals))))
197 198
     (finish-output)
     (let* ((param-vals (loop for x in is-var?
sds's avatar
sds committed
199 200 201 202 203 204 205 206 207 208 209 210
                              for v in vals
                              when x collect v))
            (fn (cl:handler-bind
                 (#+sbcl (sb-ext::compiler-note #'muffle-warning)
                         (warning #'muffle-warning))
                 (compile nil form)))
            (result
             (if store-into-cell?
                 (let ((r (make-array nil :element-type upgraded-result-type)))
                   (apply fn r param-vals)
                   (aref r))
               (apply fn param-vals))))
211
       (setq *random-type-prop-result*
sds's avatar
sds committed
212 213 214 215 216
             (list :upgraded-result-type upgraded-result-type
                   :form form
                   :vals vals
                   :result result
                   :rval rval))
217
       (unless (funcall test result rval)
sds's avatar
sds committed
218
         (return *random-type-prop-result*))))
pfdietz's avatar
pfdietz committed
219
    ;; #+allegro (excl::gc t)
220
  ))))
221

222 223 224
(defun make-random-arguments (types-or-funs)
  (let ((vals nil))
    (loop for type-or-fun in types-or-funs
sds's avatar
sds committed
225 226 227 228 229 230 231 232
          for type = (or (typecase type-or-fun
                           ((and function (not symbol))
                            (apply type-or-fun vals))
                           (t type-or-fun))
                         (return-from make-random-arguments nil) ;; null type
                         )
          for val = (make-random-element-of-type type)
          do (setf vals (nconc vals (list val))))
233 234 235
    ;; (dolist (v vals) (describe v))
    vals))

236 237 238
(defmacro defmethods (name &rest bodies)
  `(progn
     ,@(mapcar
sds's avatar
sds committed
239 240
        #'(lambda (body) `(defmethod ,name ,@body))
        bodies)))
241

pfdietz's avatar
pfdietz committed
242 243 244 245 246 247 248 249 250 251 252
(defgeneric make-random-type-containing* (val)
  (:method-combination randomized)
  (:documentation "Produce a random type containing VAL.  If the special
variable *REPLICATE-TYPE* is true, and the value is mutable, then do not
use the value in MEMBER or EQL type specifiers."))

(defun make-random-type-containing (type &optional *replicate-type*)
  (declare (special *replicate-type*))
  (make-random-type-containing* type))

(defmethods make-random-type-containing*
253
  (4 ((val t))
pfdietz's avatar
pfdietz committed
254
     (declare (special *replicate-type*))
255 256 257
     (rcase
      (1 t)
      (1 (if (consp val) 'cons 'atom))
pfdietz's avatar
pfdietz committed
258
      (1 (if *replicate-type* (make-random-type-containing* val)
sds's avatar
sds committed
259 260
           `(eql ,val)))
      (1
pfdietz's avatar
pfdietz committed
261
       (if *replicate-type* (make-random-type-containing* val)
sds's avatar
sds committed
262 263 264 265 266 267 268
         (let* ((n1 (random 4))
                (n2 (random 4))
                ;; Replace these calls with (make-random-element-of-type t)
                ;; at some point
                (l1 (loop repeat n1 collect (random-leaf)))
                (l2 (loop repeat n2 collect (random-leaf))))
           `(member ,@l1 ,val ,@l2))))))
269

270
  (1 ((val standard-object)) 'standard-object)
271
  (1 ((val structure-object)) 'structure-object)
272 273 274 275 276 277
  (1 ((val class)) 'class)
  (1 ((val standard-class)) 'standard-class)
  (1 ((val structure-class)) 'structure-class)
  (1 ((val number)) 'number)
  (1 ((val real)) 'real)
  (1 ((val ratio)) 'ratio)
278

279 280 281 282 283
  (1 ((val integer))
     (rcase
      (1 'integer)
      (1 'signed-byte)
      (1 (let* ((n1 (random 4))
sds's avatar
sds committed
284 285 286 287
                (n2 (random 4))
                (l1 (loop repeat n1 collect (make-random-integer)))
                (l2 (loop repeat n2 collect (make-random-integer))))
           `(member ,@l1 ,val ,@l2)))
288
      (1 (let ((lo (abs (make-random-integer))))
sds's avatar
sds committed
289
           `(integer ,(- val lo))))
290
      (2 (let ((lo (abs (make-random-integer))))
sds's avatar
sds committed
291
           `(integer ,(- val lo) *)))
292
      (2 (let ((hi (abs (make-random-integer))))
sds's avatar
sds committed
293
           `(integer * ,(+ val hi))))
294
      (4 (let ((lo (abs (make-random-integer)))
sds's avatar
sds committed
295 296
               (hi (abs (make-random-integer))))
           `(integer ,(- val lo) ,(+ val hi))))
297
      (1 (if (>= val 0) 'unsigned-byte (throw 'fail nil)))))
298

299 300 301 302
  (2 ((val character))
     (rcase
      (1 'character)
      (1 (if (typep val 'base-char) 'base-char
sds's avatar
sds committed
303 304 305
           #-sbcl 'extended-char
           #+sbcl (throw 'fail nil)
           ))
306 307
      (1 (if (typep val 'standard-char) 'standard-char (throw 'fail nil)))
      (1 (let* ((n1 (random 4))
sds's avatar
sds committed
308 309 310 311
                (n2 (random 4))
                (l1 (loop repeat n1 collect (make-random-character)))
                (l2 (loop repeat n2 collect (make-random-character))))
           `(member ,@l1 ,val ,@l2)))))
312

313
  (1 ((val null)) 'null)
314

315 316 317 318 319
  (2 ((val symbol))
     (rcase
      (1 'symbol)
      (1 (typecase val (boolean 'boolean) (keyword 'keyword) (otherwise (throw 'fail nil))))
      (1 (let* ((n1 (random 4))
sds's avatar
sds committed
320 321 322 323
                (n2 (random 4))
                (l1 (loop repeat n1 collect (make-random-symbol)))
                (l2 (loop repeat n2 collect (make-random-symbol))))
           `(member ,@l1 ,val ,@l2)))))
324

325 326 327 328
  (1 ((val rational))
     (rcase
      (1 'rational)
      (1 (let* ((n1 (random 4))
sds's avatar
sds committed
329 330 331 332
                (n2 (random 4))
                (l1 (loop repeat n1 collect (make-random-element-of-type 'rational)))
                (l2 (loop repeat n2 collect (make-random-element-of-type 'rational))))
           `(member ,@l1 ,val ,@l2)))
333 334 335
      (1 `(rational ,val))
      (1 `(rational * ,val))
      (1 (let ((v (make-random-element-of-type 'rational)))
sds's avatar
sds committed
336 337 338 339
           (if (<= v val)
               `(rational ,v ,val)
             `(rational ,val ,v))))))

340 341 342
  (1 ((val float))
     (rcase
      (1 (let* ((n1 (random 4))
sds's avatar
sds committed
343 344 345 346
                (n2 (random 4))
                (l1 (loop repeat n1 collect (- 2 (random (float 1.0 val)))))
                (l2 (loop repeat n2 collect (- 2 (random (float 1.0 val))))))
           `(member ,@l1 ,val ,@l2)))
347
      (1 (let ((names (float-types-containing val)))
sds's avatar
sds committed
348
           (random-from-seq names)))
349
      (1 (let ((name (random-from-seq (float-types-containing val))))
sds's avatar
sds committed
350 351 352
           (if (>= val 0)
               `(,name ,(coerce 0 name) ,val)
             `(,name ,val ,(coerce 0 name)))))))
353 354 355 356
  )

(defun float-types-containing (val)
  (loop for n in '(short-float single-float double-float long-float float)
sds's avatar
sds committed
357 358
        when (typep val n)
        collect n))
359 360 361 362 363 364 365

(defun make-random-array-dimension-spec (array dim-index)
  (assert (<= 0 dim-index))
  (assert (< dim-index (array-rank array)))
  (let ((dim (array-dimension array dim-index)))
    (rcase (1 '*) (1 dim))))

366
;;; More methods
pfdietz's avatar
pfdietz committed
367
(defmethods make-random-type-containing*
368 369
  (3 ((val bit-vector))
     (let ((root (if (and (coin)
sds's avatar
sds committed
370 371 372
                          (typep val 'simple-bit-vector))
                     'simple-bit-vector
                   'bit-vector)))
373
       (rcase (1 root)
sds's avatar
sds committed
374 375
              (1 `(,root))
              (3 `(,root ,(make-random-array-dimension-spec val 0))))))
376

377 378
  (3 ((val vector))
     (let ((root 'vector)
sds's avatar
sds committed
379 380 381 382 383 384 385 386 387 388 389
            (alt-root (if (and (coin) (simple-vector-p val)) 'simple-vector 'vector))
            (etype (rcase (1 '*)
                          (1 (array-element-type val))
                          ;; Add rule for creating new element types?
                          )))
        (rcase (1 alt-root)
               (1 `(,alt-root))
               (1 `(,root ,etype))
               (2 (if (and (simple-vector-p val) (coin))
                      `(simple-vector ,(make-random-array-dimension-spec val 0))
                    `(,root ,etype ,(make-random-array-dimension-spec val 0)))))))
390

391 392
  (3 ((val array))
     (let ((root (if (and (coin) (typep val 'simple-array)) 'simple-array 'array))
sds's avatar
sds committed
393 394
        (etype (rcase (1 (array-element-type val)) (1 '*)))
        (rank (array-rank val)))
395
       (rcase
sds's avatar
sds committed
396 397 398 399 400 401
        (1 root)
        (1 `(,root))
        (1 `(,root ,etype))
        (1 `(,root ,etype ,(loop for i below rank collect (make-random-array-dimension-spec val i))))
        (1 `(,root ,etype ,(loop for i below rank collect (array-dimension val i))))
        #-ecl (1 `(,root ,etype ,rank)))))
402

403 404
  (3 ((val string))
     (let ((root (cond
sds's avatar
sds committed
405 406 407 408 409 410 411 412 413 414
                  ((and (coin)
                        (typep val 'base-string))
                   (cond
                    ((and (coin) (typep val 'simple-base-string))
                     'simple-base-string)
                    (t 'base-string)))
                  ((and (coin)
                        (typep val 'simple-string))
                   'simple-string)
                  (t 'string))))
415
       (rcase (1 root)
sds's avatar
sds committed
416 417
              (1 `(,root))
              (3 `(,root ,(make-random-array-dimension-spec val 0))))))
418

419
  (1 ((val list)) 'list)
420

421 422 423
  (1 ((val cons))
     (rcase
      (1 'cons)
pfdietz's avatar
pfdietz committed
424
      (2 `(cons ,(make-random-type-containing* (car val))
sds's avatar
sds committed
425
                ,(make-random-type-containing* (cdr val))))
pfdietz's avatar
pfdietz committed
426
      (1 `(cons ,(make-random-type-containing* (car val))
sds's avatar
sds committed
427
                ,(random-from-seq #(t *))))
pfdietz's avatar
pfdietz committed
428
      (1 `(cons ,(make-random-type-containing* (car val))))
429
      (1 `(cons ,(random-from-seq #(t *))
sds's avatar
sds committed
430 431
                ,(make-random-type-containing* (cdr val))
                ))))
432

433 434 435 436 437
  (1 ((val complex))
     (rcase
      (1 'complex)
      #-gcl
      (1 (let* ((t1 (type-of (realpart val)))
sds's avatar
sds committed
438 439 440 441 442 443 444 445 446 447 448 449 450
                (t2 (type-of (imagpart val)))
                (part-type
                 (cond
                  ((subtypep t1 t2) (upgraded-complex-part-type t2))
                  ((subtypep t2 t1) (upgraded-complex-part-type t1))
                  ((and (subtypep t1 'rational)
                        (subtypep t2 'rational))
                   'rational)
                  (t
                   (upgraded-complex-part-type `(or ,t1 ,t2))))))
           (if (subtypep 'real part-type)
               '(complex real)
             `(complex ,part-type))))))
451

452 453 454 455 456
  (1 ((val generic-function)) 'generic-function)
  (1 ((val function))
     (rcase
      (1 'function)
      (1 (if (typep val 'compiled-function)
sds's avatar
sds committed
457 458
             'compiled-function
           'function))))
459
  )
460

461 462 463 464
;;; Macro for defining random type prop tests

(defmacro def-type-prop-test (name &body args)
  `(deftest ,(intern (concatenate 'string "RANDOM-TYPE-PROP."
sds's avatar
sds committed
465 466
                                  (string name))
                     (find-package :cl-test))
467 468
     (do-random-type-prop-tests ,@args)
     nil))
pfdietz's avatar
pfdietz committed
469 470 471 472 473 474

;;; Function used in constructing list types for some random type prop tests

(defun make-list-type (length &optional (rest-type 'null) (element-type t))
  (let ((result rest-type))
    (loop repeat length
sds's avatar
sds committed
475
          do (setq result `(cons ,element-type ,result)))
pfdietz's avatar
pfdietz committed
476 477
    result))

478 479 480
(defun make-sequence-type (length &optional (element-type t))
  (rcase
   (1 `(vector ,element-type ,length))
481 482 483
   (1 `(array ,element-type (,length)))
   (1 `(simple-array ,element-type (,length)))
   (2 (make-list-type length 'null element-type))))
484

pfdietz's avatar
pfdietz committed
485 486
(defun make-random-sequence-type-containing (element &optional *replicate-type*)
  (make-sequence-type (random 10) (make-random-type-containing* element)))
487

pfdietz's avatar
pfdietz committed
488 489 490 491 492 493 494 495 496 497 498 499
(defun same-set-p (set1 set2 &rest args &key key test test-not)
  (declare (ignorable key test test-not))
  (and (apply #'subsetp set1 set2 args)
       (apply #'subsetp set2 set2 args)
       t))

(defun index-type-for-dim (dim)
  "Returns a function that computes integer type for valid indices
   of an array dimension, or NIL if there are none."
  #'(lambda (array &rest other)
      (declare (ignore other))
      (let ((d (array-dimension array dim)))
sds's avatar
sds committed
500
        (and (> d 0) `(integer 0 (,d))))))
pfdietz's avatar
pfdietz committed
501 502 503 504 505 506 507 508 509 510 511 512 513 514

(defun index-type-for-v1 (v1 &rest other)
  "Computes integer type for valid indices for the first of two vectors"
  (declare (ignore other))
  (let ((d (length v1))) `(integer 0 ,d)))

(defun index-type-for-v2 (v1 v2 &rest other)
  "Computes integer type for valid indices for the second of two vectors"
  (declare (ignore v1 other))
  (let ((d (length v2))) `(integer 0 ,d)))

(defun end-type-for-v1 (v1 v2 &rest other)
  (declare (ignore v2))
  (let ((d (length v1))
sds's avatar
sds committed
515
        (start1 (or (cadr (member :start1 other)) 0)))
pfdietz's avatar
pfdietz committed
516 517 518 519 520
    `(integer ,start1 ,d)))

(defun end-type-for-v2 (v1 v2 &rest other)
  (declare (ignore v1))
  (let ((d (length v2))
sds's avatar
sds committed
521
        (start2 (or (cadr (member :start2 other)) 0)))
pfdietz's avatar
pfdietz committed
522 523 524
    `(integer ,start2 ,d)))


pfdietz's avatar
pfdietz committed
525 526 527 528 529
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defgeneric replicate (obj)
  (:documentation "Copies the structure of a lisp object recursively, preserving sharing."))

530 531 532
(defmacro replicate-with ((source-obj dest-obj copy-form) &body body)
  `(or (gethash ,source-obj *replicate-table*)
       (let ((,dest-obj ,copy-form))
sds's avatar
sds committed
533 534 535
         (setf (gethash ,source-obj *replicate-table*) ,dest-obj)
         ,@body
         ,dest-obj)))
536

pfdietz's avatar
pfdietz committed
537 538 539 540 541 542 543 544 545 546 547 548
(declaim (special *replicate-table*))

(defmethod replicate :around ((obj t))
  "Wrapper to create a hash table for structure sharing, if none exists."
  (if (boundp '*replicate-table*)
      (call-next-method obj)
    (let ((*replicate-table* (make-hash-table)))
      (call-next-method obj))))

(defmethod replicate ((obj cons))
  (or (gethash obj *replicate-table*)
      (let ((x (cons nil nil)))
sds's avatar
sds committed
549 550 551 552
        (setf (gethash obj *replicate-table*) x)
        (setf (car x) (replicate (car obj)))
        (setf (cdr x) (replicate (cdr obj)))
        x)))
pfdietz's avatar
pfdietz committed
553 554 555 556 557 558 559 560 561 562

;;; Default method for objects without internal structure
(defmethod replicate ((obj t)) obj)

(defmethod replicate ((obj array))
  (multiple-value-bind
      (new-obj old-leaf new-leaf)
      (replicate-displaced-array obj)
    (when new-leaf
      (loop for i below (array-total-size new-leaf)
sds's avatar
sds committed
563 564
            do (setf (row-major-aref new-leaf i)
                     (row-major-aref old-leaf i))))
pfdietz's avatar
pfdietz committed
565 566 567 568 569 570 571 572 573
    new-obj))

(defun replicate-displaced-array (obj)
  "Replicate the non-terminal (and not already replicated) arrays
   in a displaced array chain.  Return the new root array, the
   old leaf array, and the new (but empty) leaf array.  The latter
   two are NIL if the leaf did not have to be copied again."
  (or (gethash obj *replicate-table*)
      (multiple-value-bind
sds's avatar
sds committed
574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600
          (displaced-to displaced-index-offset)
          (array-displacement obj)
        (let ((dims (array-dimensions obj))
              (element-type (array-element-type obj))
              (fill-pointer (and (array-has-fill-pointer-p obj)
                                 (fill-pointer obj)))
              (adj (adjustable-array-p obj)))
          (if displaced-to
              ;; The array is displaced
              ;; Copy recursively
              (multiple-value-bind
                  (new-displaced-to old-leaf new-leaf)
                  (replicate-displaced-array displaced-to)
                (let ((new-obj (make-array dims :element-type element-type
                                           :fill-pointer fill-pointer
                                           :adjustable adj
                                           :displaced-to new-displaced-to
                                           :displaced-index-offset displaced-index-offset)))
                  (setf (gethash obj *replicate-table*) new-obj)
                  (values new-obj old-leaf new-leaf)))
            ;; The array is not displaced
            ;; This is the leaf array
            (let ((new-obj (make-array dims :element-type element-type
                                       :fill-pointer fill-pointer
                                       :adjustable adj)))
              (setf (gethash obj *replicate-table*) new-obj)
              (values new-obj obj new-obj)))))))
601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(declaim (special *isomorphism-table*))

(defun isomorphic-p (obj1 obj2)
  (let ((*isomorphism-table* (make-hash-table)))
    (isomorphic-p* obj1 obj2)))

(defgeneric isomorphic-p* (obj1 obj2)
  (:documentation
   "Returns true iff obj1 and obj2 are 'isomorphic' (that is, have the same structure,
    including the same leaf values and the same pattern of sharing).  It should be
    the case that (isomorphic-p obj (replicate obj)) is true."))

(defmethod isomorphic-p* ((obj1 t) (obj2 t))
  (eql obj1 obj2))

(defmethod isomorphic-p* ((obj1 cons) (obj2 cons))
  (let ((previous (gethash obj1 *isomorphism-table*)))
    (cond
     (previous
      ;; If we've already produced a mapping from obj1 to something,
      ;; isomorphism requires that obj2 be that object
      (eq previous obj2))
     ;; Otherwise, assume obj1 will map to obj2 and recurse
     (t
      (setf (gethash obj1  *isomorphism-table*) obj2)
      (and (isomorphic-p* (car obj1) (car obj2))
sds's avatar
sds committed
630
           (isomorphic-p* (cdr obj1) (cdr obj2)))))))
631 632 633 634 635 636 637 638 639 640 641

(defmethod isomorphic-p* ((obj1 array) (obj2 array))
  (let ((previous (gethash obj1 *isomorphism-table*)))
    (cond
     (previous
      ;; If we've already produced a mapping from obj1 to something,
      ;; isomorphism requires that obj2 be that object
      (eq previous obj2))
     (t
      (setf (gethash obj1 *isomorphism-table*) obj2)
      (and (equal (array-dimensions obj1) (array-dimensions obj2))
sds's avatar
sds committed
642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658
           (equal (array-element-type obj1) (array-element-type obj2))
           (if (array-has-fill-pointer-p obj1)
               (and (array-has-fill-pointer-p obj2)
                    (eql (fill-pointer obj1) (fill-pointer obj2)))
             (not (array-has-fill-pointer-p obj2)))
           (let (to-1 (index-1 0) to-2 (index-2 0))
             (multiple-value-setq (to-1 index-1) (array-displacement obj1))
             (multiple-value-setq (to-2 index-2) (array-displacement obj2))
             (if to-1
                 (and to-2
                      (eql index-1 index-2)
                      (isomorphic-p* to-1 to-2))
               ;; Not displaced -- recurse on elements
               (let ((total-size (array-total-size obj1)))
                 (loop for i below total-size
                       always (isomorphic-p* (row-major-aref obj1 i)
                                             (row-major-aref obj2 i)))))))))))
659

660
;;; Test that sequences have identical elements
661

662 663 664
(defun equalp-and-eql-elements (s1 s2)
  (and (equalp s1 s2)
       (every #'eql s1 s2)))