From e8c34efef61039ff3319203710b533be1a7906ca Mon Sep 17 00:00:00 2001 From: "Kevin M. Rosenberg" Date: Wed, 25 Jun 2003 18:08:09 +0000 Subject: [PATCH] r5198: *** empty log message *** --- attrib-class.lisp | 47 ++++++++++++++++++++++------------------------- equal.lisp | 9 +++++---- kmrcl.asd | 8 ++++---- mop.lisp | 18 +++++++++++++++--- 4 files changed, 46 insertions(+), 36 deletions(-) diff --git a/attrib-class.lisp b/attrib-class.lisp index 04f8840..a76e991 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.14 2003/06/12 02:38:39 kevin Exp $ +;;;; $Id: attrib-class.lisp,v 1.15 2003/06/25 18:08:09 kevin Exp $ ;;;; ;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; @@ -19,7 +19,7 @@ ;;;; Defines a metaclass that allows the use of attributes (or subslots) ;;;; on slots. Based on example in AMOP, but modified to use ACL's MOP. -(in-package :kmrcl) +(in-package #:kmrcl) (defclass attributes-class (kmr-mop:standard-class) () @@ -37,7 +37,7 @@ on example from AMOP")) ;; encapsulating macro for Lispworks (kmr-mop:process-slot-option attributes-class :attributes) -#+(or cmu scl sbcl) +#+(or cmu scl sbcl openmcl) (defmethod kmr-mop:validate-superclass ((class attributes-class) (superclass kmr-mop:standard-class)) t) @@ -59,28 +59,25 @@ on example from AMOP")) (defmethod kmr-mop:compute-slots ((class attributes-class)) (let* ((normal-slots (call-next-method)) - (alist (delete - nil - (mapcar - #'(lambda (slot) - (let ((attr-list (mapcar #'(lambda (attr) (list attr)) - (esd-attributes slot)))) - (when attr-list - (cons (kmr-mop:slot-definition-name slot) attr-list)))) - normal-slots)))) - (let ((attrib-slot (make-instance 'attributes-esd - :name 'all-attributes - :initform `',alist - :initfunction #'(lambda () alist) - :allocation :instance - :class class - :documentation "" - :type t - ;; This is an attempted work-around -- lispworks doesn't work - ;; it appears to setup storage someplace - #+lispworks :location #+lispworks (length normal-slots) - ))) - (append normal-slots (list attrib-slot))))) + (alist (mapcar + #'(lambda (slot) + (cons (kmr-mop:slot-definition-name slot) + (mapcar #'(lambda (attr) (list attr)) + (esd-attributes slot)))) + normal-slots))) + (cons (make-instance 'attributes-esd + :name 'all-attributes + :initform `',alist + :initfunction #'(lambda () alist) + :allocation :instance + :class class + :documentation "" + :type t + ;; This is an attempted work-around -- lispworks doesn't work + ;; it appears to setup storage someplace + ;; #+lispworks :location #+lispworks (length normal-slots) + ) + normal-slots))) (defun slot-attribute (instance slot-name attribute) (cdr (slot-attribute-bucket instance slot-name attribute))) diff --git a/equal.lisp b/equal.lisp index 0da3c48..4ba6049 100644 --- a/equal.lisp +++ b/equal.lisp @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Apr 2000 ;;;; -;;;; $Id: equal.lisp,v 1.14 2003/05/07 21:57:10 kevin Exp $ +;;;; $Id: equal.lisp,v 1.15 2003/06/25 18:08:09 kevin Exp $ ;;;; ;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; @@ -92,12 +92,12 @@ #+(or allegro cmu lispworks sbcl scl) (mapcar #'kmr-mop:slot-definition-name (kmr-mop:class-slots (kmr-mop:find-class c-name))) - #+mcl + #+(and mcl (not openmcl)) (let* ((class (find-class c-name nil))) (when (typep class 'standard-class) (nconc (mapcar #'car (ccl:class-instance-slots class)) (mapcar #'car (ccl:class-class-slots class))))) - #-(or allegro lispworks cmu mcl sbcl scl) + #-(or allegro lispworks cmu mcl sbcl scl openmcl) (error "class-slot-names is not defined on this platform") ) @@ -112,7 +112,8 @@ (kernel:dd-slots (kernel:layout-info (kernel:class-layout (find-class s-name))))) - #+mcl (let* ((sd (gethash s-name ccl::%defstructs%)) + #+(and mcl (not openmcl)) + (let* ((sd (gethash s-name ccl::%defstructs%)) (slots (if sd (ccl::sd-slots sd)))) (mapcar #'car (if (symbolp (caar slots)) slots (cdr slots)))) #-(or allegro lispworks cmu sbcl scl mcl) diff --git a/kmrcl.asd b/kmrcl.asd index 4351f11..1461c52 100644 --- a/kmrcl.asd +++ b/kmrcl.asd @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Apr 2000 ;;;; -;;;; $Id: kmrcl.asd,v 1.35 2003/06/20 08:35:21 kevin Exp $ +;;;; $Id: kmrcl.asd,v 1.36 2003/06/25 18:08:09 kevin Exp $ ;;;; ;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; @@ -20,7 +20,7 @@ (defpackage #:kmrcl-system (:use #:asdf #:cl)) (in-package #:kmrcl-system) -#+(or allegro cmu lispworks sbcl scl) +#+(or allegro cmu lispworks sbcl scl openmcl) (pushnew :kmr-mop cl:*features*) (defsystem kmrcl @@ -53,8 +53,8 @@ (:file "xml-utils" :depends-on ("macros"))) ) -#+(or allegro lispworks sbcl cmu scl) -(defmethod perform ((o test-op) (c (eql (find-system :kmrcl)))) +#+(or allegro lispworks sbcl cmu scl openmcl) +(defmethod perform ((o test-op) (c (eql (find-system 'kmrcl)))) (operate 'load-op 'kmrcl-tests) (operate 'test-op 'kmrcl-tests)) diff --git a/mop.lisp b/mop.lisp index 07240b7..fb58968 100644 --- a/mop.lisp +++ b/mop.lisp @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Apr 2003 ;;;; -;;;; $Id: mop.lisp,v 1.14 2003/05/05 20:15:22 kevin Exp $ +;;;; $Id: mop.lisp,v 1.15 2003/06/25 18:08:09 kevin Exp $ ;;;; ;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; @@ -58,7 +58,7 @@ (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) + #-lispworks (declare (ignore metaclass slot-name required)) ) @@ -125,7 +125,19 @@ clos:make-method-lambda clos:generic-function-lambda-list clos::compute-slots ;; note: make-method-lambda is not fbound - ))) + ) + #+openmcl + '(openmcl-mop::standard-class + 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 -- 2.34.1