From 23dc098eb50376f955b164df32cea3927ec7f945 Mon Sep 17 00:00:00 2001 From: "Kevin M. Rosenberg" Date: Tue, 29 Apr 2003 07:52:38 +0000 Subject: [PATCH] r4687: Automatic commit for debian_version_1_32-1 --- attrib-class.lisp | 50 ++++++++++++++++++-------------- mop.lisp | 74 ++++++++++++++++++++++++++++------------------- 2 files changed, 73 insertions(+), 51 deletions(-) diff --git a/attrib-class.lisp b/attrib-class.lisp index b5b8961..ee0228b 100644 --- a/attrib-class.lisp +++ b/attrib-class.lisp @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Apr 2000 ;;;; -;;;; $Id: attrib-class.lisp,v 1.11 2003/04/29 06:40:03 kevin Exp $ +;;;; $Id: attrib-class.lisp,v 1.12 2003/04/29 07:52:38 kevin Exp $ ;;;; ;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; @@ -21,6 +21,11 @@ (in-package :kmrcl) +(defclass attributes-class (kmr-mop:standard-class) + () + (:documentation "metaclass that implements attributes on slots. Based +on example from AMOP")) + (defclass attributes-dsd (kmr-mop:standard-direct-slot-definition) ((attributes :initarg :attributes :initform nil :accessor dsd-attributes))) @@ -29,12 +34,8 @@ ((attributes :initarg :attributes :initform nil :accessor esd-attributes))) - -(defclass attributes-class (kmr-mop:standard-class) - () - (:documentation "metaclass that implements attributes on slots. Based -on example from AMOP")) - +;; encapsulating macro for Lispworks +(kmr-mop:process-slot-option attributes-class :attributes) #+(or cmu scl sbcl) (defmethod kmr-mop:validate-superclass ((class attributes-class) @@ -45,25 +46,28 @@ on example from AMOP")) (declare (ignore initargs)) (kmr-mop:find-class 'attributes-dsd)) -#+ignore +(defmethod kmr-mop:effective-slot-definition-class ((cl attributes-class) #+kmr-normal-dsdc &rest initargs) + (declare (ignore initargs)) + (kmr-mop:find-class 'attributes-esd)) + (defmethod kmr-mop:compute-effective-slot-definition :around ((cl attributes-class) #+kmr-normal-cesd name dsds) - #+kmr-normal-cesd (declare (ignore name)) + #+(and kmr-normal-cesd (not lispworks)) (declare (ignore name)) (apply #'make-instance 'attributes-esd :attributes (remove-duplicates (mapappend #'dsd-attributes dsds)) - (kmr-mop::compute-effective-slot-definition-initargs cl dsds)) + (kmr-mop::compute-effective-slot-definition-initargs cl #+lispworks name dsds)) ) +#+ignore (defmethod kmr-mop:compute-effective-slot-definition :around - ((cl attributes-class) #+kmr-named-cesd name dsds) - #+kmr-named-cesd (declare (ignore name)) + ((cl attributes-class) #+kmr-normal-cesd name dsds) + #+kmr-normal-cesd (declare (ignore name)) (let ((esd (call-next-method))) + (setq esd (change-class esd 'attributes-esd)) (print esd) - (print (remove-duplicates - (mapappend #'dsd-attributes dsds))) - (setf (esd-attributes esd) - (remove-duplicates (mapappend #'dsd-attributes dsds))) + (print (remove-duplicates (mapappend #'dsd-attributes dsds))) + (setf (esd-attributes esd) (remove-duplicates (mapappend #'dsd-attributes dsds))) esd)) @@ -77,12 +81,14 @@ on example from AMOP")) (when attr-list (cons (kmr-mop:slot-definition-name slot) attr-list)))) normal-slots))) - (setq alist (delete nil alist)) - (cons (make-instance 'kmr-mop:standard-effective-slot-definition - :name 'all-attributes - :initform `',alist - :initfunction #'(lambda () alist)) - normal-slots))) + (format t "normal-slots: ~A~%" normal-slots) + (format t "alist: ~A~%" alist) + (let ((attrib-slot (make-instance 'attributes-esd + :name 'all-attributes + :initform `',alist + :initfunction #'(lambda () alist)))) + (format t "attrib-slot: ~A~%" attrib-slot) + (cons attrib-slot normal-slots)))) (defun slot-attribute (instance slot-name attribute) (cdr (slot-attribute-bucket instance slot-name attribute))) diff --git a/mop.lisp b/mop.lisp index cad16f3..79ac647 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: mop.lisp,v 1.10 2003/04/29 07:52:38 kevin Exp $ ;;;; ;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; @@ -45,33 +45,41 @@ (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)) + #+(or allegro sbcl cmu scl) + (declare (ignore 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 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 +89,9 @@ 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::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,7 +101,7 @@ '(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::compute-effective-slot-definition-initargs pcl::slot-value-using-class @@ -102,6 +112,7 @@ '(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::validate-superclass clos:direct-slot-definition-class clos:compute-effective-slot-definition clos::compute-effective-slot-definition-initargs @@ -110,19 +121,24 @@ clos:make-method-lambda clos:generic-function-lambda-list clos::compute-slots ;; note: make-method-lambda is not fbound - )) + ))) +(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 + ;; KMR-MOP encapsulating macros + process-slot-option + process-class-option)) #+sbcl (if (find-package 'sb-mop) -- 2.34.1