(insert-ideograph-radical-char-data): Use `insert-char-data' with new

[chise/xemacs-chise.git-] / lisp / subr.el

diff --git a/lisp/subr.el b/lisp/subr.el
index 94a6071..fa38653 100644 (file)
--- a/lisp/subr.el
+++ b/lisp/subr.el
@@ -3,6 +3,7 @@
 ;; Copyright (C) 1985, 1986, 1992, 1994-5, 1997 Free Software Foundation, Inc.
 ;; Copyright (C) 1995 Tinker Systems and INS Engineering Corp.
 ;; Copyright (C) 1995 Sun Microsystems.
 ;; Copyright (C) 1985, 1986, 1992, 1994-5, 1997 Free Software Foundation, Inc.
 ;; Copyright (C) 1995 Tinker Systems and INS Engineering Corp.
 ;; Copyright (C) 1995 Sun Microsystems.

+;; Copyright (C) 2000 Ben Wing.

 
 ;; Maintainer: XEmacs Development Team
 ;; Keywords: extensions, dumped
 
 ;; Maintainer: XEmacs Development Team
 ;; Keywords: extensions, dumped

@@ -117,7 +118,9 @@ one.
 This function does nothing if HOOK is already local in the current
 buffer.
 
 This function does nothing if HOOK is already local in the current
 buffer.
 

-Do not use `make-local-variable' to make a hook variable buffer-local."
+Do not use `make-local-variable' to make a hook variable buffer-local.
+
+See also `add-local-hook' and `remove-local-hook'."

   (if (local-variable-p hook (current-buffer)) ; XEmacs
       nil
     (or (boundp hook) (set hook nil))
   (if (local-variable-p hook (current-buffer)) ; XEmacs
       nil
     (or (boundp hook) (set hook nil))

@@ -139,7 +142,11 @@ To make a hook variable buffer-local, always use
 
 HOOK should be a symbol, and FUNCTION may be any valid function.  If
 HOOK is void, it is first set to nil.  If HOOK's value is a single
 
 HOOK should be a symbol, and FUNCTION may be any valid function.  If
 HOOK is void, it is first set to nil.  If HOOK's value is a single

-function, it is changed to a list of functions."
+function, it is changed to a list of functions.
+
+You can remove this hook yourself using `remove-hook'.
+
+See also `add-local-hook' and `add-one-shot-hook'."

   (or (boundp hook) (set hook nil))
   (or (default-boundp hook) (set-default hook nil))
   ;; If the hook value is a single function, turn it into a list.
   (or (boundp hook) (set hook nil))
   (or (default-boundp hook) (set-default hook nil))
   ;; If the hook value is a single function, turn it into a list.

@@ -185,25 +192,114 @@ To make a hook variable buffer-local, always use
          (null (symbol-value hook))    ;value is nil, or
          (null function))              ;function is nil, then
       nil                              ;Do nothing.
          (null (symbol-value hook))    ;value is nil, or
          (null function))              ;function is nil, then
       nil                              ;Do nothing.

-    (if (or local
-           ;; Detect the case where make-local-variable was used on a hook
-           ;; and do what we used to do.
-           (and (local-variable-p hook (current-buffer))
-                (not (memq t (symbol-value hook)))))
-       (let ((hook-value (symbol-value hook)))
-         (if (and (consp hook-value) (not (functionp hook-value)))
-             (if (member function hook-value)
-                 (setq hook-value (delete function (copy-sequence hook-value))))
-           (if (equal hook-value function)
-               (setq hook-value nil)))
-         (set hook hook-value))
-      (let ((hook-value (default-value hook)))
-       (if (and (consp hook-value) (not (functionp hook-value)))
-           (if (member function hook-value)
-               (setq hook-value (delete function (copy-sequence hook-value))))
-         (if (equal hook-value function)
-             (setq hook-value nil)))
-       (set-default hook hook-value)))))
+    (flet ((hook-remove
+           (function hook-value)
+           (flet ((hook-test
+                   (fn hel)
+                   (or (equal fn hel)
+                       (and (symbolp hel)
+                            (equal fn
+                                   (get hel 'one-shot-hook-fun))))))
+             (if (and (consp hook-value)
+                      (not (functionp hook-value)))
+                 (if (member* function hook-value :test 'hook-test)
+                     (setq hook-value
+                           (delete* function (copy-sequence hook-value)
+                                    :test 'hook-test)))
+               (if (equal hook-value function)
+                   (setq hook-value nil)))
+             hook-value)))
+      (if (or local
+             ;; Detect the case where make-local-variable was used on a hook
+             ;; and do what we used to do.
+             (and (local-variable-p hook (current-buffer))
+                  (not (memq t (symbol-value hook)))))
+         (set hook (hook-remove function (symbol-value hook)))
+       (set-default hook (hook-remove function (default-value hook)))))))
+
+;; XEmacs addition
+;; #### we need a coherent scheme for indicating compatibility info,
+;; so that it can be programmatically retrieved.
+(defun add-local-hook (hook function &optional append)
+  "Add to the local value of HOOK the function FUNCTION.
+This modifies only the buffer-local value for the hook (which is
+automatically make buffer-local, if necessary), not its default value.
+FUNCTION is not added if already present.
+FUNCTION is added (if necessary) at the beginning of the hook list
+unless the optional argument APPEND is non-nil, in which case
+FUNCTION is added at the end.
+
+HOOK should be a symbol, and FUNCTION may be any valid function.  If
+HOOK is void, it is first set to nil.  If HOOK's value is a single
+function, it is changed to a list of functions.
+
+You can remove this hook yourself using `remove-local-hook'.
+
+See also `add-hook' and `make-local-hook'."
+  (make-local-hook hook)
+  (add-hook hook function append t))
+
+;; XEmacs addition
+(defun remove-local-hook (hook function)
+  "Remove from the local value of HOOK the function FUNCTION.
+This modifies only the buffer-local value for the hook, not its default
+value. (Nothing happens if the hook is not buffer-local.)
+HOOK should be a symbol, and FUNCTION may be any valid function.  If
+FUNCTION isn't the value of HOOK, or, if FUNCTION doesn't appear in the
+list of hooks to run in HOOK, then nothing is done.  See `add-hook'.
+
+See also `add-local-hook' and `make-local-hook'."
+  (if (local-variable-p hook (current-buffer))
+      (remove-hook hook function t)))
+
+(defun add-one-shot-hook (hook function &optional append local)
+  "Add to the value of HOOK the one-shot function FUNCTION.
+FUNCTION will automatically be removed from the hook the first time
+after it runs (whether to completion or to an error).
+FUNCTION is not added if already present.
+FUNCTION is added (if necessary) at the beginning of the hook list
+unless the optional argument APPEND is non-nil, in which case
+FUNCTION is added at the end.
+
+HOOK should be a symbol, and FUNCTION may be any valid function.  If
+HOOK is void, it is first set to nil.  If HOOK's value is a single
+function, it is changed to a list of functions.
+
+You can remove this hook yourself using `remove-hook'.
+
+See also `add-hook', `add-local-hook', and `add-local-one-shot-hook'."
+  (let ((sym (gensym)))
+    (fset sym `(lambda (&rest args)
+                (unwind-protect
+                    (apply ',function args)
+                  (remove-hook ',hook ',sym ',local))))
+    (put sym 'one-shot-hook-fun function)
+    (add-hook hook sym append local)))
+
+(defun add-local-one-shot-hook (hook function &optional append)
+  "Add to the local value of HOOK the one-shot function FUNCTION.
+FUNCTION will automatically be removed from the hook the first time
+after it runs (whether to completion or to an error).
+FUNCTION is not added if already present.
+FUNCTION is added (if necessary) at the beginning of the hook list
+unless the optional argument APPEND is non-nil, in which case
+FUNCTION is added at the end.
+
+The optional fourth argument, LOCAL, if non-nil, says to modify
+the hook's buffer-local value rather than its default value.
+This makes no difference if the hook is not buffer-local.
+To make a hook variable buffer-local, always use
+`make-local-hook', not `make-local-variable'.
+
+HOOK should be a symbol, and FUNCTION may be any valid function.  If
+HOOK is void, it is first set to nil.  If HOOK's value is a single
+function, it is changed to a list of functions.
+
+You can remove this hook yourself using `remove-local-hook'.
+
+See also `add-hook', `add-local-hook', and `add-local-one-shot-hook'."
+  (make-local-hook hook)
+  (add-one-shot-hook hook function append t))

 
 (defun add-to-list (list-var element)
   "Add to the value of LIST-VAR the element ELEMENT if it isn't there yet.
 
 (defun add-to-list (list-var element)
   "Add to the value of LIST-VAR the element ELEMENT if it isn't there yet.

@@ -239,6 +335,22 @@ just before emacs is actually killed.")
 (define-function 'rplaca 'setcar)
 (define-function 'rplacd 'setcdr)
 
 (define-function 'rplaca 'setcar)
 (define-function 'rplacd 'setcdr)
 

+(defun copy-symbol (symbol &optional copy-properties)
+  "Return a new uninterned symbol with the same name as SYMBOL.
+If COPY-PROPERTIES is non-nil, the new symbol will have a copy of
+SYMBOL's value, function, and property lists."
+  (let ((new (make-symbol (symbol-name symbol))))
+    (when copy-properties
+      ;; This will not copy SYMBOL's chain of forwarding objects, but
+      ;; I think that's OK.  Callers should not expect such magic to
+      ;; keep working in the copy in the first place.
+      (and (boundp symbol)
+          (set new (symbol-value symbol)))
+      (and (fboundp symbol)
+          (fset new (symbol-function symbol)))
+      (setplist new (copy-list (symbol-plist symbol))))
+    new))
+

 ;;;; String functions.
 
 ;; XEmacs
 ;;;; String functions.
 
 ;; XEmacs

@@ -323,7 +435,8 @@ If PATTERN is omitted, it defaults to \"[ \\f\\t\\n\\r\\v]+\"."
   "Collect output to `standard-output' while evaluating FORMS and return
 it as a string."
   ;; by "William G. Dubuque" <wgd@zurich.ai.mit.edu> w/ mods from Stig
   "Collect output to `standard-output' while evaluating FORMS and return
 it as a string."
   ;; by "William G. Dubuque" <wgd@zurich.ai.mit.edu> w/ mods from Stig

-  `(with-current-buffer (get-buffer-create " *string-output*")
+  `(with-current-buffer (get-buffer-create
+                        (generate-new-buffer-name " *string-output*"))

      (setq buffer-read-only nil)
      (buffer-disable-undo (current-buffer))
      (erase-buffer)
      (setq buffer-read-only nil)
      (buffer-disable-undo (current-buffer))
      (erase-buffer)

@@ -334,7 +447,7 @@ it as a string."
        (erase-buffer))))
 
 (defmacro with-current-buffer (buffer &rest body)
        (erase-buffer))))
 
 (defmacro with-current-buffer (buffer &rest body)

-  "Execute the forms in BODY with BUFFER as the current buffer.
+  "Temporarily make BUFFER the current buffer and execute the forms in BODY.

 The value returned is the value of the last form in BODY.
 See also `with-temp-buffer'."
   `(save-current-buffer
 The value returned is the value of the last form in BODY.
 See also `with-temp-buffer'."
   `(save-current-buffer

@@ -377,16 +490,10 @@ See also `with-temp-file' and `with-output-to-string'."
   "With the contents of the current buffer being STR, run BODY.
 Returns the new contents of the buffer, as modified by BODY.
 The original current buffer is restored afterwards."
   "With the contents of the current buffer being STR, run BODY.
 Returns the new contents of the buffer, as modified by BODY.
 The original current buffer is restored afterwards."

-  `(let ((tempbuf (get-buffer-create " *string-as-buffer-contents*")))
-     (with-current-buffer tempbuf
-       (unwind-protect
-          (progn
-            (buffer-disable-undo (current-buffer))
-            (erase-buffer)
-            (insert ,str)
-            ,@body
-            (buffer-string))
-        (erase-buffer tempbuf)))))
+  `(with-temp-buffer
+     (insert ,str)
+     ,@body
+     (buffer-string)))

 
 (defun insert-face (string face)
   "Insert STRING and highlight with FACE.  Return the extent created."
 
 (defun insert-face (string face)
   "Insert STRING and highlight with FACE.  Return the extent created."

@@ -569,9 +676,6 @@ This function accepts any number of arguments, but ignores them."
   (interactive)
   nil)
 
   (interactive)
   nil)
 

-(define-function 'mapc-internal 'mapc)
-(make-obsolete 'mapc-internal 'mapc)
-

 (define-function 'eval-in-buffer 'with-current-buffer)
 (make-obsolete 'eval-in-buffer 'with-current-buffer)
 
 (define-function 'eval-in-buffer 'with-current-buffer)
 (make-obsolete 'eval-in-buffer 'with-current-buffer)
 

@@ -618,6 +722,12 @@ If FUNCTION is not interactive, nil will be returned."
        (t
         (error "Non-funcallable object: %s" function))))
 
        (t
         (error "Non-funcallable object: %s" function))))
 

+(defun function-allows-args (function n)
+  "Return whether FUNCTION can be called with N arguments."
+  (and (<= (function-min-args function) n)
+       (or (null (function-max-args function))
+          (<= n (function-max-args function)))))
+

 ;; This function used to be an alias to `buffer-substring', except
 ;; that FSF Emacs 20.4 added a BUFFER argument in an incompatible way.
 ;; The new FSF's semantics makes more sense, but we try to support
 ;; This function used to be an alias to `buffer-substring', except
 ;; that FSF Emacs 20.4 added a BUFFER argument in an incompatible way.
 ;; The new FSF's semantics makes more sense, but we try to support

@@ -632,13 +742,17 @@ If BUFFER is specified, the contents of that buffer are returned.
 The arguments OLD-END and OLD-BUFFER are supported for backward
 compatibility with pre-21.2 XEmacsen times when arguments to this
 function were (buffer-string &optional START END BUFFER)."
 The arguments OLD-END and OLD-BUFFER are supported for backward
 compatibility with pre-21.2 XEmacsen times when arguments to this
 function were (buffer-string &optional START END BUFFER)."

-  (if (or (null buffer)
-         (bufferp buffer)
-         (stringp buffer))
-      ;; The new way
-      (buffer-substring nil nil buffer)
-    ;; The old way
-    (buffer-substring buffer old-end old-buffer)))
+  (cond
+   ((or (stringp buffer) (bufferp buffer))
+    ;; Most definitely the new way.
+    (buffer-substring nil nil buffer))
+   ((or (stringp old-buffer) (bufferp old-buffer)
+       (natnump buffer) (natnump old-end))
+    ;; Definitely the old way.
+    (buffer-substring buffer old-end old-buffer))
+   (t
+    ;; Probably the old way.
+    (buffer-substring buffer old-end old-buffer))))

 
 ;; This was not present before.  I think Jamie had some objections
 ;; to this, so I'm leaving this undefined for now. --ben
 
 ;; This was not present before.  I think Jamie had some objections
 ;; to this, so I'm leaving this undefined for now. --ben

@@ -682,16 +796,6 @@ FILE should be the name of a library, with no directory name."
   (eval-after-load file (read)))
 (make-compatible 'eval-next-after-load "")
 
   (eval-after-load file (read)))
 (make-compatible 'eval-next-after-load "")
 

-(unless (featurep 'mule)
-  (defun make-char (charset &optional arg1 arg2)
-    "Make a character from CHARSET and octets ARG1 and ARG2.
-This function is available for compatibility with Mule-enabled XEmacsen.
-When CHARSET is `ascii', return (int-char ARG1).  Otherwise, return
-that value with the high bit set.  ARG2 is always ignored."
-    (int-char (if (eq charset 'ascii)
-                 arg1
-               (logior arg1 #x80)))))
-

 ; alternate names (not obsolete)
 (if (not (fboundp 'mod)) (define-function 'mod '%))
 (define-function 'move-marker 'set-marker)
 ; alternate names (not obsolete)
 (if (not (fboundp 'mod)) (define-function 'mod '%))
 (define-function 'move-marker 'set-marker)