X-Git-Url: http://git.kpe.io/?p=kmrcl.git;a=blobdiff_plain;f=attrib-class.lisp;h=b102eca9300d33edb1e92ac8ce42dfc507b50cd6;hp=12572a290e458f671d0ee2553589abbf32687349;hb=03712fbb06acbb103602bae10f41aeae7fa05127;hpb=739b14ee8844dc777b174105646df3abcb865282 diff --git a/attrib-class.lisp b/attrib-class.lisp index 12572a2..b102eca 100644 --- a/attrib-class.lisp +++ b/attrib-class.lisp @@ -32,18 +32,18 @@ on example from AMOP")) (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) - ((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) #+(or cmu scl sbcl openmcl) (defmethod kmr-mop:validate-superclass ((class attributes-class) - (superclass kmr-mop:standard-class)) + (superclass kmr-mop:standard-class)) t) (defmethod kmr-mop:direct-slot-definition-class ((cl attributes-class) #+kmr-normal-dsdc &rest initargs) @@ -65,24 +65,24 @@ on example from AMOP")) (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 - '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))) @@ -92,14 +92,14 @@ on example from AMOP")) (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." - slot-name instance)) + slot-name instance)) (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)))