X-Git-Url: http://git.kpe.io/?p=kmrcl.git;a=blobdiff_plain;f=mop.lisp;h=f8aba54c1f26ae47ed39b74987ed1c056938e15f;hp=82fcb471dd51affbf49563ddaecb06f244c5c7fa;hb=54cd6cb1b9550ac2310e2c6dffc9cdecd2bdccd3;hpb=d11d6cc43fd9227a8aeed28dc2cfecdbc587ec4a

diff --git a/mop.lisp b/mop.lisp
index 82fcb47..f8aba54 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
@@ -24,26 +22,27 @@
 #+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*)))
+      (pushnew 'kmrcl::sbcl-mop cl:*features*)
+      (pushnew 'kmrcl::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*)))
+          (find-package 'common-lisp))
+      (pushnew 'kmrcl::cmucl-mop cl:*features*)
+      (pushnew 'kmrcl::cmucl-pcl cl:*features*)))
 
 (defpackage #:kmr-mop
   (:use
    #:cl
    #:kmrcl
-   #+kmr-sbcl-mop #:sb-mop
-   #+kmr-cmucl-mop #:mop
+   #+kmrcl::sbcl-mop #:sb-mop
+   #+kmrcl::cmucl-mop #:mop
    #+allegro #:mop
    #+lispworks #:clos
+   #+clisp #:clos
    #+scl #:clos
-   #+openmcl #:openmcl-mop
+   #+ccl #:openmcl-mop
    )
   )
 
@@ -53,29 +52,29 @@
 (defun intern-eql-specializer (slot)
   `(eql ,slot))
 
-  (defmacro process-class-option (metaclass slot-name &optional required)
-    #+lispworks
-    `(defmethod clos:process-a-class-option ((class ,metaclass)
-					     (name (eql ,slot-name))
-					     value)
-      (when (and ,required (null value))
-	(error "metaclass ~A class slot ~A must have a value" (quote ,metaclass) name))
-      (list name `',value))
-    #-lispworks
-    (declare (ignore metaclass slot-name required))
-    )
-
-  (defmacro process-slot-option (metaclass slot-name)
-    #+lispworks
-    `(defmethod clos:process-a-slot-option ((class ,metaclass)
-					    (option (eql ,slot-name))
-					    value
-					    already-processed-options
-					    slot)
-      (list* option `',value already-processed-options))
-    #-lispworks
-    (declare (ignore metaclass slot-name))
-    )
+(defmacro process-class-option (metaclass slot-name &optional required)
+  #+lispworks
+  `(defmethod clos:process-a-class-option ((class ,metaclass)
+                                           (name (eql ,slot-name))
+                                           value)
+    (when (and ,required (null value))
+      (error "metaclass ~A class slot ~A must have a value" (quote ,metaclass) name))
+    (list name `',value))
+  #-lispworks
+  (declare (ignore metaclass slot-name required))
+  )
+
+(defmacro process-slot-option (metaclass slot-name)
+  #+lispworks
+  `(defmethod clos:process-a-slot-option ((class ,metaclass)
+                                          (option (eql ,slot-name))
+                                          value
+                                          already-processed-options
+                                          slot)
+    (list* option `',value already-processed-options))
+  #-lispworks
+  (declare (ignore metaclass slot-name))
+  )
 
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
@@ -84,11 +83,13 @@
    '(excl::compute-effective-slot-definition-initargs)
    #+lispworks
    '(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
+   '(#+kmrcl::sbcl-mop class-of #-kmrcl::sbcl-mop sb-pcl:class-of
+     #+kmrcl::sbcl-mop class-name #-kmrcl::sbcl-mop sb-pcl:class-name
+     #+kmrcl::sbcl-mop class-slots #-kmrcl::sbcl-mop sb-pcl:class-slots
+     #+kmrcl::sbcl-mop find-class #-kmrcl::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
@@ -129,7 +130,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
@@ -140,45 +141,45 @@
      openmcl-mop:class-prototype openmcl-mop:generic-function-method-class openmcl-mop:intern-eql-specializer
      openmcl-mop:make-method-lambda openmcl-mop:generic-function-lambda-list
      openmcl-mop::compute-slots)   ))
-  
+
 (eval-when (:compile-toplevel :load-toplevel :execute)
   (export '(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
-	    compute-effective-slot-definition-initargs
-	    direct-slot-definition-class effective-slot-definition-class
-	    compute-effective-slot-definition
-	    slot-value-using-class
-	    class-prototype generic-function-method-class intern-eql-specializer
-	    make-method-lambda generic-function-lambda-list
-	    compute-slots
-	    class-direct-slots
-	    ;; KMR-MOP encapsulating macros
-	    process-slot-option
-	    process-class-option))
-  
+            standard-class
+            slot-definition-name finalize-inheritance
+            standard-direct-slot-definition
+            standard-effective-slot-definition validate-superclass
+            compute-effective-slot-definition-initargs
+            direct-slot-definition-class effective-slot-definition-class
+            compute-effective-slot-definition
+            slot-value-using-class
+            class-prototype generic-function-method-class intern-eql-specializer
+            make-method-lambda generic-function-lambda-list
+            compute-slots
+            class-direct-slots
+            ;; KMR-MOP encapsulating macros
+            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*)))
-  
+      (setq cl:*features* (delete 'kmrcl::sbcl-mop cl:*features*))
+      (setq cl:*features* (delete 'kmrcl::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*)))
-  
-  (when (>= (length (generic-function-lambda-list
-		     (ensure-generic-function
-		      'compute-effective-slot-definition)))
-	    3)
-    (pushnew :kmr-normal-cesd cl:*features*))
-  
-  (when (>= (length (generic-function-lambda-list
-		     (ensure-generic-function
-		      'direct-slot-definition-class)))
-	    3)
-    (pushnew :kmr-normal-dsdc 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
+                     (ensure-generic-function
+                      'compute-effective-slot-definition)))
+            3)
+    (pushnew 'short-arg-cesd cl:*features*))
+
+  (when (< (length (generic-function-lambda-list
+                    (ensure-generic-function
+                     'direct-slot-definition-class)))
+           3)
+    (pushnew 'short-arg-dsdc cl:*features*))
 
   )  ;; eval-when