+ (let* ((source-code (source-code view))
+ (printer `(lambda
+ (,(intern (symbol-name '#:self)
+ (symbol-package (object-class view)))
+ ,(intern (symbol-name '#:s)
+ (symbol-package (object-class view))))
+ (declare (ignorable
+ ,(intern (symbol-name '#:self)
+ (symbol-package (object-class view)))
+ ,(intern (symbol-name '#:s)
+ (symbol-package (object-class view)))))
+ (with-slots ,(slots view)
+ ,(intern (symbol-name '#:self)
+ (symbol-package (object-class view)))
+ ,@source-code))))
+ (setf (printer view)
+ (compile nil (eval printer)))))
+
+(defmacro write-simple (v s)
+ `(typecase ,v
+ (string
+ (write-string ,v ,s))
+ (fixnum
+ (write-fixnum ,v ,s))
+ (symbol
+ (write-string (symbol-name ,v) ,s))
+ (t
+ (write-string (write-to-string ,v) ,s))))
+
+(defun write-ho-value (obj name type formatter cdata strm)
+ (declare (ignorable type))
+ (let* ((slot-data (slot-value obj name))
+ (fmt-data (if formatter
+ (funcall formatter slot-data)
+ slot-data)))
+ (if cdata
+ (write-cdata fmt-data strm)
+ (write-simple fmt-data strm))))
+
+(defun ppfc-html (title name type formatter cdata print-func)
+ (vector-push-extend '(write-string "<span class=\"" s) print-func)
+ (vector-push-extend `(write-string ,title s) print-func)
+ (vector-push-extend '(write-string "\">" s) print-func)
+ (vector-push-extend `(write-ho-value x ',name ',type ',formatter ,cdata s) print-func)
+ (vector-push-extend '(write-string "</span>" s) print-func))
+
+(defun ppfc-xml (tag name type formatter cdata print-func)
+ (vector-push-extend '(write-char #\< s) print-func)
+ (vector-push-extend `(write-string ,tag s) print-func)
+ (vector-push-extend '(write-char #\> s) print-func)
+ (vector-push-extend `(write-ho-value x ',name ',type ',formatter ,cdata s) print-func)
+ (vector-push-extend '(write-string "</" s) print-func)
+ (vector-push-extend `(write-string ,tag s) print-func)
+ (vector-push-extend '(write-char #\> s) print-func))
+
+(defun ppfc-html-labels (label name type formatter cdata print-func)
+ (vector-push-extend '(write-string "<span class=\"label\">" s) print-func)
+ (vector-push-extend `(write-string ,label s) print-func)
+ (vector-push-extend '(write-string "</span> " s) print-func)
+ (ppfc-html label name type formatter cdata print-func))
+
+(defun ppfc-xhtml-labels (label tag name type formatter cdata print-func)
+ (vector-push-extend '(write-string "<span class=\"label\">" s) print-func)
+ (vector-push-extend `(write-string ,label s) print-func)
+ (vector-push-extend '(write-string "</span> " s) print-func)
+ (ppfc-html tag name type formatter cdata print-func))
+
+(defun ppfc-xml-labels (label tag name type formatter cdata print-func)
+ (vector-push-extend '(write-string "<label>" s) print-func)
+ (vector-push-extend `(write-string ,label s) print-func)
+ (vector-push-extend '(write-string "</label> " s) print-func)
+ (ppfc-xml tag name type formatter cdata print-func))
+
+(defun ppfc-html-link (name type formatter cdata nlink print-func)
+ (declare (fixnum nlink))
+ (vector-push-extend '(write-char #\< s) print-func)
+ (vector-push-extend `(write-string (nth ,(+ nlink nlink) links) s) print-func)
+ (vector-push-extend '(write-char #\> s) print-func)
+ (vector-push-extend `(write-ho-value x ',name ',type ',formatter ,cdata s) print-func)
+ (vector-push-extend '(write-string "</" s) print-func)
+ (vector-push-extend `(write-string (nth ,(+ nlink nlink 1) links) s) print-func)
+ (vector-push-extend '(write-char #\> s) print-func))
+
+(defun ppfc-html-link-labels (label name type formatter cdata nlink print-func)
+ (vector-push-extend '(write-string "<span class=\"label\">" s) print-func)
+ (vector-push-extend `(write-string ,label s) print-func)
+ (vector-push-extend '(write-string "</span> " s) print-func)
+ (ppfc-html-link name type formatter cdata nlink print-func))
+
+(defun push-print-fun-code (vid slot nlink print-func)
+ (let* ((formatter (esd-print-formatter slot))
+ (name (slot-definition-name slot))
+ (user-name (esd-user-name slot))
+ (xml-user-name (escape-xml-string user-name))
+ (xml-tag (escape-xml-string user-name))
+ (type (slot-value slot 'type))
+ (cdata (not (null
+ (and (in vid :xml :xhtml :xml-link :xhtml-link
+ :xml-labels :ie-xml-labels
+ :xhtml-link-labels :xml-link-labels :ie-xml-link
+ :ie-xml-link-labels)
+ (or formatter
+ (lisp-type-is-a-string type))))))
+ (hyperlink (esd-hyperlink slot)))