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-initargs attribute
)
54 ;; This plist will be used to init the attribute object
55 ;; Once the description itself is properly initiated.
57 'effective-attribute attribute
58 'description-class class
))
62 (defclass standard-description-class
(description-access-class layered-class
)
64 (:default-initargs
:defining-metaclass
'description-access-class
))
66 (defmethod validate-superclass
67 ((class standard-description-class
)
68 (superclass standard-class
))
71 (defclass standard-description-object
(standard-layer-object) ())
73 (defun description-class-name (description-class)
74 (read-from-string (symbol-name (class-name description-class
))))
76 (defun initialize-description-class (class)
78 ;;; HACK: initialization does not happen properly
79 ;;; when compiling and loading or something like that.
80 ;;; Obviously i'm not sure why.
81 ;;; So we're going to explicitly initialize things.
84 (pushnew class
*defined-descriptions
*)
88 (let* ((description (find-layer class
))
92 (setf (attribute-object slot
)
93 (apply #'make-instance
95 (attribute-object-initargs slot
))))
96 (class-slots (class-of description
))))
97 (defining-classes (partial-class-defining-classes (class-of description
))))
101 :on defining-classes
:by
#'cddr
102 :do
(funcall-with-layer-context
103 (adjoin-layer (find-layer layer
) (current-layer-context))
105 (loop :for direct-slot
:in
(class-direct-slots class
)
107 (find (slot-definition-name direct-slot
)
109 :key
#'attribute-name
)))
110 (apply #'reinitialize-instance attribute
111 (direct-attribute-properties direct-slot
))
112 (apply #'change-class attribute
(attribute-class attribute
) (direct-attribute-properties direct-slot
))
114 (setf (slot-value description
(attribute-name attribute
))
117 ;;;; HACK: run this at startup till we figure things out.
118 (defun initialize-descriptions ()
119 (map nil
#'initialize-description-class
120 (setf *defined-descriptions
*
121 (remove-duplicates *defined-descriptions
*))))
123 (defmethod initialize-instance :around
((class standard-description-class
) &rest initargs
&key
(direct-superclasses '()))
124 (declare (dynamic-extent initargs
))
126 (if (loop for direct-superclass in direct-superclasses
127 thereis
(ignore-errors (subtypep direct-superclass
'standard-description-object
)))
129 (apply #'call-next-method
132 (append direct-superclasses
133 (list (find-class 'standard-description-object
)))
135 (initialize-description-class class
)))
138 (defmethod reinitialize-instance :around
((class standard-description-class
) &rest initargs
&key
(direct-superclasses '() direct-superclasses-p
))
139 (declare (dynamic-extent initargs
))
140 ; (warn "CLASS ~A ARGS ~A:" class initargs)
142 (if (or (not direct-superclasses-p
)
143 (loop for direct-superclass in direct-superclasses
144 thereis
(ignore-errors (subtypep direct-superclass
'standard-description-object
))))
146 (apply #'call-next-method
149 (append direct-superclasses
150 (list (find-class 'standard-description-object
)))
152 (initialize-description-class class
)))
155 (defmethod print-object ((object standard-description-object
) stream
)
156 (print-unreadable-object (object stream
:type nil
:identity t
)
157 (format stream
"DESCRIPTION ~A" (ignore-errors (description-print-name object
)))))
159 (defmethod print-object ((object standard-description-class
) stream
)
160 (print-unreadable-object (object stream
:type t
:identity t
)
161 (princ (ignore-errors (description-print-name (find-layer object
))) stream
)))
163 (defun find-description (name)
164 (find-layer (find-class (defining-description name
))))