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 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))))