From: tomo Date: Tue, 19 Dec 2000 06:35:37 +0000 (+0000) Subject: Remove poe, pces, poem, pcustom and emu. X-Git-Tag: semi21-1_14_0-1~6 X-Git-Url: http://git.chise.org/cgi-bin/gitweb.cgi?a=commitdiff_plain;h=02867644f6ca4a1943a812156e83c46edde10311;p=elisp%2Flemi.git Remove poe, pces, poem, pcustom and emu. --- diff --git a/poe/emu.el b/poe/emu.el deleted file mode 100644 index d610c53..0000000 --- a/poe/emu.el +++ /dev/null @@ -1,233 +0,0 @@ -;;; emu.el --- Emulation module for each Emacs variants - -;; Copyright (C) 1995,1996,1997,1998 Free Software Foundation, Inc. - -;; Author: MORIOKA Tomohiko -;; Keywords: emulation, compatibility, NEmacs, MULE, Emacs/mule, XEmacs - -;; This file is part of emu. - -;; This program is free software; you can redistribute it and/or -;; modify it under the terms of the GNU General Public License as -;; published by the Free Software Foundation; either version 2, or (at -;; your option) any later version. - -;; This program is distributed in the hope that it will be useful, but -;; WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Code: - -(require 'poe) - -(defvar running-emacs-18 (<= emacs-major-version 18)) -(defvar running-xemacs (featurep 'xemacs)) - -(defvar running-mule-merged-emacs (and (not (boundp 'MULE)) - (not running-xemacs) (featurep 'mule))) -(defvar running-xemacs-with-mule (and running-xemacs (featurep 'mule))) - -(defvar running-emacs-19 (and (not running-xemacs) (= emacs-major-version 19))) -(defvar running-emacs-19_29-or-later - (or (and running-emacs-19 (>= emacs-minor-version 29)) - (and (not running-xemacs)(>= emacs-major-version 20)))) - -(defvar running-xemacs-19 (and running-xemacs - (= emacs-major-version 19))) -(defvar running-xemacs-20-or-later (and running-xemacs - (>= emacs-major-version 20))) -(defvar running-xemacs-19_14-or-later - (or (and running-xemacs-19 (>= emacs-minor-version 14)) - running-xemacs-20-or-later)) - -(cond (running-xemacs - ;; for XEmacs - (defvar mouse-button-1 'button1) - (defvar mouse-button-2 'button2) - (defvar mouse-button-3 'button3) - ) - ((>= emacs-major-version 19) - ;; mouse - (defvar mouse-button-1 [mouse-1]) - (defvar mouse-button-2 [mouse-2]) - (defvar mouse-button-3 [down-mouse-3]) - ) - (t - ;; mouse - (defvar mouse-button-1 nil) - (defvar mouse-button-2 nil) - (defvar mouse-button-3 nil) - )) - -;; for tm-7.106 -(unless (fboundp 'tl:make-overlay) - (defalias 'tl:make-overlay 'make-overlay) - (make-obsolete 'tl:make-overlay 'make-overlay) - ) -(unless (fboundp 'tl:overlay-put) - (defalias 'tl:overlay-put 'overlay-put) - (make-obsolete 'tl:overlay-put 'overlay-put) - ) -(unless (fboundp 'tl:overlay-put) - (defalias 'tl:overlay-buffer 'overlay-buffer) - (make-obsolete 'tl:overlay-buffer 'overlay-buffer) - ) - -(require 'poem) -(require 'mcharset) -(require 'invisible) - -(defsubst char-list-to-string (char-list) - "Convert list of character CHAR-LIST to string." - (apply (function string) char-list)) - -(cond ((featurep 'mule) - (cond ((featurep 'xemacs) ; for XEmacs with MULE - ;; old Mule emulating aliases - - ;;(defalias 'char-leading-char 'char-charset) - - (defun char-category (character) - "Return string of category mnemonics for CHAR in TABLE. -CHAR can be any multilingual character -TABLE defaults to the current buffer's category table." - (mapconcat (lambda (chr) - (char-to-string (int-char chr))) - (char-category-list character) - "")) - ) - ((>= emacs-major-version 20) ; for Emacs 20 - (defalias 'insert-binary-file-contents-literally - 'insert-file-contents-literally) - - ;; old Mule emulating aliases - (defun char-category (character) - "Return string of category mnemonics for CHAR in TABLE. -CHAR can be any multilingual character -TABLE defaults to the current buffer's category table." - (category-set-mnemonics (char-category-set character))) - ) - (t ; for MULE 1.* and 2.* - (require 'emu-mule) - )) - ) - ((boundp 'NEMACS) - ;; for NEmacs and NEpoch - - ;; old MULE emulation - (defconst *noconv* 0) - (defconst *sjis* 1) - (defconst *junet* 2) - (defconst *ctext* 2) - (defconst *internal* 3) - (defconst *euc-japan* 3) - - (defun code-convert-string (str ic oc) - "Convert code in STRING from SOURCE code to TARGET code, -On successful converion, returns the result string, -else returns nil." - (if (not (eq ic oc)) - (convert-string-kanji-code str ic oc) - str)) - - (defun code-convert-region (beg end ic oc) - "Convert code of the text between BEGIN and END from SOURCE -to TARGET. On successful conversion returns t, -else returns nil." - (if (/= ic oc) - (save-excursion - (save-restriction - (narrow-to-region beg end) - (convert-region-kanji-code beg end ic oc))) - )) - ) - (t - ;; for Emacs 19 and XEmacs without MULE - - ;; old MULE emulation - (defconst *internal* nil) - (defconst *ctext* nil) - (defconst *noconv* nil) - - (defun code-convert-string (str ic oc) - "Convert code in STRING from SOURCE code to TARGET code, -On successful converion, returns the result string, -else returns nil. [emu-latin1.el; old MULE emulating function]" - str) - - (defun code-convert-region (beg end ic oc) - "Convert code of the text between BEGIN and END from SOURCE -to TARGET. On successful conversion returns t, -else returns nil. [emu-latin1.el; old MULE emulating function]" - t) - )) - - -;;; @ Mule emulating aliases -;;; -;;; You should not use it. - -(or (boundp '*noconv*) - (defconst *noconv* 'binary - "Coding-system for binary. -This constant is defined to emulate old MULE anything older than MULE 2.3. -It is obsolete, so don't use it.")) - - -;;; @ without code-conversion -;;; - -(defalias 'insert-binary-file-contents 'insert-file-contents-as-binary) -(make-obsolete 'insert-binary-file-contents 'insert-file-contents-as-binary) - -(defun-maybe insert-binary-file-contents-literally (filename - &optional visit - beg end replace) - "Like `insert-file-contents-literally', q.v., but don't code conversion. -A buffer may be modified in several ways after reading into the buffer due -to advanced Emacs features, such as file-name-handlers, format decoding, -find-file-hooks, etc. - This function ensures that none of these modifications will take place." - (as-binary-input-file - ;; Returns list absolute file name and length of data inserted. - (insert-file-contents-literally filename visit beg end replace))) - - -;;; @ for text/richtext and text/enriched -;;; - -(cond ((fboundp 'richtext-decode) - ;; have richtext.el - ) - ((or running-emacs-19_29-or-later running-xemacs-19_14-or-later) - ;; have enriched.el - (autoload 'richtext-decode "richtext") - (or (assq 'text/richtext format-alist) - (setq format-alist - (cons - (cons 'text/richtext - '("Extended MIME text/richtext format." - "Content-[Tt]ype:[ \t]*text/richtext" - richtext-decode richtext-encode t enriched-mode)) - format-alist))) - ) - (t - ;; don't have enriched.el - (autoload 'richtext-decode "tinyrich") - (autoload 'enriched-decode "tinyrich") - )) - - -;;; @ end -;;; - -(require 'product) -(product-provide (provide 'emu) (require 'apel-ver)) - -;;; emu.el ends here diff --git a/poe/pces-20.el b/poe/pces-20.el deleted file mode 100644 index 6531710..0000000 --- a/poe/pces-20.el +++ /dev/null @@ -1,239 +0,0 @@ -;;; -*-byte-compile-dynamic: t;-*- -;;; pces-20.el --- pces submodule for Emacs 20 and XEmacs with coding-system - -;; Copyright (C) 1997,1998,1999 Free Software Foundation, Inc. - -;; Author: MORIOKA Tomohiko -;; Keywords: emulation, compatibility, Mule - -;; This file is part of APEL (A Portable Emacs Library). - -;; This program is free software; you can redistribute it and/or -;; modify it under the terms of the GNU General Public License as -;; published by the Free Software Foundation; either version 2, or (at -;; your option) any later version. - -;; This program is distributed in the hope that it will be useful, but -;; WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: - -;; This module requires Emacs 20.0.93, XEmacs 20.3-b5 (with mule) -;; or later. - -;;; Code: - -;; (defun-maybe-cond multibyte-string-p (object) -;; "Return t if OBJECT is a multibyte string." -;; ((featurep 'mule) (stringp object)) -;; (t nil)) - - -;;; @ without code-conversion -;;; - -(defmacro as-binary-process (&rest body) - `(let (selective-display ; Disable ^M to nl translation. - (coding-system-for-read 'binary) - (coding-system-for-write 'binary)) - ,@body)) - -(defmacro as-binary-input-file (&rest body) - `(let ((coding-system-for-read 'binary)) - ,@body)) - -(defmacro as-binary-output-file (&rest body) - `(let ((coding-system-for-write 'binary)) - ,@body)) - -(defun write-region-as-binary (start end filename - &optional append visit lockname) - "Like `write-region', q.v., but don't encode." - (let ((coding-system-for-write 'binary) - jka-compr-compression-info-list jam-zcat-filename-list) - (write-region start end filename append visit lockname))) - -(require 'broken) - -(broken-facility insert-file-contents-literally-treats-binary - "Function `insert-file-contents-literally' decodes text." - (let* ((str "\r\n") - (coding-system-for-write 'binary) - (coding-system-for-read 'raw-text-dos) - ;; (default-enable-multibyte-characters (multibyte-string-p str)) - ) - (with-temp-buffer - (insert str) - (write-region (point-min)(point-max) "literal-test-file") - ) - (string= - (with-temp-buffer - (let (file-name-handler-alist) - (insert-file-contents-literally "literal-test-file") - ) - (buffer-string) - ) - str))) - -(broken-facility insert-file-contents-literally-treats-file-name-handler - "Function `insert-file-contents' doesn't call file-name-handler." - (let (called) - (with-temp-buffer - (let ((file-name-handler-alist - '(("literal-test-file" . (lambda (operation &rest args) - (setq called t) - (let (file-name-handler-alist) - (apply operation args) - )))))) - (insert-file-contents-literally "literal-test-file") - ) - (delete-file "literal-test-file") - ) - called)) - -(static-if - (or (broken-p 'insert-file-contents-literally-treats-binary) - (broken-p 'insert-file-contents-literally-treats-file-name-handler)) - (defun insert-file-contents-as-binary (filename - &optional visit beg end replace) - "Like `insert-file-contents', but only reads in the file literally. -A buffer may be modified in several ways after reading into the buffer, -to Emacs features such as format decoding, character code -conversion, find-file-hooks, automatic uncompression, etc. - -This function ensures that none of these modifications will take place." - (let ((format-alist nil) - (after-insert-file-functions nil) - (coding-system-for-read 'binary) - (coding-system-for-write 'binary) - (jka-compr-compression-info-list nil) - (jam-zcat-filename-list nil) - (find-buffer-file-type-function - (if (fboundp 'find-buffer-file-type) - (symbol-function 'find-buffer-file-type) - nil))) - (unwind-protect - (progn - (fset 'find-buffer-file-type (lambda (filename) t)) - (insert-file-contents filename visit beg end replace)) - (if find-buffer-file-type-function - (fset 'find-buffer-file-type find-buffer-file-type-function) - (fmakunbound 'find-buffer-file-type))))) - (defalias 'insert-file-contents-as-binary 'insert-file-contents-literally) - ) - -(defun insert-file-contents-as-raw-text (filename - &optional visit beg end replace) - "Like `insert-file-contents', q.v., but don't code and format conversion. -Like `insert-file-contents-literary', but it allows find-file-hooks, -automatic uncompression, etc. -Like `insert-file-contents-as-binary', but it converts line-break -code." - (let ((coding-system-for-read 'raw-text) - format-alist) - ;; Returns list of absolute file name and length of data inserted. - (insert-file-contents filename visit beg end replace))) - -(defun insert-file-contents-as-raw-text-CRLF (filename - &optional visit beg end replace) - "Like `insert-file-contents', q.v., but don't code and format conversion. -Like `insert-file-contents-literary', but it allows find-file-hooks, -automatic uncompression, etc. -Like `insert-file-contents-as-binary', but it converts line-break code -from CRLF to LF." - (let ((coding-system-for-read 'raw-text-dos) - format-alist) - ;; Returns list of absolute file name and length of data inserted. - (insert-file-contents filename visit beg end replace))) - -(defun write-region-as-raw-text-CRLF (start end filename - &optional append visit lockname) - "Like `write-region', q.v., but write as network representation." - (let ((coding-system-for-write 'raw-text-dos)) - (write-region start end filename append visit lockname))) - -(defun find-file-noselect-as-binary (filename &optional nowarn rawfile) - "Like `find-file-noselect', q.v., but don't code and format conversion." - (let ((coding-system-for-read 'binary) - format-alist) - (find-file-noselect filename nowarn rawfile))) - -(defun find-file-noselect-as-raw-text (filename &optional nowarn rawfile) - "Like `find-file-noselect', q.v., but it does not code and format conversion -except for line-break code." - (let ((coding-system-for-read 'raw-text) - format-alist) - (find-file-noselect filename nowarn rawfile))) - -(defun find-file-noselect-as-raw-text-CRLF (filename &optional nowarn rawfile) - "Like `find-file-noselect', q.v., but it does not code and format conversion -except for line-break code." - (let ((coding-system-for-read 'raw-text-dos) - format-alist) - (find-file-noselect filename nowarn rawfile))) - -(defun save-buffer-as-binary (&optional args) - "Like `save-buffer', q.v., but don't encode." - (let ((coding-system-for-write 'binary)) - (save-buffer args))) - -(defun save-buffer-as-raw-text-CRLF (&optional args) - "Like `save-buffer', q.v., but save as network representation." - (let ((coding-system-for-write 'raw-text-dos)) - (save-buffer args))) - -(defun open-network-stream-as-binary (name buffer host service) - "Like `open-network-stream', q.v., but don't code conversion." - (let ((coding-system-for-read 'binary) - (coding-system-for-write 'binary)) - (open-network-stream name buffer host service))) - - -;;; @ with code-conversion -;;; - -(defun insert-file-contents-as-coding-system - (coding-system filename &optional visit beg end replace) - "Like `insert-file-contents', q.v., but CODING-SYSTEM the first arg will -be applied to `coding-system-for-read'." - (let ((coding-system-for-read coding-system) - format-alist) - (insert-file-contents filename visit beg end replace))) - -(defun write-region-as-coding-system - (coding-system start end filename &optional append visit lockname) - "Like `write-region', q.v., but CODING-SYSTEM the first arg will be -applied to `coding-system-for-write'." - (let ((coding-system-for-write coding-system) - jka-compr-compression-info-list jam-zcat-filename-list) - (write-region start end filename append visit lockname))) - -(defun find-file-noselect-as-coding-system - (coding-system filename &optional nowarn rawfile) - "Like `find-file-noselect', q.v., but CODING-SYSTEM the first arg will -be applied to `coding-system-for-read'." - (let ((coding-system-for-read coding-system) - format-alist) - (find-file-noselect filename nowarn rawfile))) - -(defun save-buffer-as-coding-system (coding-system &optional args) - "Like `save-buffer', q.v., but CODING-SYSTEM the first arg will be -applied to `coding-system-for-write'." - (let ((coding-system-for-write coding-system)) - (save-buffer args))) - - -;;; @ end -;;; - -(require 'product) -(product-provide (provide 'pces-20) (require 'apel-ver)) - -;;; pces-20.el ends here diff --git a/poe/pces-e20.el b/poe/pces-e20.el deleted file mode 100644 index 724f8af..0000000 --- a/poe/pces-e20.el +++ /dev/null @@ -1,48 +0,0 @@ -;;; pces-e20.el --- pces submodule for Emacs 20 - -;; Copyright (C) 1998,1999 Free Software Foundation, Inc. - -;; Author: MORIOKA Tomohiko -;; Keywords: emulation, compatibility, Mule - -;; This file is part of APEL (A Portable Emacs Library). - -;; This program is free software; you can redistribute it and/or -;; modify it under the terms of the GNU General Public License as -;; published by the Free Software Foundation; either version 2, or (at -;; your option) any later version. - -;; This program is distributed in the hope that it will be useful, but -;; WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Code: - -(require 'pces-20) - -(unless (and (fboundp 'set-buffer-multibyte) - (subrp (symbol-function 'set-buffer-multibyte))) - (require 'pces-e20_2) ; for Emacs 20.1 and 20.2 - ) - -(defsubst-maybe find-coding-system (obj) - "Return OBJ if it is a coding-system." - (if (coding-system-p obj) - obj)) - -(defalias 'set-process-input-coding-system 'set-process-coding-system) - - -;;; @ end -;;; - -(require 'product) -(product-provide (provide 'pces-e20) (require 'apel-ver)) - -;;; pces-e20.el ends here diff --git a/poe/pces.el b/poe/pces.el deleted file mode 100644 index 85bce8c..0000000 --- a/poe/pces.el +++ /dev/null @@ -1,59 +0,0 @@ -;;; pces.el --- Portable Character Encoding Scheme (coding-system) features - -;; Copyright (C) 1998,1999 Free Software Foundation, Inc. - -;; Author: MORIOKA Tomohiko -;; Keywords: coding-system, emulation, compatibility, Mule - -;; This file is part of APEL (A Portable Emacs Library). - -;; This program is free software; you can redistribute it and/or -;; modify it under the terms of the GNU General Public License as -;; published by the Free Software Foundation; either version 2, or (at -;; your option) any later version. - -;; This program is distributed in the hope that it will be useful, but -;; WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Code: - -(require 'poe) - -(eval-and-compile - (unless (fboundp 'open-network-stream) - (require 'tcp))) - -(cond ((featurep 'xemacs) - (if (featurep 'file-coding) - (require 'pces-xfc) - (require 'pces-raw) - )) - ((featurep 'mule) - (if (>= emacs-major-version 20) - (require 'pces-e20) - ;; for MULE 1.* and 2.* - (require 'pces-om) - )) - ((boundp 'NEMACS) - ;; for Nemacs and Nepoch - (require 'pces-nemacs) - ) - (t - (require 'pces-raw) - )) - - -;;; @ end -;;; - -(require 'product) -(product-provide (provide 'pces) (require 'apel-ver)) - -;;; pces.el ends here diff --git a/poe/pcustom.el b/poe/pcustom.el deleted file mode 100644 index 4d023f1..0000000 --- a/poe/pcustom.el +++ /dev/null @@ -1,65 +0,0 @@ -;;; pcustom.el -- a portable custom.el. - -;; Copyright (C) 1999 Free Software Foundation, Inc. -;; Copyright (C) 1999 Mikio Nakajima - -;; Author: Mikio Nakajima -;; Shuhei KOBAYASHI -;; Keywords: emulating, custom - -;; This file is part of APEL (A Portable Emacs Library). - -;; This program is free software; you can redistribute it and/or -;; modify it under the terms of the GNU General Public License as -;; published by the Free Software Foundation; either version 2, or (at -;; your option) any later version. - -;; This program is distributed in the hope that it will be useful, but -;; WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with this program; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: - -;;; Code: - -(require 'poe) -(eval-when-compile (require 'static)) - -(static-if (condition-case nil - ;; compile-time check. - (if (and (require 'custom) - (fboundp 'custom-declare-variable)) - ;; you have "new custom". - t - ;; you have custom, but it is "old". - (message "\ - ** \"old custom\" is loaded. See README if you want to use \"new custom\".") - (sleep-for 1) - nil) - ;; you don't have custom. - (error nil)) - ;; you have "new custom". no load-time check. - (require 'custom) - ;; your custom is "old custom", - ;; or you don't have custom library at compile-time. - (or (condition-case nil - ;; load-time check. - ;; load "custom" if exists. - (and (require 'custom) - (fboundp 'custom-declare-variable)) - (error nil)) - ;; your custom is "old custom", - ;; or you don't have custom library. - ;; load emulation version of "new custom". - (require 'tinycustom))) - -(require 'product) -(product-provide (provide 'pcustom) (require 'apel-ver)) - -;;; pcustom.el ends here diff --git a/poe/poe.el b/poe/poe.el deleted file mode 100644 index 1458a0c..0000000 --- a/poe/poe.el +++ /dev/null @@ -1,1673 +0,0 @@ -;;; poe.el --- Portable Outfit for Emacsen - -;; Copyright (C) 1995,1996,1997,1998,1999 Free Software Foundation, Inc. - -;; Author: MORIOKA Tomohiko -;; Shuhei KOBAYASHI -;; Keywords: emulation, compatibility, Nemacs, MULE, Emacs/mule, XEmacs - -;; This file is part of APEL (A Portable Emacs Library). - -;; This program is free software; you can redistribute it and/or -;; modify it under the terms of the GNU General Public License as -;; published by the Free Software Foundation; either version 2, or (at -;; your option) any later version. - -;; This program is distributed in the hope that it will be useful, but -;; WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: - -;;; Code: - -(require 'product) -(product-provide (provide 'poe) (require 'apel-ver)) - -(require 'pym) - - -;;; @ Version information. -;;; - -(static-when (= emacs-major-version 18) - (require 'poe-18)) - -;; Some ancient version of XEmacs did not provide 'xemacs. -(static-when (string-match "XEmacs" emacs-version) - (provide 'xemacs)) - -;; `file-coding' was appeared in the spring of 1998, just before XEmacs -;; 21.0. Therefore it is not provided in XEmacs with MULE versions 20.4 -;; or earlier. -(static-when (featurep 'xemacs) - ;; must be load-time check to share .elc between w/ MULE and w/o MULE. - (when (featurep 'mule) - (provide 'file-coding))) - -(static-when (featurep 'xemacs) - (require 'poe-xemacs)) - -;; must be load-time check to share .elc between different systems. -(or (fboundp 'open-network-stream) - (require 'tcp)) - - -;;; @ C primitives emulation. -;;; - -;; Emacs 20.3 and earlier: (require FEATURE &optional FILENAME) -;; Emacs 20.4 and later: (require FEATURE &optional FILENAME NOERROR) -(static-condition-case nil - ;; compile-time check. - (progn - (require 'nofeature "nofile" 'noerror) - (if (get 'require 'defun-maybe) - (error "`require' is already redefined"))) - (error - ;; load-time check. - (or (fboundp 'si:require) - (progn - (fset 'si:require (symbol-function 'require)) - (put 'require 'defun-maybe t) - (defun require (feature &optional filename noerror) - "\ -If feature FEATURE is not loaded, load it from FILENAME. -If FEATURE is not a member of the list `features', then the feature -is not loaded; so load the file FILENAME. -If FILENAME is omitted, the printname of FEATURE is used as the file name, -but in this case `load' insists on adding the suffix `.el' or `.elc'. -If the optional third argument NOERROR is non-nil, -then return nil if the file is not found. -Normally the return value is FEATURE." - (if noerror - (condition-case nil - (si:require feature filename) - (file-error)) - (si:require feature filename))))))) - -;; Emacs 19.29 and later: (plist-get PLIST PROP) -;; (defun-maybe plist-get (plist prop) -;; (while (and plist -;; (not (eq (car plist) prop))) -;; (setq plist (cdr (cdr plist)))) -;; (car (cdr plist))) -(static-unless (and (fboundp 'plist-get) - (not (get 'plist-get 'defun-maybe))) - (or (fboundp 'plist-get) - (progn - (defvar plist-get-internal-symbol) - (defun plist-get (plist prop) - "\ -Extract a value from a property list. -PLIST is a property list, which is a list of the form -\(PROP1 VALUE1 PROP2 VALUE2...\). This function returns the value -corresponding to the given PROP, or nil if PROP is not -one of the properties on the list." - (setplist 'plist-get-internal-symbol plist) - (get 'plist-get-internal-symbol prop)) - ;; for `load-history'. - (setq current-load-list (cons 'plist-get current-load-list)) - (put 'plist-get 'defun-maybe t)))) - -;; Emacs 19.29 and later: (plist-put PLIST PROP VAL) -;; (defun-maybe plist-put (plist prop val) -;; (catch 'found -;; (let ((tail plist) -;; (prev nil)) -;; (while (and tail (cdr tail)) -;; (if (eq (car tail) prop) -;; (progn -;; (setcar (cdr tail) val) -;; (throw 'found plist)) -;; (setq prev tail -;; tail (cdr (cdr tail))))) -;; (if prev -;; (progn -;; (setcdr (cdr prev) (list prop val)) -;; plist) -;; (list prop val))))) -(static-unless (and (fboundp 'plist-put) - (not (get 'plist-put 'defun-maybe))) - (or (fboundp 'plist-put) - (progn - (defvar plist-put-internal-symbol) - (defun plist-put (plist prop val) - "\ -Change value in PLIST of PROP to VAL. -PLIST is a property list, which is a list of the form -\(PROP1 VALUE1 PROP2 VALUE2 ...\). PROP is a symbol and VAL is any object. -If PROP is already a property on the list, its value is set to VAL, -otherwise the new PROP VAL pair is added. The new plist is returned; -use `\(setq x \(plist-put x prop val\)\)' to be sure to use the new value. -The PLIST is modified by side effects." - (setplist 'plist-put-internal-symbol plist) - (put 'plist-put-internal-symbol prop val) - (symbol-plist 'plist-put-internal-symbol)) - ;; for `load-history'. - (setq current-load-list (cons 'plist-put current-load-list)) - (put 'plist-put 'defun-maybe t)))) - -;; Emacs 19.23 and later: (minibuffer-prompt-width) -(defun-maybe minibuffer-prompt-width () - "Return the display width of the minibuffer prompt." - (save-excursion - (set-buffer (window-buffer (minibuffer-window))) - (current-column))) - -;; (read-string PROMPT &optional INITIAL-INPUT HISTORY) -;; Emacs 19.29/XEmacs 19.14(?) and later takes optional 3rd arg HISTORY. -(static-unless (or (featurep 'xemacs) - (>= emacs-major-version 20) - (and (= emacs-major-version 19) - (>= emacs-minor-version 29))) - (or (fboundp 'si:read-string) - (progn - (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. -See `read-from-minibuffer' for details of HISTORY argument." - (si:read-string prompt initial-input))))) - -;; (completing-read prompt table &optional -;; FSF Emacs -;; --19.7 : predicate require-match init -;; 19.7 --19.34 : predicate require-match init hist -;; 20.1 -- : predicate require-match init hist def inherit-input-method -;; XEmacs -;; --19.(?): predicate require-match init -;; --21.2 : predicate require-match init hist -;; 21.2 -- : predicate require-match init hist def -;; ) - -;; We support following API. -;; (completing-read prompt table -;; &optional predicate require-match init hist def) -(static-cond - ;; add 'hist' and 'def' argument. - ((< emacs-major-version 19) - (or (fboundp 'si:completing-read) - (progn - (fset 'si:completing-read (symbol-function 'completing-read)) - (defun completing-read - (prompt table &optional predicate require-match init - hist def) - "Read a string in the minibuffer, with completion. -PROMPT is a string to prompt with; normally it ends in a colon and a space. -TABLE is an alist whose elements' cars are strings, or an obarray. -PREDICATE limits completion to a subset of TABLE. -See `try-completion' and `all-completions' for more details - on completion, TABLE, and PREDICATE. - -If REQUIRE-MATCH is non-nil, the user is not allowed to exit unless - the input is (or completes to) an element of TABLE or is null. - If it is also not t, Return does not exit if it does non-null completion. -If the input is null, `completing-read' returns an empty string, - regardless of the value of REQUIRE-MATCH. - -If INIT is non-nil, insert it in the minibuffer initially. - If it is (STRING . POSITION), the initial input - is STRING, but point is placed POSITION characters into the string. -HIST is ignored in this implementation. -DEF, if non-nil, is the default value. - -Completion ignores case if the ambient value of - `completion-ignore-case' is non-nil." - (let ((string (si:completing-read prompt table predicate - require-match init))) - (if (and (string= string "") def) - def string)))))) - ;; add 'def' argument. - ((or (and (featurep 'xemacs) - (or (and (eq emacs-major-version 21) - (< emacs-minor-version 2)) - (< emacs-major-version 21))) - (< emacs-major-version 20)) - (or (fboundp 'si:completing-read) - (progn - (fset 'si:completing-read (symbol-function 'completing-read)) - (defun completing-read - (prompt table &optional predicate require-match init - hist def) - "Read a string in the minibuffer, with completion. -PROMPT is a string to prompt with; normally it ends in a colon and a space. -TABLE is an alist whose elements' cars are strings, or an obarray. -PREDICATE limits completion to a subset of TABLE. -See `try-completion' and `all-completions' for more details - on completion, TABLE, and PREDICATE. - -If REQUIRE-MATCH is non-nil, the user is not allowed to exit unless - the input is (or completes to) an element of TABLE or is null. - If it is also not t, Return does not exit if it does non-null completion. -If the input is null, `completing-read' returns an empty string, - regardless of the value of REQUIRE-MATCH. - -If INIT is non-nil, insert it in the minibuffer initially. - If it is (STRING . POSITION), the initial input - is STRING, but point is placed POSITION characters into the string. -HIST, if non-nil, specifies a history list - and optionally the initial position in the list. - It can be a symbol, which is the history list variable to use, - or it can be a cons cell (HISTVAR . HISTPOS). - In that case, HISTVAR is the history list variable to use, - and HISTPOS is the initial position (the position in the list - which INIT corresponds to). - Positions are counted starting from 1 at the beginning of the list. -DEF, if non-nil, is the default value. - -Completion ignores case if the ambient value of - `completion-ignore-case' is non-nil." - (let ((string (si:completing-read prompt table predicate - require-match init hist))) - (if (and (string= string "") def) - def string))))))) - -;; v18: (string-to-int STRING) -;; v19: (string-to-number STRING) -;; v20: (string-to-number STRING &optional BASE) -;; -;; XXX: `string-to-number' of Emacs 20.3 and earlier is broken. -;; (string-to-number "1e1" 16) => 10.0, should be 481. -(static-condition-case nil - ;; compile-time check. - (if (= (string-to-number "1e1" 16) 481) - (if (get 'string-to-number 'defun-maybe) - (error "`string-to-number' is already redefined")) - (error "`string-to-number' is broken")) - (error - ;; load-time check. - (or (fboundp 'si:string-to-number) - (progn - (if (fboundp 'string-to-number) - (fset 'si:string-to-number (symbol-function 'string-to-number)) - (fset 'si:string-to-number (symbol-function 'string-to-int)) - ;; XXX: In v18, this causes infinite loop while bytecompiling. - ;; (defalias 'string-to-int 'string-to-number) - ) - (put 'string-to-number 'defun-maybe t) - (defun string-to-number (string &optional base) - "\ -Convert STRING to a number by parsing it as a decimal number. -This parses both integers and floating point numbers. -It ignores leading spaces and tabs. - -If BASE, interpret STRING as a number in that base. If BASE isn't -present, base 10 is used. BASE must be between 2 and 16 (inclusive). -If the base used is not 10, floating point is not recognized." - (if (or (null base) (= base 10)) - (si:string-to-number string) - (if (or (< base 2)(> base 16)) - (signal 'args-out-of-range (cons base nil))) - (let ((len (length string)) - (pos 0)) - ;; skip leading whitespace. - (while (and (< pos len) - (memq (aref string pos) '(?\ ?\t))) - (setq pos (1+ pos))) - (if (= pos len) - 0 - (let ((number 0)(negative 1) - chr num) - (if (eq (aref string pos) ?-) - (setq negative -1 - pos (1+ pos)) - (if (eq (aref string pos) ?+) - (setq pos (1+ pos)))) - (while (and (< pos len) - (setq chr (aref string pos) - num (cond - ((and (<= ?0 chr)(<= chr ?9)) - (- chr ?0)) - ((and (<= ?A chr)(<= chr ?F)) - (+ (- chr ?A) 10)) - ((and (<= ?a chr)(<= chr ?f)) - (+ (- chr ?a) 10)) - (t nil))) - (< num base)) - (setq number (+ (* number base) num) - pos (1+ pos))) - (* negative number)))))))))) - -;; Emacs 20.1 and 20.2: (concat-chars &rest CHARS) -;; Emacs 20.3/XEmacs 21.0 and later: (string &rest CHARS) -(static-cond - ((and (fboundp 'string) - (subrp (symbol-function 'string))) - ;; Emacs 20.3/XEmacs 21.0 and later. - ) - ((and (fboundp 'concat-chars) - (subrp (symbol-function 'concat-chars))) - ;; Emacs 20.1 and 20.2. - (defalias 'string 'concat-chars)) - (t - ;; Use `defun-maybe' to update `load-history'. - (defun-maybe string (&rest chars) - "Concatenate all the argument characters and make the result a string." - ;; We cannot use (apply 'concat chars) here because `concat' does not - ;; work with multibyte chars on Mule 1.* and 2.*. - (mapconcat (function char-to-string) chars "")))) - -;; Mule: (char-before POS) -;; v20: (char-before &optional POS) -(static-condition-case nil - ;; compile-time check. - (progn - (char-before) - (if (get 'char-before 'defun-maybe) - (error "`char-before' is already defined"))) - (wrong-number-of-arguments ; Mule. - ;; load-time check. - (or (fboundp 'si:char-before) - (progn - (fset 'si:char-before (symbol-function 'char-before)) - (put 'char-before 'defun-maybe t) - ;; takes IGNORED for backward compatibility. - (defun char-before (&optional pos ignored) - "\ -Return character in current buffer preceding position POS. -POS is an integer or a buffer pointer. -If POS is out of range, the value is nil." - (si:char-before (or pos (point))))))) - (void-function ; non-Mule. - ;; load-time check. - (defun-maybe char-before (&optional pos) - "\ -Return character in current buffer preceding position POS. -POS is an integer or a buffer pointer. -If POS is out of range, the value is nil." - (if pos - (save-excursion - (and (= (goto-char pos) (point)) - (not (bobp)) - (preceding-char))) - (and (not (bobp)) - (preceding-char))))) - (error ; found our definition at compile-time. - ;; load-time check. - (condition-case nil - (char-before) - (wrong-number-of-arguments ; Mule. - (or (fboundp 'si:char-before) - (progn - (fset 'si:char-before (symbol-function 'char-before)) - (put 'char-before 'defun-maybe t) - ;; takes IGNORED for backward compatibility. - (defun char-before (&optional pos ignored) - "\ -Return character in current buffer preceding position POS. -POS is an integer or a buffer pointer. -If POS is out of range, the value is nil." - (si:char-before (or pos (point))))))) - (void-function ; non-Mule. - (defun-maybe char-before (&optional pos) - "\ -Return character in current buffer preceding position POS. -POS is an integer or a buffer pointer. -If POS is out of range, the value is nil." - (if pos - (save-excursion - (and (= (goto-char pos) (point)) - (not (bobp)) - (preceding-char))) - (and (not (bobp)) - (preceding-char)))))))) - -;; v18, v19: (char-after POS) -;; v20: (char-after &optional POS) -(static-condition-case nil - ;; compile-time check. - (progn - (char-after) - (if (get 'char-after 'defun-maybe) - (error "`char-after' is already redefined"))) - (wrong-number-of-arguments ; v18, v19 - ;; load-time check. - (or (fboundp 'si:char-after) - (progn - (fset 'si:char-after (symbol-function 'char-after)) - (put 'char-after 'defun-maybe t) - (defun char-after (&optional pos) - "\ -Return character in current buffer at position POS. -POS is an integer or a buffer pointer. -If POS is out of range, the value is nil." - (si:char-after (or pos (point))))))) - (void-function ; NEVER happen? - ;; load-time check. - (defun-maybe char-after (&optional pos) - "\ -Return character in current buffer at position POS. -POS is an integer or a buffer pointer. -If POS is out of range, the value is nil." - (if pos - (save-excursion - (and (= (goto-char pos) (point)) - (not (eobp)) - (following-char))) - (and (not (eobp)) - (following-char))))) - (error ; found our definition at compile-time. - ;; load-time check. - (condition-case nil - (char-after) - (wrong-number-of-arguments ; v18, v19 - (or (fboundp 'si:char-after) - (progn - (fset 'si:char-after (symbol-function 'char-after)) - (put 'char-after 'defun-maybe t) - (defun char-after (&optional pos) - "\ -Return character in current buffer at position POS. -POS is an integer or a buffer pointer. -If POS is out of range, the value is nil." - (si:char-after (or pos (point))))))) - (void-function ; NEVER happen? - (defun-maybe char-after (&optional pos) - "\ -Return character in current buffer at position POS. -POS is an integer or a buffer pointer. -If POS is out of range, the value is nil." - (if pos - (save-excursion - (and (= (goto-char pos) (point)) - (not (eobp)) - (following-char))) - (and (not (eobp)) - (following-char)))))))) - -;; Emacs 19.29 and later: (buffer-substring-no-properties START END) -(defun-maybe buffer-substring-no-properties (start end) - "Return the characters of part of the buffer, without the text properties. -The two arguments START and END are character positions; -they can be in either order." - (let ((string (buffer-substring start end))) - (set-text-properties 0 (length string) nil string) - string)) - -;; Emacs 19.31 and later: (buffer-live-p OBJECT) -(defun-maybe buffer-live-p (object) - "Return non-nil if OBJECT is a buffer which has not been killed. -Value is nil if OBJECT is not a buffer or if it has been killed." - (and object - (get-buffer object) - (buffer-name (get-buffer object)) - t)) - -;; Emacs 20: (line-beginning-position &optional N) -(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. -If scan reaches end of buffer, return that position. -This function does not move point." - (save-excursion - (forward-line (1- (or n 1))) - (point))) - -;; Emacs 20: (line-end-position &optional N) -(defun-maybe line-end-position (&optional n) - "Return the character position of the last character on the current line. -With argument N not nil or 1, move forward N - 1 lines first. -If scan reaches end of buffer, return that position. -This function does not move point." - (save-excursion - (end-of-line (or n 1)) - (point))) - -;; FSF Emacs 19.29 and later -;; (read-file-name PROMPT &optional DIR DEFAULT-FILENAME MUSTMATCH INITIAL) -;; XEmacs 19.14 and later: -;; (read-file-name (PROMPT &optional DIR DEFAULT MUST-MATCH INITIAL-CONTENTS -;; HISTORY) - -;; In FSF Emacs 19.28 and earlier (except for v18) or XEmacs 19.13 and -;; earlier, this function is incompatible with the other Emacsen. -;; For instance, if DEFAULT-FILENAME is nil, INITIAL is not and user -;; enters a null string, it returns the visited file name of the current -;; buffer if it is non-nil. - -;; It does not assimilate the different numbers of the optional arguments -;; on various Emacsen (yet). -(static-cond - ((and (not (featurep 'xemacs)) - (eq emacs-major-version 19) - (< emacs-minor-version 29)) - (if (fboundp 'si:read-file-name) - nil - (fset 'si:read-file-name (symbol-function 'read-file-name)) - (defun read-file-name (prompt &optional dir default-filename mustmatch - initial) - "Read file name, prompting with PROMPT and completing in directory DIR. -Value is not expanded---you must call `expand-file-name' yourself. -Default name to DEFAULT-FILENAME if user enters a null string. - (If DEFAULT-FILENAME is omitted, the visited file name is used, - except that if INITIAL is specified, that combined with DIR is used.) -Fourth arg MUSTMATCH non-nil means require existing file's name. - Non-nil and non-t means also require confirmation after completion. -Fifth arg INITIAL specifies text to start with. -DIR defaults to current buffer's directory default." - (si:read-file-name prompt dir - (or default-filename - (if initial - (expand-file-name initial dir))) - mustmatch initial)))) - ((and (featurep 'xemacs) - (eq emacs-major-version 19) - (< emacs-minor-version 14)) - (if (fboundp 'si:read-file-name) - nil - (fset 'si:read-file-name (symbol-function 'read-file-name)) - (defun read-file-name (prompt &optional dir default must-match - initial-contents history) - "Read file name, prompting with PROMPT and completing in directory DIR. -This will prompt with a dialog box if appropriate, according to - `should-use-dialog-box-p'. -Value is not expanded---you must call `expand-file-name' yourself. -Value is subject to interpreted by substitute-in-file-name however. -Default name to DEFAULT if user enters a null string. - (If DEFAULT is omitted, the visited file name is used, - except that if INITIAL-CONTENTS is specified, that combined with DIR is - used.) -Fourth arg MUST-MATCH non-nil means require existing file's name. - Non-nil and non-t means also require confirmation after completion. -Fifth arg INITIAL-CONTENTS specifies text to start with. -Sixth arg HISTORY specifies the history list to use. Default is - `file-name-history'. -DIR defaults to current buffer's directory default." - (si:read-file-name prompt dir - (or default - (if initial-contents - (expand-file-name initial-contents dir))) - must-match initial-contents history))))) - - -;;; @ Basic lisp subroutines emulation. (lisp/subr.el) -;;; - -;;; @@ Lisp language features. - -(defmacro-maybe push (newelt listname) - "Add NEWELT to the list stored in the symbol LISTNAME. -This is equivalent to (setq LISTNAME (cons NEWELT LISTNAME)). -LISTNAME must be a symbol." - (list 'setq listname - (list 'cons newelt listname))) - -(defmacro-maybe pop (listname) - "Return the first element of LISTNAME's value, and remove it from the list. -LISTNAME must be a symbol whose value is a list. -If the value is nil, `pop' returns nil but does not actually -change the list." - (list 'prog1 (list 'car listname) - (list 'setq listname (list 'cdr listname)))) - -(defmacro-maybe when (cond &rest body) - "If COND yields non-nil, do BODY, else return nil." - (list 'if cond (cons 'progn body))) -;; (def-edebug-spec when (&rest form)) - -(defmacro-maybe unless (cond &rest body) - "If COND yields nil, do BODY, else return nil." - (cons 'if (cons cond (cons nil body)))) -;; (def-edebug-spec unless (&rest form)) - -(defsubst-maybe caar (x) - "Return the car of the car of X." - (car (car x))) - -(defsubst-maybe cadr (x) - "Return the car of the cdr of X." - (car (cdr x))) - -(defsubst-maybe cdar (x) - "Return the cdr of the car of X." - (cdr (car x))) - -(defsubst-maybe cddr (x) - "Return the cdr of the cdr of X." - (cdr (cdr x))) - -(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)) - -;; Actually, `butlast' and `nbutlast' are defined in lisp/cl.el. -(defun 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))) - -(defun nbutlast (x &optional n) - "Modifies LIST to remove the last N elements." - (let ((m (length x))) - (or n (setq n 1)) - (and (< n m) - (progn - (if (> n 0) (setcdr (nthcdr (- (1- m) n) x) nil)) - x)))) - -;; Emacs 20.3 and later: (assoc-default KEY ALIST &optional TEST DEFAULT) -(defun-maybe assoc-default (key alist &optional test default) - "Find object KEY in a pseudo-alist ALIST. -ALIST is a list of conses or objects. Each element (or the element's car, -if it is a cons) is compared with KEY by evaluating (TEST (car elt) KEY). -If that is non-nil, the element matches; -then `assoc-default' returns the element's cdr, if it is a cons, -or DEFAULT if the element is not a cons. - -If no element matches, the value is nil. -If TEST is omitted or nil, `equal' is used." - (let (found (tail alist) value) - (while (and tail (not found)) - (let ((elt (car tail))) - (when (funcall (or test 'equal) (if (consp elt) (car elt) elt) key) - (setq found t value (if (consp elt) (cdr elt) default)))) - (setq tail (cdr tail))) - value)) - -;; The following two function use `compare-strings', which we don't -;; support yet. -;; (defun assoc-ignore-case (key alist)) -;; (defun assoc-ignore-representation (key alist)) - -;; Emacs 19.29/XEmacs 19.13 and later: (rassoc KEY LIST) -;; Actually, `rassoc' is defined in src/fns.c. -(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. -Elements of LIST that are not conses are ignored." - (catch 'found - (while list - (cond ((not (consp (car list)))) - ((equal (cdr (car list)) key) - (throw 'found (car list)))) - (setq list (cdr list))))) - -;; XEmacs 19.13 and later: (remassq KEY LIST) -(defun-maybe remassq (key list) - "Delete by side effect any elements of LIST whose car is `eq' to KEY. -The modified LIST is returned. If the first member of LIST has a car -that is `eq' to KEY, there is no way to remove it by side effect; -therefore, write `(setq foo (remassq key foo))' to be sure of changing -the value of `foo'." - (if (setq key (assq key list)) - (delq key list) - list)) - -;; XEmacs 19.13 and later: (remassoc KEY LIST) -(defun-maybe remassoc (key list) - "Delete by side effect any elements of LIST whose car is `equal' to KEY. -The modified LIST is returned. If the first member of LIST has a car -that is `equal' to KEY, there is no way to remove it by side effect; -therefore, write `(setq foo (remassoc key foo))' to be sure of changing -the value of `foo'." - (if (setq key (assoc key list)) - (delq key list) - list)) - -;; XEmacs 19.13 and later: (remrassq VALUE LIST) -(defun-maybe remrassq (value list) - "Delete by side effect any elements of LIST whose cdr is `eq' to VALUE. -The modified LIST is returned. If the first member of LIST has a car -that is `eq' to VALUE, there is no way to remove it by side effect; -therefore, write `(setq foo (remrassq value foo))' to be sure of changing -the value of `foo'." - (if (setq value (rassq value list)) - (delq value list) - list)) - -;; XEmacs 19.13 and later: (remrassoc VALUE LIST) -(defun-maybe remrassoc (value list) - "Delete by side effect any elements of LIST whose cdr is `equal' to VALUE. -The modified LIST is returned. If the first member of LIST has a car -that is `equal' to VALUE, there is no way to remove it by side effect; -therefore, write `(setq foo (remrassoc value foo))' to be sure of changing -the value of `foo'." - (if (setq value (rassoc value list)) - (delq value list) - list)) - -;;; Define `functionp' here because "localhook" uses it. - -;; Emacs 20.1/XEmacs 20.3 (but first appeared in Epoch?): (functionp OBJECT) -(defun-maybe functionp (object) - "Non-nil if OBJECT is a type of object that can be called as a function." - (or (subrp object) (byte-code-function-p object) - (eq (car-safe object) 'lambda) - (and (symbolp object) (fboundp object)))) - -;;; @@ Hook manipulation functions. - -;; "localhook" package is written for Emacs 19.28 and earlier. -;; `run-hooks' was a lisp function in Emacs 19.29 and earlier. -;; So, in Emacs 19.29, `run-hooks' and others will be overrided. -;; But, who cares it? -(static-unless (subrp (symbol-function 'run-hooks)) - (require 'localhook)) - -;; Emacs 19.29/XEmacs 19.14(?) and later: (add-to-list LIST-VAR ELEMENT) -(defun-maybe add-to-list (list-var element) - "Add to the value of LIST-VAR the element ELEMENT if it isn't there yet. -The test for presence of ELEMENT is done with `equal'. -If you want to use `add-to-list' on a variable that is not defined -until a certain package is loaded, you should put the call to `add-to-list' -into a hook function that will be run only after loading the package. -`eval-after-load' provides one way to do this. In some cases -other hooks, such as major mode hooks, can do the job." - (or (member element (symbol-value list-var)) - (set list-var (cons element (symbol-value list-var))))) - -;; (eval-after-load FILE FORM) -;; Emacs 19.28 and earlier do not evaluate FORM if FILE is already loaded. -;; XEmacs 20.2 and earlier have `after-load-alist', but refuse to support -;; `eval-after-load'. (see comments in XEmacs/lisp/subr.el.) -(static-cond - ((featurep 'xemacs) - ;; for XEmacs 20.2 and earlier. - (defun-maybe eval-after-load (file form) - "Arrange that, if FILE is ever loaded, FORM will be run at that time. -This makes or adds to an entry on `after-load-alist'. -If FILE is already loaded, evaluate FORM right now. -It does nothing if FORM is already on the list for FILE. -FILE should be the name of a library, with no directory name." - ;; Make sure there is an element for FILE. - (or (assoc file after-load-alist) - (setq after-load-alist (cons (list file) after-load-alist))) - ;; Add FORM to the element if it isn't there. - (let ((elt (assoc file after-load-alist))) - (or (member form (cdr elt)) - (progn - (nconc elt (list form)) - ;; If the file has been loaded already, run FORM right away. - (and (assoc file load-history) - (eval form))))) - form)) - ((>= emacs-major-version 20)) - ((and (= emacs-major-version 19) - (< emacs-minor-version 29)) - ;; for Emacs 19.28 and earlier. - (defun eval-after-load (file form) - "Arrange that, if FILE is ever loaded, FORM will be run at that time. -This makes or adds to an entry on `after-load-alist'. -If FILE is already loaded, evaluate FORM right now. -It does nothing if FORM is already on the list for FILE. -FILE should be the name of a library, with no directory name." - ;; Make sure there is an element for FILE. - (or (assoc file after-load-alist) - (setq after-load-alist (cons (list file) after-load-alist))) - ;; Add FORM to the element if it isn't there. - (let ((elt (assoc file after-load-alist))) - (or (member form (cdr elt)) - (progn - (nconc elt (list form)) - ;; If the file has been loaded already, run FORM right away. - (and (assoc file load-history) - (eval form))))) - form)) - (t - ;; should emulate for v18? - )) - -(defun-maybe eval-next-after-load (file) - "Read the following input sexp, and run it whenever FILE is loaded. -This makes or adds to an entry on `after-load-alist'. -FILE should be the name of a library, with no directory name." - (eval-after-load file (read))) - -;;; @@ Input and display facilities. - -;; XXX: (defun read-passwd (prompt &optional confirm default)) - -;;; @@ Miscellanea. - -;; Avoid compiler warnings about this variable, -;; which has a special meaning on certain system types. -(defvar-maybe buffer-file-type nil - "Non-nil if the visited file is a binary file. -This variable is meaningful on MS-DOG and Windows NT. -On those systems, it is automatically local in every buffer. -On other systems, this variable is normally always nil.") - -;; Emacs 20.1/XEmacs 20.3(?) and later: (save-current-buffer &rest BODY) -;; -;; v20 defines `save-current-buffer' as a C primitive (in src/editfns.c) -;; and introduces a new bytecode Bsave_current_buffer(_1), replacing an -;; obsolete bytecode Bread_char. To make things worse, Emacs 20.1 and -;; 20.2 have a bug that it will restore the current buffer without -;; confirming that it is alive. -;; -;; This is a source of incompatibility of .elc between v18/v19 and v20. -;; (XEmacs compiler takes care of it if compatibility mode is enabled.) -(defmacro-maybe save-current-buffer (&rest body) - "Save the current buffer; execute BODY; restore the current buffer. -Executes BODY just like `progn'." - (` (let ((orig-buffer (current-buffer))) - (unwind-protect - (progn (,@ body)) - (if (buffer-live-p orig-buffer) - (set-buffer orig-buffer)))))) - -;; Emacs 20.1/XEmacs 20.3(?) and later: (with-current-buffer BUFFER &rest BODY) -(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. -See also `with-temp-buffer'." - (` (save-current-buffer - (set-buffer (, buffer)) - (,@ body)))) - -;; Emacs 20.1/XEmacs 20.3(?) and later: (with-temp-file FILE &rest FORMS) -(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'. -See also `with-temp-buffer'." - (let ((temp-file (make-symbol "temp-file")) - (temp-buffer (make-symbol "temp-buffer"))) - (` (let (((, temp-file) (, file)) - ((, temp-buffer) - (get-buffer-create (generate-new-buffer-name " *temp file*")))) - (unwind-protect - (prog1 - (with-current-buffer (, temp-buffer) - (,@ forms)) - (with-current-buffer (, temp-buffer) - (widen) - (write-region (point-min) (point-max) (, temp-file) nil 0))) - (and (buffer-name (, temp-buffer)) - (kill-buffer (, temp-buffer)))))))) - -;; Emacs 20.4 and later: (with-temp-message MESSAGE &rest BODY) -;; This macro uses `current-message', which appears in v20. -(static-when (and (fboundp 'current-message) - (subrp (symbol-function 'current-message))) - (defmacro-maybe with-temp-message (message &rest body) - "\ -Display MESSAGE temporarily if non-nil while BODY is evaluated. -The original message is restored to the echo area after BODY has finished. -The value returned is the value of the last form in BODY. -MESSAGE is written to the message log buffer if `message-log-max' is non-nil. -If MESSAGE is nil, the echo area and message log buffer are unchanged. -Use a MESSAGE of \"\" to temporarily clear the echo area." - (let ((current-message (make-symbol "current-message")) - (temp-message (make-symbol "with-temp-message"))) - (` (let (((, temp-message) (, message)) - ((, current-message))) - (unwind-protect - (progn - (when (, temp-message) - (setq (, current-message) (current-message)) - (message "%s" (, temp-message)) - (,@ body)) - (and (, temp-message) (, current-message) - (message "%s" (, current-message)))))))))) - -;; Emacs 20.1/XEmacs 20.3(?) and later: (with-temp-buffer &rest FORMS) -(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'." - (let ((temp-buffer (make-symbol "temp-buffer"))) - (` (let (((, temp-buffer) - (get-buffer-create (generate-new-buffer-name " *temp*")))) - (unwind-protect - (with-current-buffer (, temp-buffer) - (,@ forms)) - (and (buffer-name (, temp-buffer)) - (kill-buffer (, temp-buffer)))))))) - -;; Emacs 20.1/XEmacs 20.3(?) and later: (with-output-to-string &rest BODY) -(defmacro-maybe with-output-to-string (&rest body) - "Execute BODY, return the text it sent to `standard-output', as a string." - (` (let ((standard-output - (get-buffer-create (generate-new-buffer-name " *string-output*")))) - (let ((standard-output standard-output)) - (,@ body)) - (with-current-buffer standard-output - (prog1 - (buffer-string) - (kill-buffer nil)))))) - -;; Emacs 20.1 and later: (combine-after-change-calls &rest BODY) -(defmacro-maybe combine-after-change-calls (&rest body) - "Execute BODY, but don't call the after-change functions till the end. -If BODY makes changes in the buffer, they are recorded -and the functions on `after-change-functions' are called several times -when BODY is finished. -The return value is the value of the last form in BODY. - -If `before-change-functions' is non-nil, then calls to the after-change -functions can't be deferred, so in that case this macro has no effect. - -Do not alter `after-change-functions' or `before-change-functions' -in BODY. - -This emulating macro does not support after-change functions at all, -just execute BODY." - (cons 'progn body)) - -;; Emacs 19.29/XEmacs 19.14(?) and later: (match-string NUM &optional STRING) -(defun-maybe match-string (num &optional string) - "Return string of text matched by last search. -NUM specifies which parenthesized expression in the last regexp. - Value is nil if NUMth pair didn't match, or there were less than NUM pairs. -Zero means the entire text matched by the whole regexp or whole string. -STRING should be given if the last search was by `string-match' on STRING." - (if (match-beginning num) - (if string - (substring string (match-beginning num) (match-end num)) - (buffer-substring (match-beginning num) (match-end num))))) - -;; Emacs 20.3 and later: (match-string-no-properties NUM &optional STRING) -(defun-maybe match-string-no-properties (num &optional string) - "Return string of text matched by last search, without text properties. -NUM specifies which parenthesized expression in the last regexp. - Value is nil if NUMth pair didn't match, or there were less than NUM pairs. -Zero means the entire text matched by the whole regexp or whole string. -STRING should be given if the last search was by `string-match' on STRING." - (if (match-beginning num) - (if string - (let ((result - (substring string (match-beginning num) (match-end num)))) - (set-text-properties 0 (length result) nil result) - result) - (buffer-substring-no-properties (match-beginning num) - (match-end num))))) - -;; Emacs 19.28 and earlier -;; (replace-match NEWTEXT &optional FIXEDCASE LITERAL) -;; Emacs 20.x (?) and later -;; (replace-match NEWTEXT &optional FIXEDCASE LITERAL STRING SUBEXP) -;; XEmacs 21: -;; (replace-match NEWTEXT &optional FIXEDCASE LITERAL STRING STRBUFFER) -;; We support following API. -;; (replace-match NEWTEXT &optional FIXEDCASE LITERAL STRING) -(static-condition-case nil - ;; compile-time check - (progn - (string-match "" "") - (replace-match "" nil nil "") - (if (get 'replace-match 'defun-maybe) - (error "`replace-match' is already defined"))) - (wrong-number-of-arguments ; Emacs 19.28 and earlier - ;; load-time check. - (or (fboundp 'si:replace-match) - (progn - (fset 'si:replace-match (symbol-function 'replace-match)) - (put 'replace-match 'defun-maybe t) - (defun replace-match (newtext &optional fixedcase literal string) - "Replace text matched by last search with NEWTEXT. -If second arg FIXEDCASE is non-nil, do not alter case of replacement text. -Otherwise maybe capitalize the whole text, or maybe just word initials, -based on the replaced text. -If the replaced text has only capital letters -and has at least one multiletter word, convert NEWTEXT to all caps. -If the replaced text has at least one word starting with a capital letter, -then capitalize each word in NEWTEXT. - -If third arg LITERAL is non-nil, insert NEWTEXT literally. -Otherwise treat `\' as special: - `\&' in NEWTEXT means substitute original matched text. - `\N' means substitute what matched the Nth `\(...\)'. - If Nth parens didn't match, substitute nothing. - `\\' means insert one `\'. -FIXEDCASE and LITERAL are optional arguments. -Leaves point at end of replacement text. - -The optional fourth argument STRING can be a string to modify. -In that case, this function creates and returns a new string -which is made by replacing the part of STRING that was matched." - (if string - (with-temp-buffer - (save-match-data - (insert string) - (let* ((matched (match-data)) - (beg (nth 0 matched)) - (end (nth 1 matched))) - (store-match-data - (list - (if (markerp beg) - (move-marker beg (1+ (match-beginning 0))) - (1+ (match-beginning 0))) - (if (markerp end) - (move-marker end (1+ (match-end 0))) - (1+ (match-end 0)))))) - (si:replace-match newtext fixedcase literal) - (buffer-string))) - (si:replace-match newtext fixedcase literal)))))) - (error ; found our definition at compile-time. - ;; load-time check. - (condition-case nil - (progn - (string-match "" "") - (replace-match "" nil nil "")) - (wrong-number-of-arguments ; Emacs 19.28 and earlier - ;; load-time check. - (or (fboundp 'si:replace-match) - (progn - (fset 'si:replace-match (symbol-function 'replace-match)) - (put 'replace-match 'defun-maybe t) - (defun replace-match (newtext &optional fixedcase literal string) - "Replace text matched by last search with NEWTEXT. -If second arg FIXEDCASE is non-nil, do not alter case of replacement text. -Otherwise maybe capitalize the whole text, or maybe just word initials, -based on the replaced text. -If the replaced text has only capital letters -and has at least one multiletter word, convert NEWTEXT to all caps. -If the replaced text has at least one word starting with a capital letter, -then capitalize each word in NEWTEXT. - -If third arg LITERAL is non-nil, insert NEWTEXT literally. -Otherwise treat `\' as special: - `\&' in NEWTEXT means substitute original matched text. - `\N' means substitute what matched the Nth `\(...\)'. - If Nth parens didn't match, substitute nothing. - `\\' means insert one `\'. -FIXEDCASE and LITERAL are optional arguments. -Leaves point at end of replacement text. - -The optional fourth argument STRING can be a string to modify. -In that case, this function creates and returns a new string -which is made by replacing the part of STRING that was matched." - (if string - (with-temp-buffer - (save-match-data - (insert string) - (let* ((matched (match-data)) - (beg (nth 0 matched)) - (end (nth 1 matched))) - (store-match-data - (list - (if (markerp beg) - (move-marker beg (1+ (match-beginning 0))) - (1+ (match-beginning 0))) - (if (markerp end) - (move-marker end (1+ (match-end 0))) - (1+ (match-end 0)))))) - (si:replace-match newtext fixedcase literal) - (buffer-string))) - (si:replace-match newtext fixedcase literal))))))))) - -;; Emacs 20: (format-time-string) -;; The the third optional argument universal is yet to be implemented. -;; Those format constructs are yet to be implemented. -;; %c, %C, %j, %U, %W, %x, %X -;; Not fully compatible especially when invalid format is specified. -(static-unless (and (fboundp 'format-time-string) - (not (get 'format-time-string 'defun-maybe))) - (or (fboundp 'format-time-string) - (progn - (defconst format-time-month-list - '(( "Zero" . ("Zero" . 0)) - ("Jan" . ("January" . 1)) ("Feb" . ("February" . 2)) - ("Mar" . ("March" . 3)) ("Apr" . ("April" . 4)) ("May" . ("May" . 5)) - ("Jun" . ("June" . 6))("Jul" . ("July" . 7)) ("Aug" . ("August" . 8)) - ("Sep" . ("September" . 9)) ("Oct" . ("October" . 10)) - ("Nov" . ("November" . 11)) ("Dec" . ("December" . 12))) - "Alist of months and their number.") - - (defconst format-time-week-list - '(("Sun" . ("Sunday" . 0)) ("Mon" . ("Monday" . 1)) - ("Tue" . ("Tuesday" . 2)) ("Wed" . ("Wednesday" . 3)) - ("Thu" . ("Thursday" . 4)) ("Fri" . ("Friday" . 5)) - ("Sat" . ("Saturday" . 6))) - "Alist of weeks and their number.") - - (defun format-time-string (format &optional time universal) - "Use FORMAT-STRING to format the time TIME, or now if omitted. -TIME is specified as (HIGH LOW . IGNORED) or (HIGH . LOW), as returned by -`current-time' or `file-attributes'. -The third, optional, argument UNIVERSAL, if non-nil, means describe TIME -as Universal Time; nil means describe TIME in the local time zone. -The value is a copy of FORMAT-STRING, but with certain constructs replaced -by text that describes the specified date and time in TIME: - -%Y is the year, %y within the century, %C the century. -%G is the year corresponding to the ISO week, %g within the century. -%m is the numeric month. -%b and %h are the locale's abbreviated month name, %B the full name. -%d is the day of the month, zero-padded, %e is blank-padded. -%u is the numeric day of week from 1 (Monday) to 7, %w from 0 (Sunday) to 6. -%a is the locale's abbreviated name of the day of week, %A the full name. -%U is the week number starting on Sunday, %W starting on Monday, - %V according to ISO 8601. -%j is the day of the year. - -%H is the hour on a 24-hour clock, %I is on a 12-hour clock, %k is like %H - only blank-padded, %l is like %I blank-padded. -%p is the locale's equivalent of either AM or PM. -%M is the minute. -%S is the second. -%Z is the time zone name, %z is the numeric form. -%s is the number of seconds since 1970-01-01 00:00:00 +0000. - -%c is the locale's date and time format. -%x is the locale's \"preferred\" date format. -%D is like \"%m/%d/%y\". - -%R is like \"%H:%M\", %T is like \"%H:%M:%S\", %r is like \"%I:%M:%S %p\". -%X is the locale's \"preferred\" time format. - -Finally, %n is a newline, %t is a tab, %% is a literal %. - -Certain flags and modifiers are available with some format controls. -The flags are `_' and `-'. For certain characters X, %_X is like %X, -but padded with blanks; %-X is like %X, but without padding. -%NX (where N stands for an integer) is like %X, -but takes up at least N (a number) positions. -The modifiers are `E' and `O'. For certain characters X, -%EX is a locale's alternative version of %X; -%OX is like %X, but uses the locale's number symbols. - -For example, to produce full ISO 8601 format, use \"%Y-%m-%dT%T%z\". - -Compatibility Note. - -The the third optional argument universal is yet to be implemented. -Those format constructs are yet to be implemented. - %c, %C, %j, %U, %W, %x, %X -Not fully compatible especially when invalid format is specified." - (let ((fmt-len (length format)) - (ind 0) - prev-ind - cur-char - (prev-char nil) - strings-so-far - (result "") - field-width - field-result - pad-left change-case - (paren-level 0) - hour - (time-string (current-time-string time))) - (setq hour (string-to-int (substring time-string 11 13))) - (while (< ind fmt-len) - (setq cur-char (aref format ind)) - (setq - result - (concat result - (cond - ((eq cur-char ?%) - ;; eat any additional args to allow for future expansion, not!! - (setq pad-left nil change-case nil field-width "" prev-ind ind - strings-so-far "") -; (catch 'invalid - (while (progn - (setq ind (1+ ind)) - (setq cur-char (if (< ind fmt-len) - (aref format ind) - ?\0)) - (or (eq ?- cur-char) ; pad on left - (eq ?# cur-char) ; case change - (if (and (string-equal field-width "") - (<= ?0 cur-char) (>= ?9 cur-char)) - ;; get format width - (let ((field-index ind)) - (while (progn - (setq ind (1+ ind)) - (setq cur-char (if (< ind fmt-len) - (aref format ind) - ?\0)) - (and (<= ?0 cur-char) (>= ?9 cur-char)))) - (setq field-width - (substring format field-index ind)) - (setq ind (1- ind) - cur-char nil) - t)))) - (setq prev-char cur-char - strings-so-far (concat strings-so-far - (if cur-char - (char-to-string cur-char) - field-width))) - ;; characters we actually use - (cond ((eq cur-char ?-) - ;; padding to left must be specified before field-width - (setq pad-left (string-equal field-width ""))) - ((eq cur-char ?#) - (setq change-case t)))) - (setq field-result - (cond - ((eq cur-char ?%) - "%") - ;; the abbreviated name of the day of week. - ((eq cur-char ?a) - (substring time-string 0 3)) - ;; the full name of the day of week - ((eq cur-char ?A) - (cadr (assoc (substring time-string 0 3) - format-time-week-list))) - ;; the abbreviated name of the month - ((eq cur-char ?b) - (substring time-string 4 7)) - ;; the full name of the month - ((eq cur-char ?B) - (cadr (assoc (substring time-string 4 7) - format-time-month-list))) - ;; a synonym for `%x %X' (yet to come) - ((eq cur-char ?c) - "") - ;; locale specific (yet to come) - ((eq cur-char ?C) - "") - ;; the day of month, zero-padded - ((eq cur-char ?d) - (format "%02d" (string-to-int (substring time-string 8 10)))) - ;; a synonym for `%m/%d/%y' - ((eq cur-char ?D) - (format "%02d/%02d/%s" - (cddr (assoc (substring time-string 4 7) - format-time-month-list)) - (string-to-int (substring time-string 8 10)) - (substring time-string -2))) - ;; the day of month, blank-padded - ((eq cur-char ?e) - (format "%2d" (string-to-int (substring time-string 8 10)))) - ;; a synonym for `%b' - ((eq cur-char ?h) - (substring time-string 4 7)) - ;; the hour (00-23) - ((eq cur-char ?H) - (substring time-string 11 13)) - ;; the hour (00-12) - ((eq cur-char ?I) - (format "%02d" (if (> hour 12) (- hour 12) hour))) - ;; the day of the year (001-366) (yet to come) - ((eq cur-char ?j) - "") - ;; the hour (0-23), blank padded - ((eq cur-char ?k) - (format "%2d" hour)) - ;; the hour (1-12), blank padded - ((eq cur-char ?l) - (format "%2d" (if (> hour 12) (- hour 12) hour))) - ;; the month (01-12) - ((eq cur-char ?m) - (format "%02d" (cddr (assoc (substring time-string 4 7) - format-time-month-list)))) - ;; the minute (00-59) - ((eq cur-char ?M) - (substring time-string 14 16)) - ;; a newline - ((eq cur-char ?n) - "\n") - ;; `AM' or `PM', as appropriate - ((eq cur-char ?p) - (setq change-case (not change-case)) - (if (> hour 12) "pm" "am")) - ;; a synonym for `%I:%M:%S %p' - ((eq cur-char ?r) - (format "%02d:%s:%s %s" - (if (> hour 12) (- hour 12) hour) - (substring time-string 14 16) - (substring time-string 17 19) - (if (> hour 12) "PM" "AM"))) - ;; a synonym for `%H:%M' - ((eq cur-char ?R) - (format "%s:%s" - (substring time-string 11 13) - (substring time-string 14 16))) - ;; the seconds (00-60) - ((eq cur-char ?S) - (substring time-string 17 19)) - ;; a tab character - ((eq cur-char ?t) - "\t") - ;; a synonym for `%H:%M:%S' - ((eq cur-char ?T) - (format "%s:%s:%s" - (substring time-string 11 13) - (substring time-string 14 16) - (substring time-string 17 19))) - ;; the week of the year (01-52), assuming that weeks - ;; start on Sunday (yet to come) - ((eq cur-char ?U) - "") - ;; the numeric day of week (0-6). Sunday is day 0 - ((eq cur-char ?w) - (format "%d" (cddr (assoc (substring time-string 0 3) - format-time-week-list)))) - ;; the week of the year (01-52), assuming that weeks - ;; start on Monday (yet to come) - ((eq cur-char ?W) - "") - ;; locale specific (yet to come) - ((eq cur-char ?x) - "") - ;; locale specific (yet to come) - ((eq cur-char ?X) - "") - ;; the year without century (00-99) - ((eq cur-char ?y) - (substring time-string -2)) - ;; the year with century - ((eq cur-char ?Y) - (substring time-string -4)) - ;; the time zone abbreviation - ((eq cur-char ?Z) - (setq change-case (not change-case)) - (downcase (cadr (current-time-zone)))) - (t - (concat - "%" - strings-so-far - (char-to-string cur-char))))) -; (setq ind prev-ind) -; (throw 'invalid "%")))) - (if (string-equal field-width "") - (if change-case (upcase field-result) field-result) - (let ((padded-result - (format (format "%%%s%s%c" - "" ; pad on left is ignored -; (if pad-left "-" "") - field-width - ?s) - (or field-result "")))) - (let ((initial-length (length padded-result)) - (desired-length (string-to-int field-width))) - (when (and (string-match "^0" field-width) - (string-match "^ +" padded-result)) - (setq padded-result - (replace-match - (make-string - (length (match-string 0 padded-result)) ?0) - nil nil padded-result))) - (if (> initial-length desired-length) - ;; truncate strings on right, years on left - (if (stringp field-result) - (substring padded-result 0 desired-length) - (if (eq cur-char ?y) - (substring padded-result (- desired-length)) - padded-result))) ;non-year numbers don't truncate - (if change-case (upcase padded-result) padded-result))))) ;) - (t - (char-to-string cur-char))))) - (setq ind (1+ ind))) - result)) - ;; for `load-history'. - (setq current-load-list (cons 'format-time-string current-load-list)) - (put 'format-time-string 'defun-maybe t)))) - -;; Emacs 20.1/XEmacs 20.3(?) and later: (split-string STRING &optional PATTERN) -;; Here is a XEmacs version. -(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]+\"." - (or pattern - (setq pattern "[ \f\t\n\r\v]+")) - ;; The FSF version of this function takes care not to cons in case - ;; of infloop. Maybe we should synch? - (let (parts (start 0)) - (while (string-match pattern string start) - (setq parts (cons (substring string start (match-beginning 0)) parts) - start (match-end 0))) - (nreverse (cons (substring string start) parts)))) - - -;;; @ Window commands emulation. (lisp/window.el) -;;; - -(defmacro-maybe save-selected-window (&rest body) - "Execute BODY, then select the window that was selected before BODY." - (list 'let - '((save-selected-window-window (selected-window))) - (list 'unwind-protect - (cons 'progn body) - (list 'select-window 'save-selected-window-window)))) - -;; Emacs 19.31 and later: -;; (get-buffer-window-list &optional BUFFER MINIBUF FRAME) -(defun-maybe get-buffer-window-list (buffer &optional minibuf frame) - "Return windows currently displaying BUFFER, or nil if none. -See `walk-windows' for the meaning of MINIBUF and FRAME." - (let ((buffer (if (bufferp buffer) buffer (get-buffer buffer))) windows) - (walk-windows - (function (lambda (window) - (if (eq (window-buffer window) buffer) - (setq windows (cons window windows))))) - minibuf frame) - windows)) - - -;;; @ Frame commands emulation. (lisp/frame.el) -;;; - -;; XEmacs 21.0 and later: -;; (save-selected-frame &rest BODY) -(defmacro-maybe save-selected-frame (&rest body) - "Execute forms in BODY, then restore the selected frame." - (list 'let - '((save-selected-frame-frame (selected-frame))) - (list 'unwind-protect - (cons 'progn body) - (list 'select-frame 'save-selected-frame-frame)))) - - -;;; @ Basic editing commands emulation. (lisp/simple.el) -;;; - - -;;; @ File input and output commands emulation. (lisp/files.el) -;;; - -(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.") - -;; Actually, `path-separator' is defined in src/emacs.c and overrided -;; in dos-w32.el. -(defvar-maybe path-separator ":" - "The directory separator in search paths, as a string.") - -;; `convert-standard-filename' is defined in lisp/files.el and overrided -;; in lisp/dos-fns.el and lisp/w32-fns.el for each environment. -(cond - ;; must be load-time check to share .elc between different systems. - ((fboundp 'convert-standard-filename)) - ((memq system-type '(windows-nt ms-dos)) - ;; should we do (require 'filename) at load-time ? - ;; (require 'filename) - ;; filename.el requires many modules, so we do not want to load it - ;; at compile-time. Instead, suppress warnings by these autoloads. - (eval-when-compile - (autoload 'filename-maybe-truncate-by-size "filename") - (autoload 'filename-special-filter "filename")) - (defun convert-standard-filename (filename) - "Convert a standard file's name to something suitable for the current OS. -This function's standard definition is trivial; it just returns the argument. -However, on some systems, the function is redefined -with a definition that really does change some file names. -Under `windows-nt' or `ms-dos', it refers `filename-replacement-alist' and -`filename-limit-length' for the basic filename and each parent directory name." - (require 'filename) - (let* ((names (split-string filename "/")) - (drive-name (car names)) - (filter (function - (lambda (string) - (filename-maybe-truncate-by-size - (filename-special-filter string)))))) - (cond - ((eq 1 (length names)) - (funcall filter drive-name)) - ((string-match "^[^/]:$" drive-name) - (concat drive-name "/" (mapconcat filter (cdr names) "/"))) - (t - (mapconcat filter names "/")))))) - (t - (defun convert-standard-filename (filename) - "Convert a standard file's name to something suitable for the current OS. -This function's standard definition is trivial; it just returns the argument. -However, on some systems, the function is redefined -with a definition that really does change some file names. -Under `windows-nt' or `ms-dos', it refers `filename-replacement-alist' and -`filename-limit-length' for the basic filename and each parent directory name." - filename))) - -(static-cond - ((fboundp 'insert-file-contents-literally)) - ((boundp 'file-name-handler-alist) - ;; Use `defun-maybe' to update `load-history'. - (defun-maybe insert-file-contents-literally (filename &optional visit - beg end replace) - "Like `insert-file-contents', q.v., but only reads in the file. -A buffer may be modified in several ways after reading into the buffer due -to advanced Emacs features, such as file-name-handlers, format decoding, -find-file-hooks, etc. - This function ensures that none of these modifications will take place." - (let (file-name-handler-alist) - (insert-file-contents filename visit beg end replace)))) - (t - (defalias 'insert-file-contents-literally 'insert-file-contents))) - -(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)))) - - -;;; @ 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." - (car (memq face-or-name (face-list)))) - -;; Emacs 21.1 defines this as an alias for `line-beginning-position'. -;; Therefore, optional 2nd arg BUFFER is not portable. -(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. -If scan reaches end of buffer, return that position. -This function does not move point." - (save-excursion - (if buffer (set-buffer buffer)) - (forward-line (1- (or n 1))) - (point))) - -;; Emacs 21.1 defines this as an alias for `line-end-position'. -;; Therefore, optional 2nd arg BUFFER is not portable. -(defun-maybe point-at-eol (&optional n buffer) - "Return the character position of the last character on the current line. -With argument N not nil or 1, move forward N - 1 lines first. -If scan reaches end of buffer, return that position. -This function does not move point." - (save-excursion - (if buffer (set-buffer buffer)) - (end-of-line (or n 1)) - (point))) - -(defsubst-maybe define-obsolete-function-alias (oldfun newfun) - "Define OLDFUN as an obsolete alias for function NEWFUN. -This makes calling OLDFUN equivalent to calling NEWFUN and marks OLDFUN -as obsolete." - (defalias oldfun newfun) - (make-obsolete oldfun newfun)) - -;; XEmacs 21: (character-to-event CH &optional EVENT DEVICE) -(defun-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." - ch) - -;; XEmacs 21: (event-to-character EVENT -;; &optional ALLOW-EXTRA-MODIFIERS ALLOW-META ALLOW-NON-ASCII) -(defun-maybe-cond event-to-character (event) - "Return the character approximation to the given event object. -If the event isn't a keypress, this returns nil." - ((and (fboundp 'read-event) - (subrp (symbol-function 'read-event))) - ;; Emacs 19 and later. - (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))) - (t - ;; v18. Is this correct? - event)) - -;; v18: no event; (read-char) -;; Emacs 19, 20.1 and 20.2: (read-event) -;; Emacs 20.3: (read-event &optional PROMPT SUPPRESS-INPUT-METHOD) -;; Emacs 20.4: (read-event &optional PROMPT INHERIT-INPUT-METHOD) -;; XEmacs: (next-event &optional EVENT PROMPT), -;; (next-command-event &optional EVENT PROMPT) -(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." - ((and (>= emacs-major-version 20) - (>= emacs-minor-version 4)) - ;; Emacs 20.4 and later. - (read-event prompt)) ; should specify 2nd arg? - ((and (= emacs-major-version 20) - (= emacs-minor-version 3)) - ;; Emacs 20.3. - (read-event prompt)) ; should specify 2nd arg? - ((and (fboundp 'read-event) - (subrp (symbol-function 'read-event))) - ;; Emacs 19, 20.1 and 20.2. - (if prompt (message prompt)) - (read-event)) - (t - (if prompt (message prompt)) - (read-char))) - - -;;; @ MULE 2 emulation. -;;; - -(defun-maybe-cond cancel-undo-boundary () - "Cancel undo boundary." - ((boundp 'buffer-undo-list) - ;; for Emacs 19 and later. - (if (and (consp buffer-undo-list) - (null (car buffer-undo-list))) - (setq buffer-undo-list (cdr buffer-undo-list))))) - - -;;; @ End. -;;; - -;;; poe.el ends here diff --git a/poe/poem-e20.el b/poe/poem-e20.el deleted file mode 100644 index ac2a17e..0000000 --- a/poe/poem-e20.el +++ /dev/null @@ -1,65 +0,0 @@ -;;; poem-e20.el --- poem submodule for Emacs 20; -*-byte-compile-dynamic: t;-*- - -;; Copyright (C) 1998 Free Software Foundation, Inc. - -;; Author: MORIOKA Tomohiko -;; Keywords: emulation, compatibility, Mule - -;; This file is part of APEL (A Portable Emacs Library). - -;; This program is free software; you can redistribute it and/or -;; modify it under the terms of the GNU General Public License as -;; published by the Free Software Foundation; either version 2, or (at -;; your option) any later version. - -;; This program is distributed in the hope that it will be useful, but -;; WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Code: - -(defun fontset-pixel-size (fontset) - (let* ((info (fontset-info fontset)) - (height (aref info 1)) - ) - (cond ((> height 0) height) - ((string-match "-\\([0-9]+\\)-" fontset) - (string-to-number - (substring fontset (match-beginning 1)(match-end 1)))) - (t 0)))) - - -;;; @ character set -;;; - -;; (defalias 'charset-columns 'charset-width) - -(defun find-non-ascii-charset-string (string) - "Return a list of charsets in the STRING except ascii." - (delq 'ascii (find-charset-string string))) - -(defun find-non-ascii-charset-region (start end) - "Return a list of charsets except ascii -in the region between START and END." - (delq 'ascii (find-charset-string (buffer-substring start end)))) - - -;;; @ end -;;; - -(if (and (fboundp 'set-buffer-multibyte) - (subrp (symbol-function 'set-buffer-multibyte))) - (require 'poem-e20_3) ; for Emacs 20.3 - (require 'poem-e20_2) ; for Emacs 20.1 and 20.2 - ) - -(require 'product) -(product-provide (provide 'poem-e20) (require 'apel-ver)) - -;;; poem-e20.el ends here diff --git a/poe/poem-e20_3.el b/poe/poem-e20_3.el deleted file mode 100644 index 5a72faa..0000000 --- a/poe/poem-e20_3.el +++ /dev/null @@ -1,68 +0,0 @@ -;;; -*-byte-compile-dynamic: t;-*- -;;; poem-e20_3.el --- poem submodule for Emacs 20.3 - -;; Copyright (C) 1998,1999,2000 Free Software Foundation, Inc. - -;; Author: MORIOKA Tomohiko -;; Keywords: emulation, compatibility, Mule - -;; This file is part of APEL (A Portable Emacs Library). - -;; This program is free software; you can redistribute it and/or -;; modify it under the terms of the GNU General Public License as -;; published by the Free Software Foundation; either version 2, or (at -;; your option) any later version. - -;; This program is distributed in the hope that it will be useful, but -;; WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: - -;; This module requires Emacs 20.2.91 or later. - -;;; Code: - -(require 'pym) - -;;; @ character -;;; - -(defsubst char-length (char) - "Return indexing length of multi-byte form of CHAR." - 1) - -(defmacro char-next-index (char index) - "Return index of character succeeding CHAR whose index is INDEX." - `(1+ ,index)) - -(defalias-maybe 'characterp 'char-valid-p) - - -;;; @ string -;;; - -(defalias 'sset 'store-substring) - -(defun string-to-char-list (string) - "Return a list of which elements are characters in the STRING." - (mapcar #'identity string)) - -(defalias 'string-to-int-list 'string-to-char-list) - -(defalias 'looking-at-as-unibyte 'looking-at) - - -;;; @ end -;;; - -(require 'product) -(product-provide (provide 'poem-e20_3) (require 'apel-ver)) - -;;; poem-e20_3.el ends here diff --git a/poe/poem.el b/poe/poem.el deleted file mode 100644 index ec752a3..0000000 --- a/poe/poem.el +++ /dev/null @@ -1,100 +0,0 @@ -;;; poem.el --- Emulate latest MULE features; -*-byte-compile-dynamic: t;-*- - -;; Copyright (C) 1998,1999 Free Software Foundation, Inc. - -;; Author: MORIOKA Tomohiko -;; Keywords: emulation, compatibility, Mule - -;; This file is part of APEL (A Portable Emacs Library). - -;; This program is free software; you can redistribute it and/or -;; modify it under the terms of the GNU General Public License as -;; published by the Free Software Foundation; either version 2, or (at -;; your option) any later version. - -;; This program is distributed in the hope that it will be useful, but -;; WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Code: - -(require 'pces) - -(cond ((featurep 'mule) - (cond ((featurep 'xemacs) - (require 'poem-xm) - ) - ((>= emacs-major-version 20) - (require 'poem-e20) - ) - (t - ;; for MULE 1.* and 2.* - (require 'poem-om) - )) - ) - ((boundp 'NEMACS) - ;; for Nemacs and Nepoch - (require 'poem-nemacs) - ) - (t - (require 'poem-ltn1) - )) - - -;;; @ Emacs 20.3 emulation -;;; - -(defsubst-maybe string-as-unibyte (string) - "Return a unibyte string with the same individual bytes as STRING. -If STRING is unibyte, the result is STRING itself. -\[Emacs 20.3 emulating macro]" - string) - -(defsubst-maybe string-as-multibyte (string) - "Return a multibyte string with the same individual bytes as STRING. -If STRING is multibyte, the result is STRING itself. -\[Emacs 20.3 emulating macro]" - string) - -(defun-maybe charset-after (&optional pos) - "Return charset of a character in current buffer at position POS. -If POS is nil, it defauls to the current point. -If POS is out of range, the value is nil. -\[Emacs 20.3 emulating function]" - (char-charset (char-after pos)) - ) - -;;; @ XEmacs-mule emulation -;;; - -(defalias-maybe 'char-int 'identity) - -(defalias-maybe 'int-char 'identity) - -(defalias-maybe 'characterp 'integerp) - -(defalias-maybe 'char-or-char-int-p 'integerp) - -(defun-maybe char-octet (ch &optional n) - "Return the octet numbered N (should be 0 or 1) of char CH. -N defaults to 0 if omitted. [XEmacs-mule emulating function]" - (or (nth (if n - (1+ n) - 1) - (split-char ch)) - 0)) - - -;;; @ end -;;; - -(require 'product) -(product-provide (provide 'poem) (require 'apel-ver)) - -;;; poem.el ends here