diff options
Diffstat (limited to 'third_party/lisp/alexandria/doc')
| -rw-r--r-- | third_party/lisp/alexandria/doc/.gitignore | 3 | ||||
| -rw-r--r-- | third_party/lisp/alexandria/doc/Makefile | 28 | ||||
| -rw-r--r-- | third_party/lisp/alexandria/doc/alexandria.texinfo | 277 | ||||
| -rw-r--r-- | third_party/lisp/alexandria/doc/docstrings.lisp | 881 |
4 files changed, 0 insertions, 1189 deletions
diff --git a/third_party/lisp/alexandria/doc/.gitignore b/third_party/lisp/alexandria/doc/.gitignore deleted file mode 100644 index f22577b3ac86..000000000000 --- a/third_party/lisp/alexandria/doc/.gitignore +++ /dev/null @@ -1,3 +0,0 @@ -alexandria -include - diff --git a/third_party/lisp/alexandria/doc/Makefile b/third_party/lisp/alexandria/doc/Makefile deleted file mode 100644 index 85eb818220d5..000000000000 --- a/third_party/lisp/alexandria/doc/Makefile +++ /dev/null @@ -1,28 +0,0 @@ -.PHONY: clean html pdf include clean-include clean-crap info doc - -doc: pdf html info clean-crap - -clean-include: - rm -rf include - -clean-crap: - rm -f *.aux *.cp *.fn *.fns *.ky *.log *.pg *.toc *.tp *.tps *.vr - -clean: clean-include - rm -f *.pdf *.html *.info - -include: - sbcl --no-userinit --eval '(require :asdf)' \ - --eval '(let ((asdf:*central-registry* (list "../"))) (require :alexandria))' \ - --load docstrings.lisp \ - --eval '(sb-texinfo:generate-includes "include/" (list :alexandria) :base-package :alexandria)' \ - --eval '(quit)' - -pdf: include - texi2pdf alexandria.texinfo - -html: include - makeinfo --html --no-split alexandria.texinfo - -info: include - makeinfo alexandria.texinfo diff --git a/third_party/lisp/alexandria/doc/alexandria.texinfo b/third_party/lisp/alexandria/doc/alexandria.texinfo deleted file mode 100644 index 89b03ac34967..000000000000 --- a/third_party/lisp/alexandria/doc/alexandria.texinfo +++ /dev/null @@ -1,277 +0,0 @@ -\input texinfo @c -*-texinfo-*- -@c %**start of header -@setfilename alexandria.info -@settitle Alexandria Manual -@c %**end of header - -@settitle Alexandria Manual -- draft version - -@c for install-info -@dircategory Software development -@direntry -* alexandria: Common Lisp utilities. -@end direntry - -@copying -Alexandria software and associated documentation are in the public -domain: - -@quotation - Authors dedicate this work to public domain, for the benefit of the - public at large and to the detriment of the authors' heirs and - successors. Authors intends this dedication to be an overt act of - relinquishment in perpetuity of all present and future rights under - copyright law, whether vested or contingent, in the work. Authors - understands that such relinquishment of all rights includes the - relinquishment of all rights to enforce (by lawsuit or otherwise) - those copyrights in the work. - - Authors recognize that, once placed in the public domain, the work - may be freely reproduced, distributed, transmitted, used, modified, - built upon, or otherwise exploited by anyone for any purpose, - commercial or non-commercial, and in any way, including by methods - that have not yet been invented or conceived. -@end quotation - -In those legislations where public domain dedications are not -recognized or possible, Alexandria is distributed under the following -terms and conditions: - -@quotation - Permission is hereby granted, free of charge, to any person - obtaining a copy of this software and associated documentation files - (the "Software"), to deal in the Software without restriction, - including without limitation the rights to use, copy, modify, merge, - publish, distribute, sublicense, and/or sell copies of the Software, - and to permit persons to whom the Software is furnished to do so, - subject to the following conditions: - - THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, - EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF - MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. - IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY - CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, - TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE - SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. -@end quotation -@end copying - -@titlepage - -@title Alexandria Manual -@subtitle draft version - -@c The following two commands start the copyright page. -@page -@vskip 0pt plus 1filll -@insertcopying - -@end titlepage - -@contents - -@ifnottex - -@include include/ifnottex.texinfo - -@node Top -@comment node-name, next, previous, up -@top Alexandria - -@insertcopying - -@menu -* Hash Tables:: -* Data and Control Flow:: -* Conses:: -* Sequences:: -* IO:: -* Macro Writing:: -* Symbols:: -* Arrays:: -* Types:: -* Numbers:: -@end menu - -@end ifnottex - -@node Hash Tables -@comment node-name, next, previous, up -@chapter Hash Tables - -@include include/macro-alexandria-ensure-gethash.texinfo -@include include/fun-alexandria-copy-hash-table.texinfo -@include include/fun-alexandria-maphash-keys.texinfo -@include include/fun-alexandria-maphash-values.texinfo -@include include/fun-alexandria-hash-table-keys.texinfo -@include include/fun-alexandria-hash-table-values.texinfo -@include include/fun-alexandria-hash-table-alist.texinfo -@include include/fun-alexandria-hash-table-plist.texinfo -@include include/fun-alexandria-alist-hash-table.texinfo -@include include/fun-alexandria-plist-hash-table.texinfo - -@node Data and Control Flow -@comment node-name, next, previous, up -@chapter Data and Control Flow - -@include include/macro-alexandria-define-constant.texinfo -@include include/macro-alexandria-destructuring-case.texinfo -@include include/macro-alexandria-ensure-functionf.texinfo -@include include/macro-alexandria-multiple-value-prog2.texinfo -@include include/macro-alexandria-named-lambda.texinfo -@include include/macro-alexandria-nth-value-or.texinfo -@include include/macro-alexandria-if-let.texinfo -@include include/macro-alexandria-when-let.texinfo -@include include/macro-alexandria-when-let-star.texinfo -@include include/macro-alexandria-switch.texinfo -@include include/macro-alexandria-cswitch.texinfo -@include include/macro-alexandria-eswitch.texinfo -@include include/macro-alexandria-whichever.texinfo -@include include/macro-alexandria-xor.texinfo - -@include include/fun-alexandria-disjoin.texinfo -@include include/fun-alexandria-conjoin.texinfo -@include include/fun-alexandria-compose.texinfo -@include include/fun-alexandria-ensure-function.texinfo -@include include/fun-alexandria-multiple-value-compose.texinfo -@include include/fun-alexandria-curry.texinfo -@include include/fun-alexandria-rcurry.texinfo - -@node Conses -@comment node-name, next, previous, up -@chapter Conses - -@include include/type-alexandria-proper-list.texinfo -@include include/type-alexandria-circular-list.texinfo - -@include include/macro-alexandria-appendf.texinfo -@include include/macro-alexandria-nconcf.texinfo -@include include/macro-alexandria-remove-from-plistf.texinfo -@include include/macro-alexandria-delete-from-plistf.texinfo -@include include/macro-alexandria-reversef.texinfo -@include include/macro-alexandria-nreversef.texinfo -@include include/macro-alexandria-unionf.texinfo -@include include/macro-alexandria-nunionf.texinfo - -@include include/macro-alexandria-doplist.texinfo - -@include include/fun-alexandria-circular-list-p.texinfo -@include include/fun-alexandria-circular-tree-p.texinfo -@include include/fun-alexandria-proper-list-p.texinfo - -@include include/fun-alexandria-alist-plist.texinfo -@include include/fun-alexandria-plist-alist.texinfo -@include include/fun-alexandria-circular-list.texinfo -@include include/fun-alexandria-make-circular-list.texinfo -@include include/fun-alexandria-ensure-car.texinfo -@include include/fun-alexandria-ensure-cons.texinfo -@include include/fun-alexandria-ensure-list.texinfo -@include include/fun-alexandria-flatten.texinfo -@include include/fun-alexandria-lastcar.texinfo -@include include/fun-alexandria-setf-lastcar.texinfo -@include include/fun-alexandria-proper-list-length.texinfo -@include include/fun-alexandria-mappend.texinfo -@include include/fun-alexandria-map-product.texinfo -@include include/fun-alexandria-remove-from-plist.texinfo -@include include/fun-alexandria-delete-from-plist.texinfo -@include include/fun-alexandria-set-equal.texinfo -@include include/fun-alexandria-setp.texinfo - -@node Sequences -@comment node-name, next, previous, up -@chapter Sequences - -@include include/type-alexandria-proper-sequence.texinfo - -@include include/macro-alexandria-deletef.texinfo -@include include/macro-alexandria-removef.texinfo - -@include include/fun-alexandria-rotate.texinfo -@include include/fun-alexandria-shuffle.texinfo -@include include/fun-alexandria-random-elt.texinfo -@include include/fun-alexandria-emptyp.texinfo -@include include/fun-alexandria-sequence-of-length-p.texinfo -@include include/fun-alexandria-length-equals.texinfo -@include include/fun-alexandria-copy-sequence.texinfo -@include include/fun-alexandria-first-elt.texinfo -@include include/fun-alexandria-setf-first-elt.texinfo -@include include/fun-alexandria-last-elt.texinfo -@include include/fun-alexandria-setf-last-elt.texinfo -@include include/fun-alexandria-starts-with.texinfo -@include include/fun-alexandria-starts-with-subseq.texinfo -@include include/fun-alexandria-ends-with.texinfo -@include include/fun-alexandria-ends-with-subseq.texinfo -@include include/fun-alexandria-map-combinations.texinfo -@include include/fun-alexandria-map-derangements.texinfo -@include include/fun-alexandria-map-permutations.texinfo - -@node IO -@comment node-name, next, previous, up -@chapter IO - -@include include/fun-alexandria-read-stream-content-into-string.texinfo -@include include/fun-alexandria-read-file-into-string.texinfo -@include include/fun-alexandria-read-stream-content-into-byte-vector.texinfo -@include include/fun-alexandria-read-file-into-byte-vector.texinfo - -@node Macro Writing -@comment node-name, next, previous, up -@chapter Macro Writing - -@include include/macro-alexandria-once-only.texinfo -@include include/macro-alexandria-with-gensyms.texinfo -@include include/macro-alexandria-with-unique-names.texinfo -@include include/fun-alexandria-featurep.texinfo -@include include/fun-alexandria-parse-body.texinfo -@include include/fun-alexandria-parse-ordinary-lambda-list.texinfo - -@node Symbols -@comment node-name, next, previous, up -@chapter Symbols - -@include include/fun-alexandria-ensure-symbol.texinfo -@include include/fun-alexandria-format-symbol.texinfo -@include include/fun-alexandria-make-keyword.texinfo -@include include/fun-alexandria-make-gensym.texinfo -@include include/fun-alexandria-make-gensym-list.texinfo -@include include/fun-alexandria-symbolicate.texinfo - -@node Arrays -@comment node-name, next, previous, up -@chapter Arrays - -@include include/type-alexandria-array-index.texinfo -@include include/type-alexandria-array-length.texinfo -@include include/fun-alexandria-copy-array.texinfo - -@node Types -@comment node-name, next, previous, up -@chapter Types - -@include include/type-alexandria-string-designator.texinfo -@include include/macro-alexandria-coercef.texinfo -@include include/fun-alexandria-of-type.texinfo -@include include/fun-alexandria-type-equals.texinfo - -@node Numbers -@comment node-name, next, previous, up -@chapter Numbers - -@include include/macro-alexandria-maxf.texinfo -@include include/macro-alexandria-minf.texinfo - -@include include/fun-alexandria-binomial-coefficient.texinfo -@include include/fun-alexandria-count-permutations.texinfo -@include include/fun-alexandria-clamp.texinfo -@include include/fun-alexandria-lerp.texinfo -@include include/fun-alexandria-factorial.texinfo -@include include/fun-alexandria-subfactorial.texinfo -@include include/fun-alexandria-gaussian-random.texinfo -@include include/fun-alexandria-iota.texinfo -@include include/fun-alexandria-map-iota.texinfo -@include include/fun-alexandria-mean.texinfo -@include include/fun-alexandria-median.texinfo -@include include/fun-alexandria-variance.texinfo -@include include/fun-alexandria-standard-deviation.texinfo - -@bye diff --git a/third_party/lisp/alexandria/doc/docstrings.lisp b/third_party/lisp/alexandria/doc/docstrings.lisp deleted file mode 100644 index 51dda07d09b7..000000000000 --- a/third_party/lisp/alexandria/doc/docstrings.lisp +++ /dev/null @@ -1,881 +0,0 @@ -;;; -*- lisp -*- - -;;;; A docstring extractor for the sbcl manual. Creates -;;;; @include-ready documentation from the docstrings of exported -;;;; symbols of specified packages. - -;;;; This software is part of the SBCL software system. SBCL is in the -;;;; public domain and is provided with absolutely no warranty. See -;;;; the COPYING file for more information. -;;;; -;;;; Written by Rudi Schlatte <rudi@constantly.at>, mangled -;;;; by Nikodemus Siivola. - -;;;; TODO -;;;; * Verbatim text -;;;; * Quotations -;;;; * Method documentation untested -;;;; * Method sorting, somehow -;;;; * Index for macros & constants? -;;;; * This is getting complicated enough that tests would be good -;;;; * Nesting (currently only nested itemizations work) -;;;; * doc -> internal form -> texinfo (so that non-texinfo format are also -;;;; easily generated) - -;;;; FIXME: The description below is no longer complete. This -;;;; should possibly be turned into a contrib with proper documentation. - -;;;; Formatting heuristics (tweaked to format SAVE-LISP-AND-DIE sanely): -;;;; -;;;; Formats SYMBOL as @code{symbol}, or @var{symbol} if symbol is in -;;;; the argument list of the defun / defmacro. -;;;; -;;;; Lines starting with * or - that are followed by intented lines -;;;; are marked up with @itemize. -;;;; -;;;; Lines containing only a SYMBOL that are followed by indented -;;;; lines are marked up as @table @code, with the SYMBOL as the item. - -(eval-when (:compile-toplevel :load-toplevel :execute) - (require 'sb-introspect)) - -(defpackage :sb-texinfo - (:use :cl :sb-mop) - (:shadow #:documentation) - (:export #:generate-includes #:document-package) - (:documentation - "Tools to generate TexInfo documentation from docstrings.")) - -(in-package :sb-texinfo) - -;;;; various specials and parameters - -(defvar *texinfo-output*) -(defvar *texinfo-variables*) -(defvar *documentation-package*) -(defvar *base-package*) - -(defparameter *undocumented-packages* '(sb-pcl sb-int sb-kernel sb-sys sb-c)) - -(defparameter *documentation-types* - '(compiler-macro - function - method-combination - setf - ;;structure ; also handled by `type' - type - variable) - "A list of symbols accepted as second argument of `documentation'") - -(defparameter *character-replacements* - '((#\* . "star") (#\/ . "slash") (#\+ . "plus") - (#\< . "lt") (#\> . "gt") - (#\= . "equals")) - "Characters and their replacement names that `alphanumize' uses. If -the replacements contain any of the chars they're supposed to replace, -you deserve to lose.") - -(defparameter *characters-to-drop* '(#\\ #\` #\') - "Characters that should be removed by `alphanumize'.") - -(defparameter *texinfo-escaped-chars* "@{}" - "Characters that must be escaped with #\@ for Texinfo.") - -(defparameter *itemize-start-characters* '(#\* #\-) - "Characters that might start an itemization in docstrings when - at the start of a line.") - -(defparameter *symbol-characters* "ABCDEFGHIJKLMNOPQRSTUVWXYZ1234567890*:-+&#'" - "List of characters that make up symbols in a docstring.") - -(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)) - (short-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" (short-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)" (short-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 short-package-name (package) - (unless (eq package *base-package*) - (car (sort (copy-list (cons (package-name package) (package-nicknames package))) - #'< :key #'length)))) - -;;; 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" (short-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)" (short-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 (let ((*base-package* nil)) - (short-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." - (let ((result (with-output-to-string (s) - (loop for char across string - when (find char *texinfo-escaped-chars*) - do (write-char #\@ s) - do (write-char char s))))) - (if downcasep (nstring-downcase result) result))) - -(defun empty-p (line-number lines) - (and (< -1 line-number (length lines)) - (not (indentation (svref lines line-number))))) - -;;; line markups - -(defvar *not-symbols* '("ANSI" "CLHS")) - -(defun locate-symbols (line) - "Return a list of index pairs of symbol-like parts of LINE." - ;; This would be a good application for a regex ... - (let (result) - (flet ((grab (start end) - (unless (member (subseq line start end) '("ANSI" "CLHS")) - (push (list start end) result)))) - (do ((begin nil) - (maybe-begin t) - (i 0 (1+ i))) - ((= i (length line)) - ;; symbol at end of line - (when (and begin (or (> i (1+ begin)) - (not (member (char line begin) '(#\A #\I))))) - (grab begin i)) - (nreverse result)) - (cond - ((and begin (find (char line i) *symbol-delimiters*)) - ;; symbol end; remember it if it's not "A" or "I" - (when (or (> i (1+ begin)) (not (member (char line begin) '(#\A #\I)))) - (grab begin i)) - (setf begin nil - maybe-begin t)) - ((and begin (not (find (char line i) *symbol-characters*))) - ;; Not a symbol: abort - (setf begin nil)) - ((and maybe-begin (not begin) (find (char line i) *symbol-characters*)) - ;; potential symbol begin at this position - (setf begin i - maybe-begin nil)) - ((find (char line i) *symbol-delimiters*) - ;; potential symbol begin after this position - (setf maybe-begin t)) - (t - ;; Not reading a symbol, not at potential start of symbol - (setf maybe-begin nil))))))) - -(defun texinfo-line (line) - "Format symbols in LINE texinfo-style: either as code or as -variables if the symbol in question is contained in symbols -*TEXINFO-VARIABLES*." - (with-output-to-string (result) - (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) - ;; &foo would be amusingly bold in the pdf thanks to TeX/Texinfo - ;; interactions,so we escape the ampersand -- amusingly for TeX. - ;; sbcl.texinfo defines macros that expand @&key and friends to &key. - (mapcar (lambda (name) - (if (member name lambda-list-keywords) - (format nil "@~A" name) - name)) - (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{~(~{@lw{~A}~^, ~}~)}~%~%" - (remove-if (lambda (class) (hide-superclass-p name class)) - (mapcar #'class-name (ensure-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}~#[~:; --- ~]~ - ~:{~2*~@[~2:*~A~P: ~{@code{@w{~S}}~^, ~}~]~:^; ~}~)~%~%" - (slot-definition-name slot) - (remove - nil - (mapcar - (lambda (name things) - (if things - (list name (length things) things))) - '("initarg" "reader" "writer") - (list - (slot-definition-initargs slot) - (slot-definition-readers slot) - (slot-definition-writers 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)))) - -(defun collect-documentation (package) - "Collects all documentation for all external symbols of the given -package, as well as for the package itself." - (let* ((*documentation-package* (find-package package)) - (docs nil)) - (check-type package package) - (do-external-symbols (symbol package) - (setf docs (nconc (collect-symbol-documentation symbol) docs))) - (let ((doc (maybe-documentation *documentation-package* t))) - (when doc - (push doc docs))) - docs)) - -(defmacro with-texinfo-file (pathname &body forms) - `(with-open-file (*texinfo-output* ,pathname - :direction :output - :if-does-not-exist :create - :if-exists :supersede) - ,@forms)) - -(defun write-ifnottex () - ;; We use @&key, etc to escape & from TeX in lambda lists -- so we need to - ;; define them for info as well. - (flet ((macro (name) - (let ((string (string-downcase name))) - (format *texinfo-output* "@macro ~A~%~A~%@end macro~%" string string)))) - (macro '&allow-other-keys) - (macro '&optional) - (macro '&rest) - (macro '&key) - (macro '&body))) - -(defun generate-includes (directory packages &key (base-package :cl-user)) - "Create files in `directory' containing Texinfo markup of all -docstrings of each exported symbol in `packages'. `directory' is -created if necessary. If you supply a namestring that doesn't end in a -slash, you lose. The generated files are of the form -\"<doc-type>_<packagename>_<symbol-name>.texinfo\" and can be included -via @include statements. Texinfo syntax-significant characters are -escaped in symbol names, but if a docstring contains invalid Texinfo -markup, you lose." - (handler-bind ((warning #'muffle-warning)) - (let ((directory (merge-pathnames (pathname directory))) - (*base-package* (find-package base-package))) - (ensure-directories-exist directory) - (dolist (package packages) - (dolist (doc (collect-documentation (find-package package))) - (with-texinfo-file (merge-pathnames (include-pathname doc) directory) - (write-texinfo doc)))) - (with-texinfo-file (merge-pathnames "ifnottex.texinfo" directory) - (write-ifnottex)) - directory))) - -(defun document-package (package &optional filename) - "Create a file containing all available documentation for the -exported symbols of `package' in Texinfo format. If `filename' is not -supplied, a file \"<packagename>.texinfo\" is generated. - -The definitions can be referenced using Texinfo statements like -@ref{<doc-type>_<packagename>_<symbol-name>.texinfo}. Texinfo -syntax-significant characters are escaped in symbol names, but if a -docstring contains invalid Texinfo markup, you lose." - (handler-bind ((warning #'muffle-warning)) - (let* ((package (find-package package)) - (filename (or filename (make-pathname - :name (string-downcase (short-package-name package)) - :type "texinfo"))) - (docs (sort (collect-documentation package) #'documentation<))) - (with-texinfo-file filename - (dolist (doc docs) - (write-texinfo doc))) - filename))) |