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