arnesi

A MOP compatability protocol 

(defpackage :it.bese.arnesi.mopp
    (:nicknames :mopp)
    (:documentation "A MOP compatabilitly layer.[...]

This package wraps the various similar but slightly different MOP
APIs. All the MOP symbols are exported (even those which are
normally exported from the common-lisp package) though not all
maybe be properly defined on all lisps.

The name of the library in an acronym for \"the Meta Object
Protocol Package\".

This package is nominally part of the arnesi utility library but
has been written so that this single file can be included in
other applications without requiring the rest of the arnesi
library.

Implementation Notes:

1) The mopp package also exports the function
   SLOT-DEFINITION-DOCUMENTATION which while not strictly part of
   the MOP specification really should be and is implementened on
   most systems.

2) On Lispworks (tested only lightly) the MOPP package
   implementes an eql-specializer class and defines a version of
   method-specializers built upon clos:method-specializers which
   returns them.

3) Various MOP implementations differ in their handling of
   direct-slot initargs, some return all of them in a
   list (should the arg appear more times), some only return the
   last and some only the first. The MOPP package defines a
   function mopp:direct-slot-definition-value which attempts to
   hide this difference (though not without some loss of
   flexibility), see the function documentation for more
   details.")
    (:use)
    (:export
     ;; classes
     #:standard-object
     #:funcallable-standard-object
     #:metaobject
     #:generic-function
     #:standard-generic-function
     #:method
     #:standard-method
     #:standard-accessor-method
     #:standard-reader-method
     #:standard-writer-method
     #:method-combination
     #:slot-definition
     #:direct-slot-definition
     #:direct-slot-definition-value
     #:effective-slot-definition
     #:standard-slot-definition
     #:standard-direct-slot-definition
     #:standard-effective-slot-definition
     #:specializer
     #:eql-specializer
     #:class
     #:built-in-class
     #:forward-referenced-class
     #:standard-class
     #:funcallable-standard-class
     ;; Taken from the MOP dictionary
     #:accessor-method-slot-definition
     #:add-dependent 
     #:add-direct-method 
     #:add-direct-subclass 
     #:add-method 
     #:allocate-instance
     #:class-default-initargs
     #:class-direct-default-initargs
     #:class-direct-slots
     #:class-direct-subclasses
     #:class-direct-superclasses
     #:class-finalized-p
     #:class-name
     #:class-precedence-list
     #:class-prototype
     #:class-slots
     #:compute-applicable-methods 
     #:compute-applicable-methods-using-classes 
     #:compute-class-precedence-list 
     #:compute-default-initargs 
     #:compute-discriminating-function 
     #:compute-effective-method 
     #:compute-effective-slot-definition 
     #:compute-slots 
     #:direct-slot-definition-class 
     #:effective-slot-definition-class
     #:ensure-class-using-class 
     #:ensure-generic-function 
     #:ensure-generic-function-using-class 
     #:eql-specializer-object 
     #:extract-lambda-list 
     #:extract-specializer-names 
     #:finalize-inheritance 
     #:find-method-combination 
     #:funcallable-standard-instance-access 
     #:generic-function-argument-precedence-order
     #:generic-function-declarations
     #:generic-function-lambda-list
     #:generic-function-method-class
     #:generic-function-method-combination
     #:generic-function-methods
     #:generic-function-name
     #:intern-eql-specializer 
     #:make-instance 
     #:make-method-lambda 
     #:map-dependents
     #:method-function
     #:method-generic-function
     #:method-lambda-list
     #:method-specializers
     #:method-qualifiers
     #:reader-method-class 
     #:remove-dependent 
     #:remove-direct-method 
     #:remove-direct-subclass 
     #:remove-method 
     #:set-funcallable-instance-function 
     #:slot-boundp-using-class
     #:slot-definition-allocation
     #:slot-definition-documentation
     #:slot-definition-initargs
     #:slot-definition-initform
     #:slot-definition-initfunction
     #:slot-definition-location
     #:slot-definition-name
     #:slot-definition-readers
     #:slot-definition-writers
     #:slot-definition-type
     #:slot-makunbound-using-class 
     #:slot-value-using-class 
     #:specializer-direct-generic-functions 
     #:specializer-direct-methods 
     #:standard-instance-access 
     #:update-dependent 
     #:validate-superclass 
     #:writer-method-class))

(defpackage :it.bese.arnesi.mopp%internals
  (:use :common-lisp))

(in-package :it.bese.arnesi.mopp%internals)

(defgeneric provide-mopp-symbol (symbol implementation)
  (:documentation "Provide the implementation of the MOP symbol SYMBOL.
[...]
SYMBOL - One of the external symbols of the package it.bese.arnesi.mopp

IMPLEMENTATION - A keyword indetifying the implementation, one
of: :OPENMCL, :SBCL, :CMU, :LISPWORKS, :ALLEGRO.

Do \"something\" such that the external symbol SYMBOL in the mopp
package provides the sematics for the like named symbol in the
MOP. Methods defined on this generic function are free to
destructivly modify SYMBOL (and the mopp package) as long as when
the method terminates there is a symbol with the same name as
SYMBOL exported form the package mopp.

Methods must return a true value if they have successfully
provided SYMBOL and nil otherwise."))

(defun import-to-mopp (symbol)
  (let ((sym (find-symbol (string symbol) :it.bese.arnesi.mopp)))
    (when sym[...]
      (unexport sym :it.bese.arnesi.mopp)
      (unintern sym :it.bese.arnesi.mopp)))
  (import symbol :it.bese.arnesi.mopp)
  (export symbol :it.bese.arnesi.mopp)
  t)

OpenMCL 

(defmethod provide-mopp-symbol ((symbol symbol)
                                (implementation (eql :openmcl)))
  "Provide MOP symbols for OpenMCL.[...]

All of OpenMCL's MOP is defined in the CCL package."
  (when (find-symbol (string symbol) :ccl)
    (import-to-mopp (find-symbol (string symbol) :ccl))))

SBCL 

(defmethod provide-mopp-symbol ((symbol symbol)
                                (implementation (eql :sbcl)))
  (when (find-symbol (string symbol) :sb-mop)
    (import-to-mopp (find-symbol (string symbol) :sb-mop))))

(defmethod provide-mopp-symbol ((symbol (eql 'mopp:slot-definition-documentation))
                                (implementation (eql :sbcl)))
  "Provide SLOT-DEFINITION-DOCUMENTATION for SBCL.[...]

On SBCL SLOT-DEFINITION-DOCUMENTATION is just a call to
sb-pcl:documentation."
  t)

#+sbcl
(defun mopp:slot-definition-documentation (slot)
  (sb-pcl::documentation slot t))

CMUCL 

(defmethod provide-mopp-symbol ((symbol symbol) (implementation (eql :cmu)))
  (when (find-symbol (string symbol) :pcl)
    (import-to-mopp (find-symbol (string symbol) :pcl))))

(defmethod provide-mopp-symbol ((symbol (eql 'mopp:slot-definition-documentation))
                                (implementation (eql :cmu)))
  "Provide SLOT-DEFINITION-DOCUMENTATION on CMUCL.[...]

Like SBCL SLOT-DEFINITION-DOCUMENTATION on CMUCL is just a call
to documentation."
  t)

#+cmu
(defun mopp:slot-definition-documentation (slot)
  (documentation slot t))

Lispworks 

(defmethod provide-mopp-symbol ((symbol symbol) (implementation (eql :lispworks)))
  (when (find-symbol (string symbol) :clos)
    (import-to-mopp (find-symbol (string symbol) :clos))))

(defmethod provide-mopp-symbol ((symbol (eql 'mopp:eql-specializer))
                                (implementation (eql :lispworks)))
  t)

(defmethod provide-mopp-symbol ((symbol (eql 'mopp:eql-specializer-object))
                                (implementation (eql :lispworks)))
  t)

(defmethod provide-mopp-symbol ((symbol (eql 'mopp:method-specializers))
                                (implementation (eql :lispworks)))
  "We can not simply export CLOS:METHOD-SPECIALIZERS as we have
to insert mopp:eql-specializers"
  t)

#+lispworks
(defclass mopp:eql-specializer ()
  ((object :accessor mopp::eql-specializer-object :initarg :object))[...]
  (:documentation "Wrapper class representing eql-specializers.

Lispworks does not implement an eql-specializer class but simply
returns lists form method-specializers, this class (along with a
wrapper for clos:method-specializers) hide this detail."))

#+lispworks
(defun mopp:method-specializers (method)
  "More MOP-y implementation of clos:method-specializers.[...]

For every returned value of clos:method-specializers of the
form `(eql ,OBJECT) this function returns a mopp:eql-specializer
object wrapping OBJECT."
  (mapcar (lambda (spec)
            (typecase spec
              (cons (make-instance 'mopp:eql-specializer :object (second spec)))
              (t spec)))
          (clos:method-specializers method)))

CLISP 

(defmethod provide-mopp-symbol ((symbol symbol) (implementation (eql :clisp)))
  (when (find-symbol (string symbol) :clos)
    (import-to-mopp (find-symbol (string symbol) :clos))))

ALLEGRO 

(defmethod provide-mopp-symbol ((symbol symbol) (implementation (eql :allegro)))
  (when (find-symbol (string symbol) :mop)
    (import-to-mopp (find-symbol (string symbol) :mop))))

(defmethod provide-mopp-symbol ((symbol (eql 'mopp:slot-definition-documentation))
				(implementation (eql :allegro)))
  t)

#+allegro
(defun mopp:slot-definition-documentation (slot)
  (documentation slot t))

Build the package 

this is "builtin"

(defmethod provide-mopp-symbol ((symbol (eql 'mopp:direct-slot-definition-value))
                                (implementation t))
  t)

we can't just do a do-external-symbols since we mess with the package and that would put us in implementation dependent territory, so we first build up a list of all the external symbols in mopp and then work on that list.

#+(or
   openmcl
   sbcl[...]
   cmu
   lispworks
   clisp
   allegro)
(eval-when (:compile-toplevel :load-toplevel :execute)
  (push 'mopp::have-mop *features*))

#+mopp::have-mop
(let ((external-symbols '()))
  (do-external-symbols (sym (find-package :it.bese.arnesi.mopp))[...]
    (push sym external-symbols))
  (dolist (sym external-symbols)
    (unless (provide-mopp-symbol sym #+openmcl :openmcl
                                     #+sbcl :sbcl
                                     #+cmu :cmu
                                     #+lispworks :lispworks
                                     #+clisp :clisp
				     #+allegro :allegro)
      (warn "Unimplemented MOP symbol: ~S" sym))))

#-mopp::have-mop
(warn "No MOPP implementation available for this lisp implementation.")

Test how direct slots initargs are handeled and define mopp:direct-slot-definition-value accordingly.

#+mopp::have-mop
(eval-when (:compile-toplevel :execute)
  (defclass %meta-class (standard-class) ())[...]

  (defmethod mopp:validate-superclass ((c %meta-class) (s mopp:standard-class)) t)

  (defclass %dsd (mopp:standard-direct-slot-definition)
    ((%slot :accessor %slot :initarg :%slot :initform nil)))

  (defmethod mopp:direct-slot-definition-class ((c %meta-class) &rest initargs)
    (declare (ignore c initargs))
    (find-class '%dsd))

  (defclass %class ()
    ((a-slot :%slot 1))
    (:metaclass %meta-class))

  (let ((definition (if (consp (%slot (find-if (lambda (s)
						 (eql 'a-slot (mopp:slot-definition-name s)))
					       (mopp:class-direct-slots (find-class '%class)))))
			(lambda (slot-value) (first slot-value))
			(lambda (slot-value) slot-value))))
    
    (defun mopp:direct-slot-definition-value (slot-value)
      "Convert the value of a direct to a nominal form.

Since some MOP implementations provide all the values as initargs
to direct-slot-definitions (as (afaict) they should) as list and
some do not this function attempts to hide this difference by
returning a single value.

On those MOP implementations where direct-slot-definition values
are collected into a list the function returns the first
element (it is implementation dependent whether this is the first
elment which appears in the defclass form or not). On those MOP
implementations where direct-slot-definition only returns one
value (effectivly ignoring the others) this returns the value
untouched.

Examples:

  Assuming our class is defined like so:

  (defclass %class ()
    ((a-slot :%slot 1))
    (:metaclass %some-meta-class))

  We assume we access the values(s) passed as :%slot via a slot
  named %SLOT in the direct-slot-definition.

  (mopp:direct-slot-definition-value
   (slot-value (find-if (lambda (s) (eql 'a-slot (mopp:slot-definition-name s)))
                        (mopp:class-direct-slots (find-class '%class)))
               '%slot))
  ==> 1

  Redefing the class specifying :%slot twice:

  (defclass %class ()
    ((a-slot :%slot 1
             :%slot 2))
    (:metaclass %meta-class))

  (mopp:direct-slot-definition-value
   (slot-value (find-if (lambda (s) (eql 'a-slot (mopp:slot-definition-name s)))
                        (mopp:class-direct-slots (find-class '%class)))
               '%slot))
  ==> 1 or 2
"
  (funcall definition slot-value))))