X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=poe.el;h=3650633dbeb3faca54cf901bf64e2076d98bcddb;hb=753a4ee807918c44a1550983c3ff174181b5c95a;hp=4b51c510dc61122e67e5608f47bb407df976c69c;hpb=276d6114d1f5f6b7097cd75155eade36c9d04b20;p=elisp%2Fapel.git

diff --git a/poe.el b/poe.el
index 4b51c51..3650633 100644
--- a/poe.el
+++ b/poe.el
@@ -1,8 +1,8 @@
-;;; poe.el --- Emulation module for each Emacs variants
+;;; poe.el --- Portable Outfit for Emacsen; -*-byte-compile-dynamic: t;-*-
 
-;; Copyright (C) 1995,1996,1997,1998 Free Software Foundation, Inc.
+;; Copyright (C) 1995,1996,1997,1998,1999 Free Software Foundation, Inc.
 
-;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
+;; Author: MORIOKA Tomohiko <tomo@m17n.org>
 ;; Keywords: emulation, compatibility, NEmacs, MULE, Emacs/mule, XEmacs
 
 ;; This file is part of APEL (A Portable Emacs Library).
@@ -22,12 +22,18 @@
 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
 ;; Boston, MA 02111-1307, USA.
 
+;;; Commentary:
+
+;; This modules does not includes MULE related features.  MULE related
+;; features are supported by `poem'.
+
 ;;; Code:
 
+(provide 'poe)
+
 (defmacro defun-maybe (name &rest everything-else)
   (or (and (fboundp name)
-	   (not (get name 'defun-maybe))
-	   )
+	   (not (get name 'defun-maybe)))
       (` (or (fboundp (quote (, name)))
 	     (progn
 	       (defun (, name) (,@ everything-else))
@@ -35,10 +41,24 @@
 	       ))
 	 )))
 
+(defmacro defmacro-maybe (name &rest everything-else)
+  (or (and (fboundp name)
+	   (not (get name 'defmacro-maybe)))
+      (` (or (fboundp (quote (, name)))
+	     (progn
+	       (defmacro (, name) (,@ everything-else))
+	       (put (quote (, name)) 'defmacro-maybe t)
+	       ))
+	 )))
+
+(defmacro-maybe defsubst (name arglist &rest body)
+  "Define an inline function.  The syntax is just like that of `defun'."
+  (cons 'defun (cons name (cons arglist body)))
+  )
+
 (defmacro defsubst-maybe (name &rest everything-else)
   (or (and (fboundp name)
-	   (not (get name 'defsubst-maybe))
-	   )
+	   (not (get name 'defsubst-maybe)))
       (` (or (fboundp (quote (, name)))
 	     (progn
 	       (defsubst (, name) (,@ everything-else))
@@ -46,14 +66,14 @@
 	       ))
 	 )))
 
-(defmacro defmacro-maybe (name &rest everything-else)
-  (or (and (fboundp name)
-	   (not (get name 'defmacro-maybe))
-	   )
-      (` (or (fboundp (quote (, name)))
+(defmacro defalias-maybe (symbol definition)
+  (setq symbol (eval symbol))
+  (or (and (fboundp symbol)
+	   (not (get symbol 'defalias-maybe)))
+      (` (or (fboundp (quote (, symbol)))
 	     (progn
-	       (defmacro (, name) (,@ everything-else))
-	       (put (quote (, name)) 'defmacro-maybe t)
+	       (defalias (quote (, symbol)) (, definition))
+	       (put (quote (, symbol)) 'defalias-maybe t)
 	       ))
 	 )))
 
@@ -61,6 +81,16 @@
 (put 'defsubst-maybe 'lisp-indent-function 'defun)
 (put 'defmacro-maybe 'lisp-indent-function 'defun)
 
+(defmacro defvar-maybe (name &rest everything-else)
+  (or (and (boundp name)
+	   (not (get name 'defvar-maybe)))
+      (` (or (boundp (quote (, name)))
+	     (progn
+	       (defvar (, name) (,@ everything-else))
+	       (put (quote (, name)) 'defvar-maybe t)
+	       ))
+	 )))
+
 (defmacro defconst-maybe (name &rest everything-else)
   (or (and (boundp name)
 	   (not (get name 'defconst-maybe))
@@ -72,6 +102,34 @@
 	       ))
 	 )))
 
+(defmacro defun-maybe-cond (name args &optional doc &rest everything-else)
+  (or (stringp doc)
+      (setq everything-else (cons doc everything-else)
+	    doc nil)
+      )
+  (or (and (fboundp name)
+	   (not (get name 'defun-maybe)))
+      (` (or (fboundp (quote (, name)))
+	     (progn
+	       (cond (,@ (mapcar (function
+				  (lambda (case)
+				    (list (car case)
+					  (if doc
+					      (` (defun (, name) (, args)
+						   (, doc)
+						   (,@ (cdr case))))
+					    (` (defun (, name) (, args)
+						 (,@ (cdr case))))
+					    ))))
+				 everything-else)))
+	       (put (quote (, name)) 'defun-maybe t)
+	       )))))
+
+(defsubst subr-fboundp (symbol)
+  "Return t if SYMBOL's function definition is a built-in function."
+  (and (fboundp symbol)
+       (subrp (symbol-function symbol))))
+
 (defconst-maybe emacs-major-version (string-to-int emacs-version))
 (defconst-maybe emacs-minor-version
   (string-to-int
@@ -86,25 +144,22 @@
        (provide 'xemacs)
        (require 'poe-xemacs)
        )
-      ((>= emacs-major-version 20)
-       (require 'poe-19)
-       (cond ((fboundp 'string)
+      ((> emacs-major-version 20))
+      ((= emacs-major-version 20)
+       (cond ((subr-fboundp 'string)
 	      ;; Emacs 20.3 or later
 	      )
-	     ((fboundp 'concat-chars)
+	     ((subr-fboundp 'concat-chars)
 	      ;; Emacs 20.1 or later
 	      (defalias 'string 'concat-chars)
 	      ))
        )
-      ((>= emacs-major-version 19)
-       (require 'poe-19)
-       )
+      ((= emacs-major-version 19))
       (t
        (require 'poe-18)
        ))
 
-
-;;; @ Emacs 19 emulation
+;;; @ Emacs 19.23 emulation
 ;;;
 
 (defun-maybe minibuffer-prompt-width ()
@@ -113,11 +168,120 @@
     (set-buffer (window-buffer (minibuffer-window)))
     (current-column)))
 
-
 ;;; @ Emacs 19.29 emulation
 ;;;
 
-(defvar path-separator ":"
+(eval-when-compile (require 'static))
+
+;; `add-hook' and `remove-hook' are imported from Emacs 19.28
+;; (with additional `local' argument).
+(static-condition-case nil
+    (let (test-hook)
+      (add-hook 'test-hook 'test 'append 'local)
+      (remove-hook 'test-hook 'test 'local))
+  (void-function
+   ;; emulate add-hook/remove-hook for version 18.
+   (defun-maybe add-hook (hook function &optional append local)
+     "Add to the value of HOOK the function FUNCTION.
+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
+\(LOCAL is only for emulation\).
+
+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.
+\[Emacs 19.29 emulating function]"
+     (or (boundp hook)
+	 (set hook nil))
+     ;; If the hook value is a single function, turn it into a list.
+     (let ((old (symbol-value hook)))
+       (if (or (not (listp old))
+	       (eq (car old) 'lambda))
+	   (set hook (list old))))
+     (or (if (consp function)
+	     ;; Clever way to tell whether a given lambda-expression
+	     ;; is equal to anything in the hook.
+	     (let ((tail (assoc (cdr function) (symbol-value hook))))
+	       (equal function tail))
+	   (memq function (symbol-value hook)))
+	 (set hook 
+	      (if append
+		  (nconc (symbol-value hook) (list function))
+		(cons function (symbol-value hook))))))
+
+   (defun-maybe remove-hook (hook function &optional local)
+     "Remove from the value of HOOK the function FUNCTION.
+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'.
+
+The optional third argument, LOCAL, if non-nil, says to modify
+the hook's buffer-local value rather than its default value
+\(LOCAL is only for emulation\).
+\[Emacs 19.29 emulating function]"
+     (if (or (not (boundp hook))
+	     (null (symbol-value hook))
+	     (null function))
+	 nil
+       (let ((hook-value (symbol-value hook)))
+	 (if (consp hook-value)
+	     (setq hook-value (delete function hook-value))
+	   (if (equal hook-value function)
+	       (setq hook-value nil)))
+	 (set hook hook-value))))
+   )
+  (wrong-number-of-arguments
+   ;; emulate `local' arg for version 19.28 and earlier.
+   (or (fboundp 'si:add-hook)
+       (progn
+	 (fset 'si:add-hook (symbol-function 'add-hook))
+	 (defun add-hook (hook function &optional append local)
+	   "Add to the value of HOOK the function FUNCTION.
+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
+\(LOCAL is only for emulation\).
+
+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.
+\[Emacs 19.29 emulating function]"
+	   ;; the fourth argument LOCAL is simply ignored.
+	   (si:add-hook hook function append))))
+
+   (or (fboundp 'si:remove-hook)
+       (progn
+	 (fset 'si:remove-hook (symbol-function 'remove-hook))
+	 (defun remove-hook (hook function &optional local)
+	   "Remove from the value of HOOK the function FUNCTION.
+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'.
+
+The optional third argument, LOCAL, if non-nil, says to modify
+the hook's buffer-local value rather than its default value
+\(LOCAL is only for emulation\).
+\[Emacs 19.29 emulating function]"
+	   ;; the third argument LOCAL is simply ignored.
+	   (si:remove-hook hook function))))
+   ))
+
+(defun-maybe make-local-hook (hook)
+  "Make the hook HOOK local to the current buffer.
+This function is only for emulation.
+\[Emacs 19.29 emulating function]"
+  )
+
+(defvar-maybe path-separator ":"
   "Character used to separate concatenated paths.")
 
 (defun-maybe buffer-substring-no-properties (start end)
@@ -146,22 +310,44 @@ STRING should be given if the last search was by `string-match' on STRING.
 	 (>= emacs-minor-version 29))
     ;; for Emacs 19.28 or earlier
     (fboundp 'si:read-string)
-    (progn
+    (eval-and-compile
       (fset 'si:read-string (symbol-function 'read-string))
-      
       (defun read-string (prompt &optional initial-input history)
 	"Read a string from the minibuffer, prompting with string PROMPT.
 If non-nil, second arg INITIAL-INPUT is a string to insert before reading.
-The third arg HISTORY, is dummy for compatibility. [emu.el]
+The third arg HISTORY, is dummy for compatibility.
 See `read-from-minibuffer' for details of HISTORY argument."
 	(si:read-string prompt initial-input))
       ))
 
+(defun-maybe rassoc (key list)
+  "Return non-nil if KEY is `equal' to the cdr of an element of LIST.
+The value is actually the element of LIST whose cdr equals KEY."
+  (catch 'found
+    (while list
+      (if (equal (cdr (car list)) key)
+	  (throw 'found (car list))
+	)
+      (setq list (cdr list)))
+    ))
+
+(defun-maybe file-name-sans-extension (filename)
+  "Return FILENAME sans final \"extension\".
+The extension, in a file name, is the part that follows the last `.'."
+  (save-match-data
+    (let ((file (file-name-sans-versions (file-name-nondirectory filename)))
+	  directory)
+      (if (string-match "\\.[^.]*\\'" file)
+	  (if (setq directory (file-name-directory filename))
+	      (expand-file-name (substring file 0 (match-beginning 0))
+				directory)
+	    (substring file 0 (match-beginning 0)))
+	filename))))
 
 ;;; @ Emacs 19.30 emulation
 ;;;
 
-;; This function was imported Emacs 19.30.
+;; imported from Emacs 19.30.
 (defun-maybe add-to-list (list-var element)
   "Add to the value of LIST-VAR the element ELEMENT if it isn't there yet.
 If you want to use `add-to-list' on a variable that is not defined
@@ -200,7 +386,7 @@ Value is nil if OBJECT is not a buffer or if it has been killed.
        (get-buffer object)
        (buffer-name (get-buffer object))))
 
-;; This macro was imported Emacs 19.33.
+;; imported from Emacs 19.33.
 (defmacro-maybe save-selected-window (&rest body)
   "Execute BODY, then select the window that was selected before BODY.
 \[Emacs 19.31 emulating function]"
@@ -214,16 +400,37 @@ Value is nil if OBJECT is not a buffer or if it has been killed.
 ;;; @ Emacs 20.1 emulation
 ;;;
 
-;; This macro was imported Emacs 20.2.
+;; imported from Emacs 20.2.
 (defmacro-maybe when (cond &rest body)
   "(when COND BODY...): if COND yields non-nil, do BODY, else return nil."
   (list 'if cond (cons 'progn body)))
 
-;; This macro was imported Emacs 20.3.
+;; imported from Emacs 20.3.
 (defmacro-maybe unless (cond &rest body)
   "(unless COND BODY...): if COND yields nil, do BODY, else return nil."
   (cons 'if (cons cond (cons nil body))))
 
+;; imported from Emacs 20.3.
+(defsubst-maybe caar (x)
+  "Return the car of the car of X."
+  (car (car x)))
+
+;; imported from Emacs 20.3.
+(defun-maybe last (x &optional n)
+  "Return the last link of the list X.  Its car is the last element.
+If X is nil, return nil.
+If N is non-nil, return the Nth-to-last link of X.
+If N is bigger than the length of X, return X."
+  (if n
+      (let ((m 0) (p x))
+	(while (consp p)
+	  (setq m (1+ m) p (cdr p)))
+	(if (<= n 0) p
+	  (if (< n m) (nthcdr (- m n) x) x)))
+    (while (cdr x)
+      (setq x (cdr x)))
+    x))
+
 (defmacro-maybe save-current-buffer (&rest body)
   "Save the current buffer; execute BODY; restore the current buffer.
 Executes BODY just like `progn'."
@@ -232,7 +439,7 @@ Executes BODY just like `progn'."
 	   (progn (,@ body))
 	 (set-buffer orig-buffer)))))
 
-;; This macro was imported Emacs 20.2.
+;; imported from Emacs 20.2.
 (defmacro-maybe with-current-buffer (buffer &rest body)
   "Execute the forms in BODY with BUFFER as the current buffer.
 The value returned is the value of the last form in BODY.
@@ -241,7 +448,7 @@ See also `with-temp-buffer'."
        (set-buffer (, buffer))
        (,@ body))))
 
-;; This macro was imported Emacs 20.2.
+;; imported from Emacs 20.2.
 (defmacro-maybe with-temp-file (file &rest forms)
   "Create a new buffer, evaluate FORMS there, and write the buffer to FILE.
 The value of the last form in FORMS is returned, like `progn'.
@@ -261,7 +468,7 @@ See also `with-temp-buffer'."
 	   (and (buffer-name (, temp-buffer))
 		(kill-buffer (, temp-buffer))))))))
 
-;; This macro was imported Emacs 20.2.
+;; imported from Emacs 20.2.
 (defmacro-maybe with-temp-buffer (&rest forms)
   "Create a temporary buffer, and evaluate FORMS there like `progn'.
 See also `with-temp-file' and `with-output-to-string'."
@@ -274,29 +481,17 @@ See also `with-temp-file' and `with-output-to-string'."
 	   (and (buffer-name (, temp-buffer))
 		(kill-buffer (, temp-buffer))))))))
 
-;; This function was imported Emacs 20.3.
-(defun-maybe last (x &optional n)
-  "Return the last link of the list X.  Its car is the last element.
-If X is nil, return nil.
-If N is non-nil, return the Nth-to-last link of X.
-If N is bigger than the length of X, return X."
-  (if n
-      (let ((m 0) (p x))
-	(while (consp p)
-	  (setq m (1+ m) p (cdr p)))
-	(if (<= n 0) p
-	  (if (< n m) (nthcdr (- m n) x) x)))
-    (while (cdr x)
-      (setq x (cdr x)))
-    x))
+(defmacro-maybe combine-after-change-calls (&rest body)
+  "Execute BODY."
+  (cons 'progn body))
 
-;; This function was imported Emacs 20.3. (cl function)
+;; imported from Emacs 20.3. (cl function)
 (defun-maybe butlast (x &optional n)
   "Returns a copy of LIST with the last N elements removed."
   (if (and n (<= n 0)) x
     (nbutlast (copy-sequence x) n)))
 
-;; This function was imported Emacs 20.3. (cl function)
+;; imported from Emacs 20.3. (cl function)
 (defun-maybe nbutlast (x &optional n)
   "Modifies LIST to remove the last N elements."
   (let ((m (length x)))
@@ -306,7 +501,7 @@ If N is bigger than the length of X, return X."
 	   (if (> n 0) (setcdr (nthcdr (- (1- m) n) x) nil))
 	   x))))
 
-;; This function was imported from XEmacs 21.
+;; imported from XEmacs 21.
 (defun-maybe split-string (string &optional pattern)
   "Return a list of substrings of STRING which are separated by PATTERN.
 If PATTERN is omitted, it defaults to \"[ \\f\\t\\n\\r\\v]+\"."
@@ -324,6 +519,17 @@ If PATTERN is omitted, it defaults to \"[ \\f\\t\\n\\r\\v]+\"."
 ;;; @ Emacs 20.3 emulation
 ;;;
 
+;; imported from Emacs 20.3.91.
+(defvar-maybe temporary-file-directory
+  (file-name-as-directory
+   (cond ((memq system-type '(ms-dos windows-nt))
+	  (or (getenv "TEMP") (getenv "TMPDIR") (getenv "TMP") "c:/temp"))
+	 ((memq system-type '(vax-vms axp-vms))
+	  (or (getenv "TMPDIR") (getenv "TMP") (getenv "TEMP") "SYS$SCRATCH:"))
+	 (t
+	  (or (getenv "TMPDIR") (getenv "TMP") (getenv "TEMP") "/tmp"))))
+  "The directory for writing temporary files.")
+
 (defun-maybe line-beginning-position (&optional n)
   "Return the character position of the first character on the current line.
 With argument N not nil or 1, move forward N - 1 lines first.
@@ -357,6 +563,15 @@ This function does not move point."
 ;;; @ XEmacs emulation
 ;;;
 
+(defun-maybe find-face (face-or-name)
+  "Retrieve the face of the given name.
+If FACE-OR-NAME is a face object, it is simply returned.
+Otherwise, FACE-OR-NAME should be a symbol.  If there is no such face,
+nil is returned.  Otherwise the associated face object is returned.
+\[XEmacs emulating function]"
+  (car (memq face-or-name (face-list)))
+  )
+
 (defun-maybe point-at-bol (&optional n buffer)
   "Return the character position of the first character on the current line.
 With argument N not nil or 1, move forward N - 1 lines first.
@@ -398,10 +613,67 @@ as obsolete. [XEmacs emulating function]"
   (make-obsolete oldfun newfun)
   )
 
+(when (subr-fboundp 'read-event)
+  ;; for Emacs 19 or later
 
-;;; @ end
+  (defun-maybe-cond next-command-event (&optional event prompt)
+    "Read an event object from the input stream.
+If EVENT is non-nil, it should be an event object and will be filled
+in and returned; otherwise a new event object will be created and
+returned.
+If PROMPT is non-nil, it should be a string and will be displayed in
+the echo area while this function is waiting for an event.
+\[XEmacs emulating function]"
+    ((subr-fboundp 'string)
+     ;; for Emacs 20.3 or later
+     (read-event prompt t)
+     )
+    (t
+     (if prompt (message prompt))
+     (read-event)
+     ))
+
+  (defsubst-maybe character-to-event (ch)
+    "Convert keystroke CH into an event structure, replete with bucky bits.
+Note that CH (the keystroke specifier) can be an integer, a character
+or a symbol such as 'clear. [XEmacs emulating function]"
+    ch)
+
+  (defun-maybe event-to-character (event)
+    "Return the character approximation to the given event object.
+If the event isn't a keypress, this returns nil.
+\[XEmacs emulating function]"
+    (cond ((symbolp event)
+	   ;; mask is (BASE-TYPE MODIFIER-BITS) or nil.
+	   (let ((mask (get event 'event-symbol-element-mask)))
+	     (if mask
+		 (let ((base (get (car mask) 'ascii-character)))
+		   (if base
+		       (logior base (car (cdr mask)))
+		     )))))
+	  ((integerp event) event)
+	  ))
+  )
+
+
+;;; @ MULE 2 emulation
 ;;;
 
-(provide 'poe)
+(defun-maybe-cond cancel-undo-boundary ()
+  "Cancel undo boundary. [MULE 2.3 emulating function]"
+  ((boundp 'buffer-undo-list)
+   ;; for Emacs 19.7 or later
+   (if (and (consp buffer-undo-list)
+	    ;; if car is nil.
+	    (null (car buffer-undo-list)))
+       (setq buffer-undo-list (cdr buffer-undo-list))
+     ))
+  (t
+   ;; for anything older than Emacs 19.7.    
+   ))
+
+
+;;; @ end
+;;;
 
 ;;; poe.el ends here