X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=poe.el;h=e3c52316cda6a6b0abbc5f8382928ec19edc5aa6;hb=e168e5c74a9ca5910a7e959a82a57a603336cdeb;hp=18fb5b6e6e55dd4593e0a32e36889e314064fbee;hpb=08bf31ba57fdba1c2b0a4d7a50f341050a3a9ec2;p=elisp%2Fapel.git diff --git a/poe.el b/poe.el index 18fb5b6..e3c5231 100644 --- a/poe.el +++ b/poe.el @@ -75,7 +75,6 @@ (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. @@ -90,7 +89,10 @@ Normally the return value is FEATURE." (condition-case nil (si:require feature filename) (file-error)) - (si:require feature filename))))))) + (si:require feature filename))) + ;; for `load-history'. + (setq current-load-list (cons 'require current-load-list)) + (put 'require 'defun-maybe t))))) ;; Emacs 19.29 and later: (plist-get PLIST PROP) ;; (defun-maybe plist-get (plist prop) @@ -265,7 +267,7 @@ HIST, if non-nil, specifies a history list DEF, if non-nil, is the default value. Completion ignores case if the ambient value of - `completion-ignore-case' is non-nil." + `completion-ignore-case' is non-nil." (let ((string (si:completing-read prompt table predicate require-match init hist))) (if (and (string= string "") def) @@ -290,7 +292,7 @@ Completion ignores case if the ambient value of (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. + ;; XXX: In v18, this causes infinite loop while byte-compiling. ;; (defalias 'string-to-int 'string-to-number) ) (put 'string-to-number 'defun-maybe t) @@ -702,38 +704,97 @@ Elements of LIST that are not conses are ignored." (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)) - (delete 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 +;; XEmacs 19.13 and later: (remassoc KEY ALIST) +(defun-maybe remassoc (key alist) + "Delete by side effect any elements of ALIST whose car is `equal' to KEY. +The modified ALIST is returned. If the first member of ALIST 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)) - (delete key 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 + (while (and (consp alist) + (or (not (consp (car alist))) + (equal (car (car alist)) key))) + (setq alist (cdr alist))) + (if (consp alist) + (let ((prev alist) + (tail (cdr alist))) + (while (consp tail) + (if (and (consp (car alist)) + (equal (car (car tail)) key)) + ;; `(setcdr CELL NEWCDR)' returns NEWCDR. + (setq tail (setcdr prev (cdr tail))) + (setq prev (cdr prev) + tail (cdr tail)))))) + alist) + +;; XEmacs 19.13 and later: (remassq KEY ALIST) +(defun-maybe remassq (key alist) + "Delete by side effect any elements of ALIST whose car is `eq' to KEY. +The modified ALIST is returned. If the first member of ALIST 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'." + (while (and (consp alist) + (or (not (consp (car alist))) + (eq (car (car alist)) key))) + (setq alist (cdr alist))) + (if (consp alist) + (let ((prev alist) + (tail (cdr alist))) + (while (consp tail) + (if (and (consp (car tail)) + (eq (car (car tail)) key)) + ;; `(setcdr CELL NEWCDR)' returns NEWCDR. + (setq tail (setcdr prev (cdr tail))) + (setq prev (cdr prev) + tail (cdr tail)))))) + alist) + +;; XEmacs 19.13 and later: (remrassoc VALUE ALIST) +(defun-maybe remrassoc (value alist) + "Delete by side effect any elements of ALIST whose cdr is `equal' to VALUE. +The modified ALIST is returned. If the first member of ALIST 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)) - (delete value list) - list)) + (while (and (consp alist) + (or (not (consp (car alist))) + (equal (cdr (car alist)) value))) + (setq alist (cdr alist))) + (if (consp alist) + (let ((prev alist) + (tail (cdr alist))) + (while (consp tail) + (if (and (consp (car tail)) + (equal (cdr (car tail)) value)) + ;; `(setcdr CELL NEWCDR)' returns NEWCDR. + (setq tail (setcdr prev (cdr tail))) + (setq prev (cdr prev) + tail (cdr tail)))))) + alist) + +;; XEmacs 19.13 and later: (remrassq VALUE ALIST) +(defun-maybe remrassq (value alist) + "Delete by side effect any elements of ALIST whose cdr is `eq' to VALUE. +The modified ALIST is returned. If the first member of ALIST 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'." + (while (and (consp alist) + (or (not (consp (car alist))) + (eq (cdr (car alist)) value))) + (setq alist (cdr alist))) + (if (consp alist) + (let ((prev alist) + (tail (cdr alist))) + (while (consp tail) + (if (and (consp (car tail)) + (eq (cdr (car tail)) value)) + ;; `(setcdr CELL NEWCDR)' returns NEWCDR. + (setq tail (setcdr prev (cdr tail))) + (setq prev (cdr prev) + tail (cdr tail)))))) + alist) ;;; Define `functionp' here because "localhook" uses it. @@ -836,6 +897,11 @@ 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.3 or later. +(defvar-maybe minor-mode-overriding-map-alist nil + "Alist of keymaps to use for minor modes, in current major mode. +APEL provides this as dummy for a compatibility.") + ;; 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) @@ -1094,6 +1160,369 @@ which is made by replacing the part of STRING that was matched." (buffer-string))) (si:replace-match newtext fixedcase literal))))))))) +;; Emacs 20: (format-time-string FORMAT &optional TIME UNIVERSAL) +;; 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. + +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 ms ls + (tz (car (current-time-zone))) + time-string) + (if universal + (progn + (or time + (setq time (current-time))) + (setq ms (car time) + ls (- (nth 1 time) tz)) + (cond ((< ls 0) + (setq ms (1- ms) + ls (+ ls 65536))) + ((>= ls 65536) + (setq ms (1+ ms) + ls (- ls 65536)))) + (setq time (append (list ms ls) (nth 2 time))))) + (setq time-string (current-time-string time) + 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) + (if universal + "UTC" + (setq change-case (not change-case)) + (downcase (cadr (current-time-zone))))) + ((eq cur-char ?z) + (if universal + "+0000" + (if (< tz 0) + (format "-%02d%02d" + (/ (- tz) 3600) (/ (% (- tz) 3600) 60)) + (format "+%02d%02d" + (/ tz 3600) (/ (% tz 3600) 60))))) + (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 19.29-19.34/XEmacs: `format-time-string' neither supports the +;; format string "%z" nor the third argument `universal'. +(unless (string-match "\\`[\\-\\+][0-9]+\\'" + (format-time-string "%z" (current-time))) + (defadvice format-time-string + (before support-timezone-in-numeric-form-and-3rd-arg + (format-string &optional time universal) activate compile) + "Advice to support the construct `%z' and the third argument `universal'." + (let ((tz (car (current-time-zone))) + case-fold-search ms ls) + (while (string-match "\\(\\(\\`\\|[^%]\\)\\(%%\\)*\\)%z" format-string) + (setq format-string + (concat (substring format-string 0 (match-end 1)) + (if universal + "+0000" + (if (< tz 0) + (format "-%02d%02d" + (/ (- tz) 3600) (/ (% (- tz) 3600) 60)) + (format "+%02d%02d" + (/ tz 3600) (/ (% tz 3600) 60)))) + (substring format-string (match-end 0))))) + (if universal + (progn + (while (string-match "\\(\\(\\`\\|[^%]\\)\\(%%\\)*\\)%Z" + format-string) + (setq format-string + (concat (substring format-string 0 (match-end 1)) + "UTC" + (substring format-string (match-end 0))))) + (or time + (setq time (current-time))) + (setq ms (car time) + ls (- (nth 1 time) tz)) + (cond ((< ls 0) + (setq ms (1- ms) + ls (+ ls 65536))) + ((>= ls 65536) + (setq ms (1+ ms) + ls (- ls 65536)))) + (setq time (append (list ms ls) (nth 2 time)))))))) + ;; 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) @@ -1108,19 +1537,6 @@ If PATTERN is omitted, it defaults to \"[ \\f\\t\\n\\r\\v]+\"." (setq parts (cons (substring string start (match-beginning 0)) parts) start (match-end 0))) (nreverse (cons (substring string start) parts)))) - -;; Emacs 20.4 and later: -;; (subst-char-in-string FROMCHAR TOCHAR STRING &optional INPLACE) -(defun subst-char-in-string (fromchar tochar string &optional inplace) - "Replace FROMCHAR with TOCHAR in STRING each time it occurs. -Unless optional argument INPLACE is non-nil, return a new string." - (let ((i (length string)) - (newstr (if inplace string (copy-sequence string)))) - (while (> i 0) - (setq i (1- i)) - (if (eq (aref newstr i) fromchar) - (aset newstr i tochar))) - newstr)) ;;; @ Window commands emulation. (lisp/window.el) @@ -1258,6 +1674,19 @@ The extension, in a file name, is the part that follows the last `.'." filename)))) +;;; @ Miscellanea. + +;; Emacs 19.29 and later: (current-fill-column) +(defun-maybe current-fill-column () + "Return the fill-column to use for this line." + fill-column) + +;; Emacs 19.29 and later: (current-left-margin) +(defun-maybe current-left-margin () + "Return the left margin to use for this line." + left-margin) + + ;;; @ XEmacs emulation. ;;;