r5198: *** empty log message ***

diff --git a/attrib-class.lisp b/attrib-class.lisp
index 04f8840f14d9c6da7cb25381fcd1129b7c493b91..a76e9913ad3e7092a11b5fac05548d99c06592f1 100644 (file)
--- 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 0da3c4865ccb307735fc27a2a9be5f708984be83..4ba6049dab960e351b8d5e9f3a3bd7b50175e325 100644 (file)
--- 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 4351f112507f9b7f4b866d29b636bd701036c677..1461c52effabc67be2257046e9b9d367ad37a254 100644 (file)
--- 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 07240b77d9c0f7f1c0a228b0e6d070a379973a37..fb58968fdd5fb1cf0a81d9e91f9add0767f7ed52 100644 (file)
--- 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