Mercurial > hg > xemacs-beta
annotate lisp/apropos.el @ 5602:c9e5612f5424
Support the MP library on recent FreeBSD, have it pass relevant tests.
src/ChangeLog addition:
2011-11-26 Aidan Kehoe <kehoea@parhasard.net>
* number-mp.c (bignum_to_string):
Don't overwrite the accumulator we've just set up for this
function.
* number-mp.c (BIGNUM_TO_TYPE):
mp_itom() doesn't necessarily do what this code used to think with
negative numbers, it can treat them as unsigned ints. Subtract
numbers from bignum_zero instead of multiplying them by -1 to
convert them to their negative equivalents.
* number-mp.c (bignum_to_int):
* number-mp.c (bignum_to_uint):
* number-mp.c (bignum_to_long):
* number-mp.c (bignum_to_ulong):
* number-mp.c (bignum_to_double):
Use the changed BIGNUM_TO_TYPE() in these functions.
* number-mp.c (bignum_ceil):
* number-mp.c (bignum_floor):
In these functions, be more careful about rounding to positive and
negative infinity, respectively. Don't use the sign of QUOTIENT
when working out out whether to add or subtract one, rather use
the sign QUOTIENT would have if arbitrary-precision division were
done.
* number-mp.h:
* number-mp.h (MP_GCD):
Wrap #include <mp.h> in BEGIN_C_DECLS/END_C_DECLS.
* number.c (Fbigfloat_get_precision):
* number.c (Fbigfloat_set_precision):
Don't attempt to call XBIGFLOAT_GET_PREC if this build doesn't
support big floats.
| author | Aidan Kehoe <kehoea@parhasard.net> |
|---|---|
| date | Sat, 26 Nov 2011 17:59:14 +0000 |
| parents | 308d34e9f07d |
| children | bbe4146603db |
| rev | line source |
|---|---|
| 428 | 1 ;;; apropos.el --- apropos commands for users and programmers. |
| 2 | |
| 3 ;; Copyright (C) 1989, 1994, 1995 Free Software Foundation, Inc. | |
| 4 | |
| 5 ;; Author: Joe Wells <jbw@bigbird.bu.edu> | |
| 6 ;; Rewritten: Daniel.Pfeiffer@Informatik.START.dbp.de, fax (+49 69) 7588-2389 | |
| 7 ;; Maintainer: SL Baur <steve@xemacs.org> | |
| 8 ;; Keywords: help | |
| 9 | |
| 10 ;; This file is part of XEmacs. | |
| 11 | |
|
5402
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
5182
diff
changeset
|
12 ;; XEmacs is free software: you can redistribute it and/or modify it |
|
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
5182
diff
changeset
|
13 ;; under the terms of the GNU General Public License as published by the |
|
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
5182
diff
changeset
|
14 ;; Free Software Foundation, either version 3 of the License, or (at your |
|
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
5182
diff
changeset
|
15 ;; option) any later version. |
| 428 | 16 |
|
5402
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
5182
diff
changeset
|
17 ;; XEmacs is distributed in the hope that it will be useful, but WITHOUT |
|
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
5182
diff
changeset
|
18 ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or |
|
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
5182
diff
changeset
|
19 ;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License |
|
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
5182
diff
changeset
|
20 ;; for more details. |
| 428 | 21 |
| 22 ;; You should have received a copy of the GNU General Public License | |
|
5402
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
5182
diff
changeset
|
23 ;; along with XEmacs. If not, see <http://www.gnu.org/licenses/>. |
| 428 | 24 |
| 25 ;;; Synched up with: Last synched with FSF 19.34, diverged since. | |
| 26 | |
| 27 ;;; Commentary: | |
| 28 | |
| 29 ;; The ideas for this package were derived from the C code in | |
| 30 ;; src/keymap.c and elsewhere. The functions in this file should | |
| 31 ;; always be byte-compiled for speed. Someone should rewrite this in | |
| 32 ;; C (as part of src/keymap.c) for speed. | |
| 33 | |
| 34 ;; The idea for super-apropos is based on the original implementation | |
| 35 ;; by Lynn Slater <lrs@esl.com>. | |
| 36 | |
| 37 ;;; ChangeLog: | |
| 38 | |
| 39 ;; Fixed bug, current-local-map can return nil. | |
| 40 ;; Change, doesn't calculate key-bindings unless needed. | |
| 41 ;; Added super-apropos capability, changed print functions. | |
| 42 ;;; Made fast-apropos and super-apropos share code. | |
| 43 ;;; Sped up fast-apropos again. | |
| 44 ;; Added apropos-do-all option. | |
| 45 ;;; Added fast-command-apropos. | |
| 46 ;; Changed doc strings to comments for helping functions. | |
| 47 ;;; Made doc file buffer read-only, buried it. | |
| 48 ;; Only call substitute-command-keys if do-all set. | |
| 49 | |
| 50 ;; Optionally use configurable faces to make the output more legible. | |
| 51 ;; Differentiate between command, function and macro. | |
| 52 ;; Apropos-command (ex command-apropos) does cmd and optionally user var. | |
| 53 ;; Apropos shows all 3 aspects of symbols (fn, var and plist) | |
| 54 ;; Apropos-documentation (ex super-apropos) now finds all it should. | |
| 55 ;; New apropos-value snoops through all values and optionally plists. | |
| 56 ;; Reading DOC file doesn't load nroff. | |
| 57 ;; Added hypertext following of documentation, mouse-2 on variable gives value | |
| 58 ;; from buffer in active window. | |
| 59 | |
| 60 ;;; Code: | |
| 61 | |
| 62 ;; I see a degradation of maybe 10-20% only. | |
| 63 ;; [sb -- FSF protects the face declarations with `if window-system' | |
| 64 ;; I see no reason why we should do so] | |
| 65 (defvar apropos-do-all nil | |
| 66 "*Whether the apropos commands should do more. | |
| 67 Slows them down more or less. Set this non-nil if you have a fast machine.") | |
| 68 | |
| 69 ;; XEmacs addition | |
| 502 | 70 (defvar apropos-symbol-face (if-boundp 'font-lock-keyword-face |
| 428 | 71 font-lock-keyword-face |
| 72 'bold) | |
| 73 "*Face for symbol name in apropos output or `nil'. | |
| 74 This looks good, but slows down the commands several times.") | |
| 75 | |
| 76 ;; XEmacs addition | |
| 502 | 77 (defvar apropos-keybinding-face (if-boundp 'font-lock-string-face |
| 428 | 78 font-lock-string-face |
| 79 'underline) | |
| 80 "*Face for keybinding display in apropos output or `nil'. | |
| 81 This looks good, but slows down the commands several times.") | |
| 82 | |
| 83 ;; XEmacs addition | |
| 502 | 84 (defvar apropos-label-face (if-boundp 'font-lock-comment-face |
| 428 | 85 font-lock-comment-face |
| 86 'italic) | |
| 87 "*Face for label (Command, Variable ...) in apropos output or `nil'. | |
| 88 If this is `nil' no mouse highlighting occurs. | |
| 89 This looks good, but slows down the commands several times. | |
| 90 When this is a face name, as it is initially, it gets transformed to a | |
| 91 text-property list for efficiency.") | |
| 92 | |
| 93 ;; XEmacs addition | |
| 502 | 94 (defvar apropos-property-face (if-boundp 'font-lock-variable-name-face |
| 428 | 95 font-lock-variable-name-face |
| 96 'bold-italic) | |
| 97 "*Face for property name in apropos output or `nil'. | |
| 98 This looks good, but slows down the commands several times.") | |
| 99 | |
| 100 (defvar apropos-match-face 'secondary-selection | |
| 101 "*Face for matching part in apropos-documentation/value output or `nil'. | |
| 102 This looks good, but slows down the commands several times.") | |
| 103 | |
| 104 | |
| 105 (defvar apropos-mode-map | |
| 106 (let ((map (make-sparse-keymap))) | |
| 107 (define-key map [(control m)] 'apropos-follow) | |
| 430 | 108 (define-key map [return] 'apropos-follow) |
| 428 | 109 (define-key map [(button2up)] 'apropos-mouse-follow) |
| 110 (define-key map [(button2)] 'undefined) | |
| 111 map) | |
| 112 "Keymap used in Apropos mode.") | |
| 113 | |
| 114 | |
| 115 (defvar apropos-regexp nil | |
| 116 "Regexp used in current apropos run.") | |
| 117 | |
| 118 (defvar apropos-files-scanned () | |
| 119 "List of elc files already scanned in current run of `apropos-documentation'.") | |
| 120 | |
| 121 (defvar apropos-accumulator () | |
| 122 "Alist of symbols already found in current apropos run.") | |
| 123 | |
| 124 (defvar apropos-item () | |
| 125 "Current item in or for apropos-accumulator.") | |
| 126 | |
| 127 (defvar apropos-mode-hook nil) ; XEmacs | |
| 128 | |
| 129 (defun apropos-mode () | |
| 130 "Major mode for following hyperlinks in output of apropos commands. | |
| 131 | |
| 132 \\{apropos-mode-map}" | |
| 133 (interactive) | |
| 134 (kill-all-local-variables) | |
| 135 (use-local-map apropos-mode-map) | |
| 136 (setq major-mode 'apropos-mode | |
| 137 mode-name "Apropos") | |
| 138 (run-hooks 'apropos-mode-hook)) ; XEmacs | |
| 139 | |
| 140 | |
| 141 ;; For auld lang syne: | |
| 142 ;;;###autoload | |
| 143 (fset 'command-apropos 'apropos-command) | |
| 144 | |
| 145 ;;;###autoload | |
| 146 (defun apropos-command (apropos-regexp &optional do-all) | |
| 147 "Shows commands (interactively callable functions) that match REGEXP. | |
| 148 With optional prefix ARG or if `apropos-do-all' is non-nil, also show | |
| 149 variables." | |
| 150 ;; XEmacs: All code related to special treatment of buffer has been removed | |
| 151 (interactive (list (read-string (concat "Apropos command " | |
| 152 (if (or current-prefix-arg | |
| 153 apropos-do-all) | |
| 154 "or variable ") | |
| 155 "(regexp): ")) | |
| 156 current-prefix-arg)) | |
| 157 (or do-all (setq do-all apropos-do-all)) | |
| 158 (setq apropos-accumulator | |
| 159 (apropos-internal apropos-regexp | |
| 160 (if do-all | |
| 161 (lambda (symbol) (or (commandp symbol) | |
| 162 (user-variable-p symbol))) | |
| 163 'commandp))) | |
| 164 (apropos-print | |
| 165 t | |
| 166 (lambda (p) | |
| 167 (let (doc symbol) | |
| 168 (while p | |
| 169 (setcar p (list | |
| 170 (setq symbol (car p)) | |
| 171 (if (commandp symbol) | |
| 172 (if (setq doc | |
| 173 ;; XEmacs change: if obsolete, | |
| 174 ;; only mention that. | |
| 175 (or (function-obsoleteness-doc symbol) | |
| 2275 | 176 (condition-case nil |
| 177 (documentation symbol t) | |
| 178 (void-function "(aliased to undefined function)") | |
| 179 (error "(unexpected error from `documention')")))) | |
| 428 | 180 (substring doc 0 (string-match "\n" doc)) |
| 181 "(not documented)")) | |
| 182 (and do-all | |
| 183 (user-variable-p symbol) | |
| 184 (if (setq doc | |
| 185 (or | |
| 186 ;; XEmacs change: if obsolete, | |
| 187 ;; only mention that. | |
| 188 (variable-obsoleteness-doc symbol) | |
| 189 (documentation-property | |
| 190 symbol 'variable-documentation t))) | |
| 191 (substring doc 0 | |
| 192 (string-match "\n" doc)))))) | |
| 193 (setq p (cdr p))))) | |
| 194 nil)) | |
| 195 | |
| 196 | |
| 197 ;;;###autoload | |
| 198 (defun apropos (apropos-regexp &optional do-all) | |
| 199 "Show all bound symbols whose names match REGEXP. | |
| 200 With optional prefix ARG or if `apropos-do-all' is non-nil, also show unbound | |
| 201 symbols and key bindings, which is a little more time-consuming. | |
| 202 Returns list of symbols and documentation found." | |
| 203 (interactive "sApropos symbol (regexp): \nP") | |
| 204 ;; XEmacs change: hitting ENTER by mistake is a common mess-up and | |
| 205 ;; shouldn't make Emacs hang for a long time trying to list all symbols. | |
| 206 (or (> (length apropos-regexp) 0) | |
| 207 (error "Must pass non-empty regexp to `apropos'")) | |
| 208 (setq apropos-accumulator | |
| 209 (apropos-internal apropos-regexp | |
| 210 (and (not do-all) | |
| 211 (not apropos-do-all) | |
| 212 (lambda (symbol) | |
| 213 (or (fboundp symbol) | |
| 214 (boundp symbol) | |
| 215 (find-face symbol) | |
| 216 (symbol-plist symbol)))))) | |
| 217 (apropos-print | |
| 218 (or do-all apropos-do-all) | |
| 219 (lambda (p) | |
| 220 (let (symbol doc) | |
| 221 (while p | |
| 222 (setcar p (list | |
| 223 (setq symbol (car p)) | |
| 224 (if (fboundp symbol) | |
| 225 (if (setq doc | |
| 226 ;; XEmacs change: if obsolete, | |
| 227 ;; only mention that. | |
| 228 (or (function-obsoleteness-doc symbol) | |
| 2275 | 229 (condition-case nil |
| 230 (documentation symbol t) | |
| 231 (void-function "(aliased to undefined function)") | |
| 232 (error "(unexpected error from `documention')")))) | |
| 428 | 233 (substring doc 0 (string-match "\n" doc)) |
| 234 "(not documented)")) | |
| 235 (if (boundp symbol) | |
| 236 (if (setq doc | |
| 237 (or | |
| 238 ;; XEmacs change: if obsolete, | |
| 239 ;; only mention that. | |
| 240 (variable-obsoleteness-doc symbol) | |
| 241 (documentation-property | |
| 242 symbol 'variable-documentation t))) | |
| 243 (substring doc 0 | |
| 244 (string-match "\n" doc)) | |
| 245 "(not documented)")) | |
| 246 (if (setq doc (symbol-plist symbol)) | |
| 247 (if (eq (/ (length doc) 2) 1) | |
| 248 (format "1 property (%s)" (car doc)) | |
| 249 (format "%d properties" (/ (length doc) 2)))) | |
| 250 (if (get symbol 'widget-type) | |
| 251 (if (setq doc (documentation-property | |
| 252 symbol 'widget-documentation t)) | |
| 253 (substring doc 0 | |
| 254 (string-match "\n" doc)) | |
| 255 "(not documented)")) | |
| 256 (if (find-face symbol) | |
| 257 (if (setq doc (face-doc-string symbol)) | |
| 258 (substring doc 0 | |
| 259 (string-match "\n" doc)) | |
| 260 "(not documented)")) | |
| 261 (when (get symbol 'custom-group) | |
| 262 (if (setq doc (documentation-property | |
| 263 symbol 'group-documentation t)) | |
| 264 (substring doc 0 | |
| 265 (string-match "\n" doc)) | |
| 266 "(not documented)")))) | |
| 267 (setq p (cdr p))))) | |
| 268 nil)) | |
| 269 | |
| 270 | |
| 271 ;;;###autoload | |
| 272 (defun apropos-value (apropos-regexp &optional do-all) | |
| 273 "Show all symbols whose value's printed image matches REGEXP. | |
| 274 With optional prefix ARG or if `apropos-do-all' is non-nil, also looks | |
| 275 at the function and at the names and values of properties. | |
| 276 Returns list of symbols and values found." | |
| 277 (interactive "sApropos value (regexp): \nP") | |
| 278 (or do-all (setq do-all apropos-do-all)) | |
| 279 (setq apropos-accumulator ()) | |
| 280 (let (f v p) | |
| 281 (mapatoms | |
| 282 (lambda (symbol) | |
| 283 (setq f nil v nil p nil) | |
| 284 (or (memq symbol '(apropos-regexp do-all apropos-accumulator | |
| 285 symbol f v p)) | |
| 286 (setq v (apropos-value-internal 'boundp symbol 'symbol-value))) | |
| 287 (if do-all | |
| 288 (setq f (apropos-value-internal 'fboundp symbol 'symbol-function) | |
| 289 p (apropos-format-plist symbol "\n " t))) | |
| 290 (if (or f v p) | |
| 291 (setq apropos-accumulator (cons (list symbol f v p) | |
| 292 apropos-accumulator)))))) | |
| 293 (apropos-print nil nil t)) | |
| 294 | |
| 295 | |
| 296 ;;;###autoload | |
| 297 (defun apropos-documentation (apropos-regexp &optional do-all) | |
| 298 "Show symbols whose documentation contain matches for REGEXP. | |
| 299 With optional prefix ARG or if `apropos-do-all' is non-nil, also use | |
| 300 documentation that is not stored in the documentation file and show key | |
| 301 bindings. | |
| 302 Returns list of symbols and documentation found." | |
| 303 (interactive "sApropos documentation (regexp): \nP") | |
| 304 (or do-all (setq do-all apropos-do-all)) | |
| 305 (setq apropos-accumulator () apropos-files-scanned ()) | |
| 306 (let ((standard-input (get-buffer-create " apropos-temp")) | |
| 307 f v) | |
| 308 (unwind-protect | |
| 309 (save-excursion | |
| 310 (set-buffer standard-input) | |
| 311 (apropos-documentation-check-doc-file) | |
| 312 (if do-all | |
| 313 (mapatoms | |
| 314 (lambda (symbol) | |
| 315 (setq f (apropos-safe-documentation symbol) | |
| 316 v (get symbol 'variable-documentation)) | |
| 317 (when (integerp v) (setq v nil)) | |
| 318 (setq f (apropos-documentation-internal f) | |
| 319 v (apropos-documentation-internal v)) | |
| 320 (if (or f v) | |
| 321 (if (setq apropos-item | |
| 322 (cdr (assq symbol apropos-accumulator))) | |
| 323 (progn | |
| 324 (if f | |
| 325 (setcar apropos-item f)) | |
| 326 (if v | |
| 327 (setcar (cdr apropos-item) v))) | |
| 328 (setq apropos-accumulator | |
| 329 (cons (list symbol f v) | |
| 330 apropos-accumulator))))))) | |
| 331 (apropos-print nil nil t)) | |
| 332 (kill-buffer standard-input)))) | |
| 333 | |
| 334 | |
| 335 (defun apropos-value-internal (predicate symbol function) | |
| 336 (if (funcall predicate symbol) | |
| 337 (progn | |
| 338 (setq symbol (prin1-to-string (funcall function symbol))) | |
| 339 (if (string-match apropos-regexp symbol) | |
| 340 (progn | |
| 341 (if apropos-match-face | |
| 342 (put-text-property (match-beginning 0) (match-end 0) | |
| 343 'face apropos-match-face | |
| 344 symbol)) | |
| 345 symbol))))) | |
| 346 | |
| 347 (defun apropos-documentation-internal (doc) | |
| 348 (if (consp doc) | |
| 349 (apropos-documentation-check-elc-file (car doc)) | |
| 350 (and doc | |
| 351 (string-match apropos-regexp doc) | |
| 352 (progn | |
| 353 (if apropos-match-face | |
| 354 (put-text-property (match-beginning 0) | |
| 355 (match-end 0) | |
| 356 'face apropos-match-face | |
| 357 (setq doc (copy-sequence doc)))) | |
| 358 doc)))) | |
| 359 | |
| 360 (defun apropos-format-plist (pl sep &optional compare) | |
| 361 (setq pl (symbol-plist pl)) | |
| 362 (let (p p-out) | |
| 363 (while pl | |
| 364 (setq p (format "%s %S" (car pl) (nth 1 pl))) | |
| 365 (if (or (not compare) (string-match apropos-regexp p)) | |
| 366 (if apropos-property-face | |
| 367 (put-text-property 0 (length (symbol-name (car pl))) | |
| 368 'face apropos-property-face p)) | |
| 369 (setq p nil)) | |
| 370 (if p | |
| 371 (progn | |
| 372 (and compare apropos-match-face | |
| 373 (put-text-property (match-beginning 0) (match-end 0) | |
| 374 'face apropos-match-face | |
| 375 p)) | |
| 376 (setq p-out (concat p-out (if p-out sep) p)))) | |
| 377 (setq pl (nthcdr 2 pl))) | |
| 378 p-out)) | |
| 379 | |
| 380 | |
| 381 ;; Finds all documentation related to APROPOS-REGEXP in internal-doc-file-name. | |
| 382 | |
| 383 (defun apropos-documentation-check-doc-file () | |
| 444 | 384 (let (type symbol (sepa 2) sepb start end doc) |
| 428 | 385 (insert ?\^_) |
| 386 (backward-char) | |
| 387 (insert-file-contents (concat doc-directory internal-doc-file-name)) | |
| 388 (forward-char) | |
| 389 (while (save-excursion | |
| 390 (setq sepb (search-forward "\^_")) | |
| 391 (not (eobp))) | |
| 392 (beginning-of-line 2) | |
| 393 (if (save-restriction | |
| 394 (narrow-to-region (point) (1- sepb)) | |
| 395 (re-search-forward apropos-regexp nil t)) | |
| 396 (progn | |
| 444 | 397 (setq start (match-beginning 0) |
| 428 | 398 end (point)) |
| 399 (goto-char (1+ sepa)) | |
| 400 (or (setq type (if (eq ?F (preceding-char)) | |
| 401 1 ; function documentation | |
| 402 2) ; variable documentation | |
| 403 symbol (read) | |
| 444 | 404 start (- start (point) 1) |
| 428 | 405 end (- end (point) 1) |
| 406 doc (buffer-substring (1+ (point)) (1- sepb)) | |
| 407 apropos-item (assq symbol apropos-accumulator)) | |
| 408 (setq apropos-item (list symbol nil nil) | |
| 409 apropos-accumulator (cons apropos-item | |
| 410 apropos-accumulator))) | |
| 411 (if apropos-match-face | |
| 444 | 412 (put-text-property start end 'face apropos-match-face doc)) |
| 428 | 413 (setcar (nthcdr type apropos-item) doc))) |
| 414 (setq sepa (goto-char sepb))))) | |
| 415 | |
| 416 (defun apropos-documentation-check-elc-file (file) | |
| 417 (if (member file apropos-files-scanned) | |
| 418 nil | |
| 444 | 419 (let (symbol doc start end this-is-a-variable) |
| 428 | 420 (setq apropos-files-scanned (cons file apropos-files-scanned)) |
| 421 (erase-buffer) | |
| 422 (insert-file-contents file) | |
| 423 (while (search-forward "\n#@" nil t) | |
| 424 ;; Read the comment length, and advance over it. | |
| 425 (setq end (read) | |
| 444 | 426 start (1+ (point)) |
| 428 | 427 end (+ (point) end -1)) |
| 428 (forward-char) | |
| 429 (if (save-restriction | |
| 430 ;; match ^ and $ relative to doc string | |
| 444 | 431 (narrow-to-region start end) |
| 428 | 432 (re-search-forward apropos-regexp nil t)) |
| 433 (progn | |
| 434 (goto-char (+ end 2)) | |
| 444 | 435 (setq doc (buffer-substring start end) |
| 436 end (- (match-end 0) start) | |
| 437 start (- (match-beginning 0) start) | |
| 428 | 438 this-is-a-variable (looking-at "(def\\(var\\|const\\) ") |
| 439 symbol (progn | |
| 440 (skip-chars-forward "(a-z") | |
| 441 (forward-char) | |
| 442 (read)) | |
| 443 symbol (if (consp symbol) | |
| 444 (nth 1 symbol) | |
| 445 symbol)) | |
| 446 (if (if this-is-a-variable | |
| 447 (get symbol 'variable-documentation) | |
| 448 (and (fboundp symbol) (apropos-safe-documentation symbol))) | |
| 449 (progn | |
| 450 (or (setq apropos-item (assq symbol apropos-accumulator)) | |
| 451 (setq apropos-item (list symbol nil nil) | |
| 452 apropos-accumulator (cons apropos-item | |
| 453 apropos-accumulator))) | |
| 454 (if apropos-match-face | |
| 444 | 455 (put-text-property start end 'face apropos-match-face |
| 428 | 456 doc)) |
| 457 (setcar (nthcdr (if this-is-a-variable 2 1) | |
| 458 apropos-item) | |
| 459 doc))))))))) | |
| 460 | |
| 461 | |
| 462 | |
| 463 (defun apropos-safe-documentation (function) | |
| 464 "Like documentation, except it avoids calling `get_doc_string'. | |
| 465 Will return nil instead." | |
| 466 (while (and function (symbolp function)) | |
| 467 (setq function (if (fboundp function) | |
| 468 (symbol-function function)))) | |
| 469 (if (eq (car-safe function) 'macro) | |
| 470 (setq function (cdr function))) | |
| 471 ;; XEmacs change from: (setq function (if (byte-code-function-p function) | |
| 472 (setq function (if (compiled-function-p function) | |
| 776 | 473 (if-fboundp 'compiled-function-doc-string |
| 428 | 474 (compiled-function-doc-string function) |
| 475 (if (> (length function) 4) | |
| 476 (aref function 4))) | |
| 477 (if (eq (car-safe function) 'autoload) | |
| 478 (nth 2 function) | |
| 479 (if (eq (car-safe function) 'lambda) | |
| 480 (if (stringp (nth 2 function)) | |
| 481 (nth 2 function) | |
| 482 (if (stringp (nth 3 function)) | |
| 483 (nth 3 function))))))) | |
| 484 (if (integerp function) | |
| 485 nil | |
| 486 function)) | |
| 487 | |
| 488 | |
| 489 | |
| 490 (defun apropos-print (do-keys doc-fn spacing) | |
| 491 "Output result of various apropos commands with `apropos-regexp'. | |
| 492 APROPOS-ACCUMULATOR is a list. Optional DOC-FN is called for each element | |
| 493 of apropos-accumulator and may modify it resulting in (symbol fn-doc | |
| 494 var-doc [plist-doc]). Returns sorted list of symbols and documentation | |
| 495 found." | |
| 496 (if (null apropos-accumulator) | |
| 497 (message "No apropos matches for `%s'" apropos-regexp) | |
| 498 (if doc-fn | |
| 499 (funcall doc-fn apropos-accumulator)) | |
| 500 (setq apropos-accumulator | |
|
5182
2e528066e2fc
Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents:
2275
diff
changeset
|
501 (sort* apropos-accumulator #'string-lessp :key #'car)) |
| 428 | 502 (and apropos-label-face |
| 503 (or (symbolp apropos-label-face) | |
| 504 (facep apropos-label-face)) ; XEmacs | |
| 505 (setq apropos-label-face `(face ,apropos-label-face | |
| 506 mouse-face highlight))) | |
| 507 (let ((help-buffer-prefix-string "Apropos")) | |
| 508 (with-displaying-help-buffer | |
| 509 (lambda () | |
| 510 (with-current-buffer standard-output | |
| 511 (run-hooks 'apropos-mode-hook) | |
| 512 (let ((p apropos-accumulator) | |
| 513 (old-buffer (current-buffer)) | |
| 514 symbol item point1 point2) | |
| 430 | 515 ;; Mostly useless but to provide better keymap |
| 516 ;; explanation. help-mode-map will be used instead. | |
| 517 (use-local-map apropos-mode-map) | |
| 428 | 518 ;; XEmacs change from (if window-system |
| 519 (if (device-on-window-system-p) | |
| 520 (progn | |
| 521 (princ "If you move the mouse over text that changes color,\n") | |
| 522 (princ (substitute-command-keys | |
| 523 "you can click \\[apropos-mouse-follow] to get more information.\n")))) | |
| 524 (princ (substitute-command-keys | |
| 525 "Type \\[apropos-follow] in this buffer to get full documentation.\n\n")) | |
| 526 (while (consp p) | |
| 527 (or (not spacing) (bobp) (terpri)) | |
| 528 (setq apropos-item (car p) | |
| 529 symbol (car apropos-item) | |
| 530 p (cdr p) | |
| 531 point1 (point)) | |
| 532 (princ symbol) ; print symbol name | |
| 533 (setq point2 (point)) | |
| 534 ;; Calculate key-bindings if we want them. | |
| 535 (and do-keys | |
| 536 (commandp symbol) | |
| 537 (indent-to 30 1) | |
| 538 (if (let ((keys | |
| 539 (save-excursion | |
| 540 (set-buffer old-buffer) | |
| 541 (where-is-internal symbol))) | |
| 542 filtered) | |
| 543 ;; Copy over the list of key sequences, | |
| 544 ;; omitting any that contain a buffer or a frame. | |
| 545 (while keys | |
| 546 (let ((key (car keys)) | |
| 547 (i 0) | |
| 548 loser) | |
| 549 (while (< i (length key)) | |
| 550 (if (or (framep (aref key i)) | |
| 551 (bufferp (aref key i))) | |
| 552 (setq loser t)) | |
| 553 (setq i (1+ i))) | |
| 554 (or loser | |
| 555 (setq filtered (cons key filtered)))) | |
| 556 (setq keys (cdr keys))) | |
| 557 (setq item filtered)) | |
| 558 ;; Convert the remaining keys to a string and insert. | |
| 559 (princ | |
| 560 (mapconcat | |
| 561 (lambda (key) | |
| 562 (setq key (key-description key)) | |
| 563 (if apropos-keybinding-face | |
| 564 (put-text-property 0 (length key) | |
| 565 'face apropos-keybinding-face | |
| 566 key)) | |
| 567 key) | |
| 568 item ", ")) | |
| 569 (princ "Type ") | |
| 570 (princ "M-x") | |
| 571 (put-text-property (- (point) 3) (point) | |
| 572 'face apropos-keybinding-face) | |
| 573 (princ (format " %s " (symbol-name symbol))) | |
| 574 (princ "RET") | |
| 575 (put-text-property (- (point) 3) (point) | |
| 576 'face apropos-keybinding-face))) | |
| 577 (terpri) | |
| 578 ;; only now so we don't propagate text attributes all over | |
| 579 (put-text-property point1 point2 'item | |
| 580 (if (eval `(or ,@(cdr apropos-item))) | |
| 581 (car apropos-item) | |
| 582 apropos-item)) | |
| 583 (if apropos-symbol-face | |
| 584 (put-text-property point1 point2 'face apropos-symbol-face)) | |
| 430 | 585 ;; Add text-property on symbol, too. |
| 586 (put-text-property point1 point2 'keymap apropos-mode-map) | |
| 428 | 587 (apropos-print-doc 'describe-function 1 |
| 588 (if (commandp symbol) | |
| 589 "Command" | |
| 590 (if (apropos-macrop symbol) | |
| 591 "Macro" | |
| 592 "Function")) | |
| 593 do-keys) | |
| 594 (if (get symbol 'custom-type) | |
| 595 (apropos-print-doc 'customize-variable-other-window 2 | |
| 596 "User Option" do-keys) | |
| 597 (apropos-print-doc 'describe-variable 2 | |
| 598 "Variable" do-keys)) | |
| 599 (apropos-print-doc 'customize-other-window 6 "Group" do-keys) | |
| 600 (apropos-print-doc 'customize-face-other-window 5 "Face" do-keys) | |
| 601 (apropos-print-doc 'widget-browse-other-window 4 "Widget" do-keys) | |
| 602 (apropos-print-doc 'apropos-describe-plist 3 | |
| 603 "Plist" nil))))) | |
| 604 apropos-regexp)) | |
| 605 (prog1 apropos-accumulator | |
| 606 (setq apropos-accumulator ())))) ; permit gc | |
| 607 | |
| 608 | |
| 609 (defun apropos-macrop (symbol) | |
| 610 "Return t if SYMBOL is a Lisp macro." | |
| 611 (and (fboundp symbol) | |
| 612 (consp (setq symbol | |
| 613 (symbol-function symbol))) | |
| 614 (or (eq (car symbol) 'macro) | |
| 615 (if (eq (car symbol) 'autoload) | |
| 616 (memq (nth 4 symbol) | |
| 617 '(macro t)))))) | |
| 618 | |
| 619 | |
| 620 (defun apropos-print-doc (action i str do-keys) | |
| 621 (with-current-buffer standard-output | |
| 622 (if (stringp (setq i (nth i apropos-item))) | |
| 623 (progn | |
| 624 (insert " ") | |
| 625 (put-text-property (- (point) 2) (1- (point)) | |
| 626 'action action) | |
| 627 (insert str ": ") | |
| 628 (if apropos-label-face | |
| 629 (add-text-properties (- (point) (length str) 2) | |
| 630 (1- (point)) | |
| 631 apropos-label-face)) | |
| 632 (add-text-properties (- (point) (length str) 2) | |
| 633 (1- (point)) | |
| 634 (list 'keymap apropos-mode-map)) | |
| 635 (insert (if do-keys (substitute-command-keys i) i)) | |
| 636 (or (bolp) (terpri)))))) | |
| 637 | |
| 638 (defun apropos-mouse-follow (event) | |
| 639 (interactive "e") | |
| 640 ;; XEmacs change: We're using the standard help buffer code now, don't | |
| 641 ;; do special tricks about trying to preserve current-buffer about mouse | |
| 642 ;; clicks. | |
| 643 | |
| 644 (save-excursion | |
| 645 ;; XEmacs change from: | |
| 646 ;; (set-buffer (window-buffer (posn-window (event-start event)))) | |
| 647 ;; (goto-char (posn-point (event-start event))) | |
| 648 (set-buffer (event-buffer event)) | |
| 649 (goto-char (event-closest-point event)) | |
| 650 ;; XEmacs change: following code seems useless | |
| 651 ;;(or (and (not (eobp)) (get-text-property (point) 'mouse-face)) | |
| 652 ;; (and (not (bobp)) (get-text-property (1- (point)) 'mouse-face)) | |
| 653 ;; (error "There is nothing to follow here")) | |
| 654 (apropos-follow))) | |
| 655 | |
| 656 | |
| 657 (defun apropos-follow (&optional other) | |
| 658 (interactive) | |
| 659 (let* (;; Properties are always found at the beginning of the line. | |
| 660 (bol (save-excursion (beginning-of-line) (point))) | |
| 661 ;; If there is no `item' property here, look behind us. | |
| 662 (item (get-text-property bol 'item)) | |
| 663 (item-at (if item nil (previous-single-property-change bol 'item))) | |
| 664 ;; Likewise, if there is no `action' property here, look in front. | |
| 665 (action (get-text-property bol 'action)) | |
| 666 (action-at (if action nil (next-single-property-change bol 'action)))) | |
| 667 (and (null item) item-at | |
| 668 (setq item (get-text-property (1- item-at) 'item))) | |
| 669 (and (null action) action-at | |
| 670 (setq action (get-text-property action-at 'action))) | |
| 671 (if (not (and item action)) | |
| 672 (error "There is nothing to follow here")) | |
| 673 (if (consp item) (error "There is nothing to follow in `%s'" (car item))) | |
| 674 (if other (set-buffer other)) | |
| 675 (funcall action item))) | |
| 676 | |
| 677 | |
| 678 | |
| 679 (defun apropos-describe-plist (symbol) | |
| 680 "Display a pretty listing of SYMBOL's plist." | |
| 681 (let ((help-buffer-prefix-string "Apropos-plist")) | |
| 682 (with-displaying-help-buffer | |
| 683 (lambda () | |
| 684 (run-hooks 'apropos-mode-hook) | |
| 685 (princ "Symbol ") | |
| 686 (prin1 symbol) | |
| 687 (princ "'s plist is\n (") | |
| 688 (with-current-buffer standard-output | |
| 689 (if apropos-symbol-face | |
| 690 (put-text-property 8 (- (point) 14) 'face apropos-symbol-face))) | |
| 691 (princ (apropos-format-plist symbol "\n ")) | |
| 692 (princ ")") | |
| 693 (terpri) | |
| 694 (print-help-return-message)) | |
| 695 (symbol-name symbol)))) | |
| 696 | |
| 697 (provide 'apropos) ; XEmacs | |
| 698 | |
| 699 ;;; apropos.el ends here |