Mercurial > hg > xemacs-beta
changeset 1333:1b0339b048ce
[xemacs-hg @ 2003-03-02 09:38:37 by ben]
To: xemacs-patches@xemacs.org
PROBLEMS: Include nt/PROBLEMS and update. Add note about incremental
linking badness.
cmdloop.el, custom.el, dumped-lisp.el, files.el, keydefs.el, keymap.el, lisp-mode.el, make-docfile.el, replace.el, simple.el, subr.el, view-less.el, wid-edit.el: Lots of syncing with FSF 21.2.
Use if-fboundp in wid-edit.el.
New file newcomment.el from FSF.
internals/internals.texi: Fix typo.
(Build-Time Dependencies): New node.
PROBLEMS: Delete.
config.inc.samp, xemacs.mak: Eliminate HAVE_VC6, use SUPPORT_EDIT_AND_CONTINUE in its place.
No incremental linking unless SUPPORT_EDIT_AND_CONTINUE, since it
can cause nasty crashes in pdump. Put warnings about this in
config.inc.samp. Report the full compile flags used for src
and lib-src in the Installation output.
alloc.c, lisp.h, ralloc.c, regex.c: Use ALLOCA() in regex.c to avoid excessive stack allocation.
Also fix subtle problem with REL_ALLOC() -- any call to malloc()
(direct or indirect) may relocate rel-alloced data, causing
buffer text to shift. After any such call, regex must update
all its pointers to such data. Add a system, when
ERROR_CHECK_MALLOC, whereby regex.c indicates all the places
it is prepared to handle malloc()/realloc()/free(), and any
calls anywhere in XEmacs outside of this will trigger an abort.
alloc.c, dialog-msw.c, eval.c, event-stream.c, general-slots.h, insdel.c, lisp.h, menubar-msw.c, menubar-x.c: Change *run_hook*_trapping_problems to take a warning class, not
a string. Factor out code to issue warnings, add flag to
call_trapping_problems() to postpone warning issue, and make
*run_hook*_trapping_problems issue their own warnings tailored
to the hook, postponed in the case of safe_run_hook_trapping_problems()
so that the appropriate message can be issued about resetting to
nil only when not `quit'. Make record_unwind_protect_restoring_int()
non-static.
dumper.c: Issue notes about incremental linking problems under Windows.
fileio.c: Mule-ize encrypt/decrypt-string code.
text.h: Spacing changes.
| author | ben |
|---|---|
| date | Sun, 02 Mar 2003 09:38:54 +0000 |
| parents | 6aa23bb3da6b |
| children | 094628fc68f5 |
| files | lisp/ChangeLog lisp/cmdloop.el lisp/custom.el lisp/dumped-lisp.el lisp/files.el lisp/keydefs.el lisp/keymap.el lisp/lisp-mode.el lisp/make-docfile.el lisp/newcomment.el lisp/replace.el lisp/simple.el lisp/subr.el lisp/view-less.el lisp/wid-edit.el man/ChangeLog man/internals/internals.texi nt/ChangeLog nt/PROBLEMS nt/config.inc.samp nt/xemacs.mak src/ChangeLog src/alloc.c src/depend src/dialog-msw.c src/dumper.c src/eval.c src/event-stream.c src/fileio.c src/general-slots.h src/insdel.c src/lisp.h src/make-src-depend src/menubar-msw.c src/menubar-x.c src/ralloc.c src/regex.c src/text.h |
| diffstat | 38 files changed, 4414 insertions(+), 1714 deletions(-) [+] |
line wrap: on
line diff
--- a/lisp/ChangeLog Sun Mar 02 02:18:12 2003 +0000 +++ b/lisp/ChangeLog Sun Mar 02 09:38:54 2003 +0000 @@ -1,3 +1,197 @@ +2003-03-01 Ben Wing <ben@xemacs.org> + + * cmdloop.el: + * cmdloop.el (read-quoted-char-radix): New. + * cmdloop.el (read-quoted-char): + * cmdloop.el (momentary-string-display): + * custom.el: + * custom.el (custom-initialize-set): + * custom.el (custom-initialize-reset): + * custom.el (custom-initialize-changed): + * custom.el (custom-declare-variable): + * custom.el (defcustom): + * dumped-lisp.el (preloaded-file-list): + * files.el: + * files.el (delete-auto-save-files): New. + * files.el (directory-abbrev-alist): + * files.el (make-backup-files): + * files.el (backup-by-copying-when-privileged-mismatch): New. + * files.el (normal-backup-enable-predicate): New. + * files.el (buffer-offer-save): + * files.el (small-temporary-file-directory): New. + * files.el (null-device): New. + * files.el (version-control): + * files.el (auto-save-file-name-transforms): New. + * files.el (save-abbrevs): + * files.el (find-directory-functions): New. + * files.el (find-file-not-found-hooks): + * files.el (write-file-hooks): + * files.el (write-contents-hooks): + * files.el (write-file-data-hooks): + * files.el (enable-local-variables): + * files.el ((fboundp 'file-locked-p)): + * files.el (view-read-only): New. + * files.el (cd-absolute): + * files.el (load-file): + * files.el (file-local-copy): + * files.el (file-chase-links): + * files.el (switch-to-buffer-other-window): + * files.el (switch-to-buffer-other-frame): + * files.el (find-file): + * files.el (find-file-other-window): + * files.el (find-file-other-frame): + * files.el (find-file-read-only): + * files.el (find-file-read-only-other-window): + * files.el (find-file-read-only-other-frame): + * files.el (abbreviate-file-name): + * files.el (find-buffer-visiting): + * files.el (find-file-wildcards): New. + * files.el (find-file-suppress-same-file-warnings): New. + * files.el (find-file-noselect): New. + * files.el (find-file-noselect-1): New. + * files.el (insert-file-contents-literally): + * files.el (insert-file-literally): New. + * files.el (after-find-file-from-revert-buffer): + * files.el (after-find-file): + * files.el (normal-mode): + * files.el (find-file-literally): New. + * files.el (dabbrev-case-fold-search): + * files.el (hack-one-local-variable-quotep): New. + * files.el (hack-one-local-variable): + * files.el (set-visited-file-name): + * files.el (write-file): + * files.el (backup-buffer): + * files.el (make-backup-file-name-function): New. + * files.el (backup-directory-alist): New. + * files.el (make-backup-file-name): + * files.el (make-backup-file-name-1): New. + * files.el (backup-extract-version-start): + * files.el (backup-extract-version-start)): New. + * files.el (file-relative-name): + * files.el (save-buffer): + * files.el (delete-auto-save-file-if-necessary): + * files.el (save-buffer-coding-system): New. + * files.el (basic-save-buffer): + * files.el (basic-save-buffer-1): + * files.el (basic-save-buffer-2): New. + * files.el (save-some-buffers): + * files.el (save-some-buffers-1): + * files.el (toggle-read-only): + * files.el (file-newest-backup): + * files.el (rename-uniquely): + * files.el (revert-buffer-insert-file-contents-function): + * files.el (recover-file): + * files.el (recover-session): + * files.el (recover-session-finish): + * files.el (kill-some-buffers): + * files.el (wildcard-to-regexp): + * files.el (file-expand-wildcards): New. + * files.el (list-directory): + * files.el (shell-quote-wildcard-pattern): New. + * files.el (insert-directory-safely): New. + * files.el (confirm-kill-emacs): New. + * files.el (save-buffers-kill-emacs): + * files.el (file-name-non-special): New. + * keydefs.el (global-map): New. + * keymap.el: + * keymap.el (kbd): Removed. + * keymap.el (substitute-key-definition): + * lisp-mode.el (construct-lisp-mode-menu): + * make-docfile.el (custom-declare-variable-list): New. + * replace.el: + * replace.el (match-string): Removed. + * replace.el (save-match-data): Removed. + * simple.el: + * simple.el (comment-column): Removed. + * simple.el (comment-start): Removed. + * simple.el (comment-start-skip): Removed. + * simple.el (comment-end): Removed. + * simple.el (comment-indent-hook): Removed. + * simple.el (comment-indent-function): Removed. + * simple.el (block-comment-start): Removed. + * simple.el (block-comment-end): Removed. + * simple.el (indent-for-comment): Removed. + * simple.el (set-comment-column): Removed. + * simple.el (kill-comment): Removed. + * simple.el (comment-padding): Removed. + * simple.el (comment-region): Removed. + * simple.el (comment-multi-line): Removed. + * simple.el (set-selective-display): + * simple.el (indent-new-comment-line): Removed. + * simple.el (overwrite-mode-textual): + * simple.el (overwrite-mode): + * simple.el (binary-overwrite-mode): + * simple.el (mail-user-agent): + * simple.el (rfc822-goto-eoh): New. + * simple.el (sendmail-user-agent-compose): + * simple.el (mh-e-user-agent): + * simple.el (set-variable-value-history): New. + * simple.el (set-variable): + * simple.el (clone-buffer-hook): New. + * simple.el (clone-process): New. + * simple.el (clone-buffer): New. + * simple.el (clone-indirect-buffer): New. + * simple.el (clone-indirect-buffer-other-window): New. + * subr.el: + * subr.el (custom-declare-variable-list): New. + * subr.el (custom-declare-variable-early): New. + * subr.el (assoc-default): New. + * subr.el (assoc-ignore-case): New. + * subr.el (assoc-ignore-representation): New. + * subr.el (member-ignore-case): New. + * subr.el ('move-marker): New. + * subr.el ('beep): New. + * subr.el ('indent-to-column): New. + * subr.el ('backward-delete-char): New. + * subr.el ('search-forward-regexp): New. + * subr.el ('search-backward-regexp): New. + * subr.el ('remove-directory): New. + * subr.el ('set-match-data): New. + * subr.el ('send-string-to-terminal): New. + * subr.el (make-local-hook): + * subr.el (add-hook): + * subr.el (remove-hook): + * subr.el (add-local-hook): + * subr.el (remove-local-hook): + * subr.el (add-one-shot-hook): + * subr.el (add-local-one-shot-hook): + * subr.el (string-equal-ignore-case): Removed. + * subr.el (with-current-buffer): + * subr.el (with-output-to-string): Removed. + * subr.el (replace-in-string): Removed. + * subr.el (split-string): Removed. + * subr.el (with-temp-message): + * subr.el (with-syntax-table): New. + * subr.el (save-match-data): New. + * subr.el (match-string): New. + * subr.el (match-string-no-properties): New. + * subr.el (subst-char-in-string): New. + * subr.el (replace-regexp-in-string): New. + * subr.el (truncate-string-to-width): + * subr.el (eval-after-load): + * view-less.el: + * wid-edit.el: + * wid-edit.el (widget-url-link-action): + Lots of syncing with FSF 21.2. + Use if-fboundp in wid-edit.el. + New file newcomment.el from FSF. + +2003-02-26 Stephen J. Turnbull <stephen@xemacs.org> + + * dumped-lisp.el (preloaded-file-list): Add markers for use of + defcustom v. custom-declare-variable-early. + + * make-docfile.el (custom-declare-variable-list): Defvar to prevent + custom (required from raw-process) from barfing a void-variable error. + +2003-02-26 Stephen J. Turnbull <stephen@xemacs.org> + + * view-less.el (view-minor-mode): Add autoload cookie. + +2003-02-26 Stephen J. Turnbull <stephen@xemacs.org> + + * view-less.el (view-minor-mode): Add autoload cookie. + 2003-02-28 Ben Wing <ben@xemacs.org> * dump-paths.el:
--- a/lisp/cmdloop.el Sun Mar 02 02:18:12 2003 +0000 +++ b/lisp/cmdloop.el Sun Mar 02 09:38:54 2003 +0000 @@ -1,7 +1,7 @@ ;;; cmdloop.el --- support functions for the top-level command loop. ;; Copyright (C) 1992-4, 1997 Free Software Foundation, Inc. -;; Copyright (C) 2001, 2002 Ben Wing. +;; Copyright (C) 2001, 2002, 2003 Ben Wing. ;; Author: Richard Mlynarik ;; Date: 8-Jul-92 @@ -26,6 +26,7 @@ ;; Boston, MA 02111-1307, USA. ;;; Synched up with: FSF 19.30. (Some of the stuff below is in FSF's subr.el.) +;;; Some parts synched with FSF 21.2. ;;; Commentary: @@ -519,21 +520,45 @@ (null ch))) ch)) +;;;; Input and display facilities. + +;; BEGIN SYNCHED WITH FSF 21.2. + +(defvar read-quoted-char-radix 8 + "*Radix for \\[quoted-insert] and other uses of `read-quoted-char'. +Legitimate radix values are 8, 10 and 16.") + +(custom-declare-variable-early + 'read-quoted-char-radix 8 + "*Radix for \\[quoted-insert] and other uses of `read-quoted-char'. +Legitimate radix values are 8, 10 and 16." + :type '(choice (const 8) (const 10) (const 16)) + :group 'editing-basics) + (defun read-quoted-char (&optional prompt) - "Like `read-char', except that if the first character read is an octal -digit, we read up to two more octal digits and return the character -represented by the octal number consisting of those digits. -Optional argument PROMPT specifies a string to use to prompt the user." - (let ((count 0) (code 0) done + "Like `read-char', but do not allow quitting. +Also, if the first character read is an octal digit, +we read any number of octal digits and return the +specified character code. Any nondigit terminates the sequence. +If the terminator is RET, it is discarded; +any other terminator is used itself as input. + +The optional argument PROMPT specifies a string to use to prompt the user. +The variable `read-quoted-char-radix' controls which radix to use +for numeric input." + (let (;(message-log-max nil) + done (first t) (code 0) char event (prompt (and prompt (gettext prompt))) - char event) - (while (and (not done) (< count 3)) - (let ((inhibit-quit (zerop count)) + ) + (while (not done) + (let ((inhibit-quit first) ;; Don't let C-h get the help message--only help function keys. (help-char nil) (help-form "Type the special character you want to use, -or three octal digits representing its character code.")) +or the octal character code. +RET terminates the character code and is discarded; +any other non-digit terminates the character code and is then used as input.")) (and prompt (display-message 'prompt (format "%s-" prompt))) (setq event (next-command-event) char (or (event-to-character event nil nil t) @@ -541,22 +566,93 @@ (list "key read cannot be inserted in a buffer" event)))) (if inhibit-quit (setq quit-flag nil))) - (cond ((<= ?0 char ?7) - (setq code (+ (* code 8) (- char ?0)) - count (1+ count)) - (when prompt - (display-message 'prompt - (setq prompt (format "%s %c" prompt char))))) - ((> count 0) - (setq unread-command-event event + ;; Translate TAB key into control-I ASCII character, and so on. + (and char + (let ((translated (lookup-key function-key-map (vector char)))) + (if (arrayp translated) + (setq char (aref translated 0))))) + (cond ((null char)) + ((not (characterp char)) + (setq unread-command-events (list char) + done t)) +; ((/= (logand char ?\M-\^@) 0) +; ;; Turn a meta-character into a character with the 0200 bit set. +; (setq code (logior (logand char (lognot ?\M-\^@)) 128) +; done t)) + ((and (<= ?0 char) (< char (+ ?0 (min 10 read-quoted-char-radix)))) + (setq code (+ (* code read-quoted-char-radix) (- char ?0))) + (and prompt (setq prompt (display-message 'prompt + (format "%s %c" prompt char))))) + ((and (<= ?a (downcase char)) + (< (downcase char) (+ ?a -10 (min 26 read-quoted-char-radix)))) + (setq code (+ (* code read-quoted-char-radix) + (+ 10 (- (downcase char) ?a)))) + (and prompt (setq prompt (display-message 'prompt + (format "%s %c" prompt char))))) + ((and (not first) (eq char ?\C-m)) + (setq done t)) + ((not first) + (setq unread-command-events (list char) done t)) - (t (setq code (char-int char) - done t)))) - (int-char code) - ;; Turn a meta-character into a character with the 0200 bit set. -; (logior (if (/= (logand code ?\M-\^@) 0) 128 0) -; (logand 255 code)))) - )) + (t (setq code char + done t))) + (setq first nil)) + (int-to-char code))) + +;; in passwd.el. +; (defun read-passwd (prompt &optional confirm default) +; "Read a password, prompting with PROMPT. Echo `.' for each character typed. +; End with RET, LFD, or ESC. DEL or C-h rubs out. C-u kills line. +; Optional argument CONFIRM, if non-nil, then read it twice to make sure. +; Optional DEFAULT is a default password to use instead of empty input." +; (if confirm +; (let (success) +; (while (not success) +; (let ((first (read-passwd prompt nil default)) +; (second (read-passwd "Confirm password: " nil default))) +; (if (equal first second) +; (progn +; (and (arrayp second) (fillarray second ?\0)) +; (setq success first)) +; (and (arrayp first) (fillarray first ?\0)) +; (and (arrayp second) (fillarray second ?\0)) +; (message "Password not repeated accurately; please start over") +; (sit-for 1)))) +; success) +; (let ((pass nil) +; (c 0) +; (echo-keystrokes 0) +; (cursor-in-echo-area t)) +; (while (progn (message "%s%s" +; prompt +; (make-string (length pass) ?.)) +; (setq c (read-char-exclusive nil t)) +; (and (/= c ?\r) (/= c ?\n) (/= c ?\e))) +; (clear-this-command-keys) +; (if (= c ?\C-u) +; (progn +; (and (arrayp pass) (fillarray pass ?\0)) +; (setq pass "")) +; (if (and (/= c ?\b) (/= c ?\177)) +; (let* ((new-char (char-to-string c)) +; (new-pass (concat pass new-char))) +; (and (arrayp pass) (fillarray pass ?\0)) +; (fillarray new-char ?\0) +; (setq c ?\0) +; (setq pass new-pass)) +; (if (> (length pass) 0) +; (let ((new-pass (substring pass 0 -1))) +; (and (arrayp pass) (fillarray pass ?\0)) +; (setq pass new-pass)))))) +; (message nil) +; (or pass default "")))) + +;; aliased to redraw-modeline, a built-in. +; (defun force-mode-line-update (&optional all) +; "Force the mode-line of the current buffer to be redisplayed. +; With optional non-nil ALL, force redisplay of all mode-lines." +; (if all (save-excursion (set-buffer (other-buffer)))) +; (set-buffer-modified-p (buffer-modified-p))) (defun momentary-string-display (string pos &optional exit-char message) "Momentarily display STRING in the buffer at POS. @@ -566,7 +662,7 @@ Display MESSAGE (optional fourth arg) in the echo area. If MESSAGE is nil, instructions to type EXIT-CHAR are displayed there." (or exit-char (setq exit-char ?\ )) - (let ((buffer-read-only nil) + (let ((inhibit-read-only t) ;; Don't modify the undo list at all. (buffer-undo-list t) (modified (buffer-modified-p)) @@ -580,8 +676,8 @@ (setq buffer-file-name nil) (insert-before-markers (gettext string)) (setq insert-end (point)) - ;; If the message end is off frame, recenter now. - (if (> (window-end) insert-end) + ;; If the message end is off screen, recenter now. + (if (< (window-end nil t) insert-end) (recenter (/ (window-height) 2))) ;; If that pushed message start off the frame, ;; scroll to start it at the top of the frame. @@ -594,11 +690,13 @@ (single-key-description exit-char)) (let ((event (save-excursion (next-command-event)))) (or (eq (event-to-character event) exit-char) - (setq unread-command-event event)))) + (setq unread-command-events (list event))))) (if insert-end (save-excursion (delete-region pos insert-end))) (setq buffer-file-name name) (set-buffer-modified-p modified)))) +;; END SYNCHED WITH FSF 21.2. + ;;; cmdloop.el ends here
--- a/lisp/custom.el Sun Mar 02 02:18:12 2003 +0000 +++ b/lisp/custom.el Sun Mar 02 09:38:54 2003 +0000 @@ -25,6 +25,8 @@ ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;; Boston, MA 02111-1307, USA. +;;; Synched with: ??? Partially synched to 21.2 by Ben Wing. + ;;; Commentary: ;; This file is dumped with XEmacs. @@ -42,6 +44,8 @@ ;; prevent require/provide loop with custom and cus-face. (provide 'custom) +;; BEGIN SYNC WITH FSF 21.2 + (eval-when-compile (load "cl-macs" nil t) ;; To elude warnings. @@ -73,7 +77,12 @@ (defun custom-initialize-set (symbol value) "Initialize SYMBOL with VALUE. -Like `custom-initialize-default', but use the function specified by +If the symbol doesn't have a default binding already, +then set it using its `:set' function (or `set-default' if it has none). +The value is either the value in the symbol's `saved-value' property, +if any, or VALUE. + +This is like `custom-initialize-default', but uses the function specified by `:set' to initialize SYMBOL." (unless (default-boundp symbol) (funcall (or (get symbol 'custom-set) 'set-default) @@ -84,6 +93,12 @@ (defun custom-initialize-reset (symbol value) "Initialize SYMBOL with VALUE. +Set the symbol, using its `:set' function (or `set-default' if it has none). +The value is either the symbol's current value + \(as obtained using the `:get' function), if any, +or the value in the symbol's `saved-value' property if any, +or (last of all) VALUE. + Like `custom-initialize-set', but use the function specified by `:get' to reinitialize SYMBOL if it is already bound." (funcall (or (get symbol 'custom-set) 'set-default) @@ -99,7 +114,8 @@ (defun custom-initialize-changed (symbol value) "Initialize SYMBOL with VALUE. Like `custom-initialize-reset', but only use the `:set' function if the -not using the standard setting. Otherwise, use the `set-default'." +not using the standard setting. +For the standard setting, use `set-default'." (cond ((default-boundp symbol) (funcall (or (get symbol 'custom-set) 'set-default) symbol @@ -112,10 +128,12 @@ (t (set-default symbol (eval value))))) -(defun custom-declare-variable (symbol value doc &rest args) - "Like `defcustom', but SYMBOL and VALUE are evaluated as normal arguments." +(defun custom-declare-variable (symbol default doc &rest args) + "Like `defcustom', but SYMBOL and DEFAULT are evaluated as normal arguments. +DEFAULT should be an expression to evaluate to compute the default value, +not the default value itself." ;; Remember the standard setting. - (put symbol 'standard-value (list value)) + (put symbol 'standard-value (list default)) ;; Maybe this option was rogue in an earlier version. It no longer is. (when (eq (get symbol 'force-value) 'rogue) ;; It no longer is. @@ -156,7 +174,7 @@ 'custom-variable)))))) (put symbol 'custom-requests requests) ;; Do the actual initialization. - (funcall initialize symbol value)) + (funcall initialize symbol default)) ;; #### This is a rough equivalent of LOADHIST_ATTACH. However, ;; LOADHIST_ATTACH also checks for `initialized'. (push symbol current-load-list) @@ -173,37 +191,44 @@ [KEYWORD VALUE]... -The following KEYWORD's are defined: +The following keywords are meaningful: :type VALUE should be a widget type for editing the symbols value. The default is `sexp'. :options VALUE should be a list of valid members of the widget type. :group VALUE should be a customization group. Add SYMBOL to that group. -:initialize VALUE should be a function used to initialize the +:initialize + VALUE should be a function used to initialize the variable. It takes two arguments, the symbol and value given in the `defcustom' call. The default is - `custom-initialize-set' -:set VALUE should be a function to set the value of the symbol. - It takes two arguments, the symbol to set and the value to - give it. The default is `custom-set-default'. + `custom-initialize-reset' +:set VALUE should be a function to set the value of the symbol. + It takes two arguments, the symbol to set and the value to + give it. The default choice of function is `custom-set-default'. :get VALUE should be a function to extract the value of symbol. - The function takes one argument, a symbol, and should return - the current value for that symbol. The default is - `default-value'. -:require VALUE should be a feature symbol. Each feature will be - required after initialization, of the user have saved this - option. -:version VALUE should be a string specifying that the variable was + The function takes one argument, a symbol, and should return + the current value for that symbol. The default choice of function + is `custom-default-value'. #### XEmacs used to say `default-value'; + is that right? +:require + VALUE should be a feature symbol. If you save a value + for this option, then when your custom init file loads the value, + it does (require VALUE) first. +:version + VALUE should be a string specifying that the variable was first introduced, or its default value was changed, in Emacs version VERSION. -:set-after VARIABLE specifies that SYMBOL should be set after VARIABLE when +:set-after VARIABLE + Specifies that SYMBOL should be set after VARIABLE when both have been customized. Read the section about customization in the Emacs Lisp manual for more information." `(custom-declare-variable (quote ,symbol) (quote ,value) ,doc ,@args)) +;; END SYNC WITH FSF 21.2 + ;;; The `defface' Macro. (defmacro defface (face spec doc &rest args) @@ -713,4 +738,13 @@ ;;; The End. +;; BEGIN SYNC WITH FSF 21.2 + +;; Process the defcustoms for variables loaded before this file. +(while custom-declare-variable-list + (apply 'custom-declare-variable (car custom-declare-variable-list)) + (setq custom-declare-variable-list (cdr custom-declare-variable-list))) + +;; END SYNC WITH FSF 21.2 + ;; custom.el ends here
--- a/lisp/dumped-lisp.el Sun Mar 02 02:18:12 2003 +0000 +++ b/lisp/dumped-lisp.el Sun Mar 02 09:38:54 2003 +0000 @@ -8,11 +8,16 @@ (setq preloaded-file-list (list + ;; do not defcustom any variables in these files + "backquote" ; needed for defsubst etc. "bytecomp-runtime" ; define defsubst "find-paths" "packages" ; Bootstrap run-time lisp environment "setup-paths" + + ;; use custom-declare-variable-early, not defcustom, in these files + "subr" ; load the most basic Lisp functions "post-gc" "replace" ; match-string used in version.el. @@ -26,6 +31,9 @@ "custom" ; Before the world so everything can be ; customized "cus-start" ; for customization of builtin variables + + ;; OK, you can use defcustom from here on + "cmdloop" "keymap" "syntax" @@ -52,6 +60,7 @@ "window" ; simple needs `save-window-excursion' "window-xemacs" "simple" + "newcomment" "keydefs" ; Before loaddefs so that keymap vars exist. "abbrev" "derived"
--- a/lisp/files.el Sun Mar 02 02:18:12 2003 +0000 +++ b/lisp/files.el Sun Mar 02 09:38:54 2003 +0000 @@ -2,7 +2,7 @@ ;; Copyright (C) 1985-1987, 1992-1995, 1997 Free Software Foundation, Inc. ;; Copyright (C) 1995 Sun Microsystems. -;; Copyright (C) 2001, 2002 Ben Wing. +;; Copyright (C) 2001, 2002, 2003 Ben Wing. ;; Maintainer: XEmacs Development Team ;; Keywords: extensions, dumped @@ -24,13 +24,26 @@ ;; Software Foundation, Inc. 59 Temple Place - Suite 330, Boston, MA ;; 02111-1307, USA. -;;; Synched up with: FSF 20.3 (but diverging) -;;; Warning: Merging this file is tough. Beware. +;;; [[ Synched up with: FSF 20.3 (but diverging) +;;; Warning: Merging this file is tough. Beware.]] + +;;; Beware of sync messages with 20.x or 21.x! (Unless I did them, of +;;; course ... :-) Those who did these synchronizations did not do proper +;;; jobs and often left out lots of changes. In practice you need to do a +;;; line-by-line comparison, and whenever encountering differences, see +;;; what FSF 19.34 looks like to see if the changes are intentional or just +;;; regressions. In at least one case below, our code was unchanged from +;;; FSF 19.30! --ben + +;;; Mostly synched to FSF 21.2 by Ben Wing using a line-by-line comparison, +;;; except some really hard parts that have changed almost completely. ;;; Commentary: ;; This file is dumped with XEmacs. +;; BEGIN SYNC WITH FSF 21.2. + ;; Defines most of XEmacs's file- and directory-handling functions, ;; including basic file visiting, backup generation, link handling, ;; ITS-id version control, load- and write-hook handling, and the like. @@ -53,10 +66,14 @@ "Finding and editing files." :group 'files) - -;; XEmacs: In buffer.c -;(defconst delete-auto-save-files t -; "*Non-nil means delete auto-save file when a buffer is saved or killed.") +;; XEmacs: In buffer.c (also) +(defcustom delete-auto-save-files t + "*Non-nil means delete auto-save file when a buffer is saved or killed. + +Note that auto-save file will not be deleted if the buffer is killed +when it has unsaved changes." + :type 'boolean + :group 'auto-save) ;; FSF has automount-dir-prefix. Our directory-abbrev-alist is more general. ;; note: tmp_mnt bogosity conversion is established in paths.el. @@ -67,6 +84,9 @@ This replacement is done when setting up the default directory of a newly visited file. *Every* FROM string should start with \\\\` or ^. +Do not use `~' in the TO strings. +They should be ordinary absolute directory names. + Use this feature when you have directories which you normally refer to via absolute symbolic links or to eliminate automounter mount points from the beginning of your filenames. Make TO the name of the link, @@ -93,7 +113,8 @@ The choice of renaming or copying is controlled by the variables `backup-by-copying', `backup-by-copying-when-linked' and -`backup-by-copying-when-mismatch'. See also `backup-inhibited'." +`backup-by-copying-when-mismatch' and +`backup-by-copying-when-privileged-mismatch'. See also `backup-inhibited'." :type 'boolean :group 'backup) @@ -128,20 +149,43 @@ :type 'boolean :group 'backup) -(defvar backup-enable-predicate - #'(lambda (name) - (not (or (null name) - (string-match "^/tmp/" name) - (let ((tmpdir (temp-directory))) - (and tmpdir - (string-match (concat "\\`" (regexp-quote tmpdir) "/") - tmpdir)))))) +(defcustom backup-by-copying-when-privileged-mismatch 200 + "*Non-nil means create backups by copying to preserve a privileged owner. +Renaming may still be used (subject to control of other variables) +when it would not result in changing the owner of the file or if the owner +has a user id greater than the value of this variable. This is useful +when low-numbered uid's are used for special system users (such as root) +that must maintain ownership of certain files. +This variable is relevant only if `backup-by-copying' and +`backup-by-copying-when-mismatch' are nil." + :type '(choice (const nil) integer) + :group 'backup) + +(defun normal-backup-enable-predicate (name) + "Default `backup-enable-predicate' function. +Checks for files in `temporary-file-directory' or +`small-temporary-file-directory'." + (let ((temporary-file-directory (temp-directory))) + (not (or (let ((comp (compare-strings temporary-file-directory 0 nil + name 0 nil))) + ;; Directory is under temporary-file-directory. + (and (not (eq comp t)) + (< comp (- (length temporary-file-directory))))) + (if small-temporary-file-directory + (let ((comp (compare-strings small-temporary-file-directory + 0 nil + name 0 nil))) + ;; Directory is under small-temporary-file-directory. + (and (not (eq comp t)) + (< comp (- (length small-temporary-file-directory)))))))))) + +(defvar backup-enable-predicate 'normal-backup-enable-predicate "Predicate that looks at a file name and decides whether to make backups. Called with an absolute file name as argument, it returns t to enable backup.") (defcustom buffer-offer-save nil - "*Non-nil in a buffer means offer to save the buffer on exit -even if the buffer is not visiting a file. + "*Non-nil in a buffer means always offer to save buffer on exit. +Do so even if the buffer is not visiting a file. Automatically local in all buffers." :type 'boolean :group 'find-file) @@ -171,6 +215,40 @@ (defvar buffer-file-numbers-unique (not (memq system-type '(windows-nt))) "Non-nil means that buffer-file-number uniquely identifies files.") +;; FSF 21.2. We use (temp-directory). +; (defvar temporary-file-directory +; (file-name-as-directory +; (cond ((memq system-type '(ms-dos windows-nt)) +; (or (getenv "TEMP") (getenv "TMPDIR") (getenv "TMP") "c:/temp")) +; ((memq system-type '(vax-vms axp-vms)) +; (or (getenv "TMPDIR") (getenv "TMP") (getenv "TEMP") "SYS$SCRATCH:")) +; (t +; (or (getenv "TMPDIR") (getenv "TMP") (getenv "TEMP") "/tmp")))) +; "The directory for writing temporary files.") + +(defvar small-temporary-file-directory + (if (eq system-type 'ms-dos) (getenv "TMPDIR")) + "The directory for writing small temporary files. +If non-nil, this directory is used instead of `temporary-file-directory' +by programs that create small temporary files. This is for systems that +have fast storage with limited space, such as a RAM disk.") + +;; The system null device. (Should reference NULL_DEVICE from C.) +(defvar null-device "/dev/null" "The system null device.") + +; (defvar file-name-invalid-regexp +; (cond ((and (eq system-type 'ms-dos) (not (msdos-long-file-names))) +; (concat "^\\([^A-Z[-`a-z]\\|..+\\)?:\\|" ; colon except after drive +; "[+, ;=|<>\"?*]\\|\\[\\|\\]\\|" ; invalid characters +; "[\000-\031]\\|" ; control characters +; "\\(/\\.\\.?[^/]\\)\\|" ; leading dots +; "\\(/[^/.]+\\.[^/.]*\\.\\)")) ; more than a single dot +; ((memq system-type '(ms-dos windows-nt)) +; (concat "^\\([^A-Z[-`a-z]\\|..+\\)?:\\|" ; colon except after drive +; "[|<>\"?*\000-\031]")) ; invalid characters +; (t "[\000]")) +; "Regexp recognizing file names which aren't allowed by the filesystem.") + (defcustom file-precious-flag nil "*Non-nil means protect against I/O errors while saving files. Some modes set this non-nil in particular buffers. @@ -191,13 +269,18 @@ t means make numeric backup versions unconditionally. nil means make them for files that have some already. `never' means do not make them." - :type 'boolean + :type '(choice (const :tag "Never" never) + (const :tag "If existing" nil) + (other :tag "Always" t)) :group 'backup :group 'vc) ;; This is now defined in efs. -;(defvar dired-kept-versions 2 -; "*When cleaning directory, number of versions to keep.") +; (defcustom dired-kept-versions 2 +; "*When cleaning directory, number of versions to keep." +; :type 'integer +; :group 'backup +; :group 'dired) (defcustom delete-old-versions nil "*If t, delete excess backup versions silently. @@ -238,15 +321,44 @@ :type 'boolean :group 'auto-save) +(defcustom auto-save-file-name-transforms + `(("\\`/[^/]*:\\(.+/\\)*\\(.*\\)" + ,(expand-file-name "\\2" (temp-directory)))) + "*Transforms to apply to buffer file name before making auto-save file name. +Each transform is a list (REGEXP REPLACEMENT): +REGEXP is a regular expression to match against the file name. +If it matches, `replace-match' is used to replace the +matching part with REPLACEMENT. +All the transforms in the list are tried, in the order they are listed. +When one transform applies, its result is final; +no further transforms are tried. + +The default value is set up to put the auto-save file into the +temporary directory (see the variable `temporary-file-directory') for +editing a remote file." + :group 'auto-save + :type '(repeat (list (string :tag "Regexp") (string :tag "Replacement"))) + ;:version "21.1" + ) + (defcustom save-abbrevs nil - "*Non-nil means save word abbrevs too when files are saved. -Loading an abbrev file sets this to t." - :type 'boolean - :group 'abbrev) - + "*Non-nil means save word abbrevs too when files are saved. +If `silently', don't ask the user before saving. + Loading an abbrev file sets this to t." + :type '(choice (const t) (const nil) (const silently)) + :group 'abbrev) + (defcustom find-file-run-dired t - "*Non-nil says run dired if `find-file' is given the name of a directory." - :type 'boolean + "*Non-nil means allow `find-file' to visit directories. +To visit the directory, `find-file' runs `find-directory-functions'." + :type 'boolean + :group 'find-file) + +(defcustom find-directory-functions '(cvs-dired-noselect dired-noselect) + "*List of functions to try in sequence to visit a directory. +Each function is called with the directory name as the sole argument +and should return either a buffer or nil." + :type '(hook :options (cvs-dired-noselect dired-noselect)) :group 'find-file) ;;;It is not useful to make this a local variable. @@ -254,7 +366,7 @@ (defvar find-file-not-found-hooks nil "List of functions to be called for `find-file' on nonexistent file. These functions are called as soon as the error is detected. -`buffer-file-name' is already set up. +Variable `buffer-file-name' is already set up. The functions are called in the order given until one of them returns non-nil.") ;;;It is not useful to make this a local variable. @@ -269,7 +381,10 @@ If one of them returns non-nil, the file is considered already written and the rest are not called. These hooks are considered to pertain to the visited file. -So this list is cleared if you change the visited file name. +So any buffer-local binding of `write-file-hooks' is +discarded if you change the visited file name with \\[set-visited-file-name]. + +Don't make this variable buffer-local; instead, use `local-write-file-hooks'. See also `write-contents-hooks' and `continue-save-buffer'.") ;;; However, in case someone does make it local... (put 'write-file-hooks 'permanent-local t) @@ -302,10 +417,18 @@ "List of functions to be called before writing out a buffer to a file. If one of them returns non-nil, the file is considered already written and the rest are not called. -These hooks are considered to pertain to the buffer's contents, -not to the particular visited file; thus, `set-visited-file-name' does -not clear this variable, but changing the major mode does clear it. + +This variable is meant to be used for hooks that pertain to the +buffer's contents, not to the particular visited file; thus, +`set-visited-file-name' does not clear this variable; but changing the +major mode does clear it. + +This variable automatically becomes buffer-local whenever it is set. +If you use `add-hook' to add elements to the list, use nil for the +LOCAL argument. + See also `write-file-hooks' and `continue-save-buffer'.") +(make-variable-buffer-local 'write-contents-hooks) ;; XEmacs addition ;; Energize needed this to hook into save-buffer at a lower level; we need @@ -321,22 +444,35 @@ If one of them returns non-nil, the file is considered already written and the rest are not called. These hooks are considered to pertain to the visited file. -So this list is cleared if you change the visited file name. +So any buffer-local binding of `write-file-data-hooks' is +discarded if you change the visited file name with \\[set-visited-file-name]. See also `write-file-hooks'.") (defcustom enable-local-variables t - "*Control use of local-variables lists in files you visit. + "*Control use of local variables in files you visit. The value can be t, nil or something else. -A value of t means local-variables lists are obeyed; +A value of t means file local variables specifications are obeyed; nil means they are ignored; anything else means query. - -The command \\[normal-mode] always obeys local-variables lists +This variable also controls use of major modes specified in +a -*- line. + +The command \\[normal-mode], when used interactively, +always obeys file local variable specifications and the -*- line, and ignores this variable." :type '(choice (const :tag "Obey" t) (const :tag "Ignore" nil) (sexp :tag "Query" :format "%t\n" other)) :group 'find-file) +; (defvar local-enable-local-variables t +; "Like `enable-local-variables' but meant for buffer-local bindings. +; The meaningful values are nil and non-nil. The default is non-nil. +; If a major mode sets this to nil, buffer-locally, then any local +; variables list in the file will be ignored. + +; This variable does not affect the use of major modes +; specified in a -*- line.") + (defcustom enable-local-eval 'maybe "*Control processing of the \"variable\" `eval' in a file's local variables. The value can be t, nil or something else. @@ -355,13 +491,18 @@ (defalias 'lock-buffer 'ignore)) (or (fboundp 'unlock-buffer) (defalias 'unlock-buffer 'ignore)) +(or (fboundp 'file-locked-p) + (defalias 'file-locked-p 'ignore)) + +(defvar view-read-only nil + "*Non-nil means buffers visiting files read-only, do it in view mode.") ;;FSFmacs bastardized ange-ftp cruft -;; This hook function provides support for ange-ftp host name -;; completion. It runs the usual ange-ftp hook, but only for -;; completion operations. Having this here avoids the need -;; to load ange-ftp when it's not really in use. ;(defun ange-ftp-completion-hook-function (op &rest args) +; "Provides support for ange-ftp host name completion. +;Runs the usual ange-ftp hook, but only for completion operations." +; ;; Having this here avoids the need to load ange-ftp when it's not +; ;; really in use. ; (if (memq op '(file-name-completion file-name-all-completions)) ; (apply 'ange-ftp-hook-function op args) ; (let ((inhibit-file-name-handlers @@ -371,6 +512,11 @@ ; (inhibit-file-name-operation op)) ; (apply op args)) +;; FSF 21.2: +;This function's standard definition is trivial; it just returns the argument. +;However, on some systems, the function is redefined with a definition +;that really does change some file names to canonicalize certain +;patterns and to guarantee valid names." (defun convert-standard-filename (filename) "Convert a standard file's name to something suitable for the current OS." (if (eq system-type 'windows-nt) @@ -432,7 +578,9 @@ (setq dir (file-truename dir))) (setq dir (abbreviate-file-name (expand-file-name dir))) (cond ((not (file-directory-p dir)) - (error "%s is not a directory" dir)) + (if (file-exists-p dir) + (error "%s is not a directory" dir) + (error "%s: no such directory" dir))) ;; this breaks ange-ftp, which doesn't (can't?) overload `file-executable-p'. ;;((not (file-executable-p dir)) ;; (error "Cannot cd to %s: Permission denied" dir)) @@ -474,7 +622,10 @@ (defun load-file (file) "Load the Lisp file named FILE." - (interactive "fLoad file: ") + ;; This is a case where .elc makes a lot of sense. + (interactive (list (let ((completion-ignored-extensions + (remove ".elc" completion-ignored-extensions))) + (read-file-name "Load file: ")))) (load (expand-file-name file) nil nil t)) ; We now dump utils/lib-complete.el which has improved versions of this. @@ -493,10 +644,12 @@ ; (find-file f) ; (error "Couldn't locate library %s" library)))) -(defun file-local-copy (file &optional buffer) +(defun file-local-copy (file) "Copy the file FILE into a temporary file on this machine. Returns the name of the local copy, or nil, if FILE is directly accessible." + ;; This formerly had an optional BUFFER argument that wasn't used by + ;; anything. (let ((handler (find-file-name-handler file 'file-local-copy))) (if handler (funcall handler 'file-local-copy file) @@ -547,8 +700,7 @@ (error "Apparent cycle of symbolic links for %s" filename)) ;; In the context of a link, `//' doesn't mean what XEmacs thinks. (while (string-match "//+" tem) - (setq tem (concat (substring tem 0 (1+ (match-beginning 0))) - (substring tem (match-end 0))))) + (setq tem (replace-match "/" nil nil tem))) ;; Handle `..' by hand, since it needs to work in the ;; target of any directory symlink. ;; This code is not quite complete; it does not handle @@ -578,9 +730,15 @@ (if (<= arg 1) (other-buffer (current-buffer)) (nth (1+ arg) (buffer-list))))) -(defun switch-to-buffer-other-window (buffer) - "Select buffer BUFFER in another window." - (interactive "BSwitch to buffer in other window: ") +;;FSF 21.2 +;Optional second arg NORECORD non-nil means +;do not put this buffer at the front of the list of recently selected ones. +(defun switch-to-buffer-other-window (buffer) ;;FSF 21.2: &optional norecord + "Select buffer BUFFER in another window. + +This uses the function `display-buffer' as a subroutine; see its +documentation for additional customization information." + (interactive "BSwitch to buffer in other window: ") (let ((pop-up-windows t)) ;; XEmacs: this used to have (selected-frame) as the third argument, ;; but this is obnoxious. If the user wants the buffer in a @@ -588,9 +746,26 @@ ;; Change documented above undone --mrb (pop-to-buffer buffer t (selected-frame)))) + ;(pop-to-buffer buffer t norecord))) + +;; FSF 21.2: +; (defun switch-to-buffer-other-frame (buffer &optional norecord) +; "Switch to buffer BUFFER in another frame. +; Optional second arg NORECORD non-nil means +; do not put this buffer at the front of the list of recently selected ones. + +; This uses the function `display-buffer' as a subroutine; see its +; documentation for additional customization information." +; (interactive "BSwitch to buffer in other frame: ") +; (let ((pop-up-frames t)) +; (pop-to-buffer buffer t norecord) +; (raise-frame (window-frame (selected-window))))) (defun switch-to-buffer-other-frame (buffer) - "Switch to buffer BUFFER in a newly-created frame." + "Switch to buffer BUFFER in a newly-created frame. + + This uses the function `display-buffer' as a subroutine; see its + documentation for additional customization information." (interactive "BSwitch to buffer in other frame: ") (let* ((name (get-frame-name-for-buffer buffer)) (frame (make-frame (if name @@ -658,7 +833,7 @@ (not (funcall buffers-tab-selection-function curbuf (car (buffer-list))))))))) -(defun find-file (filename &optional codesys) +(defun find-file (filename &optional codesys wildcards) "Edit file FILENAME. Switch to a buffer visiting file FILENAME, creating one if none already exists. Optional second argument specifies the coding system to use when @@ -682,63 +857,112 @@ 5. The coding system 'raw-text. See `insert-file-contents' for more details about how the process of -determining the coding system works." - (interactive "FFind file: \nZCoding system: ") +determining the coding system works. + +Interactively, or if WILDCARDS is non-nil in a call from Lisp, +expand wildcards (if any) and visit multiple files. Wildcard expansion +can be suppressed by setting `find-file-wildcards'." + (interactive (list (read-file-name "Find file: ") + (and current-prefix-arg + (read-coding-system "Coding system: ")) + t)) (if codesys (let ((coding-system-for-read (get-coding-system codesys))) - (switch-to-buffer (find-file-noselect filename))) - (switch-to-buffer (find-file-noselect filename)))) - -(defun find-file-other-window (filename &optional codesys) + (let ((value (find-file-noselect filename nil nil wildcards))) + (if (listp value) + (mapcar 'switch-to-buffer (nreverse value)) + (switch-to-buffer value)))) + (let ((value (find-file-noselect filename nil nil wildcards))) + (if (listp value) + (mapcar 'switch-to-buffer (nreverse value)) + (switch-to-buffer value))))) + +(defun find-file-other-window (filename &optional codesys wildcards) "Edit file FILENAME, in another window. May create a new window, or reuse an existing one. See the function `display-buffer'. Optional second argument specifies the coding system to use when decoding the file. Interactively, with a prefix argument, you will be prompted for the coding system." - (interactive "FFind file in other window: \nZCoding system: ") + (interactive (list (read-file-name "Find file in other window: ") + (and current-prefix-arg + (read-coding-system "Coding system: ")) + t)) (if codesys (let ((coding-system-for-read (get-coding-system codesys))) - (switch-to-buffer-other-window (find-file-noselect filename))) - (switch-to-buffer-other-window (find-file-noselect filename)))) - -(defun find-file-other-frame (filename &optional codesys) + (let ((value (find-file-noselect filename nil nil wildcards))) + (if (listp value) + (progn + (setq value (nreverse value)) + (switch-to-buffer-other-window (car value)) + (mapcar 'switch-to-buffer (cdr value))) + (switch-to-buffer-other-window value)))) + (let ((value (find-file-noselect filename nil nil wildcards))) + (if (listp value) + (progn + (setq value (nreverse value)) + (switch-to-buffer-other-window (car value)) + (mapcar 'switch-to-buffer (cdr value))) + (switch-to-buffer-other-window value))))) + +(defun find-file-other-frame (filename &optional codesys wildcards) "Edit file FILENAME, in a newly-created frame. Optional second argument specifies the coding system to use when decoding the file. Interactively, with a prefix argument, you will be prompted for the coding system." - (interactive "FFind file in other frame: \nZCoding system: ") + (interactive (list (read-file-name "Find file in other frame: ") + (and current-prefix-arg + (read-coding-system "Coding system: ")) + t)) (if codesys (let ((coding-system-for-read (get-coding-system codesys))) - (switch-to-buffer-other-frame (find-file-noselect filename))) - (switch-to-buffer-other-frame (find-file-noselect filename)))) - -(defun find-file-read-only (filename &optional codesys) + (let ((value (find-file-noselect filename nil nil wildcards))) + (if (listp value) + (progn + (setq value (nreverse value)) + (switch-to-buffer-other-frame (car value)) + (mapcar 'switch-to-buffer (cdr value))) + (switch-to-buffer-other-frame value)))) + (let ((value (find-file-noselect filename nil nil wildcards))) + (if (listp value) + (progn + (setq value (nreverse value)) + (switch-to-buffer-other-frame (car value)) + (mapcar 'switch-to-buffer (cdr value))) + (switch-to-buffer-other-frame value))))) + +(defun find-file-read-only (filename &optional codesys wildcards) "Edit file FILENAME but don't allow changes. Like \\[find-file] but marks buffer as read-only. Use \\[toggle-read-only] to permit editing. Optional second argument specifies the coding system to use when decoding the file. Interactively, with a prefix argument, you will be prompted for the coding system." - (interactive "fFind file read-only: \nZCoding system: ") + (interactive (list (read-file-name "Find file read-only: ") + (and current-prefix-arg + (read-coding-system "Coding system: ")) + t)) (if codesys (let ((coding-system-for-read (get-coding-system codesys))) - (find-file filename)) - (find-file filename)) + (find-file filename nil wildcards)) + (find-file filename nil wildcards)) (setq buffer-read-only t) (current-buffer)) -(defun find-file-read-only-other-window (filename &optional codesys) +(defun find-file-read-only-other-window (filename &optional codesys wildcards) "Edit file FILENAME in another window but don't allow changes. Like \\[find-file-other-window] but marks buffer as read-only. Use \\[toggle-read-only] to permit editing. Optional second argument specifies the coding system to use when decoding the file. Interactively, with a prefix argument, you will be prompted for the coding system." - (interactive "fFind file read-only other window: \nZCoding system: ") + (interactive (list (read-file-name "Find file read-only other window: ") + (and current-prefix-arg + (read-coding-system "Coding system: ")) + t)) (if codesys (let ((coding-system-for-read (get-coding-system codesys))) @@ -747,14 +971,17 @@ (setq buffer-read-only t) (current-buffer)) -(defun find-file-read-only-other-frame (filename &optional codesys) +(defun find-file-read-only-other-frame (filename &optional codesys wildcards) "Edit file FILENAME in another frame but don't allow changes. Like \\[find-file-other-frame] but marks buffer as read-only. Use \\[toggle-read-only] to permit editing. Optional second argument specifies the coding system to use when decoding the file. Interactively, with a prefix argument, you will be prompted for the coding system." - (interactive "fFind file read-only other frame: \nZCoding system: ") + (interactive (list (read-file-name "Find file read-only other frame: ") + (and current-prefix-arg + (read-coding-system "Coding system: ")) + t)) (if codesys (let ((coding-system-for-read (get-coding-system codesys))) @@ -836,7 +1063,7 @@ (rename-buffer oname)))) (or (eq (current-buffer) obuf) (kill-buffer obuf)))) - + (defun create-file-buffer (filename) "Create a suitably named buffer for visiting FILENAME, and return it. FILENAME (sans directory) is used unchanged if that name is free; @@ -859,7 +1086,7 @@ (defun abbreviate-file-name (filename &optional hack-homedir) "Return a version of FILENAME shortened using `directory-abbrev-alist'. -See documentation of variable `directory-abbrev-alist' for more information. +Type \\[describe-variable] directory-abbrev-alist RET for more information. If optional argument HACK-HOMEDIR is non-nil, then this also substitutes \"~\" for the user's home directory." (let ((handler (find-file-name-handler filename 'abbreviate-file-name))) @@ -938,31 +1165,240 @@ (setq found (car list)))) (setq list (cdr list))) found) - (let ((number (nthcdr 10 (file-attributes truename))) - (list (buffer-list)) found) + (let* ((attributes (file-attributes truename)) + (number (nthcdr 10 attributes)) + (list (buffer-list)) found) (and buffer-file-numbers-unique number (while (and (not found) list) - (save-excursion - (set-buffer (car list)) - (if (and buffer-file-number - (equal buffer-file-number number) + (with-current-buffer (car list) + (if (and buffer-file-name + (equal buffer-file-number number) ;; Verify this buffer's file number ;; still belongs to its file. (file-exists-p buffer-file-name) - (equal (nthcdr 10 (file-attributes buffer-file-name)) - number)) + (equal (file-attributes buffer-file-name) + attributes)) (setq found (car list)))) (setq list (cdr list)))) found)))) - + +(defcustom find-file-wildcards t + "*Non-nil means file-visiting commands should handle wildcards. +For example, if you specify `*.c', that would visit all the files +whose names match the pattern." + :group 'files +; :version "20.4" + :type 'boolean) + +(defcustom find-file-suppress-same-file-warnings nil + "*Non-nil means suppress warning messages for symlinked files. +When nil, Emacs prints a warning when visiting a file that is already +visited, but with a different name. Setting this option to t +suppresses this warning." + :group 'files +; :version "21.1" + :type 'boolean) + +(defun find-file-noselect (filename &optional nowarn rawfile wildcards) + "Read file FILENAME into a buffer and return the buffer. +If a buffer exists visiting FILENAME, return that one, but +verify that the file has not changed since visited or saved. +The buffer is not selected, just returned to the caller. +If NOWARN is non-nil, warning messages will be suppressed. +If RAWFILE is non-nil, the file is read literally." + (setq filename + (abbreviate-file-name + (expand-file-name filename))) + (if (file-directory-p filename) + (or (and find-file-run-dired + (loop for fn in find-directory-functions + for x = (and (fboundp fn) + (funcall fn + (if find-file-use-truenames + (abbreviate-file-name + (file-truename filename)) + filename))) + if x + return x)) + (error "%s is a directory" filename)) + (if (and wildcards + find-file-wildcards + (not (string-match "\\`/:" filename)) + (string-match "[[*?]" filename)) + (let ((files (condition-case nil + (file-expand-wildcards filename t) + (error (list filename)))) + (find-file-wildcards nil)) + (if (null files) + (find-file-noselect filename) + (mapcar #'find-file-noselect files))) + (let* ((buf (get-file-buffer filename)) + (truename (abbreviate-file-name (file-truename filename))) + (number (nthcdr 10 (file-attributes truename))) +; ;; Find any buffer for a file which has same truename. +; (other (and (not buf) (find-buffer-visiting filename))) + (error nil)) + +; ;; Let user know if there is a buffer with the same truename. +; (if other +; (progn +; (or nowarn +; find-file-suppress-same-file-warnings +; (string-equal filename (buffer-file-name other)) +; (message "%s and %s are the same file" +; filename (buffer-file-name other))) +; ;; Optionally also find that buffer. +; (if (or find-file-existing-other-name find-file-visit-truename) +; (setq buf other)))) + + (when (and buf + (or find-file-compare-truenames find-file-use-truenames) + (not find-file-suppress-same-file-warnings) + (not nowarn)) + (save-excursion + (set-buffer buf) + (if (not (string-equal buffer-file-name filename)) + (message "%s and %s are the same file (%s)" + filename buffer-file-name + buffer-file-truename)))) + + (if buf + (progn + (or nowarn + (verify-visited-file-modtime buf) + (cond ((not (file-exists-p filename)) + (error "File %s no longer exists!" filename)) + ;; Certain files should be reverted automatically + ;; if they have changed on disk and not in the buffer. + ((and (not (buffer-modified-p buf)) + (dolist (rx revert-without-query nil) + (when (string-match rx filename) + (return t)))) + (with-current-buffer buf + (message "Reverting file %s..." filename) + (revert-buffer t t) + (message "Reverting file %s... done" filename))) + ((yes-or-no-p + (if (string= (file-name-nondirectory filename) + (buffer-name buf)) + (format + (if (buffer-modified-p buf) + (gettext "File %s changed on disk. Discard your edits? ") + (gettext "File %s changed on disk. Reread from disk? ")) + (file-name-nondirectory filename)) + (format + (if (buffer-modified-p buf) + (gettext "File %s changed on disk. Discard your edits in %s? ") + (gettext "File %s changed on disk. Reread from disk into %s? ")) + (file-name-nondirectory filename) + (buffer-name buf)))) + (with-current-buffer buf + (revert-buffer t t))))) + (when (not (eq rawfile (not (null find-file-literally)))) + (with-current-buffer buf + (if (buffer-modified-p) + (if (y-or-n-p (if rawfile + "Save file and revisit literally? " + "Save file and revisit non-literally? ")) + (progn + (save-buffer) + (find-file-noselect-1 buf filename nowarn + rawfile truename number)) + (if (y-or-n-p (if rawfile + "Discard your edits and revisit file literally? " + "Discard your edits and revisit file non-literally? ")) + (find-file-noselect-1 buf filename nowarn + rawfile truename number) + (error (if rawfile "File already visited non-literally" + "File already visited literally")))) + (if (y-or-n-p (if rawfile + "Revisit file literally? " + "Revisit file non-literally? ")) + (find-file-noselect-1 buf filename nowarn + rawfile truename number) + (error (if rawfile "File already visited non-literally" + "File already visited literally")))))) + ;; Return the buffer we are using. + buf) + ;; Create a new buffer. + (setq buf (create-file-buffer filename)) + ;; Catch various signals, such as QUIT, and kill the buffer + ;; in that case. + (condition-case data + (progn + (set-buffer-major-mode buf) + ;; find-file-noselect-1 may use a different buffer. + (find-file-noselect-1 buf filename nowarn + rawfile truename number)) + (t + (kill-buffer buf) + (signal (car data) (cdr data))))))))) + +(defun find-file-noselect-1 (buf filename nowarn rawfile truename number) + (let ((inhibit-read-only t) + error) + (with-current-buffer buf + (kill-local-variable 'find-file-literally) + ;; Needed in case we are re-visiting the file with a different + ;; text representation. + (kill-local-variable 'buffer-file-coding-system) + (erase-buffer) +; (and (default-value 'enable-multibyte-characters) +; (not rawfile) +; (set-buffer-multibyte t)) + (condition-case () + (if rawfile + (insert-file-contents-literally filename t) + (insert-file-contents filename t)) + (file-error + (when (and (file-exists-p filename) + (not (file-readable-p filename))) + (signal 'file-error (list "File is not readable" filename))) + (if rawfile + ;; Unconditionally set error + (setq error t) + (or + ;; Run find-file-not-found-hooks until one returns non-nil. + (run-hook-with-args-until-success 'find-file-not-found-hooks) + ;; If they fail too, set error. + (setq error t))))) + ;; Find the file's truename, and maybe use that as visited name. + ;; automatically computed in XEmacs, unless jka-compr was used! + (unless buffer-file-truename + (setq buffer-file-truename truename)) + (setq buffer-file-number number) + (and find-file-use-truenames + ;; This should be in C. Put pathname + ;; abbreviations that have been explicitly + ;; requested back into the pathname. Most + ;; importantly, strip out automounter /tmp_mnt + ;; directories so that auto-save will work + (setq buffer-file-name (abbreviate-file-name buffer-file-name))) + ;; Set buffer's default directory to that of the file. + (setq default-directory (file-name-directory buffer-file-name)) + ;; Turn off backup files for certain file names. Since + ;; this is a permanent local, the major mode won't eliminate it. + (and (not (funcall backup-enable-predicate buffer-file-name)) + (progn + (make-local-variable 'backup-inhibited) + (setq backup-inhibited t))) + (if rawfile + (progn + (setq buffer-file-coding-system 'no-conversion) + (make-local-variable 'find-file-literally) + (setq find-file-literally t)) + (after-find-file error (not nowarn)) + (setq buf (current-buffer))) + (current-buffer)))) + (defun insert-file-contents-literally (filename &optional visit start end replace) - "Like `insert-file-contents', q.v., but only reads in the file. -A buffer may be modified in several ways after reading into the buffer due -to advanced Emacs features, such as format decoding, character code -conversion, find-file-hooks, automatic uncompression, etc. - - This function ensures that none of these modifications will take place." + "Like `insert-file-contents', but only reads in the file literally. +A buffer may be modified in several ways after reading into the buffer, +due to Emacs features such as format decoding, character code +conversion, `find-file-hooks', automatic uncompression, etc. + +This function ensures that none of these modifications will take place." (let ((wrap-func (find-file-name-handler filename 'insert-file-contents-literally))) (if wrap-func @@ -976,7 +1412,9 @@ (find-buffer-file-type-function (if (fboundp 'find-buffer-file-type) (symbol-function 'find-buffer-file-type) - nil))) + nil)) + (inhibit-file-name-handlers '(jka-compr-handler image-file-handler)) + (inhibit-file-name-operation 'insert-file-contents)) (unwind-protect (progn (fset 'find-buffer-file-type (lambda (filename) t)) @@ -985,150 +1423,44 @@ (fset 'find-buffer-file-type find-buffer-file-type-function) (fmakunbound 'find-buffer-file-type))))))) -(defun find-file-noselect (filename &optional nowarn rawfile) - "Read file FILENAME into a buffer and return the buffer. -If a buffer exists visiting FILENAME, return that one, but -verify that the file has not changed since visited or saved. -The buffer is not selected, just returned to the caller. -If NOWARN is non-nil, warning messages will be suppressed. -If RAWFILE is non-nil, the file is read literally." - (setq filename (abbreviate-file-name (expand-file-name filename))) +(defun insert-file-literally (filename) + "Insert contents of file FILENAME into buffer after point with no conversion. + +This function is meant for the user to run interactively. +Don't call it from programs! Use `insert-file-contents-literally' instead. +\(Its calling sequence is different; see its documentation)." + (interactive "*fInsert file literally: ") (if (file-directory-p filename) - (if (and (fboundp 'dired-noselect) find-file-run-dired) - (declare-fboundp - (dired-noselect (if find-file-use-truenames - (abbreviate-file-name (file-truename filename)) - filename))) - (error "%s is a directory" filename)) - (let* ((buf (get-file-buffer filename)) - (truename (abbreviate-file-name (file-truename filename))) - (number (nthcdr 10 (file-attributes truename))) -; ;; Find any buffer for a file which has same truename. -; (other (and (not buf) (find-buffer-visiting filename))) - (error nil)) - -; ;; Let user know if there is a buffer with the same truename. -; (if (and (not buf) same-truename (not nowarn)) -; (message "%s and %s are the same file (%s)" -; filename (buffer-file-name same-truename) -; truename) -; (if (and (not buf) same-number (not nowarn)) -; (message "%s and %s are the same file" -; filename (buffer-file-name same-number)))) -; ;; Optionally also find that buffer. -; (if (or find-file-existing-other-name find-file-visit-truename) -; (setq buf (or same-truename same-number))) - - (when (and buf - (or find-file-compare-truenames find-file-use-truenames) - (not nowarn)) - (save-excursion - (set-buffer buf) - (if (not (string-equal buffer-file-name filename)) - (message "%s and %s are the same file (%s)" - filename buffer-file-name - buffer-file-truename)))) - - (if buf - (or nowarn - (verify-visited-file-modtime buf) - (cond ((not (file-exists-p filename)) - (error "File %s no longer exists!" filename)) - ;; Certain files should be reverted automatically - ;; if they have changed on disk and not in the buffer. - ((and (not (buffer-modified-p buf)) - (dolist (rx revert-without-query nil) - (when (string-match rx filename) - (return t)))) - (with-current-buffer buf - (message "Reverting file %s..." filename) - (revert-buffer t t) - (message "Reverting file %s... done" filename))) - ((yes-or-no-p - (if (string= (file-name-nondirectory filename) - (buffer-name buf)) - (format - (if (buffer-modified-p buf) - (gettext "File %s changed on disk. Discard your edits? ") - (gettext "File %s changed on disk. Reread from disk? ")) - (file-name-nondirectory filename)) - (format - (if (buffer-modified-p buf) - (gettext "File %s changed on disk. Discard your edits in %s? ") - (gettext "File %s changed on disk. Reread from disk into %s? ")) - (file-name-nondirectory filename) - (buffer-name buf)))) - (with-current-buffer buf - (revert-buffer t t))))) - ;; Else: we must create a new buffer for filename - (save-excursion -;;; The truename stuff makes this obsolete. -;;; (let* ((link-name (car (file-attributes filename))) -;;; (linked-buf (and (stringp link-name) -;;; (get-file-buffer link-name)))) -;;; (if (bufferp linked-buf) -;;; (message "Symbolic link to file in buffer %s" -;;; (buffer-name linked-buf)))) - (setq buf (create-file-buffer filename)) - ;; Catch various signals, such as QUIT, and kill the buffer - ;; in that case. - (condition-case data - (progn - (set-buffer-major-mode buf) - (set-buffer buf) - (erase-buffer) - (condition-case () - (if rawfile - (insert-file-contents-literally filename t) - (insert-file-contents filename t)) - (file-error - (when (and (file-exists-p filename) - (not (file-readable-p filename))) - (signal 'file-error (list "File is not readable" filename))) - (if rawfile - ;; Unconditionally set error - (setq error t) - (or - ;; Run find-file-not-found-hooks until one returns non-nil. - (run-hook-with-args-until-success 'find-file-not-found-hooks) - ;; If they fail too, set error. - (setq error t))))) - ;; Find the file's truename, and maybe use that as visited name. - ;; automatically computed in XEmacs, unless jka-compr was used! - (unless buffer-file-truename - (setq buffer-file-truename truename)) - (setq buffer-file-number number) - (and find-file-use-truenames - ;; This should be in C. Put pathname - ;; abbreviations that have been explicitly - ;; requested back into the pathname. Most - ;; importantly, strip out automounter /tmp_mnt - ;; directories so that auto-save will work - (setq buffer-file-name (abbreviate-file-name buffer-file-name))) - ;; Set buffer's default directory to that of the file. - (setq default-directory (file-name-directory buffer-file-name)) - ;; Turn off backup files for certain file names. Since - ;; this is a permanent local, the major mode won't eliminate it. - (and (not (funcall backup-enable-predicate buffer-file-name)) - (progn - (make-local-variable 'backup-inhibited) - (setq backup-inhibited t))) - (if rawfile - ;; #### FSF 20.3 sets buffer-file-coding-system to - ;; `no-conversion' here. Should we copy? It also - ;; makes `find-file-literally' a local variable - ;; and sets it to t. - nil - (after-find-file error (not nowarn)) - (setq buf (current-buffer)))) - (t - (kill-buffer buf) - (signal (car data) (cdr data)))) - )) - buf))) + (signal 'file-error (list "Opening input file" "file is a directory" + filename))) + (let ((tem (insert-file-contents-literally filename))) + (push-mark (+ (point) (car (cdr tem)))))) + +(defvar find-file-literally nil + "Non-nil if this buffer was made by `find-file-literally' or equivalent. +This is a permanent local.") +(put 'find-file-literally 'permanent-local t) + +(defun find-file-literally (filename) + "Visit file FILENAME with no conversion of any kind. +Format conversion and character code conversion are both disabled, +and multibyte characters are disabled in the resulting buffer. +The major mode used is Fundamental mode regardless of the file name, +and local variable specifications in the file are ignored. +Automatic uncompression and adding a newline at the end of the +file due to `require-final-newline' is also disabled. + +You cannot absolutely rely on this function to result in +visiting the file literally. If Emacs already has a buffer +which is visiting the file, you get the existing buffer, +regardless of whether it was created literally or not. + +In a Lisp program, if you want to be sure of accessing a file's +contents literally, you should create a temporary buffer and then read +the file contents into it using `insert-file-contents-literally'." + (interactive "FFind file literally: ") + (switch-to-buffer (find-file-noselect filename nil t))) -;; FSF has `insert-file-literally' and `find-file-literally' here. - (defvar after-find-file-from-revert-buffer nil) (defun after-find-file (&optional error warn noauto @@ -1143,59 +1475,73 @@ Fourth arg AFTER-FIND-FILE-FROM-REVERT-BUFFER non-nil means this call was from `revert-buffer'. Fifth arg NOMODES non-nil means don't alter the file's modes. -Finishes by calling the functions in `find-file-hooks'." +Finishes by calling the functions in `find-file-hooks' +unless NOMODES is non-nil." (setq buffer-read-only (not (file-writable-p buffer-file-name))) (if noninteractive nil (let* (not-serious (msg - (cond ((and error (file-attributes buffer-file-name)) - (setq buffer-read-only t) - (gettext "File exists, but cannot be read.")) - ((not buffer-read-only) - (if (and warn - (file-newer-than-file-p (make-auto-save-file-name) - buffer-file-name)) - (format "%s has auto save data; consider M-x recover-file" - (file-name-nondirectory buffer-file-name)) - (setq not-serious t) - (if error (gettext "(New file)") nil))) - ((not error) - (setq not-serious t) - (gettext "Note: file is write protected")) - ((file-attributes (directory-file-name default-directory)) - (gettext "File not found and directory write-protected")) - ((file-exists-p (file-name-directory buffer-file-name)) - (setq buffer-read-only nil)) - (t - ;; If the directory the buffer is in doesn't exist, - ;; offer to create it. It's better to do this now - ;; than when we save the buffer, because we want - ;; autosaving to work. - (setq buffer-read-only nil) - ;; XEmacs - (or (file-exists-p (file-name-directory buffer-file-name)) - (condition-case nil - (if (yes-or-no-p - (format - "\ + (cond + ((not warn) nil) + ((and error (file-attributes buffer-file-name)) + (setq buffer-read-only t) + (gettext "File exists, but cannot be read.")) + ((not buffer-read-only) + (if (and warn + (file-newer-than-file-p (make-auto-save-file-name) + buffer-file-name)) + (format "%s has auto save data; consider M-x recover-file" + (file-name-nondirectory buffer-file-name)) + (setq not-serious t) + (if error (gettext "(New file)") nil))) + ((not error) + (setq not-serious t) + (gettext "Note: file is write protected")) + ((file-attributes (directory-file-name default-directory)) + (gettext "File not found and directory write-protected")) + ((file-exists-p (file-name-directory buffer-file-name)) + (setq buffer-read-only nil)) + (t + ;; If the directory the buffer is in doesn't exist, + ;; offer to create it. It's better to do this now + ;; than when we save the buffer, because we want + ;; autosaving to work. + (setq buffer-read-only nil) + ;; XEmacs + (or (file-exists-p (file-name-directory buffer-file-name)) + (condition-case nil + (if (yes-or-no-p + (format + "\ The directory containing %s does not exist. Create? " - (abbreviate-file-name buffer-file-name))) - (make-directory (file-name-directory - buffer-file-name) - t)) - (quit - (kill-buffer (current-buffer)) - (signal 'quit nil)))) - nil)))) + (abbreviate-file-name buffer-file-name))) + (make-directory (file-name-directory + buffer-file-name) + t)) + (quit + (kill-buffer (current-buffer)) + (signal 'quit nil)))) + nil)))) (if msg (progn (message "%s" msg) (or not-serious (sit-for 1 t))))) - (if (and auto-save-default (not noauto)) + (when (and auto-save-default (not noauto)) (auto-save-mode t))) + ;; Make people do a little extra work (C-x C-q) + ;; before altering a backup file. + (when (backup-file-name-p buffer-file-name) + (setq buffer-read-only t)) (unless nomodes + ;; #### No view-mode-disable. +; (when view-read-only +; (and-boundp 'view-mode (view-mode-disable))) (normal-mode t) + (when (and buffer-read-only + view-read-only + (not (eq (get major-mode 'mode-class) 'special))) + (view-mode)) (run-hooks 'find-file-hooks))) (defun normal-mode (&optional find-file) @@ -1204,10 +1550,15 @@ Uses the visited file name, the -*- line, and the local variables spec. This function is called automatically from `find-file'. In that case, -we may set up specified local variables depending on the value of -`enable-local-variables': if it is t, we do; if it is nil, we don't; -otherwise, we query. `enable-local-variables' is ignored if you -run `normal-mode' explicitly." +we may set up the file-specified mode and local variables, +depending on the value of `enable-local-variables': if it is t, we do; +if it is nil, we don't; otherwise, we query. +In addition, if `local-enable-local-variables' is nil, we do +not set local variables (though we do notice a mode specified with -*-.) + +`enable-local-variables' is ignored if you run `normal-mode' interactively, +or from Lisp without specifying the optional argument FIND-FILE; +in that case, this function acts as if `enable-local-variables' were t." (interactive) (or find-file (funcall (or default-major-mode 'fundamental-mode))) (and (with-trapping-errors @@ -1220,8 +1571,14 @@ :operation "File local-variables" :class 'local-variables :error-form nil + ;; FSF 21.2: +; (let ((enable-local-variables (or (not find-file) +; enable-local-variables))) +; (hack-local-variables)) (hack-local-variables (not find-file))))) +;; END SYNC WITH FSF 21.2. + ;; `auto-mode-alist' used to contain entries for modes in core and in packages. ;; The applicable entries are now located in the corresponding modes in ;; packages, the ones here are for core modes. Ditto for @@ -1307,6 +1664,19 @@ When checking `inhibit-first-line-modes-regexps', we first discard from the end of the file name anything that matches one of these regexps.") +;; Junk from FSF 21.2. Unnecessary in XEmacs, since `interpreter-mode-alist' +;; can have regexps. +; (defvar auto-mode-interpreter-regexp +; "#![ \t]?\\([^ \t\n]*\ +; /bin/env[ \t]\\)?\\([^ \t\n]+\\)" +; "Regular expression matching interpreters, for file mode determination. +; This regular expression is matched against the first line of a file +; to determine the file's mode in `set-auto-mode' when Emacs can't deduce +; a mode from the file's name. If it matches, the file is assumed to +; be interpreted by the interpreter matched by the second group of the +; regular expression. The mode is then determined as the mode associated +; with that interpreter in `interpreter-mode-alist'.") + (defvar user-init-file nil ; set by command-line "File name including directory of user's initialization file.") @@ -1639,6 +2009,8 @@ (setq result (cdr result))) mode-p))) +;; BEGIN SYNC WITH FSF 21.2. + (defconst ignored-local-variables (list 'enable-local-eval) "Variables to be ignored in a file's local variable spec.") @@ -1658,6 +2030,8 @@ (put 'load-path 'risky-local-variable t) (put 'exec-directory 'risky-local-variable t) (put 'process-environment 'risky-local-variable t) +(put 'dabbrev-case-fold-search 'risky-local-variable t) +(put 'dabbrev-case-replace 'risky-local-variable t) ;; Don't wait for outline.el to be loaded, for the sake of outline-minor-mode. (put 'outline-level 'risky-local-variable t) (put 'rmail-output-file-alist 'risky-local-variable t) @@ -1665,53 +2039,59 @@ ;; This one is safe because the user gets to check it before it is used. (put 'compile-command 'safe-local-variable t) -;(defun hack-one-local-variable-quotep (exp) -; (and (consp exp) (eq (car exp) 'quote) (consp (cdr exp)))) - -;; "Set" one variable in a local variables spec. -;; A few variable names are treated specially. +(defun hack-one-local-variable-quotep (exp) + (and (consp exp) (eq (car exp) 'quote) (consp (cdr exp)))) + (defun hack-one-local-variable (var val) + "\"Set\" one variable in a local variables spec. +A few variable names are treated specially." (cond ((eq var 'mode) (funcall (intern (concat (downcase (symbol-name val)) "-mode")))) + ((eq var 'coding) + ;; We have already handled coding: tag in set-auto-coding. + nil) ((memq var ignored-local-variables) nil) ;; "Setting" eval means either eval it or do nothing. ;; Likewise for setting hook variables. ((or (get var 'risky-local-variable) (and - (string-match "-hooks?$\\|-functions?$\\|-forms?$\\|-program$\\|-command$" + (string-match "-hooks?$\\|-functions?$\\|-forms?$\\|-program$\\|-command$\\|-predicate$" (symbol-name var)) (not (get var 'safe-local-variable)))) -; ;; Permit evaling a put of a harmless property -; ;; if the args do nothing tricky. -; (if (or (and (eq var 'eval) -; (consp val) -; (eq (car val) 'put) -; (hack-one-local-variable-quotep (nth 1 val)) -; (hack-one-local-variable-quotep (nth 2 val)) -; ;; Only allow safe values of lisp-indent-hook; -; ;; not functions. -; (or (numberp (nth 3 val)) -; (equal (nth 3 val) ''defun)) -; (memq (nth 1 (nth 2 val)) -; '(lisp-indent-hook))) - (if (and (not (zerop (user-uid))) - (or (eq enable-local-eval t) - (and enable-local-eval - (save-window-excursion - (switch-to-buffer (current-buffer)) - (save-excursion - (beginning-of-line) - (set-window-start (selected-window) (point))) - (setq enable-local-eval - (y-or-n-p (format "Process `eval' or hook local variables in file %s? " - (file-name-nondirectory buffer-file-name)))))))) + ;; Permit evalling a put of a harmless property. + ;; if the args do nothing tricky. + (if (or (and (eq var 'eval) + (consp val) + (eq (car val) 'put) + (hack-one-local-variable-quotep (nth 1 val)) + (hack-one-local-variable-quotep (nth 2 val)) + ;; Only allow safe values of lisp-indent-hook; + ;; not functions. + (or (numberp (nth 3 val)) + (equal (nth 3 val) ''defun)) + (memq (nth 1 (nth 2 val)) + '(lisp-indent-hook))) + ;; Permit eval if not root and user says ok. + (and (not (zerop (user-uid))) + (or (eq enable-local-eval t) + (and enable-local-eval + (save-window-excursion + (switch-to-buffer (current-buffer)) + (save-excursion + (beginning-of-line) + (set-window-start (selected-window) (point))) + (setq enable-local-eval + (y-or-n-p (format "Process `eval' or hook local variables in %s? " + (if buffer-file-name + (concat "file " (file-name-nondirectory buffer-file-name)) + (concat "buffer " (buffer-name))))))))))) (if (eq var 'eval) (save-excursion (eval val)) (make-local-variable var) (set var val)) - (message "Ignoring `eval:' in file's local variables"))) + (message "Ignoring `eval:' in the local variables list"))) ;; Ordinary variable, really set it. (t (make-local-variable var) (set var val)))) @@ -1762,6 +2142,7 @@ ))) )))) + (defcustom change-major-mode-with-file-name t "*Non-nil means \\[write-file] should set the major mode from the file name. However, the mode will not be changed if @@ -1882,17 +2263,23 @@ (hack-local-variables t) (set-auto-mode t)) (error nil)) - ;; #### ?? + ;; #### ?? not in FSF. (run-hooks 'after-set-visited-file-name-hooks)) (defun write-file (filename &optional confirm codesys) "Write current buffer into file FILENAME. -Makes buffer visit that file, and marks it not modified. If the buffer is -already visiting a file, you can specify a directory name as FILENAME, to -write a file of the same old name in that directory. - -If optional second arg CONFIRM is non-nil, ask for confirmation for -overwriting an existing file. +This makes the buffer visit that file, and marks it as not modified. + +If you specify just a directory name as FILENAME, that means to use +the default file name but in that directory. You can also yank +the default file name into the minibuffer to edit it, using M-n. + +If the buffer is not already visiting a file, the default file name +for the output file is the buffer name. + +If optional second arg CONFIRM is non-nil, this function +asks for confirmation before overwriting an existing file. +Interactively, this is always the case. Optional third argument specifies the coding system to use when encoding the file. Interactively, with a prefix argument, you will be prompted for @@ -1902,10 +2289,11 @@ (list (if buffer-file-name (read-file-name "Write file: " nil nil nil nil) - (read-file-name "Write file: " - (cdr (assq 'default-directory - (buffer-local-variables))) - nil nil (buffer-name))) + (read-file-name "Write file: " default-directory + (expand-file-name + (file-name-nondirectory (buffer-name)) + default-directory) + nil nil)) t (if current-prefix-arg (read-coding-system "Coding system: ")))) (and (eq (current-buffer) mouse-grabbed-buffer) @@ -1913,28 +2301,37 @@ (or (null filename) (string-equal filename "") (progn ;; If arg is just a directory, - ;; use same file name, but in that directory. - (if (and (file-directory-p filename) buffer-file-name) + ;; use the default file name, but in that directory. + (if (file-directory-p filename) (setq filename (concat (file-name-as-directory filename) - (file-name-nondirectory buffer-file-name)))) + (file-name-nondirectory + (or buffer-file-name (buffer-name)))))) (and confirm (file-exists-p filename) (or (y-or-n-p (format "File `%s' exists; overwrite? " filename)) (error "Canceled"))) - (set-visited-file-name filename))) + (set-visited-file-name filename (not confirm)))) (set-buffer-modified-p t) - (setq buffer-read-only nil) + ;; Make buffer writable if file is writable. + (and buffer-file-name + (file-writable-p buffer-file-name) + (setq buffer-read-only nil)) (if codesys (let ((buffer-file-coding-system (get-coding-system codesys))) (save-buffer)) (save-buffer))) + (defun backup-buffer () "Make a backup of the disk file visited by the current buffer, if appropriate. This is normally done before saving the buffer the first time. -If the value is non-nil, it is the result of `file-modes' on the original file; -this means that the caller, after saving the buffer, should change the modes -of the new file to agree with the old modes." +If the value is non-nil, it is the result of `file-modes' on the original +file; this means that the caller, after saving the buffer, should change +the modes of the new file to agree with the old modes. + +A backup may be done by renaming or by copying; see documentation of +variable `make-backup-files'. If it's done by renaming, then the file is +no longer accessible under its old name." (if buffer-file-name (let ((handler (find-file-name-handler buffer-file-name 'backup-buffer))) (if handler @@ -1974,10 +2371,15 @@ backup-by-copying (and backup-by-copying-when-linked (> (file-nlinks real-file-name) 1)) - (and backup-by-copying-when-mismatch + (and (or backup-by-copying-when-mismatch + (integerp backup-by-copying-when-privileged-mismatch)) (let ((attr (file-attributes real-file-name))) - (or (nth 9 attr) - (not (file-ownership-preserved-p real-file-name)))))) + (and (or backup-by-copying-when-mismatch + (and (integerp (nth 2 attr)) + (integerp backup-by-copying-when-privileged-mismatch) + (<= (nth 2 attr) backup-by-copying-when-privileged-mismatch))) + (or (nth 9 attr) + (not (file-ownership-preserved-p real-file-name))))))) (condition-case () (copy-file real-file-name backupname t t) (file-error @@ -1995,7 +2397,8 @@ (setq backupname (expand-file-name (convert-standard-filename "~/%backup%~"))) - (lwarn 'file 'alert "Cannot write backup file; backing up in ~/%%backup%%~") + (lwarn 'file 'alert "Cannot write backup file; backing up in %s" + (file-name-nondirectory backupname)) (sleep-for 1) (condition-case () (copy-file real-file-name backupname t t) @@ -2077,11 +2480,113 @@ (if period ""))))) +(defcustom make-backup-file-name-function nil + "A function to use instead of the default `make-backup-file-name'. +A value of nil gives the default `make-backup-file-name' behaviour. + +This could be buffer-local to do something special for specific +files. If you define it, you may need to change `backup-file-name-p' +and `file-name-sans-versions' too. + +See also `backup-directory-alist'." + :group 'backup + :type '(choice (const :tag "Default" nil) + (function :tag "Your function"))) + +(defcustom backup-directory-alist nil + "Alist of filename patterns and backup directory names. +Each element looks like (REGEXP . DIRECTORY). Backups of files with +names matching REGEXP will be made in DIRECTORY. DIRECTORY may be +relative or absolute. If it is absolute, so that all matching files +are backed up into the same directory, the file names in this +directory will be the full name of the file backed up with all +directory separators changed to `!' to prevent clashes. This will not +work correctly if your filesystem truncates the resulting name. + +For the common case of all backups going into one directory, the alist +should contain a single element pairing \".\" with the appropriate +directory name. + +If this variable is nil, or it fails to match a filename, the backup +is made in the original file's directory. + +On MS-DOS filesystems without long names this variable is always +ignored." + :group 'backup + :type '(repeat (cons (regexp :tag "Regexp matching filename") + (directory :tag "Backup directory name")))) + (defun make-backup-file-name (file) "Create the non-numeric backup file name for FILE. -This is a separate function so you can redefine it for customization." - ;; FSF has code here for MS-DOS short filenames, not supported in XEmacs. - (concat file "~")) +Normally this will just be the file's name with `~' appended. +Customization hooks are provided as follows. + +If the variable `make-backup-file-name-function' is non-nil, its value +should be a function which will be called with FILE as its argument; +the resulting name is used. + +Otherwise a match for FILE is sought in `backup-directory-alist'; see +the documentation of that variable. If the directory for the backup +doesn't exist, it is created." + (if make-backup-file-name-function + (funcall make-backup-file-name-function file) +; (if (and (eq system-type 'ms-dos) +; (not (msdos-long-file-names))) +; (let ((fn (file-name-nondirectory file))) +; (concat (file-name-directory file) +; (or (and (string-match "\\`[^.]+\\'" fn) +; (concat (match-string 0 fn) ".~")) +; (and (string-match "\\`[^.]+\\.\\(..?\\)?" fn) +; (concat (match-string 0 fn) "~"))))) + (concat (make-backup-file-name-1 file) "~"))) + +(defun make-backup-file-name-1 (file) + "Subroutine of `make-backup-file-name' and `find-backup-file-name'." + (let ((alist backup-directory-alist) + elt backup-directory dir-sep-string) + (while alist + (setq elt (pop alist)) + (if (string-match (car elt) file) + (setq backup-directory (cdr elt) + alist nil))) + (if (null backup-directory) + file + (unless (file-exists-p backup-directory) + (condition-case nil + (make-directory backup-directory 'parents) + (file-error file))) + (if (file-name-absolute-p backup-directory) + (progn + (when (memq system-type '(windows-nt ms-dos)) + ;; Normalize DOSish file names: convert all slashes to + ;; directory-sep-char, downcase the drive letter, if any, + ;; and replace the leading "x:" with "/drive_x". + (or (file-name-absolute-p file) + (setq file (expand-file-name file))) ; make defaults explicit + ;; Replace any invalid file-name characters (for the + ;; case of backing up remote files). + (setq file (expand-file-name (convert-standard-filename file))) + (setq dir-sep-string (char-to-string directory-sep-char)) + (if (eq (aref file 1) ?:) + (setq file (concat dir-sep-string + "drive_" + (char-to-string (downcase (aref file 0))) + (if (eq (aref file 2) directory-sep-char) + "" + dir-sep-string) + (substring file 2))))) + ;; Make the name unique by substituting directory + ;; separators. It may not really be worth bothering about + ;; doubling `!'s in the original name... + (expand-file-name + (subst-char-in-string + directory-sep-char ?! + (replace-regexp-in-string "!" "!!" file)) + backup-directory)) + (expand-file-name (file-name-nondirectory file) + (file-name-as-directory + (expand-file-name backup-directory + (file-name-directory file)))))))) (defun backup-file-name-p (file) "Return non-nil if FILE is a backup file name (numeric or not). @@ -2089,64 +2594,72 @@ You may need to redefine `file-name-sans-versions' as well." (string-match "~\\'" file)) +(defvar backup-extract-version-start) + ;; This is used in various files. -;; The usage of bv-length is not very clean, -;; but I can't see a good alternative, -;; so as of now I am leaving it alone. +;; The usage of backup-extract-version-start is not very clean, +;; but I can't see a good alternative, so as of now I am leaving it alone. (defun backup-extract-version (fn) - "Given the name of a numeric backup file, return the backup number. -Uses the free variable `bv-length', whose value should be + "Given the name of a numeric backup file, FN, return the backup number. +Uses the free variable `backup-extract-version-start', whose value should be the index in the name where the version number begins." - (declare (special bv-length)) - (if (and (string-match "[0-9]+~\\'" fn bv-length) - (= (match-beginning 0) bv-length)) - (string-to-int (substring fn bv-length -1)) + (if (and (string-match "[0-9]+~$" fn backup-extract-version-start) + (= (match-beginning 0) backup-extract-version-start)) + (string-to-int (substring fn backup-extract-version-start -1)) 0)) +;; [[ FSF 21.2 says: +;; I believe there is no need to alter this behavior for VMS; +;; since backup files are not made on VMS, it should not get called. ]] (defun find-backup-file-name (fn) - "Find a file name for a backup file, and suggestions for deletions. + "Find a file name for a backup file FN, and suggestions for deletions. Value is a list whose car is the name for the backup file - and whose cdr is a list of old versions to consider deleting now. -If the value is nil, don't make a backup." - (declare (special bv-length)) +and whose cdr is a list of old versions to consider deleting now. +If the value is nil, don't make a backup. +Uses `backup-directory-alist' in the same way as does +`make-backup-file-name'." (let ((handler (find-file-name-handler fn 'find-backup-file-name))) ;; Run a handler for this function so that ange-ftp can refuse to do it. (if handler (funcall handler 'find-backup-file-name fn) - (if (eq version-control 'never) + (if (or (eq version-control 'never) + ;; We don't support numbered backups on plain MS-DOS + ;; when long file names are unavailable. +; (and (eq system-type 'ms-dos) +; (not (msdos-long-file-names))) + ) (list (make-backup-file-name fn)) - (let* ((base-versions (concat (file-name-nondirectory fn) ".~")) - ;; used by backup-extract-version: - (bv-length (length base-versions)) - possibilities - (versions nil) + (let* ((basic-name (make-backup-file-name-1 fn)) + (base-versions (concat (file-name-nondirectory basic-name) + ".~")) + (backup-extract-version-start (length base-versions)) (high-water-mark 0) - (deserve-versions-p nil) - (number-to-delete 0)) + (number-to-delete 0) + possibilities deserve-versions-p versions) (condition-case () (setq possibilities (file-name-all-completions base-versions - (file-name-directory fn)) - versions (sort (mapcar - #'backup-extract-version - possibilities) - '<) - high-water-mark (apply #'max 0 versions) + (file-name-directory basic-name)) + versions (sort (mapcar #'backup-extract-version + possibilities) + #'<) + high-water-mark (apply 'max 0 versions) deserve-versions-p (or version-control (> high-water-mark 0)) number-to-delete (- (length versions) - kept-old-versions kept-new-versions -1)) - (file-error - (setq possibilities nil))) + kept-old-versions + kept-new-versions + -1)) + (file-error (setq possibilities nil))) (if (not deserve-versions-p) (list (make-backup-file-name fn)) - (cons (concat fn ".~" (int-to-string (1+ high-water-mark)) "~") + (cons (format "%s.~%d~" basic-name (1+ high-water-mark)) (if (and (> number-to-delete 0) ;; Delete nothing if there is overflow ;; in the number of versions to keep. (>= (+ kept-new-versions kept-old-versions -1) 0)) - (mapcar #'(lambda (n) - (concat fn ".~" (int-to-string n) "~")) + (mapcar (lambda (n) + (format "%s.~%d~" basic-name n)) (let ((v (nthcdr kept-old-versions versions))) (rplacd (nthcdr (1- number-to-delete) v) ()) v)))))))))) @@ -2156,7 +2669,7 @@ (car (cdr (file-attributes filename)))) (defun file-relative-name (filename &optional directory) - "Convert FILENAME to be relative to DIRECTORY (default: default-directory). + "Convert FILENAME to be relative to DIRECTORY (default: `default-directory'). This function returns a relative file name which is equivalent to FILENAME when used with that default directory as the default. If this is impossible (which can happen on MS Windows when the file name @@ -2195,14 +2708,17 @@ (defun save-buffer (&optional args) "Save current buffer in visited file if modified. Versions described below. - By default, makes the previous version into a backup file if previously requested or if this is the first save. -With 1 or 3 \\[universal-argument]'s, marks this version +With 1 \\[universal-argument], marks this version to become a backup when the next save is done. -With 2 or 3 \\[universal-argument]'s, +With 2 \\[universal-argument]'s, unconditionally makes the previous version into a backup file. -With argument of 0, never makes the previous version into a backup file. +With 3 \\[universal-argument]'s, marks this version + to become a backup when the next save is done, + and unconditionally makes the previous version into a backup file. + +With argument of 0, never make the previous version into a backup file. If a file's name is FOO, the names of its numbered backup versions are FOO.~i~ for various integers i. A non-numbered backup file is called FOO~. @@ -2211,28 +2727,34 @@ numeric versions of the file being backed up, or `version-control' is non-nil. We don't want excessive versions piling up, so there are variables - `kept-old-versions', which tells XEmacs how many oldest versions to keep, + `kept-old-versions', which tells Emacs how many oldest versions to keep, and `kept-new-versions', which tells how many newest versions to keep. Defaults are 2 old versions and 2 new. `dired-kept-versions' controls dired's clean-directory (.) command. If `delete-old-versions' is nil, system will query user - before trimming versions. Otherwise it does it silently." + before trimming versions. Otherwise it does it silently. + +If `vc-make-backup-files' is nil, which is the default, + no backup files are made for files managed by version control. + (This is because the version control system itself records previous versions.) + +See the subroutine `basic-save-buffer' for more information." (interactive "_p") (let ((modp (buffer-modified-p)) (large (> (buffer-size) 50000)) (make-backup-files (or (and make-backup-files (not (eq args 0))) (memq args '(16 64))))) (and modp (memq args '(16 64)) (setq buffer-backed-up nil)) - (if (and modp large) (display-message - 'progress (format "Saving file %s..." - (buffer-file-name)))) + (if (and modp large (buffer-file-name)) + (display-message 'progress (format "Saving file %s..." + (buffer-file-name)))) (basic-save-buffer) (and modp (memq args '(4 64)) (setq buffer-backed-up nil)))) (defun delete-auto-save-file-if-necessary (&optional force) "Delete auto-save file for current buffer if `delete-auto-save-files' is t. -Normally delete only if the file was written by this XEmacs -since the last real save, but optional arg FORCE non-nil means delete anyway." +Normally delete only if the file was written by this XEmacs since +the last real save, but optional arg FORCE non-nil means delete anyway." (and buffer-auto-save-file-name delete-auto-save-files (not (string= buffer-file-name buffer-auto-save-file-name)) (or force (recent-auto-save-p)) @@ -2256,12 +2778,26 @@ (if (not region-written) (write-region (point-min) (point-max) realname nil t truename)))) +; (defvar auto-save-hook nil +; "Normal hook run just before auto-saving.") + (put 'after-save-hook 'permanent-local t) (defvar after-save-hook nil "Normal hook that is run after a buffer is saved to its file. These hooks are considered to pertain to the visited file. So this list is cleared if you change the visited file name.") +(defvar save-buffer-coding-system nil + "If non-nil, use this coding system for saving the buffer. +More precisely, use this coding system in place of the +value of `buffer-file-coding-system', when saving the buffer. +Calling `write-region' for any purpose other than saving the buffer +will still use `buffer-file-coding-system'; this variable has no effect +in such cases.") + +(make-variable-buffer-local 'save-buffer-coding-system) +(put 'save-buffer-coding-system 'permanent-local t) + (defun files-fetch-hook-value (hook) (let ((localval (symbol-value hook)) (globalval (default-value hook))) @@ -2271,9 +2807,12 @@ (defun basic-save-buffer () "Save the current buffer in its visited file, if it has been modified. -After saving the buffer, run `after-save-hook'." +The hooks `write-contents-hooks', `local-write-file-hooks' and +`write-file-hooks' get a chance to do the job of saving; if they do not, +then the buffer is saved in the visited file file in the usual way. +After saving the buffer, this function runs `after-save-hook'." (interactive) - (save-excursion + (save-current-buffer ;; In an indirect buffer, save its base buffer instead. (if (buffer-base-buffer) (set-buffer (buffer-base-buffer))) @@ -2297,20 +2836,24 @@ (error "Save not confirmed")) (save-restriction (widen) - - ;; Add final newline if required. See `require-final-newline'. - (when (and (not (eq (char-before (point-max)) ?\n)) ; common case - (char-before (point-max)) ; empty buffer? - (not (and (eq selective-display t) - (eq (char-before (point-max)) ?\r))) - (or (eq require-final-newline t) - (and require-final-newline - (y-or-n-p - (format "Buffer %s does not end in newline. Add one? " - (buffer-name)))))) - (save-excursion - (goto-char (point-max)) - (insert ?\n))) + (save-excursion + (and (> (point-max) 1) + (not find-file-literally) + (not (eq (char-after (1- (point-max))) ?\n)) + (not (and (eq selective-display t) + (eq (char-after (1- (point-max))) ?\r))) + (or (eq require-final-newline t) + (and require-final-newline + (y-or-n-p + (format "Buffer %s does not end in newline. Add one? " + (buffer-name))))) + (save-excursion + (goto-char (point-max)) + (insert ?\n)))) + + ;; Support VC version backups. + (if-fboundp 'vc-before-save + (vc-before-save)) ;; Run the write-file-hooks until one returns non-nil. ;; Bind after-save-hook to nil while running the @@ -2338,7 +2881,8 @@ (if (not done) (basic-save-buffer-1))) ;; XEmacs: next two clauses (buffer-file-number setting and - ;; set-file-modes) moved into basic-save-buffer-1. + ;; set-file-modes) moved into basic-save-buffer-1 for use by + ;; continue-save-buffer. ) ;; If the auto-save file was recent before this command, ;; delete it now. @@ -2354,11 +2898,19 @@ ;; but inhibited if one of write-file-hooks returns non-nil. ;; It returns a value to store in setmodes. (defun basic-save-buffer-1 () + (if save-buffer-coding-system + (let ((coding-system-for-write save-buffer-coding-system)) + (basic-save-buffer-2)) + (basic-save-buffer-2))) + +(defun basic-save-buffer-2 () (let (setmodes tempsetmodes) (if (not (file-writable-p buffer-file-name)) (let ((dir (file-name-directory buffer-file-name))) (if (not (file-directory-p dir)) - (error "%s is not a directory" dir) + (if (file-exists-p dir) + (error "%s is not a directory" dir) + (error "%s: no such directory" buffer-file-name)) (if (not (file-exists-p buffer-file-name)) (error "Directory %s write-protected" dir) (if (yes-or-no-p @@ -2396,7 +2948,8 @@ ;; delete the temp file. (or succeed (progn - (delete-file tempname) + (ignore-file-errors + (delete-file tempname)) (set-visited-file-modtime old-modtime)))) ;; Since we have created an entirely new file ;; and renamed it, make sure it gets the @@ -2412,8 +2965,15 @@ (cond ((and tempsetmodes (not setmodes)) ;; Change the mode back, after writing. (setq setmodes (file-modes buffer-file-name)) - (set-file-modes buffer-file-name 511))) + (set-file-modes buffer-file-name (logior setmodes 128)))) (basic-write-file-data buffer-file-name buffer-file-truename))) + ;; #### FSF 21.2. We don't have last-coding-system-used. +; ;; Now we have saved the current buffer. Let's make sure +; ;; that buffer-file-coding-system is fixed to what +; ;; actually used for saving by binding it locally. +; (if save-buffer-coding-system +; (setq save-buffer-coding-system last-coding-system-used) +; (setq buffer-file-coding-system last-coding-system-used)) (setq buffer-file-number (if buffer-file-name (nth 10 (file-attributes buffer-file-name)) @@ -2454,11 +3014,14 @@ :type 'boolean :group 'editing-basics) -(defun save-some-buffers (&optional arg exiting) +(defun save-some-buffers (&optional arg pred) "Save some modified file-visiting buffers. Asks user about each one. Optional argument (the prefix) non-nil means save all with no questions. -Optional second argument EXITING means ask about certain non-file buffers - as well as about file buffers." +Optional second argument PRED determines which buffers are considered: +If PRED is nil, all the file-visiting buffers are considered. +If PRED is t, then certain non-file buffers will also be considered. +If PRED is a zero-argument function, it indicates for each buffer whether +to consider it or not when called with that buffer current." (interactive "P") (save-excursion ;; `delete-other-windows' can bomb during autoloads generation, so @@ -2468,15 +3031,15 @@ (not save-some-buffers-query-display-buffer)) ;; If playing with windows is unsafe or undesired, just do the ;; usual drill. - (save-some-buffers-1 arg exiting nil) + (save-some-buffers-1 arg pred nil) ;; Else, protect the windows. (when (save-window-excursion - (save-some-buffers-1 arg exiting t)) + (save-some-buffers-1 arg pred t)) ;; Force redisplay. (sit-for 0))))) ;; XEmacs - do not use queried flag -(defun save-some-buffers-1 (arg exiting switch-buffer) +(defun save-some-buffers-1 (arg pred switch-buffer) (let* ((switched nil) (last-buffer nil) (files-done @@ -2489,10 +3052,12 @@ (not (symbol-value-in-buffer 'save-buffers-skip buffer)) (or (buffer-file-name buffer) - (and exiting + (and pred (progn (set-buffer buffer) (and buffer-offer-save (> (buffer-size) 0))))) + (or (not (functionp pred)) + (with-current-buffer buffer (funcall pred))) (if arg t ;; #### We should provide a per-buffer means to @@ -2535,7 +3100,11 @@ (list (list ?\C-r (lambda (buf) ;; #### FSF has an EXIT-ACTION argument ;; to `view-buffer'. - (view-buffer buf) + (view-buffer buf +; (function +; (lambda (ignore) +; (exit-recursive-edit)))) + ) (with-boundp 'view-exit-action (setq view-exit-action (lambda (ignore) @@ -2548,6 +3117,7 @@ (and save-abbrevs abbrevs-changed (progn (if (or arg + (eq save-abbrevs 'silently) (y-or-n-p (format "Save abbrevs in %s? " abbrev-file-name))) (write-abbrev-file nil)) ;; Don't keep bothering user if he says no. @@ -2558,6 +3128,7 @@ switched)) + (defun not-modified (&optional arg) "Mark current buffer as unmodified, not needing to be saved. With prefix arg, mark buffer as modified, so \\[save-buffer] will save. @@ -2571,15 +3142,26 @@ (set-buffer-modified-p arg)) (defun toggle-read-only (&optional arg) - "Toggle the current buffer's read-only status. -With arg, set read-only iff arg is positive." - (interactive "_P") - (setq buffer-read-only - (if (null arg) - (not buffer-read-only) - (> (prefix-numeric-value arg) 0))) - ;; Force modeline redisplay - (redraw-modeline)) + "Change whether this buffer is visiting its file read-only. +With arg, set read-only iff arg is positive. +If visiting file read-only and `view-read-only' is non-nil, enter view mode." + (interactive "P") + (cond + ((and arg (if (> (prefix-numeric-value arg) 0) buffer-read-only + (not buffer-read-only))) ; If buffer-read-only is set correctly, + nil) ; do nothing. + ;; Toggle. + ((and buffer-read-only view-minor-mode) + ;(View-exit-and-edit) + (view-mode) + (make-local-variable 'view-read-only) + (setq view-read-only t)) ; Must leave view mode. + ((and (not buffer-read-only) view-read-only + (not (eq (get major-mode 'mode-class) 'special))) + ;(view-mode-enter) + (view-mode)) + (t (setq buffer-read-only (not buffer-read-only)) + (force-mode-line-update)))) (defun insert-file (filename &optional codesys) "Insert contents of file FILENAME into buffer after point. @@ -2619,17 +3201,24 @@ (defun file-newest-backup (filename) "Return most recent backup file for FILENAME or nil if no backups exist." - (let* ((filename (expand-file-name filename)) + ;; `make-backup-file-name' will get us the right directory for + ;; ordinary or numeric backups. It might create a directory for + ;; backups as a side-effect, according to `backup-directory-alist'. + (let* ((filename (file-name-sans-versions + (make-backup-file-name filename))) (file (file-name-nondirectory filename)) (dir (file-name-directory filename)) (comp (file-name-all-completions file dir)) - newest) + (newest nil) + tem) (while comp - (setq file (concat dir (car comp)) - comp (cdr comp)) - (if (and (backup-file-name-p file) - (or (null newest) (file-newer-than-file-p file newest))) - (setq newest file))) + (setq tem (pop comp)) + (cond ((and (backup-file-name-p tem) + (string= (file-name-sans-versions tem) file)) + (setq tem (concat dir tem)) + (if (or (null newest) + (file-newer-than-file-p tem newest)) + (setq newest tem))))) newest)) (defun rename-uniquely () @@ -2638,21 +3227,17 @@ or multiple mail buffers, etc." (interactive) (save-match-data - (let* ((base-name (if (and (string-match "<[0-9]+>\\'" (buffer-name)) - (not (and buffer-file-name - (string= (buffer-name) - (file-name-nondirectory - buffer-file-name))))) - ;; If the existing buffer name has a <NNN>, - ;; which isn't part of the file name (if any), - ;; then get rid of that. - (substring (buffer-name) 0 (match-beginning 0)) - (buffer-name))) - (new-buf (generate-new-buffer base-name)) - (name (buffer-name new-buf))) - (kill-buffer new-buf) - (rename-buffer name) - (redraw-modeline)))) + (let ((base-name (buffer-name))) + (and (string-match "<[0-9]+>\\'" base-name) + (not (and buffer-file-name + (string= base-name + (file-name-nondirectory buffer-file-name)))) + ;; If the existing buffer name has a <NNN>, + ;; which isn't part of the file name (if any), + ;; then get rid of that. + (setq base-name (substring base-name 0 (match-beginning 0)))) + (rename-buffer (generate-new-buffer-name base-name)) + (force-mode-line-update)))) (defun make-directory-path (path) "Create all the directories along path that don't exist yet." @@ -2696,7 +3281,9 @@ Gets two args, first the nominal file name to use, and second, t if reading the auto-save file. If the current buffer contents are to be discarded, the function must do -so itself.") +so itself. + +The function you specify is responsible for updating (or preserving) point.") (defvar before-revert-hook nil "Normal hook for `revert-buffer' to run before reverting. @@ -2715,6 +3302,8 @@ (defvar revert-buffer-internal-hook nil "Don't use this.") +;; END SYNC WITH FSF 21.2. + (defun revert-buffer (&optional ignore-auto noconfirm preserve-modes) "Replace the buffer text with the text of the visited file on disk. This undoes all changes since the file was visited or saved. @@ -2929,6 +3518,8 @@ newbuf (and (kill-buffer newbuf) nil)))) +;; BEGIN SYNC WITH FSF 21.2. + (defvar recover-file-diff-program "diff" "Absolute or relative name of the `diff' program used by `recover-file'.") (defvar recover-file-diff-arguments '("-c") @@ -2963,12 +3554,20 @@ (with-output-to-temp-buffer "*Directory*" (buffer-disable-undo standard-output) (save-excursion - (set-buffer "*Directory*") - (setq default-directory (file-name-directory file)) - (insert-directory file - (if (file-symlink-p file) "-lL" "-l")) - (setq default-directory (file-name-directory file-name)) - (insert-directory file-name "-l"))) + (let ((switches dired-listing-switches)) + (if (file-symlink-p file) + (setq switches (concat switches "L"))) + (set-buffer standard-output) + ;; XEmacs had the following line, not in FSF. + (setq default-directory (file-name-directory file)) + ;; Use insert-directory-safely, not insert-directory, + ;; because these files might not exist. In particular, + ;; FILE might not exist if the auto-save file was for + ;; a buffer that didn't visit a file, such as "*mail*". + ;; The code in v20.x called `ls' directly, so we need + ;; to emulate what `ls' did in that case. + (insert-directory-safely file switches) + (insert-directory-safely file-name switches)))) (block nil (while t (case (get-user-response @@ -2984,10 +3583,14 @@ (no (error "Recover-file cancelled.")) (yes (switch-to-buffer (find-file-noselect file t)) - (let ((buffer-read-only nil)) + (let ((buffer-read-only nil) + ;; Keep the current buffer-file-coding-system. + (coding-system buffer-file-coding-system) + ;; Auto-saved file shoule be read without any code conversion. + (coding-system-for-read 'escape-quoted)) (erase-buffer) - (let ((coding-system-for-read 'escape-quoted)) - (insert-file-contents file-name nil))) + (insert-file-contents file-name nil) + (set-buffer-file-coding-system coding-system)) (after-find-file nil nil t) (return nil)) (diff @@ -3031,16 +3634,20 @@ (list temp file-name))) (io-error (save-excursion - (set-buffer standard-output) - (setq default-directory - (file-name-directory file)) - (insert-directory - file - (if (file-symlink-p file) "-lL" - "-l")) - (setq default-directory - (file-name-directory file-name)) - (insert-directory file-name "-l") + (let ((switches dired-listing-switches)) + (if (file-symlink-p file) + (setq switches (concat switches "L"))) + (set-buffer standard-output) + ;; XEmacs had the following line, not in FSF. + (setq default-directory (file-name-directory file)) + ;; Use insert-directory-safely, not insert-directory, + ;; because these files might not exist. In particular, + ;; FILE might not exist if the auto-save file was for + ;; a buffer that didn't visit a file, such as "*mail*". + ;; The code in v20.x called `ls' directly, so we need + ;; to emulate what `ls' did in that case. + (insert-directory-safely file switches) + (insert-directory-safely file-name switches)) (terpri) (princ "Error during diff: ") (display-error ferr @@ -3061,6 +3668,9 @@ (if (null auto-save-list-file-prefix) (error "You set `auto-save-list-file-prefix' to disable making session files")) + (let ((dir (file-name-directory auto-save-list-file-prefix))) + (unless (file-directory-p dir) + (make-directory dir t))) (let* ((auto-save-list-dir (file-name-directory auto-save-list-file-prefix)) (files (directory-files @@ -3073,14 +3683,15 @@ (unless files (error "No sessions can be recovered now")) (declare-fboundp (dired (cons auto-save-list-dir files))) - (goto-char (point-min)) - (or (looking-at "Move to the session you want to recover,") - (let ((inhibit-read-only t)) - (delete-matching-lines "^[ \t]*total.*$") - (insert "Move to the session you want to recover,\n" - "then type C-c C-c to select it.\n\n" - "You can also delete some of these files;\n" - "type d on a line to mark that file for deletion.\n\n"))) + (save-excursion + (goto-char (point-min)) + (or (looking-at "Move to the session you want to recover,") + (let ((inhibit-read-only t)) + (delete-matching-lines "^[ \t]*total.*$") + (insert "Move to the session you want to recover,\n" + "then type C-c C-c to select it.\n\n" + "You can also delete some of these files;\n" + "type d on a line to mark that file for deletion.\n\n")))) (use-local-map (let ((map (make-sparse-keymap))) (set-keymap-parents map (list (current-local-map))) map)) @@ -3144,6 +3755,7 @@ (interactive) ;; Get the name of the session file to recover from. (let ((file (declare-fboundp (dired-get-filename)))) + (dired-unmark 1) ;; #### dired-do-flagged-delete in FSF. ;; This version is for ange-ftp ;;(dired-do-deletions t) @@ -3176,7 +3788,7 @@ (let* ((buffer (car list)) (name (buffer-name buffer))) (and (not (string-equal name "")) - (/= (aref name 0) ?\ ) + (not (eq (aref name 0) ?\ )) (yes-or-no-p (format (if (buffer-modified-p buffer) @@ -3224,10 +3836,14 @@ (recent-auto-save-p)) (rename-file osave buffer-auto-save-file-name t)))) +;; END SYNC WITH FSF 21.2. + ;; make-auto-save-file-name and auto-save-file-name-p are now only in ;; auto-save.el. +;; BEGIN SYNC WITH FSF 21.2. + (defun wildcard-to-regexp (wildcard) "Given a shell file name pattern WILDCARD, return an equivalent regexp. The generated regexp will match a filename iff the filename @@ -3246,6 +3862,10 @@ result (concat result (cond + ((and (eq ch ?\[) + (< (1+ i) len) + (eq (aref wildcard (1+ i)) ?\])) + "\\[") ((eq ch ?\[) ; [...] maps to regexp char class (progn (setq i (1+ i)) @@ -3305,6 +3925,49 @@ :type 'string :group 'dired) +(defun file-expand-wildcards (pattern &optional full) + "Expand wildcard pattern PATTERN. +This returns a list of file names which match the pattern. + +If PATTERN is written as an absolute relative file name, +the values are absolute also. + +If PATTERN is written as a relative file name, it is interpreted +relative to the current default directory, `default-directory'. +The file names returned are normally also relative to the current +default directory. However, if FULL is non-nil, they are absolute." + (let* ((nondir (file-name-nondirectory pattern)) + (dirpart (file-name-directory pattern)) + ;; A list of all dirs that DIRPART specifies. + ;; This can be more than one dir + ;; if DIRPART contains wildcards. + (dirs (if (and dirpart (string-match "[[*?]" dirpart)) + (mapcar 'file-name-as-directory + (file-expand-wildcards (directory-file-name dirpart))) + (list dirpart))) + contents) + (while dirs + (when (or (null (car dirs)) ; Possible if DIRPART is not wild. + (file-directory-p (directory-file-name (car dirs)))) + (let ((this-dir-contents + ;; Filter out "." and ".." + (delq nil + (mapcar #'(lambda (name) + (unless (string-match "\\`\\.\\.?\\'" + (file-name-nondirectory name)) + name)) + (directory-files (or (car dirs) ".") full + (wildcard-to-regexp nondir)))))) + (setq contents + (nconc + (if (and (car dirs) (not full)) + (mapcar (function (lambda (name) (concat (car dirs) name))) + this-dir-contents) + this-dir-contents) + contents)))) + (setq dirs (cdr dirs))) + contents)) + (defun list-directory (dirname &optional verbose) "Display a list of files in or matching DIRNAME, a la `ls'. DIRNAME is globbed by the shell if necessary. @@ -3327,10 +3990,59 @@ (terpri) (save-excursion (set-buffer "*Directory*") - (setq default-directory (file-name-directory dirname)) + (setq default-directory + (if (file-directory-p dirname) + (file-name-as-directory dirname) + (file-name-directory dirname))) (let ((wildcard (not (file-directory-p dirname)))) (insert-directory dirname switches wildcard (not wildcard))))))) +(defun shell-quote-wildcard-pattern (pattern) + "Quote characters special to the shell in PATTERN, leave wildcards alone. + +PATTERN is assumed to represent a file-name wildcard suitable for the +underlying filesystem. For Unix and GNU/Linux, the characters from the +set [ \\t\\n;<>&|()#$] are quoted with a backslash; for DOS/Windows, all +the parts of the pattern which don't include wildcard characters are +quoted with double quotes. +Existing quote characters in PATTERN are left alone, so you can pass +PATTERN that already quotes some of the special characters." + (save-match-data + (cond + ((memq system-type '(ms-dos windows-nt)) + ;; DOS/Windows don't allow `"' in file names. So if the + ;; argument has quotes, we can safely assume it is already + ;; quoted by the caller. + (if (or (string-match "[\"]" pattern) + ;; We quote [&()#$'] in case their shell is a port of a + ;; Unixy shell. We quote [,=+] because stock DOS and + ;; Windows shells require that in some cases, such as + ;; passing arguments to batch files that use positional + ;; arguments like %1. + (not (string-match "[ \t;&()#$',=+]" pattern))) + pattern + (let ((result "\"") + (beg 0) + end) + (while (string-match "[*?]+" pattern beg) + (setq end (match-beginning 0) + result (concat result (substring pattern beg end) + "\"" + (substring pattern end (match-end 0)) + "\"") + beg (match-end 0))) + (concat result (substring pattern beg) "\"")))) + (t + (let ((beg 0)) + (while (string-match "[ \t\n;<>&|()#$]" pattern beg) + (setq pattern + (concat (substring pattern 0 (match-beginning 0)) + "\\" + (substring pattern (match-beginning 0))) + beg (1+ (match-end 0))))) + pattern)))) + + (defvar insert-directory-program "ls" "Absolute or relative name of the `ls' program used by `insert-directory'.") @@ -3352,6 +4064,9 @@ ;; dired-insert-headerline ;; dired-after-subdir-garbage (defines what a "total" line is) ;; - variable dired-subdir-regexp + +;; END SYNC WITH FSF 21.2. + (defun insert-directory (file switches &optional wildcard full-directory-p) "Insert directory listing for FILE, formatted according to SWITCHES. Leaves point after the inserted text. @@ -3431,6 +4146,19 @@ ".") file))))))))))) +;; BEGIN SYNC WITH FSF 21.2. + +(defun insert-directory-safely (file switches + &optional wildcard full-directory-p) + "Insert directory listing for FILE, formatted according to SWITCHES. + +Like `insert-directory', but if FILE does not exist, it inserts a +message to that effect instead of signaling an error." + (if (file-exists-p file) + (insert-directory file switches wildcard full-directory-p) + ;; Simulate the message printed by `ls'. + (insert (format "%s: No such file or directory\n" file)))) + (defvar kill-emacs-query-functions nil "Functions to call with no arguments to query about killing XEmacs. If any of these functions returns nil, killing Emacs is cancelled. @@ -3438,6 +4166,17 @@ but `kill-emacs', the low level primitive, does not. See also `kill-emacs-hook'.") +(defcustom confirm-kill-emacs nil + "How to ask for confirmation when leaving Emacs. +If nil, the default, don't ask at all. If the value is non-nil, it should +be a predicate function such as `yes-or-no-p'." + :type '(choice (const :tag "Ask with yes-or-no-p" yes-or-no-p) + (const :tag "Ask with y-or-n-p" y-or-n-p) + (const :tag "Don't confirm" nil)) + :group 'emacs + ;:version "21.1" + ) + (defun save-buffers-kill-emacs (&optional arg) "Offer to save each buffer, then kill this XEmacs process. With prefix arg, silently save all file-visiting buffers, then kill." @@ -3468,6 +4207,8 @@ "Active processes exist; kill them and exit anyway? ")))))) ;; Query the user for other things, perhaps. (run-hook-with-args-until-failure 'kill-emacs-query-functions) + (or (null confirm-kill-emacs) + (funcall confirm-kill-emacs "Really exit Emacs? ")) (kill-emacs))) (defun symlink-expand-file-name (filename) @@ -3493,6 +4234,67 @@ (declare-fboundp (efs-ftp-path file-name))) (t nil))) -;; #### FSF has file-name-non-special here. + +;; We use /: as a prefix to "quote" a file name +;; so that magic file name handlers will not apply to it. + +(setq file-name-handler-alist + (cons '("\\`/:" . file-name-non-special) + file-name-handler-alist)) + +;; We depend on being the last handler on the list, +;; so that anything else which does need handling +;; has been handled already. +;; So it is safe for us to inhibit *all* magic file name handlers. + +(defun file-name-non-special (operation &rest arguments) + (let ((file-name-handler-alist nil) + (default-directory + (if (eq operation 'insert-directory) + (directory-file-name + (expand-file-name + (unhandled-file-name-directory default-directory))) + default-directory)) + ;; Get a list of the indices of the args which are file names. + (file-arg-indices + (cdr (or (assq operation + ;; The first four are special because they + ;; return a file name. We want to include the /: + ;; in the return value. + ;; So just avoid stripping it in the first place. + '((expand-file-name . nil) + ;; `identity' means just return the first arg + ;; as stripped of its quoting. + (substitute-in-file-name . identity) + (file-name-directory . nil) + (file-name-as-directory . nil) + (directory-file-name . nil) + (file-name-completion 0 1) + (file-name-all-completions 0 1) + (rename-file 0 1) + (copy-file 0 1) + (make-symbolic-link 0 1) + (add-name-to-file 0 1))) + ;; For all other operations, treat the first argument only + ;; as the file name. + '(nil 0)))) + ;; Copy ARGUMENTS so we can replace elements in it. + (arguments (copy-sequence arguments))) + ;; Strip off the /: from the file names that have this handler. + (save-match-data + (while (consp file-arg-indices) + (let ((pair (nthcdr (car file-arg-indices) arguments))) + (and (car pair) + (string-match "\\`/:" (car pair)) + (setcar pair + (if (= (length (car pair)) 2) + "/" + (substring (car pair) 2))))) + (setq file-arg-indices (cdr file-arg-indices)))) + (if (eq file-arg-indices 'identity) + (car arguments) + (apply operation arguments)))) + +;; END SYNC WITH FSF 21.2. ;;; files.el ends here
--- a/lisp/keydefs.el Sun Mar 02 02:18:12 2003 +0000 +++ b/lisp/keydefs.el Sun Mar 02 09:38:54 2003 +0000 @@ -122,6 +122,7 @@ (define-key global-map "\C-x\C-d" 'list-directory) (define-key global-map "\C-x\C-c" 'save-buffers-kill-emacs) +(define-key global-map "\C-x4c" 'clone-indirect-buffer-other-window) (define-key global-map "\C-x4f" 'find-file-other-window) (define-key global-map "\C-x4r" 'find-file-read-only-other-window) (define-key global-map "\C-x4\C-f" 'find-file-other-window)
--- a/lisp/keymap.el Sun Mar 02 02:18:12 2003 +0000 +++ b/lisp/keymap.el Sun Mar 02 09:38:54 2003 +0000 @@ -2,6 +2,7 @@ ;; Copyright (C) 1993-4, 1997 Free Software Foundation, Inc. ;; Copyright (C) 1995 Tinker Systems and INS Engineering Corp. +;; Copyright (C) 2003 Ben Wing. ;; Maintainer: XEmacs Development Team ;; Keywords: internals, dumped @@ -37,21 +38,15 @@ ;;; Code: -(put 'undefined 'suppress-keymap t) +;; BEGIN SYNCHED WITH FSF 21.2. (defun undefined () (interactive) (ding)) -(defmacro kbd (keys) - "Convert KEYS to the internal Emacs key representation. -KEYS should be a string in the format used for saving keyboard macros -\(see `insert-kbd-macro')." - (if (or (stringp keys) - (vectorp keys)) - ;; #### need to move xemacs-base into the core!!!!!! - (declare-fboundp (read-kbd-macro keys)) - `(declare-fboundp (read-kbd-macro ,keys)))) +;Prevent the \{...} documentation construct +;from mentioning keys that run this command. +(put 'undefined 'suppress-keymap t) (defun suppress-keymap (map &optional nodigits) "Make MAP override all normally self-inserting keys to be undefined. @@ -66,6 +61,8 @@ (define-key map string 'digit-argument) (incf (aref string 0)))))) +;Unneeded in XEmacs (defvar key-substitution-in-progress nil + (defun substitute-key-definition (olddef newdef keymap &optional oldmap prefix) "Replace OLDDEF with NEWDEF for any keys in KEYMAP now defined as OLDDEF. In other words, OLDDEF is replaced with NEWDEF wherever it appears. @@ -84,7 +81,12 @@ maps (cdr maps)) ;; Substitute in this keymap (map-keymap #'(lambda (key binding) - (if (eq binding olddef) + (if (or (eq binding olddef) + ;; Compare with equal if definition is a key + ;; sequence. That is useful for operating on + ;; function-key-map. + (and (or (stringp binding) (vectorp binding)) + (equal binding olddef))) ;; The new bindings always go in KEYMAP even if we ;; found them in OLDMAP or one of its children. ;; If KEYMAP will be shadowing OLDMAP, then do not @@ -103,6 +105,38 @@ map) ))) +;; FSF garbage. They misguidedly tried to put menu entries into keymaps, +;; and needed stuff like the following. Eventually they admitted defeat +;; and switched to our method. + +; (defun define-key-after (keymap key definition &optional after) +; "Add binding in KEYMAP for KEY => DEFINITION, right after AFTER's binding. +; This is like `define-key' except that the binding for KEY is placed +; just after the binding for the event AFTER, instead of at the beginning +; of the map. Note that AFTER must be an event type (like KEY), NOT a command +; \(like DEFINITION). +; +; If AFTER is t or omitted, the new binding goes at the end of the keymap. +; +; KEY must contain just one event type--that is to say, it must be a +; string or vector of length 1, but AFTER should be a single event +; type--a symbol or a character, not a sequence. +; +; Bindings are always added before any inherited map. +; +; The order of bindings in a keymap matters when it is used as a menu." + +(defmacro kbd (keys) + "Convert KEYS to the internal Emacs key representation. +KEYS should be a string constant in the format used for +saving keyboard macros (see `insert-kbd-macro')." + (if (or (stringp keys) + (vectorp keys)) + ;; #### need to move xemacs-base into the core!!!!!! + (declare-fboundp (read-kbd-macro keys)) + `(declare-fboundp (read-kbd-macro ,keys)))) + +;; END SYNCHED WITH FSF 21.2. ;; This used to wrap forms into an interactive lambda. It is unclear ;; to me why this is needed in this function. Anyway,
--- a/lisp/lisp-mode.el Sun Mar 02 02:18:12 2003 +0000 +++ b/lisp/lisp-mode.el Sun Mar 02 09:38:54 2003 +0000 @@ -72,9 +72,7 @@ (indent-sexp)))] "---" ["%_Comment Out Region" comment-region :active (region-exists-p)] - ["Unc%_omment Region" (comment-region (region-beginning) - (region-end) '(4)) - :active (region-exists-p)] + ["Unc%_omment Region" uncomment-region :active (region-exists-p)] "---" ,@(if popup-p '(["%_Find Function"
--- a/lisp/make-docfile.el Sun Mar 02 02:18:12 2003 +0000 +++ b/lisp/make-docfile.el Sun Mar 02 09:38:54 2003 +0000 @@ -145,6 +145,7 @@ ;; Then process the autoloads (setq autoload-file-name "auto-autoloads.elc") +(defvar custom-declare-variable-list nil) ; unclean (load "find-paths.el") (load "packages.el") (load "setup-paths.el")
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/newcomment.el Sun Mar 02 09:38:54 2003 +0000 @@ -0,0 +1,1071 @@ +;;; newcomment.el --- (un)comment regions of buffers + +;; Copyright (C) 1999, 2000 Free Software Foundation Inc. + +;; Author: code extracted from Emacs-20's simple.el +;; Maintainer: Stefan Monnier <monnier@cs.yale.edu> +;; Keywords: comment uncomment +;; Revision: $Id: newcomment.el,v 1.1 2003/03/02 09:38:40 ben Exp $ + +;; This file is part of GNU Emacs. + +;; GNU Emacs 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. + +;; GNU Emacs 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 GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;; A replacement for simple.el's comment-related functions. + +;;; Bugs: + +;; - single-char nestable comment-start can only do the "\\s<+" stuff +;; if the corresponding closing marker happens to be right. +;; - comment-box in TeXinfo generate bogus comments @ccccc@ +;; - uncomment-region with a numeric argument can render multichar +;; comment markers invalid. +;; - comment-indent or comment-region when called inside a comment +;; will happily break the surrounding comment. +;; - comment-quote-nested will not (un)quote properly all nested comment +;; markers if there are more than just comment-start and comment-end. +;; For example, in Pascal where {...*) and (*...} are possible. + +;;; Todo: + +;; - quantized steps in comment-alignment +;; - try to align tail comments +;; - check what c-comment-line-break-function has to say +;; - spill auto-fill of comments onto the end of the next line +;; - uncomment-region with a consp (for blocks) or somehow make the +;; deletion of continuation markers less dangerous +;; - drop block-comment-<foo> unless it's really used +;; - uncomment-region on a subpart of a comment +;; - support gnu-style "multi-line with space in continue" +;; - somehow allow comment-dwim to use the region even if transient-mark-mode +;; is not turned on. + +;; - when auto-filling a comment, try to move the comment to the left +;; rather than break it (if possible). +;; - sometimes default the comment-column to the same +;; one used on the preceding line(s). + +;;; Code: + +;;;###autoload +(defalias 'indent-for-comment 'comment-indent) +;;;###autoload +(defalias 'set-comment-column 'comment-set-column) +;;;###autoload +(defalias 'kill-comment 'comment-kill) +;;;###autoload +(defalias 'indent-new-comment-line 'comment-indent-new-line) + +;;;###autoload +(defgroup comment nil + "Indenting and filling of comments." + :prefix "comment-" + :version "21.1" + :group 'fill) + +(defvar comment-use-syntax 'undecided + "Non-nil if syntax-tables can be used instead of regexps. +Can also be `undecided' which means that a somewhat expensive test will +be used to try to determine whether syntax-tables should be trusted +to understand comments or not in the given buffer. +Major modes should set this variable.") + +;;;###autoload +(defcustom comment-column 32 + "*Column to indent right-margin comments to. +Setting this variable automatically makes it local to the current buffer. +Each mode establishes a different default value for this variable; you +can set the value for a particular mode using that mode's hook." + :type 'integer + :group 'comment) +(make-variable-buffer-local 'comment-column) + +;;;###autoload +(defvar comment-start nil + "*String to insert to start a new comment, or nil if no comment syntax.") + +;;;###autoload +(defvar comment-start-skip nil + "*Regexp to match the start of a comment plus everything up to its body. +If there are any \\(...\\) pairs, the comment delimiter text is held to begin +at the place matched by the close of the first pair.") + +;;;###autoload +(defvar comment-end-skip nil + "Regexp to match the end of a comment plus everything up to its body.") + +;;;###autoload +(defvar comment-end "" + "*String to insert to end a new comment. +Should be an empty string if comments are terminated by end-of-line.") + +;;;###autoload +(defvar comment-indent-function 'comment-indent-default + "Function to compute desired indentation for a comment. +This function is called with no args with point at the beginning of +the comment's starting delimiter and should return either the desired +column indentation or nil. +If nil is returned, indentation is delegated to `indent-according-to-mode'.") + +(defvar block-comment-start nil) +(defvar block-comment-end nil) + +(defvar comment-quote-nested t + "Non-nil if nested comments should be quoted. +This should be locally set by each major mode if needed.") + +(defvar comment-continue nil + "Continuation string to insert for multiline comments. +This string will be added at the beginning of each line except the very +first one when commenting a region with a commenting style that allows +comments to span several lines. +It should generally have the same length as `comment-start' in order to +preserve indentation. +If it is nil a value will be automatically derived from `comment-start' +by replacing its first character with a space.") + +(defvar comment-add 0 + "How many more comment chars should be inserted by `comment-region'. +This determines the default value of the numeric argument of `comment-region'. +This should generally stay 0, except for a few modes like Lisp where +it can be convenient to set it to 1 so that regions are commented with +two semi-colons.") + +(defconst comment-styles + '((plain . (nil nil nil nil)) + (indent . (nil nil nil t)) + (aligned . (nil t nil t)) + (multi-line . (t nil nil t)) + (extra-line . (t nil t t)) + (box . (nil t t t)) + (box-multi . (t t t t))) + "Possible comment styles of the form (STYLE . (MULTI ALIGN EXTRA INDENT)). +STYLE should be a mnemonic symbol. +MULTI specifies that comments are allowed to span multiple lines. +ALIGN specifies that the `comment-end' markers should be aligned. +EXTRA specifies that an extra line should be used before and after the + region to comment (to put the `comment-end' and `comment-start'). +INDENT specifies that the `comment-start' markers should not be put at the + left margin but at the current indentation of the region to comment.") + +;;;###autoload +(defcustom comment-style 'plain + "*Style to be used for `comment-region'. +See `comment-styles' for a list of available styles." + :group 'comment + :type (if (boundp 'comment-styles) + `(choice ,@(mapcar (lambda (s) `(const ,(car s))) comment-styles)) + 'symbol)) + +;;;###autoload +(defcustom comment-padding " " + "Padding string that `comment-region' puts between comment chars and text. +Can also be an integer which will be automatically turned into a string +of the corresponding number of spaces. + +Extra spacing between the comment characters and the comment text +makes the comment easier to read. Default is \" \". nil means 0." + :group 'comment + :type '(choice string integer (const nil))) + +;;;###autoload +(defcustom comment-multi-line t ; XEmacs - this works well with adaptive fill + "*Non-nil means \\[indent-new-comment-line] should continue same comment +on new line, with no new terminator or starter. +This is obsolete because you might as well use \\[newline-and-indent]." + :type 'boolean + :group 'comment) + +;;;; +;;;; Helpers +;;;; + +(defun comment-string-strip (str beforep afterp) + "Strip STR of any leading (if BEFOREP) and/or trailing (if AFTERP) space." + (string-match (concat "\\`" (if beforep "\\s-*") + "\\(.*?\\)" (if afterp "\\s-*\n?") + "\\'") str) + (match-string 1 str)) + +(defun comment-string-reverse (s) + "Return the mirror image of string S, without any trailing space." + (comment-string-strip (concat (nreverse (string-to-list s))) nil t)) + +(defun comment-normalize-vars (&optional noerror) + (if (not comment-start) (or noerror (error "No comment syntax is defined")) + ;; comment-use-syntax + (when (eq comment-use-syntax 'undecided) + (set (make-local-variable 'comment-use-syntax) + (let ((st (syntax-table)) + (cs comment-start) + (ce (if (string= "" comment-end) "\n" comment-end))) + ;; Try to skip over a comment using forward-comment + ;; to see if the syntax tables properly recognize it. + (with-temp-buffer + (set-syntax-table st) + (insert cs " hello " ce) + (goto-char (point-min)) + (and (forward-comment 1) (eobp)))))) + ;; comment-padding + (unless comment-padding (setq comment-padding 0)) + (when (integerp comment-padding) + (setq comment-padding (make-string comment-padding ? ))) + ;; comment markers + ;;(setq comment-start (comment-string-strip comment-start t nil)) + ;;(setq comment-end (comment-string-strip comment-end nil t)) + ;; comment-continue + (unless (or comment-continue (string= comment-end "")) + (set (make-local-variable 'comment-continue) + (concat (if (string-match "\\S-\\S-" comment-start) " " "|") + (substring comment-start 1)))) + ;; comment-skip regexps + (unless comment-start-skip + (set (make-local-variable 'comment-start-skip) + (concat "\\(\\(^\\|[^\\\\\n]\\)\\(\\\\\\\\\\)*\\)\\(\\s<+\\|" + (regexp-quote (comment-string-strip comment-start t t)) + ;; Let's not allow any \s- but only [ \t] since \n + ;; might be both a comment-end marker and \s-. + "+\\)[ \t]*"))) + (unless comment-end-skip + (let ((ce (if (string= "" comment-end) "\n" + (comment-string-strip comment-end t t)))) + (set (make-local-variable 'comment-end-skip) + ;; We use [ \t] rather than \s- because we don't want to + ;; remove ^L in C mode when uncommenting. + (concat "[ \t]*\\(\\s>" (if comment-quote-nested "" "+") + "\\|" (regexp-quote (substring ce 0 1)) + (if (and comment-quote-nested (<= (length ce) 1)) "" "+") + (regexp-quote (substring ce 1)) + "\\)")))))) + +(defun comment-quote-re (str unp) + (concat (regexp-quote (substring str 0 1)) + "\\\\" (if unp "+" "*") + (regexp-quote (substring str 1)))) + +(defun comment-quote-nested (cs ce unp) + "Quote or unquote nested comments. +If UNP is non-nil, unquote nested comment markers." + (setq cs (comment-string-strip cs t t)) + (setq ce (comment-string-strip ce t t)) + (when (and comment-quote-nested (> (length ce) 0)) + (let ((re (concat (comment-quote-re ce unp) + "\\|" (comment-quote-re cs unp)))) + (goto-char (point-min)) + (while (re-search-forward re nil t) + (goto-char (match-beginning 0)) + (forward-char 1) + (if unp (delete-char 1) (insert "\\")) + (when (= (length ce) 1) + ;; If the comment-end is a single char, adding a \ after that + ;; "first" char won't deactivate it, so we turn such a CE + ;; into !CS. I.e. for pascal, we turn } into !{ + (if (not unp) + (when (string= (match-string 0) ce) + (replace-match (concat "!" cs) t t)) + (when (and (< (point-min) (match-beginning 0)) + (string= (buffer-substring (1- (match-beginning 0)) + (1- (match-end 0))) + (concat "!" cs))) + (backward-char 2) + (delete-char (- (match-end 0) (match-beginning 0))) + (insert ce)))))))) + +;;;; +;;;; Navigation +;;;; + +(defun comment-search-forward (limit &optional noerror) + "Find a comment start between point and LIMIT. +Moves point to inside the comment and returns the position of the +comment-starter. If no comment is found, moves point to LIMIT +and raises an error or returns nil of NOERROR is non-nil." + (if (not comment-use-syntax) + (if (re-search-forward comment-start-skip limit noerror) + (or (match-end 1) (match-beginning 0)) + (goto-char limit) + (unless noerror (error "No comment"))) + (let* ((pt (point)) + ;; Assume (at first) that pt is outside of any string. + (s (parse-partial-sexp pt (or limit (point-max)) nil nil nil t))) + (when (and (nth 8 s) (nth 3 s)) + ;; The search ended inside a string. Try to see if it + ;; works better when we assume that pt is inside a string. + (setq s (parse-partial-sexp + pt (or limit (point-max)) nil nil + (list nil nil nil (nth 3 s) nil nil nil nil) + t))) + (if (not (and (nth 8 s) (not (nth 3 s)))) + (unless noerror (error "No comment")) + ;; We found the comment. + (let ((pos (point)) + (start (nth 8 s)) + (bol (line-beginning-position)) + (end nil)) + (while (and (null end) (>= (point) bol)) + (if (looking-at comment-start-skip) + (setq end (min (or limit (point-max)) (match-end 0))) + (backward-char))) + (goto-char (or end pos)) + start))))) + +(defun comment-search-backward (&optional limit noerror) + "Find a comment start between LIMIT and point. +Moves point to inside the comment and returns the position of the +comment-starter. If no comment is found, moves point to LIMIT +and raises an error or returns nil of NOERROR is non-nil." + ;; FIXME: If a comment-start appears inside a comment, we may erroneously + ;; stop there. This can be rather bad in general, but since + ;; comment-search-backward is only used to find the comment-column (in + ;; comment-set-column) and to find the comment-start string (via + ;; comment-beginning) in indent-new-comment-line, it should be harmless. + (if (not (re-search-backward comment-start-skip limit t)) + (unless noerror (error "No comment")) + (beginning-of-line) + (let* ((end (match-end 0)) + (cs (comment-search-forward end t)) + (pt (point))) + (if (not cs) + (progn (beginning-of-line) + (comment-search-backward limit noerror)) + (while (progn (goto-char cs) + (comment-forward) + (and (< (point) end) + (setq cs (comment-search-forward end t)))) + (setq pt (point))) + (goto-char pt) + cs)))) + +(defun comment-beginning () + "Find the beginning of the enclosing comment. +Returns nil if not inside a comment, else moves point and returns +the same as `comment-search-forward'." + ;; HACK ATTACK! + ;; We should really test `in-string-p' but that can be expensive. + (unless (eq (get-text-property (point) 'face) 'font-lock-string-face) + (let ((pt (point)) + (cs (comment-search-backward nil t))) + (when cs + (if (save-excursion + (goto-char cs) + (and + ;; For modes where comment-start and comment-end are the same, + ;; the search above may have found a `ce' rather than a `cs'. + (or (not (looking-at comment-end-skip)) + ;; Maybe font-lock knows that it's a `cs'? + (eq (get-text-property (match-end 0) 'face) + 'font-lock-comment-face) + (unless (eq (get-text-property (point) 'face) + 'font-lock-comment-face) + ;; Let's assume it's a `cs' if we're on the same line. + (>= (line-end-position) pt))) + ;; Make sure that PT is not past the end of the comment. + (if (comment-forward 1) (> (point) pt) (eobp)))) + cs + (goto-char pt) + nil))))) + +(defun comment-forward (&optional n) + "Skip forward over N comments. +Just like `forward-comment' but only for positive N +and can use regexps instead of syntax." + (setq n (or n 1)) + (if (< n 0) (error "No comment-backward") + (if comment-use-syntax (forward-comment n) + (while (> n 0) + (setq n + (if (or (forward-comment 1) + (and (looking-at comment-start-skip) + (goto-char (match-end 0)) + (re-search-forward comment-end-skip nil 'move))) + (1- n) -1))) + (= n 0)))) + +(defun comment-enter-backward () + "Move from the end of a comment to the end of its content. +Point is assumed to be just at the end of a comment." + (if (bolp) + ;; comment-end = "" + (progn (backward-char) (skip-syntax-backward " ")) + (let ((end (point))) + (beginning-of-line) + (save-restriction + (narrow-to-region (point) end) + (if (re-search-forward (concat comment-end-skip "\\'") nil t) + (goto-char (match-beginning 0)) + ;; comment-end-skip not found probably because it was not set right. + ;; Since \\s> should catch the single-char case, we'll blindly + ;; assume we're at the end of a two-char comment-end. + (goto-char (point-max)) + (backward-char 2) + (skip-chars-backward (string (char-after))) + (skip-syntax-backward " ")))))) + +;;;; +;;;; Commands +;;;; + +;;;###autoload + +;; #### XEmacs had this: in place of just (current-column) +; (defconst comment-indent-function +; ;; XEmacs - add at least one space after the end of the text on the +; ;; current line... +; (lambda () +; (save-excursion +; (beginning-of-line) +; (let ((eol (save-excursion (end-of-line) (point)))) +; (and comment-start-skip +; (re-search-forward comment-start-skip eol t) +; (setq eol (match-beginning 0))) +; (goto-char eol) +; (skip-chars-backward " \t") +; (max comment-column (1+ (current-column)))))) +; "Function to compute desired indentation for a comment. +; This function is called with no args with point at the beginning of +; the comment's starting delimiter.") + +(defun comment-indent-default () + "Default for `comment-indent-function'." + (if (and (looking-at "\\s<\\s<\\(\\s<\\)?") + (or (match-end 1) (/= (current-column) (current-indentation)))) + 0 + (when (or (/= (current-column) (current-indentation)) + (and (> comment-add 0) (looking-at "\\s<\\S<"))) + comment-column))) + +;;;###autoload +(defun comment-indent (&optional continue) + "Indent this line's comment to comment column, or insert an empty comment. +If CONTINUE is non-nil, use the `comment-continue' markers if any. +Comments starting in column 0 are not moved." + (interactive "*") + (comment-normalize-vars) + (let* ((empty (save-excursion (beginning-of-line) + (looking-at "[ \t]*$"))) + (starter (or (and continue comment-continue) + (and empty block-comment-start) comment-start)) + (ender (or (and continue comment-continue "") + (and empty block-comment-end) comment-end))) + (unless starter (error "No comment syntax defined")) + (beginning-of-line) + (let* ((eolpos (line-end-position)) + (begpos (comment-search-forward eolpos t)) + cpos indent) + ;; An existing comment? + (if begpos (setq cpos (point-marker)) + ;; If none, insert one. + (save-excursion + ;; Some comment-indent-function insist on not moving comments that + ;; are in column 0, so we first go to the likely target column. + (indent-to comment-column) + (setq begpos (point)) + (insert starter) + (setq cpos (point-marker)) + (insert ender))) + (goto-char begpos) + ;; Compute desired indent. + (setq indent (save-excursion (funcall comment-indent-function))) + (if (not indent) + ;; comment-indent-function refuses delegates to indent. + (indent-according-to-mode) + ;; Avoid moving comments past the fill-column. + (unless (save-excursion (skip-chars-backward " \t") (bolp)) + (setq indent + (min indent + (+ (current-column) + (- fill-column + (save-excursion (end-of-line) (current-column))))))) + ;; XEmacs change: Preserve indentation of comments starting in + ;; column 0, as documented. + (if (or (= (current-column) 0) (= (current-column) indent)) + (goto-char begpos) + ;; If that's different from current, change it. + (skip-chars-backward " \t") + (delete-region (point) begpos) + (indent-to (if (bolp) indent + (max indent (1+ (current-column))))))) + (goto-char cpos) + (set-marker cpos nil)))) + +;;;###autoload +(defun comment-set-column (arg) + "Set the comment column based on point. +With no ARG, set the comment column to the current column. +With just minus as arg, kill any comment on this line. +With any other arg, set comment column to indentation of the previous comment + and then align or create a comment on this line at that column." + (interactive "P") + (cond + ((eq arg '-) (comment-kill nil)) + (arg + (save-excursion + (beginning-of-line) + (comment-search-backward) + (beginning-of-line) + (goto-char (comment-search-forward (line-end-position))) + (setq comment-column (current-column)) + (lmessage 'command "Comment column set to %d" comment-column)) + (comment-indent)) + (t (setq comment-column (current-column)) + (lmessage 'command "Comment column set to %d" comment-column)))) + +;;;###autoload +(defun comment-kill (arg) + "Kill the comment on this line, if any. +With prefix ARG, kill comments on that many lines starting with this one." + ;; XEmacs change: add * + (interactive "*P") + (dotimes (_ (prefix-numeric-value arg)) + (save-excursion + (beginning-of-line) + (let ((cs (comment-search-forward (line-end-position) t))) + (when cs + (goto-char cs) + (skip-syntax-backward " ") + (setq cs (point)) + (comment-forward) + (kill-region cs (if (bolp) (1- (point)) (point))) + (indent-according-to-mode)))) + (if arg (forward-line 1)))) + +(defun comment-padright (str &optional n) + "Construct a string composed of STR plus `comment-padding'. +It also adds N copies of the last non-whitespace chars of STR. +If STR already contains padding, the corresponding amount is +ignored from `comment-padding'. +N defaults to 0. +If N is `re', a regexp is returned instead, that would match +the string for any N." + (setq n (or n 0)) + (when (and (stringp str) (not (string= "" str))) + ;; Separate the actual string from any leading/trailing padding + (string-match "\\`\\s-*\\(.*?\\)\\s-*\\'" str) + (let ((s (match-string 1 str)) ;actual string + (lpad (substring str 0 (match-beginning 1))) ;left padding + (rpad (concat (substring str (match-end 1)) ;original right padding + (substring comment-padding ;additional right padding + (min (- (match-end 0) (match-end 1)) + (length comment-padding))))) + ;; We can only duplicate C if the comment-end has multiple chars + ;; or if comments can be nested, else the comment-end `}' would + ;; be turned into `}}}' where only the first ends the comment + ;; and the rest becomes bogus junk. + (multi (not (and comment-quote-nested + ;; comment-end is a single char + (string-match "\\`\\s-*\\S-\\s-*\\'" comment-end))))) + (if (not (symbolp n)) + (concat lpad s (when multi (make-string n (aref str (1- (match-end 1))))) rpad) + ;; construct a regexp that would match anything from just S + ;; to any possible output of this function for any N. + (concat (mapconcat (lambda (c) (concat (regexp-quote (string c)) "?")) + lpad "") ;padding is not required + (regexp-quote s) + (when multi "+") ;the last char of S might be repeated + (mapconcat (lambda (c) (concat (regexp-quote (string c)) "?")) + rpad "")))))) ;padding is not required + +(defun comment-padleft (str &optional n) + "Construct a string composed of `comment-padding' plus STR. +It also adds N copies of the first non-whitespace chars of STR. +If STR already contains padding, the corresponding amount is +ignored from `comment-padding'. +N defaults to 0. +If N is `re', a regexp is returned instead, that would match + the string for any N." + (setq n (or n 0)) + (when (and (stringp str) (not (string= "" str))) + ;; Only separate the left pad because we assume there is no right pad. + (string-match "\\`\\s-*" str) + (let ((s (substring str (match-end 0))) + (pad (concat (substring comment-padding + (min (- (match-end 0) (match-beginning 0)) + (length comment-padding))) + (match-string 0 str))) + (c (aref str (match-end 0))) ;the first non-space char of STR + ;; We can only duplicate C if the comment-end has multiple chars + ;; or if comments can be nested, else the comment-end `}' would + ;; be turned into `}}}' where only the first ends the comment + ;; and the rest becomes bogus junk. + (multi (not (and comment-quote-nested + ;; comment-end is a single char + (string-match "\\`\\s-*\\S-\\s-*\\'" comment-end))))) + (if (not (symbolp n)) + (concat pad (when multi (make-string n c)) s) + ;; Construct a regexp that would match anything from just S + ;; to any possible output of this function for any N. + ;; We match any number of leading spaces because this regexp will + ;; be used for uncommenting where we might want to remove + ;; uncomment markers with arbitrary leading space (because + ;; they were aligned). + (concat "\\s-*" + (if multi (concat (regexp-quote (string c)) "*")) + (regexp-quote s)))))) + +;;;###autoload +(defun uncomment-region (beg end &optional arg) + "Uncomment each line in the BEG..END region. +The numeric prefix ARG can specify a number of chars to remove from the +comment markers." + (interactive "*r\nP") + (comment-normalize-vars) + (if (> beg end) (let (mid) (setq mid beg beg end end mid))) + (save-excursion + (goto-char beg) + (setq end (copy-marker end)) + + ;; XEmacs: Add the following clause + + ;; if user didn't specify how many comments to remove, be smart + ;; and remove the minimal number that all lines have. that way, + ;; comments in a region of Elisp code that gets commented out will + ;; get put back correctly. + (if (null arg) + (let ((min-comments 999999)) + (while (not (eobp)) + (let ((this-comments 0)) + (while (looking-at (regexp-quote comment-start)) + (incf this-comments) + (forward-char (length comment-start))) + (if (and (> this-comments 0) (< this-comments min-comments)) + (setq min-comments this-comments)) + (forward-line 1))) + (if (< min-comments 999999) + (setq arg (list min-comments))) + (goto-char beg))) + + (let ((numarg (prefix-numeric-value arg)) + spt) + (while (and (< (point) end) + (setq spt (comment-search-forward end t))) + (let* ((ipt (point)) + ;; Find the end of the comment. + (ept (progn + (goto-char spt) + (unless (comment-forward) + (error "Can't find the comment end")) + (point))) + (box nil) + (ccs comment-continue) + (srei (comment-padright ccs 're)) + (sre (and srei (concat "^\\s-*?\\(" srei "\\)")))) + (save-restriction + (narrow-to-region spt ept) + ;; Remove the comment-start. + (goto-char ipt) + (skip-syntax-backward " ") + ;; Check for special `=' used sometimes in comment-box. + (when (and (= (- (point) (point-min)) 1) (looking-at "=\\{7\\}")) + (skip-chars-forward "=")) + ;; A box-comment starts with a looong comment-start marker. + (when (> (- (point) (point-min) (length comment-start)) 7) + (setq box t)) + (when (looking-at (regexp-quote comment-padding)) + (goto-char (match-end 0))) + (when (and sre (looking-at (concat "\\s-*\n\\s-*" srei))) + (goto-char (match-end 0))) + (if (null arg) (delete-region (point-min) (point)) + (skip-syntax-backward " ") + (delete-char (- numarg))) + + ;; Remove the end-comment (and leading padding and such). + (goto-char (point-max)) (comment-enter-backward) + ;; Check for special `=' used sometimes in comment-box. + (when (= (- (point-max) (point)) 1) + (let ((pos (point))) + ;; skip `=' but only if there are at least 7. + (when (> (skip-chars-backward "=") -7) (goto-char pos)))) + (unless (looking-at "\\(\n\\|\\s-\\)*\\'") + (when (and (bolp) (not (bobp))) (backward-char)) + (if (null arg) (delete-region (point) (point-max)) + (skip-syntax-forward " ") + (delete-char numarg))) + + ;; Unquote any nested end-comment. + (comment-quote-nested comment-start comment-end t) + + ;; Eliminate continuation markers as well. + (when sre + (let* ((cce (comment-string-reverse (or comment-continue + comment-start))) + (erei (and box (comment-padleft cce 're))) + (ere (and erei (concat "\\(" erei "\\)\\s-*$")))) + (goto-char (point-min)) + (while (progn + (if (and ere (re-search-forward + ere (line-end-position) t)) + (replace-match "" t t nil (if (match-end 2) 2 1)) + (setq ere nil)) + (forward-line 1) + (re-search-forward sre (line-end-position) t)) + (replace-match "" t t nil (if (match-end 2) 2 1))))) + ;; Go the the end for the next comment. + (goto-char (point-max))))) + (set-marker end nil)))) + +(defun comment-make-extra-lines (cs ce ccs cce min-indent max-indent &optional block) + "Make the leading and trailing extra lines. +This is used for `extra-line' style (or `box' style if BLOCK is specified)." + (let ((eindent 0)) + (if (not block) + ;; Try to match CS and CE's content so they align aesthetically. + (progn + (setq ce (comment-string-strip ce t t)) + (when (string-match "\\(.+\\).*\n\\(.*?\\)\\1" (concat ce "\n" cs)) + (setq eindent + (max (- (match-end 2) (match-beginning 2) (match-beginning 0)) + 0)))) + ;; box comment + (let* ((width (- max-indent min-indent)) + (s (concat cs "a=m" cce)) + (e (concat ccs "a=m" ce)) + (c (if (string-match ".*\\S-\\S-" cs) + (aref cs (1- (match-end 0))) ?=)) + ; Huh? (_ (string-match "\\s-*a=m\\s-*" s)) + (fill + (make-string (+ width (- (match-end 0) + (match-beginning 0) (length cs) 3)) c))) + (setq cs (replace-match fill t t s)) + (string-match "\\s-*a=m\\s-*" e) + (setq ce (replace-match fill t t e)))) + (cons (concat cs "\n" (make-string min-indent ? ) ccs) + (concat cce "\n" (make-string (+ min-indent eindent) ? ) ce)))) + +;(def-edebug-spec comment-with-narrowing t) +(put 'comment-with-narrowing 'lisp-indent-function 2) +(defmacro comment-with-narrowing (beg end &rest body) + "Execute BODY with BEG..END narrowing. +Space is added (and then removed) at the beginning for the text's +indentation to be kept as it was before narrowing." + (let ((bindent (make-symbol "bindent"))) + `(let ((,bindent (save-excursion (goto-char beg) (current-column)))) + (save-restriction + (narrow-to-region beg end) + (goto-char (point-min)) + (insert (make-string ,bindent ? )) + (prog1 + (progn ,@body) + ;; remove the bindent + (save-excursion + (goto-char (point-min)) + (when (looking-at " *") + (let ((n (min (- (match-end 0) (match-beginning 0)) ,bindent))) + (delete-char n) + (setq ,bindent (- ,bindent n)))) + (end-of-line) + (let ((e (point))) + (beginning-of-line) + (while (and (> ,bindent 0) (re-search-forward " *" e t)) + (let ((n (min ,bindent (- (match-end 0) (match-beginning 0) 1)))) + (goto-char (match-beginning 0)) + (delete-char n) + (setq ,bindent (- ,bindent n))))))))))) + +(defun comment-region-internal (beg end cs ce + &optional ccs cce block lines indent) + "Comment region BEG..END. +CS and CE are the comment start resp end string. +CCS and CCE are the comment continuation strings for the start resp end +of lines (default to CS and CE). +BLOCK indicates that end of lines should be marked with either CCE, CE or CS +\(if CE is empty) and that those markers should be aligned. +LINES indicates that an extra lines will be used at the beginning and end +of the region for CE and CS. +INDENT indicates to put CS and CCS at the current indentation of the region +rather than at left margin." + ;;(assert (< beg end)) + (let ((no-empty t)) + ;; Sanitize CE and CCE. + (if (and (stringp ce) (string= "" ce)) (setq ce nil)) + (if (and (stringp cce) (string= "" cce)) (setq cce nil)) + ;; If CE is empty, multiline cannot be used. + (unless ce (setq ccs nil cce nil)) + ;; Should we mark empty lines as well ? + (if (or ccs block lines) (setq no-empty nil)) + ;; Make sure we have end-markers for BLOCK mode. + (when block (unless ce (setq ce (comment-string-reverse cs)))) + ;; If BLOCK is not requested, we don't need CCE. + (unless block (setq cce nil)) + ;; Continuation defaults to the same as CS and CE. + (unless ccs (setq ccs cs cce ce)) + + (save-excursion + (goto-char end) + ;; If the end is not at the end of a line and the comment-end + ;; is implicit (i.e. a newline), explicitly insert a newline. + (unless (or ce (eolp)) (insert "\n") (indent-according-to-mode)) + (comment-with-narrowing beg end + (let ((min-indent (point-max)) + (max-indent 0)) + (goto-char (point-min)) + ;; Quote any nested comment marker + (comment-quote-nested comment-start comment-end nil) + + ;; Loop over all lines to find the needed indentations. + (goto-char (point-min)) + (while + (progn + (unless (looking-at "[ \t]*$") + (setq min-indent (min min-indent (current-indentation)))) + (end-of-line) + (setq max-indent (max max-indent (current-column))) + (not (or (eobp) (progn (forward-line) nil))))) + + ;; Inserting ccs can change max-indent by (1- tab-width). + (setq max-indent + (+ max-indent (max (length cs) (length ccs)) tab-width -1)) + (unless indent (setq min-indent 0)) + + ;; make the leading and trailing lines if requested + (when lines + (let ((csce + (comment-make-extra-lines + cs ce ccs cce min-indent max-indent block))) + (setq cs (car csce)) + (setq ce (cdr csce)))) + + (goto-char (point-min)) + ;; Loop over all lines from BEG to END. + (while + (progn + (unless (and no-empty (looking-at "[ \t]*$")) + (move-to-column min-indent t) + (insert cs) (setq cs ccs) ;switch to CCS after the first line + (end-of-line) + (if (eobp) (setq cce ce)) + (when cce + (when block (move-to-column max-indent t)) + (insert cce))) + (end-of-line) + (not (or (eobp) (progn (forward-line) nil)))))))))) + +;;;###autoload +(defun comment-region (beg end &optional arg) + "Comment or uncomment each line in the region. +With just \\[universal-argument] prefix arg, uncomment each line in region BEG..END. +Numeric prefix arg ARG means use ARG comment characters. +If ARG is negative, delete that many comment characters instead. +By default, comments start at the left margin, are terminated on each line, +even for syntax in which newline does not end the comment and blank lines +do not get comments. This can be changed with `comment-style'. + +The strings used as comment starts are built from +`comment-start' without trailing spaces and `comment-padding'." + (interactive "*r\nP") + (comment-normalize-vars) + (if (> beg end) (let (mid) (setq mid beg beg end end mid))) + (let* ((numarg (prefix-numeric-value arg)) + (add comment-add) + (style (cdr (assoc comment-style comment-styles))) + (lines (nth 2 style)) + (block (nth 1 style)) + (multi (nth 0 style))) + (save-excursion + ;; we use `chars' instead of `syntax' because `\n' might be + ;; of end-comment syntax rather than of whitespace syntax. + ;; sanitize BEG and END + (goto-char beg) (skip-chars-forward " \t\n\r") (beginning-of-line) + (setq beg (max beg (point))) + (goto-char end) (skip-chars-backward " \t\n\r") (end-of-line) + (setq end (min end (point))) + (if (>= beg end) (error "Nothing to comment")) + + ;; sanitize LINES + (setq lines + (and + lines ;; multi + (progn (goto-char beg) (beginning-of-line) + (skip-syntax-forward " ") + (>= (point) beg)) + (progn (goto-char end) (end-of-line) (skip-syntax-backward " ") + (<= (point) end)) + (or (not (string= "" comment-end)) block) + (progn (goto-char beg) (search-forward "\n" end t))))) + + ;; don't add end-markers just because the user asked for `block' + (unless (or lines (string= "" comment-end)) (setq block nil)) + + (cond + ((consp arg) (uncomment-region beg end)) + ((< numarg 0) (uncomment-region beg end (- numarg))) + (t + (setq numarg (if (and (null arg) (= (length comment-start) 1)) + add (1- numarg))) + (comment-region-internal + beg end + (let ((s (comment-padright comment-start numarg))) + (if (string-match comment-start-skip s) s + (comment-padright comment-start))) + (let ((s (comment-padleft comment-end numarg))) + (and s (if (string-match comment-end-skip s) s + (comment-padright comment-end)))) + (if multi (comment-padright comment-continue numarg)) + (if multi (comment-padleft (comment-string-reverse comment-continue) numarg)) + block + lines + (nth 3 style)))))) + +(defun comment-box (beg end &optional arg) + "Comment out the BEG..END region, putting it inside a box. +The numeric prefix ARG specifies how many characters to add to begin- and +end- comment markers additionally to what `comment-add' already specifies." + (interactive "*r\np") + (let ((comment-style (if (cadr (assoc comment-style comment-styles)) + 'box-multi 'box))) + (comment-region beg end (+ comment-add arg)))) + +;;;###autoload +(defun comment-dwim (arg) + "Call the comment command you want (Do What I Mean). +If the region is active and `transient-mark-mode' is on, call + `comment-region' (unless it only consists of comments, in which + case it calls `uncomment-region'). +Else, if the current line is empty, insert a comment and indent it. +Else if a prefix ARG is specified, call `comment-kill'. +Else, call `comment-indent'." + (interactive "*P") + (comment-normalize-vars) + (if (region-active-p) ;mark-active transient-mark-mode) + (let ((beg (min (point) (mark))) + (end (max (point) (mark)))) + (if (save-excursion ;; check for already commented region + (goto-char beg) + (comment-forward (point-max)) + (<= end (point))) + (uncomment-region beg end arg) + (comment-region beg end arg))) + (if (save-excursion (beginning-of-line) (not (looking-at "\\s-*$"))) + ;; FIXME: If there's no comment to kill on this line and ARG is + ;; specified, calling comment-kill is not very clever. + (if arg (comment-kill (and (integerp arg) arg)) (comment-indent)) + (let ((add (if arg (prefix-numeric-value arg) + (if (= (length comment-start) 1) comment-add 0)))) + ;; Some modes insist on keeping column 0 comment in column 0 + ;; so we need to move away from it before inserting the comment. + (indent-according-to-mode) + (insert (comment-padright comment-start add)) + (save-excursion + (unless (string= "" comment-end) + (insert (comment-padleft comment-end add))) + (indent-according-to-mode)))))) + +(defcustom comment-auto-fill-only-comments nil + "Non-nil means to only auto-fill inside comments. +This has no effect in modes that do not define a comment syntax." + :type 'boolean + :group 'comment) + +;;;###autoload +(defun comment-indent-new-line (&optional soft) + "Break line at point and indent, continuing comment if within one. +This indents the body of the continued comment +under the previous comment line. + +This command is intended for styles where you write a comment per line, +starting a new comment (and terminating it if necessary) on each line. +If you want to continue one comment across several lines, use \\[newline-and-indent]. + +If a fill column is specified, it overrides the use of the comment column +or comment indentation. + +The inserted newline is marked hard if variable `use-hard-newlines' is true, +unless optional argument SOFT is non-nil." + (interactive) + (comment-normalize-vars t) + (let (compos comin) + ;; If we are not inside a comment and we only auto-fill comments, + ;; don't do anything (unless no comment syntax is defined). + (unless (and comment-start + comment-auto-fill-only-comments + (not (save-excursion + (prog1 (setq compos (comment-beginning)) + (setq comin (point)))))) + + ;; Now we know we should auto-fill. + ;; XEmacs: next 3 lines from old version. + (skip-chars-backward " \t") + (if (featurep 'mule) + (declare-fboundp (kinsoku-process))) + (delete-horizontal-space) + (if soft (insert-and-inherit ?\n) (newline 1)) + (if fill-prefix + (progn + (indent-to-left-margin) + (insert-and-inherit fill-prefix)) + + ;;#### jhod: probably need to fix this for kinsoku processing + ;; If necessary check whether we're inside a comment. + (unless (or comment-multi-line compos (null comment-start)) + (save-excursion + (backward-char) + (setq compos (comment-beginning)) + (setq comin (point)))) + + ;; If we're not inside a comment, just try to indent. + ;; #### XEmacs: the line `(if comcol' was changed as follows. + ;; I'm leaving it out since who knows if it's applicable any more. + ;; --ben + ;; (if (and comcol (not fill-prefix)) ; XEmacs - (ENE) from fa-extras. + (if (not compos) (indent-according-to-mode) + (let* ((comment-column + ;; The continuation indentation should be somewhere between + ;; the current line's indentation (plus 2 for good measure) + ;; and the current comment's indentation, with a preference + ;; for comment-column. + (save-excursion + (goto-char compos) + (min (current-column) (max comment-column + (+ 2 (current-indentation)))))) + (comstart (buffer-substring compos comin)) + (normalp + (string-match (regexp-quote (comment-string-strip + comment-start t t)) + comstart)) + (comment-end + (if normalp comment-end + ;; The comment starter is not the normal comment-start + ;; so we can't just use comment-end. + (save-excursion + (goto-char compos) + (if (not (comment-forward)) comment-end + (comment-string-strip + (buffer-substring + (save-excursion (comment-enter-backward) (point)) + (point)) + nil t))))) + (comment-start comstart) + ;; Force comment-continue to be recreated from comment-start. + ;; FIXME: wrong if comment-continue was set explicitly! + (comment-continue nil)) + (insert-and-inherit ?\n) + (forward-char -1) + (comment-indent (cadr (assoc comment-style comment-styles))) + (save-excursion + (let ((pt (point))) + (end-of-line) + (let ((comend (buffer-substring pt (point)))) + ;; The 1+ is to make sure we delete the \n inserted above. + (delete-region pt (1+ (point))) + (beginning-of-line) + (backward-char) + (insert comend) + (forward-char)))))))))) + +(provide 'newcomment) + +;;; newcomment.el ends here
--- a/lisp/replace.el Sun Mar 02 02:18:12 2003 +0000 +++ b/lisp/replace.el Sun Mar 02 09:38:54 2003 +0000 @@ -1024,23 +1024,4 @@ ; 'query-replace 'region)))) ; (move-overlay replace-overlay start end (current-buffer))))) -(defun match-string (num &optional string) - "Return string of text matched by last search. -NUM specifies which parenthesized expression in the last regexp. - Value is nil if NUMth pair didn't match, or there were less than NUM pairs. -Zero means the entire text matched by the whole regexp or whole string. -STRING should be given if the last search was by `string-match' on STRING." - (if (match-beginning num) - (if string - (substring string (match-beginning num) (match-end num)) - (buffer-substring (match-beginning num) (match-end num))))) - -(defmacro save-match-data (&rest body) - "Execute BODY forms, restoring the global value of the match data." - (let ((original (make-symbol "match-data"))) - (list 'let (list (list original '(match-data))) - (list 'unwind-protect - (cons 'progn body) - (list 'store-match-data original))))) - ;;; replace.el ends here
--- a/lisp/simple.el Sun Mar 02 02:18:12 2003 +0000 +++ b/lisp/simple.el Sun Mar 02 09:38:54 2003 +0000 @@ -25,6 +25,8 @@ ;; 02111-1307, USA. ;;; Synched up with: FSF 19.34 [But not very closely]. +;;; Occasional synching to FSF 21.2, as marked. Comment stuff also +;;; synched, and in newcomment.el. ;;; Commentary: @@ -2681,295 +2683,6 @@ (setq arg (1+ arg))))))) -(defcustom comment-column 32 - "*Column to indent right-margin comments to. -Setting this variable automatically makes it local to the current buffer. -Each mode establishes a different default value for this variable; you -can set the value for a particular mode using that mode's hook." - :type 'integer - :group 'fill-comments) -(make-variable-buffer-local 'comment-column) - -(defcustom comment-start nil - "*String to insert to start a new comment, or nil if no comment syntax." - :type '(choice (const :tag "None" nil) - string) - :group 'fill-comments) - -(defcustom comment-start-skip nil - "*Regexp to match the start of a comment plus everything up to its body. -If there are any \\(...\\) pairs, the comment delimiter text is held to begin -at the place matched by the close of the first pair." - :type '(choice (const :tag "None" nil) - regexp) - :group 'fill-comments) - -(defcustom comment-end "" - "*String to insert to end a new comment. -Should be an empty string if comments are terminated by end-of-line." - :type 'string - :group 'fill-comments) - -(defconst comment-indent-hook nil - "Obsolete variable for function to compute desired indentation for a comment. -Use `comment-indent-function' instead. -This function is called with no args with point at the beginning of -the comment's starting delimiter.") - -(defconst comment-indent-function - ;; XEmacs - add at least one space after the end of the text on the - ;; current line... - (lambda () - (save-excursion - (beginning-of-line) - (let ((eol (save-excursion (end-of-line) (point)))) - (and comment-start-skip - (re-search-forward comment-start-skip eol t) - (setq eol (match-beginning 0))) - (goto-char eol) - (skip-chars-backward " \t") - (max comment-column (1+ (current-column)))))) - "Function to compute desired indentation for a comment. -This function is called with no args with point at the beginning of -the comment's starting delimiter.") - -(defcustom block-comment-start nil - "*String to insert to start a new comment on a line by itself. -If nil, use `comment-start' instead. -Note that the regular expression `comment-start-skip' should skip this string -as well as the `comment-start' string." - :type '(choice (const :tag "Use `comment-start'" nil) - string) - :group 'fill-comments) - -(defcustom block-comment-end nil - "*String to insert to end a new comment on a line by itself. -Should be an empty string if comments are terminated by end-of-line. -If nil, use `comment-end' instead." - :type '(choice (const :tag "Use `comment-end'" nil) - string) - :group 'fill-comments) - -(defun indent-for-comment () - "Indent this line's comment to comment column, or insert an empty -comment. Comments starting in column 0 are not moved." - (interactive "*") - (let* ((empty (save-excursion (beginning-of-line) - (looking-at "[ \t]*$"))) - (starter (or (and empty block-comment-start) comment-start)) - (ender (or (and empty block-comment-end) comment-end))) - (if (null starter) - (error "No comment syntax defined") - (let* ((eolpos (save-excursion (end-of-line) (point))) - cpos indent begpos) - (beginning-of-line) - (if (re-search-forward comment-start-skip eolpos 'move) - (progn (setq cpos (point-marker)) - ;; Find the start of the comment delimiter. - ;; If there were paren-pairs in comment-start-skip, - ;; position at the end of the first pair. - (if (match-end 1) - (goto-char (match-end 1)) - ;; If comment-start-skip matched a string with - ;; internal whitespace (not final whitespace) then - ;; the delimiter start at the end of that - ;; whitespace. Otherwise, it starts at the - ;; beginning of what was matched. - (skip-syntax-backward " " (match-beginning 0)) - (skip-syntax-backward "^ " (match-beginning 0))))) - (setq begpos (point)) - ;; Compute desired indent. - ;; XEmacs change: Preserve indentation of comments starting in - ;; column 0, as documented. - (cond - ((= (current-column) 0) - (goto-char begpos)) - ((= (current-column) - (setq indent (funcall comment-indent-function))) - (goto-char begpos)) - (t - ;; If that's different from current, change it. - (skip-chars-backward " \t") - (delete-region (point) begpos) - (indent-to indent))) - ;; An existing comment? - (if cpos - (progn (goto-char cpos) - (set-marker cpos nil)) - ;; No, insert one. - (insert starter) - (save-excursion - (insert ender))))))) - -(defun set-comment-column (arg) - "Set the comment column based on point. -With no arg, set the comment column to the current column. -With just minus as arg, kill any comment on this line. -With any other arg, set comment column to indentation of the previous comment - and then align or create a comment on this line at that column." - (interactive "P") - (if (eq arg '-) - (kill-comment nil) - (if arg - (progn - (save-excursion - (beginning-of-line) - (re-search-backward comment-start-skip) - (beginning-of-line) - (re-search-forward comment-start-skip) - (goto-char (match-beginning 0)) - (setq comment-column (current-column)) - (lmessage 'command "Comment column set to %d" comment-column)) - (indent-for-comment)) - (setq comment-column (current-column)) - (lmessage 'command "Comment column set to %d" comment-column)))) - -(defun kill-comment (arg) - "Kill the comment on this line, if any. -With argument, kill comments on that many lines starting with this one." - ;; this function loses in a lot of situations. it incorrectly recognizes - ;; comment delimiters sometimes (ergo, inside a string), doesn't work - ;; with multi-line comments, can kill extra whitespace if comment wasn't - ;; through end-of-line, et cetera. - (interactive "*P") - (or comment-start-skip (error "No comment syntax defined")) - (let ((count (prefix-numeric-value arg)) endc) - (while (> count 0) - (save-excursion - (end-of-line) - (setq endc (point)) - (beginning-of-line) - (and (string< "" comment-end) - (setq endc - (progn - (re-search-forward (regexp-quote comment-end) endc 'move) - (skip-chars-forward " \t") - (point)))) - (beginning-of-line) - (if (re-search-forward comment-start-skip endc t) - (progn - (goto-char (match-beginning 0)) - (skip-chars-backward " \t") - (kill-region (point) endc) - ;; to catch comments a line beginnings - (indent-according-to-mode)))) - (if arg (forward-line 1)) - (setq count (1- count))))) - -;; This variable: Synched up with 20.7. -(defvar comment-padding 1 - "Number of spaces `comment-region' puts between comment chars and text. - -Extra spacing between the comment characters and the comment text -makes the comment easier to read. Default is 1. Nil means 0 and is -more efficient.") - -;; This function: Synched up with 20.7. -(defun comment-region (start end &optional arg) - "Comment or uncomment each line in the region. -With just C-u prefix arg, uncomment each line in region. -Numeric prefix arg ARG means use ARG comment characters. -If ARG is negative, delete that many comment characters instead. -Comments are terminated on each line, even for syntax in which newline does -not end the comment. Blank lines do not get comments." - ;; if someone wants it to only put a comment-start at the beginning and - ;; comment-end at the end then typing it, C-x C-x, closing it, C-x C-x - ;; is easy enough. No option is made here for other than commenting - ;; every line. - (interactive "r\nP") - (or comment-start (error "No comment syntax is defined")) - (if (> start end) (let (mid) (setq mid start start end end mid))) - (save-excursion - (save-restriction - (let ((cs comment-start) (ce comment-end) - (cp (when comment-padding - (make-string comment-padding ? ))) - numarg) - (if (consp arg) (setq numarg t) - (setq numarg (prefix-numeric-value arg)) - ;; For positive arg > 1, replicate the comment delims now, - ;; then insert the replicated strings just once. - (while (> numarg 1) - (setq cs (concat cs comment-start) - ce (concat ce comment-end)) - (setq numarg (1- numarg)))) - ;; Loop over all lines from START to END. - (narrow-to-region start end) - (goto-char start) - ;; if user didn't specify how many comments to remove, be smart - ;; and remove the minimal number that all lines have. that way, - ;; comments in a region of Elisp code that gets commented out will - ;; get put back correctly. - (if (eq numarg t) - (let ((min-comments 999999)) - (while (not (eobp)) - (let ((this-comments 0)) - (while (looking-at (regexp-quote cs)) - (incf this-comments) - (forward-char (length cs))) - (if (and (> this-comments 0) (< this-comments min-comments)) - (setq min-comments this-comments)) - (forward-line 1))) - (if (< min-comments 999999) - (setq numarg (- min-comments))) - (goto-char start))) - (if (or (eq numarg t) (< numarg 0)) - (while (not (eobp)) - (let (found-comment) - ;; Delete comment start from beginning of line. - (if (eq numarg t) - (while (looking-at (regexp-quote cs)) - (setq found-comment t) - (delete-char (length cs))) - (let ((count numarg)) - (while (and (> 1 (setq count (1+ count))) - (looking-at (regexp-quote cs))) - (setq found-comment t) - (delete-char (length cs))))) - ;; Delete comment padding from beginning of line - (when (and found-comment comment-padding - (looking-at (regexp-quote cp))) - (delete-char comment-padding)) - ;; Delete comment end from end of line. - (if (string= "" ce) - nil - (if (eq numarg t) - (progn - (end-of-line) - ;; This is questionable if comment-end ends in - ;; whitespace. That is pretty brain-damaged, - ;; though. - (while (progn (skip-chars-backward " \t") - (and (>= (- (point) (point-min)) - (length ce)) - (save-excursion - (backward-char (length ce)) - (looking-at (regexp-quote ce))))) - (delete-char (- (length ce))))) - (let ((count numarg)) - (while (> 1 (setq count (1+ count))) - (end-of-line) - ;; This is questionable if comment-end ends in - ;; whitespace. That is pretty brain-damaged though - (skip-chars-backward " \t") - (if (>= (- (point) (point-min)) (length ce)) - (save-excursion - (backward-char (length ce)) - (if (looking-at (regexp-quote ce)) - (delete-char (length ce))))))))) - (forward-line 1))) - - (when comment-padding - (setq cs (concat cs cp))) - (while (not (eobp)) - ;; Insert at beginning and at end. - (if (looking-at "[ \t]*$") () - (insert cs) - (if (string= "" ce) () - (end-of-line) - (insert ce))) - (search-forward "\n" nil 'move))))))) - ;; XEmacs (defun prefix-region (prefix) "Add a prefix string to each line between mark and point." @@ -3334,98 +3047,9 @@ (error "set-fill-column requires an explicit argument"))) (lmessage 'command "fill-column set to %d" fill-column)) -(defcustom comment-multi-line t ; XEmacs - this works well with adaptive fill - "*Non-nil means \\[indent-new-comment-line] should continue same comment -on new line, with no new terminator or starter. -This is obsolete because you might as well use \\[newline-and-indent]." - :type 'boolean - :group 'fill-comments) - -(defun indent-new-comment-line (&optional soft) - "Break line at point and indent, continuing comment if within one. -This indents the body of the continued comment -under the previous comment line. - -This command is intended for styles where you write a comment per line, -starting a new comment (and terminating it if necessary) on each line. -If you want to continue one comment across several lines, use \\[newline-and-indent]. - -If a fill column is specified, it overrides the use of the comment column -or comment indentation. - -The inserted newline is marked hard if `use-hard-newlines' is true, -unless optional argument SOFT is non-nil." - (interactive) - (let (comcol comstart) - (skip-chars-backward " \t") - (if (featurep 'mule) - (declare-fboundp (kinsoku-process))) - (delete-region (point) - (progn (skip-chars-forward " \t") - (point))) - (if soft (insert ?\n) (newline 1)) - (if fill-prefix - (progn - (indent-to-left-margin) - (insert fill-prefix)) - ;; #### - Eric Eide reverts to v18 semantics for this function in - ;; fa-extras, which I'm not gonna do. His changes are to (1) execute - ;; the save-excursion below unconditionally, and (2) uncomment the check - ;; for (not comment-multi-line) further below. --Stig - ;;#### jhod: probably need to fix this for kinsoku processing - (if (not comment-multi-line) - (save-excursion - (if (and comment-start-skip - (let ((opoint (point))) - (forward-line -1) - (re-search-forward comment-start-skip opoint t))) - ;; The old line is a comment. - ;; Set WIN to the pos of the comment-start. - ;; But if the comment is empty, look at preceding lines - ;; to find one that has a nonempty comment. - - ;; If comment-start-skip contains a \(...\) pair, - ;; the real comment delimiter starts at the end of that pair. - (let ((win (or (match-end 1) (match-beginning 0)))) - (while (and (eolp) (not (bobp)) - (let (opoint) - (beginning-of-line) - (setq opoint (point)) - (forward-line -1) - (re-search-forward comment-start-skip opoint t))) - (setq win (or (match-end 1) (match-beginning 0)))) - ;; Indent this line like what we found. - (goto-char win) - (setq comcol (current-column)) - (setq comstart - (buffer-substring (point) (match-end 0))))))) - (if (and comcol (not fill-prefix)) ; XEmacs - (ENE) from fa-extras. - (let ((comment-column comcol) - (comment-start comstart) - (block-comment-start comstart) - (comment-end comment-end)) - (and comment-end (not (equal comment-end "")) - ; (if (not comment-multi-line) - (progn - (backward-char 1) - (insert comment-end) - (forward-char 1)) - ; (setq comment-column (+ comment-column (length comment-start)) - ; comment-start "") - ; ) - ) - (if (not (eolp)) - (setq comment-end "")) - (insert ?\n) - (backward-char 1) - (indent-for-comment) - (save-excursion - ;; Make sure we delete the newline inserted above. - (end-of-line) - (delete-char 1))) - (indent-according-to-mode))))) - - + +;; BEGIN SYNCHED WITH FSF 21.2. + (defun set-selective-display (arg) "Set `selective-display' to ARG; clear it if no arg. When the value of `selective-display' is a number > 0, @@ -3471,14 +3095,14 @@ (add-hook 'change-major-mode-hook 'nuke-selective-display) -(defconst overwrite-mode-textual " Ovwrt" +(defvar overwrite-mode-textual " Ovwrt" "The string displayed in the mode line when in overwrite mode.") -(defconst overwrite-mode-binary " Bin Ovwrt" +(defvar overwrite-mode-binary " Bin Ovwrt" "The string displayed in the mode line when in binary overwrite mode.") (defun overwrite-mode (arg) "Toggle overwrite mode. -With arg, enable overwrite mode if arg is positive, else disable. +With arg, turn overwrite mode on iff arg is positive. In overwrite mode, printing characters typed in replace existing text on a one-for-one basis, rather than pushing it to the right. At the end of a line, such characters extend the line. Before a tab, @@ -3494,7 +3118,7 @@ (defun binary-overwrite-mode (arg) "Toggle binary overwrite mode. -With arg, enable binary overwrite mode if arg is positive, else disable. +With arg, turn binary overwrite mode on iff arg is positive. In binary overwrite mode, printing characters typed in replace existing text. Newlines are not treated specially, so typing at the end of a line joins the line to the next, with the typed character @@ -3513,6 +3137,9 @@ (> (prefix-numeric-value arg) 0)) 'overwrite-mode-binary)) (redraw-modeline)) + +;; END SYNCHED WITH FSF 21.2. + (defcustom line-number-mode t "*Non-nil means display line number in modeline." @@ -3672,26 +3299,43 @@ ;; mail composition code ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; BEGIN SYNCHED WITH FSF 21.2. + (defcustom mail-user-agent 'sendmail-user-agent "*Your preference for a mail composition package. -Various Emacs Lisp packages (e.g. reporter) require you to compose an +Various Emacs Lisp packages (e.g. Reporter) require you to compose an outgoing email message. This variable lets you specify which mail-sending package you prefer. Valid values include: - sendmail-user-agent -- use the default Emacs Mail package - mh-e-user-agent -- use the Emacs interface to the MH mail system - message-user-agent -- use the GNUS mail sending package + `sendmail-user-agent' -- use the default Emacs Mail package. + See Info node `(emacs)Sending Mail'. + `mh-e-user-agent' -- use the Emacs interface to the MH mail system. + See Info node `(mh-e)'. + `message-user-agent' -- use the Gnus Message package. + See Info node `(message)'. + `gnus-user-agent' -- like `message-user-agent', but with Gnus + paraphernalia, particularly the Gcc: header for + archiving. Additional valid symbols may be available; check with the author of -your package for details." +your package for details. The function should return non-nil if it +succeeds. + +See also `read-mail-command' concerning reading mail." :type '(radio (function-item :tag "Default Emacs mail" :format "%t\n" sendmail-user-agent) - (function-item :tag "Gnus mail sending package" + (function-item :tag "Emacs interface to MH" + :format "%t\n" + mh-e-user-agent) + (function-item :tag "Gnus Message package" :format "%t\n" message-user-agent) + (function-item :tag "Gnus Message with full Gnus features" + :format "%t\n" + gnus-user-agent) (function :tag "Other")) :group 'mail) @@ -3737,6 +3381,13 @@ 'message-mail 'message-send-and-exit 'message-kill-buffer 'message-send-hook) +(defun rfc822-goto-eoh () + ;; Go to header delimiter line in a mail message, following RFC822 rules + (goto-char (point-min)) + (while (looking-at "^[^: \n]+:\\|^[ \t]") + (forward-line 1)) + (point)) + (defun sendmail-user-agent-compose (&optional to subject other-headers continue switch-function yank-action send-actions) @@ -3747,24 +3398,28 @@ (same-window-regexps nil)) (funcall switch-function "*mail*"))) (let ((cc (cdr (assoc-ignore-case "cc" other-headers))) - (in-reply-to (cdr (assoc-ignore-case "in-reply-to" other-headers)))) + (in-reply-to (cdr (assoc-ignore-case "in-reply-to" other-headers))) + (body (cdr (assoc-ignore-case "body" other-headers)))) (or (declare-fboundp (mail continue to subject in-reply-to cc yank-action send-actions)) continue (error "Message aborted")) (save-excursion - (goto-char (point-min)) - (search-forward (declare-boundp mail-header-separator)) - (beginning-of-line) + (rfc822-goto-eoh) (while other-headers - (if (not (member (car (car other-headers)) '("in-reply-to" "cc"))) + (unless (member* (car (car other-headers)) + '("in-reply-to" "cc" "body") + :test 'equalp) (insert (car (car other-headers)) ": " (cdr (car other-headers)) "\n")) (setq other-headers (cdr other-headers))) + (when body + (forward-line 1) + (insert body)) t))) (define-mail-user-agent 'mh-e-user-agent - 'mh-user-agent-compose 'mh-send-letter 'mh-fully-kill-draft + 'mh-smail-batch 'mh-send-letter 'mh-fully-kill-draft 'mh-before-send-letter-hook) (defun compose-mail (&optional to subject other-headers continue @@ -3822,48 +3477,199 @@ ;; set variable ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defvar set-variable-value-history nil + "History of values entered with `set-variable'.") + (defun set-variable (var val) "Set VARIABLE to VALUE. VALUE is a Lisp object. -When using this interactively, supply a Lisp expression for VALUE. +When using this interactively, enter a Lisp object for VALUE. If you want VALUE to be a string, you must surround it with doublequotes. +VALUE is used literally, not evaluated. + If VARIABLE is a specifier, VALUE is added to it as an instantiator in the 'global locale with nil tag set (see `set-specifier'). If VARIABLE has a `variable-interactive' property, that is used as if -it were the arg to `interactive' (which see) to interactively read the value." +it were the arg to `interactive' (which see) to interactively read VALUE. + +If VARIABLE has been defined with `defcustom', then the type information +in the definition is used to check that VALUE is valid." (interactive - (let* ((var (read-variable "Set variable: ")) - ;; #### - yucky code replication here. This should use something - ;; from help.el or hyper-apropos.el - (myhelp - #'(lambda () - (with-output-to-temp-buffer "*Help*" - (prin1 var) - (princ "\nDocumentation:\n") - (princ (substring (documentation-property var 'variable-documentation) - 1)) - (if (boundp var) - (let ((print-length 20)) - (princ "\n\nCurrent value: ") - (prin1 (symbol-value var)))) - (save-excursion - (set-buffer standard-output) - (help-mode)) - nil))) - (minibuffer-help-form - '(funcall myhelp))) - (list var - (let ((prop (get var 'variable-interactive))) - (if prop - ;; Use VAR's `variable-interactive' property - ;; as an interactive spec for prompting. - (call-interactively (list 'lambda '(arg) - (list 'interactive prop) - 'arg)) - (eval-minibuffer (format "Set %s to value: " var))))))) + (let* ((default-var (variable-at-point)) + (var (if (symbolp default-var) + (read-variable (format "Set variable (default %s): " default-var) + default-var) + (read-variable "Set variable: "))) + (minibuffer-help-form '(describe-variable var)) + (prop (get var 'variable-interactive)) + (prompt (format "Set %s to value: " var)) + (val (if prop + ;; Use VAR's `variable-interactive' property + ;; as an interactive spec for prompting. + (call-interactively `(lambda (arg) + (interactive ,prop) + arg)) + (read + (read-string prompt nil + 'set-variable-value-history))))) + (list var val))) + + (let ((type (get var 'custom-type))) + (when type + ;; Match with custom type. + (require 'cus-edit) + (setq type (widget-convert type)) + (unless (widget-apply type :match val) + (error "Value `%S' does not match type %S of %S" + val (car type) var)))) (if (and (boundp var) (specifierp (symbol-value var))) (set-specifier (symbol-value var) val) - (set var val))) + (set var val)) + + ;; Force a thorough redisplay for the case that the variable + ;; has an effect on the display, like `tab-width' has. + (force-mode-line-update)) + + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; forking a twin copy of a buffer ;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defvar clone-buffer-hook nil + "Normal hook to run in the new buffer at the end of `clone-buffer'.") + +(defun clone-process (process &optional newname) + "Create a twin copy of PROCESS. +If NEWNAME is nil, it defaults to PROCESS' name; +NEWNAME is modified by adding or incrementing <N> at the end as necessary. +If PROCESS is associated with a buffer, the new process will be associated + with the current buffer instead. +Returns nil if PROCESS has already terminated." + (setq newname (or newname (process-name process))) + (if (string-match "<[0-9]+>\\'" newname) + (setq newname (substring newname 0 (match-beginning 0)))) + (when (memq (process-status process) '(run stop open)) + (let* ((process-connection-type (process-tty-name process)) + (old-kwoq (process-kill-without-query process nil)) + (new-process + (if (memq (process-status process) '(open)) + (apply 'open-network-stream newname + (if (process-buffer process) (current-buffer)) + ;; FSF: (process-contact process) + (process-command process)) + (apply 'start-process newname + (if (process-buffer process) (current-buffer)) + (process-command process))))) + (process-kill-without-query new-process old-kwoq) + (process-kill-without-query process old-kwoq) + ;; FSF 21.2: +; (set-process-inherit-coding-system-flag +; new-process (process-inherit-coding-system-flag process)) + (set-process-filter new-process (process-filter process)) + (set-process-sentinel new-process (process-sentinel process)) + new-process))) + +;; things to maybe add (currently partly covered by `funcall mode': +;; - syntax-table +;; - overlays +(defun clone-buffer (&optional newname display-flag) + "Create a twin copy of the current buffer. +If NEWNAME is nil, it defaults to the current buffer's name; +NEWNAME is modified by adding or incrementing <N> at the end as necessary. + +If DISPLAY-FLAG is non-nil, the new buffer is shown with `pop-to-buffer'. +This runs the normal hook `clone-buffer-hook' in the new buffer +after it has been set up properly in other respects." + (interactive (list (if current-prefix-arg (read-string "Name: ")) + t)) + (if buffer-file-name + (error "Cannot clone a file-visiting buffer")) + (if (get major-mode 'no-clone) + (error "Cannot clone a buffer in %s mode" mode-name)) + (setq newname (or newname (buffer-name))) + (if (string-match "<[0-9]+>\\'" newname) + (setq newname (substring newname 0 (match-beginning 0)))) + (let ((buf (current-buffer)) + (ptmin (point-min)) + (ptmax (point-max)) + (pt (point)) + (mk (mark t)) ;(if mark-active (mark t))) + (modified (buffer-modified-p)) + (mode major-mode) + (lvars (buffer-local-variables)) + (process (get-buffer-process (current-buffer))) + (new (generate-new-buffer (or newname (buffer-name))))) + (save-restriction + (widen) + (with-current-buffer new + (insert-buffer-substring buf))) + (with-current-buffer new + (narrow-to-region ptmin ptmax) + (goto-char pt) + (if mk (set-mark mk)) + (set-buffer-modified-p modified) + + ;; Clone the old buffer's process, if any. + (when process (clone-process process)) + + ;; Now set up the major mode. + (funcall mode) + + ;; Set up other local variables. + (mapcar (lambda (v) + (condition-case () ;in case var is read-only + (if (symbolp v) + (makunbound v) + (set (make-local-variable (car v)) (cdr v))) + (error nil))) + lvars) + + ;; Run any hooks (typically set up by the major mode + ;; for cloning to work properly). + (run-hooks 'clone-buffer-hook)) + (if display-flag (pop-to-buffer new)) + new)) + + +(defun clone-indirect-buffer (newname display-flag &optional norecord) + "Create an indirect buffer that is a twin copy of the current buffer. + +Give the indirect buffer name NEWNAME. Interactively, read NEW-NAME +from the minibuffer when invoked with a prefix arg. If NEWNAME is nil +or if not called with a prefix arg, NEWNAME defaults to the current +buffer's name. The name is modified by adding a `<N>' suffix to it +or by incrementing the N in an existing suffix. + +DISPLAY-FLAG non-nil means show the new buffer with `pop-to-buffer'. +This is always done when called interactively. + +Optional last arg NORECORD non-nil means do not put this buffer at the +front of the list of recently selected ones." + (interactive (list (if current-prefix-arg + (read-string "BName of indirect buffer: ")) + t)) + (setq newname (or newname (buffer-name))) + (if (string-match "<[0-9]+>\\'" newname) + (setq newname (substring newname 0 (match-beginning 0)))) + (let* ((name (generate-new-buffer-name newname)) + (buffer (make-indirect-buffer (current-buffer) name t))) + (when display-flag + (pop-to-buffer buffer norecord)) + buffer)) + + +(defun clone-indirect-buffer-other-window (buffer &optional norecord) + "Create an indirect buffer that is a twin copy of BUFFER. +Select the new buffer in another window. +Optional second arg NORECORD non-nil means do not put this buffer at +the front of the list of recently selected ones." + (interactive "bClone buffer in other window: ") + (let ((pop-up-windows t)) + (set-buffer buffer) + (clone-indirect-buffer nil t norecord))) + +;; END SYNCHED WITH FSF 21.2. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
--- a/lisp/subr.el Sun Mar 02 02:18:12 2003 +0000 +++ b/lisp/subr.el Sun Mar 02 09:38:54 2003 +0000 @@ -3,7 +3,7 @@ ;; Copyright (C) 1985, 1986, 1992, 1994-5, 1997 Free Software Foundation, Inc. ;; Copyright (C) 1995 Tinker Systems and INS Engineering Corp. ;; Copyright (C) 1995 Sun Microsystems. -;; Copyright (C) 2000, 2001, 2002 Ben Wing. +;; Copyright (C) 2000, 2001, 2002, 2003 Ben Wing. ;; Maintainer: XEmacs Development Team ;; Keywords: extensions, dumped @@ -25,7 +25,7 @@ ;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA ;; 02111-1307, USA. -;;; Synched up with: FSF 19.34. +;;; Synched up with: FSF 19.34. Some things synched up with later versions. ;;; Commentary: @@ -36,8 +36,18 @@ ;; of commentary just to give diff(1) something to synch itself with to ;; provide useful context diffs. -sb +;; BEGIN SYNCHED WITH FSF 21.2 + ;;; Code: +(defvar custom-declare-variable-list nil + "Record `defcustom' calls made before `custom.el' is loaded to handle them. +Each element of this list holds the arguments to one call to `defcustom'.") +;; Use this, rather than defcustom, in subr.el and other files loaded +;; before custom.el. +(defun custom-declare-variable-early (&rest arguments) + (setq custom-declare-variable-list + (cons arguments custom-declare-variable-list))) ;;;; Lisp language features. @@ -58,6 +68,36 @@ BODY should be a list of lisp expressions." `(function (lambda ,@cdr))) +;; FSF 21.2 has various basic macros here. We don't because they're either +;; in cl*.el (which we dump and hence is always available) or built-in. + +;; More powerful versions in cl.el. +;(defmacro push (newelt listname) +;(defmacro pop (listname) + +;; Built-in. +;(defmacro when (cond &rest body) +;(defmacro unless (cond &rest body) + +;; More powerful versions in cl-macs.el. +;(defmacro dolist (spec &rest body) +;(defmacro dotimes (spec &rest body) + +;; In cl.el. Ours are defun, but cl arranges for them to be inlined anyway. +;(defsubst caar (x) +;(defsubst cadr (x) +;(defsubst cdar (x) +;(defsubst cddr (x) + +;; Built-in. Our `last' is more powerful in that it handles circularity. +;(defun last (x &optional n) +;(defun butlast (x &optional n) +;(defun nbutlast (x &optional n) + +;; In cl-seq.el. +;(defun remove (elt seq) +;(defun remq (elt list) + (defmacro defun-when-void (&rest args) "Define a function, just like `defun', unless it's already defined. Used for compatibility among different emacs variants." @@ -73,6 +113,52 @@ (define-function ,@args))) +(defun assoc-default (key alist &optional test default) + "Find object KEY in a pseudo-alist ALIST. +ALIST is a list of conses or objects. Each element (or the element's car, +if it is a cons) is compared with KEY by evaluating (TEST (car elt) KEY). +If that is non-nil, the element matches; +then `assoc-default' returns the element's cdr, if it is a cons, +or DEFAULT if the element is not a cons. + +If no element matches, the value is nil. +If TEST is omitted or nil, `equal' is used." + (let (found (tail alist) value) + (while (and tail (not found)) + (let ((elt (car tail))) + (when (funcall (or test 'equal) (if (consp elt) (car elt) elt) key) + (setq found t value (if (consp elt) (cdr elt) default)))) + (setq tail (cdr tail))) + value)) + +(defun assoc-ignore-case (key alist) + "Like `assoc', but ignores differences in case and text representation. +KEY must be a string. Upper-case and lower-case letters are treated as equal." + (let (element) + (while (and alist (not element)) + (if (eq t (compare-strings key 0 nil (car (car alist)) 0 nil t)) + (setq element (car alist))) + (setq alist (cdr alist))) + element)) + +(defun assoc-ignore-representation (key alist) + "Like `assoc', but ignores differences in text representation. +KEY must be a string." + (let (element) + (while (and alist (not element)) + (if (eq t (compare-strings key 0 nil (car (car alist)) 0 nil)) + (setq element (car alist))) + (setq alist (cdr alist))) + element)) + +(defun member-ignore-case (elt list) + "Like `member', but ignores differences in case and text representation. +ELT must be a string. Upper-case and lower-case letters are treated as equal." + (while (and list (not (eq t (compare-strings elt 0 nil (car list) 0 nil t)))) + (setq list (cdr list))) + list) + + ;;;; Keymap support. ;; XEmacs: removed to keymap.el @@ -85,8 +171,22 @@ ;; XEmacs: This stuff is done in C Code. -;;;; Obsolescent names for functions. -;; XEmacs: not used. +;;;; Obsolescent names for functions generally appear elsewhere, in +;;;; obsolete.el or in the files they are related do. Many very old +;;;; obsolete stuff has been removed entirely (e.g. anything with `dot' in +;;;; place of `point'). + +; alternate names (not obsolete) +(if (not (fboundp 'mod)) (define-function 'mod '%)) +(define-function 'move-marker 'set-marker) +(define-function 'beep 'ding) ; preserve lingual purity +(define-function 'indent-to-column 'indent-to) +(define-function 'backward-delete-char 'delete-backward-char) +(define-function 'search-forward-regexp (symbol-function 're-search-forward)) +(define-function 'search-backward-regexp (symbol-function 're-search-backward)) +(define-function 'remove-directory 'delete-directory) +(define-function 'set-match-data 'store-match-data) +(define-function 'send-string-to-terminal 'external-debugging-output) ;; XEmacs: (defun local-variable-if-set-p (sym buffer) @@ -103,6 +203,11 @@ (defun make-local-hook (hook) "Make the hook HOOK local to the current buffer. +The return value is HOOK. + +You never need to call this function now that `add-hook' does it for you +if its LOCAL argument is non-nil. + When a hook is local, its local and global values work in concert: running the hook actually runs all the hook functions listed in *either* the local value *or* the global value @@ -118,14 +223,13 @@ This function does nothing if HOOK is already local in the current buffer. -Do not use `make-local-variable' to make a hook variable buffer-local. - -See also `add-local-hook' and `remove-local-hook'." +Do not use `make-local-variable' to make a hook variable buffer-local." (if (local-variable-p hook (current-buffer)) ; XEmacs nil (or (boundp hook) (set hook nil)) (make-local-variable hook) - (set hook (list t)))) + (set hook (list t))) + hook) (defun add-hook (hook function &optional append local) "Add to the value of HOOK the function FUNCTION. @@ -136,7 +240,7 @@ The optional fourth argument, LOCAL, if non-nil, says to modify the hook's buffer-local value rather than its default value. -This makes no difference if the hook is not buffer-local. +This makes the hook buffer-local if needed. To make a hook variable buffer-local, always use `make-local-hook', not `make-local-variable'. @@ -146,35 +250,27 @@ You can remove this hook yourself using `remove-hook'. -See also `add-local-hook' and `add-one-shot-hook'." +See also `add-one-shot-hook'." (or (boundp hook) (set hook nil)) (or (default-boundp hook) (set-default hook nil)) - ;; If the hook value is a single function, turn it into a list. - (let ((old (symbol-value hook))) - (if (or (not (listp old)) (eq (car old) 'lambda)) - (set hook (list old)))) - (if (or local - ;; Detect the case where make-local-variable was used on a hook - ;; and do what we used to do. - (and (local-variable-if-set-p hook (current-buffer)) ; XEmacs - (not (memq t (symbol-value hook))))) - ;; Alter the local value only. - (or (if (consp function) - (member function (symbol-value hook)) - (memq function (symbol-value hook))) - (set hook - (if append - (append (symbol-value hook) (list function)) - (cons function (symbol-value hook))))) - ;; Alter the global value (which is also the only value, - ;; if the hook doesn't have a local value). - (or (if (consp function) - (member function (default-value hook)) - (memq function (default-value hook))) - (set-default hook - (if append - (append (default-value hook) (list function)) - (cons function (default-value hook))))))) + (if local (unless (local-variable-if-set-p hook (current-buffer)) ; XEmacs + (make-local-hook hook)) + ;; Detect the case where make-local-variable was used on a hook + ;; and do what we used to do. + (unless (and (consp (symbol-value hook)) (memq t (symbol-value hook))) + (setq local t))) + (let ((hook-value (if local (symbol-value hook) (default-value hook)))) + ;; If the hook value is a single function, turn it into a list. + (when (or (not (listp hook-value)) (eq (car hook-value) 'lambda)) + (setq hook-value (list hook-value))) + ;; Do the actual addition if necessary + (unless (member function hook-value) + (setq hook-value + (if append + (append hook-value (list function)) + (cons function hook-value)))) + ;; Set the actual variable + (if local (set hook hook-value) (set-default hook hook-value)))) (defun remove-hook (hook function &optional local) "Remove from the value of HOOK the function FUNCTION. @@ -184,73 +280,54 @@ The optional third argument, LOCAL, if non-nil, says to modify the hook's buffer-local value rather than its default value. -This makes no difference if the hook is not buffer-local. +This makes the hook buffer-local if needed. To make a hook variable buffer-local, always use `make-local-hook', not `make-local-variable'." - (if (or (not (boundp hook)) ;unbound symbol, or - (not (default-boundp 'hook)) - (null (symbol-value hook)) ;value is nil, or - (null function)) ;function is nil, then - nil ;Do nothing. - (flet ((hook-remove - (function hook-value) - (flet ((hook-test - (fn hel) - (or (equal fn hel) - (and (symbolp hel) - (equal fn - (get hel 'one-shot-hook-fun)))))) - (if (and (consp hook-value) - (not (functionp hook-value))) - (if (member* function hook-value :test 'hook-test) - (setq hook-value - (delete* function (copy-sequence hook-value) - :test 'hook-test))) - (if (equal hook-value function) - (setq hook-value nil))) - hook-value))) - (if (or local - ;; Detect the case where make-local-variable was used on a hook - ;; and do what we used to do. - (and (local-variable-p hook (current-buffer)) - (not (memq t (symbol-value hook))))) - (set hook (hook-remove function (symbol-value hook))) - (set-default hook (hook-remove function (default-value hook))))))) + (or (boundp hook) (set hook nil)) + (or (default-boundp hook) (set-default hook nil)) + (if local (unless (local-variable-if-set-p hook (current-buffer)) ; XEmacs + (make-local-hook hook)) + ;; Detect the case where make-local-variable was used on a hook + ;; and do what we used to do. + (unless (and (consp (symbol-value hook)) (memq t (symbol-value hook))) + (setq local t))) + (let ((hook-value (if local (symbol-value hook) (default-value hook)))) + ;; Remove the function, for both the list and the non-list cases. + ;; XEmacs: add hook-test, for handling one-shot hooks. + (flet ((hook-test + (fn hel) + (or (equal fn hel) + (and (symbolp hel) + (equal fn + (get hel 'one-shot-hook-fun)))))) + (if (or (not (listp hook-value)) (eq (car hook-value) 'lambda)) + (if (equal hook-value function) (setq hook-value nil)) + (setq hook-value (delete* function (copy-sequence hook-value) + :test 'hook-test))) + ;; If the function is on the global hook, we need to shadow it locally + ;;(when (and local (member* function (default-value hook) + ;; :test 'hook-test) + ;; (not (member* (cons 'not function) hook-value + ;; :test 'hook-test))) + ;; (push (cons 'not function) hook-value)) + ;; Set the actual variable + (if local (set hook hook-value) (set-default hook hook-value))))) ;; XEmacs addition ;; #### we need a coherent scheme for indicating compatibility info, ;; so that it can be programmatically retrieved. (defun add-local-hook (hook function &optional append) "Add to the local value of HOOK the function FUNCTION. -This modifies only the buffer-local value for the hook (which is -automatically make buffer-local, if necessary), not its default value. -FUNCTION is not added if already present. -FUNCTION is added (if necessary) at the beginning of the hook list -unless the optional argument APPEND is non-nil, in which case -FUNCTION is added at the end. - -HOOK should be a symbol, and FUNCTION may be any valid function. If -HOOK is void, it is first set to nil. If HOOK's value is a single -function, it is changed to a list of functions. - -You can remove this hook yourself using `remove-local-hook'. - -See also `add-hook' and `make-local-hook'." - (make-local-hook hook) +You don't need this any more. It's equivalent to specifying the LOCAL +argument to `add-hook'." (add-hook hook function append t)) ;; XEmacs addition (defun remove-local-hook (hook function) "Remove from the local value of HOOK the function FUNCTION. -This modifies only the buffer-local value for the hook, not its default -value. (Nothing happens if the hook is not buffer-local.) -HOOK should be a symbol, and FUNCTION may be any valid function. If -FUNCTION isn't the value of HOOK, or, if FUNCTION doesn't appear in the -list of hooks to run in HOOK, then nothing is done. See `add-hook'. - -See also `add-local-hook' and `make-local-hook'." - (if (local-variable-p hook (current-buffer)) - (remove-hook hook function t))) +You don't need this any more. It's equivalent to specifying the LOCAL +argument to `remove-hook'." + (remove-hook hook function t)) (defun add-one-shot-hook (hook function &optional append local) "Add to the value of HOOK the one-shot function FUNCTION. @@ -267,7 +344,7 @@ You can remove this hook yourself using `remove-hook'. -See also `add-hook', `add-local-hook', and `add-local-one-shot-hook'." +See also `add-hook'." (let ((sym (gensym))) (fset sym `(lambda (&rest args) (unwind-protect @@ -278,27 +355,8 @@ (defun add-local-one-shot-hook (hook function &optional append) "Add to the local value of HOOK the one-shot function FUNCTION. -FUNCTION will automatically be removed from the hook the first time -after it runs (whether to completion or to an error). -FUNCTION is not added if already present. -FUNCTION is added (if necessary) at the beginning of the hook list -unless the optional argument APPEND is non-nil, in which case -FUNCTION is added at the end. - -The optional fourth argument, LOCAL, if non-nil, says to modify -the hook's buffer-local value rather than its default value. -This makes no difference if the hook is not buffer-local. -To make a hook variable buffer-local, always use -`make-local-hook', not `make-local-variable'. - -HOOK should be a symbol, and FUNCTION may be any valid function. If -HOOK is void, it is first set to nil. If HOOK's value is a single -function, it is changed to a list of functions. - -You can remove this hook yourself using `remove-local-hook'. - -See also `add-hook', `add-local-hook', and `add-local-one-shot-hook'." - (make-local-hook hook) +You don't need this any more. It's equivalent to specifying the LOCAL +argument to `add-one-shot-hook'." (add-one-shot-hook hook function append t)) (defun add-to-list (list-var element &optional append) @@ -320,6 +378,8 @@ (append (symbol-value list-var) (list element)) (cons element (symbol-value list-var)))))) +;; END SYNCHED WITH FSF 21.2 + ;; XEmacs additions ;; called by Fkill_buffer() (defvar kill-buffer-hook nil @@ -368,22 +428,234 @@ (with-current-buffer buffer (set sym val))) -;;;; String functions. + +;; BEGIN SYNCHED WITH FSF 21.2 + +;; #### #### #### AAaargh! Must be in C, because it is used insanely +;; early in the bootstrap process. +;(defun split-path (path) +; "Explode a search path into a list of strings. +;The path components are separated with the characters specified +;with `path-separator'." +; (while (or (not stringp path-separator) +; (/= (length path-separator) 1)) +; (setq path-separator (signal 'error (list "\ +;`path-separator' should be set to a single-character string" +; path-separator)))) +; (split-string-by-char path (aref separator 0))) + +(defmacro with-current-buffer (buffer &rest body) + "Temporarily make BUFFER the current buffer and execute the forms in BODY. +The value returned is the value of the last form in BODY. +See also `with-temp-buffer'." + `(save-current-buffer + (set-buffer ,buffer) + ,@body)) + +(defmacro with-temp-file (filename &rest forms) + "Create a new buffer, evaluate FORMS there, and write the buffer to FILENAME. +The value of the last form in FORMS is returned, like `progn'. +See also `with-temp-buffer'." + (let ((temp-file (make-symbol "temp-file")) + (temp-buffer (make-symbol "temp-buffer"))) + `(let ((,temp-file ,filename) + (,temp-buffer + (get-buffer-create (generate-new-buffer-name " *temp file*")))) + (unwind-protect + (prog1 + (with-current-buffer ,temp-buffer + ,@forms) + (with-current-buffer ,temp-buffer + (widen) + (write-region (point-min) (point-max) ,temp-file nil 0))) + (and (buffer-name ,temp-buffer) + (kill-buffer ,temp-buffer)))))) + +;; FSF compatibility +(defmacro with-temp-message (message &rest body) + "Display MESSAGE temporarily while BODY is evaluated. +The original message is restored to the echo area after BODY has finished. +The value returned is the value of the last form in BODY. +If MESSAGE is nil, the echo area and message log buffer are unchanged. +Use a MESSAGE of \"\" to temporarily clear the echo area. -;; XEmacs -(defun string-equal-ignore-case (str1 str2) - "Return t if two strings have identical contents, ignoring case differences. -Case is not significant. Text properties and extents are ignored. -Symbols are also allowed; their print names are used instead. +Note that this function exists for FSF compatibility purposes. A better way +under XEmacs is to give the message a particular label (see `display-message'); +then, the old message is automatically restored when you clear your message +with `clear-message'." +;; FSF additional doc string from 21.2: +;; MESSAGE is written to the message log buffer if `message-log-max' is non-nil. + (let ((current-message (make-symbol "current-message")) + (temp-message (make-symbol "with-temp-message"))) + `(let ((,temp-message ,message) + (,current-message)) + (unwind-protect + (progn + (when ,temp-message + (setq ,current-message (current-message)) + (message "%s" ,temp-message)) + ,@body) + (and ,temp-message ,current-message + (message "%s" ,current-message)))))) + +(defmacro with-temp-buffer (&rest forms) + "Create a temporary buffer, and evaluate FORMS there like `progn'. +See also `with-temp-file' and `with-output-to-string'." + (let ((temp-buffer (make-symbol "temp-buffer"))) + `(let ((,temp-buffer + (get-buffer-create (generate-new-buffer-name " *temp*")))) + (unwind-protect + (with-current-buffer ,temp-buffer + ,@forms) + (and (buffer-name ,temp-buffer) + (kill-buffer ,temp-buffer)))))) + +(defmacro with-output-to-string (&rest body) + "Execute BODY, return the text it sent to `standard-output', as a string." + `(let ((standard-output + (get-buffer-create (generate-new-buffer-name " *string-output*")))) + (let ((standard-output standard-output)) + ,@body) + (with-current-buffer standard-output + (prog1 + (buffer-string) + (kill-buffer nil))))) + +;; FSF 21.2. + +; (defmacro combine-after-change-calls (&rest body) +; "Execute BODY, but don't call the after-change functions till the end. +; If BODY makes changes in the buffer, they are recorded +; and the functions on `after-change-functions' are called several times +; when BODY is finished. +; The return value is the value of the last form in BODY. + +; If `before-change-functions' is non-nil, then calls to the after-change +; functions can't be deferred, so in that case this macro has no effect. + +; Do not alter `after-change-functions' or `before-change-functions' +; in BODY." +; `(unwind-protect +; (let ((combine-after-change-calls t)) +; . ,body) +; (combine-after-change-execute))) -See also `equalp'." - (if (symbolp str1) - (setq str1 (symbol-name str1))) - (if (symbolp str2) - (setq str2 (symbol-name str2))) - (eq t (compare-strings str1 nil nil str2 nil nil t))) +(defmacro with-syntax-table (table &rest body) + "Evaluate BODY with syntax table of current buffer set to a copy of TABLE. +The syntax table of the current buffer is saved, BODY is evaluated, and the +saved table is restored, even in case of an abnormal exit. +Value is what BODY returns." + (let ((old-table (make-symbol "table")) + (old-buffer (make-symbol "buffer"))) + `(let ((,old-table (syntax-table)) + (,old-buffer (current-buffer))) + (unwind-protect + (progn + (set-syntax-table (copy-syntax-table ,table)) + ,@body) + (save-current-buffer + (set-buffer ,old-buffer) + (set-syntax-table ,old-table)))))) + +(put 'with-syntax-table 'lisp-indent-function 1) +(put 'with-syntax-table 'edebug-form-spec '(form body)) + + +;; Moved from mule-coding.el. +(defmacro with-string-as-buffer-contents (str &rest body) + "With the contents of the current buffer being STR, run BODY. +Returns the new contents of the buffer, as modified by BODY. +The original current buffer is restored afterwards." + `(with-temp-buffer + (insert ,str) + ,@body + (buffer-string))) + + +(defmacro save-match-data (&rest body) + "Execute BODY forms, restoring the global value of the match data." + (let ((original (make-symbol "match-data"))) + (list 'let (list (list original '(match-data))) + (list 'unwind-protect + (cons 'progn body) + (list 'store-match-data original))))) + + +(defun match-string (num &optional string) + "Return string of text matched by last search. +NUM specifies which parenthesized expression in the last regexp. + Value is nil if NUMth pair didn't match, or there were less than NUM pairs. +Zero means the entire text matched by the whole regexp or whole string. +STRING should be given if the last search was by `string-match' on STRING." + (if (match-beginning num) + (if string + (substring string (match-beginning num) (match-end num)) + (buffer-substring (match-beginning num) (match-end num))))) -;; XEmacs +(defun match-string-no-properties (num &optional string) + "Return string of text matched by last search, without text properties. +NUM specifies which parenthesized expression in the last regexp. + Value is nil if NUMth pair didn't match, or there were less than NUM pairs. +Zero means the entire text matched by the whole regexp or whole string. +STRING should be given if the last search was by `string-match' on STRING." + (if (match-beginning num) + (if string + (let ((result + (substring string (match-beginning num) (match-end num)))) + (set-text-properties 0 (length result) nil result) + result) + (buffer-substring-no-properties (match-beginning num) + (match-end num))))) + +(defun split-string (string &optional separators) + "Splits STRING into substrings where there are matches for SEPARATORS. +Each match for SEPARATORS is a splitting point. +The substrings between the splitting points are made into a list +which is returned. +If SEPARATORS is absent, it defaults to \"[ \\f\\t\\n\\r\\v]+\". + +If there is match for SEPARATORS at the beginning of STRING, we do not +include a null substring for that. Likewise, if there is a match +at the end of STRING, we don't include a null substring for that. + +Modifies the match data; use `save-match-data' if necessary." + (let ((rexp (or separators "[ \f\t\n\r\v]+")) + (start 0) + notfirst + (list nil)) + (while (and (string-match rexp string + (if (and notfirst + (= start (match-beginning 0)) + (< start (length string))) + (1+ start) start)) + (< (match-beginning 0) (length string))) + (setq notfirst t) + (or (eq (match-beginning 0) 0) + (and (eq (match-beginning 0) (match-end 0)) + (eq (match-beginning 0) start)) + (setq list + (cons (substring string start (match-beginning 0)) + list))) + (setq start (match-end 0))) + (or (eq start (length string)) + (setq list + (cons (substring string start) + list))) + (nreverse list))) + +(defun subst-char-in-string (fromchar tochar string &optional inplace) + "Replace FROMCHAR with TOCHAR in STRING each time it occurs. +Unless optional argument INPLACE is non-nil, return a new string." + (let ((i (length string)) + (newstr (if inplace string (copy-sequence string)))) + (while (> i 0) + (setq i (1- i)) + (if (eq (aref newstr i) fromchar) + (aset newstr i tochar))) + newstr)) + + +;; XEmacs addition: (defun replace-in-string (str regexp newtext &optional literal) "Replace all matches in STR for REGEXP with NEWTEXT string, and returns the new string. @@ -416,112 +688,80 @@ str newstr)) str))) -(defun split-string (string &optional pattern) - "Return a list of substrings of STRING which are separated by PATTERN. -If PATTERN is omitted, it defaults to \"[ \\f\\t\\n\\r\\v]+\"." - (or pattern - (setq pattern "[ \f\t\n\r\v]+")) - (let (parts (start 0) (len (length string))) - (if (string-match pattern string) - (setq parts (cons (substring string 0 (match-beginning 0)) parts) - start (match-end 0))) - (while (and (< start len) - (string-match pattern string (if (> start (match-beginning 0)) - start - (1+ start)))) - (setq parts (cons (substring string start (match-beginning 0)) parts) - start (match-end 0))) - (nreverse (cons (substring string start) parts)))) +(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. -;; #### #### #### AAaargh! Must be in C, because it is used insanely -;; early in the bootstrap process. -;(defun split-path (path) -; "Explode a search path into a list of strings. -;The path components are separated with the characters specified -;with `path-separator'." -; (while (or (not stringp path-separator) -; (/= (length path-separator) 1)) -; (setq path-separator (signal 'error (list "\ -;`path-separator' should be set to a single-character string" -; path-separator)))) -; (split-string-by-char path (aref separator 0))) +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. -(defmacro with-output-to-string (&rest body) - "Execute BODY, return the text it sent to `standard-output', as a string." - `(let ((standard-output - (get-buffer-create (generate-new-buffer-name " *string-output*")))) - (let ((standard-output standard-output)) - ,@body) - (with-current-buffer standard-output - (prog1 - (buffer-string) - (kill-buffer nil))))) - -(defmacro with-current-buffer (buffer &rest body) - "Temporarily make BUFFER the current buffer and execute the forms in BODY. -The value returned is the value of the last form in BODY. -See also `with-temp-buffer'." - `(save-current-buffer - (set-buffer ,buffer) - ,@body)) +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\" +" -(defmacro with-temp-file (filename &rest forms) - "Create a new buffer, evaluate FORMS there, and write the buffer to FILENAME. -The value of the last form in FORMS is returned, like `progn'. -See also `with-temp-buffer'." - (let ((temp-file (make-symbol "temp-file")) - (temp-buffer (make-symbol "temp-buffer"))) - `(let ((,temp-file ,filename) - (,temp-buffer - (get-buffer-create (generate-new-buffer-name " *temp file*")))) - (unwind-protect - (prog1 - (with-current-buffer ,temp-buffer - ,@forms) - (with-current-buffer ,temp-buffer - (widen) - (write-region (point-min) (point-max) ,temp-file nil 0))) - (and (buffer-name ,temp-buffer) - (kill-buffer ,temp-buffer)))))) + ;; To avoid excessive consing from multiple matches in long strings, + ;; don't just call `replace-match' continually. Walk down the + ;; string looking for matches of REGEXP and building up a (reversed) + ;; list MATCHES. This comprises segments of STRING which weren't + ;; matched interspersed with replacements for segments that were. + ;; [For a `large' number of replacments it's more efficient to + ;; operate in a temporary buffer; we can't tell from the function's + ;; args whether to choose the buffer-based implementation, though it + ;; might be reasonable to do so for long enough STRING.] + (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))))) -(defmacro with-temp-message (message &rest body) - "Display MESSAGE temporarily while BODY is evaluated. -The original message is restored to the echo area after BODY has finished. -The value returned is the value of the last form in BODY." - (let ((current-message (make-symbol "current-message")) - (temp-message (make-symbol "with-temp-message"))) - `(let ((,temp-message ,message) - (,current-message)) - (unwind-protect - (progn - (when ,temp-message - (setq ,current-message (current-message)) - (message "%s" ,temp-message)) - ,@body) - (and ,temp-message ,current-message - (message "%s" ,current-message)))))) +;; END SYNCHED WITH FSF 21.2 + + +;;; Basic string functions -(defmacro with-temp-buffer (&rest forms) - "Create a temporary buffer, and evaluate FORMS there like `progn'. -See also `with-temp-file' and `with-output-to-string'." - (let ((temp-buffer (make-symbol "temp-buffer"))) - `(let ((,temp-buffer - (get-buffer-create (generate-new-buffer-name " *temp*")))) - (unwind-protect - (with-current-buffer ,temp-buffer - ,@forms) - (and (buffer-name ,temp-buffer) - (kill-buffer ,temp-buffer)))))) +;; XEmacs +(defun string-equal-ignore-case (str1 str2) + "Return t if two strings have identical contents, ignoring case differences. +Case is not significant. Text properties and extents are ignored. +Symbols are also allowed; their print names are used instead. -;; Moved from mule-coding.el. -(defmacro with-string-as-buffer-contents (str &rest body) - "With the contents of the current buffer being STR, run BODY. -Returns the new contents of the buffer, as modified by BODY. -The original current buffer is restored afterwards." - `(with-temp-buffer - (insert ,str) - ,@body - (buffer-string))) +See also `equalp'." + (if (symbolp str1) + (setq str1 (symbol-name str1))) + (if (symbolp str2) + (setq str2 (symbol-name str2))) + (eq t (compare-strings str1 nil nil str2 nil nil t))) (defun insert-face (string face) "Insert STRING and highlight with FACE. Return the extent created." @@ -606,7 +846,7 @@ ;; From FSF 21.1; ELLIPSES is XEmacs addition. (defun truncate-string-to-width (str end-column &optional start-column padding - ellipses) + ellipses) "Truncate string STR to end at column END-COLUMN. The optional 3rd arg START-COLUMN, if non-nil, specifies the starting column; that means to return the characters occupying @@ -1224,6 +1464,8 @@ ;; Probably the old way. (buffer-substring buffer old-end old-buffer)))) +;; BEGIN SYNC WITH FSF 21.2 + ;; This was not present before. I think Jamie had some objections ;; to this, so I'm leaving this undefined for now. --ben @@ -1244,7 +1486,13 @@ This makes or adds to an entry on `after-load-alist'. If FILE is already loaded, evaluate FORM right now. It does nothing if FORM is already on the list for FILE. -FILE should be the name of a library, with no directory name." +FILE must match exactly. Normally FILE is the name of a library, +with no directory or extension specified, since that is how `load' +is normally called." + ;; Make sure `load-history' contains the files dumped with Emacs + ;; for the case that FILE is one of the files dumped with Emacs. + (if-fboundp 'load-symbol-file-load-history + (load-symbol-file-load-history)) ;; Make sure there is an element for FILE. (or (assoc file after-load-alist) (setq after-load-alist (cons (list file) after-load-alist))) @@ -1266,16 +1514,6 @@ (eval-after-load file (read))) (make-compatible 'eval-next-after-load "") -; alternate names (not obsolete) -(if (not (fboundp 'mod)) (define-function 'mod '%)) -(define-function 'move-marker 'set-marker) -(define-function 'beep 'ding) ; preserve lingual purity -(define-function 'indent-to-column 'indent-to) -(define-function 'backward-delete-char 'delete-backward-char) -(define-function 'search-forward-regexp (symbol-function 're-search-forward)) -(define-function 'search-backward-regexp (symbol-function 're-search-backward)) -(define-function 'remove-directory 'delete-directory) -(define-function 'set-match-data 'store-match-data) -(define-function 'send-string-to-terminal 'external-debugging-output) +;; END SYNC WITH FSF 21.2 ;;; subr.el ends here
--- a/lisp/view-less.el Sun Mar 02 02:18:12 2003 +0000 +++ b/lisp/view-less.el Sun Mar 02 09:38:54 2003 +0000 @@ -48,6 +48,7 @@ (defvar view-default-lines 10 "Default value for the \"d\" and \"u\" commands in view-mode") +;;;###autoload (defvar view-minor-mode nil "Non-nil when view-mode is active. Call `view-mode' to toggle.") (make-variable-buffer-local 'view-minor-mode)
--- a/lisp/wid-edit.el Sun Mar 02 02:18:12 2003 +0000 +++ b/lisp/wid-edit.el Sun Mar 02 09:38:54 2003 +0000 @@ -942,6 +942,7 @@ "Make a deep copy of WIDGET." (widget-apply (copy-sequence widget) :copy)) +;;;###autoload (defun widget-convert (type &rest args) "Convert TYPE to a widget without inserting it in the buffer. The optional ARGS are additional keyword arguments." @@ -2079,7 +2080,7 @@ (defun widget-url-link-action (widget &optional event) "Open the url specified by WIDGET." - (if (fboundp 'browse-url) + (if-fboundp 'browse-url (browse-url (widget-value widget)) ;; #### Should subclass a 'missing-package error. (error 'unimplemented
--- a/man/ChangeLog Sun Mar 02 02:18:12 2003 +0000 +++ b/man/ChangeLog Sun Mar 02 09:38:54 2003 +0000 @@ -1,3 +1,9 @@ +2003-02-26 Stephen J. Turnbull <stephen@xemacs.org> + + * internals/internals.texi (XEmacs From the Perspective of Building): + Fix typo. + (Build-Time Dependencies): New node. + 2003-02-16 Steve Youngs <youngs@xemacs.org> * XEmacs 21.5.11 "cabbage" is released.
--- a/man/internals/internals.texi Sun Mar 02 02:18:12 2003 +0000 +++ b/man/internals/internals.texi Sun Mar 02 09:38:54 2003 +0000 @@ -113,6 +113,7 @@ * XEmacs From the Outside:: A broad conceptual overview. * The Lisp Language:: An overview. * XEmacs From the Perspective of Building:: +* Build-Time Dependencies:: * XEmacs From the Inside:: * The XEmacs Object System (Abstractly Speaking):: * How Lisp Objects Are Represented in C:: @@ -1131,7 +1132,7 @@ that makes it a full-fledged application platform, very much like an OS inside the real OS. -@node XEmacs From the Perspective of Building, XEmacs From the Inside, The Lisp Language, Top +@node XEmacs From the Perspective of Building, Build-Time Dependencies, The Lisp Language, Top @chapter XEmacs From the Perspective of Building @cindex XEmacs from the perspective of building @cindex building, XEmacs from the perspective of @@ -1240,9 +1241,73 @@ This is useful when the dumping procedure described above is broken, or when using certain program debugging tools such as Purify. These tools get mighty confused by the tricks played by the XEmacs build process, -such as allocation memory in one process, and freeing it in the next. - -@node XEmacs From the Inside, The XEmacs Object System (Abstractly Speaking), XEmacs From the Perspective of Building, Top +such as allocating memory in one process, and freeing it in the next. + +@node Build-Time Dependencies, XEmacs From the Inside, XEmacs From the Perspective of Building, Top +@chapter Build-Time Dependencies +@cindex build-time dependencies +@cindex dependencies, build-time + +This is a collection of random notes on build-time dependencies as of +about XEmacs 21.5.11. Of course we use @file{make} to manage most +dependencies, especially for the C code. The main thing here is for the +Release Engineer to run the @file{src/make-src-depend} script every so +often, at least at every release. + +However, since most of XEmacs is written in Lisp, and we compile and +preload the Lisp for efficiency, managing Lisp compilation using +@file{make} would imply running XEmacs hundreds of times. This would +make the build process unbearably long. Thus those processes that +require running the same Lisp programs on many files are managed using +Lisp driver functions rather than @file{make}. The situation is further +complicated by the fact that documentation strings are kept in an +external database, and referenced in the dumped XEmacs by file offset. +Finally, the Lisp files are processed to collect autoloaded function +information and customize dependencies, which are then written into +generated Lisp files. + +About this, Ben sez: + +@quotation +@enumerate 1 +@item +Redumping depends on up-to-date dumped @file{.elc} files and @file{DOC} +but not directly on auto-autoloads. + +@item +Rebuilding dumped @file{.elc} files depends on auto-autoloads being +up-to-date. + +@item +Building the @file{DOC} file depends on up-to-date dumped @file{.elc} +files but not directly on auto-autoloads. + +@item +Recompiling anything depends on @file{bytecomp.elc} and +@file{byte-optimize.elc} being up-to-date. +@end enumerate + +Put these together and you'll see it's perfectly acceptable to build +auto-autoloads *after* dumping if no @file{.elc} files are out-of-date. +@end quotation + +These Lisp driver programs typically run from temacs, not a dumped +XEmacs. The simplest (but time-consuming) way to achieve a sane +environment for running Lisp is to load @file{loadup.el} or +@file{loadup-el.el}. (The latter is used to avoid loading possibly +out-of-date compiled Lisp files.) If this is not done, you have to +construct the environment yourself. See @file{dumped-lisp.el} to see +how it is done in the dumped XEmacs. + +One potential gotcha is that very early customizations are now handled +by adding the definitions to the special variable +@code{custom-declare-variable-list}, defined in @file{subr.el}. If you +use any higher-level functionality that might load @file{custom.el}, but +you do not need @file{subr.el}, you should @samp{defvar} +@code{custom-declare-variable-list} to prevent the @samp{void-variable} +error. (Currently this is only needed for @file{make-docfile.el}.) + +@node XEmacs From the Inside, The XEmacs Object System (Abstractly Speaking), Build-Time Dependencies, Top @chapter XEmacs From the Inside @cindex XEmacs from the inside @cindex inside, XEmacs from the
--- a/nt/ChangeLog Sun Mar 02 02:18:12 2003 +0000 +++ b/nt/ChangeLog Sun Mar 02 09:38:54 2003 +0000 @@ -1,3 +1,25 @@ +2003-03-01 Ben Wing <ben@xemacs.org> + + * PROBLEMS: Delete. + + * config.inc.samp (USE_FASTCALL): + * config.inc.samp (HAVE_VC6): Removed. + * config.inc.samp (DEBUG_XEMACS): + * config.inc.samp (SUPPORT_EDIT_AND_CONTINUE): New. + * xemacs.mak (DEBUG_XEMACS): + * xemacs.mak (HAVE_VC6): Removed. + * xemacs.mak (SUPPORT_EDIT_AND_CONTINUE): New. + * xemacs.mak (CCV): + * xemacs.mak (LIB_SRC_CFLAGS): New. + * xemacs.mak (ETAGS_DEPS): + * xemacs.mak (OS): + * xemacs.mak (TEMACS_LFLAGS): + Eliminate HAVE_VC6, use SUPPORT_EDIT_AND_CONTINUE in its place. + No incremental linking unless SUPPORT_EDIT_AND_CONTINUE, since it + can cause nasty crashes in pdump. Put warnings about this in + config.inc.samp. Report the full compile flags used for src + and lib-src in the Installation output. + 2003-02-28 Ben Wing <ben@xemacs.org> * README:
--- a/nt/PROBLEMS Sun Mar 02 02:18:12 2003 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,177 +0,0 @@ - -*- mode:outline -*- - -This file describes various problems that have been encountered in -running XEmacs on Windows 95, 98 and NT. It has been updated for -XEmacs 21.0. - -This is the first release of XEmacs on Windows. In testing it has -proved to be extremely stable in general use (but see the gnus and -subprocess problems below), but not all features or packages work -correctly yet. - -Use `C-c C-f' to move to the next equal level of outline, and -`C-c C-b' to move to previous equal level. `C-h m' will give more -info about the Outline mode. - -Also, Try finding the things you need using one of the search commands -XEmacs provides (e.g. `C-s'). - -General advice: - Remember your .emacs file! ~\.emacs is your Emacs init file. If - you observe strange problems, invoke XEmacs with the `-q' option - and see if you can repeat the problem. - - -* Problems with running XEmacs -============================== -** Conflicts with FSF NTEmacs - -Depending on how it is installed, FSF NTEmacs may setup various EMACS* -variables in your environment. The presence of these variables may -cause XEmacs to fail at startup, cause you to see corrupted -doc-strings, or cause other random problems. - -You should remove these variables from your environment. These -variables are not required to run FSF NTEmacs if you start it by -running emacs.bat. - -** XEmacs can't find my .emacs file - -XEmacs looks for your .emacs in your "home" directory. XEmacs decides -that your "home" directory is, in order of preference: - -- The value of the HOME environment variable, if the variable exists. -- The value of the HOMEDRIVE and HOMEPATH environment variables, if - these variables both exist. -- The directory that XEmacs was started from. - -** XEmacs can't find any packages - -XEmacs looks for your packages in subdirectories of a directory which -is set at compile-time, and defaults to C:\Program Files\XEmacs. The -variable configure-package-path holds the actual path that was -compiled into your copy of XEmacs. - -The compile-time default location can be overridden by the -EMACSPACKAGEPATH environment variable or by the -SOFTWARE\GNU\XEmacs\EMACSPACKAGEPATH registry entry. You should check -that these variables, if they exist, point to the actual location of -your package tree. - -** XEmacs sometimes crashes when using gnus - -This is a known bug in this release of XEmacs on Windows. - -If you want to use gnus anyway, you should minimize any possible data -loss by saving any modified buffers before you start and ensuring that -you haven't set gnus-use-dribble-file to nil or disabled the normal -XEmacs auto-save mechanism. - -** XEmacs doesn't die when shutting down Windows 95 or 98 - -When shutting down Windows 95 or 98 you may see a dialog that says - "xemacs / You must quit this program before you quit Windows". -It is safe to - "Click OK to quit the program and Windows", -but you won't be offered a chance to save any modified XEmacs buffers. - -* Look and feel -=============== -** Key bindings - -The C-z, C-x, C-c, and C-v keystrokes have traditional uses in both -emacs and Windows programs. XEmacs binds these keys to their -traditional emacs uses, and provides Windows 3.x style bindings for -the Cut, Copy and Paste functions. - - Function XEmacs binding - -------- -------------- - Undo C-_ - Cut Sh-Del - Copy C-Insert - Paste Sh-Insert - -You can rebind keys to make XEmacs more Windows-compatible; for -example, to bind C-z to undo: - - (global-set-key [(control z)] 'undo) - -Rebindind C-x and C-c is trickier because by default these are prefix -keys in XEmacs. See the "Key Bindings" node in the XEmacs manual. - -** Behavior of selected regions - -Selected regions behave differently in XEmacs from typical Windows -programs. The pc-select package provides various functions to enable -the standard Windows behavior for selected regions (eg mark via -shift-arrow, self-inserting deletes region, etc). - -** Limitations on the use of the AltGr key. - -In some locale and OS combinations you can't generate M-AltGr-key or -C-M-AltGr-key sequences at all. - -To generate C-AltGr-key or C-M-AltGr-key sequences you must use the -right-hand Control key and you must press it *after* AltGr. - -These limitations arise from fundamental problems in the way that the -win32 API reports AltGr key events. There isn't anything that XEmacs -can do to work round these problems that it isn't already doing. - -You may want to create alternative bindings if any of the standard -XEmacs bindings require you to use some combination of Control or Meta -and AltGr. - - -* Features not fully supported in this release -============================================== -** Limited support for subprocesses - -Attempting to use call-process to run a 16bit program gives a -"Spawning child process: Exec format error". For example shell-command -fails under Windows 95 and 98 if you use command.com or any other -16bit program as your shell. - -XEmacs may incorrectly quote your call-process command if it contains -double quotes, backslashes or spaces. - -start-process and functions that rely on it are supported under Windows 95, -98 and NT. However, starting a 16bit program that requires keyboard input -may cause XEmacs to hang or crash under Windows 95 and 98, and will leave -the orphaned 16bit program consuming all available CPU time. - -Sending signals to subprocesses started by call-process or by -start-process fails with a "Cannot send signal to process" error under -Windows 95 and 98. As a side effect of this, quitting XEmacs while it -is still running subprocesses causes it to crash under Windows 95 and -98. - -** Changing fonts from the Options menu - -The "Font" and "Size" entries on the Options menu don't work yet. This -will be fixed in a future release. In the meantime, you can either -change face fonts with customize or manually; for example: - - (set-face-font 'default "Lucida Console:Regular:10::Western") - (set-face-font 'modeline "MS Sans Serif:Regular:10::Western") - -Font weight and style and character set must be supplied in English as -above. Common weights and styles are "Regular", "Regular Italic", -"Bold" and "Bold Italic". Common character sets are "Western", -"Central European" and "OEM/DOS". - -Windows 95 only comes with one fixed-width font that is suitable for -use by XEmacs, namely "Courier New". - -** No MULE support - -This release of XEmacs on Windows does not contain MULE support. MULE -support has not been a priority for the XEmacs on Windows developers. - -** Printing - -This release of XEmacs on Windows does not support printing natively. - -You can use the lpr-command and lpr-switches variables to specify an -external print program. -
--- a/nt/config.inc.samp Sun Mar 02 02:18:12 2003 +0000 +++ b/nt/config.inc.samp Sun Mar 02 09:38:54 2003 +0000 @@ -112,9 +112,6 @@ # #### Change to 1 when I check in the ws with support for fastcall USE_FASTCALL=0 -# True if running VC++ 6 or later. -HAVE_VC6=1 - ############################################################################ # Development options # ############################################################################ @@ -131,6 +128,12 @@ # variable, below.) DEBUG_XEMACS=1 +# Set this to enable support for edit-and-continue under VC++. +# WARNING: This turns on incremental linking, which is known to lead to +# occasional weird crashes in pdump loading. If that happens, do a +# nmake -f xemacs.mak clean so that temacs.exe and xemacs.exe get removed. +SUPPORT_EDIT_AND_CONTINUE=0 + # Uncomment this to turn off or on the error-checking code, which adds # abundant internal error checking (and slows things down a lot). Normally, # leave this alone -- it will be on for beta builds and off for release @@ -143,6 +146,10 @@ # CPLUSPLUS_COMPILE=0 # Set this to speed up building, for development purposes. +# WARNING: This may not completely rebuild all targets. In particular, +# DOC is not rebuilt, and changes to lisp.h and config.h do not trigger +# mass rebuilding. Other things may also be enabled that are not safe +# for release builds. QUICK_BUILD=0 # Set this to see exactly which compilation commands are being run (not
--- a/nt/xemacs.mak Sun Mar 02 02:18:12 2003 +0000 +++ b/nt/xemacs.mak Sun Mar 02 09:38:54 2003 +0000 @@ -161,8 +161,8 @@ !if !defined(DEBUG_XEMACS) DEBUG_XEMACS=0 !endif -!if !defined(HAVE_VC6) -HAVE_VC6=1 +!if !defined(SUPPORT_EDIT_AND_CONTINUE) +SUPPORT_EDIT_AND_CONTINUE=0 !endif !if !defined(ERROR_CHECK_ALL) @@ -520,13 +520,17 @@ !if $(DEBUG_XEMACS) # ---- Debugging support ---- -! if $(HAVE_VC6) +! if $(SUPPORT_EDIT_AND_CONTINUE) # support edit-and-continue DEBUG_FLAGS_COMPILE=-ZI +# WARNING: There is a very good reason for -incremental:no, as it can cause +# all sorts of weird crashes in or after a pdump load. We must allow +# incremental linking for edit-and-continue to work, however. +DEBUG_FLAGS_LINK=-debug:full ! else DEBUG_FLAGS_COMPILE=-Zi +DEBUG_FLAGS_LINK=-debug:full -incremental:no ! endif -DEBUG_FLAGS_LINK=-debug:full DEBUG_DEFINES=-DDEBUG_XEMACS -D_DEBUG #BROWSERFLAGS=-Fr -Fd$(OUTDIR)\temacs.pdb BROWSERFLAGS=-Fr$*.sbr -Fd$(OUTDIR)\temacs.pdb @@ -882,14 +886,16 @@ LINK_DEPENDENCY_ARGS = -Fe$@ -Fd$* $** -link $(DEBUG_FLAGS_LINK) LINK_STANDARD_LIBRARY_ARGS = setargv.obj user32.lib wsock32.lib +LIB_SRC_CFLAGS = $(CFLAGS) -I$(LIB_SRC) -I$(SRC) $(LIB_SRC_DEFINES) + # Inferred rule {$(LIB_SRC)}.c{$(BLDLIB_SRC)}.exe : - $(CCV) -I$(LIB_SRC) -I$(SRC) $(LIB_SRC_DEFINES) $(CFLAGS) $(LINK_DEPENDENCY_ARGS) $(LINK_STANDARD_LIBRARY_ARGS) + $(CCV) $(LIB_SRC_CFLAGS) $(LINK_DEPENDENCY_ARGS) $(LINK_STANDARD_LIBRARY_ARGS) # Individual dependencies ETAGS_DEPS = $(LIB_SRC)/getopt.c $(LIB_SRC)/getopt1.c $(SRC)/regex.c $(BLDLIB_SRC)/etags.exe : $(LIB_SRC)/etags.c $(ETAGS_DEPS) - $(CCV) -I$(LIB_SRC) -I$(SRC) $(LIB_SRC_DEFINES) $(CFLAGS) $(LINK_DEPENDENCY_ARGS) -stack:0x800000 $(LINK_STANDARD_LIBRARY_ARGS) + $(CCV) $(LIB_SRC_CFLAGS) $(LINK_DEPENDENCY_ARGS) -stack:0x800000 $(LINK_STANDARD_LIBRARY_ARGS) $(BLDLIB_SRC)/movemail.exe : $(LIB_SRC)/movemail.c $(LIB_SRC)/pop.c $(ETAGS_DEPS) @@ -1131,7 +1137,8 @@ Building XEmacs into compiled tree "$(BLDROOT:\=\\)". !endif !if defined(CCV) - Using compiler "$(CC) $(CFLAGS)". + For src, using compiler "$(CC) $(TEMACS_CPP_FLAGS)". + For lib-src, using compiler "$(CC) $(LIB_SRC_CFLAGS)". !endif !if $(CPLUSPLUS_COMPILE) Compiling as C++. @@ -1262,8 +1269,8 @@ oldnames.lib kernel32.lib user32.lib gdi32.lib comdlg32.lib advapi32.lib \ shell32.lib wsock32.lib netapi32.lib winmm.lib winspool.lib ole32.lib \ mpr.lib uuid.lib imm32.lib $(LIBC_LIB) -TEMACS_LFLAGS=-nologo $(LIBRARIES) $(DEBUG_FLAGS_LINK) -base:0x1000000\ - -stack:0x800000 $(TEMACS_ENTRYPOINT) -subsystem:windows\ +TEMACS_LFLAGS=-nologo $(LIBRARIES) $(DEBUG_FLAGS_LINK) \ + -base:0x1000000 -stack:0x800000 $(TEMACS_ENTRYPOINT) -subsystem:windows \ -pdb:$(BLDSRC)\temacs.pdb -map:$(BLDSRC)\temacs.map \ -heap:0x00100000 -nodefaultlib $(PROFILE_FLAGS) setargv.obj
--- a/src/ChangeLog Sun Mar 02 02:18:12 2003 +0000 +++ b/src/ChangeLog Sun Mar 02 09:38:54 2003 +0000 @@ -1,3 +1,112 @@ +2003-03-01 Ben Wing <ben@xemacs.org> + + * alloc.c: + * alloc.c (xmalloc): + * alloc.c (xcalloc): + * alloc.c (xrealloc): + * alloc.c (endif): + * lisp.h (ALLOCA): + * lisp.h (MALLOC_OR_ALLOCA): + * lisp.h (DO_REALLOC): + * ralloc.c: + * ralloc.c (REGEX_MALLOC_CHECK): + * ralloc.c (r_alloc): + * ralloc.c (r_alloc_free): + * ralloc.c (r_re_alloc): + * regex.c: + * regex.c (REGEX_ALLOCATE): + * regex.c (REGEX_REALLOCATE): + * regex.c (REGEX_ALLOCATE_STACK): + * regex.c (TALLOC): + * regex.c (INIT_FAIL_STACK): + * regex.c (PUSH_FAILURE_POINT): + * regex.c (EXTEND_BUFFER): + * regex.c (FREE_STACK_RETURN): + * regex.c (regex_compile): + * regex.c (re_compile_fastmap): + * regex.c (re_search_2): + * regex.c (FREE_VARIABLES): + * regex.c (re_match): + * regex.c (re_match_2): + * regex.c (re_match_2_internal): + * regex.c (re_comp): + * regex.c (regcomp): + * regex.c (regexec): + * regex.c (regfree): + Use ALLOCA() in regex.c to avoid excessive stack allocation. + Also fix subtle problem with REL_ALLOC() -- any call to malloc() + (direct or indirect) may relocate rel-alloced data, causing + buffer text to shift. After any such call, regex must update + all its pointers to such data. Add a system, when + ERROR_CHECK_MALLOC, whereby regex.c indicates all the places + it is prepared to handle malloc()/realloc()/free(), and any + calls anywhere in XEmacs outside of this will trigger an abort. + + * alloc.c (garbage_collect_1): + * dialog-msw.c: + * dialog-msw.c (dialog_proc): + * eval.c: + * eval.c (run_post_gc_hook): + * eval.c (flagged_a_squirmer): + * eval.c (issue_call_trapping_problems_warning): + * eval.c (call_trapping_problems): + * eval.c (run_hook_trapping_problems): + * eval.c (safe_run_hook_trapping_problems): + * eval.c (run_hook_with_args_in_buffer_trapping_problems): + * eval.c (run_hook_with_args_trapping_problems): + * eval.c (va_run_hook_with_args_trapping_problems): + * eval.c (va_run_hook_with_args_in_buffer_trapping_problems): + * eval.c (record_unwind_protect_restoring_int): + * event-stream.c (run_pre_idle_hook): + * event-stream.c (pre_command_hook): + * event-stream.c (post_command_hook): + * general-slots.h: + * insdel.c: + * insdel.c (signal_first_change): + * insdel.c (signal_before_change): + * insdel.c (signal_after_change): + * lisp.h (POSTPONE_WARNING_ISSUE): + * lisp.h: + * menubar-msw.c: + * menubar-msw.c (unsafe_handle_wm_initmenu_1): + * menubar-x.c (pre_activate_callback): + Change *run_hook*_trapping_problems to take a warning class, not + a string. Factor out code to issue warnings, add flag to + call_trapping_problems() to postpone warning issue, and make + *run_hook*_trapping_problems issue their own warnings tailored + to the hook, postponed in the case of safe_run_hook_trapping_problems() + so that the appropriate message can be issued about resetting to + nil only when not `quit'. Make record_unwind_protect_restoring_int() + non-static. + + * dumper.c: + * dumper.c (pdump_unsupported_dump_type): + * dumper.c (pdump_register_sub): + * dumper.c (pdump_store_new_pointer_offsets): + * dumper.c (pdump_reloc_one): + * dumper.c (pdump_dump_root_struct_ptrs): + Issue notes about incremental linking problems under Windows. + + * fileio.c: + * fileio.c (barf_or_query_if_file_exists): + * fileio.c (Fsysnetunam): + * fileio.c (Fencrypt_string): + * fileio.c (Fdecrypt_string): + * fileio.c (Fdo_auto_save): + Mule-ize encrypt/decrypt-string code. + + * text.h (DEC_IBYTEPTR): + * text.h (EI_ALLOC): + * text.h (eicpy_lstr): + * text.h (eicpy_raw_fmt): + * text.h (eicpy_ch): + * text.h (eicat_ch): + * text.h (eisub_ei): + * text.h (eisub_ch): + * text.h (eito_external): + * text.h (EI_CASECHANGE): + Spacing changes. + 2003-02-28 Ben Wing <ben@xemacs.org> * m/acorn.h:
--- a/src/alloc.c Sun Mar 02 02:18:12 2003 +0000 +++ b/src/alloc.c Sun Mar 02 09:38:54 2003 +0000 @@ -315,6 +315,7 @@ #ifdef ERROR_CHECK_MALLOC static int in_malloc; +extern int regex_malloc_disallowed; #endif #undef xmalloc @@ -324,6 +325,7 @@ void *val; #ifdef ERROR_CHECK_MALLOC assert (!in_malloc); + assert (!regex_malloc_disallowed); in_malloc = 1; #endif val = malloc (size); @@ -342,6 +344,7 @@ void *val; #ifdef ERROR_CHECK_MALLOC assert (!in_malloc); + assert (!regex_malloc_disallowed); in_malloc = 1; #endif val= calloc (nelem, elsize); @@ -366,6 +369,7 @@ { #ifdef ERROR_CHECK_MALLOC assert (!in_malloc); + assert (!regex_malloc_disallowed); in_malloc = 1; #endif block = realloc (block, size); @@ -392,6 +396,7 @@ assert (block != (void *) 0xDEADBEEF); assert (block); assert (!in_malloc); + assert (!regex_malloc_disallowed); in_malloc = 1; #endif /* ERROR_CHECK_MALLOC */ free (block); @@ -4448,7 +4453,7 @@ if (!gc_hooks_inhibited) run_hook_trapping_problems - ("Error in pre-gc-hook", Qpre_gc_hook, + (Qgarbage_collecting, Qpre_gc_hook, INHIBIT_EXISTING_PERMANENT_DISPLAY_OBJECT_DELETION); /* Now show the GC cursor/message. */
--- a/src/depend Sun Mar 02 02:18:12 2003 +0000 +++ b/src/depend Sun Mar 02 09:38:54 2003 +0000 @@ -152,7 +152,7 @@ font-lock.o: $(LISP_H) buffer.h bufslots.h casetab.h charset.h chartab.h insdel.h syntax.h frame.o: $(LISP_H) buffer.h bufslots.h casetab.h charset.h chartab.h conslots.h console-impl.h console.h device-impl.h device.h devslots.h events.h extents.h faces.h frame-impl.h frame.h frameslots.h glyphs.h gui.h gutter.h menubar.h redisplay.h scrollbar.h specifier.h systime.h toolbar.h window-impl.h window.h winslots.h free-hook.o: $(LISP_H) hash.h -general.o: $(LISP_H) +general.o: $(LISP_H) general-slots.h getloadavg.o: $(LISP_H) sysfile.h syssignal.h gif_io.o: $(LISP_H) gifrlib.h sysfile.h glyphs-eimage.o: $(LISP_H) buffer.h bufslots.h casetab.h charset.h chartab.h coding-system-slots.h conslots.h console-impl.h console.h device-impl.h device.h devslots.h faces.h file-coding.h frame.h gifrlib.h glyphs.h lstream.h objects-impl.h objects.h opaque.h redisplay.h scrollbar.h specifier.h sysfile.h window-impl.h window.h winslots.h
--- a/src/dialog-msw.c Sun Mar 02 02:18:12 2003 +0000 +++ b/src/dialog-msw.c Sun Mar 02 09:38:54 2003 +0000 @@ -1,6 +1,6 @@ /* Implements elisp-programmable dialog boxes -- MS Windows interface. Copyright (C) 1998 Kirill M. Katsnelson <kkm@kis.ru> - Copyright (C) 2000, 2001, 2002 Ben Wing. + Copyright (C) 2000, 2001, 2002, 2003 Ben Wing. This file is part of XEmacs. @@ -230,7 +230,7 @@ mswindows_enqueue_misc_user_event (did->frame, Qrun_hooks, Qmenu_no_selection_hook); va_run_hook_with_args_trapping_problems - (0, Qdelete_dialog_box_hook, 1, data, 0); + (Qdialog, Qdelete_dialog_box_hook, 1, data, 0); DestroyWindow (hwnd); }
--- a/src/dumper.c Sun Mar 02 02:18:12 2003 +0000 +++ b/src/dumper.c Sun Mar 02 09:38:54 2003 +0000 @@ -1,7 +1,7 @@ /* Portable data dumper for XEmacs. Copyright (C) 1999-2000 Olivier Galibert Copyright (C) 2001 Martin Buchholz - Copyright (C) 2001, 2002 Ben Wing. + Copyright (C) 2001, 2002, 2003 Ben Wing. This file is part of XEmacs. @@ -410,6 +410,20 @@ } static void +pdump_unsupported_dump_type (enum memory_description_type type, + int do_backtrace) +{ + stderr_out ("Unsupported dump type : %d\n", type); +#ifdef WIN32_NATIVE + stderr_out ("Are you compiling with SUPPORT_EDIT_AND_CONTINUE?\n"); + stderr_out ("See the PROBLEMS file.\n"); +#endif + if (do_backtrace) + pdump_backtrace (); + abort (); +} + +static void pdump_bump_depth (void) { int me = pdump_depth++; @@ -545,9 +559,7 @@ break; default: - stderr_out ("Unsupported dump type : %d\n", desc1->type); - pdump_backtrace (); - abort (); + pdump_unsupported_dump_type (desc1->type, 1); } } } @@ -807,8 +819,7 @@ break; default: - stderr_out ("Unsupported dump type : %d\n", desc1->type); - abort (); + pdump_unsupported_dump_type (desc1->type, 0); } } } @@ -942,8 +953,7 @@ break; default: - stderr_out ("Unsupported dump type : %d\n", desc1->type); - abort (); + pdump_unsupported_dump_type (desc1->type, 0); } } } @@ -997,8 +1007,10 @@ pdump_static_pointer *data = alloca_array (pdump_static_pointer, count); for (i = 0; i < count; i++) { - data[i].address = (char **) Dynarr_atp (pdump_root_struct_ptrs, i)->ptraddress; - data[i].value = (char *) pdump_get_entry (* data[i].address)->save_offset; + data[i].address = + (char **) Dynarr_atp (pdump_root_struct_ptrs, i)->ptraddress; + data[i].value = + (char *) pdump_get_entry (* data[i].address)->save_offset; } PDUMP_ALIGN_OUTPUT (pdump_static_pointer); retry_fwrite (data, sizeof (pdump_static_pointer), count, pdump_out);
--- a/src/eval.c Sun Mar 02 02:18:12 2003 +0000 +++ b/src/eval.c Sun Mar 02 09:38:54 2003 +0000 @@ -3746,9 +3746,7 @@ args[1] = Fcons (Fcons (Qfinalize_list, zap_finalize_list ()), Qnil); run_hook_with_args_trapping_problems - ("Error in post-gc-hook", - 2, args, - RUN_HOOKS_TO_COMPLETION, + (Qgarbage_collecting, 2, args, RUN_HOOKS_TO_COMPLETION, INHIBIT_QUIT | NO_INHIBIT_ERRORS); } @@ -4818,14 +4816,14 @@ { struct call_trapping_problems *p = (struct call_trapping_problems *) get_opaque_ptr (opaque); - struct gcpro gcpro1; - Lisp_Object lstream = Qnil; - Lisp_Object errstr; - int speccount = specpdl_depth (); if (!(inhibit_flags & INHIBIT_WARNING_ISSUE) && !warning_will_be_discarded (current_warning_level ())) { + struct gcpro gcpro1; + Lisp_Object lstream = Qnil; + int speccount = specpdl_depth (); + /* We're no longer protected against errors or quit here, so at least let's temporarily inhibit quit. We definitely do not want to inhibit quit during the calling of the function @@ -4841,19 +4839,6 @@ Lstream_delete (XLSTREAM (lstream)); UNGCPRO; - /* #### This should call - (with-output-to-string (display-error (cons error_conditions data)) - but that stuff is all in Lisp currently. */ - errstr = - emacs_sprintf_string_lisp - ("%s: (%s %s)\n\nBacktrace follows:\n\n%s", - Qnil, 4, - build_msg_string (p->warning_string ? p->warning_string : "error"), - error_conditions, data, p->backtrace); - - warn_when_safe_lispobj (p->warning_class, current_warning_level (), - errstr); - unbind_to (speccount); } else @@ -4882,6 +4867,52 @@ call_trapping_problems_2, opaque); } +static void +issue_call_trapping_problems_warning (Lisp_Object warning_class, + const CIbyte *warning_string, + struct call_trapping_problems_result *p) +{ + if (!warning_will_be_discarded (current_warning_level ())) + { + int depth = specpdl_depth (); + + /* We're no longer protected against errors or quit here, so at + least let's temporarily inhibit quit. */ + specbind (Qinhibit_quit, Qt); + + if (p->caught_throw) + { + Lisp_Object errstr = + emacs_sprintf_string_lisp + ("%s: Attempt to throw outside of function " + "to catch `%s' with value `%s'", + Qnil, 3, + build_msg_string (warning_string ? warning_string : "error"), + p->thrown_tag, p->thrown_value); + warn_when_safe_lispobj (Qerror, current_warning_level (), errstr); + } + else if (p->caught_error) + { + Lisp_Object errstr; + /* #### This should call + (with-output-to-string (display-error (cons error_conditions + data)) + but that stuff is all in Lisp currently. */ + errstr = + emacs_sprintf_string_lisp + ("%s: (%s %s)\n\nBacktrace follows:\n\n%s", + Qnil, 4, + build_msg_string (warning_string ? warning_string : "error"), + p->error_conditions, p->data, p->backtrace); + + warn_when_safe_lispobj (warning_class, current_warning_level (), + errstr); + } + + unbind_to (depth); + } +} + /* Turn on the trapping flags in FLAGS -- see call_trapping_problems(). This cannot handle INTERNAL_INHIBIT_THROWS() or INTERNAL_INHIBIT_ERRORS (because they ultimately boil down to a setjmp()!) -- you must directly @@ -4944,6 +4975,11 @@ (If FLAGS contains INHIBIT_WARNING_ISSUE, no warnings are issued; this applies to recursive invocations of call_trapping_problems, too. + If FLAGS contains POSTPONE_WARNING_ISSUE, no warnings are issued; + but values useful for generating a warning are still computed (in + particular, the backtrace), so that the calling function can issue + a warning. + If FLAGS contains ISSUE_WARNINGS_AT_DEBUG_LEVEL, warnings will be issued, but at level `debug', which normally is below the minimum specified by `log-warning-minimum-level', meaning such warnings will @@ -5065,6 +5101,7 @@ int speccount = specpdl_depth (); struct gcpro gcpro1, gcpro2, gcpro3, gcpro4, gcpro5; struct call_trapping_problems package; + struct call_trapping_problems_result real_problem; Lisp_Object opaque, thrown_tag, tem; int thrown = 0; @@ -5109,59 +5146,43 @@ /* Nothing special. */ tem = (fun) (arg); - if (thrown && !EQ (thrown_tag, package.catchtag) - && !(flags & INHIBIT_WARNING_ISSUE) - && !warning_will_be_discarded (current_warning_level ())) + if (!problem) + problem = &real_problem; + + if (!thrown) { - Lisp_Object errstr; - - if (!(flags & INHIBIT_QUIT)) - /* We're no longer protected against errors or quit here, so at - least let's temporarily inhibit quit. */ - specbind (Qinhibit_quit, Qt); - errstr = - emacs_sprintf_string_lisp - ("%s: Attempt to throw outside of function " - "to catch `%s' with value `%s'", - Qnil, 3, build_msg_string (warning_string ? warning_string : "error"), - thrown_tag, tem); - - warn_when_safe_lispobj (Qerror, current_warning_level (), errstr); + problem->caught_error = 0; + problem->caught_throw = 0; + problem->error_conditions = Qnil; + problem->data = Qnil; + problem->backtrace = Qnil; + problem->thrown_tag = Qnil; + problem->thrown_value = Qnil; } - - if (problem) + else if (EQ (thrown_tag, package.catchtag)) { - if (!thrown) - { - problem->caught_error = 0; - problem->caught_throw = 0; - problem->error_conditions = Qnil; - problem->data = Qnil; - problem->backtrace = Qnil; - problem->thrown_tag = Qnil; - problem->thrown_value = Qnil; - } - else if (EQ (thrown_tag, package.catchtag)) - { - problem->caught_error = 1; - problem->caught_throw = 0; - problem->error_conditions = package.error_conditions; - problem->data = package.data; - problem->backtrace = package.backtrace; - problem->thrown_tag = Qnil; - problem->thrown_value = Qnil; - } - else - { - problem->caught_error = 0; - problem->caught_throw = 1; - problem->error_conditions = Qnil; - problem->data = Qnil; - problem->backtrace = Qnil; - problem->thrown_tag = thrown_tag; - problem->thrown_value = tem; - } + problem->caught_error = 1; + problem->caught_throw = 0; + problem->error_conditions = package.error_conditions; + problem->data = package.data; + problem->backtrace = package.backtrace; + problem->thrown_tag = Qnil; + problem->thrown_value = Qnil; } + else + { + problem->caught_error = 0; + problem->caught_throw = 1; + problem->error_conditions = Qnil; + problem->data = Qnil; + problem->backtrace = Qnil; + problem->thrown_tag = thrown_tag; + problem->thrown_value = tem; + } + + if (!(flags & INHIBIT_WARNING_ISSUE) && !(flags & POSTPONE_WARNING_ISSUE)) + issue_call_trapping_problems_warning (warning_class, warning_string, + problem); if (!NILP (package.catchtag) && !EQ (package.catchtag, Vcatch_everything_tag)) @@ -5472,11 +5493,11 @@ } Lisp_Object -run_hook_trapping_problems (const CIbyte *warning_string, +run_hook_trapping_problems (Lisp_Object warning_class, Lisp_Object hook_symbol, int flags) { - return run_hook_with_args_trapping_problems (warning_string, 1, &hook_symbol, + return run_hook_with_args_trapping_problems (warning_class, 1, &hook_symbol, RUN_HOOKS_TO_COMPLETION, flags); } @@ -5494,9 +5515,8 @@ if an error occurs (but not a quit). */ Lisp_Object -safe_run_hook_trapping_problems (const CIbyte *warning_string, - Lisp_Object hook_symbol, - int flags) +safe_run_hook_trapping_problems (Lisp_Object warning_class, + Lisp_Object hook_symbol, int flags) { Lisp_Object tem; struct gcpro gcpro1, gcpro2; @@ -5509,14 +5529,32 @@ return Qnil; GCPRO2 (hook_symbol, tem); - tem = call_trapping_problems (Qerror, warning_string, flags, + tem = call_trapping_problems (Qerror, NULL, + flags | POSTPONE_WARNING_ISSUE, &prob, safe_run_hook_trapping_problems_1, LISP_TO_VOID (hook_symbol)); - if (prob.caught_throw || (prob.caught_error && !EQ (prob.error_conditions, - Qquit))) - Fset (hook_symbol, Qnil); - RETURN_UNGCPRO (tem); + { + Lisp_Object hook_name = XSYMBOL_NAME (hook_symbol); + Ibyte *hook_str = XSTRING_DATA (hook_name); + Ibyte *err = alloca_ibytes (XSTRING_LENGTH (hook_name) + 100); + + if (prob.caught_throw || (prob.caught_error && !EQ (prob.error_conditions, + Qquit))) + { + Fset (hook_symbol, Qnil); + qxesprintf (err, "Error in `%s' (resetting to nil)", hook_str); + } + else + qxesprintf (err, "Quit in `%s'", hook_str); + + + issue_call_trapping_problems_warning (warning_class, (CIbyte *) err, + &prob); + } + + UNGCPRO; + return tem; } struct run_hook_with_args_in_buffer_trapping_problems @@ -5541,7 +5579,7 @@ call_trapping_problems! */ Lisp_Object -run_hook_with_args_in_buffer_trapping_problems (const CIbyte *warning_string, +run_hook_with_args_in_buffer_trapping_problems (Lisp_Object warning_class, struct buffer *buf, int nargs, Lisp_Object *args, enum run_hooks_condition cond, @@ -5550,6 +5588,9 @@ Lisp_Object sym, val, ret; struct run_hook_with_args_in_buffer_trapping_problems diversity_and_distrust; struct gcpro gcpro1; + Lisp_Object hook_name; + Ibyte *hook_str; + Ibyte *err; if (!initialized || preparing_for_armageddon) /* We need to bail out of here pronto. */ @@ -5569,27 +5610,30 @@ diversity_and_distrust.args = args; diversity_and_distrust.cond = cond; + hook_name = XSYMBOL_NAME (args[0]); + hook_str = XSTRING_DATA (hook_name); + err = alloca_ibytes (XSTRING_LENGTH (hook_name) + 100); + qxesprintf (err, "Error in `%s'", hook_str); RETURN_UNGCPRO (call_trapping_problems - (Qerror, warning_string, - flags, 0, + (warning_class, (CIbyte *) err, flags, 0, run_hook_with_args_in_buffer_trapping_problems_1, &diversity_and_distrust)); } Lisp_Object -run_hook_with_args_trapping_problems (const CIbyte *warning_string, +run_hook_with_args_trapping_problems (Lisp_Object warning_class, int nargs, Lisp_Object *args, enum run_hooks_condition cond, int flags) { return run_hook_with_args_in_buffer_trapping_problems - (warning_string, current_buffer, nargs, args, cond, flags); + (warning_class, current_buffer, nargs, args, cond, flags); } Lisp_Object -va_run_hook_with_args_trapping_problems (const CIbyte *warning_string, +va_run_hook_with_args_trapping_problems (Lisp_Object warning_class, Lisp_Object hook_var, int nargs, ...) { @@ -5609,13 +5653,12 @@ GCPRO1_ARRAY (funcall_args, nargs + 1); RETURN_UNGCPRO (run_hook_with_args_in_buffer_trapping_problems - (warning_string, current_buffer, nargs + 1, funcall_args, + (warning_class, current_buffer, nargs + 1, funcall_args, RUN_HOOKS_TO_COMPLETION, flags)); } Lisp_Object -va_run_hook_with_args_in_buffer_trapping_problems (const CIbyte * - warning_string, +va_run_hook_with_args_in_buffer_trapping_problems (Lisp_Object warning_class, struct buffer *buf, Lisp_Object hook_var, int nargs, ...) @@ -5636,7 +5679,7 @@ GCPRO1_ARRAY (funcall_args, nargs + 1); RETURN_UNGCPRO (run_hook_with_args_in_buffer_trapping_problems - (warning_string, buf, nargs + 1, funcall_args, + (warning_class, buf, nargs + 1, funcall_args, RUN_HOOKS_TO_COMPLETION, flags)); } @@ -5876,7 +5919,7 @@ /* Establish an unwind-protect which will restore the int pointed to by ADDR with the value VAL. This function works correctly with all ints, even those that don't fit into a Lisp integer. */ -static int +int record_unwind_protect_restoring_int (int *addr, int val) { Lisp_Object opaque = make_opaque_ptr (addr);
--- a/src/event-stream.c Sun Mar 02 02:18:12 2003 +0000 +++ b/src/event-stream.c Sun Mar 02 09:38:54 2003 +0000 @@ -2181,8 +2181,7 @@ if (!NILP (Vpre_idle_hook) && !detect_input_pending (1)) safe_run_hook_trapping_problems - ("Error in `pre-idle-hook' (setting hook to nil)", - Qpre_idle_hook, + (Qredisplay, Qpre_idle_hook, /* Quit is inhibited as a result of being within next-event so we need to fix that. */ INHIBIT_EXISTING_PERMANENT_DISPLAY_OBJECT_DELETION | UNINHIBIT_QUIT); @@ -4259,8 +4258,8 @@ last_point_position_buffer = wrap_buffer (current_buffer); /* This function can GC */ safe_run_hook_trapping_problems - ("Error in `pre-command-hook' (setting hook to nil)", - Qpre_command_hook, INHIBIT_EXISTING_PERMANENT_DISPLAY_OBJECT_DELETION); + (Qcommand, Qpre_command_hook, + INHIBIT_EXISTING_PERMANENT_DISPLAY_OBJECT_DELETION); /* This is a kludge, but necessary; see simple.el */ call0 (Qhandle_pre_motion_command); @@ -4304,23 +4303,8 @@ zmacs_update_region (); safe_run_hook_trapping_problems - ("Error in `post-command-hook' (setting hook to nil)", - Qpost_command_hook, INHIBIT_EXISTING_PERMANENT_DISPLAY_OBJECT_DELETION); - -#if 0 /* FSF Emacs crap */ - if (!NILP (Vdeferred_action_list)) - call0 (Vdeferred_action_function); - - if (NILP (Vunread_command_events) - && NILP (Vexecuting_macro) - && !NILP (Vpost_command_idle_hook) - && !NILP (Fsit_for (make_float ((double) post_command_idle_delay - / 1000000), Qnil))) - safe_run_hook_trapping_problems - ("Error in `post-command-idle-hook' (setting hook to nil)", - Qpost_command_idle_hook, + (Qcommand, Qpost_command_hook, INHIBIT_EXISTING_PERMANENT_DISPLAY_OBJECT_DELETION); -#endif /* FSF Emacs crap */ #if 0 /* FSF Emacs */ if (!NILP (current_buffer->mark_active))
--- a/src/fileio.c Sun Mar 02 02:18:12 2003 +0000 +++ b/src/fileio.c Sun Mar 02 09:38:54 2003 +0000 @@ -1,6 +1,6 @@ /* File IO for XEmacs. Copyright (C) 1985-1988, 1992-1995 Free Software Foundation, Inc. - Copyright (C) 1996, 2001, 2002 Ben Wing. + Copyright (C) 1996, 2001, 2002, 2003 Ben Wing. This file is part of XEmacs. @@ -25,6 +25,7 @@ incomplete synching, so beware.) */ /* Mule-ized completely except for the #if 0-code including decrypt-string and encrypt-string. --ben 7-2-00 */ +/* #if 0-code Mule-ized, 2-22-03. --ben */ #include <config.h> @@ -1698,7 +1699,7 @@ If the file does not exist, STATPTR->st_mode is set to 0. */ static void -barf_or_query_if_file_exists (Lisp_Object absname, const char *querystring, +barf_or_query_if_file_exists (Lisp_Object absname, const CIbyte *querystring, int interactive, struct stat *statptr) { /* This function can call Lisp. GC checked 2000-07-28 ben */ @@ -2193,8 +2194,8 @@ (path, login)) { int netresult; - const char *path_ext; - const char *login_ext; + const Extbyte *path_ext; + const Extbyte *login_ext; CHECK_STRING (path); CHECK_STRING (login); @@ -3667,28 +3668,31 @@ */ (string, key)) { - char *encrypted_string, *raw_key; - int rounded_size, extra, key_size; - - /* !!#### May produce bogus data under Mule. */ + Extbyte *encrypted_string, *raw_key; + Extbyte *string_ext, *key_ext; + Bytecount string_size_ext, key_size_ext, rounded_size, extra, key_size; + CHECK_STRING (string); CHECK_STRING (key); - extra = XSTRING_LENGTH (string) % CRYPT_BLOCK_SIZE; - rounded_size = XSTRING_LENGTH (string) + extra; + LISP_STRING_TO_SIZED_EXTERNAL (string, string_ext, string_size_ext, Qbinary); + LISP_STRING_TO_SIZED_EXTERNAL (key, key_ext, key_size_ext, Qbinary); + + extra = string_size_ext % CRYPT_BLOCK_SIZE; + rounded_size = string_size_ext + extra; encrypted_string = ALLOCA (rounded_size + 1); - memcpy (encrypted_string, XSTRING_DATA (string), XSTRING_LENGTH (string)); + memcpy (encrypted_string, string_ext, string_size_ext); memset (encrypted_string + rounded_size - extra, 0, extra + 1); - key_size = min (CRYPT_KEY_SIZE, XSTRING_LENGTH (key)) + key_size = min (CRYPT_KEY_SIZE, key_size_ext); raw_key = ALLOCA (CRYPT_KEY_SIZE + 1); - memcpy (raw_key, XSTRING_DATA (key), key_size); + memcpy (raw_key, key_ext, key_size); memset (raw_key + key_size, 0, (CRYPT_KEY_SIZE + 1) - key_size); ecb_crypt (raw_key, encrypted_string, rounded_size, DES_ENCRYPT | DES_SW); - return make_string (encrypted_string, rounded_size); + return make_ext_string (encrypted_string, rounded_size, Qbinary); } DEFUN ("decrypt-string", Fdecrypt_string, 2, 2, 0, /* @@ -3696,27 +3700,30 @@ */ (string, key)) { - /* !!#### May produce bogus data under Mule. */ - char *decrypted_string, *raw_key; - int string_size, key_size; + Extbyte *decrypted_string, *raw_key; + Extbyte *string_ext, *key_ext; + Bytecount string_size_ext, key_size_ext, string_size, key_size; CHECK_STRING (string); CHECK_STRING (key); - string_size = XSTRING_LENGTH (string) + 1; + LISP_STRING_TO_SIZED_EXTERNAL (string, string_ext, string_size_ext, Qbinary); + LISP_STRING_TO_SIZED_EXTERNAL (key, key_ext, key_size_ext, Qbinary); + + string_size = string_size_ext + 1; decrypted_string = ALLOCA (string_size); - memcpy (decrypted_string, XSTRING_DATA (string), string_size); + memcpy (decrypted_string, string_ext, string_size); decrypted_string[string_size - 1] = '\0'; - key_size = min (CRYPT_KEY_SIZE, XSTRING_LENGTH (key)) + key_size = min (CRYPT_KEY_SIZE, key_size_ext); raw_key = ALLOCA (CRYPT_KEY_SIZE + 1); - memcpy (raw_key, XSTRING_DATA (key), key_size); + memcpy (raw_key, key_ext, key_size); memset (raw_key + key_size, 0, (CRYPT_KEY_SIZE + 1) - key_size); ecb_crypt (raw_key, decrypted_string, string_size, D | DES_SW); - return make_string (decrypted_string, string_size - 1); + return make_ext_string (decrypted_string, string_size - 1, Qbinary); } #endif /* 0 */ @@ -4040,10 +4047,9 @@ set_buffer_internal (b); if (!auto_saved && NILP (no_message)) { - static const unsigned char *msg - = (const unsigned char *) "Auto-saving..."; + static const Ibyte *msg = (const Ibyte *) "Auto-saving..."; echo_area_message (selected_frame (), msg, Qnil, - 0, strlen ((const char *) msg), + 0, qxestrlen (msg), Qauto_saving); } @@ -4150,10 +4156,9 @@ if (auto_saved && NILP (no_message) && NILP (clear_echo_area (selected_frame (), Qauto_saving, 0))) { - static const unsigned char *msg - = (const unsigned char *)"Auto-saving...done"; + static const Ibyte *msg = (const Ibyte *)"Auto-saving...done"; echo_area_message (selected_frame (), msg, Qnil, 0, - strlen ((const char *) msg), Qauto_saving); + qxestrlen (msg), Qauto_saving); } Vquit_flag = oquit;
--- a/src/general-slots.h Sun Mar 02 02:18:12 2003 +0000 +++ b/src/general-slots.h Sun Mar 02 09:38:54 2003 +0000 @@ -73,6 +73,7 @@ SYMBOL (Qcategory); SYMBOL (Qcenter); SYMBOL (Qchain); +SYMBOL (Qchange); SYMBOL (Qchannel); SYMBOL (Qchar); SYMBOL (Qcharacter); @@ -133,6 +134,7 @@ SYMBOL (Qfuncall); SYMBOL (Qfunction); SYMBOL (Qgap_overhead); +SYMBOL (Qgarbage_collection); SYMBOL (Qgeneric); SYMBOL (Qgeometry); SYMBOL (Qglobal);
--- a/src/insdel.c Sun Mar 02 02:18:12 2003 +0000 +++ b/src/insdel.c Sun Mar 02 09:38:54 2003 +0000 @@ -2,7 +2,7 @@ Copyright (C) 1985, 1986, 1991, 1992, 1993, 1994, 1995 Free Software Foundation, Inc. Copyright (C) 1995 Sun Microsystems, Inc. - Copyright (C) 2001, 2002 Ben Wing. + Copyright (C) 2001, 2002, 2003 Ben Wing. This file is part of XEmacs. @@ -736,7 +736,7 @@ set_buffer_internal (buf); in_first_change = 1; run_hook_trapping_problems - (0, Qfirst_change_hook, + (Qchange, Qfirst_change_hook, INHIBIT_EXISTING_PERMANENT_DISPLAY_OBJECT_DELETION); unbind_to (speccount); } @@ -807,12 +807,12 @@ { set_buffer_internal (buf); va_run_hook_with_args_trapping_problems - (0, Qbefore_change_functions, 2, + (Qchange, Qbefore_change_functions, 2, make_int (start), make_int (end), INHIBIT_EXISTING_PERMANENT_DISPLAY_OBJECT_DELETION); /* Obsolete, for compatibility */ va_run_hook_with_args_trapping_problems - (0, Qbefore_change_function, 2, + (Qchange, Qbefore_change_function, 2, make_int (start), make_int (end), INHIBIT_EXISTING_PERMANENT_DISPLAY_OBJECT_DELETION); } @@ -896,13 +896,13 @@ /* The actual after-change functions take slightly different arguments than what we were passed. */ va_run_hook_with_args_trapping_problems - (0, Qafter_change_functions, 3, + (Qchange, Qafter_change_functions, 3, make_int (start), make_int (new_end), make_int (orig_end - start), INHIBIT_EXISTING_PERMANENT_DISPLAY_OBJECT_DELETION); /* Obsolete, for compatibility */ va_run_hook_with_args_trapping_problems - (0, Qafter_change_function, 3, + (Qchange, Qafter_change_function, 3, make_int (start), make_int (new_end), make_int (orig_end - start), INHIBIT_EXISTING_PERMANENT_DISPLAY_OBJECT_DELETION);
--- a/src/lisp.h Sun Mar 02 02:18:12 2003 +0000 +++ b/src/lisp.h Sun Mar 02 09:38:54 2003 +0000 @@ -1145,6 +1145,13 @@ extern Bytecount __temp_alloca_size__; extern Bytecount funcall_alloca_count; +#ifdef ERROR_CHECK_MALLOC +extern int regex_malloc_disallowed; +#define REGEX_MALLOC_CHECK() assert (!regex_malloc_disallowed) +#else +#define REGEX_MALLOC_CHECK() ((void) 0) +#endif + /* Do stack or heap alloca() depending on size. NOTE: The use of a global temporary like this is unsafe if ALLOCA() occurs @@ -1153,7 +1160,8 @@ expression has side effects -- something easy to forget. */ #define ALLOCA(size) \ - (__temp_alloca_size__ = (size), \ + (REGEX_MALLOC_CHECK (), \ + __temp_alloca_size__ = (size), \ __temp_alloca_size__ > MAX_ALLOCA_VS_C_ALLOCA ? \ xemacs_c_alloca (__temp_alloca_size__) : \ (need_to_check_c_alloca ? xemacs_c_alloca (0) : 0, \ @@ -1172,7 +1180,8 @@ function! */ #define MALLOC_OR_ALLOCA(size) \ - (__temp_alloca_size__ = (size), \ + (REGEX_MALLOC_CHECK (), \ + __temp_alloca_size__ = (size), \ __temp_alloca_size__ > MAX_ALLOCA_VS_MALLOC ? \ xmalloc_and_record_unwind (__temp_alloca_size__) : \ (need_to_check_c_alloca ? xemacs_c_alloca (0) : 0, \ @@ -1187,6 +1196,7 @@ which ensures constant amortized time per element. */ #define DO_REALLOC(basevar, sizevar, needed_size, type) do { \ Bytecount do_realloc_needed_size = (needed_size); \ + REGEX_MALLOC_CHECK (); \ if ((sizevar) < do_realloc_needed_size) \ { \ if ((sizevar) < 32) \ @@ -3560,7 +3570,7 @@ extern int need_to_garbage_collect; extern int need_to_check_c_alloca; extern int need_to_signal_post_gc; -extern Lisp_Object Qpost_gc_hook; +extern Lisp_Object Qpost_gc_hook, Qgarbage_collecting; void recompute_funcall_allocation_flag (void); #ifdef MEMORY_USAGE_STATS @@ -4038,6 +4048,7 @@ #define INHIBIT_ANY_CHANGE_AFFECTING_REDISPLAY (1<<14) #define INHIBIT_ENTERING_DEBUGGER (1<<15) #define CALL_WITH_SUSPENDED_ERRORS (1<<16) +#define POSTPONE_WARNING_ISSUE (1<<17) enum check_allowed_operation { @@ -4086,32 +4097,27 @@ Lisp_Object, int); Lisp_Object eval_in_buffer_trapping_problems (const char *, struct buffer *, Lisp_Object, int); -Lisp_Object run_hook_trapping_problems (const char *, Lisp_Object, int); -Lisp_Object safe_run_hook_trapping_problems (const char *, Lisp_Object, int); -Lisp_Object run_hook_with_args_in_buffer_trapping_problems (const char - *warning_string, - struct buffer - *buf, int nargs, +Lisp_Object run_hook_trapping_problems (Lisp_Object, Lisp_Object, int); +Lisp_Object safe_run_hook_trapping_problems (Lisp_Object, Lisp_Object, int); +Lisp_Object run_hook_with_args_in_buffer_trapping_problems (Lisp_Object, + struct buffer *, + int nargs, Lisp_Object *args, enum run_hooks_condition cond, int flags); -Lisp_Object run_hook_with_args_trapping_problems (const char *warning_string, +Lisp_Object run_hook_with_args_trapping_problems (Lisp_Object, int nargs, Lisp_Object *args, enum run_hooks_condition cond, int flags); -Lisp_Object va_run_hook_with_args_trapping_problems (const char - *warning_string, +Lisp_Object va_run_hook_with_args_trapping_problems (Lisp_Object, Lisp_Object hook_var, int nargs, ...); -Lisp_Object va_run_hook_with_args_in_buffer_trapping_problems (const char - *warning_string, - struct buffer - *buf, - Lisp_Object - hook_var, +Lisp_Object va_run_hook_with_args_in_buffer_trapping_problems (Lisp_Object, + struct buffer *, + Lisp_Object, int nargs, ...); Lisp_Object call_with_suspended_errors (lisp_fn_t, Lisp_Object, Lisp_Object, @@ -4133,6 +4139,7 @@ int record_unwind_protect (Lisp_Object (*) (Lisp_Object), Lisp_Object); int record_unwind_protect_freeing (void *ptr); int record_unwind_protect_freeing_dynarr (void *ptr); +int record_unwind_protect_restoring_int (int *addr, int val); int internal_bind_int (int *addr, int newval); int internal_bind_lisp_object (Lisp_Object *addr, Lisp_Object newval); void do_autoload (Lisp_Object, Lisp_Object); /* GCPROs both arguments */
--- a/src/make-src-depend Sun Mar 02 02:18:12 2003 +0000 +++ b/src/make-src-depend Sun Mar 02 09:38:54 2003 +0000 @@ -124,6 +124,9 @@ delete $uses{$file}{'config.h'}; $uses{$file}{'$(CONFIG_H)'} = 1; } + # Huge hack. With QUICK_BUILD, general.c has no dependence on + # general-slots.h but really should. + $uses{$file}{'general-slots.h'} = 1 if $file eq "general.c"; print "@{[sort keys %{$uses{$file}}]}\n"; }
--- a/src/menubar-msw.c Sun Mar 02 02:18:12 2003 +0000 +++ b/src/menubar-msw.c Sun Mar 02 09:38:54 2003 +0000 @@ -2,7 +2,7 @@ Copyright (C) 1993, 1994 Free Software Foundation, Inc. Copyright (C) 1995 Tinker Systems and INS Engineering Corp. Copyright (C) 1997 Kirill M. Katsnelson <kkm@kis.ru>. - Copyright (C) 2000, 2001, 2002 Ben Wing. + Copyright (C) 2000, 2001, 2002, 2003 Ben Wing. This file is part of XEmacs. @@ -655,7 +655,7 @@ /* We simply ignore return value. In any case, we construct the bar on the fly */ run_hook_trapping_problems - ("Error in activate-menubar-hook", Qactivate_menubar_hook, + (Qmenubar, Qactivate_menubar_hook, INHIBIT_EXISTING_PERMANENT_DISPLAY_OBJECT_DELETION); update_frame_menubar_maybe (f);
--- a/src/menubar-x.c Sun Mar 02 02:18:12 2003 +0000 +++ b/src/menubar-x.c Sun Mar 02 09:38:54 2003 +0000 @@ -496,7 +496,7 @@ a pointer back to lisp data needs to be hidden away somewhere. So that an INCREMENTAL_TYPE widget_value can be recreated... Hmmmmm. */ run_hook_trapping_problems - ("Error in activate-menubar-hook", Qactivate_menubar_hook, + (Qmenubar, Qactivate_menubar_hook, INHIBIT_EXISTING_PERMANENT_DISPLAY_OBJECT_DELETION); set_frame_menubar (f, 1, 0); DEVICE_X_MOUSE_TIMESTAMP (XDEVICE (FRAME_DEVICE (f))) =
--- a/src/ralloc.c Sun Mar 02 02:18:12 2003 +0000 +++ b/src/ralloc.c Sun Mar 02 09:38:54 2003 +0000 @@ -65,6 +65,8 @@ #else /* Not emacs. */ +#define REGEX_MALLOC_CHECK() + #include <stddef.h> typedef void *POINTER; @@ -943,6 +945,8 @@ { bloc_ptr new_bloc; + REGEX_MALLOC_CHECK (); + if (! r_alloc_initialized) init_ralloc (); @@ -967,6 +971,8 @@ { register bloc_ptr dead_bloc; + REGEX_MALLOC_CHECK (); + if (! r_alloc_initialized) init_ralloc (); @@ -1002,6 +1008,8 @@ { register bloc_ptr bloc; + REGEX_MALLOC_CHECK (); + if (! r_alloc_initialized) init_ralloc (); @@ -1854,6 +1862,8 @@ { MMAP_HANDLE mh; + REGEX_MALLOC_CHECK (); + switch(r_alloc_initialized) { case 0: @@ -1896,6 +1906,8 @@ void r_alloc_free (POINTER *ptr) { + REGEX_MALLOC_CHECK (); + switch( r_alloc_initialized) { case 0: abort(); @@ -1938,6 +1950,8 @@ POINTER r_re_alloc (POINTER *ptr, size_t sz) { + REGEX_MALLOC_CHECK (); + if (r_alloc_initialized == 0) { abort ();
--- a/src/regex.c Sun Mar 02 02:18:12 2003 +0000 +++ b/src/regex.c Sun Mar 02 09:38:54 2003 +0000 @@ -5,7 +5,7 @@ Copyright (C) 1993, 1994, 1995 Free Software Foundation, Inc. Copyright (C) 1995 Sun Microsystems, Inc. - Copyright (C) 1995, 2001, 2002 Ben Wing. + Copyright (C) 1995, 2001, 2002, 2003 Ben Wing. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by @@ -126,6 +126,47 @@ return 0; } +#ifdef REL_ALLOC + +/* STRING1 is the value of STRING1 given to re_match_2(). LISPOBJ is + the Lisp object (if any) from which the string is taken. If LISPOBJ + is a buffer, return a relocation offset to be added to all pointers to + string data so that they will be accurate again, after an allocation or + reallocation that potentially relocated the buffer data. +*/ +static Bytecount +offset_post_relocation (Lisp_Object lispobj, char *string1) +{ + struct buffer *buf; + + if (!BUFFERP (lispobj)) + return 0; + return (BYTE_BUF_BYTE_ADDRESS (XBUFFER (lispobj), + BYTE_BUF_BEGV (XBUFFER (lispobj))) - + string1); +} + +#endif /* REL_ALLOC */ + +#ifdef ERROR_CHECK_MALLOC + +/* NOTE that this can run malloc() so you need to adjust afterwards. */ + +static int +bind_regex_malloc_disallowed (int value) +{ + /* Tricky, because the act of binding can run malloc(). */ + int old_regex_malloc_disallowed = regex_malloc_disallowed; + int depth; + regex_malloc_disallowed = 0; + depth = record_unwind_protect_restoring_int (®ex_malloc_disallowed, + old_regex_malloc_disallowed); + regex_malloc_disallowed = value; + return depth; +} + +#endif /* ERROR_CHECK_MALLOC */ + #else /* not emacs */ /* If we are not linking with Emacs proper, @@ -300,11 +341,61 @@ not functions -- `alloca'-allocated space disappears at the end of the function it is called in. */ +#ifndef emacs +#define ALLOCA alloca +#define xmalloc malloc +#define xrealloc realloc +#define xfree free +#endif + +#ifdef emacs +#define ALLOCA_GARBAGE_COLLECT() \ +do \ +{ \ + if (need_to_check_c_alloca) \ + xemacs_c_alloca (0); \ +} while (0) +#elif defined (C_ALLOCA) +#define ALLOCA_GARBAGE_COLLECT() alloca (0) +#else +#define ALLOCA_GARBAGE_COLLECT() +#endif + +#ifndef emacs +/* So we can use just it to conditionalize on */ +#undef ERROR_CHECK_MALLOC +#endif + +#ifdef ERROR_CHECK_MALLOC +/* When REL_ALLOC, malloc() is problematic because it could potentially + cause all rel-alloc()ed data -- including buffer text -- to be relocated. + We deal with this by checking for such relocation whenever we have + executed a statement that may call malloc() -- or alloca(), which may + end up calling malloc() in some circumstances -- and recomputing all + of our string pointers in re_match_2_internal() and re_search_2(). + However, if malloc() or alloca() happens and we don't know about it, + we could still be screwed. So we set up a system where we indicate all + places where we are prepared for malloc() or alloca(), and in any + other circumstances, calls to those functions (from anywhere inside of + XEmacs!) will abort(). We do this even when REL_ALLOC is not defined + so that we catch these problems sooner, since many developers and beta + testers will not be running with REL_ALLOC. */ +int regex_malloc_disallowed; +#define BEGIN_REGEX_MALLOC_OK() regex_malloc_disallowed = 0 +#define END_REGEX_MALLOC_OK() regex_malloc_disallowed = 1 +#define UNBIND_REGEX_MALLOC_CHECK() unbind_to (depth) +#else +#define BEGIN_REGEX_MALLOC_OK() +#define END_REGEX_MALLOC_OK() +#define UNBIND_REGEX_MALLOC_CHECK() +#endif + + #ifdef REGEX_MALLOC -#define REGEX_ALLOCATE malloc -#define REGEX_REALLOCATE(source, osize, nsize) realloc (source, nsize) -#define REGEX_FREE free +#define REGEX_ALLOCATE xmalloc +#define REGEX_REALLOCATE(source, osize, nsize) xrealloc (source, nsize) +#define REGEX_FREE xfree #else /* not REGEX_MALLOC */ @@ -329,11 +420,11 @@ #endif /* not alloca */ -#define REGEX_ALLOCATE alloca +#define REGEX_ALLOCATE ALLOCA /* Assumes a `char *destination' variable. */ #define REGEX_REALLOCATE(source, osize, nsize) \ - (destination = (char *) alloca (nsize), \ + (destination = (char *) ALLOCA (nsize), \ memmove (destination, source, osize), \ destination) @@ -356,13 +447,13 @@ #ifdef REGEX_MALLOC -#define REGEX_ALLOCATE_STACK malloc -#define REGEX_REALLOCATE_STACK(source, osize, nsize) realloc (source, nsize) -#define REGEX_FREE_STACK free +#define REGEX_ALLOCATE_STACK xmalloc +#define REGEX_REALLOCATE_STACK(source, osize, nsize) xrealloc (source, nsize) +#define REGEX_FREE_STACK xfree #else /* not REGEX_MALLOC */ -#define REGEX_ALLOCATE_STACK alloca +#define REGEX_ALLOCATE_STACK ALLOCA #define REGEX_REALLOCATE_STACK(source, osize, nsize) \ REGEX_REALLOCATE (source, osize, nsize) @@ -380,8 +471,8 @@ (size1 && string1 <= (ptr) && (ptr) <= string1 + size1) /* (Re)Allocate N items of type T using malloc, or fail. */ -#define TALLOC(n, t) ((t *) malloc ((n) * sizeof (t))) -#define RETALLOC(addr, n, t) ((addr) = (t *) realloc (addr, (n) * sizeof (t))) +#define TALLOC(n, t) ((t *) xmalloc ((n) * sizeof (t))) +#define RETALLOC(addr, n, t) ((addr) = (t *) xrealloc (addr, (n) * sizeof (t))) #define REGEX_TALLOC(n, t) ((t *) REGEX_ALLOCATE ((n) * sizeof (t))) #define BYTEWIDTH 8 /* In bits. */ @@ -1115,6 +1206,26 @@ /* Avoiding alloca during matching, to placate r_alloc. */ +/* About these various flags: + + MATCH_MAY_ALLOCATE indicates that it's OK to do allocation in the + searching and matching functions. In this case, we use local variables + to hold the values allocated. If not, we use *global* variables, which + are pre-allocated. NOTE: XEmacs ***MUST*** run with MATCH_MAY_ALLOCATE, + because the regexp routines may get called reentrantly as a result of + QUIT processing (e.g. under Windows: re_match -> QUIT -> quit_p -> drain + events -> process WM_INITMENU -> call filter -> re_match; see stack + trace in signal.c), so we cannot have any global variables (unless we do + lots of trickiness including some unwind-protects, which isn't worth it + at this point). + + REL_ALLOC means that the relocating allocator is in use, for buffers + and such. REGEX_REL_ALLOC means that we use rel-alloc to manage the + fail stack, which may grow quite large. REGEX_MALLOC means we use + malloc() in place of alloca() to allocate the fail stack -- only + applicable if REGEX_REL_ALLOC is not defined. +*/ + /* Define MATCH_MAY_ALLOCATE unless we need to make sure that the searching and matching functions should not call alloca. On some systems, alloca is implemented in terms of malloc, and if we're @@ -1147,21 +1258,25 @@ matching routines; then we don't notice interrupts when they come in. So, Emacs blocks input around all regexp calls except the matching calls, which it leaves unprotected, in the faith that they - will not malloc.]] This previous paragraph is irrelevant. - - XEmacs: We *do not* do anything so stupid as process input from within a - signal handler. However, the regexp routines may get called reentrantly - as a result of QUIT processing (e.g. under Windows: re_match -> QUIT -> - quit_p -> drain events -> process WM_INITMENU -> call filter -> - re_match; see stack trace in signal.c), so we cannot have any global - variables (unless we do lots of trickiness including some - unwind-protects, which isn't worth it at this point). The first - paragraph appears utterly garbled to me -- shouldn't *ANY* use of - rel-alloc to different potentially cause buffer data to be relocated? I + will not malloc.]] This previous paragraph is irrelevant under XEmacs, + as we *do not* do anything so stupid as process input from within a + signal handler. + + However, the regexp routines may get called reentrantly as a result of + QUIT processing (e.g. under Windows: re_match -> QUIT -> quit_p -> drain + events -> process WM_INITMENU -> call filter -> re_match; see stack + trace in signal.c), so we cannot have any global variables (unless we do + lots of trickiness including some unwind-protects, which isn't worth it + at this point). Hence we MUST have MATCH_MAY_ALLOCATE defined. + + Also, the first paragraph does not make complete sense to me -- what + about the use of rel-alloc to handle the fail stacks? Shouldn't these + reallocations potentially cause buffer data to be relocated as well? I must be missing something, though -- perhaps the writer above is assuming that the failure stack(s) will always be allocated after the buffer data, and thus reallocating them with rel-alloc won't move buffer - data. --ben */ + data. (In fact, a cursory glance at the code in ralloc.c seems to + confirm this.) --ben */ /* Normally, this is fine. */ #define MATCH_MAY_ALLOCATE @@ -1178,14 +1293,12 @@ failure stack, but we would still use it for the register vectors; so REL_ALLOC should not affect this. */ -/* XEmacs change emacs -> REL_ALLOC */ -#if (defined (C_ALLOCA) || defined (REGEX_MALLOC)) && defined (REL_ALLOC) +/* XEmacs can handle REL_ALLOC and malloc() OK */ +#if !defined (emacs) && (defined (C_ALLOCA) || defined (REGEX_MALLOC)) && defined (REL_ALLOC) #undef MATCH_MAY_ALLOCATE #endif -/* #### need better check */ - -#if !defined (MATCH_MAY_ALLOCATE) && defined (emacs) && defined (HAVE_MS_WINDOWS) +#if !defined (MATCH_MAY_ALLOCATE) && defined (emacs) #error regex must be handle reentrancy; MATCH_MAY_ALLOCATE must be defined #endif @@ -1238,16 +1351,20 @@ Do `return -2' if the alloc fails. */ #ifdef MATCH_MAY_ALLOCATE -#define INIT_FAIL_STACK() \ - do { \ - fail_stack.stack = (fail_stack_elt_t *) \ - REGEX_ALLOCATE_STACK (INIT_FAILURE_ALLOC * sizeof (fail_stack_elt_t)); \ - \ - if (fail_stack.stack == NULL) \ - return -2; \ - \ - fail_stack.size = INIT_FAILURE_ALLOC; \ - fail_stack.avail = 0; \ +#define INIT_FAIL_STACK() \ + do { \ + fail_stack.stack = (fail_stack_elt_t *) \ + REGEX_ALLOCATE_STACK (INIT_FAILURE_ALLOC * \ + sizeof (fail_stack_elt_t)); \ + \ + if (fail_stack.stack == NULL) \ + { \ + UNBIND_REGEX_MALLOC_CHECK (); \ + return -2; \ + } \ + \ + fail_stack.size = INIT_FAILURE_ALLOC; \ + fail_stack.avail = 0; \ } while (0) #define RESET_FAIL_STACK() REGEX_FREE_STACK (fail_stack.stack) @@ -1281,6 +1398,93 @@ : ((fail_stack).size <<= 1, \ 1))) +#if !defined (emacs) || !defined (REL_ALLOC) +#define RE_MATCH_RELOCATE_MOVEABLE_DATA_POINTERS() +#else +/* Don't change NULL pointers */ +#define ADD_IF_NZ(val) if (val) val += rmdp_offset +#define RE_MATCH_RELOCATE_MOVEABLE_DATA_POINTERS() \ +do \ +{ \ + Bytecount rmdp_offset = offset_post_relocation (lispobj, string1); \ + \ + if (rmdp_offset) \ + { \ + int i; \ + \ + ADD_IF_NZ (string1); \ + ADD_IF_NZ (string2); \ + ADD_IF_NZ (d); \ + ADD_IF_NZ (dend); \ + ADD_IF_NZ (end1); \ + ADD_IF_NZ (end2); \ + ADD_IF_NZ (end_match_1); \ + ADD_IF_NZ (end_match_2); \ + \ + if (bufp->re_ngroups) \ + { \ + for (i = 0; i < numregs; i++) \ + { \ + ADD_IF_NZ (regstart[i]); \ + ADD_IF_NZ (regend[i]); \ + ADD_IF_NZ (old_regstart[i]); \ + ADD_IF_NZ (old_regend[i]); \ + ADD_IF_NZ (best_regstart[i]); \ + ADD_IF_NZ (best_regend[i]); \ + ADD_IF_NZ (reg_dummy[i]); \ + } \ + } \ + \ + ADD_IF_NZ (match_end); \ + } \ +} while (0) +#endif /* !defined (emacs) || !defined (REL_ALLOC) */ + +#if !defined (emacs) || !defined (REL_ALLOC) +#define RE_SEARCH_RELOCATE_MOVEABLE_DATA_POINTERS() +#else +#define RE_SEARCH_RELOCATE_MOVEABLE_DATA_POINTERS() \ +do \ +{ \ + Bytecount rmdp_offset = offset_post_relocation (lispobj, str1); \ + \ + if (rmdp_offset) \ + { \ + int i; \ + \ + ADD_IF_NZ (str1); \ + ADD_IF_NZ (str2); \ + ADD_IF_NZ (string1); \ + ADD_IF_NZ (string2); \ + ADD_IF_NZ (d); \ + \ + \ + \ + ADD_IF_NZ (dend); \ + ADD_IF_NZ (end1); \ + ADD_IF_NZ (end2); \ + ADD_IF_NZ (end_match_1); \ + ADD_IF_NZ (end_match_2); \ + \ + if (bufp->re_ngroups) \ + { \ + for (i = 0; i < numregs; i++) \ + { \ + ADD_IF_NZ (regstart[i]); \ + ADD_IF_NZ (regend[i]); \ + ADD_IF_NZ (old_regstart[i]); \ + ADD_IF_NZ (old_regend[i]); \ + ADD_IF_NZ (best_regstart[i]); \ + ADD_IF_NZ (best_regend[i]); \ + ADD_IF_NZ (reg_dummy[i]); \ + } \ + } \ + \ + ADD_IF_NZ (match_end); \ + } \ +} while (0) + +#endif /* emacs */ /* Push pointer POINTER on FAIL_STACK. Return 1 if was able to do so and 0 if ran out of memory allocating @@ -1363,13 +1567,20 @@ /* Ensure we have enough space allocated for what we will push. */ \ while (REMAINING_AVAIL_SLOTS < NUM_FAILURE_ITEMS) \ { \ + BEGIN_REGEX_MALLOC_OK (); \ if (!DOUBLE_FAIL_STACK (fail_stack)) \ - return failure_code; \ - \ + { \ + END_REGEX_MALLOC_OK (); \ + UNBIND_REGEX_MALLOC_CHECK (); \ + return failure_code; \ + } \ + END_REGEX_MALLOC_OK (); \ DEBUG_PRINT2 ("\n Doubled stack; size now: %ld\n", \ (long) (fail_stack).size); \ DEBUG_PRINT2 (" slots available: %ld\n", \ (long) REMAINING_AVAIL_SLOTS); \ + \ + RE_MATCH_RELOCATE_MOVEABLE_DATA_POINTERS (); \ } \ \ /* Push the info, starting with the registers. */ \ @@ -1676,29 +1887,30 @@ reset the pointers that pointed into the old block to point to the correct places in the new one. If extending the buffer results in it being larger than MAX_BUF_SIZE, then flag memory exhausted. */ -#define EXTEND_BUFFER() \ - do { \ - re_char *old_buffer = bufp->buffer; \ - if (bufp->allocated == MAX_BUF_SIZE) \ - return REG_ESIZE; \ - bufp->allocated <<= 1; \ - if (bufp->allocated > MAX_BUF_SIZE) \ - bufp->allocated = MAX_BUF_SIZE; \ - bufp->buffer = (unsigned char *) realloc (bufp->buffer, bufp->allocated);\ - if (bufp->buffer == NULL) \ - return REG_ESPACE; \ - /* If the buffer moved, move all the pointers into it. */ \ - if (old_buffer != bufp->buffer) \ - { \ - buf_end = (buf_end - old_buffer) + bufp->buffer; \ - begalt = (begalt - old_buffer) + bufp->buffer; \ - if (fixup_alt_jump) \ - fixup_alt_jump = (fixup_alt_jump - old_buffer) + bufp->buffer;\ - if (laststart) \ - laststart = (laststart - old_buffer) + bufp->buffer; \ - if (pending_exact) \ - pending_exact = (pending_exact - old_buffer) + bufp->buffer; \ - } \ +#define EXTEND_BUFFER() \ + do { \ + re_char *old_buffer = bufp->buffer; \ + if (bufp->allocated == MAX_BUF_SIZE) \ + return REG_ESIZE; \ + bufp->allocated <<= 1; \ + if (bufp->allocated > MAX_BUF_SIZE) \ + bufp->allocated = MAX_BUF_SIZE; \ + bufp->buffer = \ + (unsigned char *) xrealloc (bufp->buffer, bufp->allocated); \ + if (bufp->buffer == NULL) \ + return REG_ESPACE; \ + /* If the buffer moved, move all the pointers into it. */ \ + if (old_buffer != bufp->buffer) \ + { \ + buf_end = (buf_end - old_buffer) + bufp->buffer; \ + begalt = (begalt - old_buffer) + bufp->buffer; \ + if (fixup_alt_jump) \ + fixup_alt_jump = (fixup_alt_jump - old_buffer) + bufp->buffer; \ + if (laststart) \ + laststart = (laststart - old_buffer) + bufp->buffer; \ + if (pending_exact) \ + pending_exact = (pending_exact - old_buffer) + bufp->buffer; \ + } \ } while (0) @@ -1913,7 +2125,11 @@ /* Return, freeing storage we allocated. */ #define FREE_STACK_RETURN(value) \ - return (free (compile_stack.stack), value) +do \ +{ \ + xfree (compile_stack.stack); \ + return value; \ +} while (0) static reg_errcode_t regex_compile (re_char *pattern, int size, reg_syntax_t syntax, @@ -3216,7 +3432,7 @@ if (syntax & RE_NO_POSIX_BACKTRACKING) BUF_PUSH (succeed); - free (compile_stack.stack); + xfree (compile_stack.stack); /* We have succeeded; set the length of the buffer. */ bufp->used = buf_end - bufp->buffer; @@ -3243,7 +3459,6 @@ { fail_stack.size = (2 * re_max_failures * MAX_FAILURE_ITEMS); -#ifdef emacs if (! fail_stack.stack) fail_stack.stack = (fail_stack_elt_t *) xmalloc (fail_stack.size @@ -3253,17 +3468,6 @@ = (fail_stack_elt_t *) xrealloc (fail_stack.stack, (fail_stack.size * sizeof (fail_stack_elt_t))); -#else /* not emacs */ - if (! fail_stack.stack) - fail_stack.stack - = (fail_stack_elt_t *) malloc (fail_stack.size - * sizeof (fail_stack_elt_t)); - else - fail_stack.stack - = (fail_stack_elt_t *) realloc (fail_stack.stack, - (fail_stack.size - * sizeof (fail_stack_elt_t))); -#endif /* emacs */ } regex_grow_registers (num_regs); @@ -3549,6 +3753,13 @@ /* We aren't doing a `succeed_n' to begin with. */ re_bool succeed_n_p = false; +#ifdef ERROR_CHECK_MALLOC + /* The pattern comes from string data, not buffer data. We don't access + any buffer data, so we don't have to worry about malloc() (but the + disallowed flag may have been set by a caller). */ + int depth = bind_regex_malloc_disallowed (0); +#endif + assert (fastmap != NULL && p != NULL); INIT_FAIL_STACK (); @@ -3838,6 +4049,7 @@ case categoryspec: case notcategoryspec: bufp->can_be_null = 1; + UNBIND_REGEX_MALLOC_CHECK (); return 0; /* end if category patch */ #endif /* MULE */ @@ -3915,6 +4127,7 @@ if (!PUSH_PATTERN_OP (p + j, fail_stack)) { RESET_FAIL_STACK (); + UNBIND_REGEX_MALLOC_CHECK (); return -2; } } @@ -3976,6 +4189,7 @@ done: RESET_FAIL_STACK (); + UNBIND_REGEX_MALLOC_CHECK (); return 0; } /* re_compile_fastmap */ @@ -4072,6 +4286,9 @@ re_char *d; #ifdef emacs Internal_Format fmt = buffer_or_other_internal_format (lispobj); +#ifdef ERROR_CHECK_MALLOC + int depth; +#endif #endif /* emacs */ #if 1 int forward_search_p; @@ -4120,10 +4337,23 @@ } #endif /* emacs */ +#ifdef ERROR_CHECK_MALLOC + /* Do this after the above return()s. */ + depth = bind_regex_malloc_disallowed (1); +#endif + /* Update the fastmap now if not correct already. */ + BEGIN_REGEX_MALLOC_OK (); if (fastmap && !bufp->fastmap_accurate) if (re_compile_fastmap (bufp RE_LISP_SHORT_CONTEXT_ARGS) == -2) - return -2; + { + END_REGEX_MALLOC_OK (); + UNBIND_REGEX_MALLOC_CHECK (); + return -2; + } + + END_REGEX_MALLOC_OK (); + RE_SEARCH_RELOCATE_MOVEABLE_DATA_POINTERS (); #ifdef REGEX_BEGLINE_CHECK { @@ -4142,9 +4372,12 @@ #endif #ifdef emacs + BEGIN_REGEX_MALLOC_OK (); scache = setup_syntax_cache (scache, lispobj, lispbuf, offset_to_charxpos (lispobj, startpos), 1); + END_REGEX_MALLOC_OK (); + RE_SEARCH_RELOCATE_MOVEABLE_DATA_POINTERS (); #endif /* Loop through the string, looking for a place to start matching. */ @@ -4274,7 +4507,7 @@ INC_IBYTEPTR_FMT (d, fmt); range -= (d - old_d); #if 1 - assert (!forward_search_p || range >= 0); + assert (!forward_search_p || range >= 0); #endif } } @@ -4292,7 +4525,7 @@ INC_IBYTEPTR_FMT (d, fmt); range -= (d - old_d); #if 1 - assert (!forward_search_p || range >= 0); + assert (!forward_search_p || range >= 0); #endif } } @@ -4338,27 +4571,44 @@ /* If can't match the null string, and that's all we have left, fail. */ if (range >= 0 && startpos == total_size && fastmap && !bufp->can_be_null) - return -1; + { + UNBIND_REGEX_MALLOC_CHECK (); + return -1; + } #ifdef emacs /* XEmacs added, w/removal of immediate_quit */ if (!no_quit_in_re_search) - QUIT; + { + BEGIN_REGEX_MALLOC_OK (); + QUIT; + END_REGEX_MALLOC_OK (); + RE_SEARCH_RELOCATE_MOVEABLE_DATA_POINTERS (); + } + #endif + BEGIN_REGEX_MALLOC_OK (); val = re_match_2_internal (bufp, string1, size1, string2, size2, startpos, regs, stop RE_LISP_CONTEXT_ARGS); #ifndef REGEX_MALLOC -#ifdef C_ALLOCA - alloca (0); + ALLOCA_GARBAGE_COLLECT (); #endif -#endif + END_REGEX_MALLOC_OK (); + RE_SEARCH_RELOCATE_MOVEABLE_DATA_POINTERS (); if (val >= 0) - return startpos; + { + UNBIND_REGEX_MALLOC_CHECK (); + return startpos; + } if (val == -2) - return -2; - + { + UNBIND_REGEX_MALLOC_CHECK (); + return -2; + } + + RE_SEARCH_RELOCATE_MOVEABLE_DATA_POINTERS (); advance: if (!range) break; @@ -4390,6 +4640,7 @@ startpos -= d_size; } } + UNBIND_REGEX_MALLOC_CHECK (); return -1; } /* re_search_2 */ @@ -4442,6 +4693,7 @@ #define FREE_VAR(var) if (var) REGEX_FREE (var); var = NULL #define FREE_VARIABLES() \ do { \ + UNBIND_REGEX_MALLOC_CHECK (); \ REGEX_FREE_STACK (fail_stack.stack); \ FREE_VAR (regstart); \ FREE_VAR (regend); \ @@ -4454,7 +4706,10 @@ FREE_VAR (reg_info_dummy); \ } while (0) #else /* not MATCH_MAY_ALLOCATE */ -#define FREE_VARIABLES() ((void)0) /* Do nothing! But inhibit gcc warning. */ +#define FREE_VARIABLES() \ + do { \ + UNBIND_REGEX_MALLOC_CHECK (); \ + } while (0) #endif /* MATCH_MAY_ALLOCATE */ /* These values must meet several constraints. They must not be valid @@ -4480,7 +4735,7 @@ int result = re_match_2_internal (bufp, NULL, 0, (re_char *) string, size, pos, regs, size RE_LISP_CONTEXT_ARGS); - alloca (0); + ALLOCA_GARBAGE_COLLECT (); return result; } #endif /* not emacs */ @@ -4517,7 +4772,7 @@ pos, regs, stop RE_LISP_CONTEXT_ARGS); - alloca (0); + ALLOCA_GARBAGE_COLLECT (); return result; } @@ -4659,11 +4914,16 @@ #ifdef emacs Internal_Format fmt = buffer_or_other_internal_format (lispobj); +#ifdef ERROR_CHECK_MALLOC + int depth = bind_regex_malloc_disallowed (1); +#endif #endif /* emacs */ DEBUG_PRINT1 ("\n\nEntering re_match_2.\n"); + BEGIN_REGEX_MALLOC_OK (); INIT_FAIL_STACK (); + END_REGEX_MALLOC_OK (); #ifdef MATCH_MAY_ALLOCATE /* Do not bother to initialize all the register variables if there are @@ -4673,6 +4933,7 @@ array indexing. We should fix this. */ if (bufp->re_ngroups) { + BEGIN_REGEX_MALLOC_OK (); regstart = REGEX_TALLOC (num_regs, re_char *); regend = REGEX_TALLOC (num_regs, re_char *); old_regstart = REGEX_TALLOC (num_regs, re_char *); @@ -4682,6 +4943,7 @@ reg_info = REGEX_TALLOC (num_regs, register_info_type); reg_dummy = REGEX_TALLOC (num_regs, re_char *); reg_info_dummy = REGEX_TALLOC (num_regs, register_info_type); + END_REGEX_MALLOC_OK (); if (!(regstart && regend && old_regstart && old_regend && reg_info && best_regstart && best_regend && reg_dummy && reg_info_dummy)) @@ -4700,6 +4962,20 @@ } #endif /* MATCH_MAY_ALLOCATE */ +#if defined (emacs) && defined (REL_ALLOC) + { + /* If the allocations above (or the call to setup_syntax_cache() in + re_match_2) caused a rel-alloc relocation, then fix up the data + pointers */ + Bytecount offset = offset_post_relocation (lispobj, string1); + if (offset) + { + string1 += offset; + string2 += offset; + } + } +#endif /* defined (emacs) && defined (REL_ALLOC) */ + /* The starting position is bogus. */ if (pos < 0 || pos > size1 + size2) { @@ -4775,7 +5051,12 @@ DEBUG_PRINT2 ("\n0x%lx: ", (long) p); #ifdef emacs /* XEmacs added, w/removal of immediate_quit */ if (!no_quit_in_re_search) - QUIT; + { + BEGIN_REGEX_MALLOC_OK (); + QUIT; + END_REGEX_MALLOC_OK (); + RE_SEARCH_RELOCATE_MOVEABLE_DATA_POINTERS (); + } #endif if (p == pend) @@ -4857,8 +5138,11 @@ extra element beyond `num_regs' for the `-1' marker GNU code uses. */ regs->num_regs = MAX (RE_NREGS, num_nonshy_regs + 1); + BEGIN_REGEX_MALLOC_OK (); regs->start = TALLOC (regs->num_regs, regoff_t); regs->end = TALLOC (regs->num_regs, regoff_t); + END_REGEX_MALLOC_OK (); + RE_MATCH_RELOCATE_MOVEABLE_DATA_POINTERS (); if (regs->start == NULL || regs->end == NULL) { FREE_VARIABLES (); @@ -4873,8 +5157,11 @@ if (regs->num_regs < num_nonshy_regs + 1) { regs->num_regs = num_nonshy_regs + 1; + BEGIN_REGEX_MALLOC_OK (); RETALLOC (regs->start, regs->num_regs, regoff_t); RETALLOC (regs->end, regs->num_regs, regoff_t); + END_REGEX_MALLOC_OK (); + RE_MATCH_RELOCATE_MOVEABLE_DATA_POINTERS (); if (regs->start == NULL || regs->end == NULL) { FREE_VARIABLES (); @@ -5815,6 +6102,7 @@ #ifdef emacs pos_before = offset_to_charxpos (lispobj, PTR_TO_OFFSET (d)) - 1; + BEGIN_REGEX_MALLOC_OK (); UPDATE_SYNTAX_CACHE (scache, pos_before); #endif syn1 = SYNTAX_FROM_CACHE (scache, emch1); @@ -5824,6 +6112,8 @@ syn2 = SYNTAX_FROM_CACHE (scache, emch2); result = ((syn1 == Sword) != (syn2 == Sword)); + END_REGEX_MALLOC_OK (); + RE_MATCH_RELOCATE_MOVEABLE_DATA_POINTERS (); } if (result == should_succeed) break; @@ -5848,21 +6138,30 @@ */ re_char *dtmp = POS_AFTER_GAP_UNSAFE (d); Ichar emch = itext_ichar_fmt (dtmp, fmt, lispobj); + int tempres; + BEGIN_REGEX_MALLOC_OK (); #ifdef emacs Charxpos charpos = offset_to_charxpos (lispobj, PTR_TO_OFFSET (d)); UPDATE_SYNTAX_CACHE (scache, charpos); #endif - if (SYNTAX_FROM_CACHE (scache, emch) != Sword) + tempres = (SYNTAX_FROM_CACHE (scache, emch) != Sword); + END_REGEX_MALLOC_OK (); + RE_MATCH_RELOCATE_MOVEABLE_DATA_POINTERS (); + if (tempres) goto fail; if (AT_STRINGS_BEG (d)) break; dtmp = POS_BEFORE_GAP_UNSAFE (d); DEC_IBYTEPTR_FMT (dtmp, fmt); emch = itext_ichar_fmt (dtmp, fmt, lispobj); + BEGIN_REGEX_MALLOC_OK (); #ifdef emacs UPDATE_SYNTAX_CACHE_BACKWARD (scache, charpos - 1); #endif - if (SYNTAX_FROM_CACHE (scache, emch) != Sword) + tempres = (SYNTAX_FROM_CACHE (scache, emch) != Sword); + END_REGEX_MALLOC_OK (); + RE_MATCH_RELOCATE_MOVEABLE_DATA_POINTERS (); + if (tempres) break; goto fail; } @@ -5882,23 +6181,35 @@ */ re_char *dtmp; Ichar emch; + int tempres; + BEGIN_REGEX_MALLOC_OK (); #ifdef emacs Charxpos charpos = offset_to_charxpos (lispobj, PTR_TO_OFFSET (d)); UPDATE_SYNTAX_CACHE (scache, charpos); #endif + END_REGEX_MALLOC_OK (); + RE_MATCH_RELOCATE_MOVEABLE_DATA_POINTERS (); dtmp = POS_BEFORE_GAP_UNSAFE (d); DEC_IBYTEPTR_FMT (dtmp, fmt); emch = itext_ichar_fmt (dtmp, fmt, lispobj); - if (SYNTAX_FROM_CACHE (scache, emch) != Sword) + BEGIN_REGEX_MALLOC_OK (); + tempres = (SYNTAX_FROM_CACHE (scache, emch) != Sword); + END_REGEX_MALLOC_OK (); + RE_MATCH_RELOCATE_MOVEABLE_DATA_POINTERS (); + if (tempres) goto fail; if (AT_STRINGS_END (d)) break; dtmp = POS_AFTER_GAP_UNSAFE (d); emch = itext_ichar_fmt (dtmp, fmt, lispobj); + BEGIN_REGEX_MALLOC_OK (); #ifdef emacs UPDATE_SYNTAX_CACHE_FORWARD (scache, charpos + 1); #endif - if (SYNTAX_FROM_CACHE (scache, emch) != Sword) + tempres = (SYNTAX_FROM_CACHE (scache, emch) != Sword); + END_REGEX_MALLOC_OK (); + RE_MATCH_RELOCATE_MOVEABLE_DATA_POINTERS (); + if (tempres) break; goto fail; } @@ -5944,12 +6255,18 @@ Ichar emch; REGEX_PREFETCH (); + BEGIN_REGEX_MALLOC_OK (); UPDATE_SYNTAX_CACHE (scache, offset_to_charxpos (lispobj, PTR_TO_OFFSET (d))); + END_REGEX_MALLOC_OK (); + RE_MATCH_RELOCATE_MOVEABLE_DATA_POINTERS (); emch = itext_ichar_fmt (d, fmt, lispobj); + BEGIN_REGEX_MALLOC_OK (); matches = (SYNTAX_FROM_CACHE (scache, emch) == (enum syntaxcode) mcnt); + END_REGEX_MALLOC_OK (); + RE_MATCH_RELOCATE_MOVEABLE_DATA_POINTERS (); INC_IBYTEPTR_FMT (d, fmt); if (matches != should_succeed) goto fail; @@ -6074,7 +6391,7 @@ FREE_VARIABLES (); return -1; /* Failure to match. */ -} /* re_match_2 */ +} /* re_match_2_internal */ /* Subroutine definitions for re_match_2. */ @@ -6415,12 +6732,12 @@ if (!re_comp_buf.buffer) { - re_comp_buf.buffer = (unsigned char *) malloc (200); + re_comp_buf.buffer = (unsigned char *) xmalloc (200); if (re_comp_buf.buffer == NULL) return gettext (re_error_msgid[(int) REG_ESPACE]); re_comp_buf.allocated = 200; - re_comp_buf.fastmap = (char *) malloc (1 << BYTEWIDTH); + re_comp_buf.fastmap = (char *) xmalloc (1 << BYTEWIDTH); if (re_comp_buf.fastmap == NULL) return gettext (re_error_msgid[(int) REG_ESPACE]); } @@ -6514,7 +6831,7 @@ { int i; - preg->translate = (char *) malloc (CHAR_SET_SIZE); + preg->translate = (char *) xmalloc (CHAR_SET_SIZE); if (preg->translate == NULL) return (int) REG_ESPACE; @@ -6613,8 +6930,8 @@ } /* If we needed the temporary register info, free the space now. */ - free (regs.start); - free (regs.end); + xfree (regs.start); + xfree (regs.end); } /* We want zero return to mean success, unlike `re_search'. */ @@ -6666,19 +6983,19 @@ regfree (regex_t *preg) { if (preg->buffer != NULL) - free (preg->buffer); + xfree (preg->buffer); preg->buffer = NULL; preg->allocated = 0; preg->used = 0; if (preg->fastmap != NULL) - free (preg->fastmap); + xfree (preg->fastmap); preg->fastmap = NULL; preg->fastmap_accurate = 0; if (preg->translate != NULL) - free (preg->translate); + xfree (preg->translate); preg->translate = NULL; }
--- a/src/text.h Sun Mar 02 02:18:12 2003 +0000 +++ b/src/text.h Sun Mar 02 09:38:54 2003 +0000 @@ -490,7 +490,7 @@ #ifdef ERROR_CHECK_TEXT /* We use a separate definition to avoid warnings about unused dc_ptr1 */ #define DEC_IBYTEPTR(ptr) do { \ - const Ibyte *dc_ptr1 = (ptr); \ + const Ibyte *dc_ptr1 = (ptr); \ do { \ (ptr)--; \ } while (!valid_ibyteptr_p (ptr)); \ @@ -1880,7 +1880,7 @@ { \ if ((ei)->mallocp_) \ /* xrealloc always preserves existing data as much as possible */ \ - (ei)->data_ = (Ibyte *) xrealloc ((ei)->data_, ei1newsize); \ + (ei)->data_ = (Ibyte *) xrealloc ((ei)->data_, ei1newsize); \ else \ { \ /* We don't have realloc, so ALLOCA() more space and copy the \ @@ -1936,7 +1936,7 @@ do { \ Lisp_Object ei3 = (lisp_string); \ EI_ALLOC_AND_COPY (ei, XSTRING_DATA (ei3), XSTRING_LENGTH (ei3), \ - string_char_length (ei3)); \ + string_char_length (ei3)); \ } while (0) #define eicpy_lstr_off(ei, lisp_string, off, charoff, len, charlen) \ @@ -1958,7 +1958,7 @@ #define eicpy_raw_fmt(ei, ptr, len, fmt, object) \ do { \ - const Ibyte *ei12ptr = (ptr); \ + const Ibyte *ei12ptr = (ptr); \ Internal_Format ei12fmt = (fmt); \ int ei12len = (len); \ assert (ei12fmt == FORMAT_DEFAULT); \ @@ -1979,11 +1979,11 @@ #define eicpy_rawz(ei, ptr) eicpy_rawz_fmt (ei, ptr, FORMAT_DEFAULT, Qnil) -#define eicpy_ch(ei, ch) \ -do { \ +#define eicpy_ch(ei, ch) \ +do { \ Ibyte ei12p2[MAX_ICHAR_LEN]; \ Bytecount ei12p2len = set_itext_ichar (ei12p2, ch); \ - EI_ALLOC_AND_COPY (ei, ei12p2, ei12p2len, 1); \ + EI_ALLOC_AND_COPY (ei, ei12p2, ei12p2len, 1); \ } while (0) #define eicpy_c(ei, c_string) \ @@ -2244,7 +2244,7 @@ #define eicat_ch(ei, ch) \ do { \ - Ibyte ei22ch[MAX_ICHAR_LEN]; \ + Ibyte ei22ch[MAX_ICHAR_LEN]; \ Bytecount ei22len = set_itext_ichar (ei22ch, ch); \ eicat_1 (ei, ei22ch, ei22len, 1); \ } while (0) @@ -2285,7 +2285,7 @@ #define eisub_ei(ei, off, charoff, len, charlen, ei2) \ do { \ - const Eistring *ei19 = (ei2); \ + const Eistring *ei19 = (ei2); \ eisub_1 (ei, off, charoff, len, charlen, ei19->data_, ei19->bytelen_, \ ei19->charlen_); \ } while (0) @@ -2300,7 +2300,7 @@ #define eisub_ch(ei, off, charoff, len, charlen, ch) \ do { \ - Ibyte ei21ch[MAX_ICHAR_LEN]; \ + Ibyte ei21ch[MAX_ICHAR_LEN]; \ Bytecount ei21len = set_itext_ichar (ei21ch, ch); \ eisub_1 (ei, off, charoff, len, charlen, ei21ch, ei21len, 1); \ } while (0) @@ -2311,7 +2311,7 @@ /* ----- Converting to an external format ----- */ -#define eito_external(ei, codesys) \ +#define eito_external(ei, codesys) \ do { \ if ((ei)->mallocp_) \ { \ @@ -2322,7 +2322,7 @@ } \ TO_EXTERNAL_FORMAT (DATA, ((ei)->data_, (ei)->bytelen_), \ MALLOC, ((ei)->extdata_, (ei)->extlen_), \ - codesys); \ + codesys); \ } \ else \ TO_EXTERNAL_FORMAT (DATA, ((ei)->data_, (ei)->bytelen_), \ @@ -2432,15 +2432,15 @@ #define EI_CASECHANGE(ei, downp) \ do { \ int ei11new_allocmax = (ei)->charlen_ * MAX_ICHAR_LEN + 1; \ - Ibyte *ei11storage = \ - (Ibyte *) alloca_array (Ibyte, ei11new_allocmax); \ + Ibyte *ei11storage = \ + (Ibyte *) alloca_array (Ibyte, ei11new_allocmax); \ int ei11newlen = eistr_casefiddle_1 ((ei)->data_, (ei)->bytelen_, \ ei11storage, downp); \ \ if (ei11newlen) \ { \ (ei)->max_size_allocated_ = ei11new_allocmax; \ - (ei)->data_ = ei11storage; \ + (ei)->data_ = ei11storage; \ (ei)->bytelen_ = ei11newlen; \ /* charlen is the same. */ \ } \