index-metaclass.lisp

;;;;; -*- mode: common-lisp;   common-lisp-style: modern;    coding: utf-8; -*-
;;;;;

(in-package :index)

(defclass indexed-class (standard-class)
  ((indices
     :initarg :indices
     :initform nil
     :accessor indexed-class-indices)
    (old-indices
      :initarg :old-indices
      :initform nil
      :accessor indexed-class-old-indices)
    (index-definitions
      :initarg :class-indices
      :initform nil
      :accessor indexed-class-index-definitions)))

(defstruct (index-holder (:type vector) :named)
  class slots name index index-subclasses)

(defmethod indexed-class-index-named ((class indexed-class) index-name)
  (let ((index-holder (find index-name (indexed-class-indices class)
			    :key #'index-holder-name)))
    (when index-holder
      (index-holder-index index-holder))))

(defmethod validate-superclass ((sub indexed-class) (super standard-class))
  t)

(defclass index-direct-slot-definition (standard-direct-slot-definition)
  ((index
     :initarg :index
     :initform nil
     :reader index-direct-slot-definition-index
     :documentation "Slot keyword for an already existing index")
    (index-var
      :initarg :index-var
      :initform nil
      :reader index-direct-slot-definition-index-var
      :documentation "Symbol that will be bound to the index")
    (index-type
      :initarg :index-type
      :initform nil
      :reader index-direct-slot-definition-index-type
      :documentation "Slot keyword to specify the class of a new slot index")
    (index-initargs
      :initarg :index-initargs
      :initform nil
      :reader index-direct-slot-definition-index-initargs
      :documentation "Arguments that will be passed to INDEX-CREATE
      when creating a new slot index")
    (index-reader
      :initform nil
      :initarg :index-reader
      :accessor index-direct-slot-definition-index-reader
      :documentation "Name of a function that will be created to query
      the slot index")
    (index-values
      :initform nil
      :initarg :index-values
      :accessor index-direct-slot-definition-index-values
      :documentation "Name of a function that will be created to get
      the values stored in the index")
    (index-mapvalues
      :initform nil
      :initarg :index-mapvalues
      :accessor index-direct-slot-definition-index-mapvalues
      :documentation "Name of a function that will be created to map
      over the values stored in the index")
    (index-keys
      :initform nil
      :initarg :index-keys
      :accessor index-direct-slot-definition-index-keys
      :documentation "Name of a function that will be created to get
      the keys stored in the index")
    (index-subclasses
      :initarg :index-subclasses
      :initform t
      :accessor index-direct-slot-definition-index-subclasses
      :documentation "Specify if the slot index will also index
      subclasses of the class to which the slot belongs, default is T")
    (class
      :initform nil
      :accessor index-direct-slot-definition-class)))

(defclass index-effective-slot-definition (standard-effective-slot-definition)
  ((indices
     :initarg :indices
     :initform nil
     :accessor index-effective-slot-definition-indices)))

(defmethod class-all-indexed-superclasses ((class indexed-class))
  (let (result)
    (labels ((superclasses (class)
	       (let ((classes (remove-if-not #'(lambda (class) (typep class 'indexed-class))
                                (class-direct-superclasses class))))
		 (dolist (class classes)
		   (unless (class-finalized-p class)
		     (finalize-inheritance class))
		   (push class result)
		   (superclasses class)))))
      (superclasses class))
    (nreverse result)))

(defmethod direct-slot-definition-class ((class indexed-class) &key index index-type)
  (if (or index index-type)
    'index-direct-slot-definition
    (call-next-method)))

(defmethod effective-slot-definition-class ((class indexed-class) &rest initargs)
  (declare (ignore initargs))
  'index-effective-slot-definition)

(defun defun-and-compile (defun)
  (let ((function (second defun)))
    (when function
      (eval defun)
      (compile function))))

(defun create-index-access-functions (index &key index-reader index-values
				      index-mapvalues index-keys index-var)
  (defun-and-compile 
      `(defun ,index-reader (key)    (index-get ,index key)))
  (defun-and-compile
      `(defun ,index-values ()       (index-values ,index)))
  (defun-and-compile
      `(defun ,index-mapvalues (fun) (index-mapvalues ,index fun)))
  (defun-and-compile
      `(defun ,index-keys ()         (index-keys ,index)))
  (when index-var
    (when (boundp index-var)
      (warn "~A is already bound to ~A, rebinding to ~A"
	    index-var (eval index-var) index))
    (eval `(defparameter ,index-var ,index))))

(defun eval-initargs (initargs)
  (loop for (key value) on initargs by #'cddr
    nconc (list key (eval value))))

(defun make-index-object (&key index type initargs reader values mapvalues slots keys var)
  (let ((index-object (if index
                        (eval index)
                        (apply #'index-create
                          (append (cons type (eval-initargs initargs))
                            (list :slots slots))))))
    (when index-object
      (create-index-access-functions index-object :index-reader reader
        :index-values values
        :index-mapvalues mapvalues
        :index-keys keys
        :index-var var))
    index-object))

(defmethod compute-effective-slot-definition :around ((class indexed-class)
						      name direct-slots)
  (declare (ignore name))
  (let* ((normal-slot (call-next-method))
	 (direct-slots (remove-if-not #'(lambda (slot)
					  (typep slot 'index-direct-slot-definition))
				      direct-slots))
	 (direct-slot (first direct-slots)))
    (when (and (typep normal-slot 'index-effective-slot-definition)
	       direct-slot
	       (or (not (index-direct-slot-definition-class direct-slot))
		   (eql (index-direct-slot-definition-class direct-slot) class)))
      (setf (index-direct-slot-definition-class direct-slot) class)
      (with-slots (index index-type index-initargs index-subclasses index-keys
			 index-reader index-values index-mapvalues index-var) direct-slot
	(when (or index index-type)
	  (let* ((name (slot-definition-name direct-slot))
		 (index-object (make-index-object :index index
						  :type index-type
						  :initargs index-initargs
						  :reader index-reader
						  :keys index-keys
						  :values index-values
						  :mapvalues index-mapvalues
						  :var index-var
						  :slots (list name))))
	    (when index-object
	      (push (make-index-holder :class class :slots (list name)
				       :name name :index index-object
				       :index-subclasses index-subclasses)
		    (indexed-class-indices class)))))))
    normal-slot))

(defmethod compute-class-indices ((class indexed-class) class-indices)
  (unless (class-finalized-p class)
    (finalize-inheritance class))
  (let* ((class-slots (class-slots class))
          (slot-names (mapcar #'slot-definition-name class-slots)))
    ;;; create new class indices
    (dolist (class-index class-indices)
      #+nil
      (format t "class-index ~A~%" class-index)      
      (destructuring-bind (name &key index-reader index-values index-mapvalues
                            index-keys (index-subclasses t) index-initargs
                            (slots :all-slots) index-type
                            index) class-index
	(when (eql slots :all-slots)
	  (setf slots slot-names))
	(let ((index-object (make-index-object :index index
                              :type index-type
                              :initargs index-initargs
                              :reader index-reader
                              :values index-values
                              :keys index-keys
                              :mapvalues index-mapvalues
                              :slots slots)))
	  (when index-object
	    (push (make-index-holder :class class :slots slots
                    :name name :index index-object
                    :index-subclasses index-subclasses)
              (indexed-class-indices class))))))
    #+nil
    (format t "superclasses ~A~%" (class-all-indexed-superclasses class))
    ;;; class indices from superclasses
    (dolist (superclass (class-all-indexed-superclasses class))
      (setf (indexed-class-indices class)
        (remove-duplicates
          (append (indexed-class-indices class)
            (cl:remove nil (indexed-class-indices superclass)
              :key #'index-holder-index-subclasses))
          :key #'index-holder-index)))

    (dolist (holder (indexed-class-indices class))
      (dolist (slot-name (index-holder-slots holder))
	(let ((slot (find slot-name class-slots :key #'slot-definition-name)))
	  #+nil
	  (format t "slot ~A indx ~A~%" slot holder)
	  (unless (and slot
                    (typep slot 'index-effective-slot-definition ))
	    (error "Could not find slot ~A to store index ~A~%" slot-name holder))
	  (pushnew (index-holder-index holder)
            (index-effective-slot-definition-indices slot)))))))

#+allegro
(defmethod finalize-inheritance :after ((class indexed-class))
  (compute-class-indices class (indexed-class-index-definitions class))
  (reinitialize-class-indices class))

(defun validate-index-declaration (class indices)
  (dolist (index indices)
    (when (and (getf (cdr index) :index)
               (getf (cdr index) :index-type))
      (error "Can't have both :INDEX and :INDEX-TYPE in index ~A of ~A" (car index) class))))

(defmethod initialize-instance :before ((class indexed-class) &key class-indices)
  (validate-index-declaration class class-indices))

(defmethod reinitialize-instance :before ((class indexed-class) &key class-indices)
  (validate-index-declaration class class-indices))

;;; avoid late instantiation

#+(or allegro cmu openmcl sbcl)
(defmethod initialize-instance :after ((class indexed-class) &key)
  (compute-class-indices class (indexed-class-index-definitions class))
  (reinitialize-class-indices class))

#+(or allegro cmu openmcl sbcl)
(defmethod reinitialize-instance :after ((class indexed-class) &key)
  (compute-class-indices class (indexed-class-index-definitions class))
  (reinitialize-class-indices class))

(defmethod reinitialize-class-indices ((class indexed-class))
  (let ((old-indices (cl:remove class (indexed-class-old-indices class)
			     :test-not #'eql :key #'index-holder-class))
	(indices (cl:remove class (indexed-class-indices class)
			 :test-not #'eql :key #'index-holder-class)))
    (when old-indices
      (dolist (holder indices)
	(let ((old-holder (find (index-holder-name holder) old-indices
				:key #'index-holder-name)))
	  (when old-holder
	    (index-reinitialize (index-holder-index holder)
				(index-holder-index old-holder))))))))

(defmethod reinitialize-instance :before ((class indexed-class) &key)
  (setf (indexed-class-old-indices class) (indexed-class-indices class)
	(indexed-class-indices class) nil))

;;; Hier koennen wir keine :AROUND method fuer COMPUTE-SLOTS bauen,
;;; weil die LISP-Implementierung die Allocation von dem neuen
;;; DESTROYED-P Slot bestimmen muss, und zwar auch im :AROUND. Das
;;; koennen wir leider nicht uebernehmen.

(defmethod compute-slots ((class indexed-class))
  (let* ((normal-slots (call-next-method))
	 (destroyed-p-slot #.`(make-instance
			       'index-effective-slot-definition
			       :name 'destroyed-p
			       :initform nil
			       :class class
			       #+(or cmu sbcl)
			       ,@'(:readers nil :writers nil)
			       :initfunction #'(lambda () nil))))
    (cons destroyed-p-slot normal-slots)))

(defvar *indexed-class-override* nil)

(defmethod slot-value-using-class :before ((class indexed-class) object slot)
  (when (and (not (eql (slot-definition-name slot) 'destroyed-p))
	     (object-destroyed-p object)
	     (not *indexed-class-override*))
    (error "Can not get slot ~A of destroyed object of class ~a."
	   (slot-definition-name slot) (class-name (class-of object)))))

(defmethod (setf slot-value-using-class) :before
    (newvalue (class indexed-class) object slot)
  (declare (ignore newvalue))
  (when (and (not (eql (slot-definition-name slot) 'destroyed-p))
	     (object-destroyed-p object)
	     (not *indexed-class-override*))
    (error "Can not set slot ~A of destroyed object ~a." 
	   (slot-definition-name slot) (class-name (class-of object)))))

(defmethod slot-makunbound-using-class :before ((class indexed-class) object slot)
  (when (and (not (eql (if (symbolp slot)
			   slot
			   (slot-definition-name slot))
		       'destroyed-p))
	     (object-destroyed-p object)
	     (not *indexed-class-override*))
    (error "Can not MAKUNBOUND slot ~A of destroyed object ~a." 
	   (slot-definition-name slot) (class-name (class-of object)))))

(defvar *in-make-instance-p* nil)

(defvar *indices-remove-p* t)

(defmethod make-instance :around ((class indexed-class) &key)
  (let* ((*in-make-instance-p* t)
	 (object (call-next-method))
	 (added-indices)
	 (error t))
    (unwind-protect
	 (progn
	   (dolist (index (mapcar #'index-holder-index (indexed-class-indices class)))
	     (index-add index object)
	     (push index added-indices))
	   (setf error nil)
	   object)
      (when error
	(dolist (index added-indices)
	  (index-remove index object))))
    object))

(defmethod (setf slot-value-using-class) :around
    (newvalue (class indexed-class) object (slot index-effective-slot-definition))
  (declare (ignore newvalue))

  (when (eql (slot-definition-name slot) 'destroyed-p)
    (return-from slot-value-using-class  (call-next-method)))

  (when *in-make-instance-p*
    (return-from slot-value-using-class (call-next-method)))
  
  (let* ((indices (index-effective-slot-definition-indices slot))
	 (slot-name (slot-definition-name slot))
	 (previous-slot-boundp (slot-boundp object slot-name))
	 (previous-slot-value (when previous-slot-boundp
				(slot-value object slot-name))))
    #+nil
    (format t "indices ~A~%" indices)
    (when (and previous-slot-boundp *indices-remove-p*)
      (let ((changed-indices)
	    (error t))
	(unwind-protect
	     (progn 
	       (dolist (index indices)
		 (index-remove index object)
		 (push index changed-indices))
	       (setf error nil))
	  (when error
	    (dolist (index changed-indices)
	      (index-add index object))))))    
    (let ((result (call-next-method)))
      #+nil
      (format t "set slot ~A of ~a to ~A, value is ~a~%"
	      (slot-definition-name slot)
	      object newvalue
	      (slot-value object (slot-definition-name slot)))      
      (when (slot-boundp object (slot-definition-name slot))
	(let ((error t)
	      (changed-indices nil))
	  (unwind-protect
	       (progn
		 (dolist (index indices)
		   (index-add index object)
		   (push index changed-indices))
		 (setf error nil))
	    (when error
	      (dolist (index changed-indices)
		(index-remove index object))
	      (let ((*indices-remove-p* nil))
		(if previous-slot-boundp
		    (setf (slot-value object slot-name) previous-slot-value)
		    (slot-makunbound object slot-name)))))))
      result)))

(defmethod slot-makunbound-using-class
    ((class indexed-class) object (slot index-effective-slot-definition))
  (let* ((slot-name (slot-definition-name slot))
	 (previous-slot-boundp (slot-boundp object slot-name))
	 (indices (index-effective-slot-definition-indices slot)))
    (when (and previous-slot-boundp
	       *indices-remove-p*)
      (let ((changed-indices nil)
	    (error t))
	(unwind-protect
	     (progn
	       (dolist (index indices)
		 (index-remove index object)
		 (push index changed-indices))
	       (setf error nil))
	  (when error
	    (dolist (index changed-indices)
	      (index-add index object))))))
    (call-next-method)))

(defmethod clear-class-indices ((class indexed-class))
  (map nil #'(lambda (holder) (index-clear (index-holder-index holder)))
       (indexed-class-indices class)))

(defmethod clear-slot-indices ((slot index-effective-slot-definition))
  (map nil #'index-clear (index-effective-slot-definition-indices slot)))

(defmethod class-slot-indices ((class indexed-class) slot-name)
  (index-effective-slot-definition-indices (find slot-name (class-slots class)
                                                 :key #'slot-definition-name)))

(defmethod class-slot-index ((class indexed-class) slot-name)
  (let ((holder (find-if #'(lambda (holder) (and (eql (index-holder-class holder) class)
						 (eql (index-holder-name holder) slot-name)))
			 (indexed-class-indices class))))
    (when holder
      (index-holder-index holder))))
	
;;; destroy object mechanic

(defgeneric destroy-object-with-class (class object))

(defgeneric destroy-object (object)
  (:documentation "Destroy the given object, and delete it from the indices."))

(defmethod destroy-object-with-class ((class standard-class) object)
  (declare (ignore object))
  (error "Can not destroy an object that is not indexed."))

(defmethod destroy-object-with-class ((class indexed-class) object)
  (dolist (index (mapcar #'index-holder-index (indexed-class-indices class)))
    (index-remove index object))
  (setf (slot-value object 'destroyed-p) t))

(defmethod destroy-object ((object t))
  (destroy-object-with-class (class-of object) object))

(defmethod object-destroyed-p ((object t))
  (and object
       (slot-boundp object 'destroyed-p)
       (slot-value object 'destroyed-p)))