[~A]
"
name type (and write-name-p (atom name) (string-downcase name))))
(defun write-entry-footer (name doc-string)
"Writes the footer for a documentation entry for the name NAME
including the documentation string DOC-STRING."
(format t "~%
~%~%~%"
(and doc-string (escape-string-iso-8859 doc-string)) name))
(defun write-constant-entry (symbol doc-string)
"Writes a full documentation entry for the constant SYMBOL."
(write-entry-header symbol "Constant")
(format t "~A" (string-downcase symbol))
(write-entry-footer symbol doc-string))
(defun write-special-var-entry (symbol doc-string)
"Writes a full documentation entry for the special variable
SYMBOL."
(write-entry-header symbol "Special variable")
(format t "~A" (string-downcase symbol))
(write-entry-footer symbol doc-string))
(defun write-class-entry (symbol doc-string)
"Writes a full documentation entry for the class SYMBOL."
(write-entry-header symbol (if (subtypep symbol 'condition)
"Condition type" "Standard class"))
(format t "~A" (string-downcase symbol))
(write-entry-footer symbol doc-string))
(defun write-lambda-list* (lambda-list &optional specializers)
"The function which does all the work for WRITE-LAMBDA-LIST and
calls itself recursive if needed."
(let (body-seen after-required-args-p (firstp t))
(dolist (part lambda-list)
(cond (body-seen (setq body-seen nil))
(t (when (and (consp part) after-required-args-p)
(setq part (first part)))
(unless firstp
(write-char #\Space))
(setq firstp nil)
(cond ((consp part)
;; a destructuring lambda list - recurse
(write-char #\()
(write-lambda-list* part)
(write-char #\)))
((member part '(&key &optional &rest &allow-other-keys &aux &environment &whole))
;; marks these between and
(setq after-required-args-p t)
(format t "~A" (escape-string (string-downcase part))))
((eq part '&body)
;; we don't really write '&BODY', we write it
;; like in the CLHS
(setq body-seen t
after-required-args-p t)
(write-string "declaration* statement*"))
(t
(let ((specializer (pop specializers)))
(cond ((and specializer (not (eq specializer t)))
;; add specializers if there are any left
(write-string (escape-string
(string-downcase
(format nil "(~A ~A)" part specializer)))))
(t (write-string (escape-string (string-downcase part)))))))))))))
(defun write-lambda-list (lambda-list &key (resultp t) specializers)
"Writes the lambda list LAMBDA-LIST, optionally with the
specializers SPECIALIZERS. Adds something like `=> result' at
the end if RESULTP is true."
(write-string "")
(write-lambda-list* lambda-list specializers)
(write-string "")
(when resultp
(write-string " => result")))
(defun write-macro-entry (symbol lambda-list doc-string)
"Writes a full documentation entry for the macro SYMBOL."
(write-entry-header symbol "Macro")
(format t "~A " (string-downcase symbol))
(write-lambda-list lambda-list)
(write-entry-footer symbol doc-string))
(defun write-function-entry (name lambda-list doc-string other-entries
&key genericp signature-only-p specializers qualifiers)
"Writes a full documentation entry for the function, generic
function, or method with name NAME. NAME is a generic function
if GENERICP is true, SPECIALIZERS is a list of specializers,
i.e. in this case NAME is a method. Likewise, QUALIFIERS is a
list of qualifiers. SIGNATURE-ONLY-P means that we don't want a
full header."
(let* ((setfp (consp name))
(symbol (if setfp (second name) name))
(type (cond (specializers :method)
(genericp :generic-function)
(t :function)))
;; check if this is a reader for which there is a writer (so
;; we have an accessor) with the same signature
(writer (and (not setfp)
(find-if (lambda (entry)
(and (equal `(setf ,name) (first entry))
(eq type (second entry))
(or (null specializers)
(equal specializers (rest (fifth entry))))))
other-entries)))
(resultp (and (not setfp)
(null (intersection '(:before :after)
qualifiers)))))
(cond (signature-only-p
(write-string ""))
(t
(write-entry-header name (if writer
(ecase type
(:method "Specialized accessor")
(:generic-function "Generic accessor")
(:function "Accessor"))
(ecase type
(:method "Method")
(:generic-function "Generic function")
(:function "Function")))
:write-name-p (null specializers))))
(cond (setfp
(format t "(setf (~A " (string-downcase symbol))
(write-lambda-list (rest lambda-list) :resultp resultp :specializers (rest specializers))
(write-string ") ")
;; we should use the specializer here as well
(format t "~A" (string-downcase (first lambda-list)))
(write-string ")")
(format t "~(~{ ~S~^~}~)" qualifiers))
(t (format t "~A " (string-downcase symbol))
(write-lambda-list lambda-list :specializers specializers :resultp resultp)
(format t "~(~{ ~S~^~}~)" qualifiers)))
(when writer
;; if this is an accessor, the add the writer immediately after
;; the reader..
(format t "~%
~%~%~@[~A~]~%~%
")
(destructuring-bind (name doc-type lambda-list doc-string &optional specializers qualifiers)
writer
(declare (ignore doc-type doc-string))
(write-function-entry name lambda-list nil nil
:signature-only-p t
:specializers specializers
:qualifiers qualifiers))
;; ...and remove it from the list of entries which haven't been
;; written yet
(setq other-entries (remove writer other-entries))))
(unless signature-only-p
(write-entry-footer name doc-string))
other-entries)
(defun write-entry (entry other-entries)
"Write one documentation entry corresponding to ENTRY.
OTHER-ENTRIES is the list of the remaining entries waiting to be
written. OTHER-ENTRIES, probably updated, will be returned."
(destructuring-bind (name doc-type lambda-list doc-string &optional specializers qualifiers)
entry
(unless (or (consp name) specializers)
;; add NAME to index list unless it's a SETF name or the name of
;; a method
(push name *symbols*))
(ecase doc-type
(:constant (write-constant-entry name doc-string))
(:special-var (write-special-var-entry name doc-string))
(:class (write-class-entry name doc-string))
(:macro (write-macro-entry name lambda-list doc-string))
(:function (setq other-entries
(write-function-entry name lambda-list doc-string other-entries)))
(:generic-function (setq other-entries
(write-function-entry name lambda-list doc-string other-entries
:genericp t)))
(:method (setq other-entries
(write-function-entry name lambda-list doc-string other-entries
:specializers specializers
:qualifiers qualifiers)))))
other-entries)
(defun write-page-header (package-name subtitle symbols)
"Writes the header of the HTML page. Assumes that the library
has the same name as the package. Adds a list of all exported
symbols with links."
(format t "
Abstract
The code comes with a BSD-style license so you can basically do with it whatever you want.Download shortcut: http://weitz.de/files/~:*~A.tar.gz.
This documentation was prepared with DOCUMENTATION-TEMPLATE.
$Header: /usr/local/cvsrep/documentation-template/output.lisp,v 1.17 2010/08/05 19:24:27 edi Exp $
BACK TO MY HOMEPAGE ")) (defun create-template (package &key (target (or *target* #-:lispworks (error "*TARGET* not specified.") #+:lispworks (capi:prompt-for-file "Select an output target:" :operation :save :filters '("HTML Files" "*.HTML;*.HTM" "All Files" "*.*") :filter "*.HTML;*.HTM"))) (subtitle "a cool library") ((:maybe-skip-methods-p *maybe-skip-methods-p*) *maybe-skip-methods-p*) (if-exists :supersede) (if-does-not-exist :create)) "Writes an HTML page with preliminary documentation entries and an index for all exported symbols of the package PACKAGE to the file TARGET. If MAYBE-SKIP-METHODS-P is true, documentation entries for inidividual methods are skipped if the corresponding generic function has a documentation string." (when target (setq *target* target)) (let (*symbols*) (with-open-file (*standard-output* target :direction :output :if-exists if-exists :if-does-not-exist if-does-not-exist) (let ((body (with-output-to-string (*standard-output*) (let ((entries (collect-all-doc-entries package))) (loop (let ((entry (or (pop entries) (return)))) (setq entries (write-entry entry entries)))))))) (write-page-header (package-name package) subtitle (mapcar #'string-downcase (reverse *symbols*))) (write-string body) (write-page-footer)))) (values))