Common Lisp Deep Copy

deep-copy.lisp

;; Jump to line 99
;; This is incomplete; follow the TODOs and think more to complete

(defpackage :deep-copy
  (:use
   :adhoc-polymorphic-functions
   :cl
   :alexandria)
  (:local-nicknames (:cm :sandalphon.compiler-macro)
                    (:mop :closer-mop))
  (:export :deep-copy))

(in-package :deep-copy)

;; DEFAULT ====================================================================

(defparameter *default-impl* (make-hash-table))

(defun %dimensions-comp (dimensions)
  (cond ((eql '* dimensions) 0)
        ((listp dimensions) (mapcar (lambda (x) (if (eql '* x) 0 x)) dimensions))
        (t dimensions)))


(defun default (type &optional environment)
  (multiple-value-bind (item knownp) (gethash type *default-impl*)
    (if knownp
        item
        (progn
          (setf type (sb-ext:typexpand type environment))
          (if (symbolp type)
              (case type
                ((bit fixnum integer rational) 0)
                ((float double-float single-float long-float real) 0.0)
                ((number complex) #c(0 0))
                ((character base-char) #\Nul)
                ((symbol t) t)
                (keyword :t)
                (hash-table `(make-hash-table))
                ((list boolean null) nil)
                (vector (make-array 0 :adjustable t))
                (string (make-array 0 :element-type 'character :initial-element #\Nul))
                (array (make-array 0)) ;;Maybe it should error here, since array dimension is nto specified?
                ;;What happens with just array? Or just sequence? I guess nothing
                (simple-string '(make-array 0 :element-type 'character :initial-element #\Nul))
                (simple-base-string '(make-array 0 :element-type 'base-char :initial-element #\Nul))
                (otherwise
                 (cond ((subtypep type 'structure-object environment)
                        (list (intern (concatenate 'string "MAKE-" (string type)))))
                       ((subtypep type 'standard-object environment)
                        `(make-instance ,type)))))
              (destructuring-bind (main . rest) type
                (case main
                  ((mod unsigned-byte singned-byte) 0)
                  ((integer eql member) (first rest))
                  ;;something about floats and rationals should be here
                  (complex `(complex ,(default (first rest)) ,(default (first rest))))
                  (cons `(cons ,(default (first rest)) ,(default (first rest))))
                  (vector `(make-array ',(if (= 2 (length rest))
                                             (%dimensions-comp (second rest))
                                             0)
                                       :adjustable t
                                       :element-type ',(or (first rest) t)
                                       :initial-element ,(if (first rest)
                                                             (default (first rest))
                                                             0)))
                  (string `(make-array ',(if (= 2 (length rest))
                                             (%dimensions-comp (second rest))
                                             0)
                                       :element-type 'character
                                       :adjustable t
                                       :initial-element #\Nul))
                  (simple-array `(make-array ',(if (= 2 (length rest))
                                                   (%dimensions-comp (second rest))
                                                   0)
                                             :element-type ',(or (first rest) t)
                                             :initial-element ,(if (first rest)
                                                                   (default (first rest))
                                                                   0)))
                  (simple-string `(make-array ',(if (= 2 (length rest))
                                                    (%dimensions-comp (second rest))
                                                    0)
                                              :element-type 'character
                                              :initial-element #\Nul))
                  (simple-base-string `(make-array ',(if (= 2 (length rest))
                                                         (%dimensions-comp (second rest))
                                                         0)
                                                   :element-type 'base-char
                                                   :initial-element #\Nul))

                  (array `(make-array ',(if (= 2 (length rest))
                                            (%dimensions-comp (second rest))
                                            0)
                                      :element-type ',(or (first rest) t)
                                      :initial-element ,(if (first rest)
                                                            (default (first rest))
                                                            0))))))))))

;; DEEP-COPY ===================================================================

(define-polymorphic-function deep-copy (object))

(defpolymorph deep-copy ((o number)) number
  ;; Assume numbers are immutable
  o)

(defpolymorph deep-copy ((o character)) character
  ;; Assume characters are immutable
  o)

(defpolymorph deep-copy ((o array)) array
  ;; Could consider more options like displacements
  (let ((r (make-array (array-dimensions o)
                       :element-type (array-element-type o)
                       :initial-element (default (array-element-type o)))))
    (loop :for i :below (array-total-size o)
          :do (setf (row-major-aref r i)
                    (deep-copy (row-major-aref o i))))
    r))

(defpolymorph-compiler-macro deep-copy (array) (o &environment env)
  (let* ((o-type (cm:form-type o env))
         (o-elt  (cm:array-type-element-type o-type))
         (o-dim  (cm:array-type-dimensions o-type)))
    `(the ,o-type
          ,(once-only (o)
             `(let ((r (make-array ',o-dim
                                   :element-type ',o-elt
                                   ;; Further part may be handled by the compiler-macro
                                   ;; of DEFAULT
                                   :initial-element (default ',o-elt))))
                (declare (type ,o-type ,o r))
                (loop :for i :below ,(reduce #'* o-dim :initial-value 1)
                      :do (setf (row-major-aref r i)
                                ;; Leave make-array and row-major-aref to be optimized by SBCL
                                (the ,o-elt
                                     (deep-copy (the ,o-elt (row-major-aref ,o i))))))
                r)))))

(defun deep-copy-single-float-array (a)
  (declare (type (array single-float (100000000)) a)
           (optimize speed))
  (deep-copy a))

(defun simple-deep-copy-array (o)
  (declare (optimize speed)
           (type array o))
  (let ((r (make-array (array-dimensions o)
                       :element-type (array-element-type o)
                       :initial-element (default (array-element-type o)))))
    (loop :for i :below (array-total-size o)
          :do (setf (row-major-aref r i)
                    (deep-copy (row-major-aref o i))))
    r))

(defun simple-deep-copy-single-float-array (o)
  (declare (optimize speed)
           (type (array single-float (100000000)) o))
  (let ((r (make-array (array-dimensions o)
                       :element-type (array-element-type o)
                       :initial-element (default (array-element-type o)))))
    (loop :for i :below (array-total-size o)
          :do (setf (row-major-aref r i)
                    (deep-copy (row-major-aref o i))))
    r))

(defpolymorph deep-copy ((o structure-object)) structure-object
  (let* ((type        (type-of o))
         (initializer (find-symbol (concatenate 'string
                                                "MAKE-"
                                                (symbol-name type))))
         (slots (mop:class-slots (find-class type))))
    (apply initializer
           (loop :for slot :in slots
                 :for name := (mop:slot-definition-name slot)
                 :for value := (slot-value o name)
                 :appending `(,(intern (symbol-name name) :keyword)
                              ,(deep-copy value))))))

(defpolymorph-compiler-macro deep-copy (structure-object) (o &environment env)
  ;; TODO: Handle the case when TYPE is something complicated: "satisfies"
  (let* ((type        (cm:form-type o env))
         (initializer (find-symbol (concatenate 'string
                                                "MAKE-"
                                                (symbol-name type))))
         (slots (mop:class-slots (find-class type))))
    (print `(the ,type
                 (let ((o ,o))
                   (declare (type ,type o))
                   (,initializer
                    ,@(loop :for slot :in slots
                            :for name := (mop:slot-definition-name slot)
                            :for slot-type := (mop:slot-definition-type slot)
                            :for value := `(slot-value o ',name)
                            :appending `(,(intern (symbol-name name) :keyword)
                                         (deep-copy (the ,slot-type ,value))))))))))

;; TODO: Check if this compiles as expected
(defun deep-copy-pair (pair)
  (declare (type pair pair)
           (optimize speed))
  (deep-copy pair))

(defun deep-copy-pair (pair)
  (declare (type pair pair)
           (optimize speed))
  (make-pair :s (deep-copy (the string (pair-s pair)))
             :a (deep-copy (the array  (pair-a pair)))))