;;;; Programmer: Kevin M. Rosenberg
;;;; Date Started: Apr 2000
;;;;
-;;;; $Id: attrib-class.lisp,v 1.12 2003/04/29 07:52:38 kevin Exp $
+;;;; $Id: attrib-class.lisp,v 1.13 2003/04/29 09:23:56 kevin Exp $
;;;;
;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg
;;;;
(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)
- #+(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 #+lispworks name dsds))
- )
-
-#+ignore
(defmethod kmr-mop:compute-effective-slot-definition :around
((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)))
esd))
-
(defmethod kmr-mop:compute-slots ((class attributes-class))
(let* ((normal-slots (call-next-method))
- (alist
- (mapcar
- #'(lambda (slot)
- (let ((attr-list (mapcar #'(lambda (attr) (cons attr nil))
- (esd-attributes slot))))
- (when attr-list
- (cons (kmr-mop:slot-definition-name slot) attr-list))))
- normal-slots)))
- (format t "normal-slots: ~A~%" normal-slots)
- (format t "alist: ~A~%" alist)
+ (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))))
- (format t "attrib-slot: ~A~%" attrib-slot)
- (cons attrib-slot normal-slots))))
+ :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)))))
(defun slot-attribute (instance slot-name attribute)
(cdr (slot-attribute-bucket instance slot-name attribute)))