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