Mercurial > hg > xemacs-beta

comparison lisp/behavior.el @ 800:a5954632b187

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
[xemacs-hg @ 2002-03-31 08:27:14 by ben] more fixes, first crack at finishing behavior implementation TODO.ben-mule-21-5: Update. configure.in: Fix for new error-checking types. make-mswin-unicode.pl: Don't be fucked up by CRLF. Output code to force errors when nonintercepted Windows calls issued. behavior.el, dumped-lisp.el, menubar-items.el: Add support for saving using custom. Load into a dumped XEmacs. Correct :title to :short-doc in accordance with behavior-defs.el. Add a submenu under Options for turning on/off behaviors. cl-macs.el: Properly document `loop'. Fix a minor bug in keymap iteration and add support for bit-vector iteration. lisp-mode.el: Rearrange and add items for macro expanding. menubar-items.el: Document connection between these two functions. window.el: Port stuff from GNU 21.1. config.inc.samp, xemacs.mak: Separate out and add new variable for controlling error-checking. s/windowsnt.h: Use new ERROR_CHECK_ALL; not related to DEBUG_XEMACS. alloc.c, backtrace.h, buffer.c, buffer.h, bytecode.c, callproc.c, casetab.c, charset.h, chartab.c, cmdloop.c, config.h.in, console-msw.c, console-stream.c, console-tty.c, console.c, console.h, data.c, device-msw.c, device.c, device.h, dired-msw.c, dired.c, dumper.c, editfns.c, eldap.c, elhash.c, emacs.c, eval.c, event-Xt.c, event-gtk.c, event-msw.c, event-stream.c, events.c, extents.c, faces.c, file-coding.c, file-coding.h, fileio.c, frame-msw.c, frame.c, frame.h, glyphs-gtk.c, glyphs-msw.c, glyphs-shared.c, glyphs-widget.c, glyphs-x.c, glyphs.c, glyphs.h, insdel.c, intl-auto-encap-win32.c, intl-auto-encap-win32.h, intl-encap-win32.c, intl-win32.c, keymap.c, lisp-union.h, lisp.h, lread.c, lrecord.h, lstream.c, lstream.h, macros.c, marker.c, md5.c, menubar-x.c, menubar.c, mule-coding.c, ntproc.c, objects-gtk.c, objects-msw.c, objects-x.c, objects.c, opaque.c, print.c, process-nt.c, process-unix.c, process.c, rangetab.c, redisplay-msw.c, redisplay-output.c, redisplay.c, regex.c, scrollbar-msw.c, select-msw.c, signal.c, specifier.c, specifier.h, symbols.c, sysdep.c, syswindows.h, text.c, text.h, toolbar-msw.c, tooltalk.c, ui-gtk.c, unicode.c, window.c: Redo error-checking macros: ERROR_CHECK_TYPECHECK -> ERROR_CHECK_TYPES, ERROR_CHECK_CHARBPOS -> ERROR_CHECK_TEXT, add ERROR_CHECK_DISPLAY, ERROR_CHECK_STRUCTURES. Document these in config.h.in. Fix code to follow docs. Fix *_checking_assert() in accordance with new names. Attempt to fix periodic redisplay crash freeing display line structures. Add first implementation of sledgehammer redisplay check. Redo print_*() to use write_fmt_string(), write_fmt_string_lisp(). Fix bug in md5 handling. Rename character-to-unicode to char-to-unicode; same for unicode-to-char{acter}. Move chartab documentation to `make-char-table'. Some header cleanup. Clean up remaining places where nonintercepted Windows calls are being used. automated/mule-tests.el: Fix for new Unicode support.
author ben
date Sun, 31 Mar 2002 08:30:17 +0000
parents 7039e6323819
children 7da79fbe37bb
comparison
equal deleted inserted replaced
799:03d9f9084848 800:a5954632b187
1 ;;; behavior.el --- consistent interface onto behaviors 1 ;;; behavior.el --- consistent interface onto behaviors
2 2
3 ;; Copyright (C) 2000, 2001 Ben Wing. 3 ;; Copyright (C) 2000, 2001, 2002 Ben Wing.
4 4
5 ;; Author: Ben Wing 5 ;; Author: Ben Wing
6 ;; Maintainer: XEmacs Development Team 6 ;; Maintainer: XEmacs Development Team
7 ;; Keywords: internal, dumped 7 ;; Keywords: internal, dumped
8 8
33 33
34 ;; This file will be dumped with XEmacs. 34 ;; This file will be dumped with XEmacs.
35 35
36 ;;; Code: 36 ;;; Code:
37 37
38 (defvar behavior-hash-table (make-hash-table)) 38 ;; Hash table mapping behavior names to property lists, with entries for
39 ;; :short-doc, :require, :enable, and :disable.
40 (defconst behavior-hash-table (make-hash-table))
41
42 (defvar within-behavior-enabling-disabling nil)
43
44 (defgroup behaviors nil
45 "Behaviors -- high-level functionality interface.")
46
47 ;; List of enabled behaviors.
48 (defcustom enabled-behavior-list nil
49 "List of currently enabled behaviors.
50 Normally, don't set it directly; use `enable-behavior' or `disable-behavior'."
51 :initialize #'set-default
52 :set #'(lambda (sym val)
53 (if within-behavior-enabling-disabling
54 (set sym val)
55 (let* ((old-val enabled-behavior-list)
56 (disable-list (set-difference old-val val))
57 (enable-list (set-difference val old-val)))
58 (dolist (b disable-list)
59 (disable-behavior b t))
60 (dolist (b enable-list)
61 (enable-behavior b t))
62 (assert (equal enabled-behavior-list val)))))
63 :type '(repeat (symbol :tag "Behavior"))
64 :group 'behaviors)
65
39 66
40 (defvar behavior-history nil 67 (defvar behavior-history nil
41 "History of entered behaviors.") 68 "History of entered behaviors.")
42 69
43 (defun define-behavior (name doc-string &rest cl-keys) 70 (defun define-behavior (name doc-string &rest cl-keys)
44 "Define a behavior named NAME. 71 "Define a behavior named NAME.
45 DOC-STRING must be specified, a description of what the behavior does 72 DOC-STRING must be specified, a description of what the behavior does
46 when it's enabled and how to further control it (typically through 73 when it's enabled and how to further control it (typically through
47 custom variables). Accepted keywords are 74 custom variables). Accepted keywords are
48 75
49 :title A \"pretty\" version of the name, for use in menus. If omitted 76 :short-doc A \"pretty\" version of the name, for use in menus. If omitted
50 a prettified name will be generated. 77 a prettified name will be generated.
51 :require A single symbol or a list of such symbols, which need to be 78 :require A single symbol or a list of such symbols, which need to be
52 present at enable time, or will be loaded using `require'. 79 present at enable time, or will be loaded using `require'.
53 :enable A function of no variables, which turns the behavior on. 80 :enable A function of no variables, which turns the behavior on.
54 :disable A function of no variables, which turns the behavior off. 81 :disable A function of no variables, which turns the behavior off.
55 82
56 Behaviors are assumed to be global, and to take effect immediately; if 83 Behaviors are assumed to be global, and to take effect immediately; if
57 the underlying package is per-buffer, it may have to scan all existing 84 the underlying package is per-buffer, it may have to scan all existing
58 buffers and frob them. When a behavior is disabled, it should completely 85 buffers and frob them. When a behavior is disabled, it should completely
59 go away *everywhere*, as if it were never invoked at all. 86 go away *everywhere*, as if it were never invoked at all.
60 87
61 The :disable keywords can be missing, although this is considered bad 88 The :disable keywords can be missing, although this is considered bad
62 practice. In such a case, attempting to disable the behavior will signal 89 practice. In such a case, attempting to disable the behavior will signal
63 an error unless you use the `force' option." 90 an error unless you use the `force' option."
64 (cl-parsing-keywords 91 (cl-parsing-keywords
65 ((:title (capitalize-string-as-title (replace-in-string 92 ((:short-doc (capitalize-string-as-title (replace-in-string
66 (symbol-name name) "-" " "))) 93 (symbol-name name) "-" " ")))
67 :require 94 :require
68 :enable 95 :enable
69 :disable) 96 :disable)
70 () 97 ()
71 (let ((entry (list :title cl-title :require cl-require 98 (let ((entry (list :short-doc cl-short-doc :require cl-require
72 :enable cl-enable :disable cl-disable))) 99 :enable cl-enable :disable cl-disable)))
73 (puthash name entry behavior-hash-table)))) 100 (puthash name entry behavior-hash-table))))
74 101
75 (defun read-behavior (prompt &optional must-match initial-contents history 102 (defun read-behavior (prompt &optional must-match initial-contents history
76 default-value) 103 default-value)
100 default-value))) 127 default-value)))
101 (if (and result (stringp result)) 128 (if (and result (stringp result))
102 (intern result) 129 (intern result)
103 result))) 130 result)))
104 131
105 (defun behavior-enabled-p (name)) 132 (defun behavior-enabled-p (behavior)
133 "Non-nil if BEHAVIOR (a symbol) if currently enabled."
134 (memq behavior enabled-behavior-list))
106 135
107 (defun enable-behavior (behavior &optional force) 136 (defun enable-behavior (behavior &optional force)
108 "Enable the specified behavior." 137 "Enable the specified behavior."
109 (interactive (list (read-behavior "Enable Behavior: " t) current-prefix-arg)) 138 (interactive (list (read-behavior "Enable Behavior: " t) current-prefix-arg))
110 (let ((plist (gethash behavior behavior-hash-table))) 139 (let ((plist (gethash behavior behavior-hash-table)))
111 (or plist (error 'invalid-argument "Not a behavior" behavior)) 140 (or plist (error 'invalid-argument "Not a behavior" behavior))
141 (or force (not (memq behavior enabled-behavior-list))
142 (error 'invalid-change "Behavior already enabled" behavior))
112 (let ((require (getf plist :require)) 143 (let ((require (getf plist :require))
113 (enable (getf plist :enable))) 144 (enable (getf plist :enable)))
114 (cond ((listp require) 145 (cond ((listp require)
115 (mapc #'(lambda (sym) (require sym)) require)) 146 (mapc #'(lambda (sym) (require sym)) require))
116 ((symbolp require) 147 ((symbolp require)
117 (require require)) 148 (require require))
118 ((null require)) 149 ((null require))
119 (t (error 'invalid-argument "Invalid :require spec" require))) 150 (t (error 'invalid-argument "Invalid :require spec" require)))
120 (if enable (funcall enable))))) 151 (message "Enabling behavior %s..." behavior)
152 (if enable (funcall enable))
153 (message "Enabling behavior %s...done" behavior)
154 (let ((within-behavior-enabling-disabling t))
155 (customize-set-variable 'enabled-behavior-list
156 (cons behavior enabled-behavior-list))))))
121 157
122 (defun disable-behavior (behavior &optional force) 158 (defun disable-behavior (behavior &optional force)
123 "Disable the specified behavior." 159 "Disable the specified behavior."
124 (interactive (list (read-behavior "Disable Behavior: " t) 160 (interactive (list (read-behavior "Disable Behavior: " t)
125 current-prefix-arg)) 161 current-prefix-arg))
126 (let ((plist (gethash behavior behavior-hash-table))) 162 (let ((plist (gethash behavior behavior-hash-table)))
127 (or plist (error 'invalid-argument "Not a behavior" behavior)) 163 (or plist (error 'invalid-argument "Not a behavior" behavior))
164 (or force (memq behavior enabled-behavior-list)
165 (error 'invalid-change "Behavior not enabled" behavior))
128 (let ((require (getf plist :require)) 166 (let ((require (getf plist :require))
129 (disable (getf plist :disable))) 167 (disable (getf plist :disable)))
130 (cond ((listp require) 168 (cond ((listp require)
131 (mapc #'(lambda (sym) (require sym)) require)) 169 (mapc #'(lambda (sym) (require sym)) require))
132 ((symbolp require) 170 ((symbolp require)
133 (require require)) 171 (require require))
134 ((null require)) 172 ((null require))
135 (t (error 'invalid-argument "Invalid :require spec" require))) 173 (t (error 'invalid-argument "Invalid :require spec" require)))
136 (if disable (funcall disable))))) 174 (message "Disabling behavior %s..." behavior)
175 (if disable (funcall disable))
176 (message "Disabling behavior %s...done" behavior)
177 (let ((within-behavior-enabling-disabling t))
178 (customize-set-variable 'enabled-behavior-list
179 (delq behavior enabled-behavior-list))))))
137 180
138 (provide 'behavior) 181 (provide 'behavior)
139 182
140 ;;; finder-inf.el ends here 183 ;;; finder-inf.el ends here