+ (let ((last 0))
+ (dolist (symbol/index (locate-symbols line))
+ (write-string (subseq line last (first symbol/index)) result)
+ (let ((symbol-name (apply #'subseq line symbol/index)))
+ (format result (if (member symbol-name *texinfo-variables*
+ :test #'string=)
+ "@var{~A}"
+ "@code{~A}")
+ (string-downcase symbol-name)))
+ (setf last (second symbol/index)))
+ (write-string (subseq line last) result))))
+
+;;; lisp sections
+
+(defun lisp-section-p (line line-number lines)
+ "Returns T if the given LINE looks like start of lisp code --
+ie. if it starts with whitespace followed by a paren or
+semicolon, and the previous line is empty"
+ (let ((offset (indentation line)))
+ (and offset
+ (plusp offset)
+ (find (find-if-not #'whitespacep line) "(;")
+ (empty-p (1- line-number) lines))))
+
+(defun collect-lisp-section (lines line-number)
+ (let ((lisp (loop for index = line-number then (1+ index)
+ for line = (and (< index (length lines)) (svref lines index))
+ while (indentation line)
+ collect line)))
+ (values (length lisp) `("@lisp" ,@lisp "@end lisp"))))
+
+;;; itemized sections
+
+(defun maybe-itemize-offset (line)
+ "Return NIL or the indentation offset if LINE looks like it starts
+an item in an itemization."
+ (let* ((offset (indentation line))
+ (char (when offset (char line offset))))
+ (and offset
+ (member char *itemize-start-characters* :test #'char=)
+ (char= #\Space (find-if-not (lambda (c) (char= c char))
+ line :start offset))
+ offset)))
+
+(defun collect-maybe-itemized-section (lines starting-line)
+ ;; Return index of next line to be processed outside
+ (let ((this-offset (maybe-itemize-offset (svref lines starting-line)))
+ (result nil)
+ (lines-consumed 0))
+ (loop for line-number from starting-line below (length lines)
+ for line = (svref lines line-number)
+ for indentation = (indentation line)
+ for offset = (maybe-itemize-offset line)
+ do (cond
+ ((not indentation)
+ ;; empty line -- inserts paragraph.
+ (push "" result)
+ (incf lines-consumed))
+ ((and offset (> indentation this-offset))
+ ;; nested itemization -- handle recursively
+ ;; FIXME: tables in itemizations go wrong
+ (multiple-value-bind (sub-lines-consumed sub-itemization)
+ (collect-maybe-itemized-section lines line-number)
+ (when sub-lines-consumed
+ (incf line-number (1- sub-lines-consumed)) ; +1 on next loop
+ (incf lines-consumed sub-lines-consumed)
+ (setf result (nconc (nreverse sub-itemization) result)))))
+ ((and offset (= indentation this-offset))
+ ;; start of new item
+ (push (format nil "@item ~A"
+ (texinfo-line (subseq line (1+ offset))))
+ result)
+ (incf lines-consumed))
+ ((and (not offset) (> indentation this-offset))
+ ;; continued item from previous line
+ (push (texinfo-line line) result)
+ (incf lines-consumed))
+ (t
+ ;; end of itemization
+ (loop-finish))))
+ ;; a single-line itemization isn't.
+ (if (> (count-if (lambda (line) (> (length line) 0)) result) 1)
+ (values lines-consumed `("@itemize" ,@(reverse result) "@end itemize"))
+ nil)))
+
+;;; table sections
+
+(defun tabulation-body-p (offset line-number lines)
+ (when (< line-number (length lines))
+ (let ((offset2 (indentation (svref lines line-number))))
+ (and offset2 (< offset offset2)))))
+
+(defun tabulation-p (offset line-number lines direction)
+ (let ((step (ecase direction
+ (:backwards (1- line-number))
+ (:forwards (1+ line-number)))))
+ (when (and (plusp line-number) (< line-number (length lines)))
+ (and (eql offset (indentation (svref lines line-number)))
+ (or (when (eq direction :backwards)
+ (empty-p step lines))
+ (tabulation-p offset step lines direction)
+ (tabulation-body-p offset step lines))))))
+
+(defun maybe-table-offset (line-number lines)
+ "Return NIL or the indentation offset if LINE looks like it starts
+an item in a tabulation. Ie, if it is (1) indented, (2) preceded by an
+empty line, another tabulation label, or a tabulation body, (3) and
+followed another tabulation label or a tabulation body."
+ (let* ((line (svref lines line-number))
+ (offset (indentation line))
+ (prev (1- line-number))
+ (next (1+ line-number)))
+ (when (and offset (plusp offset))
+ (and (or (empty-p prev lines)
+ (tabulation-body-p offset prev lines)
+ (tabulation-p offset prev lines :backwards))
+ (or (tabulation-body-p offset next lines)
+ (tabulation-p offset next lines :forwards))
+ offset))))
+
+;;; FIXME: This and itemization are very similar: could they share
+;;; some code, mayhap?
+
+(defun collect-maybe-table-section (lines starting-line)
+ ;; Return index of next line to be processed outside
+ (let ((this-offset (maybe-table-offset starting-line lines))
+ (result nil)
+ (lines-consumed 0))
+ (loop for line-number from starting-line below (length lines)
+ for line = (svref lines line-number)
+ for indentation = (indentation line)
+ for offset = (maybe-table-offset line-number lines)
+ do (cond
+ ((not indentation)
+ ;; empty line -- inserts paragraph.
+ (push "" result)
+ (incf lines-consumed))
+ ((and offset (= indentation this-offset))
+ ;; start of new item, or continuation of previous item
+ (if (and result (search "@item" (car result) :test #'char=))
+ (push (format nil "@itemx ~A" (texinfo-line line))
+ result)
+ (progn
+ (push "" result)
+ (push (format nil "@item ~A" (texinfo-line line))
+ result)))
+ (incf lines-consumed))
+ ((> indentation this-offset)
+ ;; continued item from previous line
+ (push (texinfo-line line) result)
+ (incf lines-consumed))
+ (t
+ ;; end of itemization
+ (loop-finish))))
+ ;; a single-line table isn't.
+ (if (> (count-if (lambda (line) (> (length line) 0)) result) 1)
+ (values lines-consumed
+ `("" "@table @emph" ,@(reverse result) "@end table" ""))
+ nil)))
+
+;;; section markup
+
+(defmacro with-maybe-section (index &rest forms)
+ `(multiple-value-bind (count collected) (progn ,@forms)
+ (when count
+ (dolist (line collected)
+ (write-line line *texinfo-output*))
+ (incf ,index (1- count)))))
+
+(defun write-texinfo-string (string &optional lambda-list)
+ "Try to guess as much formatting for a raw docstring as possible."
+ (let ((*texinfo-variables* (flatten lambda-list))
+ (lines (string-lines (escape-for-texinfo string nil))))
+ (loop for line-number from 0 below (length lines)
+ for line = (svref lines line-number)
+ do (cond
+ ((with-maybe-section line-number
+ (and (lisp-section-p line line-number lines)
+ (collect-lisp-section lines line-number))))
+ ((with-maybe-section line-number
+ (and (maybe-itemize-offset line)
+ (collect-maybe-itemized-section lines line-number))))
+ ((with-maybe-section line-number
+ (and (maybe-table-offset line-number lines)
+ (collect-maybe-table-section lines line-number))))
+ (t
+ (write-line (texinfo-line line) *texinfo-output*))))))
+
+;;;; texinfo formatting tools
+
+(defun hide-superclass-p (class-name super-name)
+ (let ((super-package (symbol-package super-name)))
+ (or
+ ;; KLUDGE: We assume that we don't want to advertise internal
+ ;; classes in CP-lists, unless the symbol we're documenting is
+ ;; internal as well.
+ (and (member super-package #.'(mapcar #'find-package *undocumented-packages*))
+ (not (eq super-package (symbol-package class-name))))
+ ;; KLUDGE: We don't generally want to advertise SIMPLE-ERROR or
+ ;; SIMPLE-CONDITION in the CPLs of conditions that inherit them
+ ;; simply as a matter of convenience. The assumption here is that
+ ;; the inheritance is incidental unless the name of the condition
+ ;; begins with SIMPLE-.
+ (and (member super-name '(simple-error simple-condition))
+ (let ((prefix "SIMPLE-"))
+ (mismatch prefix (string class-name) :end2 (length prefix)))
+ t ; don't return number from MISMATCH
+ ))))
+
+(defun hide-slot-p (symbol slot)
+ ;; FIXME: There is no pricipal reason to avoid the slot docs fo
+ ;; structures and conditions, but their DOCUMENTATION T doesn't
+ ;; currently work with them the way we'd like.
+ (not (and (typep (find-class symbol nil) 'standard-class)
+ (docstring slot t))))
+
+(defun texinfo-anchor (doc)
+ (format *texinfo-output* "@anchor{~A}~%" (node-name doc)))
+
+;;; KLUDGE: &AUX *PRINT-PRETTY* here means "no linebreaks please"
+(defun texinfo-begin (doc &aux *print-pretty*)
+ (let ((kind (get-kind doc)))
+ (format *texinfo-output* "@~A {~:(~A~)} ~(~A~@[ ~{~A~^ ~}~]~)~%"
+ (case kind
+ ((package constant variable)
+ "defvr")
+ ((structure class condition type)
+ "deftp")
+ (t
+ "deffn"))
+ (map 'string (lambda (char) (if (eql char #\-) #\Space char)) (string kind))
+ (title-name doc)
+ (lambda-list doc))))
+
+(defun texinfo-index (doc)
+ (let ((title (title-name doc)))
+ (case (get-kind doc)
+ ((structure type class condition)
+ (format *texinfo-output* "@tindex ~A~%" title))
+ ((variable constant)
+ (format *texinfo-output* "@vindex ~A~%" title))
+ ((compiler-macro function method-combination macro generic-function)
+ (format *texinfo-output* "@findex ~A~%" title)))))
+
+(defun texinfo-inferred-body (doc)
+ (when (member (get-kind doc) '(class structure condition))
+ (let ((name (get-name doc)))
+ ;; class precedence list
+ (format *texinfo-output* "Class precedence list: @code{~(~{@w{~A}~^, ~}~)}~%~%"
+ (remove-if (lambda (class) (hide-superclass-p name class))
+ (mapcar #'class-name (class-precedence-list (find-class name)))))
+ ;; slots
+ (let ((slots (remove-if (lambda (slot) (hide-slot-p name slot))
+ (class-direct-slots (find-class name)))))
+ (when slots
+ (format *texinfo-output* "Slots:~%@itemize~%")
+ (dolist (slot slots)
+ (format *texinfo-output* "@item ~(@code{~A} ~
+ ~@[--- initargs: @code{~{@w{~S}~^, ~}}~]~)~%~%"
+ (slot-definition-name slot)
+ (slot-definition-initargs slot))
+ ;; FIXME: Would be neater to handler as children
+ (write-texinfo-string (docstring slot t)))
+ (format *texinfo-output* "@end itemize~%~%"))))))
+
+(defun texinfo-body (doc)
+ (write-texinfo-string (get-string doc)))
+
+(defun texinfo-end (doc)
+ (write-line (case (get-kind doc)
+ ((package variable constant) "@end defvr")
+ ((structure type class condition) "@end deftp")
+ (t "@end deffn"))
+ *texinfo-output*))
+
+(defun write-texinfo (doc)
+ "Writes TexInfo for a DOCUMENTATION instance to *TEXINFO-OUTPUT*."
+ (texinfo-anchor doc)
+ (texinfo-begin doc)
+ (texinfo-index doc)
+ (texinfo-inferred-body doc)
+ (texinfo-body doc)
+ (texinfo-end doc)
+ ;; FIXME: Children should be sorted one way or another
+ (mapc #'write-texinfo (get-children doc)))
+
+;;;; main logic
+
+(defun collect-gf-documentation (gf)
+ "Collects method documentation for the generic function GF"
+ (loop for method in (generic-function-methods gf)
+ for doc = (maybe-documentation method t)
+ when doc
+ collect doc))
+
+(defun collect-name-documentation (name)
+ (loop for type in *documentation-types*
+ for doc = (maybe-documentation name type)
+ when doc
+ collect doc))
+
+(defun collect-symbol-documentation (symbol)
+ "Collects all docs for a SYMBOL and (SETF SYMBOL), returns a list of
+the form DOC instances. See `*documentation-types*' for the possible
+values of doc-type."
+ (nconc (collect-name-documentation symbol)
+ (collect-name-documentation (list 'setf symbol))))