X-Git-Url: http://git.kpe.io/?p=kmrcl.git;a=blobdiff_plain;f=mop.lisp;h=8decec559d7ec7330ac0e79202d4817b53da800c;hp=cad16f328edfa52a2464e9b996a67e8c562a4cdd;hb=3884e25c65417de34331b45a7b68d479dde15949;hpb=858422593b76417361614970d9b84f462f58b6d9 diff --git a/mop.lisp b/mop.lisp index cad16f3..8decec5 100644 --- a/mop.lisp +++ b/mop.lisp @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Apr 2003 ;;;; -;;;; $Id: mop.lisp,v 1.9 2003/04/29 05:57:24 kevin Exp $ +;;;; $Id$ ;;;; ;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; @@ -29,7 +29,8 @@ #+cmu (eval-when (:compile-toplevel :load-toplevel :execute) - (if (find-package 'mop) + (if (eq (symbol-package 'pcl:find-class) + (find-package 'common-lisp)) (pushnew :kmr-cmucl-mop cl:*features*) (pushnew :kmr-cmucl-pcl cl:*features*))) @@ -41,37 +42,48 @@ #+kmr-cmucl-mop #:mop #+allegro #:mop #+lispworks #:clos - #+scl #:clos)) + #+scl #:clos + #+openmcl #:openmcl-mop + ) + ) (in-package #:kmr-mop) +#+lispworks +(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)) + ) + + (eval-when (:compile-toplevel :load-toplevel :execute) (shadowing-import #+allegro - '(class-of class-name class-slots find-class mop::standard-class - mop::slot-definition-name mop:finalize-inheritance - mop::standard-direct-slot-definition mop::standard-effective-slot-definition - mop::validate-superclass mop:direct-slot-definition-class - mop:compute-effective-slot-definition - excl::compute-effective-slot-definition-initargs - mop::slot-value-using-class - mop:class-prototype mop:generic-function-method-class mop:intern-eql-specializer - mop:make-method-lambda mop:generic-function-lambda-list - mop::compute-slots - ;; note: make-method-lambda is not fbound - ) + '(excl::compute-effective-slot-definition-initargs) #+lispworks - '(class-of class-name class-slots find-class - clos::standard-class - clos:slot-definition-name clos::finalize-inheritance - clos::standard-direct-slot-definition - clos::standard-effective-slot-definition clos::validate-superclass - clos::direct-slot-definition-class clos::compute-effective-slot-definition - clos::compute-effective-slot-definition-initargs - clos::slot-value-using-class - clos:class-prototype clos:generic-function-method-class clos:intern-eql-specializer - clos:make-method-lambda clos:generic-function-lambda-list - clos::compute-slots) + '(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 @@ -81,7 +93,10 @@ 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::compute-effective-slot-definition + 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 @@ -91,8 +106,9 @@ '(pcl:class-of pcl:class-name pcl:class-slots pcl:find-class pcl::standard-class pcl::slot-definition-name pcl:finalize-inheritance pcl::standard-direct-slot-definition pcl::standard-effective-slot-definition - pcl::validate-superclass pcl:direct-slot-definition-class + pcl::validate-superclass pcl:direct-slot-definition-class pcl::effective-slot-definition-class pcl:compute-effective-slot-definition + pcl:class-direct-slots pcl::compute-effective-slot-definition-initargs pcl::slot-value-using-class pcl:class-prototype pcl:generic-function-method-class pcl:intern-eql-specializer @@ -102,27 +118,46 @@ '(class-of class-name class-slots find-class clos::standard-class clos::slot-definition-name clos:finalize-inheritance clos::standard-direct-slot-definition clos::standard-effective-slot-definition + clos::effective-slot-definition-class + clos:class-direct-slots clos::validate-superclass clos:direct-slot-definition-class clos:compute-effective-slot-definition clos::compute-effective-slot-definition-initargs clos::slot-value-using-class - clos:class-prototype clos:generic-function-method-class clos:intern-eql-specializer + clos::class-prototype clos:generic-function-method-class clos:intern-eql-specializer clos:make-method-lambda clos:generic-function-lambda-list clos::compute-slots ;; note: make-method-lambda is not fbound - )) + ) + #+openmcl + '(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 + openmcl-mop:compute-effective-slot-definition + openmcl-mop:class-direct-slots + openmcl-mop::compute-effective-slot-definition-initargs + openmcl-mop::slot-value-using-class + 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 - direct-slot-definition-class compute-effective-slot-definition 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)) + compute-slots + class-direct-slots + ;; KMR-MOP encapsulating macros + process-slot-option + process-class-option)) #+sbcl (if (find-package 'sb-mop)