X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;ds=inline;f=poe.el;h=1e585ff28ad7120b69e84e305e92a3f6ad807743;hb=961193295ae71b9e98645fe19000f638fc3d2651;hp=03c4b09dac9609105d8f93dae2881135a20a9c65;hpb=589e43b3abf40ddb3d60c0ac573a1cf9a69120f8;p=elisp%2Fapel.git diff --git a/poe.el b/poe.el index 03c4b09..1e585ff 100644 --- a/poe.el +++ b/poe.el @@ -31,8 +31,9 @@ (provide 'poe) +(or (boundp 'current-load-list) (setq current-load-list nil)) + (put 'defun-maybe 'lisp-indent-function 'defun) -(put 'defun-maybe 'edebug-form-spec 'defun) (defmacro defun-maybe (name &rest everything-else) "Define NAME as a function if NAME is not defined. See also the function `defun'." @@ -41,10 +42,13 @@ See also the function `defun'." (` (or (fboundp (quote (, name))) (prog1 (defun (, name) (,@ everything-else)) + ;; This `defun' will be compiled to `fset', which does + ;; not update `load-history'. + (setq current-load-list + (cons (quote (, name)) current-load-list)) (put (quote (, name)) 'defun-maybe t)))))) (put 'defmacro-maybe 'lisp-indent-function 'defun) -(put 'defmacro-maybe 'edebug-form-spec '(&define name lambda-list def-body)) (defmacro defmacro-maybe (name &rest everything-else) "Define NAME as a macro if NAME is not defined. See also the function `defmacro'." @@ -53,10 +57,11 @@ See also the function `defmacro'." (` (or (fboundp (quote (, name))) (prog1 (defmacro (, name) (,@ everything-else)) + (setq current-load-list + (cons (quote (, name)) current-load-list)) (put (quote (, name)) 'defmacro-maybe t)))))) (put 'defsubst-maybe 'lisp-indent-function 'defun) -(put 'defsubst-maybe 'edebug-form-spec 'defun) (defmacro defsubst-maybe (name &rest everything-else) "Define NAME as an inline function if NAME is not defined. See also the macro `defsubst'." @@ -65,6 +70,8 @@ See also the macro `defsubst'." (` (or (fboundp (quote (, name))) (prog1 (defsubst (, name) (,@ everything-else)) + (setq current-load-list + (cons (quote (, name)) current-load-list)) (put (quote (, name)) 'defsubst-maybe t)))))) (defmacro defalias-maybe (symbol definition) @@ -76,6 +83,8 @@ See also the function `defalias'." (` (or (fboundp (quote (, symbol))) (prog1 (defalias (quote (, symbol)) (, definition)) + (setq current-load-list + (cons (quote (, symbol)) current-load-list)) (put (quote (, symbol)) 'defalias-maybe t)))))) (defmacro defvar-maybe (name &rest everything-else) @@ -86,6 +95,8 @@ See also the function `defvar'." (` (or (boundp (quote (, name))) (prog1 (defvar (, name) (,@ everything-else)) + ;; byte-compiler will generate code to update + ;; `load-history'. (put (quote (, name)) 'defvar-maybe t)))))) (defmacro defconst-maybe (name &rest everything-else) @@ -96,6 +107,8 @@ See also the function `defconst'." (` (or (boundp (quote (, name))) (prog1 (defconst (, name) (,@ everything-else)) + ;; byte-compiler will generate code to update + ;; `load-history'. (put (quote (, name)) 'defconst-maybe t)))))) (defmacro defun-maybe-cond (name args &optional doc &rest everything-else) @@ -106,16 +119,20 @@ See also the function `defconst'." (not (get name 'defun-maybe))) (` (or (fboundp (quote (, name))) (prog1 - (cond (,@ (mapcar (function - (lambda (case) - (list (car case) - (if doc - (` (defun (, name) (, args) - (, doc) - (,@ (cdr case)))) - (` (defun (, name) (, args) - (,@ (cdr case)))))))) - everything-else))) + (cond + (,@ (mapcar + (function + (lambda (case) + (list (car case) + (if doc + (` (defun (, name) (, args) + (, doc) + (,@ (cdr case)))) + (` (defun (, name) (, args) + (,@ (cdr case)))))))) + everything-else))) + (setq current-load-list + (cons (quote (, name)) current-load-list)) (put (quote (, name)) 'defun-maybe t)))))) (defmacro defmacro-maybe-cond (name args &optional doc &rest everything-else) @@ -126,16 +143,20 @@ See also the function `defconst'." (not (get name 'defmacro-maybe))) (` (or (fboundp (quote (, name))) (prog1 - (cond (,@ (mapcar (function - (lambda (case) - (list (car case) - (if doc - (` (defmacro (, name) (, args) - (, doc) - (,@ (cdr case)))) - (` (defmacro (, name) (, args) - (,@ (cdr case)))))))) - everything-else))) + (cond + (,@ (mapcar + (function + (lambda (case) + (list (car case) + (if doc + (` (defmacro (, name) (, args) + (, doc) + (,@ (cdr case)))) + (` (defmacro (, name) (, args) + (,@ (cdr case)))))))) + everything-else))) + (setq current-load-list + (cons (quote (, name)) current-load-list)) (put (quote (, name)) 'defmacro-maybe t)))))) (defun subr-fboundp (symbol) @@ -178,8 +199,48 @@ See also the function `defconst'." ;; XXX: should do compile-time and load-time check before loading ;; "localhook". But, it is difficult since "localhook" is ;; already loaded via "install" at compile-time. any idea? - (require 'localhook) - )) + (require 'localhook))) + +;;; `eval-when-compile' is defined in "poe-18" under v18 with old compiler. +(eval-when-compile (require 'static)) + +;; imported from emacs-20.3/lisp/emacs-lisp/edebug.el. +;; `def-edebug-spec' is an autoloaded macro in v19 and later. +(defmacro-maybe def-edebug-spec (symbol spec) + "Set the edebug-form-spec property of SYMBOL according to SPEC. +Both SYMBOL and SPEC are unevaluated. The SPEC can be 0, t, a symbol +\(naming a function\), or a list." + (` (put (quote (, symbol)) 'edebug-form-spec (quote (, spec))))) + +(def-edebug-spec defun-maybe defun) +(def-edebug-spec defmacro-maybe defmacro) +(def-edebug-spec defsubst-maybe defun) +(def-edebug-spec defun-maybe-cond + (&define name lambda-list + [&optional stringp] + [&rest ([¬ eval] [&rest sexp])] + [&optional (eval [&optional ("interactive" interactive)] def-body)] + &rest (&rest sexp))) +(def-edebug-spec defmacro-maybe-cond + (&define name lambda-list + [&rest ([¬ eval] [&rest sexp])] + [&optional (eval def-body)] + &rest (&rest sexp))) + +;;; Emacs 20.1 emulation + +;; imported from emacs-20.3/lisp/subr.el. +(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)) + +;; imported from emacs-20.3/lisp/subr.el. +(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)) + ;;; @ Emacs 19.23 emulation ;;; @@ -190,6 +251,7 @@ See also the function `defconst'." (set-buffer (window-buffer (minibuffer-window))) (current-column))) + ;;; @ Emacs 19.29 emulation ;;; @@ -218,31 +280,32 @@ STRING should be given if the last search was by `string-match' on STRING. (substring string (match-beginning num) (match-end num)) (buffer-substring (match-beginning num) (match-end num))))) -(or (featurep 'xemacs) - (>= emacs-major-version 20) - (and (= emacs-major-version 19) - (>= emacs-minor-version 29)) - ;; for Emacs 19.28 or earlier - (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. +(static-unless (or (featurep 'xemacs) + (>= emacs-major-version 20) + (and (= emacs-major-version 19) + (>= emacs-minor-version 29))) + ;; for Emacs 19.28 or earlier + (unless (fboundp 'si:read-string) + (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)) - )) + (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. +Elements of LIST that are not conses are ignored. \[Emacs 19.29 emulating function]" (catch 'found (while list - (if (equal (cdr (car list)) key) - (throw 'found (car list))) - (setq list (cdr list))))) + (cond ((not (consp (car list)))) + ((equal (cdr (car list)) key) + (throw 'found (car list)) )) + (setq list (cdr list)) ))) ;; imported from emacs-19.34/lisp/files.el. (defun-maybe file-name-sans-extension (filename) @@ -259,6 +322,7 @@ The extension, in a file name, is the part that follows the last `.'. (substring file 0 (match-beginning 0))) filename)))) + ;;; @ Emacs 19.30 emulation ;;; @@ -315,21 +379,33 @@ Value is nil if OBJECT is not a buffer or if it has been killed. (cons 'progn body) (list 'select-window 'save-selected-window-window)))) +(defun-maybe-cond 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. +\[Emacs 19.31 emulating function]" + ((memq system-type '(windows-nt ms-dos)) + (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 filename)) + ;;; @ Emacs 20.1 emulation ;;; ;; imported from emacs-20.3/lisp/subr.el. -(defmacro-maybe when (cond &rest body) - "If COND yields non-nil, do BODY, else return nil." - (list 'if cond (cons 'progn body))) - -;; imported from emacs-20.3/lisp/subr.el. -(defmacro-maybe unless (cond &rest body) - "If COND yields nil, do BODY, else return nil." - (cons 'if (cons cond (cons nil body)))) - -;; imported from emacs-20.3/lisp/subr.el. (defsubst-maybe caar (x) "Return the car of the car of X." (car (car x))) @@ -458,6 +534,140 @@ If PATTERN is omitted, it defaults to \"[ \\f\\t\\n\\r\\v]+\"." start (match-end 0))) (nreverse (cons (substring string start) parts)))) +;; emulating char-before of Emacs 20. +(static-condition-case nil + ;; compile-time check. + (progn + ;; XXX: this file is already loaded at compile-time, + ;; so this test will always success. + (char-before) + ;; If our definition is found at compile-time, signal an error. + ;; XXX: should signal more specific error. + (if (get 'char-before 'defun-maybe) + (error ""))) + (wrong-number-of-arguments ; Mule 1.*, 2.*. + ;; 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 1.*, 2.*. + (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)))))))) + +;; emulating char-after of Emacs 20. +(static-condition-case nil + ;; compile-time check. + (progn + ;; XXX: this file is already loaded at compile-time, + ;; so this test will always success. + (char-after) + ;; If our definition is found at compile-time, signal an error. + ;; XXX: should signal more specific error. + (if (get 'char-after 'defun-maybe) + (error ""))) + (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 20.3 emulation ;;; @@ -563,7 +773,7 @@ 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) + (defsubst-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]" @@ -575,8 +785,7 @@ If the event isn't a keypress, this returns nil. (if base (logior base (car (cdr mask))) ))))) - ((integerp event) event) - )) + ((integerp event) event))) )