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.")
    (: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
     #: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)

OpenMCL

SBCL

#+sbcl

CMUCL

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

Lispworks

#+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

ALLEGRO

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

Building the MOPP package 

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.")