Mercurial > hg > xemacs-beta
annotate lisp/compat.el @ 5767:4e69b24a2301
Disable ASLR on Mavericks.
| author | Marcus Crestani <crestani@informatik.uni-tuebingen.de> |
|---|---|
| date | Mon, 28 Oct 2013 16:03:53 +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 ) |