Mercurial > hg > xemacs-beta
changeset 2548:c4c8a36043be
[xemacs-hg @ 2005-02-03 07:11:19 by ben]
behavior ws #4: package-suppress, autoload update/sync, add easy-mmode/regexp-opt to core
lread.c, lisp.h: Remove undeeded Vload_file_name_internal_the_purecopy,
Qload_file_name -- use internal_bind_lisp_object instead of
specbind.
Add load-suppress-alist.
* easy-mmode.el, regexp-opt.el:
Move these files into core.
Uncomment stuff depending on new custom.el.
autoload.el: Removed.
Major update. Sync with FSF 21.2.
Create the ability to make custom-defines files.
update-elc-2.el, update-elc.el: Rewrite to use new autoload API.
update-elc.el: Add easy-mmode.
| author | ben |
|---|---|
| date | Thu, 03 Feb 2005 07:11:28 +0000 |
| parents | a9527fcdf77f |
| children | 9ec13301bb30 |
| files | lisp/ChangeLog lisp/autoload.el lisp/easy-mmode.el lisp/regexp-opt.el lisp/update-elc-2.el lisp/update-elc.el src/ChangeLog src/lisp.h src/lread.c |
| diffstat | 9 files changed, 1623 insertions(+), 494 deletions(-) [+] |
line wrap: on
line diff
--- a/lisp/ChangeLog Thu Feb 03 06:14:40 2005 +0000 +++ b/lisp/ChangeLog Thu Feb 03 07:11:28 2005 +0000 @@ -1,3 +1,48 @@ +2005-02-02 Ben Wing <ben@xemacs.org> + + * easy-mmode.el, regexp-opt.el: + Move these files into core. + Uncomment stuff depending on new custom.el. + + * autoload.el: + * autoload.el (generate-autoload-function): New. + * autoload.el (autoload-feature-suffix): New. + * autoload.el (generate-autoload-section-continuation): New. + * autoload.el (make-autoload): + * autoload.el (generate-file-autoloads): + * autoload.el (generate-autoload-type-section): + * autoload.el (process-one-lisp-autoload): New. + * autoload.el (generate-lisp-file-autoloads-1): + * autoload.el (generate-c-file-autoloads-1): + * autoload.el (generate-custom-defines): New. + * autoload.el (print-autoload): Removed. + * autoload.el (autoload-print-form): New. + * autoload.el (defcustom): + * autoload.el (autoload-read-section-header): New. + * autoload.el (update-file-autoloads): + * autoload.el (update-autoloads-here): Removed. + * autoload.el (batch-update-directory-custom-defines): New. + * autoload.el (update-autoload-files): + * autoload.el (autoload-update-directory-autoloads): Removed. + * autoload.el (batch-update-directory-autoloads): New. + * autoload.el (autoload-featurep-protect-autoloads): + * autoload.el (update-autoloads-from-directory): Removed. + * autoload.el (update-custom-define-files): New. + * autoload.el (autoload-make-feature-name): + * autoload.el (batch-update-autoloads): + * autoload.el (batch-update-directory): Removed. + * autoload.el (batch-update-one-directory): Removed. + * autoload.el (batch-force-update-one-directory): Removed. + Major update. Sync with FSF 21.2. + Create the ability to make custom-defines files. + + * update-elc-2.el (batch-update-elc-2): + * update-elc.el (do-autoload-commands): + Rewrite to use new autoload API. + + * update-elc.el (lisp-files-needing-early-byte-compilation): + Add easy-mmode. + 2005-02-02 Ben Wing <ben@xemacs.org> * behavior.el: @@ -207,42 +252,6 @@ 2004-11-09 Ben Wing <ben@xemacs.org> - * easy-mmode.el, regexp-opt.el: - Move these files into core. - Uncomment stuff depending on new custom.el. - - * autoload.el: - * autoload.el (generate-autoload-function): New. - * autoload.el (autoload-feature-suffix): New. - * autoload.el (generate-autoload-section-continuation): New. - * autoload.el (make-autoload): - * autoload.el (generate-file-autoloads): - * autoload.el (generate-autoload-type-section): - * autoload.el (process-one-lisp-autoload): New. - * autoload.el (generate-lisp-file-autoloads-1): - * autoload.el (generate-c-file-autoloads-1): - * autoload.el (generate-custom-defines): New. - * autoload.el (print-autoload): Removed. - * autoload.el (autoload-print-form): New. - * autoload.el (defcustom): - * autoload.el (autoload-read-section-header): New. - * autoload.el (update-file-autoloads): - * autoload.el (update-autoloads-here): Removed. - * autoload.el (batch-update-directory-custom-defines): New. - * autoload.el (update-autoload-files): - * autoload.el (autoload-update-directory-autoloads): Removed. - * autoload.el (batch-update-directory-autoloads): New. - * autoload.el (autoload-featurep-protect-autoloads): - * autoload.el (update-autoloads-from-directory): Removed. - * autoload.el (update-custom-define-files): New. - * autoload.el (autoload-make-feature-name): - * autoload.el (batch-update-autoloads): - * autoload.el (batch-update-directory): Removed. - * autoload.el (batch-update-one-directory): Removed. - * autoload.el (batch-force-update-one-directory): Removed. - Major update. Sync with FSF 21.2. - Create the ability to make custom-defines files. - * paragraphs.el: * paragraphs.el (paragraphs): New. * paragraphs.el (use-hard-newlines): Removed. @@ -259,12 +268,6 @@ * paragraphs.el (transpose-sentences): Sync to 21.3. Depends on easy-mmode in core. - * update-elc-2.el (batch-update-elc-2): - * update-elc.el (do-autoload-commands): - Rewrite to use new autoload API. - - * update-elc.el (lisp-files-needing-early-byte-compilation): - Add easy-mmode. 2005-01-31 Ben Wing <ben@xemacs.org>
--- a/lisp/autoload.el Thu Feb 03 06:14:40 2005 +0000 +++ b/lisp/autoload.el Thu Feb 03 07:11:28 2005 +0000 @@ -2,9 +2,10 @@ ;; Copyright (C) 1991-1994, 1997, 2003 Free Software Foundation, Inc. ;; Copyright (C) 1995 Tinker Systems and INS Engineering Corp. -;; Copyright (C) 1996, 2000, 2002, 2003 Ben Wing. +;; Copyright (C) 1996, 2000, 2002, 2003, 2004 Ben Wing. -;; Author: Roland McGrath <roland@gnu.ai.mit.edu> +;; Original Author: Roland McGrath <roland@gnu.ai.mit.edu> +;; Heavily Modified: XEmacs Maintainers ;; Keywords: maint ;; This file is part of XEmacs. @@ -24,13 +25,17 @@ ;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA ;; 02111-1307, USA. -;;; Synched up with: Not synched with FSF. +;;; Synched up with: FSF 21.2 by Ben Wing. +;;; Note that update-file-autoloads is seriously modified and not really +;;; syncable. ;;; Commentary: ;; This code keeps auto-autoloads.el files up to date. It interprets ;; magic cookies (of the form ";;;###autoload" in Lisp source files ;; and "/* ###autoload */" in C source files) in various useful ways. +;; It is also used to maintain custom-defines.el files, since most of +;; the logic for computing them is the same as for auto-autoloads.el. ;; Usage ;; ===== @@ -39,8 +44,7 @@ ;; build process, is ;; xemacs -no-packages -batch \ -;; -eval "(setq generated-autoload-file \"PATH\")" \ -;; -l autoload -f autoload-update-directory-autoloads PREFIX DIRECTORY +;; -l autoload -f batch-update-directory-autoloads PREFIX DIRECTORY ;; which causes XEmacs to update the file named by PATH from the .el ;; files in DIRECTORY (but not recursing into subdirectories) and (if @@ -61,24 +65,13 @@ ;; of XEmacs). ;; The probable next step is to fix up the packages to use the -;; `autoload-update-directory-autoloads' API. However, for backward +;; `batch-update-directory-autoloads' API. However, for backward ;; compatibility with XEmacs 21.4 and 21.1, this can't be done quickly. -;; For now the API used in update-elc-2.el: - -;; (let* ((dir "DIRECTORY") -;; (generated-autoload-file (expand-file-name "auto-autoloads.el" dir)) -;; (autoload-package-name "PREFIX")) -;; (update-autoload-files (list muledir)) -;; (byte-recompile-file generated-autoload-file 0)) - -;; is available, but this ugly kludge is deprecated. It will be removed -;; in favor of using proper arguments instead of special variables. - ;; For backward compatibility the API used in the packages/XEmacs.rules: ;; xemacs -vanilla -batch -eval "$(AUTOLOAD_PACKAGE_NAME)" \ -;; -l autoload -f batch-update-directory $(AUTOLOAD_PATH) +;; -l autoload -f batch-update-autoloads $(AUTOLOAD_PATH) ;; is supported, and the implementation is unchanged. However, ;; revision of the API (in a backward compatible way) and the @@ -130,6 +123,10 @@ ;;; Code: +;; Need to load easy-mmode because we expand macro calls to easy-mmode +;; macros in make-autoloads below. +(require 'easy-mmode) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Standard file and directory names @@ -144,6 +141,10 @@ ;; Dynamic variables for communication among functions +;; FSF 21.2: +;; The autoload file is assumed to contain a trailer starting with a FormFeed +;; character. + (defvar generated-autoload-file (expand-file-name autoload-file-name lisp-directory) "*File `update-file-autoloads' puts autoloads into. @@ -154,6 +155,11 @@ generally the file named by `autoload-file-name' in the directory being updated. XEmacs.rules setq's this variable for package autoloads.") +(defvar generate-autoload-function + #'generate-file-autoloads + "Function to generate the autoloads for a file and insert at point. +Called with one argument, the file.") + (define-obsolete-variable-alias 'autoload-package-name 'autoload-feature-prefix) (defvar autoload-feature-prefix nil @@ -164,6 +170,9 @@ auto-autoloads file). Highest priority candidate except for an explicit argument to `autoload-make-feature-name' (q.v.).") +(defvar autoload-feature-suffix "-autoloads" + "String added to `autoload-feature-prefix' to create the autoload feature name.") + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Magic strings in source files @@ -210,40 +219,69 @@ (defconst generate-autoload-section-trailer "\n;;;***\n" "String which indicates the end of the section of autoloads for a file.") +(defconst generate-autoload-section-continuation ";;;;;; " + "String to add on each continuation of the section header form.") + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Parsing the source file text. -;; Autoloads in C source differ from those in Lisp source. For historical -;; reasons, functions handling only Lisp don't have "lisp" in their names; -;; maybe this should be changed. +;; Autoloads in C source differ from those in Lisp source. (defun make-autoload (form file) - "Turn a definition generator FORM into an autoload for source file FILE. -Returns nil if FORM is not a defun, defun*, defmacro, defmacro*, -define-skeleton, or define-derived-mode." - (let ((car (car-safe form))) - (if (memq car '(defun defun* define-skeleton defmacro defmacro* - define-derived-mode)) - (let ((macrop (memq car '(defmacro defmacro*))) - name doc) - (setq form (cdr form) - name (car form) - ;; Ignore the arguments. - form (cdr (cond ((eq car 'define-skeleton) - form) - ((eq car 'define-derived-mode) - (cddr form)) - (t - (cdr form)))) - doc (car form)) - (if (stringp doc) - (setq form (cdr form)) - (setq doc nil)) - (list 'autoload (list 'quote name) file doc - (or (eq car 'define-skeleton) - (eq car 'define-derived-mode) - (eq (car-safe (car form)) 'interactive)) - (if macrop (list 'quote 'macro) nil))) - nil))) + "Turn FORM into an autoload or defvar for source file FILE. +Returns nil if FORM is not a special autoload form (i.e. a function definition +or macro definition or a defcustom)." + (let ((car (car-safe form)) expand) + (cond + ;; For complex cases, try again on the macro-expansion. + ((and (memq car '(easy-mmode-define-global-mode + easy-mmode-define-minor-mode define-minor-mode)) + (setq expand (let ((load-file-name file)) (macroexpand form))) + (eq (car expand) 'progn) + (memq :autoload-end expand)) + (let ((end (memq :autoload-end expand))) + ;; Cut-off anything after the :autoload-end marker. + (setcdr end nil) + (cons 'progn + (mapcar (lambda (form) (make-autoload form file)) + (cdr expand))))) + + ;; For special function-like operators, use the `autoload' function. + ((memq car '(defun define-skeleton defmacro define-derived-mode + define-generic-mode easy-mmode-define-minor-mode + easy-mmode-define-global-mode + define-minor-mode defun* defmacro*)) + (let* ((macrop (memq car '(defmacro defmacro*))) + (name (nth 1 form)) + (body (nthcdr (get car 'doc-string-elt) form)) + (doc (if (stringp (car body)) (pop body)))) + ;; `define-generic-mode' quotes the name, so take care of that + (list 'autoload (if (listp name) name (list 'quote name)) file doc + (or (and (memq car '(define-skeleton define-derived-mode + define-generic-mode + easy-mmode-define-global-mode + easy-mmode-define-minor-mode + define-minor-mode)) t) + (eq (car-safe (car body)) 'interactive)) + (if macrop (list 'quote 'macro) nil)))) + + ;; Convert defcustom to a simpler (and less space-consuming) defvar, + ;; but add some extra stuff if it uses :require. + ((eq car 'defcustom) + (let ((varname (car-safe (cdr-safe form))) + (init (car-safe (cdr-safe (cdr-safe form)))) + (doc (car-safe (cdr-safe (cdr-safe (cdr-safe form))))) + (rest (cdr-safe (cdr-safe (cdr-safe (cdr-safe form)))))) + (if (not (plist-get rest :require)) + `(defvar ,varname ,init ,doc) + `(progn + (defvar ,varname ,init ,doc) + (custom-add-to-group ,(plist-get rest :group) + ',varname 'custom-variable) + (custom-add-load ',varname + ,(plist-get rest :require)))))) + + ;; nil here indicates that this is not a special autoload form. + (t nil)))) (defun make-c-autoload (module) "Make an autoload list for the DEFUN at point in MODULE. @@ -283,7 +321,7 @@ ;; Generating autoloads for a single file ;;;###autoload -(defun generate-file-autoloads (file &optional funlist) +(defun generate-file-autoloads (file) "Insert at point an autoload section for FILE. autoloads are generated for defuns and defmacros in FILE marked by `generate-autoload-cookie' (which see). @@ -291,26 +329,26 @@ are used." (interactive "fGenerate autoloads for file: ") (cond ((string-match "\\.el$" file) - (generate-autoload-ish-1 + (generate-autoload-type-section file (replace-in-string (file-name-nondirectory file) "\\.elc?$" "") - nil #'generate-file-autoloads-1 - funlist)) + nil #'generate-lisp-file-autoloads-1)) ;; #### jj, are C++ modules possible? ((string-match "\\.c$" file) - (generate-autoload-ish-1 + (generate-autoload-type-section file (replace-in-string (file-name-nondirectory file) "\\.c$" "") - t #'generate-c-file-autoloads-1 - funlist)) + t #'generate-c-file-autoloads-1)) (t (error 'wrong-type-argument file "not a C or Elisp source file")))) -(defun* generate-autoload-ish-1 (file load-name literal fun-to-call &rest args) +(defun* generate-autoload-type-section (file load-name literal fun-to-call) "Insert at point an autoload-type section for FILE. -If LITERAL, open the file literally, without decoding. -Calls FUN-TO-CALL to compute the autoloads, passing it OUTBUF, LOAD-NAME, - TRIM-NAME, and ARGS." +LOAD-NAME is the non-directory portion of the name, with the final .el, .elc +or .c section removed. If LITERAL, open the file literally, without decoding. +Calls FUN-TO-CALL to compute the autoloads, with the loaded file in the +current buffer, passing it OUTBUF (where to write the autoloads), LOAD-NAME, +and TRIM-NAME (result of calling `autoload-trim-file-name' on FILE)." (let ((outbuf (current-buffer)) (trim-name (autoload-trim-file-name file)) (autoloads-done '()) @@ -318,6 +356,7 @@ (print-readably t) ; XEmacs (float-output-format nil) (visited (get-file-buffer file)) + suppress-form ;; (done-any nil) output-end) @@ -329,21 +368,74 @@ ;; subdirectory of the current buffer's directory, we'll make it ;; relative to the current buffer's directory. (setq file (expand-file-name file)) + ;; #### FSF 21.2. Do we want this? +; (let* ((source-truename (file-truename file)) +; (dir-truename (file-name-as-directory +; (file-truename default-directory))) +; (len (length dir-truename))) +; (if (and (< len (length source-truename)) +; (string= dir-truename (substring source-truename 0 len))) +; (setq file (substring source-truename len)))) + + ;; Check for suppression form (XEmacs) + (let* ((dir (file-name-directory file)) + (_pkg (expand-file-name "_pkg.el" dir)) + (pkg-vis (get-file-buffer _pkg)) + pkg-buf) + (save-excursion + (when (file-readable-p _pkg) + (unwind-protect + (progn + (let ((find-file-hooks nil) + (enable-local-variables nil)) + (set-buffer (or pkg-vis (find-file-noselect _pkg))) + (set-syntax-table emacs-lisp-mode-syntax-table)) + (save-excursion + (save-restriction + (widen) + (goto-char (point-min)) + (block nil + (while (search-forward "(package-suppress" nil t) + ;; skip over package-name + (forward-sexp 1) + (let ((supfile (read (current-buffer)))) + (when (equal supfile load-name) + (setq suppress-form (eval (read (current-buffer)))) + (return)))))))) + (unless pkg-vis + ;; We created this buffer, so we should kill it. + (if pkg-buf (kill-buffer pkg-buf))))))) (save-excursion (unwind-protect (progn - (let ((find-file-hooks nil) - (enable-local-variables nil)) + (let (;(find-file-hooks nil) + ;(enable-local-variables nil) + ) (set-buffer (or visited (find-file-noselect file literal literal ))) ;; This doesn't look right for C files, but it is. The only ;; place we need the syntax table is when snarfing the Lisp ;; function name. (set-syntax-table emacs-lisp-mode-syntax-table)) +; (if visited +; (set-buffer visited) +; ;; It is faster to avoid visiting the file. +; (set-buffer (get-buffer-create " *generate-autoload-file*")) +; (kill-all-local-variables) +; (erase-buffer) +; (setq buffer-undo-list t +; buffer-read-only nil) +; ;; This doesn't look right for C files, but it is. The only +; ;; place we need the syntax table is when snarfing the Lisp +; ;; function name. +; (emacs-lisp-mode) +; (if literal +; (insert-file-contents-literally file nil) +; (insert-file-contents file nil))) (unless (setq autoloads-done - (apply fun-to-call outbuf load-name trim-name args)) - (return-from generate-autoload-ish-1)) + (funcall fun-to-call outbuf load-name trim-name)) + (return-from generate-autoload-type-section)) ) (unless visited ;; We created this buffer, so we should kill it. @@ -354,108 +446,124 @@ ;; XEmacs -- always do this so that we cache the information ;; that we've processed the file already. (progn + ;; Insert the section-header line + ;; which lists the file name and which functions are in it, etc. (insert generate-autoload-section-header) - (prin1 (list 'autoloads autoloads-done load-name trim-name) + (prin1 (list 'autoloads autoloads-done load-name trim-name + ;; In FSF 21.2. Also in FSF 19.30. Presumably + ;; deleted from XEmacs. + ;; (nth 5 (file-attributes file)) + ) outbuf) (terpri outbuf) - ;;;; (insert ";;; Generated autoloads from " - ;;;; (autoload-trim-file-name file) "\n") - ;; Warn if we put a line in auto-autoloads.el - ;; that is long enough to cause trouble. - (when (< output-end (point)) - (setq output-end (point-marker))) - (while (< (point) output-end) - ;; (let ((beg (point))) - (end-of-line) - ;; Emacs -- I still haven't figured this one out. - ;; (if (> (- (point) beg) 900) - ;; (progn - ;; (message "A line is too long--over 900 characters") - ;; (sleep-for 2) - ;; (goto-char output-end))) - ;; ) - (forward-line 1)) + ;; #### Alas, we will have to think about this. Adding this means + ;; that, once we have created or maintained an auto-autoloads file, + ;; we alone and our successors can update the file. The file itself + ;; will work fine in older XEmacsen, but they won't be able to + ;; update autoloads -- hence, to build. +; ;; Break that line at spaces, to avoid very long lines. +; ;; Make each sub-line into a comment. +; (with-current-buffer outbuf +; (save-excursion +; (forward-line -1) +; (while (not (eolp)) +; (move-to-column 64) +; (skip-chars-forward "^ \n") +; (or (eolp) +; (insert "\n" generate-autoload-section-continuation))))) + ;; XEmacs: This was commented out before. #### Correct? +; (insert ";;; Generated autoloads from " +; (autoload-trim-file-name file) "\n") + ;; XEmacs -- handle suppression + (when suppress-form + (insert "\n;;; Suppress form from _pkg.el\n") + (insert "(unless " (prin1-to-string suppress-form) "\n\n")) (goto-char output-end) + ;; XEmacs -- handle suppression + (when suppress-form + (insert "\n) ;; unless (suppressed)\n")) (insert generate-autoload-section-trailer))) - (or noninteractive ; XEmacs: only need one line in -batch mode. - (message "Generating autoloads for %s...done" file)))) + )) + -(defun* generate-file-autoloads-1 (outbuf load-name trim-name funlist) - "Insert at point an autoload section for FILE. -autoloads are generated for defuns and defmacros in FILE -marked by `generate-autoload-cookie' (which see). -If FILE is being visited in a buffer, the contents of the buffer -are used." +(defun process-one-lisp-autoload (autoloads-done outbuf load-name) + "Process a single autoload at point and write to OUTBUF. +Point should be just after a magic cookie string (e.g. ;;;###autoload). +Updates AUTOLOADS-DONE and returns the new value." + (skip-chars-forward " \t") + ;; (setq done-any t) + (if (eolp) + ;; Read the next form and make an autoload. + (let* ((form (prog1 (read (current-buffer)) + (or (bolp) (forward-line 1)))) + (autoload (make-autoload form load-name))) + (if autoload + (setq autoloads-done (cons (nth 1 form) + autoloads-done)) + (setq autoload form)) + (autoload-print-form autoload outbuf "")) + ;; Copy the rest of the line to the output. + (cond ((looking-at "immediate\\s *$") ; XEmacs + ;; This is here so that you can automatically + ;; have small hook functions copied to + ;; auto-autoloads.el so that it's not necessary + ;; to load a whole file just to get a two-line + ;; do-nothing find-file-hook... --Stig + (forward-line 1) + (let ((begin (point))) + (forward-sexp) + (forward-line 1) + (princ (buffer-substring begin (point)) outbuf))) + (t + (princ (buffer-substring + (progn + ;; Back up over whitespace, to preserve it. + (skip-chars-backward " \f\t") + (if (= (char-after (1+ (point))) ? ) + ;; Eat one space. + (forward-char 1)) + (point)) + (progn (forward-line 1) (point))) + outbuf)))) + autoloads-done) + +(defun* generate-lisp-file-autoloads-1 (outbuf load-name trim-name) + "Insert at point in OUTBUF an autoload section for an Elisp file. +The file is assumed to be already loaded and in the current buffer. +autoloads are generated for defuns and defmacros marked by +`generate-autoload-cookie' (which see)." (let ((autoloads-done '()) - (dofiles (not (null funlist))) ) - (save-excursion (save-restriction (widen) (goto-char (point-min)) (unless (search-forward generate-autoload-cookie nil t) (message "No autoloads found in %s" trim-name) - (return-from generate-file-autoloads-1 nil)) + (return-from generate-lisp-file-autoloads-1 nil)) (message "Generating autoloads for %s..." trim-name) (goto-char (point-min)) - (while (if dofiles funlist (not (eobp))) - (if (not dofiles) - (skip-chars-forward " \t\n\f") - (goto-char (point-min)) - (re-search-forward - (concat "(def\\(un\\|var\\|const\\|macro\\) " - (regexp-quote (symbol-name (car funlist))) - "\\s ")) - (goto-char (match-beginning 0))) + (while (not (eobp)) + (skip-chars-forward " \t\n\f") (cond - ((or dofiles - (looking-at (regexp-quote generate-autoload-cookie))) - (if dofiles - nil - (search-forward generate-autoload-cookie) - (skip-chars-forward " \t")) - ;; (setq done-any t) - (if (or dofiles (eolp)) - ;; Read the next form and make an autoload. - (let* ((form (prog1 (read (current-buffer)) - (or (bolp) (forward-line 1)))) - (autoload (make-autoload form load-name)) - (doc-string-elt (get (car-safe form) - 'doc-string-elt))) - (if autoload - (setq autoloads-done (cons (nth 1 form) - autoloads-done)) - (setq autoload form)) - (print-autoload autoload doc-string-elt outbuf "")) - ;; Copy the rest of the line to the output. - (let ((begin (point))) - ;; (terpri outbuf) - (cond ((looking-at "immediate\\s *$") ; XEmacs - ;; This is here so that you can automatically - ;; have small hook functions copied to - ;; auto-autoloads.el so that it's not necessary - ;; to load a whole file just to get a two-line - ;; do-nothing find-file-hook... --Stig - (forward-line 1) - (setq begin (point)) - (forward-sexp) - (forward-line 1)) - (t - (forward-line 1))) - (princ (buffer-substring begin (point)) outbuf)))) + ((looking-at (regexp-quote generate-autoload-cookie)) + (search-forward generate-autoload-cookie) + (setq autoloads-done + (process-one-lisp-autoload autoloads-done outbuf load-name))) ((looking-at ";") ;; Don't read the comment. (forward-line 1)) (t (forward-sexp 1) (forward-line 1))) - (if dofiles - (setq funlist (cdr funlist)))))) + ))) + (or noninteractive ; XEmacs: only need one line in -batch mode. + (message "Generating autoloads for %s...done" trim-name)) autoloads-done)) -(defun* generate-c-file-autoloads-1 (outbuf load-name trim-name funlist) +(defun* generate-c-file-autoloads-1 (outbuf load-name trim-name + &optional funlist) "Insert at point an autoload section for the C file FILE. autoloads are generated for defuns and defmacros in FILE marked by `generate-c-autoload-cookie' (which see). @@ -488,7 +596,7 @@ (let ((autoload (make-c-autoload load-name))) (when autoload (push (nth 1 (nth 1 autoload)) autoloads-done) - (print-autoload autoload 3 outbuf " ")))) + (autoload-print-form autoload outbuf " ")))) ;; close the princ'd `when' form (princ ")" outbuf)) (goto-char (point-min)) @@ -505,91 +613,175 @@ (let ((autoload (make-c-autoload load-name))) (when autoload (push (nth 1 (nth 1 autoload)) autoloads-done) - (print-autoload autoload 3 outbuf " "))) + (autoload-print-form autoload outbuf " "))) (setq match (search-forward generate-c-autoload-cookie nil t))) ;; close the princ'd `when' form (princ ")" outbuf))))) + (or noninteractive ; XEmacs: only need one line in -batch mode. + (message "Generating autoloads for %s...done" trim-name)) autoloads-done)) -;; Assorted utilities for generating autoloads and pieces thereof +;;;###autoload +(defun generate-custom-defines (file) + "Insert at point a custom-define section for FILE. +If FILE is being visited in a buffer, the contents of the buffer +are used." + (interactive "fGenerate custom defines for file: ") + (cond ((string-match "\\.el$" file) + (generate-autoload-type-section + file + (replace-in-string (file-name-nondirectory file) "\\.elc?$" "") + nil #'generate-custom-defines-1)) + ((string-match "\\.c$" file) + ;; no way to generate custom-defines for C files (currently?), + ;; but cannot signal an error. + nil) + (t + (error 'wrong-type-argument file "not a C or Elisp source file")))) -(defun print-autoload (autoload doc-string-elt outbuf margin) +(defun* generate-custom-defines-1 (outbuf load-name trim-name) + "Insert at point in OUTBUF a custom-define section for an Elisp file. +This contains all defcustoms and defgroups in the file. +The file is assumed to be already loaded and in the current buffer." + (let* ((search-regexp-1 "^(\\(defcustom\\|defgroup\\) ") + (search-string-2 ";;;###custom-define") + (search-regexp-2 (regexp-quote search-string-2)) + (autoloads-done '())) + (save-excursion + (save-restriction + (widen) + (goto-char (point-min)) + (unless (or (re-search-forward search-regexp-1 nil t) + (re-search-forward search-regexp-2 nil t)) + (message "No custom defines found in %s" trim-name) + (return-from generate-custom-defines-1 nil)) + (message "Generating custom defines for %s..." trim-name) + (princ "(defconst custom-define-current-source-file " outbuf) + (prin1 (file-relative-name (buffer-file-name) + (symbol-value-in-buffer 'default-directory + outbuf)) outbuf) + (princ ")\n" outbuf) + + (goto-char (point-min)) + (while (not (eobp)) + (skip-chars-forward " \t\n\f") + (cond + ((looking-at search-regexp-1) + ;; Read the next form and copy it to make an autoload. + (let* ((form (prog1 (read (current-buffer)) + (or (bolp) (forward-line 1)))) + (autoload form ;(make-autoload form load-name) + )) + (if autoload + (setq autoloads-done (cons (nth 1 form) + autoloads-done)) + (setq autoload form)) + (autoload-print-form autoload outbuf "")) + ) + ((looking-at search-regexp-2) + (search-forward search-string-2) + (beep) + (setq autoloads-done + (process-one-lisp-autoload autoloads-done outbuf load-name))) + ((looking-at ";") + ;; Don't read the comment. + (forward-line 1)) + (t + (forward-sexp 1) + (forward-line 1))) + ))) + (or noninteractive ; XEmacs: only need one line in -batch mode. + (message "Generating custom defines for %s...done" trim-name)) + autoloads-done)) + +;; Assorted utilities for generating autoloads and pieces thereof + +(defun autoload-print-form (form outbuf margin) "Print an autoload form, handling special characters. In particular, print docstrings with escapes inserted before left parentheses at the beginning of lines and ^L characters." - (if (and doc-string-elt (stringp (nth doc-string-elt autoload))) - ;; We need to hack the printing because the doc-string must be - ;; printed specially for make-docfile (sigh). - (let* ((p (nthcdr (1- doc-string-elt) autoload)) - (elt (cdr p)) - (start-string (format "\n%s(" margin))) - (setcdr p nil) - (princ start-string outbuf) - ;; XEmacs change: don't let ^^L's get into - ;; the file or sorting is hard. - (let ((print-escape-newlines t) - (p (save-excursion - (set-buffer outbuf) - (point))) + (cond + ;; If the form is a sequence, recurse. + ((eq (car form) 'progn) + (mapcar #'(lambda (x) (autoload-print-form x outbuf margin)) + (cdr form))) + ;; Symbols at the toplevel are meaningless. + ((symbolp form) nil) + (t + (let ((doc-string-elt (get (car-safe form) 'doc-string-elt))) + (if (and doc-string-elt (stringp (nth doc-string-elt form))) + ;; We need to hack the printing because the doc-string must be + ;; printed specially for make-docfile (sigh). + (let* ((p (nthcdr (1- doc-string-elt) form)) + (elt (cdr p)) + (start-string (format "\n%s(" margin))) + (setcdr p nil) + (princ start-string outbuf) + ;; XEmacs change: don't let ^^L's get into + ;; the file or sorting is hard. + (let ((print-escape-newlines t) + ;;#### FSF 21.2 (print-escape-nonascii t) + (p (point outbuf)) + p2) + (mapcar #'(lambda (elt) + (prin1 elt outbuf) + (princ " " outbuf)) + form) + (with-current-buffer outbuf + (setq p2 (point-marker)) + (goto-char p) + (save-match-data + (while (search-forward "\^L" p2 t) + (delete-char -1) + (insert "\\^L"))) + (goto-char p2))) + (princ "\"\\\n" outbuf) + (let ((begin (point outbuf))) + (princ (substring (prin1-to-string (car elt)) 1) outbuf) + ;; Insert a backslash before each ( that appears at the beginning + ;; of a line in the doc string. + (with-current-buffer outbuf + (save-excursion + (while (search-backward start-string begin t) + (forward-char 1) + (insert "\\")))) + (if (null (cdr elt)) + (princ ")" outbuf) + (princ " " outbuf) + (princ (substring (prin1-to-string (cdr elt)) 1) outbuf)) + (terpri outbuf) + (princ margin outbuf))) + ;; XEmacs change: another ^L hack + (let ((p (point outbuf)) + (print-escape-newlines t) + ;;#### FSF 21.2 (print-escape-nonascii t) p2) - (mapcar #'(lambda (elt) - (prin1 elt outbuf) - (princ " " outbuf)) - autoload) - (save-excursion - (set-buffer outbuf) + (print form outbuf) + (with-current-buffer outbuf (setq p2 (point-marker)) (goto-char p) (save-match-data (while (search-forward "\^L" p2 t) (delete-char -1) (insert "\\^L"))) - (goto-char p2))) - (princ "\"\\\n" outbuf) - (let ((begin (save-excursion - (set-buffer outbuf) - (point)))) - (princ (substring (prin1-to-string (car elt)) 1) outbuf) - ;; Insert a backslash before each ( that appears at the beginning - ;; of a line in the doc string. - (save-excursion - (set-buffer outbuf) - (save-excursion - (while (search-backward start-string begin t) - (forward-char 1) - (insert "\\")))) - (if (null (cdr elt)) - (princ ")" outbuf) - (princ " " outbuf) - (princ (substring (prin1-to-string (cdr elt)) 1) outbuf)) - (terpri outbuf) - (princ margin outbuf))) - ;; XEmacs change: another ^L hack - (let ((p (save-excursion - (set-buffer outbuf) - (point))) - (print-escape-newlines t) - p2) - (print autoload outbuf) - (save-excursion - (set-buffer outbuf) - (setq p2 (point-marker)) - (goto-char p) - (save-match-data - (while (search-forward "\^L" p2 t) - (delete-char -1) - (insert "\\^L"))) - (goto-char p2))))) + (goto-char p2)))))))) ;;; Forms which have doc-strings which should be printed specially. ;;; A doc-string-elt property of ELT says that (nth ELT FORM) is ;;; the doc-string in FORM. ;;; -;;; defvar and defconst should be also be marked in this way. There is -;;; no interference from make-docfile, which only processes those files -;;; that are loaded into the dumped Emacs, and those files should -;;; never have anything autoloaded here. Problems only occur with files +;;; There used to be the following note here: +;;; ;;; Note: defconst and defvar should NOT be marked in this way. +;;; ;;; We don't want to produce defconsts and defvars that +;;; ;;; make-docfile can grok, because then it would grok them twice, +;;; ;;; once in foo.el (where they are given with ;;;###autoload) and +;;; ;;; once in loaddefs.el. +;;; +;;; Counter-note: Yes, they should be marked in this way. +;;; make-docfile only processes those files that are loaded into the +;;; dumped Emacs, and those files should never have anything +;;; autoloaded here. The above-feared problem only occurs with files ;;; which have autoloaded entries *and* are processed by make-docfile; ;;; there should be no such files. @@ -597,11 +789,18 @@ (put 'defun 'doc-string-elt 3) (put 'defun* 'doc-string-elt 3) (put 'defvar 'doc-string-elt 3) +(put 'defcustom 'doc-string-elt 3) (put 'defconst 'doc-string-elt 3) (put 'defmacro 'doc-string-elt 3) (put 'defmacro* 'doc-string-elt 3) -(put 'define-skeleton 'doc-string-elt 3) +(put 'defsubst 'doc-string-elt 3) +(put 'define-skeleton 'doc-string-elt 2) (put 'define-derived-mode 'doc-string-elt 4) +(put 'easy-mmode-define-minor-mode 'doc-string-elt 2) +(put 'define-minor-mode 'doc-string-elt 2) +(put 'define-generic-mode 'doc-string-elt 7) +;; defin-global-mode has no explicit docstring. +(put 'easy-mmode-define-global-mode 'doc-string-elt 1000) (defun autoload-trim-file-name (file) "Returns relative pathname of FILE including the last directory. @@ -615,6 +814,27 @@ ;; #### is this a good idea? "\\\\" "/")) +(defun autoload-read-section-header () + "Read a section header form. +Since continuation lines have been marked as comments, +we must copy the text of the form and remove those comment +markers before we call `read'." + (save-match-data + (let ((beginning (point)) + string) + (forward-line 1) + (while (looking-at generate-autoload-section-continuation) + (forward-line 1)) + (setq string (buffer-substring beginning (point))) + (with-current-buffer (get-buffer-create " *autoload*") + (erase-buffer) + (insert string) + (goto-char (point-min)) + (while (search-forward generate-autoload-section-continuation nil t) + (replace-match " ")) + (goto-char (point-min)) + (read (current-buffer)))))) + ;;;###autoload (defun update-file-autoloads (file) "Update the autoloads for FILE in `generated-autoload-file' @@ -633,16 +853,42 @@ (trim-name (autoload-trim-file-name file)) section-begin form) (save-excursion + ;; FSF has: [[ We want to get a value for generated-autoload-file + ;; from the local variables section if it's there. ]] Not + ;; applicable in XEmacs, since we always keep the autoloads + ;; up-to-date. + + ;; #### FSF 21.2 adds: [[ We must read/write the file without any + ;; code conversion, but still decode EOLs. ]] Not clear if we need + ;; this. --ben + ;; (let ((coding-system-for-read 'raw-text)) (let ((find-file-hooks nil)) (set-buffer (or (get-file-buffer generated-autoload-file) (find-file-noselect generated-autoload-file)))) + ;; FSF 21.2 says: + + ;; [[ This is to make generated-autoload-file have Unix EOLs, so + ;; that it is portable to all platforms. ]] + ;; (setq buffer-file-coding-system 'raw-text-unix)) + ;; Not applicable in XEmacs, since we always keep the autoloads + ;; up-to-date and recompile when we build. + + ;; FSF 21.2: [not applicable to XEmacs] +; (or (> (buffer-size) 0) +; (error "Autoloads file %s does not exist" buffer-file-name)) +; (or (file-writable-p buffer-file-name) +; (error "Autoloads file %s is not writable" buffer-file-name)) + + ;; NOTE: The rest of this function is totally changed from FSF. + ;; Hence, not synched. + ;; Make sure we can scribble in it. (setq buffer-read-only nil) ;; First delete all sections for this file. (goto-char (point-min)) (while (search-forward generate-autoload-section-header nil t) (setq section-begin (match-beginning 0)) - (setq form (read (current-buffer))) + (setq form (autoload-read-section-header)) (when (string= (nth 2 form) load-name) (search-forward generate-autoload-section-trailer) (delete-region section-begin (point)))) @@ -651,7 +897,7 @@ (block find-insertion-point (goto-char (point-min)) (while (search-forward generate-autoload-section-header nil t) - (setq form (read (current-buffer))) + (setq form (autoload-read-section-header)) (when (string< trim-name (nth 3 form)) ;; Found alphabetically correct insertion point (goto-char (match-beginning 0)) @@ -661,65 +907,15 @@ (goto-char (point-max)))) ; Append. ;; Add in new sections for file - (generate-file-autoloads file)) + (funcall generate-autoload-function file)) (when (interactive-p) (save-buffer))))) -;;;###autoload -(defun update-autoloads-here () - "Update sections of the current buffer generated by `update-file-autoloads'." - (interactive) - (let ((generated-autoload-file (buffer-file-name))) - (save-excursion - (goto-char (point-min)) - (while (search-forward generate-autoload-section-header nil t) - (let* ((form (condition-case () - (read (current-buffer)) - (end-of-file nil))) - (file (nth 3 form))) - ;; XEmacs change: if we can't find the file as specified, look - ;; around a bit more. - (cond ((and (stringp file) - (or (get-file-buffer file) - (file-exists-p file)))) - ((and (stringp file) - (save-match-data - (let ((loc (locate-file (file-name-nondirectory file) - load-path))) - (if (null loc) - nil - (setq loc (expand-file-name - (autoload-trim-file-name loc) - "..")) - (if (or (get-file-buffer loc) - (file-exists-p loc)) - (setq file loc) - nil)))))) - (t - (setq file - (if (y-or-n-p - (format - "Can't find library `%s'; remove its autoloads? " - (nth 2 form) file)) - t - (condition-case () - (read-file-name - (format "Find `%s' load file: " - (nth 2 form)) - nil nil t) - (quit nil)))))) - (if file - (let ((begin (match-beginning 0))) - (search-forward generate-autoload-section-trailer) - (delete-region begin (point)))) - (if (stringp file) - (generate-file-autoloads file))))))) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Utilities for batch updates ;;;###autoload -(defun autoload-update-directory-autoloads () +(defun batch-update-directory-autoloads () "Update the autoloads for a directory, using a specified feature prefix. Must be used only with -batch. The feature prefix and directory to update are taken from the first and second elements of `command-line-args-left', @@ -731,15 +927,32 @@ #### The API and semantics of this function are subject to change." (unless noninteractive - (error "autoload-batch-update-autoloads: may be used only with -batch")) - (let* ((autoload-feature-prefix (car command-line-args-left)) - (dir (cadr command-line-args-left)) - (generated-autoload-file (expand-file-name autoload-file-name dir))) - (update-autoload-files (list dir) t t) - (setq command-line-args-left (cddr command-line-args-left)))) + (error "batch-update-directory-autoloads: may be used only with -batch")) + (update-autoload-files (list (cadr command-line-args-left)) + (car command-line-args-left) nil t) + (setq command-line-args-left (cddr command-line-args-left))) ;;;###autoload -(defun update-autoload-files (files-or-dirs &optional all-into-one-file force) +(defun batch-update-directory-custom-defines () + "Update the custom defines for a directory, using a specified feature prefix. +Must be used only with -batch. The feature prefix and directory to update +are taken from the first and second elements of `command-line-args-left', +respectively, and they are then removed from `command-line-args-left'. + +Runs `update-file-autoloads' on each file in the given directory. Always +rewrites the autoloads file, even if unchanged. Makes a feature name by +applying `autoload-make-feature-name' to the specified feature prefix. + +#### The API and semantics of this function are subject to change." + (unless noninteractive + (error "batch-update-directory-custom-defines: may be used only with -batch")) + (update-custom-define-files (list (cadr command-line-args-left)) + (car command-line-args-left) nil t) + (setq command-line-args-left (cddr command-line-args-left))) + +;;;###autoload +(defun update-autoload-files (files-or-dirs feature-prefix + &optional into-file force) "Update all the autoload files associated with FILES-OR-DIRS. FILES-OR-DIRS is a list of files and/or directories to be processed. @@ -747,98 +960,144 @@ each element of FILES-OR-DIRS. Fixup code testing for the autoload file's feature and to provide the feature is added. -If optional ALL-INTO-ONE-FILE is non-`nil', `generated-autoload-file' -should be set to the name of an autoload file and all autoloads will be -placed in that file. `autoload-feature-prefix' should be set to an -appropriate prefix which will be concatenated with \"-autoloads\" to -produce the feature name. Otherwise the appropriate autoload file for -each file or directory (located in that directory, or in the directory of -the specified file) will be updated with the directory's or file's -autoloads and the protective forms will be added, and the files will be -saved. Use of the default here is unreliable, and therefore deprecated. +If optional INTO-FILE is non-`nil', it should specify a file into which +the autoloads will be placed. Otherwise, the autoloads will be placed into +a file named `auto-autoloads.el' in the directory of each element in +FILES-OR-DIRS. + +FEATURE-PREFIX should be set to an appropriate prefix which will +be concatenated with \"-autoloads\" to produce the feature name. Otherwise +the appropriate autoload file for each file or directory (located in that +directory, or in the directory of the specified file) will be updated with +the directory's or file's autoloads and the protective forms will be added, +and the files will be saved. Use of the default here is unreliable, and +therefore deprecated. Note that if some of FILES-OR-DIRS are directories, recursion goes only one level deep. If FORCE is non-nil, always save out the autoload files even if unchanged." + (or (listp files-or-dirs) (setq files-or-dirs (list files-or-dirs))) (let ((defdir (directory-file-name default-directory)) ;; value for all-into-one-file - (autoload-feature-name (autoload-make-feature-name)) - (enable-local-eval nil)) ; Don't query in batch mode. + (autoload-feature-name (autoload-make-feature-name feature-prefix)) + (enable-local-eval nil) ; Don't query in batch mode. + (autoload-feature-prefix feature-prefix) + ;; protect from change + (generated-autoload-file generated-autoload-file)) (dolist (arg files-or-dirs) (setq arg (expand-file-name arg defdir)) (cond ((file-directory-p arg) + (setq generated-autoload-file + (or into-file (expand-file-name autoload-file-name arg))) (message "Updating autoloads for directory %s..." arg) - (update-autoloads-from-directory arg)) + (let ((simple-dir (file-name-as-directory + (file-name-nondirectory + (directory-file-name arg)))) + (enable-local-eval nil)) + (save-excursion + (let ((find-file-hooks nil)) + (set-buffer (find-file-noselect generated-autoload-file))) + (goto-char (point-min)) + (while (search-forward generate-autoload-section-header nil t) + (let* ((begin (match-beginning 0)) + (form (autoload-read-section-header)) + (file (nth 3 form))) + (when (and (stringp file) + (string= (file-name-directory file) simple-dir) + (not (file-exists-p + (expand-file-name + (file-name-nondirectory file) arg)))) + ;; Remove the obsolete section. + (search-forward generate-autoload-section-trailer) + (delete-region begin (point))))) + ;; Update or create autoload sections for existing files. + (mapcar 'update-file-autoloads + (directory-files arg t "^[^=].*\\.\\(el\\|c\\)$"))))) ((file-exists-p arg) + (setq generated-autoload-file + (or into-file (expand-file-name autoload-file-name + (file-name-directory arg)))) (update-file-autoloads arg)) (t (error "No such file or directory: %s" arg))) - (when (not all-into-one-file) + (when (not into-file) (autoload-featurep-protect-autoloads (autoload-make-feature-name - (file-name-nondirectory (directory-file-name arg)))) + (or feature-prefix + (file-name-nondirectory (directory-file-name arg))))) (if force (set-buffer-modified-p t (find-file-noselect generated-autoload-file))))) - (when all-into-one-file + (when into-file (autoload-featurep-protect-autoloads autoload-feature-name) (if force (set-buffer-modified-p - t (find-file-noselect generated-autoload-file)))) + t (find-file-noselect into-file)))) (save-some-buffers t) )) ;;;###autoload -(defun update-autoloads-from-directory (dir) - "Update `generated-autoload-file' with all the current autoloads from DIR. -This runs `update-file-autoloads' on each .el and .c file in DIR. -Obsolete autoload entries for files that no longer exist are deleted. -Note that, if this function is called from `batch-update-directory', -`generated-autoload-file' was rebound in that function. - -You don't really want to be calling this function. Try using -`update-autoload-files' instead." - (interactive "DUpdate autoloads for directory: ") - (setq dir (expand-file-name dir)) - (let ((simple-dir (file-name-as-directory - (file-name-nondirectory - (directory-file-name dir)))) - (enable-local-eval nil)) - (save-excursion - (let ((find-file-hooks nil)) - (set-buffer (find-file-noselect generated-autoload-file))) - (goto-char (point-min)) - (while (search-forward generate-autoload-section-header nil t) - (let* ((begin (match-beginning 0)) - (form (condition-case () - (read (current-buffer)) - (end-of-file nil))) - (file (nth 3 form))) - (when (and (stringp file) - (string= (file-name-directory file) simple-dir) - (not (file-exists-p - (expand-file-name - (file-name-nondirectory file) dir)))) - ;; Remove the obsolete section. - (search-forward generate-autoload-section-trailer) - (delete-region begin (point))))) - ;; Update or create autoload sections for existing files. - (mapcar 'update-file-autoloads - (directory-files dir t "^[^=].*\\.\\(el\\|c\\)$")) - (unless noninteractive - (save-buffer))))) +(defun update-custom-define-files (files-or-dirs feature-prefix + &optional into-file force) + "Update all the custom-define files associated with FILES-OR-DIRS. +Works just like `update-file-autoloads'." + (let* ((autoload-feature-suffix "-custom-defines") + (autoload-file-name "custom-defines.el") + (generate-autoload-function #'generate-custom-defines)) + (update-autoload-files files-or-dirs feature-prefix into-file force))) (defun autoload-featurep-protect-autoloads (sym) (save-excursion (set-buffer (find-file-noselect generated-autoload-file)) (goto-char (point-min)) - (if (and (not (= (point-min) (point-max))) - (not (looking-at ";;; DO NOT MODIFY THIS FILE"))) - (progn - (insert ";;; DO NOT MODIFY THIS FILE\n") - (insert "(if (featurep '" sym ")") - (insert " (error \"Feature " sym " already loaded\"))\n") - (goto-char (point-max)) - (insert "\n(provide '" sym ")\n"))))) + (cond ((eq (point-min) (point-max)) nil) + ;; if there's some junk in the file but no sections, just + ;; delete everything. the junk might be stuff inserted by + ;; an older version of this function. + ((not (search-forward generate-autoload-section-header nil t)) + (delete-region (point-min) (point-max))) + (t + (goto-char (point-min)) + (when (looking-at ";;; DO NOT MODIFY THIS FILE") + (delete-region (point-min) + (progn + (search-forward generate-autoload-section-header) + (match-beginning 0)))) + ;; Determine and set the coding system for the file if under Mule. + ;; If there are any extended characters in the input file, use + ;; `escape-quoted' to make sure that both binary and extended + ;; characters are output properly and distinguished properly. + ;; Otherwise, use `raw-text' for maximum portability with non-Mule + ;; Emacsen. + (if (or (featurep '(not mule)) ;; Don't scan if no Mule support + (progn + (goto-char (point-min)) + ;; mrb- There must be a better way than skip-chars-forward + (skip-chars-forward (concat (char-to-string 0) "-" + (char-to-string 255))) + (eq (point) (point-max)))) + (setq buffer-file-coding-system 'raw-text-unix) + (setq buffer-file-coding-system 'escape-quoted)) + (goto-char (point-min)) + (insert ";;; DO NOT MODIFY THIS FILE") + ;; NOTE: XEmacs prior to 21.5.12 or so had a bug in that it + ;; recognized only one of the two magic-cookie styles (the -*- kind) + ;; in find-file, but both of them in load. We go ahead and put both + ;; in, just to be safe. + (when (eq buffer-file-coding-system 'escape-quoted) + (insert " -*- coding: escape-quoted; -*- +\(or (featurep 'mule) (error \"Loading this file requires Mule support\")) +;;;###coding system: escape-quoted")) + (insert "\n(if (featurep '" sym ")") + (insert " (error \"Feature " sym " already loaded\"))\n") + (goto-char (point-max)) + (save-excursion + (forward-line -1) + (when (looking-at "(provide") + (delete-region (point) (point-max)))) + (unless (bolp) (insert "\n")) + (unless (eq (char-before (1- (point))) ?\^L) + (insert "\^L\n")) + (insert "(provide '" sym ")\n"))))) (defun autoload-make-feature-name (&optional prefix) "Generate the feature name to protect this auto-autoloads file from PREFIX. @@ -864,19 +1123,23 @@ (file-name-directory generated-autoload-file)))) (t (error 'invalid-argument "Could not compute a feature name"))) - "-autoloads")) + autoload-feature-suffix)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Deprecated entry points ;; A grep of the core and packages shows use of `batch-update-autoloads' ;; by XEmacs.rules, pcomplete, eshell, oort-gnus; `batch-update-directory' -;; by liece. +;; by liece. The other two entry points (`batch-update-one-directory', +;; `batch-force-update-one-directory') were not used at all. +;; +;; All except the first are now history. liece has been updated. +;; XEmacs.rules has been updated. The others will be, eventually. -;; #### these entry points below are a big mess, especially the -;; first two. there don't seem to be very many packages that use the -;; first one (the "all-into-one-file" variety), and do they actually -;; rely on this functionality? --ben +;; There don't seem to be very many packages that use the first one (the +;; "all-into-one-file" variety), and do they actually rely on this +;; functionality? --ben + ;; but XEmacs.rules does, though maybe it doesn't "rely" on it, and ;; modules do now, and that relies on it. --sjt @@ -891,59 +1154,15 @@ on the command line." (unless noninteractive (error "batch-update-autoloads is to be used only with -batch")) - (update-autoload-files command-line-args-left t) + (update-autoload-files command-line-args-left generated-autoload-file) (kill-emacs 0)) -;;;###autoload -(defun batch-update-directory () - "Update the autoloads for the directories on the command line. -Runs `update-file-autoloads' on each file in the given directory, and must -be used only with -batch. - -Uses and removes the first element of `command-line-args-left'." - (unless noninteractive - (error "batch-update-directory is to be used only with -batch")) - (update-autoload-files command-line-args-left) - ;; (kill-emacs 0) - (setq command-line-args-left nil)) - -;;;###autoload -(defun batch-update-one-directory () - "Update the autoloads for a single directory on the command line. -Runs `update-file-autoloads' on each file in the given directory, and must -be used only with -batch." - (unless noninteractive - (error "batch-update-one-directory is to be used only with -batch")) - (let ((arg (car command-line-args-left))) - (setq command-line-args-left (cdr command-line-args-left)) - (update-autoload-files (list arg)))) - -;;;###autoload -(defun batch-force-update-one-directory () - "Update the autoloads for a single directory on the command line. -Runs `update-file-autoloads' on each file in the given directory, and must -be used only with -batch. Always rewrites the autoloads file, even if -unchanged. - -Uses and removes the first element of `command-line-args-left'." - (unless noninteractive - (error "batch-force-update-directory is to be used only with -batch")) - (let ((arg (car command-line-args-left))) - (setq command-line-args-left (cdr command-line-args-left)) - (update-autoload-files (list arg) nil t))) - ;; Declare obsolescence (make-obsolete-variable 'autoload-target-directory "Don't use this. Bind `generated-autoload-file' to an absolute path.") (make-obsolete 'batch-update-autoloads 'autoload-update-directory-autoloads) -(make-obsolete 'batch-update-directory - 'autoload-update-directory-autoloads) -(make-obsolete 'batch-update-one-directory - 'autoload-update-directory-autoloads) -(make-obsolete 'batch-force-update-one-directory - 'autoload-update-directory-autoloads) (provide 'autoload)
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/easy-mmode.el Thu Feb 03 07:11:28 2005 +0000 @@ -0,0 +1,601 @@ +;;; easy-mmode.el --- easy definition for major and minor modes + +;; Copyright (C) 1997, 2000, 2001 Free Software Foundation, Inc. + +;; Author: Georges Brun-Cottan <Georges.Brun-Cottan@inria.fr> +;; Maintainer: Stefan Monnier <monnier@gnu.org> + +;; Keywords: extensions lisp + +;; This file is part of XEmacs. + +;; XEmacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; XEmacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Synched up with: GNU Emacs 21.3. + +;;; Commentary: + +;; Minor modes are useful and common. This package makes defining a +;; minor mode easy, by focusing on the writing of the minor mode +;; functionalities themselves. Moreover, this package enforces a +;; conventional naming of user interface primitives, making things +;; natural for the minor-mode end-users. + +;; For each mode, easy-mmode defines the following: +;; <mode> : The minor mode predicate. A buffer-local variable. +;; <mode>-map : The keymap possibly associated to <mode>. +;; <mode>-hook,<mode>-on-hook,<mode>-off-hook and <mode>-mode: +;; see `define-minor-mode' documentation +;; +;; eval +;; (pp (macroexpand '(define-minor-mode <your-mode> <doc>))) +;; to check the result before using it. + +;; The order in which minor modes are installed is important. Keymap +;; lookup proceeds down minor-mode-map-alist, and the order there +;; tends to be the reverse of the order in which the modes were +;; installed. Perhaps there should be a feature to let you specify +;; orderings. + +;; Additionally to `define-minor-mode', the package provides convenient +;; ways to define keymaps, and other helper functions for major and minor +;; modes. + +;;; Code: + +(eval-when-compile (require 'cl)) + +;;; This file uses two functions that did not exist in some versions of +;;; XEmacs: propertize and replace-regexp-in-string. We provide these +;;; functions here for such XEmacsen. +;;; +;;; FIXME: These function definitions should go into the future or +;;; forward-compat package, once that package exists. + +;; XEmacs <= 21.4 does not have propertize, but XEmacs >= 21.5 dumps it (it is +;; defined in subr.el). Therefore, it is either defined regardless of what +;; has been loaded already, or it won't be defined regardless of what is +;; loaded. +(if (not (fboundp 'propertize)) + (defun propertize (string &rest properties) + "Return a copy of STRING with text properties added. +First argument is the string to copy. +Remaining arguments form a sequence of PROPERTY VALUE pairs for text +properties to add to the result." + (let ((str (copy-sequence string))) + (add-text-properties 0 (length str) + properties + str) + str))) + +;; XEmacs <= 21.4 does not have replace-regexp-in-string, but XEmacs >= 21.5 +;; dumps it (it is defined in subr.el). Therefore, it is either defined +;; regardless of what has been loaded already, or it won't be defined +;; regardless of what is loaded. +(if (not (fboundp 'replace-regexp-in-string)) + (defun replace-regexp-in-string (regexp rep string &optional + fixedcase literal subexp start) + "Replace all matches for REGEXP with REP in STRING. + +Return a new string containing the replacements. + +Optional arguments FIXEDCASE, LITERAL and SUBEXP are like the +arguments with the same names of function `replace-match'. If START +is non-nil, start replacements at that index in STRING. + +REP is either a string used as the NEWTEXT arg of `replace-match' or a +function. If it is a function it is applied to each match to generate +the replacement passed to `replace-match'; the match-data at this +point are such that match 0 is the function's argument. + +To replace only the first match (if any), make REGEXP match up to \\' +and replace a sub-expression, e.g. + (replace-regexp-in-string \"\\(foo\\).*\\'\" \"bar\" \" foo foo\" nil nil 1) + => \" bar foo\" +" + (let ((l (length string)) + (start (or start 0)) + matches str mb me) + (save-match-data + (while (and (< start l) (string-match regexp string start)) + (setq mb (match-beginning 0) + me (match-end 0)) + ;; If we matched the empty string, make sure we advance by one char + (when (= me mb) (setq me (min l (1+ mb)))) + ;; Generate a replacement for the matched substring. + ;; Operate only on the substring to minimize string consing. + ;; Set up match data for the substring for replacement; + ;; presumably this is likely to be faster than munging the + ;; match data directly in Lisp. + (string-match regexp (setq str (substring string mb me))) + (setq matches + (cons (replace-match (if (stringp rep) + rep + (funcall rep (match-string 0 str))) + fixedcase literal str subexp) + (cons (substring string start mb) ; unmatched prefix + matches))) + (setq start me)) + ;; Reconstruct a string from the pieces. + (setq matches (cons (substring string start l) matches)) ; leftover + (apply #'concat (nreverse matches)))))) + + +(defun easy-mmode-pretty-mode-name (mode &optional lighter) + "Turn the symbol MODE into a string intended for the user. +If provided LIGHTER will be used to help choose capitalization." + (let* ((case-fold-search t) + (name (concat (replace-regexp-in-string + "-Minor" " minor" + (capitalize (replace-regexp-in-string + "-mode\\'" "" (symbol-name mode)))) + " mode"))) + (if (not (stringp lighter)) name + (setq lighter + (replace-regexp-in-string "\\`\\s-+\\|\\-s+\\'" "" lighter)) + (replace-regexp-in-string lighter lighter name t t)))) + +;; XEmacs change: add -on-hook, -off-hook, and macro parameter documentation. +;;;###no-autoload +(defalias 'easy-mmode-define-minor-mode 'define-minor-mode) +;;;###no-autoload +(defmacro define-minor-mode (mode doc &optional init-value lighter keymap &rest body) + "Define a new minor mode MODE. +This function defines the associated control variable MODE, keymap MODE-map, +toggle command MODE, and hook MODE-hook. + +DOC is the documentation for the mode toggle command. +Optional INIT-VALUE is the initial value of the mode's variable. +Optional LIGHTER is displayed in the modeline when the mode is on. +Optional KEYMAP is the default (defvar) keymap bound to the mode keymap. + If it is a list, it is passed to `easy-mmode-define-keymap' + in order to build a valid keymap. It's generally better to use + a separate MODE-map variable than to use this argument. +The above three arguments can be skipped if keyword arguments are +used (see below). + +BODY contains code that will be executed each time the mode is (de)activated. + It will be executed after any toggling but before running the hooks. + Before the actual body code, you can write + keyword arguments (alternating keywords and values). + These following keyword arguments are supported: +:group GROUP Custom group name to use in all generated `defcustom' forms. +:global GLOBAL If non-nil specifies that the minor mode is not meant to be + buffer-local, so don't make the variable MODE buffer-local. + By default, the mode is buffer-local. +:init-value VAL Same as the INIT-VALUE argument. +:lighter SPEC Same as the LIGHTER argument. +:require SYM Same as in `defcustom'. + +For backwards compatibility, these hooks are run each time the mode is +\(de)activated. When the mode is toggled, MODE-hook is always run before the +other hook. +MODE-hook: run if the mode is toggled. +MODE-on-hook: run if the mode is activated. +MODE-off-hook: run if the mode is deactivated. + +\(defmacro easy-mmode-define-minor-mode + (MODE DOC &optional INIT-VALUE LIGHTER KEYMAP &rest BODY)...\) + +For example, you could write + (define-minor-mode foo-mode \"If enabled, foo on you!\" + nil \"Foo \" foo-keymap + :require 'foo :global t :group 'inconvenience + ...BODY CODE...)" + + ;; Allow skipping the first three args. + (cond + ((keywordp init-value) + (setq body (list* init-value lighter keymap body) + init-value nil lighter nil keymap nil)) + ((keywordp lighter) + (setq body (list* lighter keymap body) lighter nil keymap nil)) + ((keywordp keymap) (push keymap body) (setq keymap nil))) + + (let* ((mode-name (symbol-name mode)) + (pretty-name (easy-mmode-pretty-mode-name mode lighter)) + (globalp nil) + (group nil) + (extra-args nil) + (require t) + (keymap-sym (if (and keymap (symbolp keymap)) keymap + (intern (concat mode-name "-map")))) + (hook (intern (concat mode-name "-hook"))) + (hook-on (intern (concat mode-name "-on-hook"))) + (hook-off (intern (concat mode-name "-off-hook")))) + + ;; Check keys. + (while (keywordp (car body)) + (case (pop body) + (:init-value (setq init-value (pop body))) + (:lighter (setq lighter (pop body))) + (:global (setq globalp (pop body))) + (:extra-args (setq extra-args (pop body))) + (:group (setq group (nconc group (list :group (pop body))))) + (:require (setq require (pop body))) + (t (pop body)))) + + (unless group + ;; We might as well provide a best-guess default group. + (setq group + `(:group ',(or (custom-current-group) + (intern (replace-regexp-in-string + "-mode\\'" "" mode-name)))))) + ;; Add default properties to LIGHTER. +;; #### FSF comments this out in 21.3. +; (unless (or (not (stringp lighter)) +; (get-text-property 0 'local-map lighter) +; (get-text-property 0 'keymap lighter)) +; (setq lighter +; (propertize lighter +; 'local-map modeline-minor-mode-map ; XEmacs change +; 'help-echo "mouse-3: minor mode menu"))) + + `(progn + ;; Define the variable to enable or disable the mode. + ,(if (not globalp) + `(progn + (defvar ,mode ,init-value ,(format "Non-nil if %s is enabled. +Use the command `%s' to change this variable." pretty-name mode)) + (make-variable-buffer-local ',mode)) + + (let ((curfile (or (and (boundp 'byte-compile-current-file) + byte-compile-current-file) + load-file-name))) + `(defcustom ,mode ,init-value + ,(format "Non-nil if %s is enabled. +See the command `%s' for a description of this minor-mode. +Setting this variable directly does not take effect; +use either \\[customize] or the function `%s'." + pretty-name mode mode) + :set (lambda (symbol value) (funcall symbol (or value 0))) + :initialize 'custom-initialize-default + ,@group + :type 'boolean + ,@(cond + ((not (and curfile require)) nil) + ((not (eq require t)) `(:require ,require)) + (t `(:require + ',(intern (file-name-nondirectory + (file-name-sans-extension curfile))))))))) + + ;; The actual function. + (defun ,mode (&optional arg ,@extra-args) + ,(or doc + (format (concat "Toggle %s on or off. +Interactively, with no prefix argument, toggle the mode. +With universal prefix ARG turn mode on. +With zero or negative ARG turn mode off. +\\{%s}") pretty-name keymap-sym)) + ;; Use `toggle' rather than (if ,mode 0 1) so that using + ;; repeat-command still does the toggling correctly. + (interactive (list (or current-prefix-arg 'toggle))) + ;; XEmacs addition: save the old mode + (let ((old-mode ,mode)) + (setq ,mode + (cond + ((eq arg 'toggle) (not ,mode)) + (arg (or (listp arg);; XEmacs addition: C-u alone + (> (prefix-numeric-value arg) 0))) + (t + (if (null ,mode) t + (message + "Toggling %s off; better pass an explicit argument." + ',mode) + nil)))) + ,@body + ;; The on/off hooks are here for backward compatibility only. + ;; The on/off hooks are here for backward compatibility only. + ;; XEmacs change: check mode before running hooks + (and ,hook + (not (equal old-mode ,mode)) + (run-hooks ',hook)) + (and ,hook-on + ,mode + (run-hooks ',hook-on)) + (and ,hook-off + (not ,mode) + (run-hooks ',hook-off))) + (if (interactive-p) + (progn + ,(if globalp `(customize-mark-as-set ',mode)) + (message ,(format "%s %%sabled" pretty-name) + (if ,mode "en" "dis")))) + (force-mode-line-update) + ;; Return the new setting. + ,mode) + + ;; Autoloading an easy-mmode-define-minor-mode autoloads + ;; everything up-to-here. + ;; + ;; XEmacs change: XEmacs does not support :autoload-end. On the other + ;; hand, I don't see why we need to support it. An autoload cookie + ;; just before a (define-minor-mode foo) form will generate an autoload + ;; form for the file with name foo. But that's exactly right, since + ;; the defun created just above here has the name foo. There are no + ;; other top-level forms created above here by the macro, so we're done. + ;; + ;;:autoload-end + + ;; The toggle's hook. + (defcustom ,hook nil + ,(format "Hook run at the end of function `%s'." mode-name) + ,@group + :type 'hook) + + ;; XEmacs addition: declare the on and off hooks also + (defcustom ,hook-on nil + ,(format "Hook to run when entering %s." mode-name) + :group ,(cadr group) + :type 'hook) + + (defcustom ,hook-off nil + ,(format "Hook to run when exiting %s." mode-name) + :group ,(cadr group) + :type 'hook) + + ;; Define the minor-mode keymap. + ,(unless (symbolp keymap) ;nil is also a symbol. + `(defvar ,keymap-sym + (let ((m ,keymap)) + (cond ((keymapp m) m) + ((listp m) (easy-mmode-define-keymap m)) + (t (error "Invalid keymap %S" ,keymap)))) + ,(format "Keymap for `%s'." mode-name))) + + (add-minor-mode ',mode ',lighter + ,(if keymap keymap-sym + `(if (boundp ',keymap-sym) + (symbol-value ',keymap-sym))) + ;; XEmacs change: supply the AFTER and TOGGLE-FUN args + t ',mode) + + ;; If the mode is global, call the function according to the default. + ,(if globalp + `(if (and load-file-name (not (equal ,init-value ,mode)) + ;; XEmacs addition: + (not purify-flag)) + (eval-after-load load-file-name '(,mode (if ,mode 1 -1)))))))) + +;;; +;;; make global minor mode +;;; + +;;;###no-autoload +(defmacro easy-mmode-define-global-mode (global-mode mode turn-on + &rest keys) + "Make GLOBAL-MODE out of the buffer-local minor MODE. +TURN-ON is a function that will be called with no args in every buffer + and that should try to turn MODE on if applicable for that buffer. +KEYS is a list of CL-style keyword arguments: +:group to specify the custom group." + (let* ((global-mode-name (symbol-name global-mode)) + (pretty-name (easy-mmode-pretty-mode-name mode)) + (pretty-global-name (easy-mmode-pretty-mode-name global-mode)) + (group nil) + (extra-args nil) + (buffers (intern (concat global-mode-name "-buffers"))) + (cmmh (intern (concat global-mode-name "-cmmh")))) + + ;; Check keys. + (while (keywordp (car keys)) + (case (pop keys) + (:extra-args (setq extra-args (pop keys))) + (:group (setq group (nconc group (list :group (pop keys))))) + (t (setq keys (cdr keys))))) + + (unless group + ;; We might as well provide a best-guess default group. + (setq group + `(:group ',(or (custom-current-group) + (intern (replace-regexp-in-string + "-mode\\'" "" (symbol-name mode))))))) + + `(progn + ;; The actual global minor-mode + (define-minor-mode ,global-mode + ,(format "Toggle %s in every buffer. +With prefix ARG, turn %s on if and only if ARG is positive. +%s is actually not turned on in every buffer but only in those +in which `%s' turns it on." + pretty-name pretty-global-name pretty-name turn-on) + :global t :extra-args ,extra-args ,@group + + ;; Setup hook to handle future mode changes and new buffers. + (if ,global-mode + ;; XEmacs: find-file-hooks not find-file-hook + (progn + (add-hook 'find-file-hooks ',buffers) + (add-hook 'change-major-mode-hook ',cmmh)) + (remove-hook 'find-file-hooks ',buffers) + (remove-hook 'change-major-mode-hook ',cmmh)) + + ;; Go through existing buffers. + (dolist (buf (buffer-list)) + (with-current-buffer buf + (if ,global-mode (,turn-on) (when ,mode (,mode -1)))))) + + ;; TODO: XEmacs does not support :autoload-end + ;; Autoloading easy-mmode-define-global-mode + ;; autoloads everything up-to-here. + :autoload-end + + ;; List of buffers left to process. + (defvar ,buffers nil) + + ;; The function that calls TURN-ON in each buffer. + (defun ,buffers () + (remove-hook 'post-command-hook ',buffers) + (while ,buffers + (let ((buf (pop ,buffers))) + (when (buffer-live-p buf) + (with-current-buffer buf (,turn-on)))))) + (put ',buffers 'definition-name ',global-mode) + + ;; The function that catches kill-all-local-variables. + (defun ,cmmh () + (add-to-list ',buffers (current-buffer)) + (add-hook 'post-command-hook ',buffers)) + (put ',cmmh 'definition-name ',global-mode)))) + +;;; +;;; easy-mmode-defmap +;;; + +(if (fboundp 'set-keymap-parents) + (defalias 'easy-mmode-set-keymap-parents 'set-keymap-parents) + (defun easy-mmode-set-keymap-parents (m parents) + (set-keymap-parent + m + (cond + ((not (consp parents)) parents) + ((not (cdr parents)) (car parents)) + (t (let ((m (copy-keymap (pop parents)))) + (easy-mmode-set-keymap-parents m parents) + m)))))) + +;;;###no-autoload +(defun easy-mmode-define-keymap (bs &optional name m args) + "Return a keymap built from bindings BS. +BS must be a list of (KEY . BINDING) where +KEY and BINDINGS are suitable for `define-key'. +Optional NAME is passed to `make-sparse-keymap'. +Optional map M can be used to modify an existing map. +ARGS is a list of additional keyword arguments." + (let (inherit dense ;suppress + ) + (while args + (let ((key (pop args)) + (val (pop args))) + (case key + (:name (setq name val)) + (:dense (setq dense val)) + (:inherit (setq inherit val)) + (:group) + ;;((eq key :suppress) (setq suppress val)) + (t (message "Unknown argument %s in defmap" key))))) + (unless (keymapp m) + (setq bs (append m bs)) + (setq m (if dense (make-keymap name) (make-sparse-keymap name)))) + (dolist (b bs) + (let ((keys (car b)) + (binding (cdr b))) + (dolist (key (if (consp keys) keys (list keys))) + (cond + ((symbolp key) + (substitute-key-definition key binding m global-map)) + ((null binding) + (unless (keymapp (lookup-key m key)) (define-key m key binding))) + ((let ((o (lookup-key m key))) + (or (null o) (numberp o) (eq o 'undefined))) + (define-key m key binding)))))) + (cond + ((keymapp inherit) (set-keymap-parent m inherit)) + ((consp inherit) (easy-mmode-set-keymap-parents m inherit))) + m)) + +;;;###no-autoload +(defmacro easy-mmode-defmap (m bs doc &rest args) + `(defconst ,m + (easy-mmode-define-keymap ,bs nil (if (boundp ',m) ,m) ,(cons 'list args)) + ,doc)) + + +;;; +;;; easy-mmode-defsyntax +;;; + +(defun easy-mmode-define-syntax (css args) + (let ((st (make-syntax-table (plist-get args :copy))) + (parent (plist-get args :inherit))) + (dolist (cs css) + (let ((char (car cs)) + (syntax (cdr cs))) + (if (sequencep char) + (mapcar (lambda (c) (modify-syntax-entry c syntax st)) char) + (modify-syntax-entry char syntax st)))) + ;; XEmacs change: we do not have set-char-table-parent + (if parent (derived-mode-merge-syntax-tables + (if (symbolp parent) (symbol-value parent) parent) st)) + st)) + +;;;###no-autoload +(defmacro easy-mmode-defsyntax (st css doc &rest args) + "Define variable ST as a syntax-table. +CSS contains a list of syntax specifications of the form (CHAR . SYNTAX)." + `(progn + (autoload 'easy-mmode-define-syntax "easy-mmode") + (defconst ,st (easy-mmode-define-syntax ,css ,(cons 'list args)) ,doc))) + + + +;;; +;;; easy-mmode-define-navigation +;;; + +;; XEmacs change: autoload +;;;###no-autoload +(defmacro easy-mmode-define-navigation (base re &optional name endfun) + "Define BASE-next and BASE-prev to navigate in the buffer. +RE determines the places the commands should move point to. +NAME should describe the entities matched by RE. It is used to build + the docstrings of the two functions. +BASE-next also tries to make sure that the whole entry is visible by + searching for its end (by calling ENDFUN if provided or by looking for + the next entry) and recentering if necessary. +ENDFUN should return the end position (with or without moving point)." + (let* ((base-name (symbol-name base)) + (prev-sym (intern (concat base-name "-prev"))) + (next-sym (intern (concat base-name "-next")))) + (unless name (setq name (symbol-name base-name))) + `(progn + (add-to-list 'debug-ignored-errors + ,(concat "^No \\(previous\\|next\\) " (regexp-quote name))) + (defun ,next-sym (&optional count) + ,(format "Go to the next COUNT'th %s." name) + (interactive) + (unless count (setq count 1)) + (if (< count 0) (,prev-sym (- count)) + (if (looking-at ,re) (incf count)) + (if (not (re-search-forward ,re nil t count)) + (if (looking-at ,re) + (goto-char (or ,(if endfun `(,endfun)) (point-max))) + (error ,(format "No next %s" name))) + (goto-char (match-beginning 0)) + (when (and (eq (current-buffer) (window-buffer (selected-window))) + (interactive-p)) + (let ((endpt (or (save-excursion + ,(if endfun `(,endfun) + `(re-search-forward ,re nil t 2))) + (point-max)))) + ;; XEmacs change: versions < 21.5.16 have a + ;; pos-visible-in-window-p that takes only 2 parameters + (unless + (if (eq (function-max-args #'pos-visible-in-window-p) 2) + (pos-visible-in-window-p endpt nil) + (pos-visible-in-window-p endpt nil t)) + (recenter '(0)))))))) + (defun ,prev-sym (&optional count) + ,(format "Go to the previous COUNT'th %s" (or name base-name)) + (interactive) + (unless count (setq count 1)) + (if (< count 0) (,next-sym (- count)) + (unless (re-search-backward ,re nil t count) + (error ,(format "No previous %s" name)))))))) + +(provide 'easy-mmode) + +;;; easy-mmode.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/regexp-opt.el Thu Feb 03 07:11:28 2005 +0000 @@ -0,0 +1,278 @@ +;;; regexp-opt.el --- generate efficient regexps to match strings + +;; Copyright (C) 1994,95,96,97,98,99,2000 Free Software Foundation, Inc. + +;; Author: Simon Marshall <simon@gnu.org> +;; Maintainer: FSF +;; Keywords: strings, regexps, extensions + +;; Modified by Karl M. Hegbloom Sep. 1997 to support the new regexp syntax +;; with shy groups. (benchmarks pending) + +;; This file is part of XEmacs. + +;; XEmacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; XEmacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;; The "opt" in "regexp-opt" stands for "optim\\(al\\|i\\(se\\|ze\\)\\)". +;; +;; This package generates a regexp from a given list of strings (which matches +;; one of those strings) so that the regexp generated by: +;; +;; (regexp-opt strings) +;; +;; is equivalent to, but more efficient than, the regexp generated by: +;; +;; (mapconcat 'regexp-quote strings "\\|") +;; +;; For example: +;; +;; (let ((strings '("cond" "if" "when" "unless" "while" +;; "let" "let*" "progn" "prog1" "prog2" +;; "save-restriction" "save-excursion" "save-window-excursion" +;; "save-current-buffer" "save-match-data" +;; "catch" "throw" "unwind-protect" "condition-case"))) +;; (concat "(" (regexp-opt strings t) "\\>")) +;; +;; => "(\\(?:c\\(?:atch\\|ond\\(?:ition-case\\)?\\)\\|if\\|let\\*?\\|prog[12n]\\|save-\\(?:current-buffer\\|excursion\\|match-data\\|restriction\\|window-excursion\\)\\|throw\\|un\\(?:less\\|wind-protect\\)\\|wh\\(?:en\\|ile\\)\\)\\>" +;; +;; +;; (let ((strings '("cond" "if" "when" "unless" "while" +;; "let" "let*" "progn" "prog1" "prog2" +;; "save-restriction" "save-excursion" "save-window-excursion" +;; "save-current-buffer" "save-match-data" +;; "catch" "throw" "unwind-protect" "condition-case"))) +;; (concat "(" (regexp-opt strings t t) "\\>")) +;; ^ +;; => "(\\(c\\(atch\\|ond\\(ition-case\\)?\\)\\|if\\|let\\*?\\|prog[12n]\\|save-\\(current-buffer\\|excursion\\|match-data\\|restriction\\|window-excursion\\)\\|throw\\|un\\(less\\|wind-protect\\)\\|wh\\(en\\|ile\\)\\)\\>" +;; +;; +;; Searching using the above example `regexp-opt' regexp takes approximately +;; two-thirds of the time taken using the equivalent `mapconcat' regexp. + +;; Since this package was written to produce efficient regexps, not regexps +;; efficiently, it is probably not a good idea to in-line too many calls in +;; your code, unless you use the following trick with `eval-when-compile': +;; +;; (defvar definition-regexp +;; (eval-when-compile +;; (concat "^(" +;; (regexp-opt '("defun" "defsubst" "defmacro" "defalias" +;; "defvar" "defconst") t) +;; "\\>"))) +;; +;; The `byte-compile' code will be as if you had defined the variable thus: +;; +;; (defvar definition-regexp +;; "^(\\(def\\(alias\\|const\\|macro\\|subst\\|un\\|var\\)\\)\\>") +;; +;; Note that if you use this trick for all instances of `regexp-opt' and +;; `regexp-opt-depth' in your code, regexp-opt.el would only have to be loaded +;; at compile time. But note also that using this trick means that should +;; regexp-opt.el be changed, perhaps to fix a bug or to add a feature to +;; improve the efficiency of `regexp-opt' regexps, you would have to recompile +;; your code for such changes to have effect in your code. + +;; Originally written for font-lock.el, from an idea from Stig's hl319.el, with +;; thanks for ideas also to Michael Ernst, Bob Glickstein and Dan Nicolaescu. +;; Please don't tell me that it doesn't produce optimal regexps; I know that +;; already. For example, the above explanation for the meaning of "opt" would +;; be more efficient as "optim\\(al\\|i[sz]e\\)", but this requires complex +;; forward looking. But (ideas or) code to improve things (are) is welcome. + +;;; Code: + +;;;###autoload +(defun regexp-opt (strings &optional paren non-shy) + "Return a regexp to match a string in STRINGS. +Each string should be unique in STRINGS and should not contain any regexps, +quoted or not. If optional PAREN is non-nil, ensure that the returned regexp +is enclosed by at least one regexp match grouping construct. If optional +NON-SHY is non nil, the inner groupings will use \"\\\\( \\\\)\" grouping, +rather than the default \"\\\\(?: \\\\)\" 'shy', or non-match-capturing groups. +The returned regexp is typically more efficient than the equivalent regexp: + + (let ((open-paren (if PAREN \"\\\\(\" \"\")) (close-paren (if PAREN \"\\\\)\" \"\"))) + (concat open-paren (mapconcat 'regexp-quote STRINGS \"\\\\|\") close-paren)) + +but typically contains more regexp grouping constructs. +Use `regexp-opt-depth' to count them. + +If PAREN is `words', then the resulting regexp is additionally surrounded +by \\=\\< and \\>." + (save-match-data + ;; Recurse on the sorted list. + (let* ((max-lisp-eval-depth (* 1024 1024)) + (completion-ignore-case nil) + (words (eq paren 'words)) + (sorted-strings (sort (copy-sequence strings) 'string-lessp)) + (re (regexp-opt-group sorted-strings paren nil non-shy))) + (if words (concat "\\<" re "\\>") re)))) + +;;;###autoload +(defun regexp-opt-depth (regexp &optional count-shy-groups-too) + "Return the depth of REGEXP. +This means the number of regexp grouping constructs (parenthesised +expressions) in REGEXP, not counting the \"\\\\(?: \\\\)\" +non-match-capturing groups unless COUNT-SHY-GROUPS-TOO is non-nil. +See `regexp-opt'." + (save-match-data + ;; Hack to signal an error if REGEXP does not have balanced parentheses. + (string-match regexp "") + ;; Count the number of open parentheses in REGEXP. + (let ((max (1- (length regexp))) + (count 0) start) + (while (string-match "\\\\(" regexp start) + (setq start (match-end 0)) + (when (or count-shy-groups-too + (not (string= (substring regexp start (min (+ start 2) max)) "?:"))) + (setq count (1+ count)))) + count))) + +;;; Workhorse functions. + +(eval-when-compile + (require 'cl)) + +(unless (fboundp 'make-bool-vector) + (defalias 'make-bool-vector 'make-vector)) + +(defun regexp-opt-group (strings &optional paren lax non-shy) + "Return a regexp to match a string in STRINGS. +If PAREN non-nil, output regexp parentheses around returned regexp. +If LAX non-nil, don't output parentheses if it doesn't require them. +If NON-SHY non-nil, don't use \\(?: \\) shy groups, use match capturing ones. +Merges keywords to avoid backtracking in Emacs' regexp matcher. + +The basic idea is to find the shortest common prefix, remove it +and recurse. If there is no prefix, we divide the list into two so that +\(at least) one half will have at least a one-character common prefix. + +Also we delay the addition of grouping parenthesis as long as possible +until we're sure we need them, and try to remove one-character sequences +so we can use character sets rather than grouping parenthesis." + (let* ((open-group (cond + ((and paren non-shy) "\\(") + (paren "\\(?:") + (t ""))) + (close-group (if paren "\\)" "")) + (open-charset (if lax "" open-group)) + (close-charset (if lax "" close-group))) + (cond + ;; + ;; If there are no strings, just return the empty string. + ((= (length strings) 0) + "") + ;; + ;; If there is only one string, just return it. + ((= (length strings) 1) + (if (= (length (car strings)) 1) + (concat open-charset (regexp-quote (car strings)) close-charset) + (concat open-group (regexp-quote (car strings)) close-group))) + ;; + ;; If there is an empty string, remove it and recurse on the rest. + ((= (length (car strings)) 0) + (concat open-charset + (regexp-opt-group (cdr strings) t t non-shy) "?" + close-charset)) + ;; + ;; If all are one-character strings, just return a character set. + ((= (length strings) (apply '+ (mapcar 'length strings))) + (concat open-charset + (regexp-opt-charset strings) + close-charset)) + ;; + ;; We have a list of different length strings. + (t + (let ((prefix (try-completion "" (mapcar 'list strings))) + (letters (let ((completion-regexp-list '("^.$"))) + (all-completions "" (mapcar 'list strings))))) + (cond + ;; + ;; If there is a common prefix, remove it and recurse on the suffixes. + ((> (length prefix) 0) + (let* ((length (length prefix)) + (suffixes (mapcar (lambda (s) (substring s length)) strings))) + (concat open-group + (regexp-quote prefix) (regexp-opt-group suffixes t t non-shy) + close-group))) + ;; + ;; If there are several one-character strings, remove them and recurse + ;; on the rest (first so the final regexp finds the longest match). + ((> (length letters) 1) + (let ((rest (let ((completion-regexp-list '("^..+$"))) + (all-completions "" (mapcar 'list strings))))) + (concat open-group + (regexp-opt-group rest nil nil non-shy) "\\|" (regexp-opt-charset letters) + close-group))) + ;; + ;; Otherwise, divide the list into those that start with a particular + ;; letter and those that do not, and recurse on them. + (t + (let* ((char (substring (car strings) 0 1)) + (half1 (all-completions char (mapcar 'list strings))) + (half2 (nthcdr (length half1) strings))) + (concat open-group + (regexp-opt-group half1 nil nil non-shy) "\\|" (regexp-opt-group half2 nil nil non-shy) + close-group))))))))) + +(defun regexp-opt-charset (chars) + ;; + ;; Return a regexp to match a character in CHARS. + ;; + ;; The basic idea is to find character ranges. Also we take care in the + ;; position of character set meta characters in the character set regexp. + ;; + (let* ((charwidth 256) ; Yeah, right. + ;; XEmacs: use bit-vectors instead of bool-vectors + (charmap (make-bit-vector charwidth 0)) + (charset "") + (bracket "") (dash "") (caret "")) + ;; + ;; Make a character map but extract character set meta characters. + (dolist (char (mapcar 'string-to-char chars)) + (case char + (?\] + (setq bracket "]")) + (?^ + (setq caret "^")) + (?- + (setq dash "-")) + (otherwise + ;; XEmacs: 1 + (aset charmap char 1)))) + ;; + ;; Make a character set from the map using ranges where applicable. + (dotimes (char charwidth) + (let ((start char)) + (while (and (< char charwidth) + ;; XEmacs: (not (zerop ...)) + (not (zerop (aref charmap char)))) + (incf char)) + (cond ((> char (+ start 3)) + (setq charset (format "%s%c-%c" charset start (1- char)))) + ((> char start) + (setq charset (format "%s%c" charset (setq char start))))))) + ;; + ;; Make sure a caret is not first and a dash is first or last. + (if (and (string-equal charset "") (string-equal bracket "")) + (concat "[" dash caret "]") + (concat "[" bracket charset caret dash "]")))) + +(provide 'regexp-opt) + +;;; regexp-opt.el ends here
--- a/lisp/update-elc-2.el Thu Feb 03 06:14:40 2005 +0000 +++ b/lisp/update-elc-2.el Thu Feb 03 07:11:28 2005 +0000 @@ -149,32 +149,25 @@ ;; way is slow, so we avoid it when possible. (when (file-exists-p (expand-file-name "REBUILD_AUTOLOADS" invocation-directory)) - (let ((generated-autoload-file (expand-file-name "auto-autoloads.el" dir)) - (autoload-package-name "auto")) ; feature prefix - ;; if we were instructed to rebuild the autoloads, force the file - ;; to be touched even w/o changes; otherwise, we won't ever stop - ;; being told to rebuild them. - (update-autoload-files (list dir) nil t) - (byte-recompile-file generated-autoload-file 0)) + ;; if we were instructed to rebuild the autoloads, force the file + ;; to be touched even w/o changes; otherwise, we won't ever stop + ;; being told to rebuild them. + (update-autoload-files dir "auto" nil t) + (byte-recompile-file (expand-file-name "auto-autoloads.el" dir) 0) (when (featurep 'mule) - (let* ((muledir (expand-file-name "../lisp/mule" (file-truename dir))) - (generated-autoload-file - (expand-file-name "auto-autoloads.el" muledir)) - (autoload-package-name "mule")) ; feature prefix + (let ((muledir (expand-file-name "../lisp/mule" (file-truename dir)))) ;; force here just like above. - (update-autoload-files (list muledir) nil t) - (byte-recompile-file generated-autoload-file 0)))) + (update-autoload-files muledir "mule" nil t) + (byte-recompile-file (expand-file-name "auto-autoloads.el" dir) 0)))) (when (featurep 'modules) (let* ((moddir (expand-file-name "../modules" (file-truename dir))) - (generated-autoload-file - (expand-file-name "auto-autoloads.el" moddir)) - (autoload-package-name "modules")) ; feature prefix - (update-autoload-files + (autofile (expand-file-name "auto-autoloads.el" moddir))) + (update-autoload-files (delete (concat (file-name-as-directory moddir) ".") (delete (concat (file-name-as-directory moddir) "..") (directory-files moddir t nil nil 0))) - t) - (byte-recompile-file generated-autoload-file 0))) + "modules" autofile) + (byte-recompile-file autofile 0))) ;; now load the (perhaps newly rebuilt) autoloads; we were called with ;; -no-autoloads so they're not already loaded. (load (expand-file-name "auto-autoloads" lisp-directory))
--- a/lisp/update-elc.el Thu Feb 03 06:14:40 2005 +0000 +++ b/lisp/update-elc.el Thu Feb 03 07:11:28 2005 +0000 @@ -106,7 +106,7 @@ ;; early byte compilation. These are files loaded by update-elc.el in ;; order to do the compilation of all the rest of the files. (defvar lisp-files-needing-early-byte-compilation - '(;"easy-mmode" + '("easy-mmode" "autoload" "shadow" "cl-macs")) @@ -312,10 +312,10 @@ need-to-rebuild-mule-autoloads) (list "-l" "autoload")) (if need-to-rebuild-autoloads - (list "-f" "autoload-update-directory-autoloads" + (list "-f" "batch-update-directory-autoloads" "auto" source-lisp)) (if need-to-rebuild-mule-autoloads - (list "-f" "autoload-update-directory-autoloads" + (list "-f" "batch-update-directory-autoloads" "mule" source-lisp-mule)) (if need-to-recompile-autoloads (list "-f" "batch-byte-compile-one-file"
--- a/src/ChangeLog Thu Feb 03 06:14:40 2005 +0000 +++ b/src/ChangeLog Thu Feb 03 07:11:28 2005 +0000 @@ -1,3 +1,19 @@ +2005-02-02 Ben Wing <ben@xemacs.org> + + * lread.c: + * lread.c (check_if_suppressed): + * lread.c (Fload_internal): + * lread.c (locate_file_in_directory_mapper): + * lread.c (readevalloop): + * lread.c (syms_of_lread): + * lread.c (vars_of_lread): + * lisp.h: + Remove undeeded Vload_file_name_internal_the_purecopy, + Qload_file_name -- use internal_bind_lisp_object instead of + specbind. + + Add load-suppress-alist. + 2005-02-02 Ben Wing <ben@xemacs.org> * menubar.c: @@ -11,38 +27,6 @@ (This will be done in compare-menu-text.) Document that return value may be same string. -2005-02-02 Ben Wing <ben@xemacs.org> - - * lread.c: - * lread.c (check_if_suppressed): - * lread.c (Fload_internal): - * lread.c (locate_file_in_directory_mapper): - * lread.c (readevalloop): - * lread.c (syms_of_lread): - * lread.c (vars_of_lread): - * menubar.c: - * menubar.c (Fcompare_menu_text): - * menubar.c (Fnormalize_menu_text): - * menubar.c (syms_of_menubar): - * menubar.c (vars_of_menubar): - -2004-11-09 Ben Wing <ben@xemacs.org> - - * lisp.h: - - * lread.c: - * lread.c (check_if_suppressed): - * lread.c (Fload_internal): - * lread.c (locate_file_in_directory_mapper): - * lread.c (readevalloop): - * lread.c (syms_of_lread): - * lread.c (vars_of_lread): - Remove undeeded Vload_file_name_internal_the_purecopy, - Qload_file_name -- use internal_bind_lisp_object instead of - specbind. - - Add load-suppress-alist. - 2003-02-15 Ben Wing <ben@xemacs.org> * syswindows.h: Define W32API_2_2 for w32api.h v2.2 or higher.
--- a/src/lisp.h Thu Feb 03 06:14:40 2005 +0000 +++ b/src/lisp.h Thu Feb 03 07:11:28 2005 +0000 @@ -5294,8 +5294,7 @@ extern Lisp_Object Vinvocation_directory, Vinvocation_name; extern Lisp_Object Vlast_command, Vlast_command_char; extern Lisp_Object Vlast_command_event, Vlast_input_event; -extern Lisp_Object Vload_file_name_internal; -extern Lisp_Object Vload_file_name_internal_the_purecopy, Vload_history; +extern Lisp_Object Vload_file_name_internal, Vload_history; extern Lisp_Object Vload_path, Vmark_even_if_inactive, Vmenubar_configuration; extern Lisp_Object Vminibuf_preprompt, Vminibuf_prompt, Vminibuffer_zero; extern Lisp_Object Vmodule_directory, Vmswindows_downcase_file_names;
--- a/src/lread.c Thu Feb 03 06:14:40 2005 +0000 +++ b/src/lread.c Thu Feb 03 07:11:28 2005 +0000 @@ -59,8 +59,8 @@ #endif Lisp_Object Qvariable_domain; /* I18N3 */ Lisp_Object Vvalues, Vstandard_input, Vafter_load_alist; -Lisp_Object Qcurrent_load_list; -Lisp_Object Qload, Qload_file_name, Qload_internal, Qfset; +Lisp_Object Vload_suppress_alist; +Lisp_Object Qload, Qload_internal, Qfset; /* Hash-table that maps directory names to hashes of their contents. */ static Lisp_Object Vlocate_file_hash_table; @@ -118,8 +118,6 @@ our #$ checks are reliable. */ Lisp_Object Vload_file_name_internal; -Lisp_Object Vload_file_name_internal_the_purecopy; - /* Function to use for reading, in `load' and friends. */ Lisp_Object Vload_read_function; @@ -340,6 +338,50 @@ return Qnil; } +/* Check if NONRELOC/RELOC (an absolute filename) is suppressed according + to load-suppress-alist. */ +static int +check_if_suppressed (Ibyte *nonreloc, Lisp_Object reloc) +{ + Bytecount len; + + if (!NILP (reloc)) + { + nonreloc = XSTRING_DATA (reloc); + len = XSTRING_LENGTH (reloc); + } + else + len = qxestrlen (nonreloc); + + if (len >= 4 && !qxestrcmp_ascii (nonreloc + len - 4, ".elc")) + len -= 4; + else if (len >= 3 && !qxestrcmp_ascii (nonreloc + len - 3, ".el")) + len -= 3; + + EXTERNAL_LIST_LOOP_2 (acons, Vload_suppress_alist) + { + if (CONSP (acons) && STRINGP (XCAR (acons))) + { + Lisp_Object name = XCAR (acons); + if (XSTRING_LENGTH (name) == len && + !memcmp (XSTRING_DATA (name), nonreloc, len)) + { + struct gcpro gcpro1; + Lisp_Object val; + + GCPRO1 (reloc); + val = Feval (XCDR (acons)); + UNGCPRO; + + if (!NILP (val)) + return 1; + } + } + } + + return 0; +} + /* The plague is coming. Ring around the rosy, pocket full of posy, @@ -689,12 +731,11 @@ internal_bind_lisp_object (&Vload_descriptor_list, Fcons (make_int (fd), Vload_descriptor_list)); internal_bind_lisp_object (&Vload_file_name_internal, found); - internal_bind_lisp_object (&Vload_file_name_internal_the_purecopy, Qnil); /* this is not a simple internal_bind. */ record_unwind_protect (load_force_doc_string_unwind, Vload_force_doc_string_list); Vload_force_doc_string_list = Qnil; - specbind (Qload_file_name, found); + internal_bind_lisp_object (&Vload_file_name, found); #ifdef I18N3 /* set it to nil; a call to #'domain will set it. */ internal_bind_lisp_object (&Vfile_domain, Qnil); @@ -818,6 +859,9 @@ requirements. Allowed symbols are `exists', `executable', `writable', and `readable'. If MODE is nil, it defaults to `readable'. +Filenames are checked against `load-suppress-alist' to determine if they +should be ignored. + `locate-file' keeps hash tables of the directories it searches through, in order to speed things up. It tries valiantly to not get confused in the face of a changing and unpredictable environment, but can occasionally @@ -1024,11 +1068,14 @@ if (closure->fd >= 0) { - /* We succeeded; return this descriptor and filename. */ - if (closure->storeptr) - *closure->storeptr = build_intstring (fn); - - return 1; + if (!check_if_suppressed (fn, Qnil)) + { + /* We succeeded; return this descriptor and filename. */ + if (closure->storeptr) + *closure->storeptr = build_intstring (fn); + + return 1; + } } } /* Keep mapping. */ @@ -1178,7 +1225,7 @@ just look for one for which access(file,MODE) succeeds. In this case, returns a nonnegative value on success. On failure, returns -1. - If STOREPTR is nonzero, it points to a slot where the name of + If STOREPTR is non-nil, it points to a slot where the name of the file actually found should be stored as a Lisp string. Nil is stored there on failure. @@ -1377,7 +1424,7 @@ READCHARFUN (which can be a stream) to Lisp. --hniksic */ /*specbind (Qstandard_input, readcharfun);*/ - specbind (Qcurrent_load_list, Qnil); + internal_bind_lisp_object (&Vcurrent_load_list, Qnil); #ifdef COMPILED_FUNCTION_ANNOTATION_HACK Vcurrent_compiled_function_annotation = Qnil; @@ -3072,9 +3119,7 @@ DEFSYMBOL (Qstandard_input); DEFSYMBOL (Qread_char); - DEFSYMBOL (Qcurrent_load_list); DEFSYMBOL (Qload); - DEFSYMBOL (Qload_file_name); DEFSYMBOL (Qload_internal); DEFSYMBOL (Qfset); @@ -3141,6 +3186,16 @@ Non-nil iff inside of `load'. */ ); + DEFVAR_LISP ("load-suppress-alist", &Vload_suppress_alist /* +An alist of expressions controlling whether particular files can be loaded. +Each element looks like (FILENAME EXPR). +FILENAME should be a full pathname, but without the .el suffix. +When `load' is run and is about to load the specified file, it evaluates +the form to determine if the file can be loaded. +This variable is normally initialized automatically. +*/ ); + Vload_suppress_alist = Qnil; + DEFVAR_LISP ("after-load-alist", &Vafter_load_alist /* An alist of expressions to be evalled when particular files are loaded. Each element looks like (FILENAME FORMS...). @@ -3255,9 +3310,6 @@ Vload_file_name_internal = Qnil; staticpro (&Vload_file_name_internal); - Vload_file_name_internal_the_purecopy = Qnil; - staticpro (&Vload_file_name_internal_the_purecopy); - #ifdef COMPILED_FUNCTION_ANNOTATION_HACK Vcurrent_compiled_function_annotation = Qnil; staticpro (&Vcurrent_compiled_function_annotation);