[Small-cl-src] small mop compatability layer

[marco]

;;;; -*- lisp -*-

(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 library is a ancronym for "the Meta Object Protocol
Package".

Notes:

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

Lispworks - (tested only lightly) Implement a eql-specializer
class and define a version of method-specializers built upon
clos:method-specializers which returns them.

This package is 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.")
    (: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)

(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.

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-pcl)
    (import-to-mopp (find-symbol (string symbol) :sb-pcl))))

(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) hides 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)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Build the package

;; we can't jsut 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.

(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)
      (warn "Unimplemented MOP symbol: ~S" sym))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Copyright (C) 2004 Edward Marco Baringer <mb at bese.it>
;;;; All rights reserved. 
;;;; 
;;;; Redistribution and use in source and binary forms, with or without
;;;; modification, are permitted provided that the following conditions are
;;;; met:
;;;; 
;;;;  - Redistributions of source code must retain the above copyright
;;;;    notice, this list of conditions and the following disclaimer.
;;;; 
;;;;  - Redistributions in binary form must reproduce the above copyright
;;;;    notice, this list of conditions and the following disclaimer in the
;;;;    documentation and/or other materials provided with the distribution.
;;;;
;;;;  - Neither the name of Edward Marco Baringer, nor BESE, nor the names
;;;;    of its contributors may be used to endorse or promote products
;;;;    derived from this software without specific prior written permission.
;;;; 
;;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
;;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
;;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
;;;; A PARTICULAR PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE COPYRIGHT
;;;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
;;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
;;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
;;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
;;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
;;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
;;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

-- 
-Marco
Ring the bells that still can ring.
Forget your perfect offering.
There is a crack in everything.
That's how the light gets in.
     -Leonard Cohen