Mercurial > hg > xemacs-beta
annotate lisp/compat.el @ 5750:66d2f63df75f
Correct some spelling and formatting in behavior.el.
Mentioned in tracker issue 826, the third thing mentioned there (the file
name at the bottom of the file) had already been fixed.
lisp/ChangeLog addition:
2013-08-05 Aidan Kehoe <kehoea@parhasard.net>
* behavior.el:
(override-behavior):
Correct some spelling and formatting here, thank you Steven
Mitchell in tracker issue 826.
| author | Aidan Kehoe <kehoea@parhasard.net> |
|---|---|
| date | Mon, 05 Aug 2013 10:05:32 +0100 |
| parents | 91b3aa59f49b |
| children |
| rev | line source |
|---|---|
| 410 | 1 ;;; compat.el --- Mechanism for non-intrusively providing compatibility funs. |
| 2 | |
| 826 | 3 ;; Copyright (C) 2000, 2002 Ben Wing. |
| 410 | 4 |
| 5 ;; Author: Ben Wing <ben@xemacs.org> | |
| 6 ;; Maintainer: Ben Wing | |
| 7 ;; Keywords: internal | |
| 8 | |
| 9 ;; This file is part of XEmacs. | |
| 10 | |
|
5402
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
5182
diff
changeset
|
11 ;; 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
|
12 ;; 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
|
13 ;; 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
|
14 ;; option) any later version. |
| 410 | 15 |
|
5402
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
5182
diff
changeset
|
16 ;; 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
|
17 ;; 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
|
18 ;; 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
|
19 ;; for more details. |
| 410 | 20 |
| 21 ;; 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
|
22 ;; along with XEmacs. If not, see <http://www.gnu.org/licenses/>. |
| 410 | 23 |
| 24 ;;; Synched up with: Not in FSF. | |
| 25 | |
| 26 ;;; Authorship: | |
| 27 | |
| 28 ; Written May 2000 by Ben Wing. | |
| 29 | |
| 30 ;;; Commentary: | |
| 31 | |
| 826 | 32 ;; The idea is to provide emulation of API's in a namespace-clean way. Lots of packages are filled with declarations such as |
| 33 | |
| 34 ;; (defalias 'gnus-overlay-get 'extent-property) | |
| 35 | |
| 36 ; There should be a single package to provide such compatibility code. The | |
| 37 ; tricky part is how to do it in a clean way, without packages interfering | |
| 38 ; with each other. | |
| 39 | |
| 40 ; The basic usage of compat is: | |
| 41 | |
| 42 ; (1) Each package copies compat.el and renames it, e.g. gnus-compat.el. | |
| 43 | |
| 44 ; (2) `compat' defines various API's that can be activated. To use them in a | |
| 45 ; file, first place code like this at the top of the file: | |
| 46 | |
| 47 ;(let ((compat-current-package 'Gnus)) | |
| 48 ; (require 'gnus-compat)) | |
| 49 | |
| 50 ; then wrap the rest of the code like this: | |
| 51 | |
| 52 ; (Gnus-compat-wrap '(overlays events) | |
| 53 | |
| 54 ;;; Commentary | |
| 55 | |
| 56 ;; blah | |
| 57 | |
| 58 ;;; Code | |
| 59 | |
| 60 ;(defun random-module-my-fun (bar baz) | |
| 61 ; ... | |
| 62 ; (overlay-put overlay 'face 'bold) | |
| 63 ; ... | |
| 64 ;) | |
| 65 ; | |
| 66 ;(defun ... | |
| 67 ;) | |
| 68 ; | |
| 69 ; | |
| 70 ; | |
| 71 ; | |
| 72 ;) ;; end of (Gnus-compat) | |
| 73 | |
| 74 ;;;; random-module.el ends here | |
| 75 | |
| 76 ; (3) What this does is implement the requested API's (in this case, the | |
| 77 ; overlay API from GNU Emacs and event API from XEmacs) in whichever | |
| 78 ; version of Emacs is running, with names such as | |
| 79 ; `Gnus-compat-overlay-put', and then it uses `macrolet' to map the | |
| 80 ; generic names in the wrapped code into namespace-clean names. The | |
| 81 ; result of loading `gnus-compat' leaves around only functions beginning | |
| 82 ; with `Gnus-compat' (or whatever prefix was specified in | |
| 83 ; `compat-current-package'). This way, various packages, with various | |
| 84 ; versions of `compat' as part of them, can coexist, with each package | |
| 85 ; running the version of `compat' that it's been tested with. The use of | |
| 86 ; `macrolet' ensures that only code that's lexically wrapped -- not code | |
| 87 ; that's called from that code -- is affected by the API mapping. | |
| 88 | |
| 410 | 89 ;; Typical usage: |
| 90 | |
| 91 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
| 92 ;; 1. Wrap modules that define compatibility functions like this: ;; | |
| 93 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
| 94 | |
| 95 ;(compat-define-group 'fsf-compat) | |
| 96 | |
| 97 ;(compat-define-functions 'fsf-compat | |
| 98 | |
| 826 | 99 ;(defun overlay-put (overlay prop value) |
| 100 ; "Set property PROP to VALUE in overlay OVERLAY." | |
| 101 ; (set-extent-property overlay prop value)) | |
| 410 | 102 |
| 103 ;(defun make-overlay (beg end &optional buffer front-advance rear-advance) | |
| 104 ; ...) | |
| 105 | |
| 106 ;... | |
| 107 | |
| 108 ;) ;; end of (compat-define-group 'fsf-compat) | |
| 109 | |
| 110 ;;;; overlay.el ends here | |
| 111 | |
| 112 | |
| 113 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
| 114 ;; 2. Wrap modules that use the compatibility functions like this: ;; | |
| 115 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
| 116 | |
| 826 | 117 ;(let ((compat-current-package 'gnus)) |
| 118 ; (require 'gnus-compat)) | |
| 119 ; | |
| 120 ;(gnus-compat 'fsf-compat | |
| 121 ; | |
| 122 ;; Code: | |
| 123 ;; | |
| 124 ;; | |
| 410 | 125 ;(defun random-module-my-fun (bar baz) |
| 826 | 126 ; ... |
| 127 ; (overlay-put overlay 'face 'bold) | |
| 128 ; ... | |
| 129 ;) | |
| 130 ; | |
| 131 ;(defun ... | |
| 132 ;) | |
| 133 ; | |
| 134 ; | |
| 135 ; | |
| 136 ; | |
| 410 | 137 ;) ;; end of (compat 'fsf-compat) |
| 138 | |
| 139 ;;;; random-module.el ends here | |
| 140 | |
| 826 | 141 (defvar compat-current-package) |
| 142 | |
| 143 (eval-when-compile | |
| 144 (setq compat-current-package 'compat)) | |
| 145 | |
| 146 ;; #### not yet working | |
| 147 '( | |
| 148 | |
| 149 (defmacro compat-define-compat-functions (&rest body) | |
| 150 "Define the functions of the `compat' package in a namespace-clean way. | |
| 151 This relies on `compat-current-package' being set. If `compat-current-package' | |
| 152 is equal to the symbol `foo', and within BODY is something like | |
| 153 | |
| 154 \(defmacro compat-define-group (group) | |
| 155 ... | |
| 156 ) | |
| 157 | |
| 158 then this turns into | |
| 159 | |
| 160 \(defmacro foo-compat-define-group (group) | |
| 161 ... | |
| 162 ) | |
| 163 | |
| 164 and all calls are replaced accordingly. | |
| 165 | |
| 166 | |
| 167 | |
| 168 | |
| 169 Functions such as | |
| 170 compatibility functions in GROUP. | |
| 171 You should simply wrap this around the code that defines the functions. | |
| 172 Any functions and macros defined at top level using `defun' or `defmacro' | |
| 173 will be noticed and added to GROUP. Other top-level code will be executed | |
| 174 normally. All code and definitions in this group can safely reference any | |
| 175 other functions in this group -- the code is effectively wrapped in a | |
| 176 `compat' call. You can call `compat-define-functions' more than once, if | |
| 177 necessary, for a single group. | |
| 178 | |
| 179 What actually happens is that the functions and macros defined here are in | |
| 180 fact defined using names prefixed with GROUP. To use these functions, | |
| 181 wrap any calling code with the `compat' macro, which lexically renames | |
| 182 the function and macro calls appropriately." | |
| 183 (let ((prefix (if (boundp 'compat-current-package) | |
| 184 compat-current-package | |
| 185 (error | |
| 186 "`compat-current-package' must be defined when loading this module"))) | |
| 187 (defs-to-munge '(defun defmacro)) | |
| 188 mappings) | |
| 189 (if (symbolp prefix) (setq prefix (symbol-name prefix))) | |
| 190 ;; first, note all defuns and defmacros | |
| 191 (let (fundef | |
| 192 (body-tail body)) | |
| 193 (while body-tail | |
| 194 (setq fundef (car body-tail)) | |
| 195 (when (and (consp fundef) (memq (car fundef) defs-to-munge)) | |
| 196 (push (cons (second fundef) (third fundef)) mappings)) | |
| 197 (setq body-tail (cdr body-tail)))) | |
| 198 ;; now, munge the definitions with the new names | |
| 199 (let (fundef | |
| 200 (body-tail body) | |
| 201 result | |
| 202 defs) | |
| 203 (while body-tail | |
| 204 (setq fundef (car body-tail)) | |
| 205 (push | |
| 206 (cond ((and (consp fundef) (memq (car fundef) defs-to-munge)) | |
| 207 (nconc (list (car fundef) | |
| 208 (intern (concat prefix "-" | |
| 209 (symbol-name (second fundef)))) | |
| 210 (third fundef)) | |
| 211 (nthcdr 3 fundef))) | |
| 212 (t fundef)) | |
| 213 result) | |
| 214 (setq body-tail (cdr body-tail))) | |
| 215 (setq result (nreverse result)) | |
| 216 ;; now, generate the munged code, with the references to the functions | |
| 217 ;; macroletted | |
| 218 (mapc | |
| 219 #'(lambda (acons) | |
| 220 (let ((fun (car acons)) | |
| 221 (args (cdr acons))) | |
| 222 (push | |
| 223 (list fun args | |
| 224 (nconc | |
| 225 (list 'list | |
| 226 (list 'quote | |
| 227 (intern (concat prefix "-" | |
| 228 (symbol-name fun))))) | |
| 229 args)) | |
| 230 defs))) | |
| 231 mappings) | |
| 232 ;; it would be cleaner to use `lexical-let' instead of `let', but that | |
| 233 ;; causes function definitions to have obnoxious, unreadable junk in | |
| 234 ;; them. #### Move `lexical-let' into C!!! | |
| 235 `(macrolet ((compat-current-package () ,compat-current-package) | |
| 236 ,@defs) | |
| 237 ,@result)))) | |
| 238 | |
| 239 (compat-define-compat-functions | |
| 410 | 240 |
| 241 (defun compat-hash-table (group) | |
| 242 (get group 'compat-table)) | |
| 243 | |
| 244 (defun compat-make-hash-table (group) | |
| 245 (put group 'compat-table (make-hash-table))) | |
| 246 | |
| 826 | 247 (defmacro compat-define-group (group &rest body) |
| 410 | 248 "Define GROUP as a group of compatibility functions. |
| 826 | 249 This macro should wrap individual Individual functions are defined using `compat-define-functions'. |
| 410 | 250 Once defined, the functions can be used by wrapping your code in the |
| 251 `compat' macro. | |
| 252 | |
| 253 If GROUP is already defined, nothing happens." | |
| 254 (let ((group (eval group))) | |
| 255 (or (hash-table-p (compat-hash-table group)) | |
| 256 (compat-make-hash-table group)))) | |
| 257 | |
| 258 (defmacro compat-clear-functions (group) | |
| 259 "Clear all defined functions and macros out of GROUP." | |
| 260 (let ((group (eval group))) | |
| 261 (clrhash (compat-hash-table group)))) | |
| 262 | |
| 826 | 263 (defmacro compat-defun (args &rest body) |
| 264 | |
| 265 (defmacro compat-define-function (props name arglist &rest body) | |
| 266 "Define a compatibility function. | |
| 267 PROPS are properties controlling how the function should be defined. | |
| 268 control how the should simply wrap this around the code that defines the functions. | |
| 410 | 269 Any functions and macros defined at top level using `defun' or `defmacro' |
| 270 will be noticed and added to GROUP. Other top-level code will be executed | |
| 271 normally. All code and definitions in this group can safely reference any | |
| 272 other functions in this group -- the code is effectively wrapped in a | |
| 273 `compat' call. You can call `compat-define-functions' more than once, if | |
| 274 necessary, for a single group. | |
| 275 | |
| 276 What actually happens is that the functions and macros defined here are in | |
| 277 fact defined using names prefixed with GROUP. To use these functions, | |
| 278 wrap any calling code with the `compat' macro, which lexically renames | |
| 279 the function and macro calls appropriately." | |
| 826 | 280 (let ((group (eval group)) |
| 281 (defs-to-munge '(defun defmacro)) | |
| 282 ) | |
| 410 | 283 (let (fundef |
| 284 (body-tail body)) | |
| 285 (while body-tail | |
| 286 (setq fundef (car body-tail)) | |
| 826 | 287 (when (and (consp fundef) (memq (car fundef) defs-to-munge)) |
| 410 | 288 (puthash (second fundef) (third fundef) (compat-hash-table group))) |
| 289 (setq body-tail (cdr body-tail)))) | |
| 290 (let (fundef | |
| 291 (body-tail body) | |
| 292 result) | |
| 293 (while body-tail | |
| 294 (setq fundef (car body-tail)) | |
| 295 (push | |
| 826 | 296 (cond ((and (consp fundef) (memq (car fundef) defs-to-munge)) |
| 297 (nconc (list (car fundef) | |
| 410 | 298 (intern (concat (symbol-name group) "-" |
| 299 (symbol-name (second fundef)))) | |
| 300 (third fundef)) | |
| 301 (nthcdr 3 fundef))) | |
| 302 (t fundef)) | |
| 303 result) | |
| 304 (setq body-tail (cdr body-tail))) | |
| 826 | 305 (nconc (list 'compat-wrap (list 'quote group)) (nreverse result))))) |
| 410 | 306 |
| 307 (defvar compat-active-groups nil) | |
| 308 | |
| 309 (defun compat-fboundp (groups fun) | |
| 310 "T if FUN is either `fboundp' or one of the compatibility funs in GROUPS. | |
| 311 GROUPS is a list of compatibility groups as defined using | |
| 312 `compat-define-group'." | |
| 313 (or (fboundp fun) | |
| 314 (block nil | |
| 315 (mapcar #'(lambda (group) | |
| 316 (if (gethash fun (compat-hash-table group)) | |
| 317 (return t))) | |
| 318 groups)))) | |
| 319 | |
| 826 | 320 (defmacro compat-wrap-runtime (groups &rest body)) |
| 321 | |
| 322 (defmacro compat-wrap (groups &rest body) | |
| 323 "Make use of compatibility functions and macros in GROUPS. | |
| 324 GROUPS is a symbol, an API group, or list of API groups. Each API group | |
| 325 defines a set of functions, macros, variables, etc. and that will (or | |
| 326 should ideally) work on all recent versions of both GNU Emacs and XEmacs, | |
| 327 and (to some extent, depending on how the functions were designed) on older | |
| 328 version. When this function is used, it will generally not be named | |
| 329 `compat-wrap', but have some name such as `Gnus-compat-wrap', if this is | |
| 330 wrapping something in `gnus'. (The renaming happened when the `compat' | |
| 331 package was loaded -- see discussion at top). | |
| 332 | |
| 333 To use `compat' in your package (assume your package is `gnus'), you first | |
| 334 have to do a bit if setup. | |
| 335 | |
| 336 -- Copy and rename compat.el, e.g. to `gnus-compat.el'. The name must be | |
| 337 globally unique across everything on the load path (that means all | |
| 338 packages). | |
| 339 -- Incude this file in your package. It will not interfere with any other | |
| 340 versions of compat (earlier, later, etc.) provided in other packages | |
| 341 and similarly renamed. | |
| 342 | |
| 343 To make use of the API's provided: | |
| 344 | |
| 345 -- First place code like this at the top of the file, after the copyright | |
| 346 notices and comments: | |
| 347 | |
| 348 \(let ((compat-current-package 'Gnus)) | |
| 349 (require 'gnus-compat)) | |
| 350 | |
| 351 -- then wrap the rest of the code like this, assuming you want access to | |
| 352 the GNU Emacs overlays API, and the XEmacs events API: | |
| 353 | |
| 354 \(Gnus-compat-wrap '(overlays xem-events) | |
| 355 | |
| 356 ... | |
| 357 ... | |
| 358 ... | |
| 359 | |
| 360 \(defun gnus-random-fun (overlay baz) | |
| 361 ... | |
| 362 (overlay-put overlay 'face 'bold) | |
| 363 ... | |
| 364 ) | |
| 365 | |
| 366 ... | |
| 367 ... | |
| 368 | |
| 369 \(defun gnus-random-fun-2 (event) | |
| 370 (interactive "e") | |
| 371 (let ((x (event-x event)) | |
| 372 (y (event-y event))) | |
| 373 ... | |
| 374 ) | |
| 375 ) | |
| 376 | |
| 377 ) ;; end of (Gnus-compat) | |
| 378 | |
| 379 ;;;; random-module.el ends here | |
| 380 | |
| 381 Both the requested API's will be implemented whichever version of Emacs | |
| 382 \(GNU Emacs, XEmacs, etc.) is running, and (with limitations) on older | |
| 383 versions as well. Furthermore, the API's are provided *ONLY* to code | |
| 384 that's actually, lexically wrapped by `compat-wrap' (or its renamed | |
| 385 version). All other code, including code that's called by the wrapped | |
| 386 code, is not affected -- e.g. if we're on XEmacs, and `overlay-put' isn't | |
| 387 normally defined, then it won't be defined in code other than the wrapped | |
| 388 code, even if the wrapped code calls that code. Clever, huh? | |
| 389 | |
| 390 What happens is that the `compat-wrap' actually uses `macrolet' to | |
| 391 inline-substitute calls to `overlay-put' to (in this case) | |
| 392 `Gnus-compat-overlay-put', which was defined when `gnus-compat' was loaded. | |
| 393 | |
| 394 What happens is that is implement the requested API's (in this case, the | |
| 395 overlay API from GNU Emacs and event API from XEmacs) in whichever | |
| 396 version of Emacs is running, with names such as | |
| 397 `Gnus-compat-overlay-put', and then it uses `macrolet' to map the | |
| 398 generic names in the wrapped code into namespace-clean names. The | |
| 399 result of loading `gnus-compat' leaves around only functions beginning | |
| 400 with `Gnus-compat' (or whatever prefix was specified in | |
| 401 `compat-current-package'). This way, various packages, with various | |
| 402 versions of `compat' as part of them, can coexist, with each package | |
| 403 running the version of `compat' that it's been tested with. The use of | |
| 404 `macrolet' ensures that only code that's lexically wrapped -- not code | |
| 405 that's called from that code -- is affected by the API mapping. | |
| 406 | |
| 407 Before using `compat' | |
| 408 | |
| 409 For any file where you want to make use of one or more API's provided by | |
| 410 `compat', first do this: | |
| 411 | |
| 412 Wrap a call to `compat-wrap' around your entire file, like this: | |
| 413 | |
| 414 ;; First, you copied compat.el into your package -- we're assuming \"gnus\" -- | |
| 415 ;; and renamed it, e.g. gnus-compat.el. Now we load it and tell it to | |
| 416 ;; use `Gnus' as the prefix for all stuff it defines. (Use a capital letter | |
| 417 ;; or some similar convention so that these names are not so easy to see.) | |
| 418 | |
| 419 \(let ((current-compat-package 'Gnus)) | |
| 420 (require 'gnus-compat)) | |
| 421 | |
| 422 ;; The function `compat-wrap' was mapped to `Gnus-compat-wrap'. The idea | |
| 423 ;; is that the raw functions beginning with `compat-' are never actually | |
| 424 ;; defined. They may appear as function calls inside of functions, but | |
| 425 ;; they will always be mapped to something beginning with the given prefix. | |
| 426 | |
| 427 \(Gnus-compat-wrap '(overlays xem-events) | |
| 428 | |
| 429 ... | |
| 430 | |
| 431 ) | |
| 432 | |
| 410 | 433 You should simply wrap this around the code that uses the functions |
| 826 | 434 and macros in GROUPS. Typically, a call to `compat' should be placed |
| 410 | 435 at the top of an ELisp module, with the closing parenthesis at the |
| 436 bottom; use this in place of a `require' statement. Wrapped code can | |
| 437 be either function or macro definitions or other ELisp code, and | |
| 438 wrapped function or macro definitions need not be at top level. All | |
| 439 calls to the compatibility functions or macros will be noticed anywhere | |
| 440 within the wrapped code. Calls to `fboundp' within the wrapped code | |
| 441 will also behave correctly when called on compatibility functions and | |
| 442 macros, even though they would return nil elsewhere (including in code | |
| 443 in other modules called dynamically from the wrapped code). | |
| 444 | |
| 445 The functions and macros define in GROUP are actually defined under | |
| 446 prefixed names, to avoid namespace clashes and bad interactions with | |
| 447 other code that calls `fboundp'. All calls inside of the wrapped code | |
| 448 to the compatibility functions and macros in GROUP are lexically | |
| 449 mapped to the prefixed names. Since this is a lexical mapping, code | |
| 450 in other modules that is called by functions in this module will not | |
| 451 be affected." | |
| 452 (let ((group (eval group)) | |
| 453 defs) | |
| 454 (maphash | |
| 455 #'(lambda (fun args) | |
| 456 (push | |
| 457 (list fun args | |
| 458 (nconc | |
| 459 (list 'list | |
| 460 (list 'quote | |
| 461 (intern (concat (symbol-name group) "-" | |
| 462 (symbol-name fun))))) | |
| 463 args)) | |
| 464 defs)) | |
| 465 (compat-hash-table group)) | |
| 466 ;; it would be cleaner to use `lexical-let' instead of `let', but that | |
| 467 ;; causes function definitions to have obnoxious, unreadable junk in | |
| 468 ;; them. #### Move `lexical-let' into C!!! | |
| 469 `(let ((compat-active-groups (cons ',group compat-active-groups))) | |
| 470 (macrolet ((fboundp (fun) `(compat-fboundp ',compat-active-groups ,fun)) | |
| 471 ,@defs) | |
| 472 ,@body)))) | |
| 826 | 473 |
| 474 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
| 475 ;; Define the compat groups ;; | |
| 476 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
| 477 | |
| 478 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; overlays ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
| 479 | |
| 480 (compat-define-group 'overlays | |
| 481 | |
| 482 (defun-compat overlayp (object) | |
| 483 "Return t if OBJECT is an overlay." | |
| 484 (and (extentp object) | |
| 485 (extent-property object 'overlay))) | |
| 486 | |
| 487 (defun-compat make-overlay (beg end &optional buffer front-advance rear-advance) | |
| 488 "Create a new overlay with range BEG to END in BUFFER. | |
| 489 If omitted, BUFFER defaults to the current buffer. | |
| 490 BEG and END may be integers or markers. | |
| 491 The fourth arg FRONT-ADVANCE, if non-nil, makes the | |
| 492 front delimiter advance when text is inserted there. | |
| 493 The fifth arg REAR-ADVANCE, if non-nil, makes the | |
| 494 rear delimiter advance when text is inserted there." | |
| 495 (if (null buffer) | |
| 496 (setq buffer (current-buffer)) | |
| 497 (check-argument-type 'bufferp buffer)) | |
| 498 (when (> beg end) | |
| 499 (setq beg (prog1 end (setq end beg)))) | |
| 500 | |
| 501 (let ((overlay (make-extent beg end buffer))) | |
| 502 (set-extent-property overlay 'overlay t) | |
| 503 (if front-advance | |
| 504 (set-extent-property overlay 'start-open t) | |
| 505 (set-extent-property overlay 'start-closed t)) | |
| 506 (if rear-advance | |
| 507 (set-extent-property overlay 'end-closed t) | |
| 508 (set-extent-property overlay 'end-open t)) | |
| 509 | |
| 510 overlay)) | |
| 511 | |
| 512 (defun-compat move-overlay (overlay beg end &optional buffer) | |
| 513 "Set the endpoints of OVERLAY to BEG and END in BUFFER. | |
| 514 If BUFFER is omitted, leave OVERLAY in the same buffer it inhabits now. | |
| 515 If BUFFER is omitted, and OVERLAY is in no buffer, put it in the current | |
| 516 buffer." | |
| 517 (check-argument-type 'overlayp overlay) | |
| 518 (if (null buffer) | |
| 519 (setq buffer (extent-object overlay))) | |
| 520 (if (null buffer) | |
| 521 (setq buffer (current-buffer))) | |
| 522 (check-argument-type 'bufferp buffer) | |
| 523 (and (= beg end) | |
| 524 (extent-property overlay 'evaporate) | |
| 525 (delete-overlay overlay)) | |
| 526 (when (> beg end) | |
| 527 (setq beg (prog1 end (setq end beg)))) | |
| 528 (set-extent-endpoints overlay beg end buffer) | |
| 529 overlay) | |
| 530 | |
| 531 (defun-compat delete-overlay (overlay) | |
| 532 "Delete the overlay OVERLAY from its buffer." | |
| 533 (check-argument-type 'overlayp overlay) | |
| 534 (detach-extent overlay) | |
| 535 nil) | |
| 536 | |
| 537 (defun-compat overlay-start (overlay) | |
| 538 "Return the position at which OVERLAY starts." | |
| 539 (check-argument-type 'overlayp overlay) | |
| 540 (extent-start-position overlay)) | |
| 541 | |
| 542 (defun-compat overlay-end (overlay) | |
| 543 "Return the position at which OVERLAY ends." | |
| 544 (check-argument-type 'overlayp overlay) | |
| 545 (extent-end-position overlay)) | |
| 546 | |
| 547 (defun-compat overlay-buffer (overlay) | |
| 548 "Return the buffer OVERLAY belongs to." | |
| 549 (check-argument-type 'overlayp overlay) | |
| 550 (extent-object overlay)) | |
| 551 | |
| 552 (defun-compat overlay-properties (overlay) | |
| 553 "Return a list of the properties on OVERLAY. | |
| 554 This is a copy of OVERLAY's plist; modifying its conses has no effect on | |
| 555 OVERLAY." | |
| 556 (check-argument-type 'overlayp overlay) | |
| 557 (extent-properties overlay)) | |
| 558 | |
| 559 (defun-compat overlays-at (pos) | |
| 560 "Return a list of the overlays that contain position POS." | |
| 561 (overlays-in pos pos)) | |
| 562 | |
| 563 (defun-compat overlays-in (beg end) | |
| 564 "Return a list of the overlays that overlap the region BEG ... END. | |
| 565 Overlap means that at least one character is contained within the overlay | |
| 566 and also contained within the specified region. | |
| 567 Empty overlays are included in the result if they are located at BEG | |
| 568 or between BEG and END." | |
| 569 (if (featurep 'xemacs) | |
| 570 (mapcar-extents #'identity nil nil beg end | |
| 571 'all-extents-closed-open 'overlay) | |
| 572 (let ((ovls (overlay-lists)) | |
| 573 tmp retval) | |
| 574 (if (< end beg) | |
| 575 (setq tmp end | |
| 576 end beg | |
| 577 beg tmp)) | |
| 578 (setq ovls (nconc (car ovls) (cdr ovls))) | |
| 579 (while ovls | |
| 580 (setq tmp (car ovls) | |
| 581 ovls (cdr ovls)) | |
| 582 (if (or (and (<= (overlay-start tmp) end) | |
| 583 (>= (overlay-start tmp) beg)) | |
| 584 (and (<= (overlay-end tmp) end) | |
| 585 (>= (overlay-end tmp) beg))) | |
| 586 (setq retval (cons tmp retval)))) | |
| 587 retval))) | |
| 588 | |
| 589 (defun-compat next-overlay-change (pos) | |
| 590 "Return the next position after POS where an overlay starts or ends. | |
| 591 If there are no more overlay boundaries after POS, return (point-max)." | |
| 592 (let ((next (point-max)) | |
| 593 tmp) | |
| 594 (map-extents | |
| 595 (lambda (overlay ignore) | |
| 596 (when (or (and (< (setq tmp (extent-start-position overlay)) next) | |
| 597 (> tmp pos)) | |
| 598 (and (< (setq tmp (extent-end-position overlay)) next) | |
| 599 (> tmp pos))) | |
| 600 (setq next tmp)) | |
| 601 nil) | |
| 602 nil pos nil nil 'all-extents-closed-open 'overlay) | |
| 603 next)) | |
| 604 | |
| 605 (defun-compat previous-overlay-change (pos) | |
| 606 "Return the previous position before POS where an overlay starts or ends. | |
| 607 If there are no more overlay boundaries before POS, return (point-min)." | |
| 608 (let ((prev (point-min)) | |
| 609 tmp) | |
| 610 (map-extents | |
| 611 (lambda (overlay ignore) | |
| 612 (when (or (and (> (setq tmp (extent-end-position overlay)) prev) | |
| 613 (< tmp pos)) | |
| 614 (and (> (setq tmp (extent-start-position overlay)) prev) | |
| 615 (< tmp pos))) | |
| 616 (setq prev tmp)) | |
| 617 nil) | |
| 618 nil nil pos nil 'all-extents-closed-open 'overlay) | |
| 619 prev)) | |
| 620 | |
| 621 (defun-compat overlay-lists () | |
| 622 "Return a pair of lists giving all the overlays of the current buffer. | |
| 623 The car has all the overlays before the overlay center; | |
| 624 the cdr has all the overlays after the overlay center. | |
| 625 Recentering overlays moves overlays between these lists. | |
| 626 The lists you get are copies, so that changing them has no effect. | |
| 627 However, the overlays you get are the real objects that the buffer uses." | |
| 628 (or (boundp 'xemacs-internal-overlay-center-pos) | |
| 629 (overlay-recenter (1+ (/ (- (point-max) (point-min)) 2)))) | |
| 630 (let ((pos xemacs-internal-overlay-center-pos) | |
| 631 before after) | |
| 632 (map-extents (lambda (overlay ignore) | |
| 633 (if (> pos (extent-end-position overlay)) | |
| 634 (push overlay before) | |
| 635 (push overlay after)) | |
| 636 nil) | |
| 637 nil nil nil nil 'all-extents-closed-open 'overlay) | |
| 638 (cons (nreverse before) (nreverse after)))) | |
| 639 | |
| 640 (defun-compat overlay-recenter (pos) | |
| 641 "Recenter the overlays of the current buffer around position POS." | |
| 642 (set (make-local-variable 'xemacs-internal-overlay-center-pos) pos)) | |
| 643 | |
| 644 (defun-compat overlay-get (overlay prop) | |
| 645 "Get the property of overlay OVERLAY with property name PROP." | |
| 646 (check-argument-type 'overlayp overlay) | |
| 647 (let ((value (extent-property overlay prop)) | |
| 648 category) | |
| 649 (if (and (null value) | |
| 650 (setq category (extent-property overlay 'category))) | |
| 651 (get category prop) | |
| 652 value))) | |
| 653 | |
| 654 (defun-compat overlay-put (overlay prop value) | |
| 655 "Set one property of overlay OVERLAY: give property PROP value VALUE." | |
| 656 (check-argument-type 'overlayp overlay) | |
| 657 (cond ((eq prop 'evaporate) | |
| 658 (set-extent-property overlay 'detachable value)) | |
| 659 ((eq prop 'before-string) | |
| 660 (set-extent-property overlay 'begin-glyph | |
| 661 (make-glyph (vector 'string :data value)))) | |
| 662 ((eq prop 'after-string) | |
| 663 (set-extent-property overlay 'end-glyph | |
| 664 (make-glyph (vector 'string :data value)))) | |
| 665 ((eq prop 'local-map) | |
| 666 (set-extent-property overlay 'keymap value)) | |
| 667 ((memq prop '(window insert-in-front-hooks insert-behind-hooks | |
| 668 modification-hooks)) | |
| 669 (error "cannot support overlay '%s property under XEmacs" | |
| 670 prop))) | |
| 671 (set-extent-property overlay prop value)) | |
| 672 ) | |
| 673 | |
| 674 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; extents ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
| 675 | |
| 676 (defalias-compat 'delete-extent 'delete-overlay) | |
| 677 (defalias-compat 'extent-end-position 'overlay-end) | |
| 678 (defalias-compat 'extent-start-position 'overlay-start) | |
| 679 (defalias-compat 'set-extent-endpoints 'move-overlay) | |
| 680 (defalias-compat 'set-extent-property 'overlay-put) | |
| 681 (defalias-compat 'make-extent 'make-overlay) | |
| 682 | |
| 683 (defun-compat extent-property (extent property &optional default) | |
| 684 (or (overlay-get extent property) default)) | |
| 685 | |
| 686 (defun-compat extent-at (pos &optional object property before at-flag) | |
| 687 (let ((tmp (overlays-at (point))) | |
| 688 ovls) | |
| 689 (if property | |
| 690 (while tmp | |
| 691 (if (extent-property (car tmp) property) | |
| 692 (setq ovls (cons (car tmp) ovls))) | |
| 693 (setq tmp (cdr tmp))) | |
| 694 (setq ovls tmp | |
| 695 tmp nil)) | |
|
5182
2e528066e2fc
Move #'sort*, #'fill, #'merge to C from cl-seq.el.
Aidan Kehoe <kehoea@parhasard.net>
parents:
826
diff
changeset
|
696 (car (sort* ovls #'< :key #'extent-length)))) |
| 826 | 697 |
| 698 (defun-compat map-extents (function &optional object from to | |
| 699 maparg flags property value) | |
| 700 (let ((tmp (overlays-in (or from (point-min)) | |
| 701 (or to (point-max)))) | |
| 702 ovls) | |
| 703 (if property | |
| 704 (while tmp | |
| 705 (if (extent-property (car tmp) property) | |
| 706 (setq ovls (cons (car tmp) ovls))) | |
| 707 (setq tmp (cdr tmp))) | |
| 708 (setq ovls tmp | |
| 709 tmp nil)) | |
| 710 (catch 'done | |
| 711 (while ovls | |
| 712 (setq tmp (funcall function (car ovls) maparg) | |
| 713 ovls (cdr ovls)) | |
| 714 (if tmp | |
| 715 (throw 'done tmp)))))) | |
| 716 | |
| 717 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; extents ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
| 718 | |
| 719 | |
| 720 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; events ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
| 721 | |
| 722 ) ;; group overlays | |
| 723 | |
| 724 ) ;; compat-define-compat-functions | |
| 725 | |
| 726 (fmakunbound 'compat-define-compat-functions) | |
| 727 | |
|
5402
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
5182
diff
changeset
|
728 |
|
5404
91b3aa59f49b
Convert lisp/ to GPLv3.
Mike Sperber <sperber@deinprogramm.de>
parents:
5402
diff
changeset
|
729 ) |