From owner-freebsd-ports-bugs@FreeBSD.ORG Fri Aug 24 02:10:17 2012 Return-Path: Delivered-To: freebsd-ports-bugs@hub.freebsd.org Received: from mx1.freebsd.org (mx1.freebsd.org [IPv6:2001:4f8:fff6::34]) by hub.freebsd.org (Postfix) with ESMTP id 62C2910656A8 for ; Fri, 24 Aug 2012 02:10:17 +0000 (UTC) (envelope-from gnats@FreeBSD.org) Received: from freefall.freebsd.org (freefall.freebsd.org [IPv6:2001:4f8:fff6::28]) by mx1.freebsd.org (Postfix) with ESMTP id 766978FC1C for ; Fri, 24 Aug 2012 02:10:08 +0000 (UTC) Received: from freefall.freebsd.org (localhost [127.0.0.1]) by freefall.freebsd.org (8.14.5/8.14.5) with ESMTP id q7O2A6nm013241 for ; Fri, 24 Aug 2012 02:10:06 GMT (envelope-from gnats@freefall.freebsd.org) Received: (from gnats@localhost) by freefall.freebsd.org (8.14.5/8.14.5/Submit) id q7O2A6nA013240; Fri, 24 Aug 2012 02:10:06 GMT (envelope-from gnats) Resent-Date: Fri, 24 Aug 2012 02:10:06 GMT Resent-Message-Id: <201208240210.q7O2A6nA013240@freefall.freebsd.org> Resent-From: FreeBSD-gnats-submit@FreeBSD.org (GNATS Filer) Resent-To: freebsd-ports-bugs@FreeBSD.org Resent-Reply-To: FreeBSD-gnats-submit@FreeBSD.org, Yasuhiro KIMURA Received: from mx1.freebsd.org (mx1.freebsd.org [IPv6:2001:4f8:fff6::34]) by hub.freebsd.org (Postfix) with ESMTP id F105B1065670 for ; Fri, 24 Aug 2012 02:07:01 +0000 (UTC) (envelope-from yasu@home.utahime.org) Received: from gate.utahime.jp (gate.utahime.jp [183.180.29.210]) by mx1.freebsd.org (Postfix) with ESMTP id 4B9558FC0A for ; Fri, 24 Aug 2012 02:07:01 +0000 (UTC) Received: from eastasia.home.utahime.org (mail.home.utahime.org [192.168.174.1]) by gate.utahime.jp (Postfix) with ESMTP id D931F2E43F; Fri, 24 Aug 2012 10:58:51 +0900 (JST) Received: from eastasia.home.utahime.org (localhost [127.0.0.1]) by localhost-backdoor.home.utahime.org (Postfix) with ESMTP id 8F2AC2E553; Fri, 24 Aug 2012 10:58:51 +0900 (JST) Received: by eastasia.home.utahime.org (Postfix, from userid 1000) id 638782E504; Fri, 24 Aug 2012 10:58:51 +0900 (JST) Message-Id: <20120824015851.638782E504@eastasia.home.utahime.org> Date: Fri, 24 Aug 2012 10:58:51 +0900 (JST) From: Yasuhiro KIMURA To: FreeBSD-gnats-submit@FreeBSD.org X-Send-Pr-Version: 3.113 Cc: Subject: ports/170961: [PATCH] editors/apel: fix old-style backquotes issue X-BeenThere: freebsd-ports-bugs@freebsd.org X-Mailman-Version: 2.1.5 Precedence: list List-Id: Ports bug reports List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , X-List-Received-Date: Fri, 24 Aug 2012 02:10:17 -0000 >Number: 170961 >Category: ports >Synopsis: [PATCH] editors/apel: fix old-style backquotes issue >Confidential: no >Severity: non-critical >Priority: low >Responsible: freebsd-ports-bugs >State: open >Quarter: >Keywords: >Date-Required: >Class: sw-bug >Submitter-Id: current-users >Arrival-Date: Fri Aug 24 02:10:06 UTC 2012 >Closed-Date: >Last-Modified: >Originator: Yasuhiro KIMURA >Release: FreeBSD 9.0-RELEASE-p4 i386 >Organization: >Environment: System: FreeBSD xxxx 9.0-RELEASE-p4 FreeBSD 9.0-RELEASE-p4 #0: Sun Aug 12 22:27:34 JST 2012 xxxx i386 >Description: Fix old-style backquotes issue >How-To-Repeat: >Fix: --- patch-apel begins here --- Index: Makefile =================================================================== RCS file: /usr0/freebsd/cvsroot/ports/editors/apel/Makefile,v retrieving revision 1.58 diff -u -r1.58 Makefile --- Makefile 1 Aug 2012 16:50:15 -0000 1.58 +++ Makefile 24 Aug 2012 00:35:40 -0000 @@ -7,7 +7,7 @@ PORTNAME= apel PORTVERSION= ${APEL_VER} -PORTREVISION= 6 +PORTREVISION= 7 CATEGORIES= editors elisp MASTER_SITES= http://kanji.zinbun.kyoto-u.ac.jp/~tomo/lemi/dist/apel/ PKGNAMESUFFIX= -${EMACS_PORT_NAME} Index: files/patch-broken.el =================================================================== RCS file: files/patch-broken.el diff -N files/patch-broken.el --- /dev/null 1 Jan 1970 00:00:00 -0000 +++ files/patch-broken.el 24 Aug 2012 00:34:45 -0000 @@ -0,0 +1,84 @@ +Index: broken.el +=================================================================== +--- broken.el (revision 2) ++++ broken.el (working copy) +@@ -58,51 +58,51 @@ + + If ASSERTION is not omitted and evaluated to nil and NO-NOTICE is nil, + it is noticed." +- (` (static-if (, assertion) +- (eval-and-compile +- (broken-facility-internal '(, facility) (, docstring) t)) +- (eval-when-compile +- (when (and '(, assertion) (not '(, no-notice)) +- notice-non-obvious-broken-facility) +- (message "BROKEN FACILITY DETECTED: %s" (, docstring))) +- nil) +- (eval-and-compile +- (broken-facility-internal '(, facility) (, docstring) nil))))) ++ `(static-if ,assertion ++ (eval-and-compile ++ (broken-facility-internal ',facility ,docstring t)) ++ (eval-when-compile ++ (when (and ',assertion (not ',no-notice) ++ notice-non-obvious-broken-facility) ++ (message "BROKEN FACILITY DETECTED: %s" ,docstring)) ++ nil) ++ (eval-and-compile ++ (broken-facility-internal ',facility ,docstring nil)))) + + (put 'if-broken 'lisp-indent-function 2) + (defmacro if-broken (facility then &rest else) + "If FACILITY is broken, expand to THEN, otherwise (progn . ELSE)." +- (` (static-if (broken-p '(, facility)) +- (, then) +- (,@ else)))) ++ `(static-if (broken-p ',facility) ++ ,then ++ ,@else)) + + + (put 'when-broken 'lisp-indent-function 1) + (defmacro when-broken (facility &rest body) + "If FACILITY is broken, expand to (progn . BODY), otherwise nil." +- (` (static-when (broken-p '(, facility)) +- (,@ body)))) ++ `(static-when (broken-p ',facility) ++ ,@body)) + + (put 'unless-broken 'lisp-indent-function 1) + (defmacro unless-broken (facility &rest body) + "If FACILITY is not broken, expand to (progn . BODY), otherwise nil." +- (` (static-unless (broken-p '(, facility)) +- (,@ body)))) ++ `(static-unless (broken-p ',facility) ++ ,@body)) + + (defmacro check-broken-facility (facility) + "Check FACILITY is broken or not. If the status is different on + compile(macro expansion) time and run time, warn it." +- (` (if-broken (, facility) +- (unless (broken-p '(, facility)) +- (message "COMPILE TIME ONLY BROKEN FACILITY DETECTED: %s" +- (or +- '(, (broken-facility-description facility)) +- (broken-facility-description '(, facility))))) +- (when (broken-p '(, facility)) +- (message "RUN TIME ONLY BROKEN FACILITY DETECTED: %s" +- (or +- (broken-facility-description '(, facility)) +- '(, (broken-facility-description facility)))))))) ++ `(if-broken ,facility ++ (unless (broken-p ',facility) ++ (message "COMPILE TIME ONLY BROKEN FACILITY DETECTED: %s" ++ (or ++ ',(broken-facility-description facility) ++ (broken-facility-description ',facility)))) ++ (when (broken-p ',facility) ++ (message "RUN TIME ONLY BROKEN FACILITY DETECTED: %s" ++ (or ++ (broken-facility-description ',facility) ++ ',(broken-facility-description facility)))))) + + + ;;; @ end Index: files/patch-filename.el =================================================================== RCS file: files/patch-filename.el diff -N files/patch-filename.el --- /dev/null 1 Jan 1970 00:00:00 -0000 +++ files/patch-filename.el 24 Aug 2012 00:34:46 -0000 @@ -0,0 +1,51 @@ +Index: filename.el +=================================================================== +--- filename.el (revision 2) ++++ filename.el (working copy) +@@ -102,26 +102,26 @@ + inc-i '(1+ i)) + (setq sref 'aref + inc-i '(+ i (char-length chr)))) +- (` (let ((len (length (, string))) +- (b 0)(i 0) +- (dest "")) +- (while (< i len) +- (let ((chr ((, sref) (, string) i)) +- (lst filename-replacement-alist) +- ret) +- (while (and lst (not ret)) +- (if (if (functionp (car (car lst))) +- (setq ret (funcall (car (car lst)) chr)) +- (setq ret (memq chr (car (car lst))))) +- t ; quit this loop. +- (setq lst (cdr lst)))) +- (if ret +- (setq dest (concat dest (substring (, string) b i) +- (cdr (car lst))) +- i (, inc-i) +- b i) +- (setq i (, inc-i))))) +- (concat dest (substring (, string) b))))))) ++ `(let ((len (length ,string)) ++ (b 0)(i 0) ++ (dest "")) ++ (while (< i len) ++ (let ((chr (,sref ,string i)) ++ (lst filename-replacement-alist) ++ ret) ++ (while (and lst (not ret)) ++ (if (if (functionp (car (car lst))) ++ (setq ret (funcall (car (car lst)) chr)) ++ (setq ret (memq chr (car (car lst))))) ++ t ; quit this loop. ++ (setq lst (cdr lst)))) ++ (if ret ++ (setq dest (concat dest (substring ,string b i) ++ (cdr (car lst))) ++ i ,inc-i ++ b i) ++ (setq i ,inc-i)))) ++ (concat dest (substring ,string b)))))) + + (defun filename-special-filter (string) + (filename-special-filter-1 string)) Index: files/patch-pccl.el =================================================================== RCS file: files/patch-pccl.el diff -N files/patch-pccl.el --- /dev/null 1 Jan 1970 00:00:00 -0000 +++ files/patch-pccl.el 24 Aug 2012 00:34:46 -0000 @@ -0,0 +1,268 @@ +Index: pccl.el +=================================================================== +--- pccl.el (revision 2) ++++ pccl.el (working copy) +@@ -27,138 +27,138 @@ + (require 'broken) + + (broken-facility ccl-usable +- "Emacs has not CCL." +- (and (featurep 'mule) +- (if (featurep 'xemacs) +- (>= emacs-major-version 21) +- (>= emacs-major-version 19)))) ++ "Emacs has not CCL." ++ (and (featurep 'mule) ++ (if (featurep 'xemacs) ++ (>= emacs-major-version 21) ++ (>= emacs-major-version 19)))) + + (unless-broken ccl-usable +- (require 'advice) ++ (require 'advice) + +- (if (featurep 'mule) +- (progn +- (require 'ccl) +- (if (featurep 'xemacs) +- (if (>= emacs-major-version 21) +- ;; for XEmacs 21 with mule +- (require 'pccl-20)) +- (if (>= emacs-major-version 20) +- ;; for Emacs 20 +- (require 'pccl-20) +- ;; for Mule 2.* +- (require 'pccl-om))))) ++ (if (featurep 'mule) ++ (progn ++ (require 'ccl) ++ (if (featurep 'xemacs) ++ (if (>= emacs-major-version 21) ++ ;; for XEmacs 21 with mule ++ (require 'pccl-20)) ++ (if (>= emacs-major-version 20) ++ ;; for Emacs 20 ++ (require 'pccl-20) ++ ;; for Mule 2.* ++ (require 'pccl-om))))) + +- (static-if (or (featurep 'xemacs) (< emacs-major-version 21)) +- (defadvice define-ccl-program +- (before accept-long-ccl-program activate) +- "When CCL-PROGRAM is too long, internal buffer is extended automatically." +- (let ((try-ccl-compile t) +- (prog (eval (ad-get-arg 1)))) +- (ad-set-arg 1 (` '(, prog))) +- (while try-ccl-compile +- (setq try-ccl-compile nil) +- (condition-case sig +- (ccl-compile prog) +- (args-out-of-range +- (if (and (eq (car (cdr sig)) ccl-program-vector) +- (= (car (cdr (cdr sig))) (length ccl-program-vector))) +- (setq ccl-program-vector +- (make-vector (* 2 (length ccl-program-vector)) 0) +- try-ccl-compile t) +- (signal (car sig) (cdr sig))))))))) ++ (static-if (or (featurep 'xemacs) (< emacs-major-version 21)) ++ (defadvice define-ccl-program ++ (before accept-long-ccl-program activate) ++ "When CCL-PROGRAM is too long, internal buffer is extended automatically." ++ (let ((try-ccl-compile t) ++ (prog (eval (ad-get-arg 1)))) ++ (ad-set-arg 1 `',prog) ++ (while try-ccl-compile ++ (setq try-ccl-compile nil) ++ (condition-case sig ++ (ccl-compile prog) ++ (args-out-of-range ++ (if (and (eq (car (cdr sig)) ccl-program-vector) ++ (= (car (cdr (cdr sig))) (length ccl-program-vector))) ++ (setq ccl-program-vector ++ (make-vector (* 2 (length ccl-program-vector)) 0) ++ try-ccl-compile t) ++ (signal (car sig) (cdr sig))))))))) + +- (static-when (and (not (featurep 'xemacs)) (< emacs-major-version 21)) +- (defun-maybe transform-make-coding-system-args (name type &optional doc-string props) +- "For internal use only. ++ (static-when (and (not (featurep 'xemacs)) (< emacs-major-version 21)) ++ (defun-maybe transform-make-coding-system-args (name type &optional doc-string props) ++ "For internal use only. + Transform XEmacs style args for `make-coding-system' to Emacs style. + Value is a list of transformed arguments." +- (let ((mnemonic (string-to-char (or (plist-get props 'mnemonic) "?"))) +- (eol-type (plist-get props 'eol-type)) +- properties tmp) +- (cond +- ((eq eol-type 'lf) (setq eol-type 'unix)) +- ((eq eol-type 'crlf) (setq eol-type 'dos)) +- ((eq eol-type 'cr) (setq eol-type 'mac))) +- (if (setq tmp (plist-get props 'post-read-conversion)) +- (setq properties (plist-put properties 'post-read-conversion tmp))) +- (if (setq tmp (plist-get props 'pre-write-conversion)) +- (setq properties (plist-put properties 'pre-write-conversion tmp))) +- (cond +- ((eq type 'shift-jis) +- (` ((, name) 1 (, mnemonic) (, doc-string) +- nil (, properties) (, eol-type)))) +- ((eq type 'iso2022) ; This is not perfect. +- (if (plist-get props 'escape-quoted) +- (error "escape-quoted is not supported: %S" +- (` ((, name) (, type) (, doc-string) (, props))))) +- (let ((g0 (plist-get props 'charset-g0)) +- (g1 (plist-get props 'charset-g1)) +- (g2 (plist-get props 'charset-g2)) +- (g3 (plist-get props 'charset-g3)) +- (use-roman +- (and +- (eq (cadr (assoc 'latin-jisx0201 +- (plist-get props 'input-charset-conversion))) +- 'ascii) +- (eq (cadr (assoc 'ascii +- (plist-get props 'output-charset-conversion))) +- 'latin-jisx0201))) +- (use-oldjis +- (and +- (eq (cadr (assoc 'japanese-jisx0208-1978 +- (plist-get props 'input-charset-conversion))) +- 'japanese-jisx0208) +- (eq (cadr (assoc 'japanese-jisx0208 +- (plist-get props 'output-charset-conversion))) +- 'japanese-jisx0208-1978)))) +- (if (charsetp g0) +- (if (plist-get props 'force-g0-on-output) +- (setq g0 (` (nil (, g0)))) +- (setq g0 (` ((, g0) t))))) +- (if (charsetp g1) +- (if (plist-get props 'force-g1-on-output) +- (setq g1 (` (nil (, g1)))) +- (setq g1 (` ((, g1) t))))) +- (if (charsetp g2) +- (if (plist-get props 'force-g2-on-output) +- (setq g2 (` (nil (, g2)))) +- (setq g2 (` ((, g2) t))))) +- (if (charsetp g3) +- (if (plist-get props 'force-g3-on-output) +- (setq g3 (` (nil (, g3)))) +- (setq g3 (` ((, g3) t))))) +- (` ((, name) 2 (, mnemonic) (, doc-string) +- ((, g0) (, g1) (, g2) (, g3) +- (, (plist-get props 'short)) +- (, (not (plist-get props 'no-ascii-eol))) +- (, (not (plist-get props 'no-ascii-cntl))) +- (, (plist-get props 'seven)) +- t +- (, (not (plist-get props 'lock-shift))) +- (, use-roman) +- (, use-oldjis) +- (, (plist-get props 'no-iso6429)) +- nil nil nil nil) +- (, properties) (, eol-type))))) +- ((eq type 'big5) +- (` ((, name) 3 (, mnemonic) (, doc-string) +- nil (, properties) (, eol-type)))) +- ((eq type 'ccl) +- (` ((, name) 4 (, mnemonic) (, doc-string) +- ((, (plist-get props 'decode)) . (, (plist-get props 'encode))) +- (, properties) (, eol-type)))) +- (t +- (error "unsupported XEmacs style make-coding-style arguments: %S" +- (` ((, name) (, type) (, doc-string) (, props)))))))) +- (defadvice make-coding-system +- (before ccl-compat (name type &rest ad-subr-args) activate) +- "Emulate XEmacs style make-coding-system." +- (when (and (symbolp type) (not (memq type '(t nil)))) +- (let ((args (apply 'transform-make-coding-system-args +- name type ad-subr-args))) +- (setq type (cadr args) +- ad-subr-args (cddr args))))))) ++ (let ((mnemonic (string-to-char (or (plist-get props 'mnemonic) "?"))) ++ (eol-type (plist-get props 'eol-type)) ++ properties tmp) ++ (cond ++ ((eq eol-type 'lf) (setq eol-type 'unix)) ++ ((eq eol-type 'crlf) (setq eol-type 'dos)) ++ ((eq eol-type 'cr) (setq eol-type 'mac))) ++ (if (setq tmp (plist-get props 'post-read-conversion)) ++ (setq properties (plist-put properties 'post-read-conversion tmp))) ++ (if (setq tmp (plist-get props 'pre-write-conversion)) ++ (setq properties (plist-put properties 'pre-write-conversion tmp))) ++ (cond ++ ((eq type 'shift-jis) ++ `(,name 1 ,mnemonic ,doc-string ++ nil ,properties ,eol-type)) ++ ((eq type 'iso2022) ; This is not perfect. ++ (if (plist-get props 'escape-quoted) ++ (error "escape-quoted is not supported: %S" ++ `(,name ,type ,doc-string ,props))) ++ (let ((g0 (plist-get props 'charset-g0)) ++ (g1 (plist-get props 'charset-g1)) ++ (g2 (plist-get props 'charset-g2)) ++ (g3 (plist-get props 'charset-g3)) ++ (use-roman ++ (and ++ (eq (cadr (assoc 'latin-jisx0201 ++ (plist-get props 'input-charset-conversion))) ++ 'ascii) ++ (eq (cadr (assoc 'ascii ++ (plist-get props 'output-charset-conversion))) ++ 'latin-jisx0201))) ++ (use-oldjis ++ (and ++ (eq (cadr (assoc 'japanese-jisx0208-1978 ++ (plist-get props 'input-charset-conversion))) ++ 'japanese-jisx0208) ++ (eq (cadr (assoc 'japanese-jisx0208 ++ (plist-get props 'output-charset-conversion))) ++ 'japanese-jisx0208-1978)))) ++ (if (charsetp g0) ++ (if (plist-get props 'force-g0-on-output) ++ (setq g0 `(nil ,g0)) ++ (setq g0 `(,g0 t)))) ++ (if (charsetp g1) ++ (if (plist-get props 'force-g1-on-output) ++ (setq g1 `(nil ,g1)) ++ (setq g1 `(,g1 t)))) ++ (if (charsetp g2) ++ (if (plist-get props 'force-g2-on-output) ++ (setq g2 `(nil ,g2)) ++ (setq g2 `(,g2 t)))) ++ (if (charsetp g3) ++ (if (plist-get props 'force-g3-on-output) ++ (setq g3 `(nil ,g3)) ++ (setq g3 `(,g3 t)))) ++ `(,name 2 ,mnemonic ,doc-string ++ (,g0 ,g1 ,g2 ,g3 ++ ,(plist-get props 'short) ++ ,(not (plist-get props 'no-ascii-eol)) ++ ,(not (plist-get props 'no-ascii-cntl)) ++ ,(plist-get props 'seven) ++ t ++ ,(not (plist-get props 'lock-shift)) ++ ,use-roman ++ ,use-oldjis ++ ,(plist-get props 'no-iso6429) ++ nil nil nil nil) ++ ,properties ,eol-type))) ++ ((eq type 'big5) ++ `(,name 3 ,mnemonic ,doc-string ++ nil ,properties ,eol-type)) ++ ((eq type 'ccl) ++ `(,name 4 ,mnemonic ,doc-string ++ (,(plist-get props 'decode) . ,(plist-get props 'encode)) ++ ,properties ,eol-type)) ++ (t ++ (error "unsupported XEmacs style make-coding-style arguments: %S" ++ `(,name ,type ,doc-string ,props)))))) ++ (defadvice make-coding-system ++ (before ccl-compat (name type &rest ad-subr-args) activate) ++ "Emulate XEmacs style make-coding-system." ++ (when (and (symbolp type) (not (memq type '(t nil)))) ++ (let ((args (apply 'transform-make-coding-system-args ++ name type ad-subr-args))) ++ (setq type (cadr args) ++ ad-subr-args (cddr args))))))) + + + ;;; @ end Index: files/patch-poe.el =================================================================== RCS file: files/patch-poe.el diff -N files/patch-poe.el --- /dev/null 1 Jan 1970 00:00:00 -0000 +++ files/patch-poe.el 24 Aug 2012 00:34:46 -0000 @@ -0,0 +1,1410 @@ +Index: poe.el +=================================================================== +--- poe.el (revision 2) ++++ poe.el (working copy) +@@ -38,22 +38,22 @@ + ;;; + + (static-when (= emacs-major-version 18) +- (require 'poe-18)) ++ (require 'poe-18)) + + ;; Some ancient version of XEmacs did not provide 'xemacs. + (static-when (string-match "XEmacs" emacs-version) +- (provide 'xemacs)) ++ (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))) ++ ;; 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)) ++ (require 'poe-xemacs)) + + ;; must be load-time check to share .elc between different systems. + (or (fboundp 'open-network-stream) +@@ -66,18 +66,18 @@ + ;; 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)) +- (defun require (feature &optional filename noerror) +- "\ ++ ;; 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)) ++ (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. +@@ -86,14 +86,14 @@ + 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))) +- ;; for `load-history'. +- (setq current-load-list (cons 'require current-load-list)) +- (put 'require 'defun-maybe t))))) ++ (if noerror ++ (condition-case nil ++ (si:require feature filename) ++ (file-error)) ++ (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) +@@ -103,21 +103,21 @@ + ;; (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) +- "\ ++ (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)))) ++ (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) +@@ -138,11 +138,11 @@ + ;; (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) +- "\ ++ (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. +@@ -150,12 +150,12 @@ + 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)))) ++ (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 () +@@ -170,16 +170,16 @@ + (>= 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) +- "\ ++ (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))))) ++ (si:read-string prompt initial-input))))) + + ;; (completing-read prompt table &optional + ;; FSF Emacs +@@ -203,8 +203,8 @@ + (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. ++ 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. +@@ -225,10 +225,10 @@ + + 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)))))) ++ (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) +@@ -240,8 +240,8 @@ + (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. ++ 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. +@@ -269,10 +269,10 @@ + + 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))))))) ++ (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) +@@ -281,24 +281,24 @@ + ;; 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 byte-compiling. +- ;; (defalias 'string-to-int 'string-to-number) +- ) +- (put 'string-to-number 'defun-maybe t) +- (defun string-to-number (string &optional base) +- "\ ++ ;; 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 byte-compiling. ++ ;; (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. +@@ -306,39 +306,39 @@ + 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)))))))))) ++ (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) +@@ -362,130 +362,130 @@ + ;; 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) +- "\ ++ ;; 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) +- "\ ++ (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) +- "\ ++ (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) +- "\ ++ (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)))))))) ++ (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) +- "\ ++ ;; 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) +- "\ ++ (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) +- "\ ++ (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) +- "\ ++ (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)))))))) ++ (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) +@@ -813,7 +813,7 @@ + ;; 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)) ++ (require 'localhook)) + + ;; Emacs 19.29/XEmacs 19.14(?) and later: (add-to-list LIST-VAR ELEMENT) + (defun-maybe add-to-list (list-var element) +@@ -916,20 +916,20 @@ + (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)))))) ++ `(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)))) ++ `(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) +@@ -938,68 +938,68 @@ + 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)))))))) ++ `(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) +- "\ ++ (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)))))))))) ++ (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)))))))) ++ `(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)))))) ++ `(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) +@@ -1056,20 +1056,20 @@ + ;; 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. ++ ;; 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. +@@ -1090,38 +1090,38 @@ + 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 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. +@@ -1142,24 +1142,24 @@ + 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))))))))) ++ (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 FORMAT &optional TIME UNIVERSAL) + ;; Those format constructs are yet to be implemented. +@@ -1167,26 +1167,26 @@ + ;; 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.") ++ (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.") ++ (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. ++ (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 +@@ -1238,250 +1238,250 @@ + 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)))) ++ (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'. Index: files/patch-product.el =================================================================== RCS file: files/patch-product.el diff -N files/patch-product.el --- /dev/null 1 Jan 1970 00:00:00 -0000 +++ files/patch-product.el 24 Aug 2012 00:34:46 -0000 @@ -0,0 +1,83 @@ +Index: product.el +=================================================================== +--- product.el (revision 2) ++++ product.el (working copy) +@@ -232,21 +232,21 @@ + (product-version (product-version product)) + (product-code-name (product-code-name product)) + (product-version-string (product-version-string product))) +- (` (progn +- (, product-def) +- (put (, feature) 'product +- (let ((product (product-find-by-name (, product-name)))) +- (product-run-checkers product '(, product-version)) +- (and (, product-family) +- (product-add-to-family (, product-family) +- (, product-name))) +- (product-add-feature product (, feature)) +- (if (equal '(, product-version) (product-version product)) +- product +- (vector (, product-name) (, product-family) +- '(, product-version) (, product-code-name) +- nil nil nil (, product-version-string))))) +- (, feature-def))))) ++ `(progn ++ ,product-def ++ (put ,feature 'product ++ (let ((product (product-find-by-name ,product-name))) ++ (product-run-checkers product ',product-version) ++ (and ,product-family ++ (product-add-to-family ,product-family ++ ,product-name)) ++ (product-add-feature product ,feature) ++ (if (equal ',product-version (product-version product)) ++ product ++ (vector ,product-name ,product-family ++ ',product-version ,product-code-name ++ nil nil nil ,product-version-string)))) ++ ,feature-def))) + + (defun product-version-as-string (product) + "Return version number of product as a string. +@@ -293,13 +293,13 @@ + PRODUCT is a product structure which returned by `product-define'." + (let (dest) + (product-for-each product nil +- (function +- (lambda (product) +- (let ((str (product-string-1 product nil))) +- (if str +- (setq dest (if dest +- (concat dest " " str) +- str))))))) ++ (function ++ (lambda (product) ++ (let ((str (product-string-1 product nil))) ++ (if str ++ (setq dest (if dest ++ (concat dest " " str) ++ str))))))) + dest)) + + (defun product-string-verbose (product) +@@ -307,13 +307,13 @@ + PRODUCT is a product structure which returned by `product-define'." + (let (dest) + (product-for-each product nil +- (function +- (lambda (product) +- (let ((str (product-string-1 product t))) +- (if str +- (setq dest (if dest +- (concat dest " " str) +- str))))))) ++ (function ++ (lambda (product) ++ (let ((str (product-string-1 product t))) ++ (if str ++ (setq dest (if dest ++ (concat dest " " str) ++ str))))))) + dest)) + + (defun product-version-compare (v1 v2) Index: files/patch-pym.el =================================================================== RCS file: files/patch-pym.el diff -N files/patch-pym.el --- /dev/null 1 Jan 1970 00:00:00 -0000 +++ files/patch-pym.el 24 Aug 2012 00:34:46 -0000 @@ -0,0 +1,282 @@ +Index: pym.el +=================================================================== +--- pym.el (revision 2) ++++ pym.el (working copy) +@@ -63,15 +63,15 @@ + See also the function `defun'." + (or (and (fboundp name) + (not (get name 'defun-maybe))) +- (` (or (fboundp (quote (, name))) +- (prog1 +- (defun (, name) (,@ everything-else)) +- ;; This `defun' will be compiled to `fset', +- ;; which does not update `load-history'. +- ;; We must update `current-load-list' explicitly. +- (setq current-load-list +- (cons (quote (, name)) current-load-list)) +- (put (quote (, name)) 'defun-maybe t)))))) ++ `(or (fboundp (quote ,name)) ++ (prog1 ++ (defun ,name ,@everything-else) ++ ;; This `defun' will be compiled to `fset', ++ ;; which does not update `load-history'. ++ ;; We must update `current-load-list' explicitly. ++ (setq current-load-list ++ (cons (quote ,name) current-load-list)) ++ (put (quote ,name) 'defun-maybe t))))) + + (put 'defmacro-maybe 'lisp-indent-function 'defun) + (defmacro defmacro-maybe (name &rest everything-else) +@@ -79,15 +79,15 @@ + See also the function `defmacro'." + (or (and (fboundp name) + (not (get name 'defmacro-maybe))) +- (` (or (fboundp (quote (, name))) +- (prog1 +- (defmacro (, name) (,@ everything-else)) +- ;; This `defmacro' will be compiled to `fset', +- ;; which does not update `load-history'. +- ;; We must update `current-load-list' explicitly. +- (setq current-load-list +- (cons (quote (, name)) current-load-list)) +- (put (quote (, name)) 'defmacro-maybe t)))))) ++ `(or (fboundp (quote ,name)) ++ (prog1 ++ (defmacro ,name ,@everything-else) ++ ;; This `defmacro' will be compiled to `fset', ++ ;; which does not update `load-history'. ++ ;; We must update `current-load-list' explicitly. ++ (setq current-load-list ++ (cons (quote ,name) current-load-list)) ++ (put (quote ,name) 'defmacro-maybe t))))) + + (put 'defsubst-maybe 'lisp-indent-function 'defun) + (defmacro defsubst-maybe (name &rest everything-else) +@@ -95,15 +95,15 @@ + See also the macro `defsubst'." + (or (and (fboundp name) + (not (get name 'defsubst-maybe))) +- (` (or (fboundp (quote (, name))) +- (prog1 +- (defsubst (, name) (,@ everything-else)) +- ;; This `defsubst' will be compiled to `fset', +- ;; which does not update `load-history'. +- ;; We must update `current-load-list' explicitly. +- (setq current-load-list +- (cons (quote (, name)) current-load-list)) +- (put (quote (, name)) 'defsubst-maybe t)))))) ++ `(or (fboundp (quote ,name)) ++ (prog1 ++ (defsubst ,name ,@everything-else) ++ ;; This `defsubst' will be compiled to `fset', ++ ;; which does not update `load-history'. ++ ;; We must update `current-load-list' explicitly. ++ (setq current-load-list ++ (cons (quote ,name) current-load-list)) ++ (put (quote ,name) 'defsubst-maybe t))))) + + (defmacro defalias-maybe (symbol definition) + "Define SYMBOL as an alias for DEFINITION if SYMBOL is not defined. +@@ -111,35 +111,35 @@ + (setq symbol (eval symbol)) + (or (and (fboundp symbol) + (not (get symbol 'defalias-maybe))) +- (` (or (fboundp (quote (, symbol))) +- (prog1 +- (defalias (quote (, symbol)) (, definition)) +- ;; `defalias' updates `load-history' internally. +- (put (quote (, symbol)) 'defalias-maybe t)))))) ++ `(or (fboundp (quote ,symbol)) ++ (prog1 ++ (defalias (quote ,symbol) ,definition) ++ ;; `defalias' updates `load-history' internally. ++ (put (quote ,symbol) 'defalias-maybe t))))) + + (defmacro defvar-maybe (name &rest everything-else) + "Define NAME as a variable if NAME is not defined. + See also the function `defvar'." + (or (and (boundp name) + (not (get name 'defvar-maybe))) +- (` (or (boundp (quote (, name))) +- (prog1 +- (defvar (, name) (,@ everything-else)) +- ;; byte-compiler will generate code to update +- ;; `load-history'. +- (put (quote (, name)) 'defvar-maybe t)))))) ++ `(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) + "Define NAME as a constant variable if NAME is not defined. + See also the function `defconst'." + (or (and (boundp name) + (not (get name 'defconst-maybe))) +- (` (or (boundp (quote (, name))) +- (prog1 +- (defconst (, name) (,@ everything-else)) +- ;; byte-compiler will generate code to update +- ;; `load-history'. +- (put (quote (, name)) 'defconst-maybe t)))))) ++ `(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 clauses) + "Define NAME as a function if NAME is not defined. +@@ -152,26 +152,26 @@ + doc nil)) + (or (and (fboundp name) + (not (get name 'defun-maybe))) +- (` (or (fboundp (quote (, name))) +- (prog1 +- (static-cond +- (,@ (mapcar +- (function +- (lambda (case) +- (list (car case) +- (if doc +- (` (defun (, name) (, args) +- (, doc) +- (,@ (cdr case)))) +- (` (defun (, name) (, args) +- (,@ (cdr case)))))))) +- clauses))) +- ;; This `defun' will be compiled to `fset', +- ;; which does not update `load-history'. +- ;; We must update `current-load-list' explicitly. +- (setq current-load-list +- (cons (quote (, name)) current-load-list)) +- (put (quote (, name)) 'defun-maybe t)))))) ++ `(or (fboundp (quote ,name)) ++ (prog1 ++ (static-cond ++ ,@(mapcar ++ (function ++ (lambda (case) ++ (list (car case) ++ (if doc ++ `(defun ,name ,args ++ ,doc ++ ,@(cdr case)) ++ `(defun ,name ,args ++ ,@ (cdr case)))))) ++ clauses)) ++ ;; This `defun' will be compiled to `fset', ++ ;; which does not update `load-history'. ++ ;; We must update `current-load-list' explicitly. ++ (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 clauses) + "Define NAME as a macro if NAME is not defined. +@@ -184,26 +184,26 @@ + doc nil)) + (or (and (fboundp name) + (not (get name 'defmacro-maybe))) +- (` (or (fboundp (quote (, name))) +- (prog1 +- (static-cond +- (,@ (mapcar +- (function +- (lambda (case) +- (list (car case) +- (if doc +- (` (defmacro (, name) (, args) +- (, doc) +- (,@ (cdr case)))) +- (` (defmacro (, name) (, args) +- (,@ (cdr case)))))))) +- clauses))) +- ;; This `defmacro' will be compiled to `fset', +- ;; which does not update `load-history'. +- ;; We must update `current-load-list' explicitly. +- (setq current-load-list +- (cons (quote (, name)) current-load-list)) +- (put (quote (, name)) 'defmacro-maybe t)))))) ++ `(or (fboundp (quote ,name)) ++ (prog1 ++ (static-cond ++ ,@(mapcar ++ (function ++ (lambda (case) ++ (list (car case) ++ (if doc ++ `(defmacro ,name ,args ++ ,doc ++ ,@(cdr case)) ++ `(defmacro ,name ,args ++ @(cdr case)))))) ++ clauses)) ++ ;; This `defmacro' will be compiled to `fset', ++ ;; which does not update `load-history'. ++ ;; We must update `current-load-list' explicitly. ++ (setq current-load-list ++ (cons (quote ,name) current-load-list)) ++ (put (quote ,name) 'defmacro-maybe t))))) + + (defmacro defsubst-maybe-cond (name args &optional doc &rest clauses) + "Define NAME as an inline function if NAME is not defined. +@@ -216,26 +216,26 @@ + doc nil)) + (or (and (fboundp name) + (not (get name 'defsubst-maybe))) +- (` (or (fboundp (quote (, name))) +- (prog1 +- (static-cond +- (,@ (mapcar +- (function +- (lambda (case) +- (list (car case) +- (if doc +- (` (defsubst (, name) (, args) +- (, doc) +- (,@ (cdr case)))) +- (` (defsubst (, name) (, args) +- (,@ (cdr case)))))))) +- clauses))) +- ;; This `defsubst' will be compiled to `fset', +- ;; which does not update `load-history'. +- ;; We must update `current-load-list' explicitly. +- (setq current-load-list +- (cons (quote (, name)) current-load-list)) +- (put (quote (, name)) 'defsubst-maybe t)))))) ++ `(or (fboundp (quote ,name)) ++ (prog1 ++ (static-cond ++ ,@ (mapcar ++ (function ++ (lambda (case) ++ (list (car case) ++ (if doc ++ `(defsubst ,name ,args ++ ,doc ++ ,@ (cdr case)) ++ `(defsubst ,name ,args ++ ,@(cdr case)))))) ++ clauses)) ++ ;; This `defsubst' will be compiled to `fset', ++ ;; which does not update `load-history'. ++ ;; We must update `current-load-list' explicitly. ++ (setq current-load-list ++ (cons (quote ,name) current-load-list)) ++ (put (quote ,name) 'defsubst-maybe t))))) + + + ;;; Edebug spec. +@@ -246,7 +246,7 @@ + "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))))) ++ `(put (quote ,symbol) 'edebug-form-spec (quote ,spec))) + + ;; edebug-spec for `def*-maybe' macros. + (def-edebug-spec defun-maybe defun) Index: files/patch-static.el =================================================================== RCS file: files/patch-static.el diff -N files/patch-static.el --- /dev/null 1 Jan 1970 00:00:00 -0000 +++ files/patch-static.el 24 Aug 2012 00:34:45 -0000 @@ -0,0 +1,71 @@ +Index: static.el +=================================================================== +--- static.el (revision 2) ++++ static.el (working copy) +@@ -29,38 +29,38 @@ + "Like `if', but evaluate COND at compile time." + (if (eval cond) + then +- (` (progn (,@ else))))) ++ `(progn ,@else))) + + (put 'static-when 'lisp-indent-function 1) + (defmacro static-when (cond &rest body) + "Like `when', but evaluate COND at compile time." + (if (eval cond) +- (` (progn (,@ body))))) ++ `(progn ,@body))) + + (put 'static-unless 'lisp-indent-function 1) + (defmacro static-unless (cond &rest body) + "Like `unless', but evaluate COND at compile time." + (if (eval cond) + nil +- (` (progn (,@ body))))) ++ `(progn ,@body))) + + (put 'static-condition-case 'lisp-indent-function 2) + (defmacro static-condition-case (var bodyform &rest handlers) + "Like `condition-case', but evaluate BODYFORM at compile time." +- (eval (` (condition-case (, var) +- (list (quote quote) (, bodyform)) +- (,@ (mapcar +- (if var +- (function +- (lambda (h) +- (` ((, (car h)) +- (list (quote funcall) +- (function (lambda ((, var)) (,@ (cdr h)))) +- (list (quote quote) (, var))))))) +- (function +- (lambda (h) +- (` ((, (car h)) (quote (progn (,@ (cdr h))))))))) +- handlers)))))) ++ (eval `(condition-case ,var ++ (list (quote quote) ,bodyform) ++ ,@(mapcar ++ (if var ++ (function ++ (lambda (h) ++ `(,(car h) ++ (list (quote funcall) ++ (function (lambda (,var) ,@(cdr h))) ++ (list (quote quote) ,var))))) ++ (function ++ (lambda (h) ++ `(,(car h) (quote (progn ,@(cdr h))))))) ++ handlers)))) + + (put 'static-defconst 'lisp-indent-function 'defun) + (defmacro static-defconst (symbol initvalue &optional docstring) +@@ -68,8 +68,8 @@ + + The variable SYMBOL can be referred at both compile time and run time." + (let ((value (eval initvalue))) +- (eval (` (defconst (, symbol) (quote (, value)) (, docstring)))) +- (` (defconst (, symbol) (quote (, value)) (, docstring))))) ++ (eval `(defconst ,symbol (quote ,value) ,docstring)) ++ `(defconst ,symbol (quote ,value) ,docstring))) + + (defmacro static-cond (&rest clauses) + "Like `cond', but evaluate CONDITION part of each clause at compile time." --- patch-apel ends here --- >Release-Note: >Audit-Trail: >Unformatted: