X-Git-Url: http://git.kpe.io/?p=kmrcl.git;a=blobdiff_plain;f=mop.lisp;h=f6bd037d1fb8cba81ba694c2ed969fd2ebd45723;hp=c62a2505dff269930403053746196db332b042f7;hb=888acd079f2e1350ba5f034cb5c93382311e3ff3;hpb=a3ddf56dae1326e736facc5d8034b457bbad1200 diff --git a/mop.lisp b/mop.lisp index c62a250..f6bd037 100644 --- a/mop.lisp +++ b/mop.lisp @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Apr 2003 ;;;; -;;;; $Id: mop.lisp,v 1.12 2003/04/29 10:33:32 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,7 +42,11 @@ #+kmr-cmucl-mop #:mop #+allegro #:mop #+lispworks #:clos - #+scl #:clos)) + #+clisp #:clos + #+scl #:clos + #+openmcl #:openmcl-mop + ) + ) (in-package #:kmr-mop) @@ -49,29 +54,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)) - #+(or allegro sbcl cmu scl) - (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) @@ -80,6 +85,8 @@ '(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 @@ -120,50 +127,61 @@ 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 - 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*))) - + #+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) + (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) + (ensure-generic-function + 'direct-slot-definition-class))) + 3) (pushnew :kmr-normal-dsdc cl:*features*)) ) ;; eval-when