cgit.sxemacs.org Git - sxemacs/blob - lisp/compat.el

   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 SXEmacs.
  10
  11 ;; SXEmacs is free software: you can redistribute it and/or modify
  12 ;; it under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation, either version 3 of the License, or
  14 ;; (at your option) any later version.
  15
  16 ;; SXEmacs is distributed in the hope that it will be useful,
  17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;; GNU General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
  23
  24 ;;; Synched up with: Not in FSF.
  25
  26 ;;; Authorship:
  27
  28 ; Written May 2000 by Ben Wing.
  29
  30 ;;; Commentary:
  31
  32 ;; Typical usage:
  33
  34 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  35 ;; 1. Wrap modules that define compatibility functions like this:     ;;
  36 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  37
  38 ;(compat-define-group 'fsf-compat)
  39
  40 ;(compat-define-functions 'fsf-compat
  41
  42 ;(defun overlayp (object)
  43 ;  "Return t if OBJECT is an overlay."
  44 ;  (and (extentp object)
  45 ;       (extent-property object 'overlay)))
  46
  47 ;(defun make-overlay (beg end &optional buffer front-advance rear-advance)
  48 ;  ...)
  49
  50 ;...
  51
  52 ;) ;; end of (compat-define-group 'fsf-compat)
  53
  54 ;;;; overlay.el ends here
  55
  56
  57 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  58 ;; 2. Wrap modules that use the compatibility functions like this:    ;;
  59 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  60
  61 ;(compat 'fsf-compat
  62
  63 ;(defun random-module-my-fun (bar baz)
  64 ;  (if (fboundp 'overlays-in) (overlays-in bar baz)))
  65
  66 ;...
  67
  68 ;) ;; end of (compat 'fsf-compat)
  69
  70 ;;;; random-module.el ends here
  71
  72
  73 (defun compat-hash-table (group)
  74   (get group 'compat-table))
  75
  76 (defun compat-make-hash-table (group)
  77   (put group 'compat-table (make-hash-table)))
  78
  79 (defmacro compat-define-group (group)
  80   "Define GROUP as a group of compatibility functions.
  81 Individual functions are defined using `compat-define-functions'.
  82 Once defined, the functions can be used by wrapping your code in the
  83 `compat' macro.
  84
  85 If GROUP is already defined, nothing happens."
  86   (let ((group (eval group)))
  87     (or (hash-table-p (compat-hash-table group))
  88         (compat-make-hash-table group))))
  89
  90 (defmacro compat-clear-functions (group)
  91   "Clear all defined functions and macros out of GROUP."
  92   (let ((group (eval group)))
  93     (clrhash (compat-hash-table group))))
  94
  95 (defmacro compat-define-functions (group &rest body)
  96   "Define compatibility functions in GROUP.
  97 You should simply wrap this around the code that defines the functions.
  98 Any functions and macros defined at top level using `defun' or `defmacro'
  99 will be noticed and added to GROUP.  Other top-level code will be executed
 100 normally.  All code and definitions in this group can safely reference any
 101 other functions in this group -- the code is effectively wrapped in a
 102 `compat' call.  You can call `compat-define-functions' more than once, if
 103 necessary, for a single group.
 104
 105 What actually happens is that the functions and macros defined here are in
 106 fact defined using names prefixed with GROUP.  To use these functions,
 107 wrap any calling code with the `compat' macro, which lexically renames
 108 the function and macro calls appropriately."
 109   (let ((group (eval group)))
 110     (let (fundef
 111           (body-tail body))
 112       (while body-tail
 113         (setq fundef (car body-tail))
 114         (when (and (consp fundef) (eq (car fundef) 'defun))
 115           (puthash (second fundef) (third fundef) (compat-hash-table group)))
 116         (when (and (consp fundef) (eq (car fundef) 'defmacro))
 117           (puthash (second fundef) (third fundef) (compat-hash-table group)))
 118         (setq body-tail (cdr body-tail))))
 119     (let (fundef
 120           (body-tail body)
 121           result)
 122       (while body-tail
 123         (setq fundef (car body-tail))
 124         (push
 125          (cond ((and (consp fundef) (eq (car fundef) 'defun))
 126                 (nconc (list 'defun
 127                               (intern (concat (symbol-name group) "-"
 128                                               (symbol-name (second fundef))))
 129                               (third fundef))
 130                         (nthcdr 3 fundef)))
 131                ((and (consp fundef) (eq (car fundef) 'defmacro))
 132                 (nconc (list 'defmacro
 133                               (intern (concat (symbol-name group) "-"
 134                                               (symbol-name (second fundef))))
 135                               (third fundef))
 136                         (nthcdr 3 fundef)))
 137                (t fundef))
 138          result)
 139         (setq body-tail (cdr body-tail)))
 140       (nconc (list 'compat (list 'quote group)) (nreverse result)))))
 141
 142 (defvar compat-active-groups nil)
 143
 144 (defun compat-fboundp (groups fun)
 145   "T if FUN is either `fboundp' or one of the compatibility funs in GROUPS.
 146 GROUPS is a list of compatibility groups as defined using
 147 `compat-define-group'."
 148   (or (fboundp fun)
 149       (block nil
 150         (mapcar #'(lambda (group)
 151                     (if (gethash fun (compat-hash-table group))
 152                         (return t)))
 153                 groups))))
 154
 155 (defmacro compat (group &rest body)
 156   "Make use of compatibility functions and macros in GROUP.
 157 You should simply wrap this around the code that uses the functions
 158 and macros in GROUP.  Typically, a call to `compat' should be placed
 159 at the top of an ELisp module, with the closing parenthesis at the
 160 bottom; use this in place of a `require' statement.  Wrapped code can
 161 be either function or macro definitions or other ELisp code, and
 162 wrapped function or macro definitions need not be at top level.  All
 163 calls to the compatibility functions or macros will be noticed anywhere
 164 within the wrapped code.  Calls to `fboundp' within the wrapped code
 165 will also behave correctly when called on compatibility functions and
 166 macros, even though they would return nil elsewhere (including in code
 167 in other modules called dynamically from the wrapped code).
 168
 169 The functions and macros define in GROUP are actually defined under
 170 prefixed names, to avoid namespace clashes and bad interactions with
 171 other code that calls `fboundp'.  All calls inside of the wrapped code
 172 to the compatibility functions and macros in GROUP are lexically
 173 mapped to the prefixed names.  Since this is a lexical mapping, code
 174 in other modules that is called by functions in this module will not
 175 be affected."
 176   (let ((group (eval group))
 177         defs)
 178     (maphash
 179      #'(lambda (fun args)
 180          (push
 181           (list fun args
 182                 (nconc
 183                  (list 'list
 184                        (list 'quote
 185                              (intern (concat (symbol-name group) "-"
 186                                              (symbol-name fun)))))
 187                  args))
 188           defs))
 189      (compat-hash-table group))
 190     ;; it would be cleaner to use `lexical-let' instead of `let', but that
 191     ;; causes function definitions to have obnoxious, unreadable junk in
 192     ;; them.  #### Move `lexical-let' into C!!!
 193     `(let ((compat-active-groups (cons ',group compat-active-groups)))
 194        (macrolet ((fboundp (fun) `(compat-fboundp ',compat-active-groups ,fun))
 195                   ,@defs)
 196          ,@body))))