+(defun docstring (x doc-type)
+ (cl:documentation x doc-type))
+
+(defun flatten-to-string (list)
+ (format nil "~{~A~^-~}" (flatten list)))
+
+(defun alphanumize (original)
+ "Construct a string without characters like *`' that will f-star-ck
+up filename handling. See `*character-replacements*' and
+`*characters-to-drop*' for customization."
+ (let ((name (remove-if (lambda (x) (member x *characters-to-drop*))
+ (if (listp original)
+ (flatten-to-string original)
+ (string original))))
+ (chars-to-replace (mapcar #'car *character-replacements*)))
+ (flet ((replacement-delimiter (index)
+ (cond ((or (< index 0) (>= index (length name))) "")
+ ((alphanumericp (char name index)) "-")
+ (t ""))))
+ (loop for index = (position-if #'(lambda (x) (member x chars-to-replace))
+ name)
+ while index
+ do (setf name (concatenate 'string (subseq name 0 index)
+ (replacement-delimiter (1- index))
+ (cdr (assoc (aref name index)
+ *character-replacements*))
+ (replacement-delimiter (1+ index))
+ (subseq name (1+ index))))))
+ name))
+
+;;;; generating various names
+
+(defgeneric name (thing)
+ (:documentation "Name for a documented thing. Names are either
+symbols or lists of symbols."))
+
+(defmethod name ((symbol symbol))
+ symbol)
+
+(defmethod name ((cons cons))
+ cons)
+
+(defmethod name ((package package))
+ (package-name package))
+
+(defmethod name ((method method))
+ (list
+ (generic-function-name (method-generic-function method))
+ (method-qualifiers method)
+ (specialized-lambda-list method)))
+
+;;; Node names for DOCUMENTATION instances
+
+(defgeneric name-using-kind/name (kind name doc))
+
+(defmethod name-using-kind/name (kind (name string) doc)
+ (declare (ignore kind doc))
+ name)
+
+(defmethod name-using-kind/name (kind (name symbol) doc)
+ (declare (ignore kind))
+ (format nil "~A:~A" (package-name (get-package doc)) name))
+
+(defmethod name-using-kind/name (kind (name list) doc)
+ (declare (ignore kind))
+ (assert (setf-name-p name))
+ (format nil "(setf ~A:~A)" (package-name (get-package doc)) (second name)))
+
+(defmethod name-using-kind/name ((kind (eql 'method)) name doc)
+ (format nil "~A~{ ~A~} ~A"
+ (name-using-kind/name nil (first name) doc)
+ (second name)
+ (third name)))
+
+(defun node-name (doc)
+ "Returns TexInfo node name as a string for a DOCUMENTATION instance."
+ (let ((kind (get-kind doc)))
+ (format nil "~:(~A~) ~(~A~)" kind (name-using-kind/name kind (get-name doc) doc))))
+
+;;; Definition titles for DOCUMENTATION instances
+
+(defgeneric title-using-kind/name (kind name doc))
+
+(defmethod title-using-kind/name (kind (name string) doc)
+ (declare (ignore kind doc))
+ name)
+
+(defmethod title-using-kind/name (kind (name symbol) doc)
+ (declare (ignore kind))
+ (format nil "~A:~A" (package-name (get-package doc)) name))
+
+(defmethod title-using-kind/name (kind (name list) doc)
+ (declare (ignore kind))
+ (assert (setf-name-p name))
+ (format nil "(setf ~A:~A)" (package-name (get-package doc)) (second name)))
+
+(defmethod title-using-kind/name ((kind (eql 'method)) name doc)
+ (format nil "~{~A ~}~A"
+ (second name)
+ (title-using-kind/name nil (first name) doc)))
+
+(defun title-name (doc)
+ "Returns a string to be used as name of the definition."
+ (string-downcase (title-using-kind/name (get-kind doc) (get-name doc) doc)))
+
+(defun include-pathname (doc)
+ (let* ((kind (get-kind doc))
+ (name (nstring-downcase
+ (if (eq 'package kind)
+ (format nil "package-~A" (alphanumize (get-name doc)))
+ (format nil "~A-~A-~A"
+ (case (get-kind doc)
+ ((function generic-function) "fun")
+ (structure "struct")
+ (variable "var")
+ (otherwise (symbol-name (get-kind doc))))
+ (alphanumize (package-name (get-package doc)))
+ (alphanumize (get-name doc)))))))
+ (make-pathname :name name :type "texinfo")))
+
+;;;; documentation class and related methods
+
+(defclass documentation ()
+ ((name :initarg :name :reader get-name)
+ (kind :initarg :kind :reader get-kind)
+ (string :initarg :string :reader get-string)
+ (children :initarg :children :initform nil :reader get-children)
+ (package :initform *documentation-package* :reader get-package)))
+
+(defgeneric make-documentation (x doc-type string))
+
+(defmethod make-documentation ((x package) doc-type string)
+ (declare (ignore doc-type))
+ (make-instance 'documentation
+ :name (name x)
+ :kind 'package
+ :string string))
+
+(defmethod make-documentation (x (doc-type (eql 'function)) string)
+ (declare (ignore doc-type))
+ (let* ((fdef (and (fboundp x) (fdefinition x)))
+ (name x)
+ (kind (cond ((and (symbolp x) (special-operator-p x))
+ 'special-operator)
+ ((and (symbolp x) (macro-function x))
+ 'macro)
+ ((typep fdef 'generic-function)
+ (assert (or (symbolp name) (setf-name-p name)))
+ 'generic-function)
+ (t
+ (assert (or (symbolp name) (setf-name-p name)))
+ 'function)))
+ (children (when (eq kind 'generic-function)
+ (collect-gf-documentation fdef))))
+ (make-instance 'documentation
+ :name (name x)
+ :string string
+ :kind kind
+ :children children)))
+
+(defmethod make-documentation ((x method) doc-type string)
+ (declare (ignore doc-type))
+ (make-instance 'documentation
+ :name (name x)
+ :kind 'method
+ :string string))
+
+(defmethod make-documentation (x (doc-type (eql 'type)) string)
+ (make-instance 'documentation
+ :name (name x)
+ :string string
+ :kind (etypecase (find-class x nil)
+ (structure-class 'structure)
+ (standard-class 'class)
+ (sb-pcl::condition-class 'condition)
+ ((or built-in-class null) 'type))))
+
+(defmethod make-documentation (x (doc-type (eql 'variable)) string)
+ (make-instance 'documentation
+ :name (name x)
+ :string string
+ :kind (if (constantp x)
+ 'constant
+ 'variable)))
+
+(defmethod make-documentation (x (doc-type (eql 'setf)) string)
+ (declare (ignore doc-type))
+ (make-instance 'documentation
+ :name (name x)
+ :kind 'setf-expander
+ :string string))
+
+(defmethod make-documentation (x doc-type string)
+ (make-instance 'documentation
+ :name (name x)
+ :kind doc-type
+ :string string))
+
+(defun maybe-documentation (x doc-type)
+ "Returns a DOCUMENTATION instance for X and DOC-TYPE, or NIL if
+there is no corresponding docstring."
+ (let ((docstring (docstring x doc-type)))
+ (when docstring
+ (make-documentation x doc-type docstring))))
+
+(defun lambda-list (doc)
+ (case (get-kind doc)
+ ((package constant variable type structure class condition)
+ nil)
+ (method
+ (third (get-name doc)))
+ (t
+ ;; KLUDGE: Eugh.
+ ;;
+ ;; believe it or not, the above comment was written before CSR
+ ;; came along and obfuscated this. (2005-07-04)
+ (when (symbolp (get-name doc))
+ (labels ((clean (x &key optional key)
+ (typecase x
+ (atom x)
+ ((cons (member &optional))
+ (cons (car x) (clean (cdr x) :optional t)))
+ ((cons (member &key))
+ (cons (car x) (clean (cdr x) :key t)))
+ ((cons cons)
+ (cons
+ (cond (key (if (consp (caar x))
+ (caaar x)
+ (caar x)))
+ (optional (caar x))
+ (t (clean (car x))))
+ (clean (cdr x) :key key :optional optional)))
+ (cons
+ (cons
+ (cond ((or key optional) (car x))
+ (t (clean (car x))))
+ (clean (cdr x) :key key :optional optional))))))
+ (clean (sb-introspect:function-arglist (get-name doc))))))))
+
+(defun documentation< (x y)
+ (let ((p1 (position (get-kind x) *ordered-documentation-kinds*))
+ (p2 (position (get-kind y) *ordered-documentation-kinds*)))
+ (if (or (not (and p1 p2)) (= p1 p2))
+ (string< (string (get-name x)) (string (get-name y)))
+ (< p1 p2))))
+
+;;;; turning text into texinfo
+
+(defun escape-for-texinfo (string &optional downcasep)
+ "Return STRING with characters in *TEXINFO-ESCAPED-CHARS* escaped
+with #\@. Optionally downcase the result."