X-Git-Url: http://git.kpe.io/?p=kmrcl.git;a=blobdiff_plain;f=mop.lisp;h=06d3e01acfe9cbc5c61e5a5b76aede0500083411;hp=f6bd037d1fb8cba81ba694c2ed969fd2ebd45723;hb=HEAD;hpb=03712fbb06acbb103602bae10f41aeae7fa05127

diff --git a/mop.lisp b/mop.lisp
index f6bd037..06d3e01 100644
--- a/mop.lisp
+++ b/mop.lisp
@@ -7,9 +7,7 @@
 ;;;; Programmer:    Kevin M. Rosenberg
 ;;;; Date Started:  Apr 2003
 ;;;;
-;;;; $Id$
-;;;;
-;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;; This file, part of KMRCL, is Copyright (c) 2002-2010 by Kevin M. Rosenberg
 ;;;;
 ;;;; KMRCL users are granted the rights to distribute and use this software
 ;;;; as governed by the terms of the Lisp Lesser GNU Public License
@@ -21,30 +19,27 @@
 
 (in-package #:cl-user)
 
-#+sbcl
-(eval-when (:compile-toplevel :load-toplevel :execute)
-  (if (find-package 'sb-mop)
-      (pushnew :kmr-sbcl-mop cl:*features*)
-      (pushnew :kmr-sbcl-pcl cl:*features*)))
-
 #+cmu
 (eval-when (:compile-toplevel :load-toplevel :execute)
   (if (eq (symbol-package 'pcl:find-class)
           (find-package 'common-lisp))
-      (pushnew :kmr-cmucl-mop cl:*features*)
-      (pushnew :kmr-cmucl-pcl cl:*features*)))
+      (pushnew 'kmrcl::cmucl-mop cl:*features*)
+      (pushnew 'kmrcl::cmucl-pcl cl:*features*)))
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+           (when (find-package '#:kmr-mop)
+             (delete-package '#:kmr-mop)))
 
 (defpackage #:kmr-mop
   (:use
    #:cl
    #:kmrcl
-   #+kmr-sbcl-mop #:sb-mop
-   #+kmr-cmucl-mop #:mop
+   #+kmrcl::cmucl-mop #:mop
    #+allegro #:mop
    #+lispworks #:clos
    #+clisp #:clos
    #+scl #:clos
-   #+openmcl #:openmcl-mop
+   #+ccl #:openmcl-mop
    )
   )
 
@@ -80,6 +75,36 @@
 
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
+  #+sbcl
+  (dolist (name '("CLASS-OF"
+                  "CLASS-NAME"
+                  "CLASS-SLOTS"
+                  "FIND-CLASS"
+                  "STANDARD-CLASS"
+                  "SLOT-DEFINITION-NAME"
+                  "FINALIZE-INHERITANCE"
+                  "STANDARD-DIRECT-SLOT-DEFINITION"
+                  "STANDARD-EFFECTIVE-SLOT-DEFINITION"
+                  "VALIDATE-SUPERCLASS" "DIRECT-SLOT-DEFINITION-CLASS"
+                  "EFFECTIVE-SLOT-DEFINITION-CLASS"
+                  "COMPUTE-EFFECTIVE-SLOT-DEFINITION"
+                  "CLASS-DIRECT-SLOTS"
+                  "COMPUTE-EFFECTIVE-SLOT-DEFINITION-INITARGS"
+                  "SLOT-VALUE-USING-CLASS"
+                  "CLASS-PROTOTYPE"
+                  "GENERIC-FUNCTION-METHOD-CLASS"
+                  "INTERN-EQL-SPECIALIZER"
+                  "MAKE-METHOD-LAMBDA"
+                  "GENERIC-FUNCTION-LAMBDA-LIST"
+                  "COMPUTE-SLOTS"))
+    (let ((sym (find-symbol name "SB-MOP")))
+      (if sym
+          (shadowing-import sym)
+          (progn
+            (setq sym (find-symbol name "SB-PCL"))
+            (when sym
+              (shadowing-import sym))))))
+  #-sbcl
   (shadowing-import
    #+allegro
    '(excl::compute-effective-slot-definition-initargs)
@@ -87,24 +112,6 @@
    '(clos::compute-effective-slot-definition-initargs)
    #+clisp
    '(clos::compute-effective-slot-definition-initargs)
-   #+sbcl
-   '(#+kmr-sbcl-mop class-of #-kmr-sbcl-mop sb-pcl:class-of
-     #+kmr-sbcl-mop class-name #-kmr-sbcl-mop sb-pcl:class-name
-     #+kmr-sbcl-mop class-slots #-kmr-sbcl-mop sb-pcl:class-slots
-     #+kmr-sbcl-mop find-class #-kmr-sbcl-mop sb-pcl:find-class
-     sb-pcl::standard-class
-     sb-pcl:slot-definition-name sb-pcl::finalize-inheritance
-     sb-pcl::standard-direct-slot-definition
-     sb-pcl::standard-effective-slot-definition sb-pcl::validate-superclass
-     sb-pcl::direct-slot-definition-class
-     sb-pcl::effective-slot-definition-class
-     sb-pcl::compute-effective-slot-definition
-     sb-pcl:class-direct-slots
-     sb-pcl::compute-effective-slot-definition-initargs
-     sb-pcl::slot-value-using-class
-     sb-pcl:class-prototype sb-pcl:generic-function-method-class sb-pcl:intern-eql-specializer
-     sb-pcl:make-method-lambda sb-pcl:generic-function-lambda-list
-     sb-pcl::compute-slots)
    #+cmu
    '(pcl:class-of  pcl:class-name pcl:class-slots pcl:find-class pcl::standard-class
      pcl::slot-definition-name pcl:finalize-inheritance
@@ -132,7 +139,7 @@
      clos::compute-slots
      ;; note: make-method-lambda is not fbound
      )
-   #+openmcl
+   #+ccl
    '(openmcl-mop::slot-definition-name openmcl-mop:finalize-inheritance
      openmcl-mop::standard-direct-slot-definition openmcl-mop::standard-effective-slot-definition
      openmcl-mop::validate-superclass openmcl-mop:direct-slot-definition-class openmcl-mop::effective-slot-definition-class
@@ -162,26 +169,21 @@
             process-slot-option
             process-class-option))
 
-  #+sbcl
-  (if (find-package 'sb-mop)
-      (setq cl:*features* (delete :kmr-sbcl-mop cl:*features*))
-      (setq cl:*features* (delete :kmr-sbcl-pcl cl:*features*)))
-
   #+cmu
   (if (find-package 'mop)
-      (setq cl:*features* (delete :kmr-cmucl-mop cl:*features*))
-      (setq cl:*features* (delete :kmr-cmucl-pcl cl:*features*)))
+      (setq cl:*features* (delete 'kmrcl::cmucl-mop cl:*features*))
+      (setq cl:*features* (delete 'kmrcl::cmucl-pcl cl:*features*)))
 
-  (when (>= (length (generic-function-lambda-list
+  (when (< (length (generic-function-lambda-list
                      (ensure-generic-function
                       'compute-effective-slot-definition)))
             3)
-    (pushnew :kmr-normal-cesd cl:*features*))
+    (pushnew 'short-arg-cesd cl:*features*))
 
-  (when (>= (length (generic-function-lambda-list
-                     (ensure-generic-function
-                      'direct-slot-definition-class)))
-            3)
-    (pushnew :kmr-normal-dsdc cl:*features*))
+  (when (< (length (generic-function-lambda-list
+                    (ensure-generic-function
+                     'direct-slot-definition-class)))
+           3)
+    (pushnew 'short-arg-dsdc cl:*features*))
 
   )  ;; eval-when