cl-closer-mop 2:0.6-1 / usr / share / common-lisp / source / closer-mop / closer-ecl.lisp

(in-package :closer-mop)

(defmacro removef (place item)
  `(setf ,place (remove ,item ,place)))

(defun extract-lambda-list (lambda-list)
  (loop for (arg . rest) on lambda-list
        for keyp = (member arg lambda-list-keywords)
        until keyp
        if (consp arg)
        collect (car arg) into args
        else collect arg into args
        finally (return (if keyp
                          (nconc args (cons arg rest))
                          args))))

(defun extract-specializer-names (lambda-list)
  (loop for arg in lambda-list
        until (member arg lambda-list-keywords)
        if (consp arg)
        collect (cadr arg)
        else collect 't))

(cl:defgeneric generic-function-method-class (object)
  (:method ((gf generic-function))
   (clos:generic-function-method-class gf)))

(cl:defmethod compute-discriminating-function ((gf generic-function)) t)

(cl:defmethod make-method-lambda ((gf generic-function) (method method)
                                  lambda-expression environment)
  (declare (ignore environment))
  (destructuring-bind
      (lambda (&rest args) &body body)
      lambda-expression
    (declare (ignore args))
    (assert (eq lambda 'lambda))
    (values
     lambda-expression
     (let ((documentation (parse-method-body body lambda-expression)))
       (when documentation
         (list 'documentation documentation))))))

(cl:defmethod compute-effective-method-function ((gf standard-generic-function) effective-method options)
  (declare (optimize (speed 3) (space 0) (compilation-speed 0)))
  (when options
    (cerror "Ignore these options."
            "This version of compute-effective-method-function does not support method combination options: ~S"
            options))
  (if (only-standard-methods gf)
    effective-method
    (lambda (&rest args)
      (declare (dynamic-extent args))
      (funcall effective-method args nil))))

(cl:defgeneric find-method-combination (generic-function type options)
  (:method ((gf generic-function) type options)
   (cons type options)))

(defclass standard-class (cl:standard-class)
  ((direct-methods :initform '() :reader specializer-direct-methods)))

(defun optimize-slot-access-p (class)
  (flet ((applicablep (specializer)
           (if (consp specializer)
             (eql class (eql-specializer-object specializer))
             (subclassp (class-of class) specializer))))
    (when (and (loop for method in (generic-function-methods #'slot-value-using-class)
                     never (applicablep (first (method-specializers method))))
               (loop for method in (generic-function-methods #'(setf slot-value-using-class))
                     never (applicablep (second (method-specializers method)))))
      '(t))))

(cl:defmethod initialize-instance :around ((class standard-class) &rest initargs)
  (declare (dynamic-extent initargs))
  (apply #'call-next-method class
         :optimize-slot-access
         (optimize-slot-access-p class)
         initargs))

(cl:defmethod reinitialize-instance :around ((class standard-class) &rest initargs)
  (declare (dynamic-extent initargs))
  (apply #'call-next-method class
         :optimize-slot-access
         (optimize-slot-access-p class)
         initargs))

(cl:defmethod initialize-instance :around ((class funcallable-standard-class) &rest initargs)
  (declare (dynamic-extent initargs))
  (apply #'call-next-method class
         :optimize-slot-access
         (optimize-slot-access-p class)
         initargs))

(cl:defmethod reinitialize-instance :around ((class funcallable-standard-class) &rest initargs)
  (declare (dynamic-extent initargs))
  (apply #'call-next-method class
         :optimize-slot-access
         (optimize-slot-access-p class)
         initargs))

(cl:defmethod initialize-instance :before ((class standard-class) &key direct-superclasses)
  (assert (loop for superclass in direct-superclasses
                always (validate-superclass class superclass))))

(cl:defmethod reinitialize-instance :before ((class standard-class) &key (direct-superclasses '() direct-superclasses-p))
  (when direct-superclasses-p
    (assert (loop for superclass in direct-superclasses
                  always (validate-superclass class superclass)))
    (loop for superclass in (class-direct-superclasses class)
          unless (member superclass direct-superclasses)
          do (remove-direct-subclass superclass class))))

(cl:defmethod initialize-instance :before ((class funcallable-standard-class) &key direct-superclasses)
  (assert (loop for superclass in direct-superclasses
                always (validate-superclass class superclass))))

(cl:defmethod initialize-instance :before ((class funcallable-standard-class) &key direct-superclasses)
  (assert (loop for superclass in direct-superclasses
                always (validate-superclass class superclass))))

(cl:defmethod (setf class-name) (new-value (class standard-class))
  (reinitialize-instance class :name new-value)
  new-value)

(cl:defmethod (setf generic-function-name) (new-value (gf standard-generic-function))
  (reinitialize-instance gf :name new-value)
  new-value)

(defvar *direct-methods-for-built-in-classes*
  (make-hash-table :test #'eq))

(cl:defgeneric add-direct-method (specializer method)
  (:method ((specializer class) (method method)))
  (:method ((specializer built-in-class) (method method))
   (pushnew method (gethash specializer *direct-methods-for-built-in-classes*)))
  (:method ((specializer standard-class) (method method))
   (pushnew method (slot-value specializer 'direct-methods)))
  (:method ((specializer funcallable-standard-class) (method method))
   (pushnew method (slot-value specializer 'direct-methods))))

(cl:defgeneric remove-direct-method (specializer method)
  (:method ((specializer class) (method method)))
  (:method ((specializer built-in-class) (method method))
   (removef (gethash specializer *direct-methods-for-built-in-classes*) method))
  (:method ((specializer standard-class) (method method))
   (removef (slot-value specializer 'direct-methods) method))
  (:method ((specializer funcallable-standard-class) (method method))
   (removef (slot-value specializer 'direct-methods) method)))

(defvar *dependents* (make-hash-table :test #'eq))

(cl:defgeneric add-dependent (metaobject dependent)
  (:method ((metaobject standard-class) dependent)
    (pushnew dependent (gethash metaobject *dependents*)))
  (:method ((metaobject funcallable-standard-class) dependent)
    (pushnew dependent (gethash metaobject *dependents*)))
  (:method ((metaobject standard-generic-function) dependent)
    (pushnew dependent (gethash metaobject *dependents*))))

(cl:defgeneric remove-dependent (metaobject dependent)
  (:method ((metaobject standard-class) dependent)
    (setf (gethash metaobject *dependents*)
	  (delete dependent (gethash metaobject *dependents*))))
  (:method ((metaobject funcallable-standard-class) dependent)
    (setf (gethash metaobject *dependents*)
	  (delete dependent (gethash metaobject *dependents*))))
  (:method ((metaobject standard-generic-function) dependent)
    (setf (gethash metaobject *dependents*)
	  (delete dependent (gethash metaobject *dependents*)))))

(cl:defgeneric map-dependents (metaobject function)
  (:method ((metaobject standard-class) function)
    (mapc function (gethash metaobject *dependents*)))
  (:method ((metaobject funcallable-standard-class) function)
    (mapc function (gethash metaobject *dependents*)))
  (:method ((metaobject standard-generic-function) function)
    (mapc function (gethash metaobject *dependents*))))

(cl:defgeneric update-dependent (metaobject dependent &rest initargs))

(cl:defmethod reinitialize-instance :after ((metaobject standard-class) &rest initargs)
  (declare (dynamic-extent initargs))
  (map-dependents metaobject (lambda (dep) (apply #'update-dependent metaobject dep initargs))))

(cl:defmethod reinitialize-instance :after ((metaobject funcallable-standard-class) &rest initargs)
  (declare (dynamic-extent initargs))
  (map-dependents metaobject (lambda (dep) (apply #'update-dependent metaobject dep initargs))))

(cl:defmethod initialize-instance :after ((gf standard-generic-function) &rest initargs)
  (declare (ignore initargs))
  (set-funcallable-instance-function gf (compute-discriminating-function gf)))

(cl:defmethod ensure-generic-function-using-class :around ((gf null) name &rest initargs)
  (declare (ignore name initargs))
  (let ((new-gf (call-next-method)))
    (if (typep new-gf 'standard-generic-function)
      (set-funcallable-instance-function new-gf (compute-discriminating-function new-gf))
      new-gf)))

(cl:defmethod reinitialize-instance :after ((gf standard-generic-function) &rest initargs)
  (declare (dynamic-extent initargs))
  (set-funcallable-instance-function gf (compute-discriminating-function gf))
  (map-dependents gf (lambda (dep) (apply #'update-dependent gf dep initargs))))

(cl:defgeneric remove-method (gf method)
  (:method ((gf generic-function) (method method))
   (cl:remove-method gf method)))

(cl:defmethod remove-method :after ((gf standard-generic-function) (method method))
  (set-funcallable-instance-function gf (compute-discriminating-function gf))
  (loop for specializer in (method-specializers method)
        if (consp specializer) do (remove-direct-method (intern-eql-specializer*
                                                         (eql-specializer-object specializer))
                                                        method)
        else do (remove-direct-method specializer method))
  (map-dependents gf (lambda (dep) (update-dependent gf dep 'remove-method method))))

(cl:defgeneric find-method (gf qualifiers specializers &optional errorp)
  (:method ((gf generic-function) qualifiers specializers &optional (errorp t))
   (cl:find-method gf qualifiers specializers errorp)))

(cl:defmethod add-method :before ((gf standard-generic-function) (method method))
  (let ((other-gf (method-generic-function method)))
    (unless (or (null other-gf) (eq other-gf gf))
      (error "The method ~S belongs to the generic function ~S and cannot be added to ~S."
             method other-gf gf)))
  (let ((old-method (find-method gf
                                 (method-qualifiers method)
                                 (method-specializers method)
                                 nil)))
    (when old-method
      (remove-method gf old-method))))

(cl:defmethod add-method :after ((gf standard-generic-function) (method method))
  (set-funcallable-instance-function gf (compute-discriminating-function gf))
  (loop for specializer in (method-specializers method)
        if (consp specializer) do (add-direct-method (intern-eql-specializer*
                                                      (eql-specializer-object specializer))
                                                     method)
        else do (add-direct-method specializer method))
  (map-dependents gf (lambda (dep) (update-dependent gf dep 'add-method method))))

(defun eql-specializer-p (thing)
  (and (consp thing)
       (eq (car thing) 'eql)
       (null (cddr thing))))

(deftype eql-specializer ()
  '(or eql-specializer* (satisfies eql-specializer-p)))

(cl:defgeneric eql-specializer-object (eql-specializer)
  (:method ((cons cons))
   (if (eql-specializer-p cons)
     (cadr cons)
     (error "~S is not an eql-specializer." cons))))

(defun intern-eql-specializer (object)
  `(eql ,object))

(cl:defmethod specializer-direct-methods ((cons cons))
  (specializer-direct-methods (eql-specializer-object cons)))

(defclass eql-specializer* ()
  ((obj :reader eql-specializer-object
        :initarg eso
        :initform (error "Use intern-eql-specializer to create eql-specializers."))
   (direct-methods :reader specializer-direct-methods
                   :accessor es-direct-methods
                   :initform ())))

(defvar *eql-specializers* (make-hash-table))

#+threads
(defvar *eql-specializers-lock* (mp:make-lock :name 'eql-specializers))

(defmacro with-eql-specializers-lock (&body body)
  #+threads `(mp:with-lock (*eql-specializers-lock*) ,@body)
  #-threads `(progn ,@body))

(defun intern-eql-specializer* (object)
  (or #+threads (gethash object *eql-specializers*)
      (with-eql-specializers-lock
       (or (gethash object *eql-specializers*)
           (setf (gethash object *eql-specializers*)
                 (make-instance 'eql-specializer* 'eso object))))))

(cl:defmethod add-direct-method ((specializer eql-specializer*) (method method))
  (pushnew method (es-direct-methods specializer)))

(cl:defmethod remove-direct-method ((specializer eql-specializer*) (method method))
  (removef (es-direct-methods specializer) method))

(cl:defgeneric specializer-direct-generic-functions (specializer)
  (:method ((class class))
   (remove-duplicates
    (mapcar #'method-generic-function
            (specializer-direct-methods class))))
  (:method ((eql-specializer eql-specializer*))
   (remove-duplicates
    (mapcar #'method-generic-function
            (specializer-direct-methods eql-specializer))))
  (:method ((cons cons))
   (specializer-direct-generic-functions
    (intern-eql-specializer*
     (eql-specializer-object cons)))))

(cl:defgeneric validate-superclass (class superclass)
  (:method (class superclass)
   (or (eq superclass (find-class 't))
       (typep superclass (find-class 'forward-referenced-class))
       (eq (class-of class) (class-of superclass))
       (let ((compatible-classes (list (find-class 'cl:standard-class)
                                       (find-class 'standard-class)
                                       (find-class 'clos:funcallable-standard-class)
                                       (find-class 'funcallable-standard-class))))
         (and (member (class-of class) compatible-classes)
              (member (class-of superclass) compatible-classes))))))

(define-validate-superclass-method standard-class cl:standard-class)
(define-validate-superclass-method funcallable-standard-class clos:funcallable-standard-class)

(eval-when (:compile-toplevel :load-toplevel :execute)
  (pushnew :closer-mop *features*))