├── .gitignore ├── Makefile ├── README ├── doc ├── style.css ├── Makefile ├── splice-analytics.lisp ├── pileup.texinfo └── docstrings.lisp ├── TODO ├── LICENCE ├── package.lisp ├── pileup.asd ├── tests.lisp └── pileup.lisp /.gitignore: -------------------------------------------------------------------------------- 1 | *~ 2 | *.fasl 3 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | .PHONY: doc web 2 | 3 | all: 4 | echo "Targets: clean, wc" 5 | 6 | clean: 7 | rm -f *.fasl *~ 8 | make -C doc clean 9 | 10 | wc: 11 | wc -l *.lisp 12 | 13 | doc: 14 | make -C doc 15 | 16 | web: doc 17 | sbcl --script doc/splice-analytics.lisp < doc/pileup.html > tmp.html 18 | git checkout gh-pages 19 | mv tmp.html index.html 20 | -------------------------------------------------------------------------------- /README: -------------------------------------------------------------------------------- 1 | For full documentation, see: http://nikodemus.github.com/pileup/ 2 | 3 | Pileup is a portable, performant, and thread-safe binary heap for 4 | Common Lisp, under an MIT-style licence. 5 | 6 | It depends on Alexandria, and outside SBCL additionally on 7 | Bordeaux-Threads. 8 | 9 | Pileup is maintained in Git: 10 | 11 | git clone git://github.com/nikodemus/pileup.git 12 | 13 | will get you a local copy. 14 | 15 | http://github.com/nikodemus/pileup 16 | 17 | is the GitHub project page. 18 | -------------------------------------------------------------------------------- /doc/style.css: -------------------------------------------------------------------------------- 1 | .node { visibility:hidden; height: 0px; } 2 | .menu { visibility:hidden; height: 0px; } 3 | .chapter { background-color:#ffe4fe; } 4 | .section { background-color:#ffe4fe; } 5 | .subsection { background-color:#ffe4fe; } 6 | .settitle { background-color:#ffe4fe; } 7 | .contents { border: 2px solid black; 8 | margin: 1cm 1cm 1cm 1cm; 9 | padding-left: 3mm; } 10 | body { padding: 2em 8em; font-family: sans-serif; } 11 | h1 { padding: 1em; text-align: center; } 12 | -------------------------------------------------------------------------------- /doc/Makefile: -------------------------------------------------------------------------------- 1 | .PHONY: clean html include doc 2 | 3 | doc: html 4 | 5 | clean: 6 | rm -rf include 7 | rm -f *.pdf *.html *.info 8 | rm -f *.aux *.cp *.fn *.fns *.ky *.log *.pg *.toc *.tp *.tps *.vr 9 | 10 | include: 11 | sbcl \ 12 | --eval '(let ((asdf:*central-registry* (cons #p"../" asdf:*central-registry*))) (require :pileup))' \ 13 | --load docstrings.lisp \ 14 | --eval '(sb-texinfo:generate-includes "include/" (list :pileup) :base-package :pileup)' \ 15 | --eval '(quit)' 16 | 17 | html: include 18 | makeinfo --html --no-split --css=style.css pileup.texinfo 19 | 20 | -------------------------------------------------------------------------------- /TODO: -------------------------------------------------------------------------------- 1 | TODO for 2.0 2 | 3 | * WIP HEAP-DELETE should accept keyword arguments similar to CL:DELETE. 4 | *** DONE :COUNT 5 | *** TODO :TEST -- keep it performant, simplify EQL to inline EQ when possible. 6 | *** TODO :KEY -- default to NIL or HEAP-KEY? 7 | If TEST or KEY is used, HEAP-DELETE needs to traverse the entire 8 | heap: it is not generally possible to know if (FUNCALL TEST ELT X) 9 | implies anything about the ordering, unlike with EQL. 10 | * TODO MERGE-HEAPS 11 | * TODO MAKE-HEAP should also accept :ELEMENT-TYPE. 12 | Unboxed allocation for long-lived heaps storing numbers. 13 | * TODO Add other types of heaps. 14 | -------------------------------------------------------------------------------- /doc/splice-analytics.lisp: -------------------------------------------------------------------------------- 1 | #!/usr/local/bin/sbcl --script 2 | 3 | (defvar *analytics* 4 | "") 17 | 18 | ;;; Hey, almost like Perl! 19 | (loop for line = (read-line *standard-input* nil nil) 20 | while line 21 | do (when (search "" line) 22 | (write-line *analytics* *standard-output*)) 23 | (write-line line *standard-output*)) 24 | -------------------------------------------------------------------------------- /LICENCE: -------------------------------------------------------------------------------- 1 | ;;;; Copyright (c) 2010-2013 Nikodemus Siivola 2 | ;;;; 3 | ;;;; Permission is hereby granted, free of charge, to any person obtaining 4 | ;;;; a copy of this software and associated documentation files (the 5 | ;;;; "Software"), to deal in the Software without restriction, including 6 | ;;;; without limitation the rights to use, copy, modify, merge, publish, 7 | ;;;; distribute, sublicense, and/or sell copies of the Software, and to 8 | ;;;; permit persons to whom the Software is furnished to do so, subject to 9 | ;;;; the following conditions: 10 | ;;;; 11 | ;;;; The above copyright notice and this permission notice shall be included 12 | ;;;; in all copies or substantial portions of the Software. 13 | ;;;; 14 | ;;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | ;;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | ;;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 17 | ;;;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY 18 | ;;;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, 19 | ;;;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE 20 | ;;;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | -------------------------------------------------------------------------------- /package.lisp: -------------------------------------------------------------------------------- 1 | ;;;; Copyright (c) 2010-2013 Nikodemus Siivola 2 | ;;;; 3 | ;;;; Permission is hereby granted, free of charge, to any person obtaining 4 | ;;;; a copy of this software and associated documentation files (the 5 | ;;;; "Software"), to deal in the Software without restriction, including 6 | ;;;; without limitation the rights to use, copy, modify, merge, publish, 7 | ;;;; distribute, sublicense, and/or sell copies of the Software, and to 8 | ;;;; permit persons to whom the Software is furnished to do so, subject to 9 | ;;;; the following conditions: 10 | ;;;; 11 | ;;;; The above copyright notice and this permission notice shall be included 12 | ;;;; in all copies or substantial portions of the Software. 13 | ;;;; 14 | ;;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | ;;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | ;;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 17 | ;;;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY 18 | ;;;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, 19 | ;;;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE 20 | ;;;; SOFTWARE OR THE;;;; USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | 22 | (defpackage :pileup 23 | (:use :cl :alexandria #-sbcl :bordeaux-threads) 24 | (:documentation 25 | "Pileup provides a thread-safe binary heap implementation.") 26 | (:export 27 | #:heap 28 | #:heap-count 29 | #:heap-delete 30 | #:heap-empty-p 31 | #:heap-insert 32 | #:heap-key 33 | #:heap-name 34 | #:heap-pop 35 | #:heap-predicate 36 | #:heap-size 37 | #:heap-size-limit 38 | #:heap-top 39 | #:make-heap 40 | #:map-heap 41 | #:with-locked-heap 42 | ) 43 | #+sb-package-locks 44 | (:lock t)) 45 | -------------------------------------------------------------------------------- /doc/pileup.texinfo: -------------------------------------------------------------------------------- 1 | \input texinfo @c -*-texinfo-*- 2 | @c %**start of header 3 | @setfilename pileup.info 4 | @settitle Pileup 5 | @c %**end of header 6 | 7 | @settitle Pileup 8 | 9 | @c for install-info 10 | @dircategory Software development 11 | @direntry 12 | * Pileup: A Thread-Safe Binary Heap 13 | @end direntry 14 | 15 | @titlepage 16 | 17 | @title Pileup 18 | @subtitle A Thread-Safe Binary Heap 19 | 20 | @c The following two commands start the copyright page. 21 | @page 22 | @vskip 0pt plus 1filll 23 | @insertcopying 24 | 25 | @end titlepage 26 | 27 | Pileup provides a portable, performant, and thread-safe binary heap 28 | for Common Lisp, licensed under MIT-style license. 29 | 30 | It depends on Alexandria, and outside SBCL additionally on Bordeaux-Threads. 31 | 32 | Pileup is maintained in Git: 33 | @example 34 | git clone git://github.com/nikodemus/pileup.git 35 | @end example 36 | will get you a local copy. 37 | @example 38 | @url{http://github.com/nikodemus/pileup} 39 | @end example 40 | is the GitHub project page. 41 | 42 | @contents 43 | 44 | @ifnottex 45 | 46 | @include include/ifnottex.texinfo 47 | 48 | @end ifnottex 49 | 50 | @chapter Making Heaps 51 | 52 | @include include/struct-pileup-heap.texinfo 53 | @include include/fun-pileup-make-heap.texinfo 54 | 55 | @chapter Heap Operations 56 | 57 | @include include/macro-pileup-with-locked-heap.texinfo 58 | 59 | @include include/fun-pileup-heap-insert.texinfo 60 | @include include/fun-pileup-heap-pop.texinfo 61 | @include include/fun-pileup-heap-top.texinfo 62 | 63 | @include include/fun-pileup-heap-delete.texinfo 64 | @include include/fun-pileup-map-heap.texinfo 65 | 66 | @chapter Heap Properties 67 | 68 | @include include/fun-pileup-heap-count.texinfo 69 | @include include/fun-pileup-heap-empty-p.texinfo 70 | @include include/fun-pileup-heap-name.texinfo 71 | 72 | @include include/fun-pileup-heap-key.texinfo 73 | @include include/fun-pileup-heap-predicate.texinfo 74 | 75 | @include include/fun-pileup-heap-size.texinfo 76 | @include include/constant-pileup-heap-size-limit.texinfo 77 | 78 | @bye 79 | -------------------------------------------------------------------------------- /pileup.asd: -------------------------------------------------------------------------------- 1 | ;;;; Copyright (c) 2010-2013 Nikodemus Siivola 2 | ;;;; 3 | ;;;; Permission is hereby granted, free of charge, to any person obtaining 4 | ;;;; a copy of this software and associated documentation files (the 5 | ;;;; "Software"), to deal in the Software without restriction, including 6 | ;;;; without limitation the rights to use, copy, modify, merge, publish, 7 | ;;;; distribute, sublicense, and/or sell copies of the Software, and to 8 | ;;;; permit persons to whom the Software is furnished to do so, subject to 9 | ;;;; the following conditions: 10 | ;;;; 11 | ;;;; The above copyright notice and this permission notice shall be included 12 | ;;;; in all copies or substantial portions of the Software. 13 | ;;;; 14 | ;;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | ;;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | ;;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 17 | ;;;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY 18 | ;;;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, 19 | ;;;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE 20 | ;;;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | 22 | (defsystem :pileup 23 | :depends-on (:alexandria #-sbcl :bordeaux-threads) 24 | :description 25 | "A portable, performant, and thread-safe binary heap / priority queue." 26 | :licence "MIT" 27 | :author "Nikodemus Siivola " 28 | :version "1.0.1" 29 | :serial t 30 | :components ((:file "package") 31 | (:file "pileup") 32 | (:static-file "README") 33 | (:static-file "LICENCE"))) 34 | 35 | (defsystem :pileup-tests 36 | :depends-on (:pileup :hu.dwim.stefil) 37 | :licence "MIT" 38 | :description "Tests for PILEUP." 39 | :author "Nikodemus Siivola " 40 | :components ((:file "tests"))) 41 | 42 | (defmethod perform ((o test-op) (c (eql (find-system :pileup)))) 43 | (load-system :pileup-tests) 44 | (funcall (intern (string '#:test-pileup) :pileup-tests))) 45 | -------------------------------------------------------------------------------- /tests.lisp: -------------------------------------------------------------------------------- 1 | ;;;; Copyright (c) 2010-2013 Nikodemus Siivola 2 | ;;;; 3 | ;;;; Permission is hereby granted, free of charge, to any person obtaining 4 | ;;;; a copy of this software and associated documentation files (the 5 | ;;;; "Software"), to deal in the Software without restriction, including 6 | ;;;; without limitation the rights to use, copy, modify, merge, publish, 7 | ;;;; distribute, sublicense, and/or sell copies of the Software, and to 8 | ;;;; permit persons to whom the Software is furnished to do so, subject to 9 | ;;;; the following conditions: 10 | ;;;; 11 | ;;;; The above copyright notice and this permission notice shall be included 12 | ;;;; in all copies or substantial portions of the Software. 13 | ;;;; 14 | ;;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | ;;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | ;;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 17 | ;;;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY 18 | ;;;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, 19 | ;;;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE 20 | ;;;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | 22 | (defpackage :pileup-tests 23 | (:use :cl :pileup :hu.dwim.stefil) 24 | (:export 25 | #:pileup-tests)) 26 | 27 | (in-package :pileup-tests) 28 | 29 | (defsuite (test-pileup :in root-suite) () 30 | (run-child-tests)) 31 | 32 | (in-suite test-pileup) 33 | 34 | (deftest heap-misc () 35 | (is (subtypep 'heap 'structure-object)) 36 | (is (< heap-size-limit array-dimension-limit))) 37 | 38 | (deftest heap-basics () 39 | (let ((heap (make-heap #'< :name "test" :size 128))) 40 | (is (heap-empty-p heap)) 41 | (is (zerop (heap-count heap))) 42 | (is (= 128 (heap-size heap))) 43 | (is (eq #'< (heap-predicate heap))) 44 | (is (equal "test" (heap-name heap))) 45 | (heap-insert 0 heap) 46 | (is (not (heap-empty-p heap))) 47 | (dotimes (i 127) 48 | (heap-insert i heap)) 49 | (heap-insert -1 heap) 50 | (is (= 129 (heap-count heap))) 51 | (is (= 256 (heap-size heap))) 52 | (is (= -1 (heap-top heap))) 53 | (heap-insert 100 heap) 54 | (is (< 130 (heap-size heap))) 55 | (is (= 130 (heap-count heap))) 56 | (is (= -1 (heap-top heap))) 57 | (is (= -1 (heap-pop heap))) 58 | (is (= 0 (heap-pop heap))) 59 | (is (= 0 (heap-top heap))) 60 | (is (< 129 (heap-size heap))) 61 | (is (= 128 (heap-count heap))) 62 | (dotimes (i 127) 63 | (when (= i 100) 64 | (is (= 100 (heap-pop heap)))) 65 | (is (= i (heap-pop heap)))) 66 | (is (= 0 (heap-count heap))) 67 | (is (heap-empty-p heap)))) 68 | 69 | (deftest heap-stress () 70 | (let ((heap (make-heap #'>))) 71 | (loop repeat 10000 72 | do (heap-insert (random 1.0) heap)) 73 | (is (= 10000 (heap-count heap))) 74 | (let ((prev 1.0) 75 | (oops 0)) 76 | (loop repeat 10000 77 | do (let ((this (heap-pop heap))) 78 | (unless (>= prev this) 79 | (incf oops)) 80 | (setf prev this))) 81 | (is (zerop oops)) 82 | (is (heap-empty-p heap))))) 83 | 84 | (deftest heap-traverse () 85 | (let ((heap (make-heap #'>))) 86 | (dotimes (i 128) 87 | (heap-insert i heap)) 88 | (let ((x 128)) 89 | (map-heap (lambda (i) 90 | (decf x) 91 | (is (eql i x))) 92 | heap) 93 | (is (zerop x)) 94 | (is (= 128 (heap-count heap)))))) 95 | 96 | (deftest heap-bad-insert () 97 | (let ((heap (make-heap #'<))) 98 | (dotimes (i 128) 99 | ;; Insertion of an element breaking the 100 | ;; predicate should unwind but leave the 101 | ;; heap intact. 102 | (ignore-errors 103 | (heap-insert (princ-to-string i) heap)) 104 | (heap-insert i heap)) 105 | (is (= 128 (heap-count heap))) 106 | (let ((oops 0)) 107 | (dotimes (i 128) 108 | (unless (= i (heap-pop heap)) 109 | (incf oops))) 110 | (is (zerop oops))))) 111 | 112 | (deftest heap-broken-delete () 113 | (let ((heap (make-heap (lambda (x y) 114 | (unless (eq :pass *) 115 | (check-type x unsigned-byte) 116 | (check-type y unsigned-byte)) 117 | (> x y))))) 118 | (dotimes (i 128) 119 | (heap-insert i heap)) 120 | (is (= 128 (heap-count heap))) 121 | (is (= 127 (heap-top heap))) 122 | ;; Now break the heap. 123 | (let ((* :pass)) 124 | (heap-insert -1 heap)) 125 | (is (eq :error 126 | (handler-case 127 | (heap-pop heap) 128 | (error () :error)))) 129 | ;; Unwinding from HEAP-POP can recover heap state 130 | ;; in simple cases. 131 | (is (eq :clean (pileup::heap-state heap))) 132 | ;; Unordered map to the rescue. 133 | (let ((new (make-heap (heap-predicate heap)))) 134 | (map-heap (lambda (i) 135 | (when (typep i 'unsigned-byte) 136 | (heap-insert i new))) 137 | heap 138 | :ordered nil) 139 | (setf heap new)) 140 | (is (= 128 (heap-count heap))) 141 | (is (= 127 (heap-top heap))) 142 | (let ((x 128) 143 | (oops 0)) 144 | (map-heap (lambda (i) 145 | (decf x) 146 | (unless (eql i x) 147 | (incf oops))) 148 | heap) 149 | (is (zerop oops)) 150 | (is (zerop x)) 151 | (is (= 128 (heap-count heap)))))) 152 | 153 | (deftest heap-key-test () 154 | (let ((heap (make-heap #'< :key #'car))) 155 | (dotimes (i 12) 156 | (heap-insert (cons i t) heap)) 157 | (is (= 12 (heap-count heap))) 158 | (is (equal (cons 0 t) (heap-top heap))))) 159 | 160 | (deftest delete-multiple-from-top () 161 | (let ((heap (make-heap #'>))) 162 | (heap-insert 100 heap) 163 | (heap-insert 100 heap) 164 | (is (eq t (heap-delete 100 heap))) 165 | (is (heap-empty-p heap)))) 166 | 167 | (deftest delete-count () 168 | (let ((heap (make-heap #'>))) 169 | (heap-insert 100 heap) 170 | (heap-insert 100 heap) 171 | (is (eq t (heap-delete 100 heap :count 1))) 172 | (is (not (heap-empty-p heap))) 173 | (is (= 100 (heap-pop heap))) 174 | (is (heap-empty-p heap)))) 175 | 176 | (deftest delete-boundary-cases () 177 | (let ((heap (make-heap #'<))) 178 | ;; No elements 179 | (is (not (heap-delete 0 heap))) 180 | (is (heap-empty-p heap)) 181 | ;; One element 182 | (heap-insert 0 heap) 183 | (is (heap-delete 0 heap)) 184 | (is (heap-empty-p heap)) 185 | ;; Two elements, first 186 | (heap-insert 0 heap) 187 | (heap-insert 1 heap) 188 | (is (= 0 (heap-top heap))) 189 | (is (heap-delete 0 heap)) 190 | (is (= 1 (heap-count heap))) 191 | (is (= 1 (heap-top heap))) 192 | ;; Two elements, last 193 | (heap-insert 0 heap) 194 | (is (= 0 (heap-top heap))) 195 | (is (heap-delete 1 heap)) 196 | (is (= 1 (heap-count heap))) 197 | (is (= 0 (heap-top heap))))) 198 | 199 | #+sbcl 200 | (deftest slot-names-nice () 201 | (let ((pileup (find-package :pileup))) 202 | (dolist (slotd (sb-mop:class-slots (find-class 'heap))) 203 | (let ((name (sb-mop:slot-definition-name slotd))) 204 | (is (eq pileup (symbol-package name))) 205 | (is (eq :internal (nth-value 1 (find-symbol (string name) pileup)))))))) 206 | 207 | (deftest cmacro-two-arg-pred () 208 | (let ((constructor-form (funcall (compiler-macro-function 'make-heap) 209 | `(make-heap #'< :key nil) 210 | nil))) 211 | (is (equal `(pileup::make-heap-using-fast-pred #'< #'pileup::two-arg-<) 212 | constructor-form)))) 213 | 214 | (deftest cmacro-user-pred () 215 | (let ((constructor-form (funcall (compiler-macro-function 'make-heap) 216 | `(make-heap #'string< :key nil) 217 | nil))) 218 | (is (equal `(pileup::make-heap-using-fast-pred #'string< #'string<) 219 | constructor-form)) 220 | (let ((heap (eval constructor-form))) 221 | (loop for char across "QWERTY" 222 | do (heap-insert (string char) heap)) 223 | (is (string= "EQRTWY" 224 | (with-output-to-string (s) 225 | (loop for x = (heap-pop heap) 226 | while x 227 | do (write-string x s)))))))) 228 | -------------------------------------------------------------------------------- /pileup.lisp: -------------------------------------------------------------------------------- 1 | ;;;; Copyright (c) 2010-2013 Nikodemus Siivola 2 | ;;;; 3 | ;;;; Permission is hereby granted, free of charge, to any person obtaining 4 | ;;;; a copy of this software and associated documentation files (the 5 | ;;;; "Software"), to deal in the Software without restriction, including 6 | ;;;; without limitation the rights to use, copy, modify, merge, publish, 7 | ;;;; distribute, sublicense, and/or sell copies of the Software, and to 8 | ;;;; permit persons to whom the Software is furnished to do so, subject to 9 | ;;;; the following conditions: 10 | ;;;; 11 | ;;;; The above copyright notice and this permission notice shall be included 12 | ;;;; in all copies or substantial portions of the Software. 13 | ;;;; 14 | ;;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | ;;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | ;;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 17 | ;;;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY 18 | ;;;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, 19 | ;;;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE 20 | ;;;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | 22 | (in-package :pileup) 23 | 24 | ;;; Tombstone for the heap vector. The only place where this really matters 25 | ;;; is at 0. 26 | (defconstant +empty+ '+empty+) 27 | 28 | (defun make-heap-vector (size) 29 | (declare (array-index size)) 30 | (let ((vector (make-array (1+ size)))) 31 | (setf (aref vector 0) +empty+) 32 | vector)) 33 | 34 | (declaim (inline make-heap make-heap-using-fast-pred)) 35 | (defstruct (heap 36 | (:constructor make-heap 37 | (predicate &key ((:name %name)) ((:size %size) 12) ((:key %key)) 38 | &aux (%vector (make-heap-vector %size)) 39 | (%predicate predicate) 40 | (fast-pred 41 | (locally 42 | #+sbcl 43 | (declare (sb-ext:muffle-conditions 44 | sb-ext:compiler-note)) 45 | (if %key 46 | (lambda (x y) 47 | (declare (function %key %predicate) 48 | (optimize (speed 3) 49 | (debug 0) 50 | (safety 0))) 51 | (let ((xx (funcall %key x)) 52 | (yy (funcall %key y))) 53 | (funcall %predicate xx yy))) 54 | %predicate))))) 55 | (:constructor make-heap-using-fast-pred 56 | (%predicate fast-pred &key ((:name %name)) ((:size %size) 12) 57 | &aux (%vector (make-heap-vector %size)))) 58 | (:copier nil) 59 | (:predicate nil)) 60 | "A thread-safe binary heap. 61 | 62 | Heap operations which need the heap to remain consistent heap lock it. Users 63 | can also group multiple heap operations into atomic units using 64 | WITH-LOCKED-HEAP. 65 | 66 | Thread-safety is implemented using a single lock per heap. While Pileup heaps 67 | are fine for threaded use, a more specialized solution is recommended when the 68 | heap is highly contested between multiple threads. 69 | 70 | Important: Pileup heaps are not asynch-unwind safe: asynchronous interrupts 71 | causing non-local exits may leave the heap in an inconsistent state or lose 72 | data. Do not use INTERRUPT-THREAD or asychronous timeouts with Pileup. 73 | 74 | All slot names in HEAP are internal to the PILEUP package, so it is safe to 75 | subclass using eg. DEFSTRUCT :INCLUDE, as long as only the exported operations 76 | are used to accessor or modify heap state." 77 | (%name nil) 78 | ;; One longer than SIZE: we keep the min element in both 0 and 1. Using 79 | ;; 1-based addressing makes heap calculations simpler, and keeping a 80 | ;; separate reference in 0 allows HEAP-TOP to be lockless. 81 | ;; 82 | ;; Using adjustable arrays would make the code simpler, but because the 83 | ;; loops for maintaining the heap-property don't need to adjust the vectors 84 | ;; we'd be paying for the increased access overheap in just the wrong place. 85 | ;; 86 | ;; The name is uglified with % because VECTOR is a symbol in CL, and we 87 | ;; don't want to have clashes with user code subclassing this structure, who 88 | ;; might also want to use that name. 89 | (%vector (required-argument :vector) :type simple-vector) 90 | (%count 0 :type array-index) 91 | (%size (required-argument :%size) :type array-index) 92 | (%predicate (required-argument :predicate) :type function :read-only t) 93 | (%key nil :type (or null function) :read-only t) 94 | ;; Combination of KEY and PREDICATE. 95 | (fast-pred (required-argument :fast-pred) :type function :read-only t) 96 | (lock #+sbcl (sb-thread:make-mutex :name "Heap Lock") 97 | #-sbcl (bordeaux-threads:make-lock "Heap Lock") 98 | :read-only t) 99 | (state :clean :type (member :clean :dirty :traverse))) 100 | 101 | ;;; Calling variadic functions like #'< is generally a whole lot slower than 102 | ;;; calling them with a known number of arguments, so we generate fixed-arity 103 | ;;; versions for the normal ones. 104 | (defvar *two-arg-predicates* nil) 105 | (macrolet ((fast (name) 106 | (let ((two-arg-name (symbolicate '#:two-arg- name))) 107 | `(progn 108 | (defun ,two-arg-name (x y) 109 | (declare (optimize (speed 3) (debug 0) (safety 0))) 110 | #+sbcl 111 | (declare (sb-ext:muffle-conditions sb-ext:compiler-note)) 112 | (,name x y)) 113 | (pushnew (cons ',name '#',two-arg-name) 114 | *two-arg-predicates* 115 | :test #'equal))))) 116 | (fast <) 117 | (fast <=) 118 | (fast >) 119 | (fast >=)) 120 | 121 | (define-compiler-macro make-heap (&whole whole predicate &rest initargs) 122 | (let ((no-key t)) 123 | ;; Check that there's no non-null KEY is being used. 124 | (doplist (key val initargs) 125 | (when (or (eq :key key) (not (keywordp key))) 126 | (unless (null val) 127 | (setf no-key nil))) 128 | (when (eq :key key) 129 | (return))) 130 | ;; At least for compilers like SBCL the FAST-PRED lambda in the constructor 131 | ;; does the same job for cases where KEY is provided. 132 | ;; 133 | ;; (Once :ELEMENT-TYPE is added we can also inform the predicate about it 134 | ;; here.) 135 | (if no-key 136 | (let ((fast-pred 137 | (or (and (consp predicate) 138 | (starts-with 'function predicate) 139 | (cdr (assoc (second predicate) *two-arg-predicates*))) 140 | predicate))) 141 | `(make-heap-using-fast-pred ,predicate ,fast-pred 142 | ,@(remove-from-plist initargs :key))) 143 | whole))) 144 | 145 | (setf (documentation 'make-heap 'function) 146 | "Constructs a HEAP. 147 | 148 | The PREDICATE determines the ordering of the heap. It must be a function of two 149 | arguments, returning true if the first argument should be closer to top of the 150 | heap than the second. If a predicate signals an error and causes a non-local 151 | exit from a heap operation, it may leave the heap in an inconsistent state and 152 | cause a subsequent heap operation to signal an error. 153 | 154 | If KEY is not NIL, it must be a function of one argument, and is used to 155 | extract values for use by PREDICATE for comparison. 156 | 157 | The NAME can be used to optionally specify a name for the heap: it affects only 158 | printing of the heap. 159 | 160 | The SIZE is the size of the storage initially reserved for the heap. 161 | Specifying size is not necessary: the heap will grow as necessary, but a 162 | reasonable estimate can improve performance by eliminating unnecessary copying 163 | by allocating sufficient storage immediately.") 164 | 165 | ;;; KLUDGE: For prettier arglist in the docs. 166 | (defun heap-name (heap) 167 | "Returns the name of the heap. Heap name affects only printed 168 | representation of the heap. Can be changed using SETF unlike other heap 169 | properties." 170 | (heap-%name heap)) 171 | (defun (setf heap-name) (name heap) 172 | (setf (heap-%name heap) name)) 173 | 174 | ;;; KLUDGE: For prettier arglist in the docs. 175 | (defun heap-predicate (heap) 176 | "Returns the heap predicate, a function of two arguments, returning true if 177 | the first argument should be closer to te top of the heap than the second." 178 | (heap-%predicate heap)) 179 | 180 | ;;; KLUDGE: For prettier arglist in the docs. 181 | (defun heap-key (heap) 182 | "Returns the heap key, a function one argument used to extract values for 183 | use by the heap predicate. Heap key may also be NIL, meaning heap elements are 184 | used directly by the heap predicate." 185 | (heap-%key heap)) 186 | 187 | (declaim (inline heap-count)) 188 | (defun heap-count (heap) 189 | "Returns the number of objects in the heap." 190 | (heap-%count heap)) 191 | 192 | (declaim (inline heap-size)) 193 | (defun heap-size (heap) 194 | "Returns the reserved size of the heap. Note, this is not the same as the 195 | number of elements in the heap: see HEAP-COUNT for comparison." 196 | (heap-%size heap)) 197 | 198 | (declaim (inline heap-empty-p)) 199 | (defun heap-empty-p (heap) 200 | "Returns true if the heap is empty, that is iff HEAP-COUNT is zero." 201 | (zerop (heap-count heap))) 202 | 203 | (defmethod print-object ((heap heap) stream) 204 | (flet ((pretty-fun (fun) 205 | (or (when (functionp fun) 206 | (nth-value 2 (function-lambda-expression fun))) 207 | fun))) 208 | (print-unreadable-object (heap stream :type t :identity t) 209 | (format stream "~@[~S ~]count: ~S predicate: ~S~@[ key: ~S~]" 210 | (heap-name heap) 211 | (heap-count heap) 212 | (pretty-fun (heap-predicate heap)) 213 | (pretty-fun (heap-key heap)))))) 214 | 215 | (defmacro with-locked-heap ((heap) &body body) 216 | "Executes BODY with HEAP locked. Heap operations which implicitly lock the 217 | heap are: HEAP-INSERT, HEAP-POP, HEAP-DELETE, and MAP-HEAP. Allows grouping 218 | multiple heap operations into atomic units." 219 | #+sbcl 220 | `(sb-thread:with-recursive-lock ((heap-lock ,heap)) 221 | ,@body) 222 | #-sbcl 223 | `(bordeaux-threads:with-recursive-lock-held ((heap-lock ,heap)) 224 | ,@body)) 225 | 226 | (defconstant heap-size-limit (- array-dimension-limit 1) 227 | "Exclusive upper limit for heap size, based on ARRAY-DIMENSION-LIMIT. 228 | When an insertion is attempted and the heap cannot grow any further, an error 229 | is signaled.") 230 | 231 | (defconstant max-heap-size (- heap-size-limit 1)) 232 | 233 | (defun check-heap-clean (heap what &optional allow-traverse) 234 | (ecase (heap-state heap) 235 | (:clean t) 236 | (:dirty 237 | (error "Heap dirty on entry to ~S: ~S" 238 | what heap)) 239 | (:traverse 240 | (unless allow-traverse 241 | (error "Cannot ~S while ~S is in progress: ~S" 242 | what 'map-heap heap))))) 243 | 244 | (defun heap-insert (elt heap) 245 | "Insert ELT to HEAP. Returns ELT. 246 | 247 | Locks the heap during its operation unless the current thread is already 248 | holding the heap lock via WITH-LOCKED-HEAP." 249 | (declare (heap heap)) 250 | (with-locked-heap (heap) 251 | (check-heap-clean heap 'heap-insert) 252 | (let* ((vector (heap-%vector heap)) 253 | (fast-pred (heap-fast-pred heap)) 254 | (size (heap-size heap)) 255 | (count (heap-count heap))) 256 | ;; Sanity-check the heap element: if the predicate will signal an error 257 | ;; on receiving it, it is better to know about it before we mess up the 258 | ;; heap state. 259 | (funcall fast-pred elt elt) 260 | ;; Make space if necessary. 261 | (when (= count size) 262 | (when (= size max-heap-size) 263 | (error "Cannot grow heap vector: at maximum size.")) 264 | (let* ((new-size (min (* 2 size) max-heap-size)) 265 | (new (make-array (1+ new-size)))) 266 | (setf vector (replace new vector) 267 | (heap-%size heap) new-size 268 | (heap-%vector heap) vector))) 269 | ;; Mark the heap dirty, and insert the element at the end of the vector. 270 | (setf (heap-state heap) :dirty 271 | (aref vector (incf count)) elt 272 | (heap-%count heap) count) 273 | ;; Restore heap property. 274 | (loop with child = count 275 | while (> child 1) 276 | do (let* ((parent (truncate child 2)) 277 | (parent-data (aref vector parent)) 278 | (child-data (aref vector child))) 279 | (cond ((funcall fast-pred parent-data child-data) 280 | (return)) 281 | (t 282 | (setf (aref vector child) parent-data 283 | (aref vector parent) child-data 284 | child parent))))) 285 | ;; Put reference to min to 0 too. Heap is now clean. 286 | (setf (aref vector 0) (aref vector 1) 287 | (heap-state heap) :clean) 288 | elt))) 289 | 290 | (defun heap-top (heap) 291 | "Returns the element at the top of the HEAP without removing it, and a 292 | secondary value of T. Should the heap be empty, both the primary and the 293 | secondary values are NIL." 294 | (let ((elt (aref (heap-%vector heap) 0))) 295 | (if (eq +empty+ elt) 296 | (values nil nil) 297 | (values elt t)))) 298 | 299 | (defun heap-pop (heap) 300 | "Removes and returns the element at the top of the HEAP and a secondary value of T. 301 | Should the heap be empty, both the primary and the secondary values are NIL. 302 | 303 | Locks the heap during its operation unless the current thread is already 304 | holding the heap lock via WITH-LOCKED-HEAP." 305 | (declare (heap heap)) 306 | (with-locked-heap (heap) 307 | (check-heap-clean heap 'heap-pop) 308 | (cond ((heap-empty-p heap) 309 | (values nil nil)) 310 | (t 311 | (values (%heap-delete 1 heap) t))))) 312 | 313 | ;;; Delete heap element identified by vector index. 314 | (defun %heap-delete (index heap) 315 | (let* ((vector (heap-%vector heap)) 316 | (count (heap-count heap)) 317 | (victim (aref vector index)) 318 | (bottom (aref vector count)) 319 | (fast-pred (heap-fast-pred heap)) 320 | (recoverable t)) 321 | (unwind-protect 322 | (progn 323 | ;; Move BOTTOM in place of VICTIM. Order is important here: if 324 | ;; INDEX=COUNT we want to be left with +EMPTY+. 325 | (setf (heap-state heap) :dirty 326 | (aref vector index) bottom 327 | (aref vector count) +empty+ 328 | (heap-%count heap) (decf count)) 329 | ;; Restore heap property. 330 | ;; Step 1: from deleted element to end 331 | (loop with parent = index 332 | while (< parent count) 333 | do (let* ((local parent) 334 | (local-data (aref vector parent)) 335 | (parent-data local-data) 336 | (left (* 2 parent)) 337 | (right (+ left 1)) 338 | (left-data nil) 339 | (right-data nil)) 340 | (unless (or (> left count) 341 | (funcall fast-pred parent-data 342 | (setf left-data (aref vector left)))) 343 | (setf local left 344 | local-data left-data)) 345 | (unless (or (> right count) 346 | (funcall fast-pred local-data 347 | (setf right-data (aref vector right)))) 348 | (setf local right 349 | local-data right-data)) 350 | (if (= local parent) 351 | (return) 352 | (setf (aref vector parent) local-data 353 | (aref vector local) parent-data 354 | parent local 355 | recoverable nil)))) 356 | ;; Step 2: fix towards the head. 357 | (cond ((= index 1) 358 | ;; Deleted the topmost element: copy it to V[0] 359 | (setf (aref vector 0) (aref vector 1))) 360 | ((= index (1+ count)) 361 | ;; Deleted the last element: nothing to do. 362 | ) 363 | (t 364 | ;; Deleted something from middle: fix heap property 365 | ;; towards the head. 366 | (loop with child = index 367 | while (> child 1) 368 | do (let* ((parent (truncate child 2)) 369 | (parent-data (aref vector parent)) 370 | (child-data (aref vector child))) 371 | (cond ((funcall fast-pred parent-data child-data) 372 | (return)) 373 | (t 374 | (setf (aref vector child) parent-data 375 | (aref vector parent) child-data 376 | child parent 377 | recoverable nil))))))) 378 | ;; Clean again 379 | (setf (heap-state heap) :clean)) 380 | ;; If we're not clean, try to recover on unwind. 381 | (unless (eq :clean (heap-state heap)) 382 | (setf (heap-%count heap) (incf count)) 383 | (if recoverable 384 | ;; We didn't actually swap any elements yet, so we can restore 385 | ;; the whole heap. 386 | (setf (aref vector count) bottom 387 | (aref vector index) victim 388 | (heap-state heap) :clean) 389 | ;; Can't recover, but at least put VICTIM back -- recovery of 390 | ;; sorts is still possible using unordered MAP-HEAP. 391 | (setf (aref vector count) victim)))) 392 | victim)) 393 | 394 | (defun heap-delete (elt heap &key count) 395 | "Removes elements of the HEAP EQL to ELT. Returns T if one or more elements 396 | were found and removed, NIL otherwise. 397 | 398 | If COUNT is NIL (the default), removes all elements EQL to ELT, otherwise at 399 | most the indicated number. 400 | 401 | Locks the heap during its operation unless the current thread is already 402 | holding the heap lock via WITH-LOCKED-HEAP." 403 | (declare (type heap heap)) 404 | (with-locked-heap (heap) 405 | (check-heap-clean heap 'heap-delete) 406 | (let* ((todo (cond ((not count) -1) 407 | ((minusp count) 0) 408 | (t count))) 409 | (count (heap-count heap)) 410 | (vector (heap-%vector heap)) 411 | (fast-pred (heap-fast-pred heap))) 412 | (unless (or (zerop count) (zerop todo)) 413 | (let ((fringe (make-heap (lambda (x y) 414 | (funcall fast-pred (aref vector x) (aref vector y)))))) 415 | ;; Grab the lock now so we don't need to do that repeatedly. 416 | (with-locked-heap (fringe) 417 | (heap-insert 1 fringe) 418 | (loop until (heap-empty-p fringe) 419 | do (let* ((parent (heap-pop fringe)) 420 | (parent-elt (aref vector parent))) 421 | (cond ((eql elt parent-elt) 422 | ;; Got it. Now delete them all. 423 | (loop do (%heap-delete parent heap) 424 | (decf todo) 425 | while (and (/= 0 todo) (eql elt (aref vector parent)))) 426 | (return-from heap-delete t)) 427 | ((funcall fast-pred elt parent-elt) 428 | ;; Searched past it. 429 | (return-from heap-delete nil)) 430 | (t 431 | (let* ((left (* 2 parent)) 432 | (right (1+ left))) 433 | (unless (> left count) 434 | (heap-insert left fringe)) 435 | (unless (> right count) 436 | (heap-insert right fringe))))))))))))) 437 | 438 | (defun map-heap (function heap &key (ordered t)) 439 | "Calls FUNCTION for each element in heap. Returns the heap. 440 | 441 | If ORDERED is true \(the default), processes the elements in heap order from 442 | top down. 443 | 444 | If ORDERED is false, uses unordered traversal. Unordered traversal is faster 445 | and also works on heaps that have been corrupted by eg. the heap predicate 446 | performing a non-local exit from a heap operation. 447 | 448 | Attempts to insert or delete elements to the heap from FUNCTION will cause 449 | an error to be signalled. 450 | 451 | Locks the heap during its operation unless the current thread is already 452 | holding the heap lock via WITH-LOCKED-HEAP." 453 | (declare (heap heap)) 454 | (with-locked-heap (heap) 455 | (let ((count (heap-count heap)) 456 | (old-state (heap-state heap))) 457 | (when ordered 458 | (check-heap-clean heap 'map-heap t)) 459 | (unwind-protect 460 | (unless (zerop count) 461 | ;; Mark the heap as traversed 462 | (setf (heap-state heap) :traverse) 463 | (let ((vector (heap-%vector heap))) 464 | (if ordered 465 | ;; ORDERED = T traversal. Keep fringe in another heap 466 | ;; to maintain order. 467 | (let* ((fast-pred (heap-fast-pred heap)) 468 | (fringe (make-heap 469 | (lambda (x y) 470 | (funcall fast-pred (aref vector x) (aref vector y)))))) 471 | ;; Grab the lock now so we don't need to do that repeatedly. 472 | (with-locked-heap (fringe) 473 | (heap-insert 1 fringe) 474 | (loop until (heap-empty-p fringe) 475 | do (let* ((parent (heap-pop fringe)) 476 | (left (* 2 parent)) 477 | (right (1+ left))) 478 | (funcall function (aref vector parent)) 479 | (unless (> left count) 480 | (heap-insert left fringe)) 481 | (unless (> right count) 482 | (heap-insert right fringe)))) 483 | (heap-size fringe))) 484 | ;; ORDERED = NIL traversal. Just iterate over the vector. 485 | (loop for i from 1 upto count 486 | do (funcall function (aref vector i)))))) 487 | ;; Restore the old state: either :CLEAN, or another :TRAVERSE. 488 | (setf (heap-state heap) old-state)))) 489 | heap) 490 | 491 | -------------------------------------------------------------------------------- /doc/docstrings.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- lisp -*- 2 | 3 | ;;;; A docstring extractor for the sbcl manual. Creates 4 | ;;;; @include-ready documentation from the docstrings of exported 5 | ;;;; symbols of specified packages. 6 | 7 | ;;;; This software is part of the SBCL software system. SBCL is in the 8 | ;;;; public domain and is provided with absolutely no warranty. See 9 | ;;;; the COPYING file for more information. 10 | ;;;; 11 | ;;;; Written by Rudi Schlatte , mangled 12 | ;;;; by Nikodemus Siivola. 13 | 14 | ;;;; TODO 15 | ;;;; * Verbatim text 16 | ;;;; * Quotations 17 | ;;;; * Method documentation untested 18 | ;;;; * Method sorting, somehow 19 | ;;;; * Index for macros & constants? 20 | ;;;; * This is getting complicated enough that tests would be good 21 | ;;;; * Nesting (currently only nested itemizations work) 22 | ;;;; * doc -> internal form -> texinfo (so that non-texinfo format are also 23 | ;;;; easily generated) 24 | 25 | ;;;; FIXME: The description below is no longer complete. This 26 | ;;;; should possibly be turned into a contrib with proper documentation. 27 | 28 | ;;;; Formatting heuristics (tweaked to format SAVE-LISP-AND-DIE sanely): 29 | ;;;; 30 | ;;;; Formats SYMBOL as @code{symbol}, or @var{symbol} if symbol is in 31 | ;;;; the argument list of the defun / defmacro. 32 | ;;;; 33 | ;;;; Lines starting with * or - that are followed by intented lines 34 | ;;;; are marked up with @itemize. 35 | ;;;; 36 | ;;;; Lines containing only a SYMBOL that are followed by indented 37 | ;;;; lines are marked up as @table @code, with the SYMBOL as the item. 38 | 39 | (eval-when (:compile-toplevel :load-toplevel :execute) 40 | (require 'sb-introspect)) 41 | 42 | (defpackage :sb-texinfo 43 | (:use :cl :sb-mop) 44 | (:shadow #:documentation) 45 | (:export #:generate-includes #:document-package) 46 | (:documentation 47 | "Tools to generate TexInfo documentation from docstrings.")) 48 | 49 | (in-package :sb-texinfo) 50 | 51 | ;;;; various specials and parameters 52 | 53 | (defvar *texinfo-output*) 54 | (defvar *texinfo-variables*) 55 | (defvar *documentation-package*) 56 | (defvar *base-package*) 57 | 58 | (defparameter *undocumented-packages* '(sb-pcl sb-int sb-kernel sb-sys sb-c)) 59 | 60 | (defparameter *documentation-types* 61 | '(compiler-macro 62 | function 63 | method-combination 64 | setf 65 | ;;structure ; also handled by `type' 66 | type 67 | variable) 68 | "A list of symbols accepted as second argument of `documentation'") 69 | 70 | (defparameter *character-replacements* 71 | '((#\* . "star") (#\/ . "slash") (#\+ . "plus") 72 | (#\< . "lt") (#\> . "gt") 73 | (#\= . "equals")) 74 | "Characters and their replacement names that `alphanumize' uses. If 75 | the replacements contain any of the chars they're supposed to replace, 76 | you deserve to lose.") 77 | 78 | (defparameter *characters-to-drop* '(#\\ #\` #\') 79 | "Characters that should be removed by `alphanumize'.") 80 | 81 | (defparameter *texinfo-escaped-chars* "@{}" 82 | "Characters that must be escaped with #\@ for Texinfo.") 83 | 84 | (defparameter *itemize-start-characters* '(#\* #\-) 85 | "Characters that might start an itemization in docstrings when 86 | at the start of a line.") 87 | 88 | (defparameter *symbol-characters* "ABCDEFGHIJKLMNOPQRSTUVWXYZ1234567890*:-+&#'" 89 | "List of characters that make up symbols in a docstring.") 90 | 91 | (defparameter *symbol-delimiters* " ,.!?;") 92 | 93 | (defparameter *ordered-documentation-kinds* 94 | '(package type structure condition class macro)) 95 | 96 | ;;;; utilities 97 | 98 | (defun flatten (list) 99 | (cond ((null list) 100 | nil) 101 | ((consp (car list)) 102 | (nconc (flatten (car list)) (flatten (cdr list)))) 103 | ((null (cdr list)) 104 | (cons (car list) nil)) 105 | (t 106 | (cons (car list) (flatten (cdr list)))))) 107 | 108 | (defun whitespacep (char) 109 | (find char #(#\tab #\space #\page))) 110 | 111 | (defun setf-name-p (name) 112 | (or (symbolp name) 113 | (and (listp name) (= 2 (length name)) (eq (car name) 'setf)))) 114 | 115 | (defgeneric specializer-name (specializer)) 116 | 117 | (defmethod specializer-name ((specializer eql-specializer)) 118 | (list 'eql (eql-specializer-object specializer))) 119 | 120 | (defmethod specializer-name ((specializer class)) 121 | (class-name specializer)) 122 | 123 | (defun ensure-class-precedence-list (class) 124 | (unless (class-finalized-p class) 125 | (finalize-inheritance class)) 126 | (class-precedence-list class)) 127 | 128 | (defun specialized-lambda-list (method) 129 | ;; courtecy of AMOP p. 61 130 | (let* ((specializers (method-specializers method)) 131 | (lambda-list (method-lambda-list method)) 132 | (n-required (length specializers))) 133 | (append (mapcar (lambda (arg specializer) 134 | (if (eq specializer (find-class 't)) 135 | arg 136 | `(,arg ,(specializer-name specializer)))) 137 | (subseq lambda-list 0 n-required) 138 | specializers) 139 | (subseq lambda-list n-required)))) 140 | 141 | (defun string-lines (string) 142 | "Lines in STRING as a vector." 143 | (coerce (with-input-from-string (s string) 144 | (loop for line = (read-line s nil nil) 145 | while line collect line)) 146 | 'vector)) 147 | 148 | (defun indentation (line) 149 | "Position of first non-SPACE character in LINE." 150 | (position-if-not (lambda (c) (char= c #\Space)) line)) 151 | 152 | (defun docstring (x doc-type) 153 | (cl:documentation x doc-type)) 154 | 155 | (defun flatten-to-string (list) 156 | (format nil "~{~A~^-~}" (flatten list))) 157 | 158 | (defun alphanumize (original) 159 | "Construct a string without characters like *`' that will f-star-ck 160 | up filename handling. See `*character-replacements*' and 161 | `*characters-to-drop*' for customization." 162 | (let ((name (remove-if (lambda (x) (member x *characters-to-drop*)) 163 | (if (listp original) 164 | (flatten-to-string original) 165 | (string original)))) 166 | (chars-to-replace (mapcar #'car *character-replacements*))) 167 | (flet ((replacement-delimiter (index) 168 | (cond ((or (< index 0) (>= index (length name))) "") 169 | ((alphanumericp (char name index)) "-") 170 | (t "")))) 171 | (loop for index = (position-if #'(lambda (x) (member x chars-to-replace)) 172 | name) 173 | while index 174 | do (setf name (concatenate 'string (subseq name 0 index) 175 | (replacement-delimiter (1- index)) 176 | (cdr (assoc (aref name index) 177 | *character-replacements*)) 178 | (replacement-delimiter (1+ index)) 179 | (subseq name (1+ index)))))) 180 | name)) 181 | 182 | ;;;; generating various names 183 | 184 | (defgeneric name (thing) 185 | (:documentation "Name for a documented thing. Names are either 186 | symbols or lists of symbols.")) 187 | 188 | (defmethod name ((symbol symbol)) 189 | symbol) 190 | 191 | (defmethod name ((cons cons)) 192 | cons) 193 | 194 | (defmethod name ((package package)) 195 | (short-package-name package)) 196 | 197 | (defmethod name ((method method)) 198 | (list 199 | (generic-function-name (method-generic-function method)) 200 | (method-qualifiers method) 201 | (specialized-lambda-list method))) 202 | 203 | ;;; Node names for DOCUMENTATION instances 204 | 205 | (defgeneric name-using-kind/name (kind name doc)) 206 | 207 | (defmethod name-using-kind/name (kind (name string) doc) 208 | (declare (ignore kind doc)) 209 | name) 210 | 211 | (defmethod name-using-kind/name (kind (name symbol) doc) 212 | (declare (ignore kind)) 213 | (format nil "~@[~A:~]~A" (short-package-name (get-package doc)) name)) 214 | 215 | (defmethod name-using-kind/name (kind (name list) doc) 216 | (declare (ignore kind)) 217 | (assert (setf-name-p name)) 218 | (format nil "(setf ~@[~A:~]~A)" (short-package-name (get-package doc)) (second name))) 219 | 220 | (defmethod name-using-kind/name ((kind (eql 'method)) name doc) 221 | (format nil "~A~{ ~A~} ~A" 222 | (name-using-kind/name nil (first name) doc) 223 | (second name) 224 | (third name))) 225 | 226 | (defun node-name (doc) 227 | "Returns TexInfo node name as a string for a DOCUMENTATION instance." 228 | (let ((kind (get-kind doc))) 229 | (format nil "~:(~A~) ~(~A~)" kind (name-using-kind/name kind (get-name doc) doc)))) 230 | 231 | (defun short-package-name (package) 232 | (unless (eq package *base-package*) 233 | (car (sort (copy-list (cons (package-name package) (package-nicknames package))) 234 | #'< :key #'length)))) 235 | 236 | ;;; Definition titles for DOCUMENTATION instances 237 | 238 | (defgeneric title-using-kind/name (kind name doc)) 239 | 240 | (defmethod title-using-kind/name (kind (name string) doc) 241 | (declare (ignore kind doc)) 242 | name) 243 | 244 | (defmethod title-using-kind/name (kind (name symbol) doc) 245 | (declare (ignore kind)) 246 | (format nil "~@[~A:~]~A" (short-package-name (get-package doc)) name)) 247 | 248 | (defmethod title-using-kind/name (kind (name list) doc) 249 | (declare (ignore kind)) 250 | (assert (setf-name-p name)) 251 | (format nil "(setf ~@[~A:~]~A)" (short-package-name (get-package doc)) (second name))) 252 | 253 | (defmethod title-using-kind/name ((kind (eql 'method)) name doc) 254 | (format nil "~{~A ~}~A" 255 | (second name) 256 | (title-using-kind/name nil (first name) doc))) 257 | 258 | (defun title-name (doc) 259 | "Returns a string to be used as name of the definition." 260 | (string-downcase (title-using-kind/name (get-kind doc) (get-name doc) doc))) 261 | 262 | (defun include-pathname (doc) 263 | (let* ((kind (get-kind doc)) 264 | (name (nstring-downcase 265 | (if (eq 'package kind) 266 | (format nil "package-~A" (alphanumize (get-name doc))) 267 | (format nil "~A-~A-~A" 268 | (case (get-kind doc) 269 | ((function generic-function) "fun") 270 | (structure "struct") 271 | (variable "var") 272 | (otherwise (symbol-name (get-kind doc)))) 273 | (alphanumize (let ((*base-package* nil)) 274 | (short-package-name (get-package doc)))) 275 | (alphanumize (get-name doc))))))) 276 | (make-pathname :name name :type "texinfo"))) 277 | 278 | ;;;; documentation class and related methods 279 | 280 | (defclass documentation () 281 | ((name :initarg :name :reader get-name) 282 | (kind :initarg :kind :reader get-kind) 283 | (string :initarg :string :reader get-string) 284 | (children :initarg :children :initform nil :reader get-children) 285 | (package :initform *documentation-package* :reader get-package))) 286 | 287 | (defmethod print-object ((documentation documentation) stream) 288 | (print-unreadable-object (documentation stream :type t) 289 | (princ (list (get-kind documentation) (get-name documentation)) stream))) 290 | 291 | (defgeneric make-documentation (x doc-type string)) 292 | 293 | (defmethod make-documentation ((x package) doc-type string) 294 | (declare (ignore doc-type)) 295 | (make-instance 'documentation 296 | :name (name x) 297 | :kind 'package 298 | :string string)) 299 | 300 | (defmethod make-documentation (x (doc-type (eql 'function)) string) 301 | (declare (ignore doc-type)) 302 | (let* ((fdef (and (fboundp x) (fdefinition x))) 303 | (name x) 304 | (kind (cond ((and (symbolp x) (special-operator-p x)) 305 | 'special-operator) 306 | ((and (symbolp x) (macro-function x)) 307 | 'macro) 308 | ((typep fdef 'generic-function) 309 | (assert (or (symbolp name) (setf-name-p name))) 310 | 'generic-function) 311 | (fdef 312 | (assert (or (symbolp name) (setf-name-p name))) 313 | 'function))) 314 | (children (when (eq kind 'generic-function) 315 | (collect-gf-documentation fdef)))) 316 | (make-instance 'documentation 317 | :name (name x) 318 | :string string 319 | :kind kind 320 | :children children))) 321 | 322 | (defmethod make-documentation ((x method) doc-type string) 323 | (declare (ignore doc-type)) 324 | (make-instance 'documentation 325 | :name (name x) 326 | :kind 'method 327 | :string string)) 328 | 329 | (defmethod make-documentation (x (doc-type (eql 'type)) string) 330 | (make-instance 'documentation 331 | :name (name x) 332 | :string string 333 | :kind (etypecase (find-class x nil) 334 | (structure-class 'structure) 335 | (standard-class 'class) 336 | (sb-pcl::condition-class 'condition) 337 | ((or built-in-class null) 'type)))) 338 | 339 | (defmethod make-documentation (x (doc-type (eql 'variable)) string) 340 | (make-instance 'documentation 341 | :name (name x) 342 | :string string 343 | :kind (if (constantp x) 344 | 'constant 345 | 'variable))) 346 | 347 | (defmethod make-documentation (x (doc-type (eql 'setf)) string) 348 | (declare (ignore doc-type)) 349 | (make-instance 'documentation 350 | :name (name x) 351 | :kind 'setf-expander 352 | :string string)) 353 | 354 | (defmethod make-documentation (x doc-type string) 355 | (make-instance 'documentation 356 | :name (name x) 357 | :kind doc-type 358 | :string string)) 359 | 360 | (defun maybe-documentation (x doc-type) 361 | "Returns a DOCUMENTATION instance for X and DOC-TYPE, or NIL if 362 | there is no corresponding docstring." 363 | (let ((docstring (docstring x doc-type))) 364 | (when docstring 365 | (make-documentation x doc-type docstring)))) 366 | 367 | (defun lambda-list (doc) 368 | (case (get-kind doc) 369 | ((package constant variable type structure class condition nil) 370 | nil) 371 | (method 372 | (third (get-name doc))) 373 | (t 374 | ;; KLUDGE: Eugh. 375 | ;; 376 | ;; believe it or not, the above comment was written before CSR 377 | ;; came along and obfuscated this. (2005-07-04) 378 | (when (symbolp (get-name doc)) 379 | (labels ((clean (x &key optional key) 380 | (typecase x 381 | (atom x) 382 | ((cons (member &optional)) 383 | (cons (car x) (clean (cdr x) :optional t))) 384 | ((cons (member &key)) 385 | (cons (car x) (clean (cdr x) :key t))) 386 | ((cons (member &whole &environment)) 387 | ;; Skip these 388 | (clean (cdr x) :optional optional :key key)) 389 | ((cons (member &aux)) 390 | ;; Drop everything after &AUX. 391 | nil) 392 | ((cons cons) 393 | (cons 394 | (cond (key (if (consp (caar x)) 395 | (caaar x) 396 | (caar x))) 397 | (optional (caar x)) 398 | (t (clean (car x)))) 399 | (clean (cdr x) :key key :optional optional))) 400 | (cons 401 | (cons 402 | (cond ((or key optional) (car x)) 403 | (t (clean (car x)))) 404 | (clean (cdr x) :key key :optional optional)))))) 405 | (clean (sb-introspect:function-lambda-list (get-name doc)))))))) 406 | 407 | (defun get-string-name (x) 408 | (let ((name (get-name x))) 409 | (cond ((symbolp name) 410 | (symbol-name name)) 411 | ((and (consp name) (eq 'setf (car name))) 412 | (symbol-name (second name))) 413 | ((stringp name) 414 | name) 415 | (t 416 | (error "Don't know which symbol to use for name ~S" name))))) 417 | 418 | (defun documentation< (x y) 419 | (let ((p1 (position (get-kind x) *ordered-documentation-kinds*)) 420 | (p2 (position (get-kind y) *ordered-documentation-kinds*))) 421 | (if (or (not (and p1 p2)) (= p1 p2)) 422 | (string< (get-string-name x) (get-string-name y)) 423 | (< p1 p2)))) 424 | 425 | ;;;; turning text into texinfo 426 | 427 | (defun escape-for-texinfo (string &optional downcasep) 428 | "Return STRING with characters in *TEXINFO-ESCAPED-CHARS* escaped 429 | with #\@. Optionally downcase the result." 430 | (let ((result (with-output-to-string (s) 431 | (loop for char across string 432 | when (find char *texinfo-escaped-chars*) 433 | do (write-char #\@ s) 434 | do (write-char char s))))) 435 | (if downcasep (nstring-downcase result) result))) 436 | 437 | (defun empty-p (line-number lines) 438 | (and (< -1 line-number (length lines)) 439 | (not (indentation (svref lines line-number))))) 440 | 441 | ;;; line markups 442 | 443 | (defvar *not-symbols* '("ANSI" "CLHS")) 444 | 445 | (defun locate-symbols (line) 446 | "Return a list of index pairs of symbol-like parts of LINE." 447 | ;; This would be a good application for a regex ... 448 | (let (result) 449 | (flet ((grab (start end) 450 | (unless (member (subseq line start end) '("ANSI" "CLHS")) 451 | (push (list start end) result)))) 452 | (do ((begin nil) 453 | (maybe-begin t) 454 | (i 0 (1+ i))) 455 | ((= i (length line)) 456 | ;; symbol at end of line 457 | (when (and begin (or (> i (1+ begin)) 458 | (not (member (char line begin) '(#\A #\I))))) 459 | (grab begin i)) 460 | (nreverse result)) 461 | (cond 462 | ((and begin (find (char line i) *symbol-delimiters*)) 463 | ;; symbol end; remember it if it's not "A" or "I" 464 | (when (or (> i (1+ begin)) (not (member (char line begin) '(#\A #\I)))) 465 | (grab begin i)) 466 | (setf begin nil 467 | maybe-begin t)) 468 | ((and begin (not (find (char line i) *symbol-characters*))) 469 | ;; Not a symbol: abort 470 | (setf begin nil)) 471 | ((and maybe-begin (not begin) (find (char line i) *symbol-characters*)) 472 | ;; potential symbol begin at this position 473 | (setf begin i 474 | maybe-begin nil)) 475 | ((find (char line i) *symbol-delimiters*) 476 | ;; potential symbol begin after this position 477 | (setf maybe-begin t)) 478 | (t 479 | ;; Not reading a symbol, not at potential start of symbol 480 | (setf maybe-begin nil))))))) 481 | 482 | (defun texinfo-line (line) 483 | "Format symbols in LINE texinfo-style: either as code or as 484 | variables if the symbol in question is contained in symbols 485 | *TEXINFO-VARIABLES*." 486 | (with-output-to-string (result) 487 | (let ((last 0)) 488 | (dolist (symbol/index (locate-symbols line)) 489 | (write-string (subseq line last (first symbol/index)) result) 490 | (let ((symbol-name (apply #'subseq line symbol/index))) 491 | (format result (if (member symbol-name *texinfo-variables* 492 | :test #'string=) 493 | "@var{~A}" 494 | "@code{~A}") 495 | (string-downcase symbol-name))) 496 | (setf last (second symbol/index))) 497 | (write-string (subseq line last) result)))) 498 | 499 | ;;; lisp sections 500 | 501 | (defun lisp-section-p (line line-number lines) 502 | "Returns T if the given LINE looks like start of lisp code -- 503 | ie. if it starts with whitespace followed by a paren or 504 | semicolon, and the previous line is empty" 505 | (let ((offset (indentation line))) 506 | (and offset 507 | (plusp offset) 508 | (find (find-if-not #'whitespacep line) "(;") 509 | (empty-p (1- line-number) lines)))) 510 | 511 | (defun collect-lisp-section (lines line-number) 512 | (let ((lisp (loop for index = line-number then (1+ index) 513 | for line = (and (< index (length lines)) (svref lines index)) 514 | while (indentation line) 515 | collect line))) 516 | (values (length lisp) `("@lisp" ,@lisp "@end lisp")))) 517 | 518 | ;;; itemized sections 519 | 520 | (defun maybe-itemize-offset (line) 521 | "Return NIL or the indentation offset if LINE looks like it starts 522 | an item in an itemization." 523 | (let* ((offset (indentation line)) 524 | (char (when offset (char line offset)))) 525 | (and offset 526 | (member char *itemize-start-characters* :test #'char=) 527 | (char= #\Space (find-if-not (lambda (c) (char= c char)) 528 | line :start offset)) 529 | offset))) 530 | 531 | (defun collect-maybe-itemized-section (lines starting-line) 532 | ;; Return index of next line to be processed outside 533 | (let ((this-offset (maybe-itemize-offset (svref lines starting-line))) 534 | (result nil) 535 | (lines-consumed 0)) 536 | (loop for line-number from starting-line below (length lines) 537 | for line = (svref lines line-number) 538 | for indentation = (indentation line) 539 | for offset = (maybe-itemize-offset line) 540 | do (cond 541 | ((not indentation) 542 | ;; empty line -- inserts paragraph. 543 | (push "" result) 544 | (incf lines-consumed)) 545 | ((and offset (> indentation this-offset)) 546 | ;; nested itemization -- handle recursively 547 | ;; FIXME: tables in itemizations go wrong 548 | (multiple-value-bind (sub-lines-consumed sub-itemization) 549 | (collect-maybe-itemized-section lines line-number) 550 | (when sub-lines-consumed 551 | (incf line-number (1- sub-lines-consumed)) ; +1 on next loop 552 | (incf lines-consumed sub-lines-consumed) 553 | (setf result (nconc (nreverse sub-itemization) result))))) 554 | ((and offset (= indentation this-offset)) 555 | ;; start of new item 556 | (push (format nil "@item ~A" 557 | (texinfo-line (subseq line (1+ offset)))) 558 | result) 559 | (incf lines-consumed)) 560 | ((and (not offset) (> indentation this-offset)) 561 | ;; continued item from previous line 562 | (push (texinfo-line line) result) 563 | (incf lines-consumed)) 564 | (t 565 | ;; end of itemization 566 | (loop-finish)))) 567 | ;; a single-line itemization isn't. 568 | (if (> (count-if (lambda (line) (> (length line) 0)) result) 1) 569 | (values lines-consumed `("@itemize" ,@(reverse result) "@end itemize")) 570 | nil))) 571 | 572 | ;;; table sections 573 | 574 | (defun tabulation-body-p (offset line-number lines) 575 | (when (< line-number (length lines)) 576 | (let ((offset2 (indentation (svref lines line-number)))) 577 | (and offset2 (< offset offset2))))) 578 | 579 | (defun tabulation-p (offset line-number lines direction) 580 | (let ((step (ecase direction 581 | (:backwards (1- line-number)) 582 | (:forwards (1+ line-number))))) 583 | (when (and (plusp line-number) (< line-number (length lines))) 584 | (and (eql offset (indentation (svref lines line-number))) 585 | (or (when (eq direction :backwards) 586 | (empty-p step lines)) 587 | (tabulation-p offset step lines direction) 588 | (tabulation-body-p offset step lines)))))) 589 | 590 | (defun maybe-table-offset (line-number lines) 591 | "Return NIL or the indentation offset if LINE looks like it starts 592 | an item in a tabulation. Ie, if it is (1) indented, (2) preceded by an 593 | empty line, another tabulation label, or a tabulation body, (3) and 594 | followed another tabulation label or a tabulation body." 595 | (let* ((line (svref lines line-number)) 596 | (offset (indentation line)) 597 | (prev (1- line-number)) 598 | (next (1+ line-number))) 599 | (when (and offset (plusp offset)) 600 | (and (or (empty-p prev lines) 601 | (tabulation-body-p offset prev lines) 602 | (tabulation-p offset prev lines :backwards)) 603 | (or (tabulation-body-p offset next lines) 604 | (tabulation-p offset next lines :forwards)) 605 | offset)))) 606 | 607 | ;;; FIXME: This and itemization are very similar: could they share 608 | ;;; some code, mayhap? 609 | 610 | (defun collect-maybe-table-section (lines starting-line) 611 | ;; Return index of next line to be processed outside 612 | (let ((this-offset (maybe-table-offset starting-line lines)) 613 | (result nil) 614 | (lines-consumed 0)) 615 | (loop for line-number from starting-line below (length lines) 616 | for line = (svref lines line-number) 617 | for indentation = (indentation line) 618 | for offset = (maybe-table-offset line-number lines) 619 | do (cond 620 | ((not indentation) 621 | ;; empty line -- inserts paragraph. 622 | (push "" result) 623 | (incf lines-consumed)) 624 | ((and offset (= indentation this-offset)) 625 | ;; start of new item, or continuation of previous item 626 | (if (and result (search "@item" (car result) :test #'char=)) 627 | (push (format nil "@itemx ~A" (texinfo-line line)) 628 | result) 629 | (progn 630 | (push "" result) 631 | (push (format nil "@item ~A" (texinfo-line line)) 632 | result))) 633 | (incf lines-consumed)) 634 | ((> indentation this-offset) 635 | ;; continued item from previous line 636 | (push (texinfo-line line) result) 637 | (incf lines-consumed)) 638 | (t 639 | ;; end of itemization 640 | (loop-finish)))) 641 | ;; a single-line table isn't. 642 | (if (> (count-if (lambda (line) (> (length line) 0)) result) 1) 643 | (values lines-consumed 644 | `("" "@table @emph" ,@(reverse result) "@end table" "")) 645 | nil))) 646 | 647 | ;;; section markup 648 | 649 | (defmacro with-maybe-section (index &rest forms) 650 | `(multiple-value-bind (count collected) (progn ,@forms) 651 | (when count 652 | (dolist (line collected) 653 | (write-line line *texinfo-output*)) 654 | (incf ,index (1- count))))) 655 | 656 | (defun write-texinfo-string (string &optional lambda-list) 657 | "Try to guess as much formatting for a raw docstring as possible." 658 | (let ((*texinfo-variables* (flatten lambda-list)) 659 | (lines (string-lines (escape-for-texinfo string nil)))) 660 | (loop for line-number from 0 below (length lines) 661 | for line = (svref lines line-number) 662 | do (cond 663 | ((with-maybe-section line-number 664 | (and (lisp-section-p line line-number lines) 665 | (collect-lisp-section lines line-number)))) 666 | ((with-maybe-section line-number 667 | (and (maybe-itemize-offset line) 668 | (collect-maybe-itemized-section lines line-number)))) 669 | ((with-maybe-section line-number 670 | (and (maybe-table-offset line-number lines) 671 | (collect-maybe-table-section lines line-number)))) 672 | (t 673 | (write-line (texinfo-line line) *texinfo-output*)))))) 674 | 675 | ;;;; texinfo formatting tools 676 | 677 | (defun hide-superclass-p (class-name super-name) 678 | (let ((super-package (symbol-package super-name))) 679 | (or 680 | ;; KLUDGE: We assume that we don't want to advertise internal 681 | ;; classes in CP-lists, unless the symbol we're documenting is 682 | ;; internal as well. 683 | (and (member super-package #.'(mapcar #'find-package *undocumented-packages*)) 684 | (not (eq super-package (symbol-package class-name)))) 685 | ;; KLUDGE: We don't generally want to advertise SIMPLE-ERROR or 686 | ;; SIMPLE-CONDITION in the CPLs of conditions that inherit them 687 | ;; simply as a matter of convenience. The assumption here is that 688 | ;; the inheritance is incidental unless the name of the condition 689 | ;; begins with SIMPLE-. 690 | (and (member super-name '(simple-error simple-condition)) 691 | (let ((prefix "SIMPLE-")) 692 | (mismatch prefix (string class-name) :end2 (length prefix))) 693 | t ; don't return number from MISMATCH 694 | )))) 695 | 696 | (defun hide-slot-p (symbol slot) 697 | ;; FIXME: There is no pricipal reason to avoid the slot docs fo 698 | ;; structures and conditions, but their DOCUMENTATION T doesn't 699 | ;; currently work with them the way we'd like. 700 | (not (and (typep (find-class symbol nil) 'standard-class) 701 | (docstring slot t)))) 702 | 703 | (defun texinfo-anchor (doc) 704 | (format *texinfo-output* "@anchor{~A}~%" (node-name doc))) 705 | 706 | ;;; KLUDGE: &AUX *PRINT-PRETTY* here means "no linebreaks please" 707 | (defun texinfo-begin (doc &aux *print-pretty*) 708 | (let ((kind (get-kind doc))) 709 | (format *texinfo-output* "@~A {~:(~A~)} ~({~A}~@[ ~{~A~^ ~}~]~)~%" 710 | (case kind 711 | ((package constant variable) 712 | "defvr") 713 | ((structure class condition type) 714 | "deftp") 715 | (t 716 | "deffn")) 717 | (map 'string (lambda (char) (if (eql char #\-) #\Space char)) (string kind)) 718 | (title-name doc) 719 | ;; &foo would be amusingly bold in the pdf thanks to TeX/Texinfo 720 | ;; interactions,so we escape the ampersand -- amusingly for TeX. 721 | ;; sbcl.texinfo defines macros that expand @&key and friends to &key. 722 | (mapcar (lambda (name) 723 | (if (member name lambda-list-keywords) 724 | (format nil "@~A" name) 725 | name)) 726 | (lambda-list doc))))) 727 | 728 | (defun texinfo-index (doc) 729 | (let ((title (title-name doc))) 730 | (case (get-kind doc) 731 | ((structure type class condition) 732 | (format *texinfo-output* "@tindex ~A~%" title)) 733 | ((variable constant) 734 | (format *texinfo-output* "@vindex ~A~%" title)) 735 | ((compiler-macro function method-combination macro generic-function) 736 | (format *texinfo-output* "@findex ~A~%" title))))) 737 | 738 | (defun texinfo-inferred-body (doc) 739 | (when (member (get-kind doc) '(class structure condition)) 740 | (let ((name (get-name doc))) 741 | ;; class precedence list 742 | (format *texinfo-output* "Class precedence list: @code{~(~{~(~A~)~^, ~}~)}~%~%" 743 | (remove-if (lambda (class) (hide-superclass-p name class)) 744 | (mapcar #'class-name (ensure-class-precedence-list (find-class name))))) 745 | ;; slots 746 | (let ((slots (remove-if (lambda (slot) (hide-slot-p name slot)) 747 | (class-direct-slots (find-class name))))) 748 | (when slots 749 | (format *texinfo-output* "Slots:~%@itemize~%") 750 | (dolist (slot slots) 751 | (format *texinfo-output* 752 | "@item ~(@code{~A}~#[~:; --- ~]~ 753 | ~:{~2*~@[~2:*~A~P: ~{@code{@w{~S}}~^, ~}~]~:^; ~}~)~%~%" 754 | (slot-definition-name slot) 755 | (remove 756 | nil 757 | (mapcar 758 | (lambda (name things) 759 | (if things 760 | (list name (length things) things))) 761 | '("initarg" "reader" "writer") 762 | (list 763 | (slot-definition-initargs slot) 764 | (slot-definition-readers slot) 765 | (slot-definition-writers slot))))) 766 | ;; FIXME: Would be neater to handler as children 767 | (write-texinfo-string (docstring slot t))) 768 | (format *texinfo-output* "@end itemize~%~%")))))) 769 | 770 | (defun texinfo-body (doc) 771 | (write-texinfo-string (get-string doc))) 772 | 773 | (defun texinfo-end (doc) 774 | (write-line (case (get-kind doc) 775 | ((package variable constant) "@end defvr") 776 | ((structure type class condition) "@end deftp") 777 | (t "@end deffn")) 778 | *texinfo-output*)) 779 | 780 | (defun write-texinfo (doc) 781 | "Writes TexInfo for a DOCUMENTATION instance to *TEXINFO-OUTPUT*." 782 | (texinfo-anchor doc) 783 | (texinfo-begin doc) 784 | (texinfo-index doc) 785 | (texinfo-inferred-body doc) 786 | (texinfo-body doc) 787 | (texinfo-end doc) 788 | ;; FIXME: Children should be sorted one way or another 789 | (mapc #'write-texinfo (get-children doc))) 790 | 791 | ;;;; main logic 792 | 793 | (defun collect-gf-documentation (gf) 794 | "Collects method documentation for the generic function GF" 795 | (loop for method in (generic-function-methods gf) 796 | for doc = (maybe-documentation method t) 797 | when doc 798 | collect doc)) 799 | 800 | (defun collect-name-documentation (name) 801 | (loop for type in *documentation-types* 802 | for doc = (maybe-documentation name type) 803 | when doc 804 | collect doc)) 805 | 806 | (defun collect-symbol-documentation (symbol) 807 | "Collects all docs for a SYMBOL and (SETF SYMBOL), returns a list of 808 | the form DOC instances. See `*documentation-types*' for the possible 809 | values of doc-type." 810 | (nconc (collect-name-documentation symbol) 811 | (collect-name-documentation (list 'setf symbol)))) 812 | 813 | (defun collect-documentation (package) 814 | "Collects all documentation for all external symbols of the given 815 | package, as well as for the package itself." 816 | (let* ((*documentation-package* (find-package package)) 817 | (docs nil)) 818 | (check-type package package) 819 | (do-external-symbols (symbol package) 820 | (setf docs (nconc (collect-symbol-documentation symbol) docs))) 821 | (let ((doc (maybe-documentation *documentation-package* t))) 822 | (when doc 823 | (push doc docs))) 824 | docs)) 825 | 826 | (defmacro with-texinfo-file (pathname &body forms) 827 | `(with-open-file (*texinfo-output* ,pathname 828 | :direction :output 829 | :if-does-not-exist :create 830 | :if-exists :supersede) 831 | ,@forms)) 832 | 833 | (defun write-ifnottex () 834 | ;; We use @&key, etc to escape & from TeX in lambda lists -- so we need to 835 | ;; define them for info as well. 836 | (flet ((macro (name) 837 | (let ((string (string-downcase name))) 838 | (format *texinfo-output* "@macro ~A~%~A~%@end macro~%" string string)))) 839 | (macro '&allow-other-keys) 840 | (macro '&optional) 841 | (macro '&rest) 842 | (macro '&key) 843 | (macro '&body))) 844 | 845 | (defun generate-includes (directory packages &key (base-package :cl-user)) 846 | "Create files in `directory' containing Texinfo markup of all 847 | docstrings of each exported symbol in `packages'. `directory' is 848 | created if necessary. If you supply a namestring that doesn't end in a 849 | slash, you lose. The generated files are of the form 850 | \"__.texinfo\" and can be included 851 | via @include statements. Texinfo syntax-significant characters are 852 | escaped in symbol names, but if a docstring contains invalid Texinfo 853 | markup, you lose." 854 | (handler-bind ((warning #'muffle-warning)) 855 | (let ((directory (merge-pathnames (pathname directory))) 856 | (*base-package* (find-package base-package))) 857 | (ensure-directories-exist directory) 858 | (dolist (package packages) 859 | (dolist (doc (collect-documentation (find-package package))) 860 | (with-texinfo-file (merge-pathnames (include-pathname doc) directory) 861 | (write-texinfo doc)))) 862 | (with-texinfo-file (merge-pathnames "ifnottex.texinfo" directory) 863 | (write-ifnottex)) 864 | directory))) 865 | 866 | (defun document-package (package &optional filename) 867 | "Create a file containing all available documentation for the 868 | exported symbols of `package' in Texinfo format. If `filename' is not 869 | supplied, a file \".texinfo\" is generated. 870 | 871 | The definitions can be referenced using Texinfo statements like 872 | @ref{__.texinfo}. Texinfo 873 | syntax-significant characters are escaped in symbol names, but if a 874 | docstring contains invalid Texinfo markup, you lose." 875 | (handler-bind ((warning #'muffle-warning)) 876 | (let* ((package (find-package package)) 877 | (filename (or filename (make-pathname 878 | :name (string-downcase (short-package-name package)) 879 | :type "texinfo"))) 880 | (docs (sort (collect-documentation package) #'documentation<))) 881 | (with-texinfo-file filename 882 | (dolist (doc docs) 883 | (write-texinfo doc))) 884 | filename))) 885 | --------------------------------------------------------------------------------