cgit.sxemacs.org Git - gnus/blob - lisp/dgnushack.el

   1 ;;; dgnushack.el --- a hack to set the load path for byte-compiling
   2 ;; Copyright (C) 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001
   3 ;;        Free Software Foundation, Inc.
   4
   5 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
   6 ;; Version: 4.19
   7 ;; Keywords: news, path
   8
   9 ;; This file is part of GNU Emacs.
  10
  11 ;; GNU Emacs is free software; you can redistribute it and/or modify
  12 ;; it under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation; either version 2, or (at your option)
  14 ;; any later version.
  15
  16 ;; GNU Emacs is distributed in the hope that it will be useful,
  17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;; GNU General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  23 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  24 ;; Boston, MA 02111-1307, USA.
  25
  26 ;;; Commentary:
  27
  28 ;;; Code:
  29
  30 (defalias 'facep 'ignore)
  31
  32 (require 'cl)
  33
  34 (defvar srcdir (or (getenv "srcdir") "."))
  35
  36 (defun my-getenv (str)
  37   (let ((val (getenv str)))
  38     (if (equal val "no") nil val)))
  39
  40 (if (my-getenv "lispdir")
  41     (push (my-getenv "lispdir") load-path))
  42
  43 (push (or (my-getenv "URLDIR") (expand-file-name "../../url/lisp/" srcdir))
  44       load-path)
  45
  46 (push (or (my-getenv "W3DIR") (expand-file-name "../../w3/lisp/" srcdir))
  47       load-path)
  48
  49 ;(push "/usr/share/emacs/site-lisp" load-path)
  50
  51 (unless (featurep 'xemacs)
  52   (define-compiler-macro last (&whole form x &optional n)
  53     (if (and (fboundp 'last)
  54              (subrp (symbol-function 'last)))
  55         form
  56       (if n
  57           `(let* ((x ,x)
  58                   (n ,n)
  59                   (m 0)
  60                   (p x))
  61              (while (consp p)
  62                (incf m)
  63                (pop p))
  64              (if (<= n 0)
  65                  p
  66                (if (< n m)
  67                    (nthcdr (- m n) x)
  68                  x)))
  69         `(let ((x ,x))
  70            (while (consp (cdr x))
  71              (pop x))
  72            x))))
  73
  74   (define-compiler-macro coerce (&whole form x type)
  75     (if (and (fboundp 'coerce)
  76              (subrp (symbol-function 'coerce)))
  77         form
  78       `(let ((x ,x)
  79              (type ,type))
  80          (cond ((eq type 'list) (if (listp x) x (append x nil)))
  81                ((eq type 'vector) (if (vectorp x) x (vconcat x)))
  82                ((eq type 'string) (if (stringp x) x (concat x)))
  83                ((eq type 'array) (if (arrayp x) x (vconcat x)))
  84                ((and (eq type 'character) (stringp x) (= (length x) 1))
  85                 (aref x 0))
  86                ((and (eq type 'character) (symbolp x)
  87                      (= (length (symbol-name x)) 1))
  88                 (aref (symbol-name x) 0))
  89                ((eq type 'float) (float x))
  90                ((typep x type) x)
  91                (t (error "Can't coerce %s to type %s" x type))))))
  92
  93   (define-compiler-macro merge (&whole form type seq1 seq2 pred &rest keys)
  94     (if (and (fboundp 'merge)
  95              (subrp (symbol-function 'merge)))
  96         form
  97       `(let ((type ,type)
  98              (seq1 ,seq1)
  99              (seq2 ,seq2)
 100              (pred ,pred))
 101          (or (listp seq1) (setq seq1 (append seq1 nil)))
 102          (or (listp seq2) (setq seq2 (append seq2 nil)))
 103          (let ((res nil))
 104            (while (and seq1 seq2)
 105              (if (funcall pred (car seq2) (car seq1))
 106                  (push (pop seq2) res)
 107                (push (pop seq1) res)))
 108            (coerce (nconc (nreverse res) seq1 seq2) type)))))
 109
 110   (define-compiler-macro subseq (&whole form seq start &optional end)
 111     (if (and (fboundp 'subseq)
 112              (subrp (symbol-function 'subseq)))
 113         form
 114       (if end
 115           `(let ((seq ,seq)
 116                  (start ,start)
 117                  (end ,end))
 118              (if (stringp seq)
 119                  (substring seq start end)
 120                (let (len)
 121                  (if (< end 0)
 122                      (setq end (+ end (setq len (length seq)))))
 123                  (if (< start 0)
 124                      (setq start (+ start (or len (setq len (length seq))))))
 125                  (cond ((listp seq)
 126                         (if (> start 0)
 127                             (setq seq (nthcdr start seq)))
 128                         (let ((res nil))
 129                           (while (>= (setq end (1- end)) start)
 130                             (push (pop seq) res))
 131                           (nreverse res)))
 132                        (t
 133                         (let ((res (make-vector (max (- end start) 0) nil))
 134                               (i 0))
 135                           (while (< start end)
 136                             (aset res i (aref seq start))
 137                             (setq i (1+ i)
 138                                   start (1+ start)))
 139                           res))))))
 140         `(let ((seq ,seq)
 141                (start ,start))
 142            (if (stringp seq)
 143                (substring seq start)
 144              (let (len)
 145                (if (< start 0)
 146                    (setq start (+ start (or len (setq len (length seq))))))
 147                (cond ((listp seq)
 148                       (if (> start 0)
 149                           (setq seq (nthcdr start seq)))
 150                       (copy-sequence seq))
 151                      (t
 152                       (let* ((end (or len (length seq)))
 153                              (res (make-vector (max (- end start) 0) nil))
 154                              (i 0))
 155                         (while (< start end)
 156                           (aset res i (aref seq start))
 157                           (setq i (1+ i)
 158                                 start (1+ start)))
 159                         res)))))))))
 160
 161   (define-compiler-macro copy-list (&whole form list)
 162     (if (and (fboundp 'copy-list)
 163              (subrp (symbol-function 'copy-list)))
 164         form
 165       `(let ((list ,list))
 166          (if (consp list)
 167              (let ((res nil))
 168                (while (consp list) (push (pop list) res))
 169                (prog1 (nreverse res) (setcdr res list)))
 170            (car list)))))
 171   )
 172
 173 ;; If we are building w3 in a different directory than the source
 174 ;; directory, we must read *.el from source directory and write *.elc
 175 ;; into the building directory.  For that, we define this function
 176 ;; before loading bytecomp.  Bytecomp doesn't overwrite this function.
 177 (defun byte-compile-dest-file (filename)
 178   "Convert an Emacs Lisp source file name to a compiled file name.
 179  In addition, remove directory name part from FILENAME."
 180   (setq filename (byte-compiler-base-file-name filename))
 181   (setq filename (file-name-sans-versions filename))
 182   (setq filename (file-name-nondirectory filename))
 183   (if (memq system-type '(win32 w32 mswindows windows-nt))
 184       (setq filename (downcase filename)))
 185   (cond ((eq system-type 'vax-vms)
 186          (concat (substring filename 0 (string-match ";" filename)) "c"))
 187         ((string-match emacs-lisp-file-regexp filename)
 188          (concat (substring filename 0 (match-beginning 0)) ".elc"))
 189         (t (concat filename ".elc"))))
 190
 191 (require 'bytecomp)
 192
 193 (push srcdir load-path)
 194 (load (expand-file-name "lpath.el" srcdir) nil t)
 195
 196 (defalias 'device-sound-enabled-p 'ignore)
 197 (defalias 'play-sound-file 'ignore)
 198 (defalias 'nndb-request-article 'ignore)
 199 (defalias 'efs-re-read-dir 'ignore)
 200 (defalias 'ange-ftp-re-read-dir 'ignore)
 201 (defalias 'define-mail-user-agent 'ignore)
 202
 203 (eval-and-compile
 204   (unless (featurep 'xemacs)
 205     (defalias 'get-popup-menu-response 'ignore)
 206     (defalias 'event-object 'ignore)
 207     (defalias 'x-defined-colors 'ignore)
 208     (defalias 'read-color 'ignore)))
 209
 210 (defun dgnushack-compile (&optional warn)
 211   ;;(setq byte-compile-dynamic t)
 212   (unless warn
 213     (setq byte-compile-warnings
 214           '(free-vars unresolved callargs redefine)))
 215   (unless (locate-library "cus-edit")
 216     (error "You do not seem to have Custom installed.
 217 Fetch it from <URL:http://www.dina.kvl.dk/~abraham/custom/>.
 218 You also then need to add the following to the lisp/dgnushack.el file:
 219
 220      (push \"~/lisp/custom\" load-path)
 221
 222 Modify to suit your needs."))
 223   (let ((files (directory-files srcdir nil "^[^=].*\\.el$"))
 224         ;;(byte-compile-generate-call-tree t)
 225         file elc)
 226     ;; Avoid barfing (from gnus-xmas) because the etc directory is not yet
 227     ;; installed.
 228     (when (featurep 'xemacs)
 229       (setq gnus-xmas-glyph-directory "dummy"))
 230     (dolist (file '("dgnushack.el" "lpath.el"))
 231       (setq files (delete file files)))
 232     (when (featurep 'base64)
 233       (setq files (delete "base64.el" files)))
 234     (condition-case code
 235         (require 'w3-forms)
 236       (error
 237        (message "No w3: %s %s" code (locate-library "w3-forms"))
 238        (dolist (file '("nnweb.el" "nnlistserv.el" "nnultimate.el"
 239                        "nnslashdot.el" "nnwarchive.el" "webmail.el"
 240                        "nnwfm.el" "nnrss.el"))
 241          (setq files (delete file files)))))
 242     (condition-case code
 243         (require 'mh-e)
 244       (error
 245        (message "No mh-e: %s %s" code (locate-library "mh-e"))
 246        (setq files (delete "gnus-mh.el" files))))
 247     (condition-case code
 248         (require 'xml)
 249       (error
 250        (message "No xml: %s %s" code (locate-library "xml"))
 251        (setq files (delete "nnrss.el" files))))
 252     (dolist (file
 253              (if (featurep 'xemacs)
 254                  '("md5.el" "smiley-ems.el")
 255                '("gnus-xmas.el" "gnus-picon.el" "messagexmas.el"
 256                  "nnheaderxm.el" "smiley.el")))
 257       (setq files (delete file files)))
 258
 259     (dolist (file files)
 260       (setq file (expand-file-name file srcdir))
 261       (when (and (file-exists-p
 262                   (setq elc (concat (file-name-nondirectory file) "c")))
 263                  (file-newer-than-file-p file elc))
 264         (delete-file elc)))
 265
 266     (while (setq file (pop files))
 267       (setq file (expand-file-name file srcdir))
 268       (when (or (not (file-exists-p
 269                       (setq elc (concat (file-name-nondirectory file) "c"))))
 270                 (file-newer-than-file-p file elc))
 271         (ignore-errors
 272           (byte-compile-file file))))))
 273
 274 (defun dgnushack-recompile ()
 275   (require 'gnus)
 276   (byte-recompile-directory "." 0))
 277
 278 (defvar dgnushack-gnus-load-file (expand-file-name "gnus-load.el"))
 279 (defvar dgnushack-cus-load-file (expand-file-name "cus-load.el"))
 280
 281 (defun dgnushack-make-cus-load ()
 282   (load "cus-dep")
 283   (let ((cusload-base-file dgnushack-cus-load-file))
 284     (if (fboundp 'custom-make-dependencies)
 285         (custom-make-dependencies)
 286       (Custom-make-dependencies))))
 287
 288 (defun dgnushack-make-auto-load ()
 289   (require 'autoload)
 290   (unless (make-autoload '(define-derived-mode child parent name
 291                             "docstring" body)
 292                          "file")
 293     (defadvice make-autoload (around handle-define-derived-mode activate)
 294       "Handle `define-derived-mode'."
 295       (if (eq (car-safe (ad-get-arg 0)) 'define-derived-mode)
 296           (setq ad-return-value
 297                 (list 'autoload
 298                       (list 'quote (nth 1 (ad-get-arg 0)))
 299                       (ad-get-arg 1)
 300                       (nth 4 (ad-get-arg 0))
 301                       t nil))
 302         ad-do-it))
 303     (put 'define-derived-mode 'doc-string-elt 3))
 304   (let ((generated-autoload-file dgnushack-gnus-load-file)
 305         (make-backup-files nil)
 306         (autoload-package-name "gnus"))
 307     (if (featurep 'xemacs)
 308         (if (file-exists-p generated-autoload-file)
 309             (delete-file generated-autoload-file))
 310       (with-temp-file generated-autoload-file
 311         (insert ?\014)))
 312     (batch-update-autoloads)))
 313
 314 (defun dgnushack-make-load ()
 315   (message (format "Generating %s..." dgnushack-gnus-load-file))
 316   (with-temp-file dgnushack-gnus-load-file
 317     (insert-file-contents dgnushack-cus-load-file)
 318     (delete-file dgnushack-cus-load-file)
 319     (goto-char (point-min))
 320     (search-forward ";;; Code:")
 321     (forward-line)
 322     (delete-region (point-min) (point))
 323     (insert "\
 324 ;;; gnus-load.el --- automatically extracted custom dependencies and autoload
 325 ;;
 326 ;;; Code:
 327 ")
 328     (goto-char (point-max))
 329     (if (search-backward "custom-versions-load-alist" nil t)
 330         (forward-line -1)
 331       (forward-line -1)
 332       (while (eq (char-after) ?\;)
 333         (forward-line -1))
 334       (forward-line))
 335     (delete-region (point) (point-max))
 336     (insert "\n")
 337     ;; smiley-* are duplicated. Remove them all.
 338     (let ((point (point)))
 339       (insert-file-contents dgnushack-gnus-load-file)
 340       (goto-char point)
 341       (while (search-forward "smiley-" nil t)
 342         (beginning-of-line)
 343         (if (looking-at "(autoload ")
 344             (delete-region (point) (progn (forward-sexp) (point)))
 345           (forward-line))))
 346     ;;
 347     (goto-char (point-max))
 348     (when (search-backward "\n(provide " nil t)
 349       (forward-line -1)
 350       (delete-region (point) (point-max)))
 351     (insert "\
 352
 353 \(provide 'gnus-load)
 354
 355 ;;; Local Variables:
 356 ;;; version-control: never
 357 ;;; no-byte-compile: t
 358 ;;; no-update-autoloads: t
 359 ;;; End:
 360 ;;; gnus-load.el ends here\n"))
 361   (message (format "Compiling %s..." dgnushack-gnus-load-file))
 362   (byte-compile-file dgnushack-gnus-load-file))
 363
 364 ;;; dgnushack.el ends here