+(defparameter *symbol-delimiters* " ,.!?;")
+
+(defparameter *ordered-documentation-kinds*
+ '(package type structure condition class macro))
+
+;;;; utilities
+
+(defun flatten (list)
+ (cond ((null list)
+ nil)
+ ((consp (car list))
+ (nconc (flatten (car list)) (flatten (cdr list))))
+ ((null (cdr list))
+ (cons (car list) nil))
+ (t
+ (cons (car list) (flatten (cdr list))))))
+
+(defun whitespacep (char)
+ (find char #(#\tab #\space #\page)))
+
+(defun setf-name-p (name)
+ (or (symbolp name)
+ (and (listp name) (= 2 (length name)) (eq (car name) 'setf))))
+
+(defgeneric specializer-name (specializer))
+
+(defmethod specializer-name ((specializer eql-specializer))
+ (list 'eql (eql-specializer-object specializer)))
+
+(defmethod specializer-name ((specializer class))
+ (class-name specializer))
+
+(defun ensure-class-precedence-list (class)
+ (unless (class-finalized-p class)
+ (finalize-inheritance class))
+ (class-precedence-list class))
+
+(defun specialized-lambda-list (method)
+ ;; courtecy of AMOP p. 61
+ (let* ((specializers (method-specializers method))
+ (lambda-list (method-lambda-list method))
+ (n-required (length specializers)))
+ (append (mapcar (lambda (arg specializer)
+ (if (eq specializer (find-class 't))
+ arg
+ `(,arg ,(specializer-name specializer))))
+ (subseq lambda-list 0 n-required)
+ specializers)
+ (subseq lambda-list n-required))))
+
+(defun string-lines (string)
+ "Lines in STRING as a vector."
+ (coerce (with-input-from-string (s string)
+ (loop for line = (read-line s nil nil)
+ while line collect line))
+ 'vector))
+
+(defun indentation (line)
+ "Position of first non-SPACE character in LINE."
+ (position-if-not (lambda (c) (char= c #\Space)) line))
+
+(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))))
+
+(defun package-shortest-name (package)
+ (let* ((names (cons (package-name package) (package-nicknames package)))
+ (sorted (sort (copy-list names) #'< :key #'length)))
+ (car sorted)))
+
+(defun package-macro-name (package)
+ (let ((short-name (package-shortest-name package)))
+ (remove-if-not #'alpha-char-p (string-downcase short-name))))
+
+;;; 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))
+ (let* ((symbol-name (symbol-name name))
+ (earmuffsp (and (char= (char symbol-name 0) #\*)
+ (char= (char symbol-name (1- (length symbol-name))) #\*)
+ (some #'alpha-char-p symbol-name))))
+ (if earmuffsp
+ (format nil "@~A{@earmuffs{~A}}" (package-macro-name (get-package doc)) (subseq symbol-name 1 (1- (length symbol-name))))
+ (format nil "@~A{~A}" (package-macro-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-macro-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)))
+
+(defmethod print-object ((documentation documentation) stream)
+ (print-unreadable-object (documentation stream :type t)
+ (princ (list (get-kind documentation) (get-name documentation)) stream)))
+
+(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)
+ (fdef
+ (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)
+ 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 (member &whole &environment))
+ ;; Skip these
+ (clean (cdr x) :optional optional :key key))
+ ((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-lambda-list (get-name doc))))))))
+
+(defun get-string-name (x)
+ (let ((name (get-name x)))
+ (cond ((symbolp name)
+ (symbol-name name))
+ ((and (consp name) (eq 'setf (car name)))
+ (symbol-name (second name)))
+ ((stringp name)
+ name)
+ (t
+ (error "Don't know which symbol to use for name ~S" name)))))
+
+(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< (get-string-name x) (get-string-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."