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

   1 ;;; symbols.el --- functions for working with symbols and symbol values
   2
   3 ;; Copyright (C) 1996 Ben Wing.
   4
   5 ;; Maintainer: SXEmacs Development Team
   6 ;; Keywords: internal
   7
   8 ;; This file is part of SXEmacs.
   9
  10 ;; SXEmacs is free software: you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation, either version 3 of the License, or
  13 ;; (at your option) any later version.
  14
  15 ;; SXEmacs is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
  22
  23 ;;; Synched up with: Not in FSF.
  24
  25 ;;; Commentary:
  26
  27 ;; Not yet dumped into SXEmacs.
  28
  29 ;; The idea behind magic variables is that you can specify arbitrary
  30 ;; behavior to happen when setting or retrieving a variable's value.  The
  31 ;; purpose of this is to make it possible to cleanly provide support for
  32 ;; obsolete variables (e.g. unread-command-event, which is obsolete for
  33 ;; unread-command-events) and variable compatibility
  34 ;; (e.g. suggest-key-bindings, the FSF equivalent of
  35 ;; teach-extended-commands-p and teach-extended-commands-timeout).
  36
  37 ;; There are a large number of functions pertaining to a variable's
  38 ;; value:
  39
  40 ;; boundp
  41 ;; globally-boundp
  42 ;; makunbound
  43 ;; symbol-value
  44 ;; set / setq
  45 ;; default-boundp
  46 ;; default-value
  47 ;; set-default / setq-default
  48 ;; make-variable-buffer-local
  49 ;; make-local-variable
  50 ;; kill-local-variable
  51 ;; kill-console-local-variable
  52 ;; symbol-value-in-buffer
  53 ;; symbol-value-in-console
  54 ;; local-variable-p / local-variable-if-set-p
  55
  56 ;; Plus some "meta-functions":
  57
  58 ;; defvaralias
  59 ;; variable-alias
  60 ;; indirect-variable
  61
  62 ;; I wanted an implementation that:
  63
  64 ;; -- would work with all the above functions, but (a) didn't require
  65 ;;    a separate handler for every function, and (b) would work OK
  66 ;;    even if more functions are added (e.g. `set-symbol-value-in-buffer'
  67 ;;    or `makunbound-default') or if more arguments are added to a
  68 ;;    function.
  69 ;; -- avoided consing if at all possible.
  70 ;; -- didn't slow down operations on non-magic variables (therefore,
  71 ;;    storing the magic information using `put' is ruled out).
  72 ;;
  73
  74 ;;; Code:
  75
  76 ;; perhaps this should check whether the functions are bound, so that
  77 ;; some handlers can be unspecified.  That requires that all functions
  78 ;; are defined before `define-magic-variable-handlers' is called,
  79 ;; though.
  80
  81 ;; perhaps there should be something that combines
  82 ;; `define-magic-variable-handlers' with `defvaralias'.
  83
  84 (globally-declare-fboundp
  85  '(set-magic-variable-handler))
  86
  87 (defun define-magic-variable-handlers (variable handler-class harg)
  88   "Set the magic variable handles for VARIABLE to those in HANDLER-CLASS.
  89 HANDLER-CLASS should be a symbol.  The handlers are constructed by adding
  90 the handler type to HANDLER-CLASS.  HARG is passed as the HARG value for
  91 each of the handlers."
  92   (mapcar
  93    #'(lambda (htype)
  94        (set-magic-variable-handler variable htype
  95                                    (intern (concat (symbol-value handler-class)
  96                                                    "-"
  97                                                    (symbol-value htype)))
  98                                    harg))
  99    '(get-value set-value other-predicate other-action)))
 100
 101 ;; unread-command-event
 102
 103 (defun mvh-first-of-list-get-value (sym fun args harg)
 104   (car (apply fun harg args)))
 105
 106 (defun mvh-first-of-list-set-value (sym value setfun getfun args harg)
 107   (apply setfun harg (cons value (apply getfun harg args)) args))
 108
 109 (defun mvh-first-of-list-other-predicate (sym fun args harg)
 110   (apply fun harg args))
 111
 112 (defun mvh-first-of-list-other-action (sym fun args harg)
 113   (apply fun harg args))
 114
 115 (define-magic-variable-handlers 'unread-command-event
 116   'mvh-first-of-list
 117   'unread-command-events)
 118
 119 ;; last-command-char, last-input-char, unread-command-char
 120
 121 (defun mvh-char-to-event-get-value (sym fun args harg)
 122   (event-to-character (apply fun harg args)))
 123
 124 (defun mvh-char-to-event-set-value (sym value setfun getfun args harg)
 125   (let ((event (apply getfun harg args)))
 126        (if (event-live-p event)
 127            nil
 128          (setq event (make-event))
 129          (apply setfun harg event args))
 130        (character-to-event value event)))
 131
 132 (defun mvh-char-to-event-other-predicate (sym fun args harg)
 133   (apply fun harg args))
 134
 135 (defun mvh-char-to-event-other-action (sym fun args harg)
 136   (apply fun harg args))
 137
 138 (define-magic-variable-handlers 'last-command-char
 139   'mvh-char-to-event
 140   'last-command-event)
 141
 142 (define-magic-variable-handlers 'last-input-char
 143   'mvh-char-to-event
 144   'last-input-event)
 145
 146 (define-magic-variable-handlers 'unread-command-char
 147   'mvh-char-to-event
 148   'unread-command-event)
 149
 150 ;; suggest-key-bindings
 151
 152 (set-magic-variable-handler
 153  'suggest-key-bindings 'get-value
 154  #'(lambda (sym fun args harg)
 155      (and (apply fun 'teach-extended-commands-p args)
 156           (apply fun 'teach-extended-commands-timeout args))))
 157
 158 (set-magic-variable-handler
 159  'suggest-key-bindings 'set-value
 160  #'(lambda (sym value setfun getfun args harg)
 161      (apply setfun 'teach-extended-commands-p (not (null value)) args)
 162      (if value
 163          (apply 'teach-extended-commands-timeout
 164                (if (numberp value) value 2) args))))
 165
 166 (set-magic-variable-handler
 167  'suggest-key-bindings 'other-action
 168  #'(lambda (sym fun args harg)
 169      (apply fun 'teach-extended-commands-p args)
 170      (apply fun 'teach-extended-commands-timeout args)))
 171
 172 (set-magic-variable-handler
 173  'suggest-key-bindings 'other-predicate
 174  #'(lambda (sym fun args harg)
 175      (and (apply fun 'teach-extended-commands-p args)
 176           (apply fun 'teach-extended-commands-timeout args))))
 177
 178 ;;; symbols.el ends here