-
-(defun init-hyperobject-class (cl)
- (let ((fmtstr-text "")
- (fmtstr-html "")
- (fmtstr-xml "")
- (fmtstr-text-labels "")
- (fmtstr-html-labels "")
- (fmtstr-xml-labels "")
- (fmtstr-html-ref "")
- (fmtstr-xml-ref "")
- (fmtstr-html-ref-labels "")
- (fmtstr-xml-ref-labels "")
- (first-field t)
- (value-func '())
- (xmlvalue-func '())
- (classname (class-name cl))
- (package (symbol-package (portable-class-name cl)))
- (ref-fields (slot-value cl 'ref-fields)))
- (declare (ignore classname))
- (dolist (f (slot-value cl 'fields))
- (let ((name (car f))
- (namestr (symbol-name (car f)))
- (namestr-lower (string-downcase (symbol-name (car f))))
- (type (cadr f))
- (formatter (caddr f))
+
+(defun find-slot-by-name (cl name)
+ (find name (class-slots cl) :key #'slot-definition-name))
+
+
+(defun process-subobjects (cl)
+ "Process class subobjects slot"
+ (setf (slot-value cl 'subobjects)
+ (let ((subobjects '()))
+ (dolist (slot (class-slots cl))
+ (when (slot-value slot 'subobject)
+ (push (make-instance 'subobject :name (slot-definition-name slot)
+ :reader (if (eq t (esd-subobject slot))
+ (slot-definition-name slot)
+ (esd-subobject slot)))
+ subobjects)))
+ subobjects)))
+
+(defun process-documentation (cl)
+ "Calculate class documentation slot"
+ (awhen (slot-value cl 'title)
+ (setf (slot-value cl 'title) (car it)))
+ (awhen (slot-value cl 'description)
+ (setf (slot-value cl 'description) (car it)))
+
+ (let ((*print-circle* nil))
+ (setf (documentation (class-name cl) 'class)
+ (format nil "Hyperobject~A~A~A~A"
+ (aif (slot-value cl 'title)
+ (format nil ": ~A" it ""))
+ (aif (slot-value cl 'description)
+ (format nil "~%Class description: ~A" it) "")
+ (aif (slot-value cl 'subobjects)
+ (format nil "~%Subobjects:~{ ~A~}" (mapcar #'name it)) "")
+ (aif (slot-value cl 'print-slots)
+ (format nil "~%Print-slots:~{ ~A~}" it) "")
+ ))))
+
+(defun process-views (cl)
+ "Calculate all view slots for a hyperobject class"
+ (let ((fmtstr-text "")
+ (fmtstr-html "")
+ (fmtstr-xml "")
+ (fmtstr-text-labels "")
+ (fmtstr-html-labels "")
+ (fmtstr-xml-labels "")
+ (fmtstr-html-ref "")
+ (fmtstr-xml-ref "")
+ (fmtstr-html-ref-labels "")
+ (fmtstr-xml-ref-labels "")
+ (first-field t)
+ (value-func '())
+ (xmlvalue-func '())
+ (classname (class-name cl))
+ (package (symbol-package (class-name cl)))
+ (references nil))
+ (declare (ignore classname))
+ (dolist (slot-name (slot-value cl 'print-slots))
+ (let ((slot (find-slot-by-name cl slot-name)))
+ (unless slot
+ (error "Slot ~A is not found in class ~S" slot-name cl))
+ (let ((name (slot-definition-name slot))
+ (namestr (symbol-name (slot-definition-name slot)))
+ (namestr-lower (string-downcase (symbol-name (slot-definition-name slot))))
+ (type (slot-value slot 'ho-type))
+ (print-formatter (slot-value slot 'print-formatter))