1 (in-package :lisp-on-lines
)
4 ;;;; A description is an object which is used
5 ;;;; to describe another object.
8 ;;; Since i'm not using deflayer, ensure-layer etc,
9 ;;; There are a few places where contextl gets confused
10 ;;; trying to locate my description layers.
12 ;;; TODO: investigate switching to deflayer!
14 (defun contextl::prepare-layer
(layer)
16 (if (eq (symbol-package layer
)
17 (find-package :description-definers
))
19 (contextl::defining-layer layer
))
23 (defmethod find-layer-class :around
((layer symbol
) &optional errorp environment
)
24 (if (eq (symbol-package layer
)
25 (find-package :description-definers
))
30 ;;; I'm having some 'issues' with
31 ;;; compiled code and my initialization.
32 ;;; So this hack initializes the world.
33 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
34 (defparameter *defined-descriptions
* nil
))
36 (defclass description-access-class
(standard-layer-class contextl
::special-layered-access-class
)
37 ((defined-in-descriptions :initarg
:in-description
)
38 (mixin-class-p :initarg
:mixinp
)))
40 (defmethod direct-slot-definition-class
41 ((class description-access-class
) &key
&allow-other-keys
)
42 (find-class 'direct-attribute-definition-class
))
44 (defmethod effective-slot-definition-class
45 ((class description-access-class
) &key
&allow-other-keys
)
46 (find-class 'effective-attribute-definition-class
))
48 (defmethod compute-effective-slot-definition
49 ((class description-access-class
) name direct-slot-definitions
)
50 (declare (ignore name
))
51 (let ((attribute (call-next-method)))
52 (setf (attribute-direct-attributes attribute
) direct-slot-definitions
)
53 (setf (attribute-object attribute
)
54 (make-instance 'standard-attribute
56 'effective-attribute attribute
57 'description-class class
))
61 (defclass standard-description-class
(description-access-class layered-class
)
63 (:default-initargs
:defining-metaclass
'description-access-class
))
65 (defmethod validate-superclass
66 ((class standard-description-class
)
67 (superclass standard-class
))
70 (defclass standard-description-object
(standard-layer-object) ())
72 (defun description-class-name (description-class)
73 (read-from-string (symbol-name (class-name description-class
))))
75 (defun initialize-description-class (class)
77 ;;; HACK: initialization does not happen properly
78 ;;; when compiling and loading or something like that.
79 ;;; Obviously i'm not sure why.
80 ;;; So we're going to explicitly initialize things.
83 (pushnew class
*defined-descriptions
*)
87 (let* ((description (find-layer class
))
88 (attribute-objects (mapcar #'attribute-object
(class-slots (class-of description
))))
89 (defining-classes (partial-class-defining-classes (class-of description
))))
95 :on defining-classes
:by
#'cddr
96 :do
(funcall-with-layer-context
97 (adjoin-layer (find-layer layer
) (current-layer-context))
99 (loop :for direct-slot
:in
(class-direct-slots class
)
101 (find (slot-definition-name direct-slot
)
103 :key
#'attribute-name
)))
104 (apply #'reinitialize-instance attribute
105 (direct-attribute-properties direct-slot
))
106 (apply #'change-class attribute
(attribute-class attribute
) (direct-attribute-properties direct-slot
))
108 (setf (slot-value description
(attribute-name attribute
))
111 ;;;; HACK: run this at startup till we figure things out.
112 (defun initialize-descriptions ()
113 (map nil
#'initialize-description-class
114 (setf *defined-descriptions
*
115 (remove-duplicates *defined-descriptions
*))))
117 (defmethod initialize-instance :around
((class standard-description-class
) &rest initargs
&key
(direct-superclasses '()))
118 (declare (dynamic-extent initargs
))
120 (if (loop for direct-superclass in direct-superclasses
121 thereis
(ignore-errors (subtypep direct-superclass
'standard-description-object
)))
123 (apply #'call-next-method
126 (append direct-superclasses
127 (list (find-class 'standard-description-object
)))
129 (initialize-description-class class
)))
132 (defmethod reinitialize-instance :around
((class standard-description-class
) &rest initargs
&key
(direct-superclasses '() direct-superclasses-p
))
133 (declare (dynamic-extent initargs
))
134 ; (warn "CLASS ~A ARGS ~A:" class initargs)
136 (if (or (not direct-superclasses-p
)
137 (loop for direct-superclass in direct-superclasses
138 thereis
(ignore-errors (subtypep direct-superclass
'standard-description-object
))))
140 (apply #'call-next-method
143 (append direct-superclasses
144 (list (find-class 'standard-description-object
)))
146 (initialize-description-class class
)))
149 (defmethod print-object ((object standard-description-object
) stream
)
150 (print-unreadable-object (object stream
:type nil
:identity t
)
151 (format stream
"DESCRIPTION ~A" (ignore-errors (description-print-name object
)))))
153 (defmethod print-object ((object standard-description-class
) stream
)
154 (print-unreadable-object (object stream
:type t
:identity t
)
155 (princ (ignore-errors (description-print-name (find-layer object
))) stream
)))
157 (defun find-description (name)
158 (find-layer (find-class (defining-description name
))))