- (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))
- (value-fmt "~a")
- (plain-value-func nil)
- html-str xml-str html-label-str xml-label-str)
-
- (when (or (eql type :integer) (eql type :fixnum))
- (setq value-fmt "~d"))
-
- (when (eql type :commainteger)
- (setq value-fmt "~:d"))
-
- (when (eql type :boolean)
- (setq value-fmt "~a"))
-
- (if first-field
- (setq first-field nil)
- (progn
- (string-append fmtstr-text " ")
- (string-append fmtstr-html " ")
- (string-append fmtstr-xml " ")
- (string-append fmtstr-text-labels " ")
- (string-append fmtstr-html-labels " ")
- (string-append fmtstr-xml-labels " ")
- (string-append fmtstr-html-ref " ")
- (string-append fmtstr-xml-ref " ")
- (string-append fmtstr-html-ref-labels " ")
- (string-append fmtstr-xml-ref-labels " ")))
-
- (setq html-str (concatenate 'string "<span class=\"" namestr-lower "\">" value-fmt "</span>"))
- (setq xml-str (concatenate 'string "<" namestr-lower ">" value-fmt "</" namestr-lower ">"))
- (setq html-label-str (concatenate 'string "<span class=\"label\">" namestr-lower "</span> <span class=\"" namestr-lower "\">" value-fmt "</span>"))
- (setq xml-label-str (concatenate 'string "<label>" namestr-lower "</label> <" namestr-lower ">" value-fmt "</" namestr-lower ">"))
-
+ (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)))
+ (setf (slot-value cl 'subobjects) subobjects)
+ (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))
+ (value-fmt "~a")
+ (plain-value-func nil)
+ html-str xml-str html-label-str xml-label-str)
+
+ (when (or (eql type :integer) (eql type :fixnum))
+ (setq value-fmt "~d"))
+
+ (when (eql type :commainteger)
+ (setq value-fmt "~:d"))
+
+ (when (eql type :boolean)
+ (setq value-fmt "~a"))
+
+ (if first-field
+ (setq first-field nil)
+ (progn
+ (string-append fmtstr-text " ")
+ (string-append fmtstr-html " ")
+ (string-append fmtstr-xml " ")
+ (string-append fmtstr-text-labels " ")
+ (string-append fmtstr-html-labels " ")
+ (string-append fmtstr-xml-labels " ")
+ (string-append fmtstr-html-ref " ")
+ (string-append fmtstr-xml-ref " ")
+ (string-append fmtstr-html-ref-labels " ")
+ (string-append fmtstr-xml-ref-labels " ")))
+
+ (setq html-str (concatenate 'string "<span class=\"" namestr-lower "\">" value-fmt "</span>"))
+ (setq xml-str (concatenate 'string "<" namestr-lower ">" value-fmt "</" namestr-lower ">"))
+ (setq html-label-str (concatenate 'string "<span class=\"label\">" namestr-lower "</span> <span class=\"" namestr-lower "\">" value-fmt "</span>"))
+ (setq xml-label-str (concatenate 'string "<label>" namestr-lower "</label> <" namestr-lower ">" value-fmt "</" namestr-lower ">"))
+