projects
/
kmrcl.git
/ blobdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
|
commitdiff
|
tree
raw
|
inline
| side by side
Add remove-alist delete-alist
[kmrcl.git]
/
attrib-class.lisp
diff --git
a/attrib-class.lisp
b/attrib-class.lisp
index 12572a290e458f671d0ee2553589abbf32687349..453da1bfe5425c8e4524c7413cd01d4941e740da 100644
(file)
--- a/
attrib-class.lisp
+++ b/
attrib-class.lisp
@@
-1,4
+1,4
@@
-;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10
; Package: kmrcl
-*-
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10-*-
;;;; *************************************************************************
;;;; FILE IDENTIFICATION
;;;;
;;;; *************************************************************************
;;;; FILE IDENTIFICATION
;;;;
@@
-7,9
+7,7
@@
;;;; Programmer: Kevin M. Rosenberg
;;;; Date Started: Apr 2000
;;;;
;;;; Programmer: Kevin M. Rosenberg
;;;; Date Started: Apr 2000
;;;;
-;;;; $Id$
-;;;;
-;;;; This file, part of KMRCL, is Copyright (c) 2002-2003 by Kevin M. Rosenberg
+;;;; This file, part of KMRCL, is Copyright (c) 2002-2010 by Kevin M. Rosenberg
;;;;
;;;; KMRCL users are granted the rights to distribute and use this software
;;;; as governed by the terms of the Lisp Lesser GNU Public License
;;;;
;;;; KMRCL users are granted the rights to distribute and use this software
;;;; as governed by the terms of the Lisp Lesser GNU Public License
@@
-32,31
+30,31
@@
on example from AMOP"))
(defclass attributes-dsd (kmr-mop:standard-direct-slot-definition)
((attributes :initarg :attributes :initform nil
(defclass attributes-dsd (kmr-mop:standard-direct-slot-definition)
((attributes :initarg :attributes :initform nil
- :accessor dsd-attributes)))
+
:accessor dsd-attributes)))
(defclass attributes-esd (kmr-mop:standard-effective-slot-definition)
(defclass attributes-esd (kmr-mop:standard-effective-slot-definition)
- ((attributes :initarg :attributes :initform nil
- :accessor esd-attributes)))
+ ((attributes :initarg :attributes :initform nil
+
:accessor esd-attributes)))
;; encapsulating macro for Lispworks
(kmr-mop:process-slot-option attributes-class :attributes)
;; encapsulating macro for Lispworks
(kmr-mop:process-slot-option attributes-class :attributes)
-#+(or cmu scl sbcl
openm
cl)
+#+(or cmu scl sbcl
c
cl)
(defmethod kmr-mop:validate-superclass ((class attributes-class)
(defmethod kmr-mop:validate-superclass ((class attributes-class)
- (superclass kmr-mop:standard-class))
+
(superclass kmr-mop:standard-class))
t)
t)
-(defmethod kmr-mop:direct-slot-definition-class ((cl attributes-class) #+kmr
-
normal-dsdc &rest initargs)
+(defmethod kmr-mop:direct-slot-definition-class ((cl attributes-class) #+kmr
cl::
normal-dsdc &rest initargs)
(declare (ignore initargs))
(kmr-mop:find-class 'attributes-dsd))
(declare (ignore initargs))
(kmr-mop:find-class 'attributes-dsd))
-(defmethod kmr-mop:effective-slot-definition-class ((cl attributes-class) #+kmr
-
normal-dsdc &rest initargs)
+(defmethod kmr-mop:effective-slot-definition-class ((cl attributes-class) #+kmr
cl::
normal-dsdc &rest initargs)
(declare (ignore initargs))
(kmr-mop:find-class 'attributes-esd))
(defmethod kmr-mop:compute-effective-slot-definition
(declare (ignore initargs))
(kmr-mop:find-class 'attributes-esd))
(defmethod kmr-mop:compute-effective-slot-definition
- ((cl attributes-class) #+kmr
-
normal-cesd name dsds)
- #+kmr
-
normal-cesd (declare (ignore name))
+ ((cl attributes-class) #+kmr
cl::
normal-cesd name dsds)
+ #+kmr
cl::
normal-cesd (declare (ignore name))
(let ((esd (call-next-method)))
(setf (esd-attributes esd) (remove-duplicates (mapappend #'dsd-attributes dsds)))
esd))
(let ((esd (call-next-method)))
(setf (esd-attributes esd) (remove-duplicates (mapappend #'dsd-attributes dsds)))
esd))
@@
-65,24
+63,24
@@
on example from AMOP"))
(defmethod kmr-mop:compute-slots ((class attributes-class))
(let* ((normal-slots (call-next-method))
(defmethod kmr-mop:compute-slots ((class attributes-class))
(let* ((normal-slots (call-next-method))
- (alist (mapcar
- #'(lambda (slot)
- (cons (kmr-mop:slot-definition-name slot)
- (mapcar #'(lambda (attr) (list attr))
- (esd-attributes slot))))
- normal-slots)))
+
(alist (mapcar
+
#'(lambda (slot)
+
(cons (kmr-mop:slot-definition-name slot)
+
(mapcar #'(lambda (attr) (list attr))
+
(esd-attributes slot))))
+
normal-slots)))
(cons (make-instance
(cons (make-instance
- 'attributes-esd
- :name 'all-attributes
- :initform `',alist
- :initfunction #'(lambda () alist)
- :allocation :instance
- :documentation "Attribute bucket"
- :type t
- )
- normal-slots)))
-
+
'attributes-esd
+
:name 'all-attributes
+
:initform `',alist
+
:initfunction #'(lambda () alist)
+
:allocation :instance
+
:documentation "Attribute bucket"
+
:type t
+
)
+
normal-slots)))
+
(defun slot-attribute (instance slot-name attribute)
(cdr (slot-attribute-bucket instance slot-name attribute)))
(defun slot-attribute (instance slot-name attribute)
(cdr (slot-attribute-bucket instance slot-name attribute)))
@@
-92,14
+90,14
@@
on example from AMOP"))
(defun slot-attribute-bucket (instance slot-name attribute)
(let* ((all-buckets (slot-value instance 'all-attributes))
(defun slot-attribute-bucket (instance slot-name attribute)
(let* ((all-buckets (slot-value instance 'all-attributes))
- (slot-bucket (assoc slot-name all-buckets)))
+
(slot-bucket (assoc slot-name all-buckets)))
(unless slot-bucket
(error "The slot named ~S of ~S has no attributes."
(unless slot-bucket
(error "The slot named ~S of ~S has no attributes."
- slot-name instance))
+
slot-name instance))
(let ((attr-bucket (assoc attribute (cdr slot-bucket))))
(unless attr-bucket
(let ((attr-bucket (assoc attribute (cdr slot-bucket))))
(unless attr-bucket
- (error "The slot named ~S of ~S has no attributes named ~S."
- slot-name instance attribute))
+
(error "The slot named ~S of ~S has no attributes named ~S."
+
slot-name instance attribute))
attr-bucket)))
attr-bucket)))