Mercurial > hg > xemacs-beta

comparison lisp/compat.el @ 410:de805c49cfc1 r21-2-35

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r21-2-35
author cvs
date Mon, 13 Aug 2007 11:19:21 +0200
parents
children 6728e641994e
comparison
equal deleted inserted replaced
409:301b9ebbdf3b 410:de805c49cfc1
1 ;;; compat.el --- Mechanism for non-intrusively providing compatibility funs.
2
3 ;; Copyright (C) 2000 Ben Wing.
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
34 ;; Typical usage:
35
36 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
37 ;; 1. Wrap modules that define compatibility functions like this: ;;
38 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
39
40 ;(compat-define-group 'fsf-compat)
41
42 ;(compat-define-functions 'fsf-compat
43
44 ;(defun overlayp (object)
45 ; "Return t if OBJECT is an overlay."
46 ; (and (extentp object)
47 ; (extent-property object 'overlay)))
48
49 ;(defun make-overlay (beg end &optional buffer front-advance rear-advance)
50 ; ...)
51
52 ;...
53
54 ;) ;; end of (compat-define-group 'fsf-compat)
55
56 ;;;; overlay.el ends here
57
58
59 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
60 ;; 2. Wrap modules that use the compatibility functions like this: ;;
61 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
62
63 ;(compat 'fsf-compat
64
65 ;(defun random-module-my-fun (bar baz)
66 ; (if (fboundp 'overlays-in) (overlays-in bar baz)))
67
68 ;...
69
70 ;) ;; end of (compat 'fsf-compat)
71
72 ;;;; random-module.el ends here
73
74
75 (defun compat-hash-table (group)
76 (get group 'compat-table))
77
78 (defun compat-make-hash-table (group)
79 (put group 'compat-table (make-hash-table)))
80
81 (defmacro compat-define-group (group)
82 "Define GROUP as a group of compatibility functions.
83 Individual functions are defined using `compat-define-functions'.
84 Once defined, the functions can be used by wrapping your code in the
85 `compat' macro.
86
87 If GROUP is already defined, nothing happens."
88 (let ((group (eval group)))
89 (or (hash-table-p (compat-hash-table group))
90 (compat-make-hash-table group))))
91
92 (defmacro compat-clear-functions (group)
93 "Clear all defined functions and macros out of GROUP."
94 (let ((group (eval group)))
95 (clrhash (compat-hash-table group))))
96
97 (defmacro compat-define-functions (group &rest body)
98 "Define compatibility functions in GROUP.
99 You should simply wrap this around the code that defines the functions.
100 Any functions and macros defined at top level using `defun' or `defmacro'
101 will be noticed and added to GROUP. Other top-level code will be executed
102 normally. All code and definitions in this group can safely reference any
103 other functions in this group -- the code is effectively wrapped in a
104 `compat' call. You can call `compat-define-functions' more than once, if
105 necessary, for a single group.
106
107 What actually happens is that the functions and macros defined here are in
108 fact defined using names prefixed with GROUP. To use these functions,
109 wrap any calling code with the `compat' macro, which lexically renames
110 the function and macro calls appropriately."
111 (let ((group (eval group)))
112 (let (fundef
113 (body-tail body))
114 (while body-tail
115 (setq fundef (car body-tail))
116 (when (and (consp fundef) (eq (car fundef) 'defun))
117 (puthash (second fundef) (third fundef) (compat-hash-table group)))
118 (when (and (consp fundef) (eq (car fundef) 'defmacro))
119 (puthash (second fundef) (third fundef) (compat-hash-table group)))
120 (setq body-tail (cdr body-tail))))
121 (let (fundef
122 (body-tail body)
123 result)
124 (while body-tail
125 (setq fundef (car body-tail))
126 (push
127 (cond ((and (consp fundef) (eq (car fundef) 'defun))
128 (nconc (list 'defun
129 (intern (concat (symbol-name group) "-"
130 (symbol-name (second fundef))))
131 (third fundef))
132 (nthcdr 3 fundef)))
133 ((and (consp fundef) (eq (car fundef) 'defmacro))
134 (nconc (list 'defmacro
135 (intern (concat (symbol-name group) "-"
136 (symbol-name (second fundef))))
137 (third fundef))
138 (nthcdr 3 fundef)))
139 (t fundef))
140 result)
141 (setq body-tail (cdr body-tail)))
142 (nconc (list 'compat (list 'quote group)) (nreverse result)))))
143
144 (defvar compat-active-groups nil)
145
146 (defun compat-fboundp (groups fun)
147 "T if FUN is either `fboundp' or one of the compatibility funs in GROUPS.
148 GROUPS is a list of compatibility groups as defined using
149 `compat-define-group'."
150 (or (fboundp fun)
151 (block nil
152 (mapcar #'(lambda (group)
153 (if (gethash fun (compat-hash-table group))
154 (return t)))
155 groups))))
156
157 (defmacro compat (group &rest body)
158 "Make use of compatibility functions and macros in GROUP.
159 You should simply wrap this around the code that uses the functions
160 and macros in GROUP. Typically, a call to `compat' should be placed
161 at the top of an ELisp module, with the closing parenthesis at the
162 bottom; use this in place of a `require' statement. Wrapped code can
163 be either function or macro definitions or other ELisp code, and
164 wrapped function or macro definitions need not be at top level. All
165 calls to the compatibility functions or macros will be noticed anywhere
166 within the wrapped code. Calls to `fboundp' within the wrapped code
167 will also behave correctly when called on compatibility functions and
168 macros, even though they would return nil elsewhere (including in code
169 in other modules called dynamically from the wrapped code).
170
171 The functions and macros define in GROUP are actually defined under
172 prefixed names, to avoid namespace clashes and bad interactions with
173 other code that calls `fboundp'. All calls inside of the wrapped code
174 to the compatibility functions and macros in GROUP are lexically
175 mapped to the prefixed names. Since this is a lexical mapping, code
176 in other modules that is called by functions in this module will not
177 be affected."
178 (let ((group (eval group))
179 defs)
180 (maphash
181 #'(lambda (fun args)
182 (push
183 (list fun args
184 (nconc
185 (list 'list
186 (list 'quote
187 (intern (concat (symbol-name group) "-"
188 (symbol-name fun)))))
189 args))
190 defs))
191 (compat-hash-table group))
192 ;; it would be cleaner to use `lexical-let' instead of `let', but that
193 ;; causes function definitions to have obnoxious, unreadable junk in
194 ;; them. #### Move `lexical-let' into C!!!
195 `(let ((compat-active-groups (cons ',group compat-active-groups)))
196 (macrolet ((fboundp (fun) `(compat-fboundp ',compat-active-groups ,fun))
197 ,@defs)
198 ,@body))))