X-Git-Url: http://git.kpe.io/?p=kmrcl.git;a=blobdiff_plain;f=mop.lisp;h=06d3e01acfe9cbc5c61e5a5b76aede0500083411;hp=8decec559d7ec7330ac0e79202d4817b53da800c;hb=HEAD;hpb=526eef1b59e071cbb4ecd35f73a14c1a3f8e32b6 diff --git a/mop.lisp b/mop.lisp index 8decec5..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,29 +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*))) + (find-package 'common-lisp)) + (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 ) ) @@ -56,8 +52,8 @@ (defmacro process-class-option (metaclass slot-name &optional required) #+lispworks `(defmethod clos:process-a-class-option ((class ,metaclass) - (name (eql ,slot-name)) - value) + (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)) @@ -68,10 +64,10 @@ (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) + (option (eql ,slot-name)) + value + already-processed-options + slot) (list* option `',value already-processed-options)) #-lispworks (declare (ignore metaclass slot-name)) @@ -79,29 +75,43 @@ (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) #+lispworks '(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) + #+clisp + '(clos::compute-effective-slot-definition-initargs) #+cmu '(pcl:class-of pcl:class-name pcl:class-slots pcl:find-class pcl::standard-class pcl::slot-definition-name pcl:finalize-inheritance @@ -129,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 @@ -140,45 +150,40 @@ 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)) - - #+sbcl - (if (find-package 'sb-mop) - (setq cl:*features* (delete :kmr-sbcl-mop cl:*features*)) - (setq cl:*features* (delete :kmr-sbcl-pcl cl:*features*))) - + 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)) + #+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