dgnushack.el (byte-optimize-apply): Make the use-mapcan advice work

[gnus] / lisp / dgnushack.el

diff --git a/lisp/dgnushack.el b/lisp/dgnushack.el
index 5141a00..b2c73e0 100644 (file)
--- a/lisp/dgnushack.el
+++ b/lisp/dgnushack.el
@@ -1,5 +1,5 @@
 ;;; dgnushack.el --- a hack to set the load path for byte-compiling
 ;;; dgnushack.el --- a hack to set the load path for byte-compiling

-;; Copyright (C) 1994-2011 Free Software Foundation, Inc.
+;; Copyright (C) 1994-2015 Free Software Foundation, Inc.

 
 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
 ;; Version: 4.19
 
 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
 ;; Version: 4.19


@@ -18,9 +18,7 @@
 ;; GNU General Public License for more details.
 
 ;; You should have received a copy of the GNU General Public License
 ;; GNU General Public License for more details.
 
 ;; You should have received a copy of the GNU General Public License

-;; along with GNU Emacs; see the file COPYING.  If not, write to the
-;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
-;; Boston, MA 02110-1301, USA.
+;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.

 
 ;;; Commentary:
 
 
 ;;; Commentary:
 


@@ -28,6 +26,11 @@
 
 (defvar dgnushack-default-load-path (copy-sequence load-path))
 
 
 (defvar dgnushack-default-load-path (copy-sequence load-path))
 

+(when (featurep 'xemacs)
+  (defmacro declare-function (fn file &optional arglist fileonly)
+    (unless (fboundp fn) (autoload fn file))
+    nil))
+

 (defalias 'facep 'ignore)
 
 (require 'cl)
 (defalias 'facep 'ignore)
 
 (require 'cl)


@@ -47,15 +50,9 @@
 (if (my-getenv "lispdir")
     (push (my-getenv "lispdir") load-path))
 
 (if (my-getenv "lispdir")
     (push (my-getenv "lispdir") load-path))
 

-(push (or (my-getenv "URLDIR") (expand-file-name "../../url/lisp/" loaddir))
-      load-path)
-
-(push (or (my-getenv "W3DIR") (expand-file-name "../../w3/lisp/" loaddir))
-      load-path)
-

 ;(push "/usr/share/emacs/site-lisp" load-path)
 
 ;(push "/usr/share/emacs/site-lisp" load-path)
 

-;; If we are building w3 in a different directory than the source
+;; If we are building Gnus in a different directory than the source

 ;; directory, we must read *.el from source directory and write *.elc
 ;; into the building directory.  For that, we define this function
 ;; before loading bytecomp.  Bytecomp doesn't overwrite this function.
 ;; directory, we must read *.el from source directory and write *.elc
 ;; into the building directory.  For that, we define this function
 ;; before loading bytecomp.  Bytecomp doesn't overwrite this function.


@@ -129,6 +126,8 @@
 (defalias 'efs-re-read-dir 'ignore)
 (defalias 'ange-ftp-re-read-dir 'ignore)
 (defalias 'define-mail-user-agent 'ignore)
 (defalias 'efs-re-read-dir 'ignore)
 (defalias 'ange-ftp-re-read-dir 'ignore)
 (defalias 'define-mail-user-agent 'ignore)

+(defalias 'debbugs-gnu-summary-mode 'ignore)
+(defvar debbugs-gnu-bug-number nil)

 
 (eval-and-compile
   (unless (featurep 'xemacs)
 
 (eval-and-compile
   (unless (featurep 'xemacs)


@@ -141,15 +140,23 @@
 
 (eval-and-compile
   (when (featurep 'xemacs)
 
 (eval-and-compile
   (when (featurep 'xemacs)

+    (defvar window-point-insertion-type nil)

     (unless (fboundp 'defadvice)
       (autoload 'defadvice "advice" nil nil 'macro))
     (unless (boundp 'help-echo-owns-message)
       (defvar help-echo-owns-message))
     (unless (fboundp 'defadvice)
       (autoload 'defadvice "advice" nil nil 'macro))
     (unless (boundp 'help-echo-owns-message)
       (defvar help-echo-owns-message))

+    (unless (boundp 'gnus-registry-enabled)
+      (defvar gnus-registry-enabled nil))
+    (unless (boundp 'mail-dont-reply-to-names)
+      (defvar mail-dont-reply-to-names nil))

     (unless (fboundp 'url-retrieve-synchronously)
       (defalias 'url-retrieve-synchronously 'url-retrieve))
     (unless (fboundp 'url-queue-retrieve)
     (unless (fboundp 'url-retrieve-synchronously)
       (defalias 'url-retrieve-synchronously 'url-retrieve))
     (unless (fboundp 'url-queue-retrieve)

-      (defun url-queue-retrieve (url callback &optional cbargs silent)
+      (defun url-queue-retrieve (url callback &optional cbargs silent
+                                    inhibit-cookies)

        (url-retrieve url callback cbargs)))
        (url-retrieve url callback cbargs)))

+    (unless (boundp 'w3-configuration-directory)
+      (setq w3-configuration-directory "~/.w3/"))

     (autoload 'Info-directory "info" nil t)
     (autoload 'Info-index "info" nil t)
     (autoload 'Info-index-next "info" nil t)
     (autoload 'Info-directory "info" nil t)
     (autoload 'Info-index "info" nil t)
     (autoload 'Info-index-next "info" nil t)


@@ -172,6 +179,7 @@
     (autoload 'customize-set-variable "cus-edit" nil t)
     (autoload 'customize-variable "cus-edit" nil t)
     (autoload 'debug "debug" nil t)
     (autoload 'customize-set-variable "cus-edit" nil t)
     (autoload 'customize-variable "cus-edit" nil t)
     (autoload 'debug "debug" nil t)

+    (autoload 'sha1 "sha1")

     (if (featurep 'mule)
        (unless (locate-library "mule-ccl")
          (autoload 'define-ccl-program "ccl" nil nil 'macro))
     (if (featurep 'mule)
        (unless (locate-library "mule-ccl")
          (autoload 'define-ccl-program "ccl" nil nil 'macro))


@@ -191,7 +199,6 @@
     (autoload 'mail-fetch-field "mail-utils")
     (autoload 'make-annotation "annotations")
     (autoload 'make-display-table "disp-table")
     (autoload 'mail-fetch-field "mail-utils")
     (autoload 'make-annotation "annotations")
     (autoload 'make-display-table "disp-table")

-    (autoload 'pgg-snarf-keys-region "pgg" nil t)

     (autoload 'pp "pp")
     (autoload 'ps-despool "ps-print" nil t)
     (autoload 'ps-spool-buffer "ps-print" nil t)
     (autoload 'pp "pp")
     (autoload 'ps-despool "ps-print" nil t)
     (autoload 'ps-spool-buffer "ps-print" nil t)


@@ -223,23 +230,21 @@
     (autoload 'toggle-truncate-lines "view-less" nil t)
     (autoload 'trace-function-background "trace" nil t)
     (autoload 'unmorse-region "morse" nil t)
     (autoload 'toggle-truncate-lines "view-less" nil t)
     (autoload 'trace-function-background "trace" nil t)
     (autoload 'unmorse-region "morse" nil t)

-    (autoload 'w3-do-setup "w3")
-    (autoload 'w3-prepare-buffer "w3-display")
-    (autoload 'w3-region "w3-display" nil t)

     (defalias 'frame-char-height 'frame-height)
     (defalias 'frame-char-width 'frame-width)
     (defalias 'frame-parameter 'frame-property)
     (defalias 'frame-char-height 'frame-height)
     (defalias 'frame-char-width 'frame-width)
     (defalias 'frame-parameter 'frame-property)

-    (defalias 'make-overlay 'ignore)
-    (defalias 'overlay-end 'ignore)
-    (defalias 'overlay-get 'ignore)
-    (defalias 'overlay-put 'ignore)
-    (defalias 'overlay-start 'ignore)
-    (defalias 'overlays-in 'ignore)

     (defalias 'replace-dehighlight 'ignore)
     (defalias 'replace-highlight 'ignore)
     (defalias 'gnutls-available-p 'ignore)
     (defvar timer-list nil)
     (defalias 'replace-dehighlight 'ignore)
     (defalias 'replace-highlight 'ignore)
     (defalias 'gnutls-available-p 'ignore)
     (defvar timer-list nil)

-    (defalias 'w3-coding-system-for-mime-charset 'ignore)))
+    (defvar scroll-margin 0)
+    (dolist (fn '(copy-overlay
+                 delete-overlay make-overlay move-overlay next-overlay-change
+                 overlay-buffer overlay-end overlay-get overlay-lists
+                 overlay-properties overlay-put overlay-recenter overlay-start
+                 overlayp overlays-at overlays-in previous-overlay-change
+                 remove-overlays))
+      (autoload fn "overlay"))))

 
 (defun dgnushack-emacs-compile-defcustom-p ()
   "Return non-nil if Emacs byte compiles `defcustom' forms.
 
 (defun dgnushack-emacs-compile-defcustom-p ()
   "Return non-nil if Emacs byte compiles `defcustom' forms.


@@ -267,9 +272,17 @@ in `defcustom' forms."
       (when (and (eq last (third form))
                 (consp last)
                 (eq 'mapcar (car last))
       (when (and (eq last (third form))
                 (consp last)
                 (eq 'mapcar (car last))

-                (equal (nth 1 form) ''nconc))
+                (member (nth 1 form) '(''nconc #'nconc)))

        (setq form (cons 'mapcan (cdr last)))))))
 
        (setq form (cons 'mapcan (cdr last)))))))
 

+(if (featurep 'emacs)
+    (defun dgnushack-compile-file (file)
+      "Byte-compile FILE after reporting that it's being compiled."
+      (message "Compiling %s..." (file-name-nondirectory file))
+      ;; The Emacs 25 version of it doesn't say much.
+      (byte-compile-file file))
+  (defalias 'dgnushack-compile-file 'byte-compile-file))
+

 (defun dgnushack-compile-verbosely ()
   "Call dgnushack-compile with warnings ENABLED.  If you are compiling
 patches to gnus, you should consider modifying make.bat to call
 (defun dgnushack-compile-verbosely ()
   "Call dgnushack-compile with warnings ENABLED.  If you are compiling
 patches to gnus, you should consider modifying make.bat to call


@@ -300,12 +313,6 @@ This means that every warning will be reported as an error."
       (setq files (delete file files)))
     (when (featurep 'base64)
       (setq files (delete "base64.el" files)))
       (setq files (delete file files)))
     (when (featurep 'base64)
       (setq files (delete "base64.el" files)))

-    (condition-case code
-       (require 'w3-parse)
-      (error
-       (message "No w3: %s %s" (cadr code) (or (locate-library "w3-parse") ""))
-       (dolist (file '("webmail.el" "nnwfm.el"))
-        (setq files (delete file files)))))

     (condition-case code
        ;; Under XEmacs 21.4 this loads easy-mmode.elc that provides
        ;; the Emacs functions `propertize' and `replace-regexp-in-string'.
     (condition-case code
        ;; Under XEmacs 21.4 this loads easy-mmode.elc that provides
        ;; the Emacs functions `propertize' and `replace-regexp-in-string'.


@@ -327,9 +334,17 @@ This means that every warning will be reported as an error."
                 ;; lpath.el binds it.
                 (not (eq (symbol-function 'libxml-parse-html-region)
                          'ignore)))
                 ;; lpath.el binds it.
                 (not (eq (symbol-function 'libxml-parse-html-region)
                          'ignore)))

-      (dolist (file '("color.el" "shr-color.el" "shr.el"))
+      (dolist (file '("color.el"))

        (setq files (delete file files))))
        (setq files (delete file files))))

-
+    (unless (locate-library "epg")
+      (setq files (delete "plstore.el" files)))
+    ;; Temporary code until we fix pcase and defmethod stuff.
+    (when (or (featurep 'xemacs)
+             (or (< emacs-major-version 24)
+                 (< emacs-minor-version 3)))
+      (setq files (delete "gnus-icalendar.el" files))
+      ;; Temporary during development.
+      (setq files (delete "gnus-cloud.el" files)))

     (dolist (file files)
       (setq file (expand-file-name file srcdir))
       (when (and (file-exists-p
     (dolist (file files)
       (setq file (expand-file-name file srcdir))
       (when (and (file-exists-p


@@ -345,10 +360,10 @@ This means that every warning will be reported as an error."
        (if error-on-warn
            (let ((byte-compile-error-on-warn t))
              (unless (ignore-errors
        (if error-on-warn
            (let ((byte-compile-error-on-warn t))
              (unless (ignore-errors

-                       (byte-compile-file file))
+                       (dgnushack-compile-file file))

                (setq compilesuccess nil)))
          (ignore-errors
                (setq compilesuccess nil)))
          (ignore-errors

-           (byte-compile-file file)))))
+           (dgnushack-compile-file file)))))

     compilesuccess))
 
 (defun dgnushack-recompile ()
     compilesuccess))
 
 (defun dgnushack-recompile ()


@@ -544,4 +559,47 @@ or remove them using `make remove-installed-shadows'.\n\n"))))))))
              (error (princ "failed\n")))))
        (setq path (cdr path))))))
 
              (error (princ "failed\n")))))
        (setq path (cdr path))))))
 

+(unless (fboundp 'with-demoted-errors)
+  (defmacro with-demoted-errors (&rest body)
+    "Run BODY and demote any errors to simple messages.
+If `debug-on-error' is non-nil, run BODY without catching its errors.
+This is to be used around code which is not expected to signal an error
+but which should be robust in the unexpected case that an error is signaled."
+    (declare (debug t) (indent 0))
+    (let ((err (make-symbol "err")))
+      `(condition-case ,err
+          (progn ,@body)
+        (error (message "Error: %S" ,err) nil)))))
+
+;; `define-obsolete-function-alias' and `define-obsolete-variable-alias'
+;; take only two arguments in XEmacs:
+;; (define-obsolete-function-alias OLDFUN NEWFUN)
+;; (define-obsolete-variable-alias OLDVAR NEWVAR)
+(condition-case nil
+    (define-obsolete-function-alias
+      'dgnushack-obsolete-name 'dgnushack-current-name "0")
+  (wrong-number-of-arguments
+   (defadvice define-obsolete-function-alias (around ignore-rest-args
+                                                    (oldfun newfun &rest args)
+                                                    activate)
+     "Ignore arguments other than the 1st and the 2nd ones."
+     ad-do-it)
+   (put 'define-obsolete-function-alias 'byte-optimizer
+       (lambda (form)
+         (setcdr (nthcdr 2 form) nil)
+         form))))
+(condition-case nil
+    (define-obsolete-variable-alias
+      'dgnushack-obsolete-name 'dgnushack-current-name "0")
+  (wrong-number-of-arguments
+   (defadvice define-obsolete-variable-alias (around ignore-rest-args
+                                                    (oldvar newvar &rest args)
+                                                    activate)
+     "Ignore arguments other than the 1st and the 2nd ones."
+     ad-do-it)
+   (put 'define-obsolete-variable-alias 'byte-optimizer
+       (lambda (form)
+         (setcdr (nthcdr 2 form) nil)
+         form))))
+

 ;;; dgnushack.el ends here
 ;;; dgnushack.el ends here