diff options
Diffstat (limited to 'lisp')
39 files changed, 1757 insertions, 988 deletions
diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 2795cbf26d4..6f75d7141b2 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,154 @@ +2004-12-27 Richard M. Stallman <rms@gnu.org> + + * simple.el (undo): Fix previous change. + +2004-12-27 YAMAMOTO Mitsuharu <mituharu@math.s.chiba-u.ac.jp> + + * term/mac-win.el: Sync with x-win.el. Rearrange the contents. + Call mac-clear-font-name-table if invoked on Mac OS 8/9. Call + x-open-connection on Mac OS X. + +2004-12-27 Richard M. Stallman <rms@gnu.org> + + * files.el (buffer-save-without-query): New var (buffer-local). + (save-some-buffers): Save those buffers first, w/o asking. + + * files.el (insert-directory-ls-version): New variable. + (insert-directory): When ls returns an error, test the version + number to decide what the return code means. + With --dired output format, detect and distinguish lines + that are really error messages. + (insert-directory-adj-pos): New function. + + * bookmark.el (bookmark-jump): Nice error if BOOKMARK is nil. + + * battery.el (battery-mode-line-format): Remove initial spaces. + + * uniquify.el (uniquify-rationalize-file-buffer-names): + Delete interactive spec. + + * type-break.el (type-break-mode): Set buffer-save-without-query. + Remove code that tried to set save-some-buffers-always. + (type-break-file-keystroke-count): Bind deactivate-mark. + + * mouse.el (mouse-drag-region): Bind mouse-autoselect-window. + + * simple.el (next-error-buffer-p): New arg AVOID-CURRENT. + Test that the buffer is live, and maybe reject current buffer too. + Clarify. + (next-error-find-buffer): Rewrite for clarity. + + * loadup.el: Don't use buffer-disable-undo; do it directly. + + * help-fns.el (describe-function-1): Call symbol-file with `defun'. + (describe-variable): Call symbol-file with `defvar'. + + * subr.el (messages-buffer-max-lines): Alias for message-log-max. + (symbol-file): Rewritten to handle new load-history format. + Now takes an arg TYPE to specify looking for a particular + type of definition only. + + * emacs-lisp/debug.el (debugger-make-xrefs): + Call symbol-file with `defun'. + + * emacs-lisp/find-func.el (find-function-noselect): + Call symbol-file with `defun'. + (find-variable-noselect): Call symbol-file with `defvar'. + + * eshell/esh-cmd.el (eshell-find-alias-function): + Call symbol-file with `defun'. + + * eshell/esh-test.el (eshell-test-goto-func): + Call symbol-file with `defun'. + + * mail/rmail.el (rmail-resend): + Let MAIL-ALIAS-FILE arg override mail-personal-alias-file. + + * net/goto-addr.el (goto-address-mail-regexp): Allow = in username. + + * progmodes/compile.el (compilation-find-buffer): Rename arg. + + * textmodes/texinfmt.el (texinfo-format-buffer-1): + Call buffer-disable-undo. + + * simple.el (undo-list-saved): New variable (buffer-local). + (undo): Set and test it. + (buffer-disable-undo): Moved here from buffer.c. + Clear out undo-list-saved. + + * international/mule.el (decode-coding-inserted-region): + Set buffer-undo-list in a correct and optimal way. + + * progmodes/cperl-mode.el (cperl-find-bad-style): Use with-no-warnings. + (cperl-font-lock-unfontify-region-function): No need to save and + restore info, since font-lock.el does it for us. + + * ansi-color.el (save-buffer-state): Definition deleted. + (ansi-color-unfontify-region): Don't use save-buffer-state. + +2004-12-27 Dave Love <fx@gnu.org> + + * wid-edit.el (function): Use restricted-sexp as parent. + +2004-12-27 Kevin Ryde <user42@zip.com.au> + + * simple.el (next-matching-history-element): Use same + `interactive' form as previous-matching-history-element. + + * ffap.el (ffap-string-at-point-mode-alist): Add "*" to url chars, + it can appear unencoded and has been seen from yahoo. + +2004-12-27 Sergey Poznyakoff <gray@Mirddin.farlep.net> + + * mail/smtpmail.el (smtpmail-try-auth-methods): Send AUTH CRAM-MD5 + in upper case. Reported by Wojciech Polak <polak@gnu.org>. + +2004-12-27 Kenichi Handa <handa@m17n.org> + + * international/utf-8.el (utf-translate-cjk-load-tables): Bind + coding-system-for-read to nil while loading subst-*. + +2004-12-26 Jay Belanger <belanger@truman.edu> + + * calc/calc-store.el (calc-read-var-name): Remove "var-" from + default input. + +2004-12-26 Luc Teirlinck <teirllm@auburn.edu> + + * buff-menu.el (Buffer-menu-revert-function): Clear out undo info + before reverting and disable undo recording while reverting. + +2004-12-26 Thien-Thi Nguyen <ttn@gnu.org> + + * progmodes/hideshow.el (hs-set-up-overlay): New user var. + (hs-make-overlay): New function. + (hs-isearch-show-temporary): Handle `display' overlay prop specially. + (hs-flag-region): Delete function. + (hs-hide-comment-region): No longer use `hs-flag-region'. + Instead, use `hs-discard-overlays' and `hs-make-overlay'. + (hs-hide-block-at-point): Likewise. + (hs-hide-level-recursive): Use `hs-discard-overlays'. + (hs-hide-all, hs-show-all): Likewise. + (hs-show-block): Likewise. + Also, use overlay prop `hs-b-offset', not `hs-ofs'. + +2004-12-24 Thien-Thi Nguyen <ttn@gnu.org> + + * progmodes/hideshow.el: Require `cl' when compiling. + Remove XEmacs and Emacs 19 compatibility. + Use `dolist' and `add-to-list' for load-time actions. + (hs-discard-overlays): Use `dolist'. + (hs-show-block): Likewise. + +2004-12-23 Dan Nicolaescu <dann@ics.uci.edu> + + * faces.el (mode-line, mode-line-inactive): Use min-colors. + +2004-12-23 Thien-Thi Nguyen <ttn@gnu.org> + + * progmodes/hideshow.el (hs-inside-comment-p): Fix omission bug: + When extending backwards, move outside the current comment first. + 2004-12-22 Kenichi Handa <handa@m17n.org> * international/quail.el (quail-start-translation): Fix prompt @@ -23,21 +174,33 @@ (undo-outer-limit-function): Use undo-outer-limit-truncate. 2004-12-21 Eli Barzilay <eli@barzilay.org> - + * calculator.el: (calculator-radix-grouping-mode) (calculator-radix-grouping-digits) (calculator-radix-grouping-separator): New defcustoms for the new radix grouping mode functionality. - (calculator-mode-hook): Now used in electric mode too. + (calculator-mode-hook): Now used in electric mode too, + (calculator): Call it. (calculator-mode-map): Some new keys. (calculator-message): New function. Some new calls. - (calculator-string-to-number): New function, + (calculator-op, calculator-set-register): Use it. + (calculator-string-to-number): New function, mostly moved and + updated code from calculator-curnum-value. (calculator-curnum-value): Use it. - (calculator-rotate-displayer, calculator-rotate-displayer-back) - (calculator-displayer-prev, calculator-displayer-next): - Change digit group size when in radix mode. - (calculator-number-to-string): Renamed from calculator-num-to-string. - Now deals with digit grouping in radix mode. + (calculator-paste): Use it, and update grabbing the + current-kill. + (calculator-rotate-displayer) + (calculator-rotate-displayer-back): Toggle digit grouping when + in radix mode, use calculator-message. + (calculator-displayer-prev, calculator-displayer-next): Change + digit group size when in radix mode. + (calculator-number-to-string): Renamed from + calculator-num-to-string. Now deals with digit grouping in + radix mode. + (calculator-update-display, calculator-put-value): Use the new + name. + (calculator-fact): Return a floating point number. + (calculator-mode): Doc fix. 2004-12-20 Glenn Morris <gmorris@ast.cam.ac.uk> diff --git a/lisp/ansi-color.el b/lisp/ansi-color.el index 30350d69a9a..e505f91e901 100644 --- a/lisp/ansi-color.el +++ b/lisp/ansi-color.el @@ -220,23 +220,6 @@ This is a good function to put in `comint-output-filter-functions'." ;; Alternative font-lock-unfontify-region-function for Emacs only - -(eval-when-compile - ;; We use this to preserve or protect things when modifying text - ;; properties. Stolen from lazy-lock and font-lock. Ugly!!! - ;; Probably most of this is not needed? - (defmacro save-buffer-state (varlist &rest body) - "Bind variables according to VARLIST and eval BODY restoring buffer state." - `(let* (,@(append varlist - '((modified (buffer-modified-p)) (buffer-undo-list t) - (inhibit-read-only t) (inhibit-point-motion-hooks t) - before-change-functions after-change-functions - deactivate-mark buffer-file-name buffer-file-truename))) - ,@body - (when (and (not modified) (buffer-modified-p)) - (set-buffer-modified-p nil)))) - (put 'save-buffer-state 'lisp-indent-function 1)) - (defun ansi-color-unfontify-region (beg end &rest xemacs-stuff) "Replacement function for `font-lock-default-unfontify-region'. @@ -259,21 +242,20 @@ A possible way to install this would be: \(function (lambda () \(setq font-lock-unfontify-region-function 'ansi-color-unfontify-region))))" - ;; save-buffer-state is a macro in font-lock.el! - (save-buffer-state nil - (when (boundp 'font-lock-syntactic-keywords) - (remove-text-properties beg end '(syntax-table nil))) - ;; instead of just using (remove-text-properties beg end '(face - ;; nil)), we find regions with a non-nil face test-property, skip - ;; positions with the ansi-color property set, and remove the - ;; remaining face test-properties. - (while (setq beg (text-property-not-all beg end 'face nil)) - (setq beg (or (text-property-not-all beg end 'ansi-color t) end)) - (when (get-text-property beg 'face) - (let ((end-face (or (text-property-any beg end 'face nil) - end))) - (remove-text-properties beg end-face '(face nil)) - (setq beg end-face)))))) + ;; Simplified now that font-lock-unfontify-region uses save-buffer-state. + (when (boundp 'font-lock-syntactic-keywords) + (remove-text-properties beg end '(syntax-table nil))) + ;; instead of just using (remove-text-properties beg end '(face + ;; nil)), we find regions with a non-nil face test-property, skip + ;; positions with the ansi-color property set, and remove the + ;; remaining face test-properties. + (while (setq beg (text-property-not-all beg end 'face nil)) + (setq beg (or (text-property-not-all beg end 'ansi-color t) end)) + (when (get-text-property beg 'face) + (let ((end-face (or (text-property-any beg end 'face nil) + end))) + (remove-text-properties beg end-face '(face nil)) + (setq beg end-face))))) ;; Working with strings diff --git a/lisp/battery.el b/lisp/battery.el index 7b172321602..b8790450735 100644 --- a/lisp/battery.el +++ b/lisp/battery.el @@ -73,12 +73,13 @@ string are substituted as defined by the current value of the variable (defvar battery-mode-line-string nil "String to display in the mode line.") +;;;###autoload (put 'battery-mode-line-string 'risky-local-variable t) (defcustom battery-mode-line-format (cond ((eq battery-status-function 'battery-linux-proc-apm) - " [%b%p%%]") + "[%b%p%%]") ((eq battery-status-function 'battery-linux-proc-acpi) - " [%b%p%%,%d°C]")) + "[%b%p%%,%d°C]")) "*Control string formatting the string to display in the mode line. Ordinary characters in the control string are printed as-is, while conversion specifications introduced by a `%' character in the control @@ -128,13 +129,14 @@ seconds." (defun battery-update () "Update battery status information in the mode line." - (setq battery-mode-line-string (propertize (if (and battery-mode-line-format - battery-status-function) - (battery-format - battery-mode-line-format - (funcall battery-status-function)) - "") - 'help-echo "Battery status information")) + (setq battery-mode-line-string + (propertize (if (and battery-mode-line-format + battery-status-function) + (battery-format + battery-mode-line-format + (funcall battery-status-function)) + "") + 'help-echo "Battery status information")) (force-mode-line-update)) diff --git a/lisp/bookmark.el b/lisp/bookmark.el index b25c261c1e7..949434baffb 100644 --- a/lisp/bookmark.el +++ b/lisp/bookmark.el @@ -1049,6 +1049,8 @@ of the old one in the permanent bookmark record." (interactive (list (bookmark-completing-read "Jump to bookmark" bookmark-current-bookmark))) + (unless bookmark + (error "No bookmark specified")) (bookmark-maybe-historicize-string bookmark) (let ((cell (bookmark-jump-noselect bookmark))) (and cell diff --git a/lisp/buff-menu.el b/lisp/buff-menu.el index 1c3fa704041..8e1a3e69295 100644 --- a/lisp/buff-menu.el +++ b/lisp/buff-menu.el @@ -198,11 +198,15 @@ Letters do not insert themselves; instead, they are commands. (revert-buffer)) (defun Buffer-menu-revert-function (ignore1 ignore2) + (or (eq buffer-undo-list t) + (setq buffer-undo-list nil)) ;; We can not use save-excursion here. The buffer gets erased. (let ((ocol (current-column)) (oline (progn (move-to-column 4) (get-text-property (point) 'buffer))) - (prop (point-min))) + (prop (point-min)) + ;; do not make undo records for the reversion. + (buffer-undo-list t)) (list-buffers-noselect Buffer-menu-files-only) (while (setq prop (next-single-property-change prop 'buffer)) (when (eq (get-text-property prop 'buffer) oline) diff --git a/lisp/calc/calc-store.el b/lisp/calc/calc-store.el index 2dca53b46bb..a3c401e734e 100644 --- a/lisp/calc/calc-store.el +++ b/lisp/calc/calc-store.el @@ -174,13 +174,17 @@ (defun calc-read-var-name (prompt &optional calc-store-opers) (setq calc-given-value nil calc-aborted-prefix nil) - (let ((var (let ((minibuffer-completion-table obarray) - (minibuffer-completion-predicate 'boundp) - (minibuffer-completion-confirm t)) - (read-from-minibuffer prompt "var-" calc-var-name-map nil)))) + (let ((var (concat + "var-" + (let ((minibuffer-completion-table + (mapcar (lambda (x) (substring x 4)) + (all-completions "var-" obarray))) + (minibuffer-completion-predicate + (lambda (x) (boundp (intern (concat "var-" x))))) + (minibuffer-completion-confirm t)) + (read-from-minibuffer prompt nil calc-var-name-map nil))))) (setq calc-aborted-prefix "") - (and (not (equal var "")) - (not (equal var "var-")) + (and (not (equal var "var-")) (if (string-match "\\`\\([-a-zA-Z0-9]+\\) *:?=" var) (if (null calc-given-value-flag) (error "Assignment is not allowed in this command") diff --git a/lisp/emacs-lisp/debug.el b/lisp/emacs-lisp/debug.el index 6e10b596e23..a84a7aca52c 100644 --- a/lisp/emacs-lisp/debug.el +++ b/lisp/emacs-lisp/debug.el @@ -352,7 +352,7 @@ That buffer should be current already." (end (progn (skip-syntax-forward "w_") (point))) (sym (intern-soft (buffer-substring-no-properties beg end))) - (file (and sym (symbol-file sym)))) + (file (and sym (symbol-file sym 'defun)))) (when file (goto-char beg) ;; help-xref-button needs to operate on something matched diff --git a/lisp/emacs-lisp/find-func.el b/lisp/emacs-lisp/find-func.el index 2a58c10f827..a70adb4d423 100644 --- a/lisp/emacs-lisp/find-func.el +++ b/lisp/emacs-lisp/find-func.el @@ -242,7 +242,7 @@ in `load-path'." (let ((library (cond ((eq (car-safe def) 'autoload) (nth 1 def)) - ((symbol-file function))))) + ((symbol-file function 'defun))))) (find-function-search-for-symbol function nil library)))) (defalias 'function-at-point 'function-called-at-point) @@ -347,8 +347,7 @@ The library where VARIABLE is defined is searched for in FILE or `find-function-source-path', if non nil, otherwise in `load-path'." (if (not variable) (error "You didn't specify a variable")) - ;; Fixme: I think `symbol-file' should be fixed instead. -- fx - (let ((library (or file (symbol-file (cons 'defvar variable))))) + (let ((library (or file (symbol-file variable 'defvar)))) (find-function-search-for-symbol variable 'variable library))) ;;;###autoload diff --git a/lisp/eshell/esh-cmd.el b/lisp/eshell/esh-cmd.el index 477d8b410ec..d7c65066ac6 100644 --- a/lisp/eshell/esh-cmd.el +++ b/lisp/eshell/esh-cmd.el @@ -1285,7 +1285,7 @@ COMMAND may result in an alias being executed, or a plain command." (defun eshell-find-alias-function (name) "Check whether a function called `eshell/NAME' exists." (let* ((sym (intern-soft (concat "eshell/" name))) - (file (symbol-file sym))) + (file (symbol-file sym 'defun))) ;; If the function exists, but is defined in an eshell module ;; that's not currently enabled, don't report it as found (if (and file diff --git a/lisp/eshell/esh-test.el b/lisp/eshell/esh-test.el index 076505da14e..c1b121bbf73 100644 --- a/lisp/eshell/esh-test.el +++ b/lisp/eshell/esh-test.el @@ -125,7 +125,7 @@ (let ((fsym (get-text-property (point) 'test-func))) (when fsym (let* ((def (symbol-function fsym)) - (library (locate-library (symbol-file fsym))) + (library (locate-library (symbol-file fsym 'defun))) (name (substring (symbol-name fsym) (length "eshell-test--"))) (inhibit-redisplay t)) diff --git a/lisp/faces.el b/lisp/faces.el index a9189d5f8f6..f3d211d60fd 100644 --- a/lisp/faces.el +++ b/lisp/faces.el @@ -1813,7 +1813,7 @@ created." (defface mode-line - '((((type x w32 mac) (class color)) + '((((class color) (min-colors 88)) :box (:line-width -1 :style released-button) :background "grey75" :foreground "black") (t @@ -1826,11 +1826,11 @@ created." (defface mode-line-inactive '((default :inherit mode-line) - (((type x w32 mac) (background light) (class color)) + (((class color) (min-colors 88) (background light)) :weight light :box (:line-width -1 :color "grey75" :style nil) :foreground "grey20" :background "grey90") - (((type x w32 mac) (background dark) (class color)) + (((class color) (min-colors 88) (background dark) ) :weight light :box (:line-width -1 :color "grey40" :style nil) :foreground "grey80" :background "grey30")) diff --git a/lisp/ffap.el b/lisp/ffap.el index ab9d223256f..c36ed7ff81f 100644 --- a/lisp/ffap.el +++ b/lisp/ffap.el @@ -962,7 +962,7 @@ If t, `ffap-tex-init' will initialize this when needed.") ;; * no commas (good for latex) (file "--:$+<>@-Z_a-z~*?" "<@" "@>;.,!:") ;; An url, or maybe a email/news message-id: - (url "--:=&?$+@-Z_a-z~#,%;" "^A-Za-z0-9" ":;.,!?") + (url "--:=&?$+@-Z_a-z~#,%;*" "^A-Za-z0-9" ":;.,!?") ;; Find a string that does *not* contain a colon: (nocolon "--9$+<>@-Z_a-z~" "<@" "@>;.,!?") ;; A machine: diff --git a/lisp/files.el b/lisp/files.el index 0c7a6fff51b..12f7e390f81 100644 --- a/lisp/files.el +++ b/lisp/files.el @@ -1200,7 +1200,8 @@ name to this list as a string." "Return the buffer visiting file FILENAME (a string). This is like `get-file-buffer', except that it checks for any buffer visiting the same file, possibly under a different name. -If PREDICATE is non-nil, only a buffer satisfying it can be returned. +If PREDICATE is non-nil, only buffers satisfying it are eligible, +and others are ignored. If there is no such live buffer, return nil." (let ((predicate (or predicate #'identity)) (truename (abbreviate-file-name (file-truename filename)))) @@ -3363,6 +3364,10 @@ This requires the external program `diff' to be in your `exec-path'." "ACTION-ALIST argument used in call to `map-y-or-n-p'.") (put 'save-some-buffers-action-alist 'risky-local-variable t) +(defvar buffer-save-without-query nil + "Non-nil means `save-some-buffers' should save this buffer without asking.") +(make-variable-buffer-local 'buffer-save-without-query) + (defun save-some-buffers (&optional arg pred) "Save some modified file-visiting buffers. Asks user about each one. You can answer `y' to save, `n' not to save, `C-r' to look at the @@ -3380,8 +3385,18 @@ See `save-some-buffers-action-alist' if you want to change the additional actions you can take on files." (interactive "P") (save-window-excursion - (let* ((queried nil) - (files-done + (let* (queried some-automatic + files-done abbrevs-done) + (dolist (buffer (buffer-list)) + ;; First save any buffers that we're supposed to save unconditionally. + ;; That way the following code won't ask about them. + (with-current-buffer buffer + (when (and buffer-save-without-query (buffer-modified-p)) + (setq some-automatic t) + (save-buffer)))) + ;; Ask about those buffers that merit it, + ;; and record the number thus saved. + (setq files-done (map-y-or-n-p (function (lambda (buffer) @@ -3410,19 +3425,22 @@ change the additional actions you can take on files." (buffer-list) '("buffer" "buffers" "save") save-some-buffers-action-alist)) - (abbrevs-done - (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. - (setq abbrevs-changed nil) - t)))) + ;; Maybe to save abbrevs, and record whether + ;; we either saved them or asked to. + (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. + (setq abbrevs-changed nil) + (setq abbrevs-done t))) (or queried (> files-done 0) abbrevs-done - (message "(No files need saving)"))))) + (message (if some-automatic + "(Some special files were saved without asking)" + "(No files need saving)")))))) (defun not-modified (&optional arg) "Mark current buffer as unmodified, not needing to be saved. @@ -4309,6 +4327,8 @@ program specified by `directory-free-space-program' if that is non-nil." (buffer-substring (point) end))))))))) +(defvar insert-directory-ls-version 'unknown) + ;; insert-directory ;; - must insert _exactly_one_line_ describing FILE if WILDCARD and ;; FULL-DIRECTORY-P is nil. @@ -4418,6 +4438,56 @@ normally equivalent short `-D' option is just passed on to (concat (file-name-as-directory file) ".") file)))))))) + ;; If we got "//DIRED//" in the output, it means we got a real + ;; directory listing, even if `ls' returned nonzero. + ;; So ignore any errors. + (when (if (stringp switches) + (string-match "--dired\\>" switches) + (member "--dired" switches)) + (save-excursion + (forward-line -2) + (when (looking-at "//SUBDIRED//") + (forward-line -1)) + (if (looking-at "//DIRED//") + (setq result 0)))) + + (when (and (not (eq 0 result)) + (eq insert-directory-ls-version 'unknown)) + ;; The first time ls returns an error, + ;; find the version numbers of ls, + ;; and set insert-directory-ls-version + ;; to > if it is more than 5.2.1, < if it is less, nil if it + ;; is equal or if the info cannot be obtained. + ;; (That can mean it isn't GNU ls.) + (let ((version-out + (with-temp-buffer + (call-process "ls" nil t nil "--version") + (buffer-string)))) + (if (string-match "ls (.*utils) \\([0-9.]*\\)$" version-out) + (let* ((version (match-string 1 version-out)) + (split (split-string version "[.]")) + (numbers (mapcar 'string-to-int split)) + (min '(5 2 1)) + comparison) + (while (and (not comparison) (or numbers min)) + (cond ((null min) + (setq comparison '>)) + ((null numbers) + (setq comparison '<)) + ((> (car numbers) (car min)) + (setq comparison '>)) + ((< (car numbers) (car min)) + (setq comparison '<)) + (t + (setq numbers (cdr numbers) + min (cdr min))))) + (setq insert-directory-ls-version (or comparison '=))) + (setq insert-directory-ls-version nil)))) + + ;; For GNU ls versions 5.2.2 and up, ignore minor errors. + (when (and (eq 1 result) (eq insert-directory-ls-version '>)) + (setq result 0)) + ;; If `insert-directory-program' failed, signal an error. (unless (eq 0 result) ;; Delete the error message it may have output. @@ -4444,23 +4514,39 @@ normally equivalent short `-D' option is just passed on to (when (looking-at "//SUBDIRED//") (delete-region (point) (progn (forward-line 1) (point))) (forward-line -1)) - (if (looking-at "//DIRED//") - (let ((end (line-end-position))) - (forward-word 1) - (forward-char 3) - (while (< (point) end) - (let ((start (+ beg (read (current-buffer)))) - (end (+ beg (read (current-buffer))))) - (if (memq (char-after end) '(?\n ?\ )) - ;; End is followed by \n or by " -> ". - (put-text-property start end 'dired-filename t) - ;; It seems that we can't trust ls's output as to - ;; byte positions of filenames. - (put-text-property beg (point) 'dired-filename nil) - (end-of-line)))) - (goto-char end) - (beginning-of-line) - (delete-region (point) (progn (forward-line 2) (point)))) + (when (looking-at "//DIRED//") + (let ((end (line-end-position)) + (linebeg (point)) + error-lines) + ;; Find all the lines that are error messages, + ;; and record the bounds of each one. + (goto-char (point-min)) + (while (< (point) linebeg) + (or (eql (following-char) ?\s) + (push (list (point) (line-end-position)) error-lines)) + (forward-line 1)) + (setq error-lines (nreverse error-lines)) + ;; Now read the numeric positions of file names. + (goto-char linebeg) + (forward-word 1) + (forward-char 3) + (while (< (point) end) + (let ((start (insert-directory-adj-pos + (+ beg (read (current-buffer))) + error-lines)) + (end (insert-directory-adj-pos + (+ beg (read (current-buffer))) + error-lines))) + (if (memq (char-after end) '(?\n ?\ )) + ;; End is followed by \n or by " -> ". + (put-text-property start end 'dired-filename t) + ;; It seems that we can't trust ls's output as to + ;; byte positions of filenames. + (put-text-property beg (point) 'dired-filename nil) + (end-of-line)))) + (goto-char end) + (beginning-of-line) + (delete-region (point) (progn (forward-line 2) (point)))) (forward-line 1) (if (looking-at "//DIRED-OPTIONS//") (delete-region (point) (progn (forward-line 1) (point))) @@ -4512,6 +4598,18 @@ normally equivalent short `-D' option is just passed on to (end-of-line) (insert " available " available))))))))))) +(defun insert-directory-adj-pos (pos error-lines) + "Convert `ls --dired' file name position value POS to a buffer position. +File name position values returned in ls --dired output +count only stdout; they don't count the error messages sent to stderr. +So this function converts to them to real buffer positions. +ERROR-LINES is a list of buffer positions of error message lines, +of the form (START END)." + (while (and error-lines (< (caar error-lines) pos)) + (setq pos (+ pos (- (nth 1 (car error-lines)) (nth 0 (car error-lines))))) + (pop error-lines)) + pos) + (defun insert-directory-safely (file switches &optional wildcard full-directory-p) "Insert directory listing for FILE, formatted according to SWITCHES. diff --git a/lisp/gnus/ChangeLog b/lisp/gnus/ChangeLog index bb7b8337f4c..fd541fed5aa 100644 --- a/lisp/gnus/ChangeLog +++ b/lisp/gnus/ChangeLog @@ -4,6 +4,35 @@ * gnus-sum.el (gnus-summary-mode-map): Likewise. +2004-12-22 Katsumi Yamaoka <yamaoka@jpl.org> + + * gnus-spec.el (gnus-spec-tab): Make a Lisp form which works + correctly even if there are wide characters. + +2004-12-21 Katsumi Yamaoka <yamaoka@jpl.org> + + * rfc2231.el (rfc2231-parse-string): Decode encoded value after + concatenating segments rather than before concatenating them. + Suggested by ARISAWA Akihiro <ari@mbf.ocn.ne.jp>. + +2004-12-17 Katsumi Yamaoka <yamaoka@jpl.org> + + * mm-util.el (mm-xemacs-find-mime-charset): New macro. + +2004-12-17 Aidan Kehoe <kehoea@parhasard.net> + + * mm-util.el (mm-xemacs-find-mime-charset-1): New function used to + unify Latin characters in XEmacs. + (mm-find-mime-charset-region): Use it. + +2004-12-17 Katsumi Yamaoka <yamaoka@jpl.org> + + * gnus-util.el (gnus-delete-directory): New function. + + * gnus-agent.el (gnus-agent-delete-group): Use it. + + * gnus-cache.el (gnus-cache-delete-group): Use it. + 2004-12-08 Stefan Monnier <monnier@iro.umontreal.ca> * gnus-art.el (gnus-narrow-to-page): Don't hardcode point-min. diff --git a/lisp/gnus/gnus-agent.el b/lisp/gnus/gnus-agent.el index 23fcbbde5df..aca9e4ec218 100644 --- a/lisp/gnus/gnus-agent.el +++ b/lisp/gnus/gnus-agent.el @@ -891,7 +891,7 @@ next enabled. Depends upon the caller to determine whether group deletion is sup (path (directory-file-name (let (gnus-command-method command-method) (gnus-agent-group-pathname group))))) - (gnus-delete-file path) + (gnus-delete-directory path) (let* ((real-group (gnus-group-real-name group))) (gnus-agent-save-group-info command-method real-group nil) diff --git a/lisp/gnus/gnus-cache.el b/lisp/gnus/gnus-cache.el index f0a5aa318fd..8f2b491f5a4 100644 --- a/lisp/gnus/gnus-cache.el +++ b/lisp/gnus/gnus-cache.el @@ -754,7 +754,7 @@ next enabled. Depends upon the caller to determine whether group renaming is sup disabled, as the old cache files would corrupt gnus when the cache was next enabled. Depends upon the caller to determine whether group deletion is supported." (let ((dir (gnus-cache-file-name group ""))) - (gnus-delete-file dir)) + (gnus-delete-directory dir)) (let ((no-save gnus-cache-active-hashtb)) (unless gnus-cache-active-hashtb diff --git a/lisp/gnus/gnus-spec.el b/lisp/gnus/gnus-spec.el index 1177df4731a..9eeedf40cae 100644 --- a/lisp/gnus/gnus-spec.el +++ b/lisp/gnus/gnus-spec.el @@ -275,21 +275,15 @@ Return a list of updated types." (defun gnus-spec-tab (column) (if (> column 0) - `(insert (make-string (max (- ,column (current-column)) 0) ? )) + `(insert-char ? (max (- ,column (current-column)) 0)) (let ((column (abs column))) - (if gnus-use-correct-string-widths - `(progn - (if (> (current-column) ,column) - (while (progn - (delete-backward-char 1) - (> (current-column) ,column)))) - (insert (make-string (max (- ,column (current-column)) 0) ? ))) - `(progn - (if (> (current-column) ,column) - (delete-region (point) - (- (point) (- (current-column) ,column))) - (insert (make-string (max (- ,column (current-column)) 0) - ? )))))))) + `(if (> (current-column) ,column) + (let ((end (point))) + (if (= (move-to-column ,column) ,column) + (delete-region (point) end) + (delete-region (1- (point)) end) + (insert " "))) + (insert-char ? (max (- ,column (current-column)) 0)))))) (defun gnus-correct-length (string) "Return the correct width of STRING." diff --git a/lisp/gnus/gnus-util.el b/lisp/gnus/gnus-util.el index d9952fd8cdc..91e087f05d5 100644 --- a/lisp/gnus/gnus-util.el +++ b/lisp/gnus/gnus-util.el @@ -708,6 +708,23 @@ Bind `print-quoted' and `print-readably' to t, and `print-length' and (when (file-exists-p file) (delete-file file))) +(defun gnus-delete-directory (directory) + "Delete files in DIRECTORY. Subdirectories remain. +If there's no subdirectory, delete DIRECTORY as well." + (when (file-directory-p directory) + (let ((files (directory-files + directory t "^\\([^.]\\|\\.\\([^.]\\|\\..\\)\\).*")) + file dir) + (while files + (setq file (pop files)) + (if (eq t (car (file-attributes file))) + ;; `file' is a subdirectory. + (setq dir t) + ;; `file' is a file or a symlink. + (delete-file file))) + (unless dir + (delete-directory directory))))) + (defun gnus-strip-whitespace (string) "Return STRING stripped of all whitespace." (while (string-match "[\r\n\t ]+" string) diff --git a/lisp/gnus/mm-util.el b/lisp/gnus/mm-util.el index 382133a027e..c0ccaa316ba 100644 --- a/lisp/gnus/mm-util.el +++ b/lisp/gnus/mm-util.el @@ -576,6 +576,83 @@ This affects whether coding conversion should be attempted generally." (length (memq (coding-system-base b) priorities))) t)))) +(eval-when-compile + (autoload 'latin-unity-massage-name "latin-unity") + (autoload 'latin-unity-maybe-remap "latin-unity") + (autoload 'latin-unity-representations-feasible-region "latin-unity") + (autoload 'latin-unity-representations-present-region "latin-unity") + (defvar latin-unity-coding-systems) + (defvar latin-unity-ucs-list)) + +(defun mm-xemacs-find-mime-charset-1 (begin end) + "Determine which MIME charset to use to send region as message. +This uses the XEmacs-specific latin-unity package to better handle the +case where identical characters from diverse ISO-8859-? character sets +can be encoded using a single one of the corresponding coding systems. + +It treats `mm-coding-system-priorities' as the list of preferred +coding systems; a useful example setting for this list in Western +Europe would be '(iso-8859-1 iso-8859-15 utf-8), which would default +to the very standard Latin 1 coding system, and only move to coding +systems that are less supported as is necessary to encode the +characters that exist in the buffer. + +Latin Unity doesn't know about those non-ASCII Roman characters that +are available in various East Asian character sets. As such, its +behavior if you have a JIS 0212 LATIN SMALL LETTER A WITH ACUTE in a +buffer and it can otherwise be encoded as Latin 1, won't be ideal. +But this is very much a corner case, so don't worry about it." + (let ((systems mm-coding-system-priorities) csets psets curset) + + ;; Load the Latin Unity library, if available. + (when (and (not (featurep 'latin-unity)) (locate-library "latin-unity")) + (require 'latin-unity)) + + ;; Now, can we use it? + (if (featurep 'latin-unity) + (progn + (setq csets (latin-unity-representations-feasible-region begin end) + psets (latin-unity-representations-present-region begin end)) + + (catch 'done + + ;; Pass back the first coding system in the preferred list + ;; that can encode the whole region. + (dolist (curset systems) + (setq curset (latin-unity-massage-name 'buffer-default curset)) + + ;; If the coding system is a universal coding system, then + ;; it can certainly encode all the characters in the region. + (if (memq curset latin-unity-ucs-list) + (throw 'done (list curset))) + + ;; If a coding system isn't universal, and isn't in + ;; the list that latin unity knows about, we can't + ;; decide whether to use it here. Leave that until later + ;; in `mm-find-mime-charset-region' function, whence we + ;; have been called. + (unless (memq curset latin-unity-coding-systems) + (throw 'done nil)) + + ;; Right, we know about this coding system, and it may + ;; conceivably be able to encode all the characters in + ;; the region. + (if (latin-unity-maybe-remap begin end curset csets psets t) + (throw 'done (list curset)))) + + ;; Can't encode using anything from the + ;; `mm-coding-system-priorities' list. + ;; Leave `mm-find-mime-charset' to do most of the work. + nil)) + + ;; Right, latin unity isn't available; let `mm-find-charset-region' + ;; take its default action, which equally applies to GNU Emacs. + nil))) + +(defmacro mm-xemacs-find-mime-charset (begin end) + (when (featurep 'xemacs) + `(mm-xemacs-find-mime-charset-1 ,begin ,end))) + (defun mm-find-mime-charset-region (b e &optional hack-charsets) "Return the MIME charsets needed to encode the region between B and E. nil means ASCII, a single-element list represents an appropriate MIME @@ -617,8 +694,12 @@ charset, and a longer list means no appropriate charset." (setq systems nil charsets (list cs)))))) charsets)) - ;; Otherwise we're not multibyte, we're XEmacs, or a single - ;; coding system won't cover it. + ;; If we're XEmacs, and some coding system is appropriate, + ;; mm-xemacs-find-mime-charset will return an appropriate list. + ;; Otherwise, we'll get nil, and the next setq will get invoked. + (setq charsets (mm-xemacs-find-mime-charset b e)) + + ;; We're not multibyte, or a single coding system won't cover it. (setq charsets (mm-delete-duplicates (mapcar 'mm-mime-charset diff --git a/lisp/gnus/rfc2231.el b/lisp/gnus/rfc2231.el index b08fe215196..8a20e19e8ad 100644 --- a/lisp/gnus/rfc2231.el +++ b/lisp/gnus/rfc2231.el @@ -88,7 +88,6 @@ The list will be on the form (point) (progn (forward-sexp 1) (point)))))) (error "Invalid header: %s" string)) (setq c (char-after)) - (setq encoded nil) (when (eq c ?*) (forward-char 1) (setq c (char-after)) @@ -126,16 +125,22 @@ The list will be on the form (point) (progn (forward-sexp) (point))))) (t (error "Invalid header: %s" string))) - (when encoded - (setq value (rfc2231-decode-encoded-string value))) (if number (setq prev-attribute attribute prev-value (concat prev-value value)) - (push (cons attribute value) parameters)))) + (push (cons attribute + (if encoded + (rfc2231-decode-encoded-string value) + value)) + parameters)))) ;; Take care of any final continuations. (when prev-attribute - (push (cons prev-attribute prev-value) parameters)) + (push (cons prev-attribute + (if encoded + (rfc2231-decode-encoded-string prev-value) + prev-value)) + parameters)) (when type `(,type ,@(nreverse parameters))))))) diff --git a/lisp/help-fns.el b/lisp/help-fns.el index f799fbd9be7..522c1e2c19d 100644 --- a/lisp/help-fns.el +++ b/lisp/help-fns.el @@ -355,7 +355,7 @@ face (according to `face-differs-from-default-p')." (if (re-search-backward "alias for `\\([^`']+\\)'" nil t) (help-xref-button 1 'help-function def))))) (or file-name - (setq file-name (symbol-file function))) + (setq file-name (symbol-file function 'defun))) (when (equal file-name "loaddefs.el") ;; Find the real def site of the preloaded function. ;; This is necessary only for defaliases. @@ -614,7 +614,7 @@ it is displayed along with the global value." ;; Make a hyperlink to the library if appropriate. (Don't ;; change the format of the buffer's initial line in case ;; anything expects the current format.) - (let ((file-name (symbol-file (cons 'defvar variable)))) + (let ((file-name (symbol-file variable 'defvar))) (when (equal file-name "loaddefs.el") ;; Find the real def site of the preloaded variable. (let ((location diff --git a/lisp/hexl.el b/lisp/hexl.el index f5b83c0afde..af996940f86 100644 --- a/lisp/hexl.el +++ b/lisp/hexl.el @@ -111,11 +111,19 @@ Quoting cannot be used, so the arguments cannot themselves contain spaces." (defvar hexl-mode-old-isearch-search-fun-function) (defvar hexl-mode-old-require-final-newline) (defvar hexl-mode-old-syntax-table) +(defvar hexl-mode-old-font-lock-keywords) (defvar hexl-ascii-overlay nil "Overlay used to highlight ASCII element corresponding to current point.") (make-variable-buffer-local 'hexl-ascii-overlay) +(defvar hexl-font-lock-keywords + '(("^\\([0-9a-f]+:\\).\\{40\\} \\(.+$\\)" + ;; "^\\([0-9a-f]+:\\).+ \\(.+$\\)" + (1 'hexl-address-area t t) + (2 'hexl-ascii-area t t))) + "Font lock keywords used in `hexl-mode'.") + ;; routines (put 'hexl-mode 'mode-class 'special) @@ -265,6 +273,11 @@ You can use \\[hexl-find-file] to visit a file in Hexl mode. (make-local-variable 'require-final-newline) (setq require-final-newline nil) + (make-local-variable 'hexl-mode-old-font-lock-keywords) + (setq hexl-mode-old-font-lock-keywords font-lock-defaults) + (make-local-variable 'font-lock-defaults) + (setq font-lock-defaults '(hexl-font-lock-keywords t)) + ;; Add hooks to rehexlify or dehexlify on various events. (add-hook 'after-revert-hook 'hexl-after-revert-hook nil t) @@ -376,6 +389,7 @@ With arg, don't unhexlify buffer." (setq isearch-search-fun-function hexl-mode-old-isearch-search-fun-function) (use-local-map hexl-mode-old-local-map) (set-syntax-table hexl-mode-old-syntax-table) + (setq font-lock-defaults hexl-mode-old-font-lock-keywords) (setq major-mode hexl-mode-old-major-mode) (force-mode-line-update)) @@ -684,15 +698,6 @@ This discards the buffer's undo information." (apply 'call-process-region (point-min) (point-max) (expand-file-name hexl-program exec-directory) t t nil (split-string hexl-options)) - (save-excursion - (goto-char (point-min)) - (while (re-search-forward "^[0-9a-f]+:" nil t) - (put-text-property (match-beginning 0) (match-end 0) - 'font-lock-face 'hexl-address-area)) - (goto-char (point-min)) - (while (re-search-forward " \\(.+$\\)" nil t) - (put-text-property (match-beginning 1) (match-end 1) - 'font-lock-face 'hexl-ascii-area))) (if (> (point) (hexl-address-to-marker hexl-max-address)) (hexl-goto-address hexl-max-address)))) diff --git a/lisp/international/mule.el b/lisp/international/mule.el index bec20a66df5..144bd0360ca 100644 --- a/lisp/international/mule.el +++ b/lisp/international/mule.el @@ -1878,13 +1878,27 @@ or a function symbol which, when called, returns such a cons cell." (defun decode-coding-inserted-region (from to filename &optional visit beg end replace) "Decode the region between FROM and TO as if it is read from file FILENAME. +The idea is that the text between FROM and TO was just inserted somehow. Optional arguments VISIT, BEG, END, and REPLACE are the same as those -of the function `insert-file-contents'." +of the function `insert-file-contents'. +Part of the job of this function is setting `buffer-undo-list' appropriately." (save-excursion (save-restriction - (narrow-to-region from to) - (goto-char (point-min)) - (let ((coding coding-system-for-read)) + (let ((coding coding-system-for-read) + undo-list-saved) + (if visit + ;; Temporarily turn off undo recording, if we're decoding the + ;; text of a visited file. + (setq buffer-undo-list t) + ;; Otherwise, if we can recognize the undo elt for the insertion, + ;; remove it and get ready to replace it later. + ;; In the mean time, turn off undo recording. + (let ((last (car buffer-undo-list))) + (if (and (consp last) (eql (car last) from) (eql (cdr last) to)) + (setq undo-list-saved (cdr buffer-undo-list) + buffer-undo-list t)))) + (narrow-to-region from to) + (goto-char (point-min)) (or coding (setq coding (funcall set-auto-coding-function filename (- (point-max) (point-min))))) @@ -1899,7 +1913,16 @@ of the function `insert-file-contents'." (setq coding nil)) (if coding (decode-coding-region (point-min) (point-max) coding) - (setq last-coding-system-used coding)))))) + (setq last-coding-system-used coding)) + ;; If we're decoding the text of a visited file, + ;; the undo list should start out empty. + (if visit + (setq buffer-undo-list nil) + ;; If we decided to replace the undo entry for the insertion, + ;; do so now. + (if undo-list-saved + (setq buffer-undo-list + (cons (cons from (point-max)) undo-list-saved)))))))) (defun make-translation-table (&rest args) "Make a translation table from arguments. diff --git a/lisp/international/utf-8.el b/lisp/international/utf-8.el index ed658eb3ddf..2fa096300d2 100644 --- a/lisp/international/utf-8.el +++ b/lisp/international/utf-8.el @@ -305,26 +305,30 @@ use either \\[customize] or the function ;; Load the files explicitly, to avoid having to keep ;; around the large tables they contain (as well as the ;; ones which get built). - (cond ((string= "Korean" current-language-environment) - (load "subst-jis") - (load "subst-big5") - (load "subst-gb2312") - (load "subst-ksc")) - ((string= "Chinese-BIG5" current-language-environment) - (load "subst-jis") - (load "subst-ksc") - (load "subst-gb2312") - (load "subst-big5")) - ((string= "Chinese-GB" current-language-environment) - (load "subst-jis") - (load "subst-ksc") - (load "subst-big5") - (load "subst-gb2312")) - (t - (load "subst-ksc") - (load "subst-gb2312") - (load "subst-big5") - (load "subst-jis"))) ; jis covers as much as big5, gb2312 + ;; Here we bind coding-system-for-read to nil so that coding tags + ;; in the files are respected even if the files are not yet + ;; byte-compiled + (let ((coding-system-for-read nil)) + (cond ((string= "Korean" current-language-environment) + (load "subst-jis") + (load "subst-big5") + (load "subst-gb2312") + (load "subst-ksc")) + ((string= "Chinese-BIG5" current-language-environment) + (load "subst-jis") + (load "subst-ksc") + (load "subst-gb2312") + (load "subst-big5")) + ((string= "Chinese-GB" current-language-environment) + (load "subst-jis") + (load "subst-ksc") + (load "subst-big5") + (load "subst-gb2312")) + (t + (load "subst-ksc") + (load "subst-gb2312") + (load "subst-big5") + (load "subst-jis")))) ; jis covers as much as big5, gb2312 (when redefined (define-translation-hash-table 'utf-subst-table-for-decode diff --git a/lisp/loadup.el b/lisp/loadup.el index bb00fe8fbbb..b5102b4b553 100644 --- a/lisp/loadup.el +++ b/lisp/loadup.el @@ -46,7 +46,8 @@ (message "Using load-path %s" load-path) ;; We don't want to have any undo records in the dumped Emacs. -(buffer-disable-undo "*scratch*") +(set-buffer "*scratch*") +(setq buffer-undo-list t) (load "emacs-lisp/byte-run") (load "emacs-lisp/backquote") diff --git a/lisp/mail/rmail.el b/lisp/mail/rmail.el index a7524cc8246..b913a73ab7f 100644 --- a/lisp/mail/rmail.el +++ b/lisp/mail/rmail.el @@ -3435,6 +3435,8 @@ typically for purposes of moderating a list." (if (not from) (setq from user-mail-address)) (let ((tembuf (generate-new-buffer " sendmail temp")) (case-fold-search nil) + (mail-personal-alias-file + (or mail-alias-file mail-personal-alias-file)) (mailbuf rmail-buffer)) (unwind-protect (with-current-buffer tembuf diff --git a/lisp/mail/smtpmail.el b/lisp/mail/smtpmail.el index d356979ea26..7e6d4746e8d 100644 --- a/lisp/mail/smtpmail.el +++ b/lisp/mail/smtpmail.el @@ -523,7 +523,7 @@ This is relative to `smtpmail-queue-dir'.") (when (and cred mech) (cond ((eq mech 'cram-md5) - (smtpmail-send-command process (format "AUTH %s" mech)) + (smtpmail-send-command process (upcase (format "AUTH %s" mech))) (if (or (null (car (setq ret (smtpmail-read-response process)))) (not (integerp (car ret))) (>= (car ret) 400)) diff --git a/lisp/mouse.el b/lisp/mouse.el index 91e2e4ae5c6..63e0f6c9d91 100644 --- a/lisp/mouse.el +++ b/lisp/mouse.el @@ -754,7 +754,8 @@ remains active. Otherwise, it remains until the next input event. If the click is in the echo area, display the `*Messages*' buffer." (interactive "e") - (let ((w (posn-window (event-start start-event)))) + (let ((w (posn-window (event-start start-event))) + (mouse-autoselect-window nil)) (if (not (or (not (window-minibuffer-p w)) (minibuffer-window-active-p w))) (save-excursion diff --git a/lisp/net/goto-addr.el b/lisp/net/goto-addr.el index 428da8cbe8a..95a13b620a2 100644 --- a/lisp/net/goto-addr.el +++ b/lisp/net/goto-addr.el @@ -100,7 +100,7 @@ A value of t means there is no limit--fontify regardless of the size." (defvar goto-address-mail-regexp ;; Actually pretty much any char could appear in the username part. -stef - "[-a-zA-Z0-9._+]+@\\([-a-zA-z0-9_]+\\.\\)+[a-zA-Z0-9]+" + "[-a-zA-Z0-9=._+]+@\\([-a-zA-z0-9_]+\\.\\)+[a-zA-Z0-9]+" "A regular expression probably matching an e-mail address.") (defvar goto-address-url-regexp diff --git a/lisp/progmodes/compile.el b/lisp/progmodes/compile.el index 9c7e8fe1560..601eb03946e 100644 --- a/lisp/progmodes/compile.el +++ b/lisp/progmodes/compile.el @@ -1463,8 +1463,8 @@ Use this command in a compilation log buffer. Sets the mark at point there." ;; If the current buffer is a compilation buffer, return it. ;; Otherwise, look for a compilation buffer and signal an error ;; if there are none. -(defun compilation-find-buffer (&optional other-buffer) - (next-error-find-buffer other-buffer 'compilation-buffer-internal-p)) +(defun compilation-find-buffer (&optional avoid-current) + (next-error-find-buffer avoid-current 'compilation-buffer-internal-p)) ;;;###autoload (defun compilation-next-error-function (n &optional reset) diff --git a/lisp/progmodes/cperl-mode.el b/lisp/progmodes/cperl-mode.el index accdad515f2..00bd1af4da9 100644 --- a/lisp/progmodes/cperl-mode.el +++ b/lisp/progmodes/cperl-mode.el @@ -6026,7 +6026,8 @@ Currently it is tuned to C and Perl syntax." (interactive) (let (found-bad (p (point))) (setq last-nonmenu-event 13) ; To disable popup - (beginning-of-buffer) + (with-no-warnings ; It is useful to push the mark here. + (beginning-of-buffer)) (map-y-or-n-p "Insert space here? " (lambda (arg) (insert " ")) 'cperl-next-bad-style @@ -7183,13 +7184,9 @@ Delay of auto-help controlled by `cperl-lazy-help-time'." ;;; Plug for wrong font-lock: (defun cperl-font-lock-unfontify-region-function (beg end) - (let* ((modified (buffer-modified-p)) (buffer-undo-list t) - (inhibit-read-only t) (inhibit-point-motion-hooks t) - before-change-functions after-change-functions - deactivate-mark buffer-file-name buffer-file-truename) - (remove-text-properties beg end '(face nil)) - (when (and (not modified) (buffer-modified-p)) - (set-buffer-modified-p nil)))) + ;; Simplified now that font-lock-unfontify-region uses save-buffer-state. + (let (before-change-functions after-change-functions) + (remove-text-properties beg end '(face nil)))) (defvar cperl-d-l nil) (defun cperl-fontify-syntaxically (end) diff --git a/lisp/progmodes/hideshow.el b/lisp/progmodes/hideshow.el index 7013c3856e3..07fcda385ef 100644 --- a/lisp/progmodes/hideshow.el +++ b/lisp/progmodes/hideshow.el @@ -5,7 +5,7 @@ ;; Author: Thien-Thi Nguyen <ttn@gnu.org> ;; Dan Nicolaescu <dann@ics.uci.edu> ;; Keywords: C C++ java lisp tools editing comments blocks hiding outlines -;; Maintainer-Version: 5.31 +;; Maintainer-Version: 5.58.2.3 ;; Time-of-Day-Author-Most-Likely-to-be-Recalcitrant: early morning ;; This file is part of GNU Emacs. @@ -58,7 +58,7 @@ ;; ;; (load-library "hideshow") ;; (add-hook 'X-mode-hook ; other modes similarly -;; '(lambda () (hs-minor-mode 1))) +;; (lambda () (hs-minor-mode 1))) ;; ;; where X = {emacs-lisp,c,c++,perl,...}. You can also manually toggle ;; hideshow minor mode by typing `M-x hs-minor-mode'. After hideshow is @@ -133,14 +133,24 @@ ;; variable `hs-special-modes-alist'. Packages that use hideshow should ;; do something like: ;; -;; (let ((my-mode-hs-info '(my-mode "{{" "}}" ...))) -;; (if (not (member my-mode-hs-info hs-special-modes-alist)) -;; (setq hs-special-modes-alist -;; (cons my-mode-hs-info hs-special-modes-alist)))) +;; (add-to-list 'hs-special-modes-alist '(my-mode "{{" "}}" ...)) ;; ;; If you have an entry that works particularly well, consider ;; submitting it for inclusion in hideshow.el. See docstring for ;; `hs-special-modes-alist' for more info on the entry format. +;; +;; See also variable `hs-set-up-overlay' for per-block customization of +;; appearance or other effects associated with overlays. For example: +;; +;; (setq hs-set-up-overlay +;; (defun my-display-code-line-counts (ov) +;; (when (eq 'code (overlay-get ov 'hs)) +;; (overlay-put ov 'display +;; (propertize +;; (format " ... <%d>" +;; (count-lines (overlay-start ov) +;; (overlay-end ov))) +;; 'face 'font-lock-type-face))))) ;; * Bugs ;; @@ -180,9 +190,9 @@ ;; In the case of `vc-diff', here is a less invasive workaround: ;; ;; (add-hook 'vc-before-checkin-hook -;; '(lambda () -;; (goto-char (point-min)) -;; (hs-show-block))) +;; (lambda () +;; (goto-char (point-min)) +;; (hs-show-block))) ;; ;; Unfortunately, these workarounds do not restore hideshow state. ;; If someone figures out a better way, please let me know. @@ -223,6 +233,7 @@ ;;; Code: (require 'easymenu) +(eval-when-compile (require 'cl)) ;;--------------------------------------------------------------------------- ;; user-configurable variables @@ -265,8 +276,7 @@ This has effect iff `search-invisible' is set to `open'." '((c-mode "{" "}" "/[*/]" nil hs-c-like-adjust-block-beginning) (c++-mode "{" "}" "/[*/]" nil hs-c-like-adjust-block-beginning) (bibtex-mode ("^@\\S(*\\(\\s(\\)" 1)) - (java-mode "{" "}" "/[*/]" nil hs-c-like-adjust-block-beginning) - ) + (java-mode "{" "}" "/[*/]" nil hs-c-like-adjust-block-beginning)) "*Alist for initializing the hideshow variables for different modes. Each element has the form (MODE START END COMMENT-START FORWARD-SEXP-FUNC ADJUST-BEG-FUNC). @@ -307,6 +317,24 @@ a block), `hs-hide-all', `hs-hide-block' and `hs-hide-level'.") These commands include the toggling commands (when the result is to show a block), `hs-show-all' and `hs-show-block'..") +(defvar hs-set-up-overlay nil + "*Function called with one arg, OV, a newly initialized overlay. +Hideshow puts a unique overlay on each range of text to be hidden +in the buffer. Here is a simple example of how to use this variable: + + (defun display-code-line-counts (ov) + (when (eq 'code (overlay-get ov 'hs)) + (overlay-put ov 'display + (format \"... / %d\" + (count-lines (overlay-start ov) + (overlay-end ov)))))) + + (setq hs-set-up-overlay 'display-code-line-counts) + +This example shows how to get information from the overlay as well +as how to set its `display' property. See `hs-make-overlay' and +info node `(elisp)Overlays'.") + ;;--------------------------------------------------------------------------- ;; internal variables @@ -378,28 +406,6 @@ Note that `mode-line-format' is buffer-local.") ;;--------------------------------------------------------------------------- ;; system dependency -; ;; xemacs compatibility -; (when (string-match "xemacs\\|lucid" emacs-version) -; ;; use pre-packaged compatiblity layer -; (require 'overlay)) -; -; ;; xemacs and emacs-19 compatibility -; (when (or (not (fboundp 'add-to-invisibility-spec)) -; (not (fboundp 'remove-from-invisibility-spec))) -; ;; `buffer-invisibility-spec' mutators snarfed from Emacs 20.3 lisp/subr.el -; (defun add-to-invisibility-spec (arg) -; (cond -; ((or (null buffer-invisibility-spec) (eq buffer-invisibility-spec t)) -; (setq buffer-invisibility-spec (list arg))) -; (t -; (setq buffer-invisibility-spec -; (cons arg buffer-invisibility-spec))))) -; (defun remove-from-invisibility-spec (arg) -; (when buffer-invisibility-spec -; (setq buffer-invisibility-spec -; (delete arg buffer-invisibility-spec))))) - -;; hs-match-data (defalias 'hs-match-data 'match-data) ;;--------------------------------------------------------------------------- @@ -409,12 +415,38 @@ Note that `mode-line-format' is buffer-local.") "Delete hideshow overlays in region defined by FROM and TO." (when (< to from) (setq from (prog1 to (setq to from)))) - (let ((ovs (overlays-in from to))) - (while ovs - (let ((ov (car ovs))) - (when (overlay-get ov 'hs) - (delete-overlay ov))) - (setq ovs (cdr ovs))))) + (dolist (ov (overlays-in from to)) + (when (overlay-get ov 'hs) + (delete-overlay ov)))) + +(defun hs-make-overlay (b e kind &optional b-offset e-offset) + "Return a new overlay in region defined by B and E with type KIND. +KIND is either `code' or `comment'. Optional fourth arg B-OFFSET +when added to B specifies the actual buffer position where the block +begins. Likewise for optional fifth arg E-OFFSET. If unspecified +they are taken to be 0 (zero). The following properties are set +in the overlay: 'invisible 'hs 'hs-b-offset 'hs-e-offset. Also, +depending on variable `hs-isearch-open', the following properties may +be present: 'isearch-open-invisible 'isearch-open-invisible-temporary. +If variable `hs-set-up-overlay' is non-nil it should specify a function +to call with the newly initialized overlay." + (unless b-offset (setq b-offset 0)) + (unless e-offset (setq e-offset 0)) + (let ((ov (make-overlay b e)) + (io (if (eq 'block hs-isearch-open) + ;; backward compatibility -- `block'<=>`code' + 'code + hs-isearch-open))) + (overlay-put ov 'invisible 'hs) + (overlay-put ov 'hs kind) + (overlay-put ov 'hs-b-offset b-offset) + (overlay-put ov 'hs-e-offset e-offset) + (when (or (eq io t) (eq io kind)) + (overlay-put ov 'isearch-open-invisible 'hs-isearch-show) + (overlay-put ov 'isearch-open-invisible-temporary + 'hs-isearch-show-temporary)) + (when hs-set-up-overlay (funcall hs-set-up-overlay ov)) + ov)) (defun hs-isearch-show (ov) "Delete overlay OV, and set `hs-headline' to nil. @@ -433,43 +465,28 @@ OV is shown. This function is meant to be used as the `isearch-open-invisible-temporary' property of an overlay." (setq hs-headline - (if hide-p - nil - (or hs-headline - (let ((start (overlay-start ov))) - (buffer-substring - (save-excursion (goto-char start) - (beginning-of-line) - (skip-chars-forward " \t") - (point)) - start))))) + (if hide-p + nil + (or hs-headline + (let ((start (overlay-start ov))) + (buffer-substring + (save-excursion (goto-char start) + (beginning-of-line) + (skip-chars-forward " \t") + (point)) + start))))) (force-mode-line-update) + ;; handle `display' property specially + (let (value) + (if hide-p + (when (setq value (overlay-get ov 'hs-isearch-display)) + (overlay-put ov 'display value) + (overlay-put ov 'hs-isearch-display nil)) + (when (setq value (overlay-get ov 'display)) + (overlay-put ov 'hs-isearch-display value) + (overlay-put ov 'display nil)))) (overlay-put ov 'invisible (and hide-p 'hs))) -(defun hs-flag-region (from to flag) - "Hide or show lines from FROM to TO, according to FLAG. -If FLAG is nil then text is shown, while if FLAG is non-nil the text is -hidden. FLAG must be one of the symbols `code' or `comment', depending -on what kind of block is to be hidden." - (save-excursion - ;; first clear it all out - (hs-discard-overlays from to) - ;; now create overlays if needed - (when flag - (let ((overlay (make-overlay from to))) - (overlay-put overlay 'invisible 'hs) - (overlay-put overlay 'hs flag) - (when (or (eq hs-isearch-open t) - (eq hs-isearch-open flag) - ;; deprecated backward compatibility -- `block'<=>`code' - (and (eq 'block hs-isearch-open) - (eq 'code flag))) - (overlay-put overlay 'isearch-open-invisible 'hs-isearch-show) - (overlay-put overlay - 'isearch-open-invisible-temporary - 'hs-isearch-show-temporary)) - overlay)))) - (defun hs-forward-sexp (match-data arg) "Adjust point based on MATCH-DATA and call `hs-forward-sexp-func' w/ ARG. Original match data is restored upon return." @@ -481,9 +498,10 @@ Original match data is restored upon return." (defun hs-hide-comment-region (beg end &optional repos-end) "Hide a region from BEG to END, marking it as a comment. Optional arg REPOS-END means reposition at end." - (hs-flag-region (progn (goto-char beg) (end-of-line) (point)) - (progn (goto-char end) (end-of-line) (point)) - 'comment) + (let ((beg-eol (progn (goto-char beg) (end-of-line) (point))) + (end-eol (progn (goto-char end) (end-of-line) (point)))) + (hs-discard-overlays beg-eol end-eol) + (hs-make-overlay beg-eol end-eol 'comment beg end)) (goto-char (if repos-end end beg))) (defun hs-hide-block-at-point (&optional end comment-reg) @@ -516,17 +534,16 @@ and then further adjusted to be at the end of the line." (end-of-line) (point)))) (when (and (< p (point)) (> (count-lines p q) 1)) - (overlay-put (hs-flag-region p q 'code) - 'hs-ofs - (- pure-p p))) + (hs-discard-overlays p q) + (hs-make-overlay p q 'code (- pure-p p))) (goto-char (if end q (min p pure-p))))))) (defun hs-safety-is-job-n () "Warn if `buffer-invisibility-spec' does not contain symbol `hs'." - (unless (and (listp buffer-invisibility-spec) - (assq 'hs buffer-invisibility-spec)) - (message "Warning: `buffer-invisibility-spec' does not contain hs!!") - (sit-for 2))) + (unless (and (listp buffer-invisibility-spec) + (assq 'hs buffer-invisibility-spec)) + (message "Warning: `buffer-invisibility-spec' does not contain hs!!") + (sit-for 2))) (defun hs-inside-comment-p () "Return non-nil if point is inside a comment, otherwise nil. @@ -543,10 +560,15 @@ as cdr." (let ((q (point))) (when (or (looking-at hs-c-start-regexp) (re-search-backward hs-c-start-regexp (point-min) t)) + ;; first get to the beginning of this comment... + (while (and (not (bobp)) + (= (point) (progn (forward-comment -1) (point)))) + (forward-char -1)) + ;; ...then extend backwards (forward-comment (- (buffer-size))) (skip-chars-forward " \t\n\f") (let ((p (point)) - (not-hidable nil)) + (hidable t)) (beginning-of-line) (unless (looking-at (concat "[ \t]*" hs-c-start-regexp)) ;; we are in this situation: (example) @@ -565,19 +587,19 @@ as cdr." (while (and (< (point) q) (> (point) p) (not (looking-at hs-c-start-regexp))) - (setq p (point));; use this to avoid an infinite cycle + (setq p (point)) ;; use this to avoid an infinite cycle (forward-comment 1) (skip-chars-forward " \t\n\f")) (when (or (not (looking-at hs-c-start-regexp)) (> (point) q)) ;; we cannot hide this comment block - (setq not-hidable t))) + (setq hidable nil))) ;; goto the end of the comment (forward-comment (buffer-size)) (skip-chars-backward " \t\n\f") (end-of-line) (when (>= (point) q) - (list (if not-hidable nil p) (point)))))))) + (list (and hidable p) (point)))))))) (defun hs-grok-mode-type () "Set up hideshow variables for new buffers. @@ -635,7 +657,7 @@ Return point, or nil if original point was not in a block." (setq minp (1+ (point))) (funcall hs-forward-sexp-func 1) (setq maxp (1- (point)))) - (hs-flag-region minp maxp nil) ; eliminate weirdness + (hs-discard-overlays minp maxp) ; eliminate weirdness (goto-char minp) (while (progn (forward-comment (buffer-size)) @@ -645,7 +667,7 @@ Return point, or nil if original point was not in a block." (hs-hide-level-recursive (1- arg) minp maxp) (goto-char (match-beginning hs-block-start-mdata-select)) (hs-hide-block-at-point t))) - (hs-safety-is-job-n) + (hs-safety-is-job-n) (goto-char maxp)) (defmacro hs-life-goes-on (&rest body) @@ -675,8 +697,8 @@ and `case-fold-search' are both t." (let ((overlays (overlays-at (point))) (found nil)) (while (and (not found) (overlayp (car overlays))) - (setq found (overlay-get (car overlays) 'hs) - overlays (cdr overlays))) + (setq found (overlay-get (car overlays) 'hs) + overlays (cdr overlays))) found))) (defun hs-c-like-adjust-block-beginning (initial) @@ -701,7 +723,7 @@ If `hs-hide-comments-when-hiding-all' is non-nil, also hide the comments." (hs-life-goes-on (message "Hiding all blocks ...") (save-excursion - (hs-flag-region (point-min) (point-max) nil) ; eliminate weirdness + (hs-discard-overlays (point-min) (point-max)) ; eliminate weirdness (goto-char (point-min)) (let ((count 0) (re (concat "\\(" @@ -724,7 +746,7 @@ If `hs-hide-comments-when-hiding-all' is non-nil, also hide the comments." (funcall hs-hide-all-non-comment-function) (hs-hide-block-at-point t))) ;; found a comment, probably - (let ((c-reg (hs-inside-comment-p))) ; blech! + (let ((c-reg (hs-inside-comment-p))) ; blech! (when (and c-reg (car c-reg)) (if (> (count-lines (car c-reg) (nth 1 c-reg)) 1) (hs-hide-block-at-point t c-reg) @@ -740,7 +762,7 @@ If `hs-hide-comments-when-hiding-all' is non-nil, also hide the comments." (interactive) (hs-life-goes-on (message "Showing all blocks ...") - (hs-flag-region (point-min) (point-max) nil) + (hs-discard-overlays (point-min) (point-max)) (message "Showing all blocks ... done") (run-hooks 'hs-show-hook))) @@ -772,18 +794,15 @@ See documentation for functions `hs-hide-block' and `run-hooks'." (or ;; first see if we have something at the end of the line (catch 'eol-begins-hidden-region-p - (let ((here (point)) - (ovs (save-excursion (end-of-line) (overlays-at (point))))) - (while ovs - (let ((ov (car ovs))) - (when (overlay-get ov 'hs) - (goto-char - (cond (end (overlay-end ov)) - ((eq 'comment (overlay-get ov 'hs)) here) - (t (+ (overlay-start ov) (overlay-get ov 'hs-ofs))))) - (delete-overlay ov) - (throw 'eol-begins-hidden-region-p t))) - (setq ovs (cdr ovs))) + (let ((here (point))) + (dolist (ov (save-excursion (end-of-line) (overlays-at (point)))) + (when (overlay-get ov 'hs) + (goto-char + (cond (end (overlay-end ov)) + ((eq 'comment (overlay-get ov 'hs)) here) + (t (+ (overlay-start ov) (overlay-get ov 'hs-b-offset))))) + (delete-overlay ov) + (throw 'eol-begins-hidden-region-p t))) nil)) ;; not immediately obvious, look for a suitable block (let ((c-reg (hs-inside-comment-p)) @@ -797,7 +816,7 @@ See documentation for functions `hs-hide-block' and `run-hooks'." (setq p (point) q (progn (hs-forward-sexp (hs-match-data t) 1) (point))))) (when (and p q) - (hs-flag-region p q nil) + (hs-discard-overlays p q) (goto-char (if end q (1+ p))))) (hs-safety-is-job-n) (run-hooks 'hs-show-hook)))) @@ -870,9 +889,9 @@ Key bindings: (interactive "P") (setq hs-headline nil - hs-minor-mode (if (null arg) - (not hs-minor-mode) - (> (prefix-numeric-value arg) 0))) + hs-minor-mode (if (null arg) + (not hs-minor-mode) + (> (prefix-numeric-value arg) 0))) (if hs-minor-mode (progn (hs-grok-mode-type) @@ -912,27 +931,19 @@ Key bindings: ))))) ;; some housekeeping -(or (assq 'hs-minor-mode minor-mode-map-alist) - (setq minor-mode-map-alist - (cons (cons 'hs-minor-mode hs-minor-mode-map) - minor-mode-map-alist))) -(or (assq 'hs-minor-mode minor-mode-alist) - (setq minor-mode-alist (append minor-mode-alist - (list '(hs-minor-mode " hs"))))) +(add-to-list 'minor-mode-map-alist (cons 'hs-minor-mode hs-minor-mode-map)) +(add-to-list 'minor-mode-alist '(hs-minor-mode " hs") t) ;; make some variables permanently buffer-local -(let ((vars '(hs-minor-mode - hs-c-start-regexp - hs-block-start-regexp - hs-block-start-mdata-select - hs-block-end-regexp - hs-forward-sexp-func - hs-adjust-block-beginning))) - (while vars - (let ((var (car vars))) - (make-variable-buffer-local var) - (put var 'permanent-local t)) - (setq vars (cdr vars)))) +(dolist (var '(hs-minor-mode + hs-c-start-regexp + hs-block-start-regexp + hs-block-start-mdata-select + hs-block-end-regexp + hs-forward-sexp-func + hs-adjust-block-beginning)) + (make-variable-buffer-local var) + (put var 'permanent-local t)) ;;--------------------------------------------------------------------------- ;; that's it diff --git a/lisp/simple.el b/lisp/simple.el index 7465e33c8e9..c9094808c9b 100644 --- a/lisp/simple.el +++ b/lisp/simple.el @@ -124,70 +124,87 @@ to navigate in it.") (make-variable-buffer-local 'next-error-function) (defsubst next-error-buffer-p (buffer - &optional + &optional avoid-current extra-test-inclusive extra-test-exclusive) "Test if BUFFER is a next-error capable buffer. -EXTRA-TEST-INCLUSIVE is called to allow extra buffers. -EXTRA-TEST-EXCLUSIVE is called to disallow buffers." - (with-current-buffer buffer - (or (and extra-test-inclusive (funcall extra-test-inclusive)) - (and (if extra-test-exclusive (funcall extra-test-exclusive) t) - next-error-function)))) - -(defun next-error-find-buffer (&optional other-buffer + +If AVOID-CURRENT is non-nil, treat the current buffer +as an absolute last resort only. + +The function EXTRA-TEST-INCLUSIVE, if non-nil, is called in each buffer +that normally would not qualify. If it returns t, the buffer +in question is treated as usable. + +The function EXTRA-TEST-EXCLUSIVE, if non-nil is called in each buffer +that would normally be considered usable. if it returns nil, +that buffer is rejected." + (and (buffer-name buffer) ;First make sure it's live. + (not (and avoid-current (eq buffer (current-buffer)))) + (with-current-buffer buffer + (if next-error-function ; This is the normal test. + ;; Optionally reject some buffers. + (if extra-test-exclusive + (funcall extra-test-exclusive) + t) + ;; Optionally accept some other buffers. + (and extra-test-inclusive + (funcall extra-test-inclusive)))))) + +(defun next-error-find-buffer (&optional avoid-current extra-test-inclusive extra-test-exclusive) "Return a next-error capable buffer. -OTHER-BUFFER will disallow the current buffer. -EXTRA-TEST-INCLUSIVE is called to allow extra buffers. -EXTRA-TEST-EXCLUSIVE is called to disallow buffers." +If AVOID-CURRENT is non-nil, treat the current buffer +as an absolute last resort only. + +The function EXTRA-TEST-INCLUSIVE, if non-nil, is called in each buffers +that normally would not qualify. If it returns t, the buffer +in question is treated as usable. + +The function EXTRA-TEST-EXCLUSIVE, if non-nil is called in each buffer +that would normally be considered usable. If it returns nil, +that buffer is rejected." (or ;; 1. If one window on the selected frame displays such buffer, return it. (let ((window-buffers (delete-dups (delq nil (mapcar (lambda (w) (if (next-error-buffer-p - (window-buffer w) + (window-buffer w) + avoid-current extra-test-inclusive extra-test-exclusive) (window-buffer w))) (window-list)))))) - (if other-buffer - (setq window-buffers (delq (current-buffer) window-buffers))) (if (eq (length window-buffers) 1) (car window-buffers))) - ;; 2. If next-error-last-buffer is set to a live buffer, use that. + ;; 2. If next-error-last-buffer is an acceptable buffer, use that. (if (and next-error-last-buffer - (buffer-name next-error-last-buffer) - (next-error-buffer-p next-error-last-buffer - extra-test-inclusive extra-test-exclusive) - (or (not other-buffer) - (not (eq next-error-last-buffer (current-buffer))))) - next-error-last-buffer) - ;; 3. If the current buffer is a next-error capable buffer, return it. - (if (and (not other-buffer) - (next-error-buffer-p (current-buffer) + (next-error-buffer-p next-error-last-buffer avoid-current extra-test-inclusive extra-test-exclusive)) + next-error-last-buffer) + ;; 3. If the current buffer is acceptable, choose it. + (if (next-error-buffer-p (current-buffer) avoid-current + extra-test-inclusive extra-test-exclusive) (current-buffer)) - ;; 4. Look for a next-error capable buffer in a buffer list. + ;; 4. Look for any acceptable buffer. (let ((buffers (buffer-list))) (while (and buffers - (or (not (next-error-buffer-p - (car buffers) - extra-test-inclusive extra-test-exclusive)) - (and other-buffer (eq (car buffers) (current-buffer))))) + (not (next-error-buffer-p + (car buffers) avoid-current + extra-test-inclusive extra-test-exclusive))) (setq buffers (cdr buffers))) - (if buffers - (car buffers) - (or (and other-buffer - (next-error-buffer-p (current-buffer) - extra-test-inclusive extra-test-exclusive) - ;; The current buffer is a next-error capable buffer. - (progn - (if other-buffer - (message "This is the only next-error capable buffer")) - (current-buffer))) - (error "No next-error capable buffer found")))))) + (car buffers)) + ;; 5. Use the current buffer as a last resort if it qualifies, + ;; even despite AVOID-CURRENT. + (and avoid-current + (next-error-buffer-p (current-buffer) nil + extra-test-inclusive extra-test-exclusive) + (progn + (message "This is the only next-error capable buffer") + (current-buffer))) + ;; 6. Give up. + (error "No next-error capable buffer found"))) (defun next-error (&optional arg reset) "Visit next next-error message and corresponding source code. @@ -1113,11 +1130,13 @@ makes the search case-sensitive." nil minibuffer-local-map nil - 'minibuffer-history-search-history))) + 'minibuffer-history-search-history + (car minibuffer-history-search-history)))) ;; Use the last regexp specified, by default, if input is empty. (list (if (string= regexp "") - (setcar minibuffer-history-search-history - (nth 1 minibuffer-history-search-history)) + (if minibuffer-history-search-history + (car minibuffer-history-search-history) + (error "No previous history search regexp")) regexp) (prefix-numeric-value current-prefix-arg)))) (previous-matching-history-element regexp (- n))) @@ -1215,6 +1234,10 @@ Return 0 if current buffer is not a mini-buffer." (defvar undo-no-redo nil "If t, `undo' doesn't go through redo entries.") +(defvar undo-list-saved nil + "The value of `buffer-undo-list' saved by the last undo command.") +(make-variable-buffer-local 'undo-list-saved) + (defun undo (&optional arg) "Undo some previous changes. Repeat this command to undo more changes. @@ -1237,7 +1260,13 @@ as an argument limits undo to changes within the current region." ;; So set `this-command' to something other than `undo'. (setq this-command 'undo-start) - (unless (eq last-command 'undo) + (unless (and (eq last-command 'undo) + ;; If something (a timer or filter?) changed the buffer + ;; since the previous command, don't continue the undo seq. + (let ((list buffer-undo-list)) + (while (eq (car list) nil) + (setq list (cdr list))) + (eq undo-list-saved list))) (setq undo-in-region (if transient-mark-mode mark-active (and arg (not (numberp arg))))) (if undo-in-region @@ -1289,10 +1318,20 @@ as an argument limits undo to changes within the current region." (setq tail (cdr tail))) (setq tail nil))) (setq prev tail tail (cdr tail)))) - + ;; Record what the current undo list says, + ;; so the next command can tell if the buffer was modified in between. + (setq undo-list-saved buffer-undo-list) (and modified (not (buffer-modified-p)) (delete-auto-save-file-if-necessary recent-save)))) +(defun buffer-disable-undo (&optional buffer) + "Make BUFFER stop keeping undo information. +No argument or nil as argument means do this for the current buffer." + (interactive) + (with-current-buffer (get-buffer buffer) + (setq buffer-undo-list t + undo-list-saved nil))) + (defun undo-only (&optional arg) "Undo some previous changes. Repeat this command to undo more changes. @@ -1491,8 +1530,9 @@ is not *inside* the region START...END." ;; so it had better not do a lot of consing. (setq undo-outer-limit-function 'undo-outer-limit-truncate) (defun undo-outer-limit-truncate (size) - (if (yes-or-no-p (format "Buffer %s undo info is %d bytes long; discard it? " - (buffer-name) size)) + (if (let (use-dialog-box) + (yes-or-no-p (format "Buffer %s undo info is %d bytes long; discard it? " + (buffer-name) size))) (progn (setq buffer-undo-list nil) t) nil)) diff --git a/lisp/subr.el b/lisp/subr.el index edc303bee8d..e7901f28852 100644 --- a/lisp/subr.el +++ b/lisp/subr.el @@ -823,7 +823,7 @@ is converted into a string by expressing it in decimal." (defalias 'unfocus-frame 'ignore "") -;;;; Obsolescence declarations for variables. +;;;; Obsolescence declarations for variables, and aliases. (make-obsolete-variable 'directory-sep-char "do not use it." "21.1") (make-obsolete-variable 'mode-line-inverse-video "use the appropriate faces instead." "21.1") @@ -840,6 +840,8 @@ is converted into a string by expressing it in decimal." (make-obsolete-variable 'x-lost-selection-hooks 'x-lost-selection-functions "21.4") (defvaralias 'x-sent-selection-hooks 'x-sent-selection-functions) (make-obsolete-variable 'x-sent-selection-hooks 'x-sent-selection-functions "21.4") + +(defvaralias 'messages-buffer-max-lines 'message-log-max) ;;;; Alternate names for functions - these are not being phased out. @@ -1012,19 +1014,33 @@ other hooks, such as major mode hooks, can do the job." ;;; nil nil t) ;;; (setq symbol-file-load-history-loaded t))) -(defun symbol-file (function) - "Return the input source from which FUNCTION was loaded. +(defun symbol-file (symbol &optional type) + "Return the input source in which SYMBOL was defined. The value is normally a string that was passed to `load': either an absolute file name, or a library name \(with no directory name and no `.el' or `.elc' at the end). -It can also be nil, if the definition is not associated with any file." - (if (and (symbolp function) (fboundp function) - (eq 'autoload (car-safe (symbol-function function)))) - (nth 1 (symbol-function function)) +It can also be nil, if the definition is not associated with any file. + +If TYPE is nil, then any kind of definition is acceptable. +If type is `defun' or `defvar', that specifies function +definition only or variable definition only." + (if (and (or (null type) (eq type 'defun)) + (symbolp symbol) (fboundp symbol) + (eq 'autoload (car-safe (symbol-function symbol)))) + (nth 1 (symbol-function symbol)) (let ((files load-history) file) (while files - (if (member function (cdr (car files))) + (if (if type + (if (eq type 'defvar) + ;; Variables are present just as their names. + (member symbol (cdr (car files))) + ;; Other types are represented as (TYPE . NAME). + (member (cons type symbol) (cdr (car files)))) + ;; We accept all types, so look for variable def + ;; and then for any other kind. + (or (member symbol (cdr (car files))) + (rassq symbol (cdr (car files))))) (setq file (car (car files)) files nil)) (setq files (cdr files))) file))) diff --git a/lisp/term/mac-win.el b/lisp/term/mac-win.el index 2b5c4d2a994..8cfce66c214 100644 --- a/lisp/term/mac-win.el +++ b/lisp/term/mac-win.el @@ -1,8 +1,9 @@ -;;; mac-win.el --- support for "Macintosh windows" +;;; mac-win.el --- parse switches controlling interface with Mac window system -;; Copyright (C) 1999, 2000, 2002, 2003 Free Software Foundation, Inc. +;; Copyright (C) 1999, 2000, 2002, 2003, 2004 Free Software Foundation, Inc. ;; Author: Andrew Choi <akochoi@mac.com> +;; Keywords: terminals ;; This file is part of GNU Emacs. @@ -23,634 +24,212 @@ ;;; Commentary: -;;; Code: +;; Mac-win.el: this file is loaded from ../lisp/startup.el when it recognizes +;; that Mac windows are to be used. Command line switches are parsed and those +;; pertaining to Mac are processed and removed from the command line. The +;; Mac display is opened and hooks are set for popping up the initial window. -;; --------------------------------------------------------------------------- -;; We want to delay setting frame parameters until the faces are setup +;; startup.el will then examine startup files, and eventually call the hooks +;; which create the first window(s). -;; Mac can't handle ~ prefix in file names -;(setq auto-save-list-file-prefix ".saves-") +;;; Code: + +;; These are the standard X switches from the Xt Initialize.c file of +;; Release 4. -(setq frame-creation-function 'x-create-frame-with-faces) +;; Command line Resource Manager string -;; for debugging -;; (defun mac-handle-scroll-bar-event (event) (interactive "e") (princ event)) +;; +rv *reverseVideo +;; +synchronous *synchronous +;; -background *background +;; -bd *borderColor +;; -bg *background +;; -bordercolor *borderColor +;; -borderwidth .borderWidth +;; -bw .borderWidth +;; -display .display +;; -fg *foreground +;; -fn *font +;; -font *font +;; -foreground *foreground +;; -geometry .geometry +;; -i .iconType +;; -itype .iconType +;; -iconic .iconic +;; -name .name +;; -reverse *reverseVideo +;; -rv *reverseVideo +;; -selectionTimeout .selectionTimeout +;; -synchronous *synchronous +;; -xrm -;;(global-set-key [vertical-scroll-bar mouse-1] 'mac-handle-scroll-bar-event) +;; An alist of X options and the function which handles them. See +;; ../startup.el. -(global-set-key - [vertical-scroll-bar down-mouse-1] - 'mac-handle-scroll-bar-event) - -(global-unset-key [vertical-scroll-bar drag-mouse-1]) -(global-unset-key [vertical-scroll-bar mouse-1]) +(if (not (eq window-system 'mac)) + (error "%s: Loading mac-win.el but not compiled for Mac" (invocation-name))) +(require 'frame) +(require 'mouse) (require 'scroll-bar) +(require 'faces) +;;(require 'select) +(require 'menu-bar) +(require 'fontset) +;;(require 'x-dnd) -(defun mac-handle-scroll-bar-event (event) - "Handle scroll bar EVENT to emulate Mac Toolbox style scrolling." - (interactive "e") - (let* ((position (event-start event)) - (window (nth 0 position)) - (bar-part (nth 4 position))) - (select-window window) - (cond - ((eq bar-part 'up) - (goto-char (window-start window)) - (mac-scroll-down-line)) - ((eq bar-part 'above-handle) - (mac-scroll-down)) - ((eq bar-part 'handle) - (scroll-bar-drag event)) - ((eq bar-part 'below-handle) - (mac-scroll-up)) - ((eq bar-part 'down) - (goto-char (window-start window)) - (mac-scroll-up-line))))) +(defvar x-invocation-args) -(defun mac-scroll-ignore-events () - ;; Ignore confusing non-mouse events - (while (not (memq (car-safe (read-event)) - '(mouse-1 double-mouse-1 triple-mouse-1))) nil)) +(defvar x-command-line-resources nil) -(defun mac-scroll-down () - (track-mouse - (mac-scroll-ignore-events) - (scroll-down))) +;; Handler for switches of the form "-switch value" or "-switch". +(defun x-handle-switch (switch) + (let ((aelt (assoc switch command-line-x-option-alist))) + (if aelt + (let ((param (nth 3 aelt)) + (value (nth 4 aelt))) + (if value + (setq default-frame-alist + (cons (cons param value) + default-frame-alist)) + (setq default-frame-alist + (cons (cons param + (car x-invocation-args)) + default-frame-alist) + x-invocation-args (cdr x-invocation-args))))))) -(defun mac-scroll-down-line () - (track-mouse - (mac-scroll-ignore-events) - (scroll-down 1))) +;; Handler for switches of the form "-switch n" +(defun x-handle-numeric-switch (switch) + (let ((aelt (assoc switch command-line-x-option-alist))) + (if aelt + (let ((param (nth 3 aelt))) + (setq default-frame-alist + (cons (cons param + (string-to-int (car x-invocation-args))) + default-frame-alist) + x-invocation-args + (cdr x-invocation-args)))))) -(defun mac-scroll-up () - (track-mouse - (mac-scroll-ignore-events) - (scroll-up))) +;; Handle options that apply to initial frame only +(defun x-handle-initial-switch (switch) + (let ((aelt (assoc switch command-line-x-option-alist))) + (if aelt + (let ((param (nth 3 aelt)) + (value (nth 4 aelt))) + (if value + (setq initial-frame-alist + (cons (cons param value) + initial-frame-alist)) + (setq initial-frame-alist + (cons (cons param + (car x-invocation-args)) + initial-frame-alist) + x-invocation-args (cdr x-invocation-args))))))) -(defun mac-scroll-up-line () - (track-mouse - (mac-scroll-ignore-events) - (scroll-up 1))) +;; Make -iconic apply only to the initial frame! +(defun x-handle-iconic (switch) + (setq initial-frame-alist + (cons '(visibility . icon) initial-frame-alist))) -(defun xw-defined-colors (&optional frame) - "Internal function called by `defined-colors', which see." - (or frame (setq frame (selected-frame))) - (let ((all-colors x-colors) - (this-color nil) - (defined-colors nil)) - (while all-colors - (setq this-color (car all-colors) - all-colors (cdr all-colors)) - (and (color-supported-p this-color frame t) - (setq defined-colors (cons this-color defined-colors)))) - defined-colors)) +;; Handle the -xrm option. +(defun x-handle-xrm-switch (switch) + (unless (consp x-invocation-args) + (error "%s: missing argument to `%s' option" (invocation-name) switch)) + (setq x-command-line-resources + (if (null x-command-line-resources) + (car x-invocation-args) + (concat x-command-line-resources "\n" (car x-invocation-args)))) + (setq x-invocation-args (cdr x-invocation-args))) -;; Don't have this yet. -(fset 'x-get-resource 'ignore) +;; Handle the geometry option +(defun x-handle-geometry (switch) + (let* ((geo (x-parse-geometry (car x-invocation-args))) + (left (assq 'left geo)) + (top (assq 'top geo)) + (height (assq 'height geo)) + (width (assq 'width geo))) + (if (or height width) + (setq default-frame-alist + (append default-frame-alist + '((user-size . t)) + (if height (list height)) + (if width (list width))) + initial-frame-alist + (append initial-frame-alist + '((user-size . t)) + (if height (list height)) + (if width (list width))))) + (if (or left top) + (setq initial-frame-alist + (append initial-frame-alist + '((user-position . t)) + (if left (list left)) + (if top (list top))))) + (setq x-invocation-args (cdr x-invocation-args)))) -(unless (eq system-type 'darwin) - ;; This variable specifies the Unix program to call (as a process) to - ;; deteremine the amount of free space on a file system (defaults to - ;; df). If it is not set to nil, ls-lisp will not work correctly - ;; unless an external application df is implemented on the Mac. - (setq directory-free-space-program nil) +;; Handle the -name option. Set the variable x-resource-name +;; to the option's operand; set the name of +;; the initial frame, too. +(defun x-handle-name-switch (switch) + (or (consp x-invocation-args) + (error "%s: missing argument to `%s' option" (invocation-name) switch)) + (setq x-resource-name (car x-invocation-args) + x-invocation-args (cdr x-invocation-args)) + (setq initial-frame-alist (cons (cons 'name x-resource-name) + initial-frame-alist))) - ;; Set this so that Emacs calls subprocesses with "sh" as shell to - ;; expand filenames Note no subprocess for the shell is actually - ;; started (see run_mac_command in sysdep.c). - (setq shell-file-name "sh")) +(defvar x-display-name nil + "The display name specifying server and frame.") -;; X Window emulation in macterm.c is not complete enough to start a -;; frame without a minibuffer properly. Call this to tell ediff -;; library to use a single frame. -; (ediff-toggle-multiframe) - -;; Setup to use the Mac clipboard. The functions mac-cut-function and -;; mac-paste-function are defined in mac.c. -(set-selection-coding-system 'compound-text-mac) - -(setq interprogram-cut-function - '(lambda (str push) - (mac-cut-function - (encode-coding-string str selection-coding-system t) push))) - -(setq interprogram-paste-function - '(lambda () - (let ((clipboard (mac-paste-function))) - (if clipboard - (decode-coding-string clipboard selection-coding-system t))))) - -;; Don't show the frame name; that's redundant. -(setq-default mode-line-frame-identification " ") - -(defun mac-drag-n-drop (event) - "Edit the files listed in the drag-n-drop event.\n\ -Switch to a buffer editing the last file dropped." - (interactive "e") - (save-excursion - ;; Make sure the drop target has positive co-ords - ;; before setting the selected frame - otherwise it - ;; won't work. <skx@tardis.ed.ac.uk> - (let* ((window (posn-window (event-start event))) - (coords (posn-x-y (event-start event))) - (x (car coords)) - (y (cdr coords))) - (if (and (> x 0) (> y 0)) - (set-frame-selected-window nil window)) - (mapcar - '(lambda (file) - (find-file - (decode-coding-string - file - (or file-name-coding-system - default-file-name-coding-system)))) - (car (cdr (cdr event))))) - (raise-frame) - (recenter))) - -(global-set-key [drag-n-drop] 'mac-drag-n-drop) - -;; By checking whether the variable mac-ready-for-drag-n-drop has been -;; defined, the event loop in macterm.c can be informed that it can -;; now receive Finder drag and drop events. Files dropped onto the -;; Emacs application icon can only be processed when the initial frame -;; has been created: this is where the files should be opened. -(add-hook 'after-init-hook - '(lambda () - (defvar mac-ready-for-drag-n-drop t))) - -; Define constant values to be set to mac-keyboard-text-encoding -(defconst kTextEncodingMacRoman 0) -(defconst kTextEncodingISOLatin1 513 "0x201") -(defconst kTextEncodingISOLatin2 514 "0x202") - - -(define-ccl-program ccl-encode-mac-roman-font - `(0 - (if (r0 != ,(charset-id 'ascii)) - (if (r0 <= ?\x8f) - (translate-character mac-roman-encoder r0 r1) - ((r1 <<= 7) - (r1 |= r2) - (translate-character mac-roman-encoder r0 r1))))) - "CCL program for Mac Roman font") - -(let - ((encoding-vector (make-vector 256 nil)) - (i 0) - (vec ;; mac-centraleurroman (128..255) -> UCS mapping - [ #x00C4 ;; 128:LATIN CAPITAL LETTER A WITH DIAERESIS - #x0100 ;; 129:LATIN CAPITAL LETTER A WITH MACRON - #x0101 ;; 130:LATIN SMALL LETTER A WITH MACRON - #x00C9 ;; 131:LATIN CAPITAL LETTER E WITH ACUTE - #x0104 ;; 132:LATIN CAPITAL LETTER A WITH OGONEK - #x00D6 ;; 133:LATIN CAPITAL LETTER O WITH DIAERESIS - #x00DC ;; 134:LATIN CAPITAL LETTER U WITH DIAERESIS - #x00E1 ;; 135:LATIN SMALL LETTER A WITH ACUTE - #x0105 ;; 136:LATIN SMALL LETTER A WITH OGONEK - #x010C ;; 137:LATIN CAPITAL LETTER C WITH CARON - #x00E4 ;; 138:LATIN SMALL LETTER A WITH DIAERESIS - #x010D ;; 139:LATIN SMALL LETTER C WITH CARON - #x0106 ;; 140:LATIN CAPITAL LETTER C WITH ACUTE - #x0107 ;; 141:LATIN SMALL LETTER C WITH ACUTE - #x00E9 ;; 142:LATIN SMALL LETTER E WITH ACUTE - #x0179 ;; 143:LATIN CAPITAL LETTER Z WITH ACUTE - #x017A ;; 144:LATIN SMALL LETTER Z WITH ACUTE - #x010E ;; 145:LATIN CAPITAL LETTER D WITH CARON - #x00ED ;; 146:LATIN SMALL LETTER I WITH ACUTE - #x010F ;; 147:LATIN SMALL LETTER D WITH CARON - #x0112 ;; 148:LATIN CAPITAL LETTER E WITH MACRON - #x0113 ;; 149:LATIN SMALL LETTER E WITH MACRON - #x0116 ;; 150:LATIN CAPITAL LETTER E WITH DOT ABOVE - #x00F3 ;; 151:LATIN SMALL LETTER O WITH ACUTE - #x0117 ;; 152:LATIN SMALL LETTER E WITH DOT ABOVE - #x00F4 ;; 153:LATIN SMALL LETTER O WITH CIRCUMFLEX - #x00F6 ;; 154:LATIN SMALL LETTER O WITH DIAERESIS - #x00F5 ;; 155:LATIN SMALL LETTER O WITH TILDE - #x00FA ;; 156:LATIN SMALL LETTER U WITH ACUTE - #x011A ;; 157:LATIN CAPITAL LETTER E WITH CARON - #x011B ;; 158:LATIN SMALL LETTER E WITH CARON - #x00FC ;; 159:LATIN SMALL LETTER U WITH DIAERESIS - #x2020 ;; 160:DAGGER - #x00B0 ;; 161:DEGREE SIGN - #x0118 ;; 162:LATIN CAPITAL LETTER E WITH OGONEK - #x00A3 ;; 163:POUND SIGN - #x00A7 ;; 164:SECTION SIGN - #x2022 ;; 165:BULLET - #x00B6 ;; 166:PILCROW SIGN - #x00DF ;; 167:LATIN SMALL LETTER SHARP S - #x00AE ;; 168:REGISTERED SIGN - #x00A9 ;; 169:COPYRIGHT SIGN - #x2122 ;; 170:TRADE MARK SIGN - #x0119 ;; 171:LATIN SMALL LETTER E WITH OGONEK - #x00A8 ;; 172:DIAERESIS - #x2260 ;; 173:NOT EQUAL TO - #x0123 ;; 174:LATIN SMALL LETTER G WITH CEDILLA - #x012E ;; 175:LATIN CAPITAL LETTER I WITH OGONEK - #x012F ;; 176:LATIN SMALL LETTER I WITH OGONEK - #x012A ;; 177:LATIN CAPITAL LETTER I WITH MACRON - #x2264 ;; 178:LESS-THAN OR EQUAL TO - #x2265 ;; 179:GREATER-THAN OR EQUAL TO - #x012B ;; 180:LATIN SMALL LETTER I WITH MACRON - #x0136 ;; 181:LATIN CAPITAL LETTER K WITH CEDILLA - #x2202 ;; 182:PARTIAL DIFFERENTIAL - #x2211 ;; 183:N-ARY SUMMATION - #x0142 ;; 184:LATIN SMALL LETTER L WITH STROKE - #x013B ;; 185:LATIN CAPITAL LETTER L WITH CEDILLA - #x013C ;; 186:LATIN SMALL LETTER L WITH CEDILLA - #x013D ;; 187:LATIN CAPITAL LETTER L WITH CARON - #x013E ;; 188:LATIN SMALL LETTER L WITH CARON - #x0139 ;; 189:LATIN CAPITAL LETTER L WITH ACUTE - #x013A ;; 190:LATIN SMALL LETTER L WITH ACUTE - #x0145 ;; 191:LATIN CAPITAL LETTER N WITH CEDILLA - #x0146 ;; 192:LATIN SMALL LETTER N WITH CEDILLA - #x0143 ;; 193:LATIN CAPITAL LETTER N WITH ACUTE - #x00AC ;; 194:NOT SIGN - #x221A ;; 195:SQUARE ROOT - #x0144 ;; 196:LATIN SMALL LETTER N WITH ACUTE - #x0147 ;; 197:LATIN CAPITAL LETTER N WITH CARON - #x2206 ;; 198:INCREMENT - #x00AB ;; 199:LEFT-POINTING DOUBLE ANGLE QUOTATION MARK - #x00BB ;; 200:RIGHT-POINTING DOUBLE ANGLE QUOTATION MARK - #x2026 ;; 201:HORIZONTAL ELLIPSIS - #x00A0 ;; 202:NO-BREAK SPACE - #x0148 ;; 203:LATIN SMALL LETTER N WITH CARON - #x0150 ;; 204:LATIN CAPITAL LETTER O WITH DOUBLE ACUTE - #x00D5 ;; 205:LATIN CAPITAL LETTER O WITH TILDE - #x0151 ;; 206:LATIN SMALL LETTER O WITH DOUBLE ACUTE - #x014C ;; 207:LATIN CAPITAL LETTER O WITH MACRON - #x2013 ;; 208:EN DASH - #x2014 ;; 209:EM DASH - #x201C ;; 210:LEFT DOUBLE QUOTATION MARK - #x201D ;; 211:RIGHT DOUBLE QUOTATION MARK - #x2018 ;; 212:LEFT SINGLE QUOTATION MARK - #x2019 ;; 213:RIGHT SINGLE QUOTATION MARK - #x00F7 ;; 214:DIVISION SIGN - #x25CA ;; 215:LOZENGE - #x014D ;; 216:LATIN SMALL LETTER O WITH MACRON - #x0154 ;; 217:LATIN CAPITAL LETTER R WITH ACUTE - #x0155 ;; 218:LATIN SMALL LETTER R WITH ACUTE - #x0158 ;; 219:LATIN CAPITAL LETTER R WITH CARON - #x2039 ;; 220:SINGLE LEFT-POINTING ANGLE QUOTATION MARK - #x203A ;; 221:SINGLE RIGHT-POINTING ANGLE QUOTATION MARK - #x0159 ;; 222:LATIN SMALL LETTER R WITH CARON - #x0156 ;; 223:LATIN CAPITAL LETTER R WITH CEDILLA - #x0157 ;; 224:LATIN SMALL LETTER R WITH CEDILLA - #x0160 ;; 225:LATIN CAPITAL LETTER S WITH CARON - #x201A ;; 226:SINGLE LOW-9 QUOTATION MARK - #x201E ;; 227:DOUBLE LOW-9 QUOTATION MARK - #x0161 ;; 228:LATIN SMALL LETTER S WITH CARON - #x015A ;; 229:LATIN CAPITAL LETTER S WITH ACUTE - #x015B ;; 230:LATIN SMALL LETTER S WITH ACUTE - #x00C1 ;; 231:LATIN CAPITAL LETTER A WITH ACUTE - #x0164 ;; 232:LATIN CAPITAL LETTER T WITH CARON - #x0165 ;; 233:LATIN SMALL LETTER T WITH CARON - #x00CD ;; 234:LATIN CAPITAL LETTER I WITH ACUTE - #x017D ;; 235:LATIN CAPITAL LETTER Z WITH CARON - #x017E ;; 236:LATIN SMALL LETTER Z WITH CARON - #x016A ;; 237:LATIN CAPITAL LETTER U WITH MACRON - #x00D3 ;; 238:LATIN CAPITAL LETTER O WITH ACUTE - #x00D4 ;; 239:LATIN CAPITAL LETTER O WITH CIRCUMFLEX - #x016B ;; 240:LATIN SMALL LETTER U WITH MACRON - #x016E ;; 241:LATIN CAPITAL LETTER U WITH RING ABOVE - #x00DA ;; 242:LATIN CAPITAL LETTER U WITH ACUTE - #x016F ;; 243:LATIN SMALL LETTER U WITH RING ABOVE - #x0170 ;; 244:LATIN CAPITAL LETTER U WITH DOUBLE ACUTE - #x0171 ;; 245:LATIN SMALL LETTER U WITH DOUBLE ACUTE - #x0172 ;; 246:LATIN CAPITAL LETTER U WITH OGONEK - #x0173 ;; 247:LATIN SMALL LETTER U WITH OGONEK - #x00DD ;; 248:LATIN CAPITAL LETTER Y WITH ACUTE - #x00FD ;; 249:LATIN SMALL LETTER Y WITH ACUTE - #x0137 ;; 250:LATIN SMALL LETTER K WITH CEDILLA - #x017B ;; 251:LATIN CAPITAL LETTER Z WITH DOT ABOVE - #x0141 ;; 252:LATIN CAPITAL LETTER L WITH STROKE - #x017C ;; 253:LATIN SMALL LETTER Z WITH DOT ABOVE - #x0122 ;; 254:LATIN CAPITAL LETTER G WITH CEDILLA - #x02C7 ;; 255:CARON - ]) - translation-table) - (while (< i 128) - (aset encoding-vector i i) - (setq i (1+ i))) - (while (< i 256) - (aset encoding-vector i - (decode-char 'ucs (aref vec (- i 128)))) - (setq i (1+ i))) - (setq translation-table - (make-translation-table-from-vector encoding-vector)) -;; (define-translation-table 'mac-centraleurroman-decoder translation-table) - (define-translation-table 'mac-centraleurroman-encoder - (char-table-extra-slot translation-table 0))) - -(let - ((encoding-vector (make-vector 256 nil)) - (i 0) - (vec ;; mac-cyrillic (128..255) -> UCS mapping - [ #x0410 ;; 128:CYRILLIC CAPITAL LETTER A - #x0411 ;; 129:CYRILLIC CAPITAL LETTER BE - #x0412 ;; 130:CYRILLIC CAPITAL LETTER VE - #x0413 ;; 131:CYRILLIC CAPITAL LETTER GHE - #x0414 ;; 132:CYRILLIC CAPITAL LETTER DE - #x0415 ;; 133:CYRILLIC CAPITAL LETTER IE - #x0416 ;; 134:CYRILLIC CAPITAL LETTER ZHE - #x0417 ;; 135:CYRILLIC CAPITAL LETTER ZE - #x0418 ;; 136:CYRILLIC CAPITAL LETTER I - #x0419 ;; 137:CYRILLIC CAPITAL LETTER SHORT I - #x041A ;; 138:CYRILLIC CAPITAL LETTER KA - #x041B ;; 139:CYRILLIC CAPITAL LETTER EL - #x041C ;; 140:CYRILLIC CAPITAL LETTER EM - #x041D ;; 141:CYRILLIC CAPITAL LETTER EN - #x041E ;; 142:CYRILLIC CAPITAL LETTER O - #x041F ;; 143:CYRILLIC CAPITAL LETTER PE - #x0420 ;; 144:CYRILLIC CAPITAL LETTER ER - #x0421 ;; 145:CYRILLIC CAPITAL LETTER ES - #x0422 ;; 146:CYRILLIC CAPITAL LETTER TE - #x0423 ;; 147:CYRILLIC CAPITAL LETTER U - #x0424 ;; 148:CYRILLIC CAPITAL LETTER EF - #x0425 ;; 149:CYRILLIC CAPITAL LETTER HA - #x0426 ;; 150:CYRILLIC CAPITAL LETTER TSE - #x0427 ;; 151:CYRILLIC CAPITAL LETTER CHE - #x0428 ;; 152:CYRILLIC CAPITAL LETTER SHA - #x0429 ;; 153:CYRILLIC CAPITAL LETTER SHCHA - #x042A ;; 154:CYRILLIC CAPITAL LETTER HARD SIGN - #x042B ;; 155:CYRILLIC CAPITAL LETTER YERU - #x042C ;; 156:CYRILLIC CAPITAL LETTER SOFT SIGN - #x042D ;; 157:CYRILLIC CAPITAL LETTER E - #x042E ;; 158:CYRILLIC CAPITAL LETTER YU - #x042F ;; 159:CYRILLIC CAPITAL LETTER YA - #x2020 ;; 160:DAGGER - #x00B0 ;; 161:DEGREE SIGN - #x0490 ;; 162:CYRILLIC CAPITAL LETTER GHE WITH UPTURN - #x00A3 ;; 163:POUND SIGN - #x00A7 ;; 164:SECTION SIGN - #x2022 ;; 165:BULLET - #x00B6 ;; 166:PILCROW SIGN - #x0406 ;; 167:CYRILLIC CAPITAL LETTER BYELORUSSIAN-UKRAINIAN I - #x00AE ;; 168:REGISTERED SIGN - #x00A9 ;; 169:COPYRIGHT SIGN - #x2122 ;; 170:TRADE MARK SIGN - #x0402 ;; 171:CYRILLIC CAPITAL LETTER DJE - #x0452 ;; 172:CYRILLIC SMALL LETTER DJE - #x2260 ;; 173:NOT EQUAL TO - #x0403 ;; 174:CYRILLIC CAPITAL LETTER GJE - #x0453 ;; 175:CYRILLIC SMALL LETTER GJE - #x221E ;; 176:INFINITY - #x00B1 ;; 177:PLUS-MINUS SIGN - #x2264 ;; 178:LESS-THAN OR EQUAL TO - #x2265 ;; 179:GREATER-THAN OR EQUAL TO - #x0456 ;; 180:CYRILLIC SMALL LETTER BYELORUSSIAN-UKRAINIAN I - #x00B5 ;; 181:MICRO SIGN - #x0491 ;; 182:CYRILLIC SMALL LETTER GHE WITH UPTURN - #x0408 ;; 183:CYRILLIC CAPITAL LETTER JE - #x0404 ;; 184:CYRILLIC CAPITAL LETTER UKRAINIAN IE - #x0454 ;; 185:CYRILLIC SMALL LETTER UKRAINIAN IE - #x0407 ;; 186:CYRILLIC CAPITAL LETTER YI - #x0457 ;; 187:CYRILLIC SMALL LETTER YI - #x0409 ;; 188:CYRILLIC CAPITAL LETTER LJE - #x0459 ;; 189:CYRILLIC SMALL LETTER LJE - #x040A ;; 190:CYRILLIC CAPITAL LETTER NJE - #x045A ;; 191:CYRILLIC SMALL LETTER NJE - #x0458 ;; 192:CYRILLIC SMALL LETTER JE - #x0405 ;; 193:CYRILLIC CAPITAL LETTER DZE - #x00AC ;; 194:NOT SIGN - #x221A ;; 195:SQUARE ROOT - #x0192 ;; 196:LATIN SMALL LETTER F WITH HOOK - #x2248 ;; 197:ALMOST EQUAL TO - #x2206 ;; 198:INCREMENT - #x00AB ;; 199:LEFT-POINTING DOUBLE ANGLE QUOTATION MARK - #x00BB ;; 200:RIGHT-POINTING DOUBLE ANGLE QUOTATION MARK - #x2026 ;; 201:HORIZONTAL ELLIPSIS - #x00A0 ;; 202:NO-BREAK SPACE - #x040B ;; 203:CYRILLIC CAPITAL LETTER TSHE - #x045B ;; 204:CYRILLIC SMALL LETTER TSHE - #x040C ;; 205:CYRILLIC CAPITAL LETTER KJE - #x045C ;; 206:CYRILLIC SMALL LETTER KJE - #x0455 ;; 207:CYRILLIC SMALL LETTER DZE - #x2013 ;; 208:EN DASH - #x2014 ;; 209:EM DASH - #x201C ;; 210:LEFT DOUBLE QUOTATION MARK - #x201D ;; 211:RIGHT DOUBLE QUOTATION MARK - #x2018 ;; 212:LEFT SINGLE QUOTATION MARK - #x2019 ;; 213:RIGHT SINGLE QUOTATION MARK - #x00F7 ;; 214:DIVISION SIGN - #x201E ;; 215:DOUBLE LOW-9 QUOTATION MARK - #x040E ;; 216:CYRILLIC CAPITAL LETTER SHORT U - #x045E ;; 217:CYRILLIC SMALL LETTER SHORT U - #x040F ;; 218:CYRILLIC CAPITAL LETTER DZHE - #x045F ;; 219:CYRILLIC SMALL LETTER DZHE - #x2116 ;; 220:NUMERO SIGN - #x0401 ;; 221:CYRILLIC CAPITAL LETTER IO - #x0451 ;; 222:CYRILLIC SMALL LETTER IO - #x044F ;; 223:CYRILLIC SMALL LETTER YA - #x0430 ;; 224:CYRILLIC SMALL LETTER A - #x0431 ;; 225:CYRILLIC SMALL LETTER BE - #x0432 ;; 226:CYRILLIC SMALL LETTER VE - #x0433 ;; 227:CYRILLIC SMALL LETTER GHE - #x0434 ;; 228:CYRILLIC SMALL LETTER DE - #x0435 ;; 229:CYRILLIC SMALL LETTER IE - #x0436 ;; 230:CYRILLIC SMALL LETTER ZHE - #x0437 ;; 231:CYRILLIC SMALL LETTER ZE - #x0438 ;; 232:CYRILLIC SMALL LETTER I - #x0439 ;; 233:CYRILLIC SMALL LETTER SHORT I - #x043A ;; 234:CYRILLIC SMALL LETTER KA - #x043B ;; 235:CYRILLIC SMALL LETTER EL - #x043C ;; 236:CYRILLIC SMALL LETTER EM - #x043D ;; 237:CYRILLIC SMALL LETTER EN - #x043E ;; 238:CYRILLIC SMALL LETTER O - #x043F ;; 239:CYRILLIC SMALL LETTER PE - #x0440 ;; 240:CYRILLIC SMALL LETTER ER - #x0441 ;; 241:CYRILLIC SMALL LETTER ES - #x0442 ;; 242:CYRILLIC SMALL LETTER TE - #x0443 ;; 243:CYRILLIC SMALL LETTER U - #x0444 ;; 244:CYRILLIC SMALL LETTER EF - #x0445 ;; 245:CYRILLIC SMALL LETTER HA - #x0446 ;; 246:CYRILLIC SMALL LETTER TSE - #x0447 ;; 247:CYRILLIC SMALL LETTER CHE - #x0448 ;; 248:CYRILLIC SMALL LETTER SHA - #x0449 ;; 249:CYRILLIC SMALL LETTER SHCHA - #x044A ;; 250:CYRILLIC SMALL LETTER HARD SIGN - #x044B ;; 251:CYRILLIC SMALL LETTER YERU - #x044C ;; 252:CYRILLIC SMALL LETTER SOFT SIGN - #x044D ;; 253:CYRILLIC SMALL LETTER E - #x044E ;; 254:CYRILLIC SMALL LETTER YU - #x20AC ;; 255:EURO SIGN - ]) - translation-table) - (while (< i 128) - (aset encoding-vector i i) - (setq i (1+ i))) - (while (< i 256) - (aset encoding-vector i - (decode-char 'ucs (aref vec (- i 128)))) - (setq i (1+ i))) - (setq translation-table - (make-translation-table-from-vector encoding-vector)) -;; (define-translation-table 'mac-cyrillic-decoder translation-table) - (define-translation-table 'mac-cyrillic-encoder - (char-table-extra-slot translation-table 0))) - -(defvar mac-font-encoder-list - '(("mac-roman" mac-roman-encoder - ccl-encode-mac-roman-font "%s") - ("mac-centraleurroman" mac-centraleurroman-encoder - ccl-encode-mac-centraleurroman-font "%s ce") - ("mac-cyrillic" mac-cyrillic-encoder - ccl-encode-mac-cyrillic-font "%s cy"))) - -(let ((encoder-list - (mapcar (lambda (lst) (nth 1 lst)) mac-font-encoder-list)) - (charset-list - '(latin-iso8859-2 - latin-iso8859-3 latin-iso8859-4 - cyrillic-iso8859-5 greek-iso8859-7 hebrew-iso8859-8 - latin-iso8859-9 latin-iso8859-14 latin-iso8859-15))) - (dolist (encoder encoder-list) - (let ((table (get encoder 'translation-table))) - (dolist (charset charset-list) - (dotimes (i 96) - (let* ((c (make-char charset (+ i 32))) - (mu (aref ucs-mule-to-mule-unicode c)) - (mac-encoded (and mu (aref table mu)))) - (if mac-encoded - (aset table c mac-encoded)))))))) - -(define-ccl-program ccl-encode-mac-centraleurroman-font - `(0 - (if (r0 != ,(charset-id 'ascii)) - (if (r0 <= ?\x8f) - (translate-character mac-centraleurroman-encoder r0 r1) - ((r1 <<= 7) - (r1 |= r2) - (translate-character mac-centraleurroman-encoder r0 r1))))) - "CCL program for Mac Central European Roman font") - -(define-ccl-program ccl-encode-mac-cyrillic-font - `(0 - (if (r0 != ,(charset-id 'ascii)) - (if (r0 <= ?\x8f) - (translate-character mac-cyrillic-encoder r0 r1) - ((r1 <<= 7) - (r1 |= r2) - (translate-character mac-cyrillic-encoder r0 r1))))) - "CCL program for Mac Cyrillic font") - - -(setq font-ccl-encoder-alist - (nconc - (mapcar (lambda (lst) (cons (nth 0 lst) (nth 2 lst))) - mac-font-encoder-list) - font-ccl-encoder-alist)) - -(defun fontset-add-mac-fonts (fontset &optional base-family) - (if base-family - (setq base-family (downcase base-family)) - (let ((ascii-font - (downcase (x-resolve-font-name - (fontset-font fontset (charset-id 'ascii)))))) - (setq base-family (aref (x-decompose-font-name ascii-font) - xlfd-regexp-family-subnum)))) -;; (if (not (string-match "^fontset-" fontset)) -;; (setq fontset -;; (concat "fontset-" (aref (x-decompose-font-name fontset) -;; xlfd-regexp-encoding-subnum)))) - (dolist - (font-encoder - (nreverse - (mapcar (lambda (lst) - (cons (cons (format (nth 3 lst) base-family) (nth 0 lst)) - (nth 1 lst))) - mac-font-encoder-list))) - (let ((font (car font-encoder)) - (encoder (cdr font-encoder))) - (map-char-table - (lambda (key val) - (or (null val) - (generic-char-p key) - (memq (char-charset key) - '(ascii eight-bit-control eight-bit-graphic)) - (set-fontset-font fontset key font))) - (get encoder 'translation-table))))) - -(defun create-fontset-from-mac-roman-font (font &optional resolved-font - fontset-name) - "Create a fontset from a Mac roman font FONT. - -Optional 1st arg RESOLVED-FONT is a resolved name of FONT. If -omitted, `x-resolve-font-name' is called to get the resolved name. At -this time, if FONT is not available, error is signaled. - -Optional 2nd arg FONTSET-NAME is a string to be used in -`<CHARSET_ENCODING>' fields of a new fontset name. If it is omitted, -an appropriate name is generated automatically. - -It returns a name of the created fontset." - (let ((fontset - (create-fontset-from-ascii-font font resolved-font fontset-name))) - (fontset-add-mac-fonts fontset) - fontset)) - -;; Create a fontset that uses mac-roman font. With this fontset, -;; characters decoded from mac-roman encoding (ascii, latin-iso8859-1, -;; and mule-unicode-xxxx-yyyy) are displayed by a mac-roman font. - -(if (fboundp 'new-fontset) - (progn - (require 'fontset) - (setup-default-fontset) - (create-fontset-from-fontset-spec - "-etl-fixed-medium-r-normal-*-16-*-*-*-*-*-fontset-mac, -ascii:-*-Monaco-*-*-*-*-12-*-*-*-*-*-mac-roman") - (fontset-add-mac-fonts "fontset-mac"))) - -(if (eq system-type 'darwin) - ;; On Darwin filenames are encoded in UTF-8 - (setq file-name-coding-system 'utf-8) - ;; To display filenames in Chinese or Japanese, replace mac-roman with - ;; big5 or sjis - (setq file-name-coding-system 'mac-roman)) - -;; If Emacs is started from the Finder, change the default directory -;; to the user's home directory. -(if (string= default-directory "/") - (cd "~")) - -;; Tell Emacs to use pipes instead of pty's for processes because the -;; latter sometimes lose characters. Pty support is compiled in since -;; ange-ftp will not work without it. -(setq process-connection-type nil) - -;; Assume that fonts are always scalable on the Mac. This sometimes -;; results in characters with jagged edges. However, without it, -;; fonts with both truetype and bitmap representations but no italic -;; or bold bitmap versions will not display these variants correctly. -(setq scalable-fonts-allowed t) - -;; Make suspend-emacs [C-z] collapse the current frame -(substitute-key-definition 'suspend-emacs 'iconify-frame - global-map) - -;; Support mouse-wheel scrolling -(mouse-wheel-mode 1) - -;; (prefer-coding-system 'mac-roman) - -;; Map certain keypad keys into ASCII characters that people usually expect -(define-key function-key-map [return] [?\C-m]) -(define-key function-key-map [M-return] [?\M-\C-m]) -(define-key function-key-map [tab] [?\t]) -(define-key function-key-map [M-tab] [?\M-\t]) -(define-key function-key-map [backspace] [127]) -(define-key function-key-map [M-backspace] [?\M-\d]) -(define-key function-key-map [escape] [?\e]) -(define-key function-key-map [M-escape] [?\M-\e]) - -;; Tell read-char how to convert special chars to ASCII -(put 'return 'ascii-character 13) -(put 'tab 'ascii-character ?\t) -(put 'backspace 'ascii-character 127) -(put 'escape 'ascii-character ?\e) +(defun x-handle-display (switch) + (setq x-display-name (car x-invocation-args) + x-invocation-args (cdr x-invocation-args))) +(defun x-handle-args (args) + "Process the X-related command line options in ARGS. +This is done before the user's startup file is loaded. They are copied to +`x-invocation-args', from which the X-related things are extracted, first +the switch (e.g., \"-fg\") in the following code, and possible values +\(e.g., \"black\") in the option handler code (e.g., x-handle-switch). +This function returns ARGS minus the arguments that have been processed." + ;; We use ARGS to accumulate the args that we don't handle here, to return. + (setq x-invocation-args args + args nil) + (while (and x-invocation-args + (not (equal (car x-invocation-args) "--"))) + (let* ((this-switch (car x-invocation-args)) + (orig-this-switch this-switch) + completion argval aelt handler) + (setq x-invocation-args (cdr x-invocation-args)) + ;; Check for long options with attached arguments + ;; and separate out the attached option argument into argval. + (if (string-match "^--[^=]*=" this-switch) + (setq argval (substring this-switch (match-end 0)) + this-switch (substring this-switch 0 (1- (match-end 0))))) + ;; Complete names of long options. + (if (string-match "^--" this-switch) + (progn + (setq completion (try-completion this-switch command-line-x-option-alist)) + (if (eq completion t) + ;; Exact match for long option. + nil + (if (stringp completion) + (let ((elt (assoc completion command-line-x-option-alist))) + ;; Check for abbreviated long option. + (or elt + (error "Option `%s' is ambiguous" this-switch)) + (setq this-switch completion)))))) + (setq aelt (assoc this-switch command-line-x-option-alist)) + (if aelt (setq handler (nth 2 aelt))) + (if handler + (if argval + (let ((x-invocation-args + (cons argval x-invocation-args))) + (funcall handler this-switch)) + (funcall handler this-switch)) + (setq args (cons orig-this-switch args))))) + (nconc (nreverse args) x-invocation-args)) + ;; ;; Available colors ;; @@ -1407,8 +986,723 @@ ascii:-*-Monaco-*-*-*-*-12-*-*-*-*-*-mac-roman") "GhostWhite" "ghost white" "snow") - "The list of X colors from the `rgb.txt' file. + "The list of X colors from the `rgb.txt' file. XConsortium: rgb.txt,v 10.41 94/02/20 18:39:36 rws Exp") +(defun xw-defined-colors (&optional frame) + "Internal function called by `defined-colors', which see." + (or frame (setq frame (selected-frame))) + (let ((all-colors x-colors) + (this-color nil) + (defined-colors nil)) + (while all-colors + (setq this-color (car all-colors) + all-colors (cdr all-colors)) + (and (color-supported-p this-color frame t) + (setq defined-colors (cons this-color defined-colors)))) + defined-colors)) + +;;;; Function keys + +(substitute-key-definition 'suspend-emacs 'iconify-or-deiconify-frame + global-map) + +;; Map certain keypad keys into ASCII characters +;; that people usually expect. +(define-key function-key-map [return] [?\C-m]) +(define-key function-key-map [M-return] [?\M-\C-m]) +(define-key function-key-map [tab] [?\t]) +(define-key function-key-map [M-tab] [?\M-\t]) +(define-key function-key-map [backspace] [127]) +(define-key function-key-map [M-backspace] [?\M-\d]) +(define-key function-key-map [escape] [?\e]) +(define-key function-key-map [M-escape] [?\M-\e]) + +;; These tell read-char how to convert +;; these special chars to ASCII. +(put 'return 'ascii-character 13) +(put 'tab 'ascii-character ?\t) +(put 'backspace 'ascii-character 127) +(put 'escape 'ascii-character ?\e) + + +;;;; Keysyms + +;; Define constant values to be set to mac-keyboard-text-encoding +(defconst kTextEncodingMacRoman 0) +(defconst kTextEncodingISOLatin1 513 "0x201") +(defconst kTextEncodingISOLatin2 514 "0x202") + + +;;;; Selections and cut buffers + +;; Setup to use the Mac clipboard. The functions mac-cut-function and +;; mac-paste-function are defined in mac.c. +(set-selection-coding-system 'compound-text-mac) + +(setq interprogram-cut-function + '(lambda (str push) + (mac-cut-function + (encode-coding-string str selection-coding-system t) push))) + +(setq interprogram-paste-function + '(lambda () + (let ((clipboard (mac-paste-function))) + (if clipboard + (decode-coding-string clipboard selection-coding-system t))))) + + +;;; Do the actual Windows setup here; the above code just defines +;;; functions and variables that we use now. + +(setq command-line-args (x-handle-args command-line-args)) + +;;; Make sure we have a valid resource name. +(or (stringp x-resource-name) + (let (i) + (setq x-resource-name (invocation-name)) + + ;; Change any . or * characters in x-resource-name to hyphens, + ;; so as not to choke when we use it in X resource queries. + (while (setq i (string-match "[.*]" x-resource-name)) + (aset x-resource-name i ?-)))) + +(if (x-display-list) + ;; On Mac OS 8/9, Most coding systems used in code conversion for + ;; font names are not ready at the time when the terminal frame is + ;; created. So we reconstruct font name table for the initial + ;; frame. + (mac-clear-font-name-table) + (x-open-connection "Mac" + x-command-line-resources + ;; Exit Emacs with fatal error if this fails. + t)) + +(setq frame-creation-function 'x-create-frame-with-faces) + +(define-ccl-program ccl-encode-mac-roman-font + `(0 + (if (r0 != ,(charset-id 'ascii)) + (if (r0 <= ?\x8f) + (translate-character mac-roman-encoder r0 r1) + ((r1 <<= 7) + (r1 |= r2) + (translate-character mac-roman-encoder r0 r1))))) + "CCL program for Mac Roman font") + +(let + ((encoding-vector (make-vector 256 nil)) + (i 0) + (vec ;; mac-centraleurroman (128..255) -> UCS mapping + [ #x00C4 ;; 128:LATIN CAPITAL LETTER A WITH DIAERESIS + #x0100 ;; 129:LATIN CAPITAL LETTER A WITH MACRON + #x0101 ;; 130:LATIN SMALL LETTER A WITH MACRON + #x00C9 ;; 131:LATIN CAPITAL LETTER E WITH ACUTE + #x0104 ;; 132:LATIN CAPITAL LETTER A WITH OGONEK + #x00D6 ;; 133:LATIN CAPITAL LETTER O WITH DIAERESIS + #x00DC ;; 134:LATIN CAPITAL LETTER U WITH DIAERESIS + #x00E1 ;; 135:LATIN SMALL LETTER A WITH ACUTE + #x0105 ;; 136:LATIN SMALL LETTER A WITH OGONEK + #x010C ;; 137:LATIN CAPITAL LETTER C WITH CARON + #x00E4 ;; 138:LATIN SMALL LETTER A WITH DIAERESIS + #x010D ;; 139:LATIN SMALL LETTER C WITH CARON + #x0106 ;; 140:LATIN CAPITAL LETTER C WITH ACUTE + #x0107 ;; 141:LATIN SMALL LETTER C WITH ACUTE + #x00E9 ;; 142:LATIN SMALL LETTER E WITH ACUTE + #x0179 ;; 143:LATIN CAPITAL LETTER Z WITH ACUTE + #x017A ;; 144:LATIN SMALL LETTER Z WITH ACUTE + #x010E ;; 145:LATIN CAPITAL LETTER D WITH CARON + #x00ED ;; 146:LATIN SMALL LETTER I WITH ACUTE + #x010F ;; 147:LATIN SMALL LETTER D WITH CARON + #x0112 ;; 148:LATIN CAPITAL LETTER E WITH MACRON + #x0113 ;; 149:LATIN SMALL LETTER E WITH MACRON + #x0116 ;; 150:LATIN CAPITAL LETTER E WITH DOT ABOVE + #x00F3 ;; 151:LATIN SMALL LETTER O WITH ACUTE + #x0117 ;; 152:LATIN SMALL LETTER E WITH DOT ABOVE + #x00F4 ;; 153:LATIN SMALL LETTER O WITH CIRCUMFLEX + #x00F6 ;; 154:LATIN SMALL LETTER O WITH DIAERESIS + #x00F5 ;; 155:LATIN SMALL LETTER O WITH TILDE + #x00FA ;; 156:LATIN SMALL LETTER U WITH ACUTE + #x011A ;; 157:LATIN CAPITAL LETTER E WITH CARON + #x011B ;; 158:LATIN SMALL LETTER E WITH CARON + #x00FC ;; 159:LATIN SMALL LETTER U WITH DIAERESIS + #x2020 ;; 160:DAGGER + #x00B0 ;; 161:DEGREE SIGN + #x0118 ;; 162:LATIN CAPITAL LETTER E WITH OGONEK + #x00A3 ;; 163:POUND SIGN + #x00A7 ;; 164:SECTION SIGN + #x2022 ;; 165:BULLET + #x00B6 ;; 166:PILCROW SIGN + #x00DF ;; 167:LATIN SMALL LETTER SHARP S + #x00AE ;; 168:REGISTERED SIGN + #x00A9 ;; 169:COPYRIGHT SIGN + #x2122 ;; 170:TRADE MARK SIGN + #x0119 ;; 171:LATIN SMALL LETTER E WITH OGONEK + #x00A8 ;; 172:DIAERESIS + #x2260 ;; 173:NOT EQUAL TO + #x0123 ;; 174:LATIN SMALL LETTER G WITH CEDILLA + #x012E ;; 175:LATIN CAPITAL LETTER I WITH OGONEK + #x012F ;; 176:LATIN SMALL LETTER I WITH OGONEK + #x012A ;; 177:LATIN CAPITAL LETTER I WITH MACRON + #x2264 ;; 178:LESS-THAN OR EQUAL TO + #x2265 ;; 179:GREATER-THAN OR EQUAL TO + #x012B ;; 180:LATIN SMALL LETTER I WITH MACRON + #x0136 ;; 181:LATIN CAPITAL LETTER K WITH CEDILLA + #x2202 ;; 182:PARTIAL DIFFERENTIAL + #x2211 ;; 183:N-ARY SUMMATION + #x0142 ;; 184:LATIN SMALL LETTER L WITH STROKE + #x013B ;; 185:LATIN CAPITAL LETTER L WITH CEDILLA + #x013C ;; 186:LATIN SMALL LETTER L WITH CEDILLA + #x013D ;; 187:LATIN CAPITAL LETTER L WITH CARON + #x013E ;; 188:LATIN SMALL LETTER L WITH CARON + #x0139 ;; 189:LATIN CAPITAL LETTER L WITH ACUTE + #x013A ;; 190:LATIN SMALL LETTER L WITH ACUTE + #x0145 ;; 191:LATIN CAPITAL LETTER N WITH CEDILLA + #x0146 ;; 192:LATIN SMALL LETTER N WITH CEDILLA + #x0143 ;; 193:LATIN CAPITAL LETTER N WITH ACUTE + #x00AC ;; 194:NOT SIGN + #x221A ;; 195:SQUARE ROOT + #x0144 ;; 196:LATIN SMALL LETTER N WITH ACUTE + #x0147 ;; 197:LATIN CAPITAL LETTER N WITH CARON + #x2206 ;; 198:INCREMENT + #x00AB ;; 199:LEFT-POINTING DOUBLE ANGLE QUOTATION MARK + #x00BB ;; 200:RIGHT-POINTING DOUBLE ANGLE QUOTATION MARK + #x2026 ;; 201:HORIZONTAL ELLIPSIS + #x00A0 ;; 202:NO-BREAK SPACE + #x0148 ;; 203:LATIN SMALL LETTER N WITH CARON + #x0150 ;; 204:LATIN CAPITAL LETTER O WITH DOUBLE ACUTE + #x00D5 ;; 205:LATIN CAPITAL LETTER O WITH TILDE + #x0151 ;; 206:LATIN SMALL LETTER O WITH DOUBLE ACUTE + #x014C ;; 207:LATIN CAPITAL LETTER O WITH MACRON + #x2013 ;; 208:EN DASH + #x2014 ;; 209:EM DASH + #x201C ;; 210:LEFT DOUBLE QUOTATION MARK + #x201D ;; 211:RIGHT DOUBLE QUOTATION MARK + #x2018 ;; 212:LEFT SINGLE QUOTATION MARK + #x2019 ;; 213:RIGHT SINGLE QUOTATION MARK + #x00F7 ;; 214:DIVISION SIGN + #x25CA ;; 215:LOZENGE + #x014D ;; 216:LATIN SMALL LETTER O WITH MACRON + #x0154 ;; 217:LATIN CAPITAL LETTER R WITH ACUTE + #x0155 ;; 218:LATIN SMALL LETTER R WITH ACUTE + #x0158 ;; 219:LATIN CAPITAL LETTER R WITH CARON + #x2039 ;; 220:SINGLE LEFT-POINTING ANGLE QUOTATION MARK + #x203A ;; 221:SINGLE RIGHT-POINTING ANGLE QUOTATION MARK + #x0159 ;; 222:LATIN SMALL LETTER R WITH CARON + #x0156 ;; 223:LATIN CAPITAL LETTER R WITH CEDILLA + #x0157 ;; 224:LATIN SMALL LETTER R WITH CEDILLA + #x0160 ;; 225:LATIN CAPITAL LETTER S WITH CARON + #x201A ;; 226:SINGLE LOW-9 QUOTATION MARK + #x201E ;; 227:DOUBLE LOW-9 QUOTATION MARK + #x0161 ;; 228:LATIN SMALL LETTER S WITH CARON + #x015A ;; 229:LATIN CAPITAL LETTER S WITH ACUTE + #x015B ;; 230:LATIN SMALL LETTER S WITH ACUTE + #x00C1 ;; 231:LATIN CAPITAL LETTER A WITH ACUTE + #x0164 ;; 232:LATIN CAPITAL LETTER T WITH CARON + #x0165 ;; 233:LATIN SMALL LETTER T WITH CARON + #x00CD ;; 234:LATIN CAPITAL LETTER I WITH ACUTE + #x017D ;; 235:LATIN CAPITAL LETTER Z WITH CARON + #x017E ;; 236:LATIN SMALL LETTER Z WITH CARON + #x016A ;; 237:LATIN CAPITAL LETTER U WITH MACRON + #x00D3 ;; 238:LATIN CAPITAL LETTER O WITH ACUTE + #x00D4 ;; 239:LATIN CAPITAL LETTER O WITH CIRCUMFLEX + #x016B ;; 240:LATIN SMALL LETTER U WITH MACRON + #x016E ;; 241:LATIN CAPITAL LETTER U WITH RING ABOVE + #x00DA ;; 242:LATIN CAPITAL LETTER U WITH ACUTE + #x016F ;; 243:LATIN SMALL LETTER U WITH RING ABOVE + #x0170 ;; 244:LATIN CAPITAL LETTER U WITH DOUBLE ACUTE + #x0171 ;; 245:LATIN SMALL LETTER U WITH DOUBLE ACUTE + #x0172 ;; 246:LATIN CAPITAL LETTER U WITH OGONEK + #x0173 ;; 247:LATIN SMALL LETTER U WITH OGONEK + #x00DD ;; 248:LATIN CAPITAL LETTER Y WITH ACUTE + #x00FD ;; 249:LATIN SMALL LETTER Y WITH ACUTE + #x0137 ;; 250:LATIN SMALL LETTER K WITH CEDILLA + #x017B ;; 251:LATIN CAPITAL LETTER Z WITH DOT ABOVE + #x0141 ;; 252:LATIN CAPITAL LETTER L WITH STROKE + #x017C ;; 253:LATIN SMALL LETTER Z WITH DOT ABOVE + #x0122 ;; 254:LATIN CAPITAL LETTER G WITH CEDILLA + #x02C7 ;; 255:CARON + ]) + translation-table) + (while (< i 128) + (aset encoding-vector i i) + (setq i (1+ i))) + (while (< i 256) + (aset encoding-vector i + (decode-char 'ucs (aref vec (- i 128)))) + (setq i (1+ i))) + (setq translation-table + (make-translation-table-from-vector encoding-vector)) +;; (define-translation-table 'mac-centraleurroman-decoder translation-table) + (define-translation-table 'mac-centraleurroman-encoder + (char-table-extra-slot translation-table 0))) + +(let + ((encoding-vector (make-vector 256 nil)) + (i 0) + (vec ;; mac-cyrillic (128..255) -> UCS mapping + [ #x0410 ;; 128:CYRILLIC CAPITAL LETTER A + #x0411 ;; 129:CYRILLIC CAPITAL LETTER BE + #x0412 ;; 130:CYRILLIC CAPITAL LETTER VE + #x0413 ;; 131:CYRILLIC CAPITAL LETTER GHE + #x0414 ;; 132:CYRILLIC CAPITAL LETTER DE + #x0415 ;; 133:CYRILLIC CAPITAL LETTER IE + #x0416 ;; 134:CYRILLIC CAPITAL LETTER ZHE + #x0417 ;; 135:CYRILLIC CAPITAL LETTER ZE + #x0418 ;; 136:CYRILLIC CAPITAL LETTER I + #x0419 ;; 137:CYRILLIC CAPITAL LETTER SHORT I + #x041A ;; 138:CYRILLIC CAPITAL LETTER KA + #x041B ;; 139:CYRILLIC CAPITAL LETTER EL + #x041C ;; 140:CYRILLIC CAPITAL LETTER EM + #x041D ;; 141:CYRILLIC CAPITAL LETTER EN + #x041E ;; 142:CYRILLIC CAPITAL LETTER O + #x041F ;; 143:CYRILLIC CAPITAL LETTER PE + #x0420 ;; 144:CYRILLIC CAPITAL LETTER ER + #x0421 ;; 145:CYRILLIC CAPITAL LETTER ES + #x0422 ;; 146:CYRILLIC CAPITAL LETTER TE + #x0423 ;; 147:CYRILLIC CAPITAL LETTER U + #x0424 ;; 148:CYRILLIC CAPITAL LETTER EF + #x0425 ;; 149:CYRILLIC CAPITAL LETTER HA + #x0426 ;; 150:CYRILLIC CAPITAL LETTER TSE + #x0427 ;; 151:CYRILLIC CAPITAL LETTER CHE + #x0428 ;; 152:CYRILLIC CAPITAL LETTER SHA + #x0429 ;; 153:CYRILLIC CAPITAL LETTER SHCHA + #x042A ;; 154:CYRILLIC CAPITAL LETTER HARD SIGN + #x042B ;; 155:CYRILLIC CAPITAL LETTER YERU + #x042C ;; 156:CYRILLIC CAPITAL LETTER SOFT SIGN + #x042D ;; 157:CYRILLIC CAPITAL LETTER E + #x042E ;; 158:CYRILLIC CAPITAL LETTER YU + #x042F ;; 159:CYRILLIC CAPITAL LETTER YA + #x2020 ;; 160:DAGGER + #x00B0 ;; 161:DEGREE SIGN + #x0490 ;; 162:CYRILLIC CAPITAL LETTER GHE WITH UPTURN + #x00A3 ;; 163:POUND SIGN + #x00A7 ;; 164:SECTION SIGN + #x2022 ;; 165:BULLET + #x00B6 ;; 166:PILCROW SIGN + #x0406 ;; 167:CYRILLIC CAPITAL LETTER BYELORUSSIAN-UKRAINIAN I + #x00AE ;; 168:REGISTERED SIGN + #x00A9 ;; 169:COPYRIGHT SIGN + #x2122 ;; 170:TRADE MARK SIGN + #x0402 ;; 171:CYRILLIC CAPITAL LETTER DJE + #x0452 ;; 172:CYRILLIC SMALL LETTER DJE + #x2260 ;; 173:NOT EQUAL TO + #x0403 ;; 174:CYRILLIC CAPITAL LETTER GJE + #x0453 ;; 175:CYRILLIC SMALL LETTER GJE + #x221E ;; 176:INFINITY + #x00B1 ;; 177:PLUS-MINUS SIGN + #x2264 ;; 178:LESS-THAN OR EQUAL TO + #x2265 ;; 179:GREATER-THAN OR EQUAL TO + #x0456 ;; 180:CYRILLIC SMALL LETTER BYELORUSSIAN-UKRAINIAN I + #x00B5 ;; 181:MICRO SIGN + #x0491 ;; 182:CYRILLIC SMALL LETTER GHE WITH UPTURN + #x0408 ;; 183:CYRILLIC CAPITAL LETTER JE + #x0404 ;; 184:CYRILLIC CAPITAL LETTER UKRAINIAN IE + #x0454 ;; 185:CYRILLIC SMALL LETTER UKRAINIAN IE + #x0407 ;; 186:CYRILLIC CAPITAL LETTER YI + #x0457 ;; 187:CYRILLIC SMALL LETTER YI + #x0409 ;; 188:CYRILLIC CAPITAL LETTER LJE + #x0459 ;; 189:CYRILLIC SMALL LETTER LJE + #x040A ;; 190:CYRILLIC CAPITAL LETTER NJE + #x045A ;; 191:CYRILLIC SMALL LETTER NJE + #x0458 ;; 192:CYRILLIC SMALL LETTER JE + #x0405 ;; 193:CYRILLIC CAPITAL LETTER DZE + #x00AC ;; 194:NOT SIGN + #x221A ;; 195:SQUARE ROOT + #x0192 ;; 196:LATIN SMALL LETTER F WITH HOOK + #x2248 ;; 197:ALMOST EQUAL TO + #x2206 ;; 198:INCREMENT + #x00AB ;; 199:LEFT-POINTING DOUBLE ANGLE QUOTATION MARK + #x00BB ;; 200:RIGHT-POINTING DOUBLE ANGLE QUOTATION MARK + #x2026 ;; 201:HORIZONTAL ELLIPSIS + #x00A0 ;; 202:NO-BREAK SPACE + #x040B ;; 203:CYRILLIC CAPITAL LETTER TSHE + #x045B ;; 204:CYRILLIC SMALL LETTER TSHE + #x040C ;; 205:CYRILLIC CAPITAL LETTER KJE + #x045C ;; 206:CYRILLIC SMALL LETTER KJE + #x0455 ;; 207:CYRILLIC SMALL LETTER DZE + #x2013 ;; 208:EN DASH + #x2014 ;; 209:EM DASH + #x201C ;; 210:LEFT DOUBLE QUOTATION MARK + #x201D ;; 211:RIGHT DOUBLE QUOTATION MARK + #x2018 ;; 212:LEFT SINGLE QUOTATION MARK + #x2019 ;; 213:RIGHT SINGLE QUOTATION MARK + #x00F7 ;; 214:DIVISION SIGN + #x201E ;; 215:DOUBLE LOW-9 QUOTATION MARK + #x040E ;; 216:CYRILLIC CAPITAL LETTER SHORT U + #x045E ;; 217:CYRILLIC SMALL LETTER SHORT U + #x040F ;; 218:CYRILLIC CAPITAL LETTER DZHE + #x045F ;; 219:CYRILLIC SMALL LETTER DZHE + #x2116 ;; 220:NUMERO SIGN + #x0401 ;; 221:CYRILLIC CAPITAL LETTER IO + #x0451 ;; 222:CYRILLIC SMALL LETTER IO + #x044F ;; 223:CYRILLIC SMALL LETTER YA + #x0430 ;; 224:CYRILLIC SMALL LETTER A + #x0431 ;; 225:CYRILLIC SMALL LETTER BE + #x0432 ;; 226:CYRILLIC SMALL LETTER VE + #x0433 ;; 227:CYRILLIC SMALL LETTER GHE + #x0434 ;; 228:CYRILLIC SMALL LETTER DE + #x0435 ;; 229:CYRILLIC SMALL LETTER IE + #x0436 ;; 230:CYRILLIC SMALL LETTER ZHE + #x0437 ;; 231:CYRILLIC SMALL LETTER ZE + #x0438 ;; 232:CYRILLIC SMALL LETTER I + #x0439 ;; 233:CYRILLIC SMALL LETTER SHORT I + #x043A ;; 234:CYRILLIC SMALL LETTER KA + #x043B ;; 235:CYRILLIC SMALL LETTER EL + #x043C ;; 236:CYRILLIC SMALL LETTER EM + #x043D ;; 237:CYRILLIC SMALL LETTER EN + #x043E ;; 238:CYRILLIC SMALL LETTER O + #x043F ;; 239:CYRILLIC SMALL LETTER PE + #x0440 ;; 240:CYRILLIC SMALL LETTER ER + #x0441 ;; 241:CYRILLIC SMALL LETTER ES + #x0442 ;; 242:CYRILLIC SMALL LETTER TE + #x0443 ;; 243:CYRILLIC SMALL LETTER U + #x0444 ;; 244:CYRILLIC SMALL LETTER EF + #x0445 ;; 245:CYRILLIC SMALL LETTER HA + #x0446 ;; 246:CYRILLIC SMALL LETTER TSE + #x0447 ;; 247:CYRILLIC SMALL LETTER CHE + #x0448 ;; 248:CYRILLIC SMALL LETTER SHA + #x0449 ;; 249:CYRILLIC SMALL LETTER SHCHA + #x044A ;; 250:CYRILLIC SMALL LETTER HARD SIGN + #x044B ;; 251:CYRILLIC SMALL LETTER YERU + #x044C ;; 252:CYRILLIC SMALL LETTER SOFT SIGN + #x044D ;; 253:CYRILLIC SMALL LETTER E + #x044E ;; 254:CYRILLIC SMALL LETTER YU + #x20AC ;; 255:EURO SIGN + ]) + translation-table) + (while (< i 128) + (aset encoding-vector i i) + (setq i (1+ i))) + (while (< i 256) + (aset encoding-vector i + (decode-char 'ucs (aref vec (- i 128)))) + (setq i (1+ i))) + (setq translation-table + (make-translation-table-from-vector encoding-vector)) +;; (define-translation-table 'mac-cyrillic-decoder translation-table) + (define-translation-table 'mac-cyrillic-encoder + (char-table-extra-slot translation-table 0))) + +(defvar mac-font-encoder-list + '(("mac-roman" mac-roman-encoder + ccl-encode-mac-roman-font "%s") + ("mac-centraleurroman" mac-centraleurroman-encoder + ccl-encode-mac-centraleurroman-font "%s ce") + ("mac-cyrillic" mac-cyrillic-encoder + ccl-encode-mac-cyrillic-font "%s cy"))) + +(let ((encoder-list + (mapcar (lambda (lst) (nth 1 lst)) mac-font-encoder-list)) + (charset-list + '(latin-iso8859-2 + latin-iso8859-3 latin-iso8859-4 + cyrillic-iso8859-5 greek-iso8859-7 hebrew-iso8859-8 + latin-iso8859-9 latin-iso8859-14 latin-iso8859-15))) + (dolist (encoder encoder-list) + (let ((table (get encoder 'translation-table))) + (dolist (charset charset-list) + (dotimes (i 96) + (let* ((c (make-char charset (+ i 32))) + (mu (aref ucs-mule-to-mule-unicode c)) + (mac-encoded (and mu (aref table mu)))) + (if mac-encoded + (aset table c mac-encoded)))))))) + +(define-ccl-program ccl-encode-mac-centraleurroman-font + `(0 + (if (r0 != ,(charset-id 'ascii)) + (if (r0 <= ?\x8f) + (translate-character mac-centraleurroman-encoder r0 r1) + ((r1 <<= 7) + (r1 |= r2) + (translate-character mac-centraleurroman-encoder r0 r1))))) + "CCL program for Mac Central European Roman font") + +(define-ccl-program ccl-encode-mac-cyrillic-font + `(0 + (if (r0 != ,(charset-id 'ascii)) + (if (r0 <= ?\x8f) + (translate-character mac-cyrillic-encoder r0 r1) + ((r1 <<= 7) + (r1 |= r2) + (translate-character mac-cyrillic-encoder r0 r1))))) + "CCL program for Mac Cyrillic font") + + +(setq font-ccl-encoder-alist + (nconc + (mapcar (lambda (lst) (cons (nth 0 lst) (nth 2 lst))) + mac-font-encoder-list) + font-ccl-encoder-alist)) + +(defun fontset-add-mac-fonts (fontset &optional base-family) + (if base-family + (setq base-family (downcase base-family)) + (let ((ascii-font + (downcase (x-resolve-font-name + (fontset-font fontset (charset-id 'ascii)))))) + (setq base-family (aref (x-decompose-font-name ascii-font) + xlfd-regexp-family-subnum)))) +;; (if (not (string-match "^fontset-" fontset)) +;; (setq fontset +;; (concat "fontset-" (aref (x-decompose-font-name fontset) +;; xlfd-regexp-encoding-subnum)))) + (dolist + (font-encoder + (nreverse + (mapcar (lambda (lst) + (cons (cons (format (nth 3 lst) base-family) (nth 0 lst)) + (nth 1 lst))) + mac-font-encoder-list))) + (let ((font (car font-encoder)) + (encoder (cdr font-encoder))) + (map-char-table + (lambda (key val) + (or (null val) + (generic-char-p key) + (memq (char-charset key) + '(ascii eight-bit-control eight-bit-graphic)) + (set-fontset-font fontset key font))) + (get encoder 'translation-table))))) + +(defun create-fontset-from-mac-roman-font (font &optional resolved-font + fontset-name) + "Create a fontset from a Mac roman font FONT. + +Optional 1st arg RESOLVED-FONT is a resolved name of FONT. If +omitted, `x-resolve-font-name' is called to get the resolved name. At +this time, if FONT is not available, error is signaled. + +Optional 2nd arg FONTSET-NAME is a string to be used in +`<CHARSET_ENCODING>' fields of a new fontset name. If it is omitted, +an appropriate name is generated automatically. + +It returns a name of the created fontset." + (let ((fontset + (create-fontset-from-ascii-font font resolved-font fontset-name))) + (fontset-add-mac-fonts fontset) + fontset)) + +;; Setup the default fontset. +(setup-default-fontset) + +;; Create a fontset that uses mac-roman font. With this fontset, +;; characters decoded from mac-roman encoding (ascii, latin-iso8859-1, +;; and mule-unicode-xxxx-yyyy) are displayed by a mac-roman font. +(create-fontset-from-fontset-spec + "-etl-fixed-medium-r-normal-*-16-*-*-*-*-*-fontset-mac, +ascii:-*-Monaco-*-*-*-*-12-*-*-*-*-*-mac-roman") +(fontset-add-mac-fonts "fontset-mac") + +;; Create fontset specified in X resources "Fontset-N" (N is 0, 1, ...). +(create-fontset-from-x-resource) + +;; Try to create a fontset from a font specification which comes +;; from initial-frame-alist, default-frame-alist, or X resource. +;; A font specification in command line argument (i.e. -fn XXXX) +;; should be already in default-frame-alist as a `font' +;; parameter. However, any font specifications in site-start +;; library, user's init file (.emacs), and default.el are not +;; yet handled here. + +(let ((font (or (cdr (assq 'font initial-frame-alist)) + (cdr (assq 'font default-frame-alist)) + (x-get-resource "font" "Font"))) + xlfd-fields resolved-name) + (if (and font + (not (query-fontset font)) + (setq resolved-name (x-resolve-font-name font)) + (setq xlfd-fields (x-decompose-font-name font))) + (if (string= "fontset" (aref xlfd-fields xlfd-regexp-registry-subnum)) + (new-fontset font (x-complement-fontset-spec xlfd-fields nil)) + ;; Create a fontset from FONT. The fontset name is + ;; generated from FONT. + (create-fontset-from-ascii-font font resolved-name "startup")))) + +;; Apply a geometry resource to the initial frame. Put it at the end +;; of the alist, so that anything specified on the command line takes +;; precedence. +(let* ((res-geometry (x-get-resource "geometry" "Geometry")) + parsed) + (if res-geometry + (progn + (setq parsed (x-parse-geometry res-geometry)) + ;; If the resource specifies a position, + ;; call the position and size "user-specified". + (if (or (assq 'top parsed) (assq 'left parsed)) + (setq parsed (cons '(user-position . t) + (cons '(user-size . t) parsed)))) + ;; All geometry parms apply to the initial frame. + (setq initial-frame-alist (append initial-frame-alist parsed)) + ;; The size parms apply to all frames. + (if (assq 'height parsed) + (setq default-frame-alist + (cons (cons 'height (cdr (assq 'height parsed))) + default-frame-alist))) + (if (assq 'width parsed) + (setq default-frame-alist + (cons (cons 'width (cdr (assq 'width parsed))) + default-frame-alist)))))) + +;; Check the reverseVideo resource. +(let ((case-fold-search t)) + (let ((rv (x-get-resource "reverseVideo" "ReverseVideo"))) + (if (and rv + (string-match "^\\(true\\|yes\\|on\\)$" rv)) + (setq default-frame-alist + (cons '(reverse . t) default-frame-alist))))) + +(defun x-win-suspend-error () + (error "Suspending an Emacs running under Mac makes no sense")) +(add-hook 'suspend-hook 'x-win-suspend-error) + +;; Don't show the frame name; that's redundant. +(setq-default mode-line-frame-identification " ") + +;; Turn on support for mouse wheels. +(mouse-wheel-mode 1) + +(defun mac-drag-n-drop (event) + "Edit the files listed in the drag-n-drop event.\n\ +Switch to a buffer editing the last file dropped." + (interactive "e") + (save-excursion + ;; Make sure the drop target has positive co-ords + ;; before setting the selected frame - otherwise it + ;; won't work. <skx@tardis.ed.ac.uk> + (let* ((window (posn-window (event-start event))) + (coords (posn-x-y (event-start event))) + (x (car coords)) + (y (cdr coords))) + (if (and (> x 0) (> y 0)) + (set-frame-selected-window nil window)) + (mapcar + '(lambda (file) + (find-file + (decode-coding-string + file + (or file-name-coding-system + default-file-name-coding-system)))) + (car (cdr (cdr event))))) + (raise-frame) + (recenter))) + +(global-set-key [drag-n-drop] 'mac-drag-n-drop) + +;; By checking whether the variable mac-ready-for-drag-n-drop has been +;; defined, the event loop in macterm.c can be informed that it can +;; now receive Finder drag and drop events. Files dropped onto the +;; Emacs application icon can only be processed when the initial frame +;; has been created: this is where the files should be opened. +(add-hook 'after-init-hook + '(lambda () + (defvar mac-ready-for-drag-n-drop t))) + +;;;; Scroll bars + +;; for debugging +;; (defun mac-handle-scroll-bar-event (event) (interactive "e") (princ event)) + +;;(global-set-key [vertical-scroll-bar mouse-1] 'mac-handle-scroll-bar-event) + +(global-set-key + [vertical-scroll-bar down-mouse-1] + 'mac-handle-scroll-bar-event) + +(global-unset-key [vertical-scroll-bar drag-mouse-1]) +(global-unset-key [vertical-scroll-bar mouse-1]) + +(defun mac-handle-scroll-bar-event (event) + "Handle scroll bar EVENT to emulate Mac Toolbox style scrolling." + (interactive "e") + (let* ((position (event-start event)) + (window (nth 0 position)) + (bar-part (nth 4 position))) + (select-window window) + (cond + ((eq bar-part 'up) + (goto-char (window-start window)) + (mac-scroll-down-line)) + ((eq bar-part 'above-handle) + (mac-scroll-down)) + ((eq bar-part 'handle) + (scroll-bar-drag event)) + ((eq bar-part 'below-handle) + (mac-scroll-up)) + ((eq bar-part 'down) + (goto-char (window-start window)) + (mac-scroll-up-line))))) + +(defun mac-scroll-ignore-events () + ;; Ignore confusing non-mouse events + (while (not (memq (car-safe (read-event)) + '(mouse-1 double-mouse-1 triple-mouse-1))) nil)) + +(defun mac-scroll-down () + (track-mouse + (mac-scroll-ignore-events) + (scroll-down))) + +(defun mac-scroll-down-line () + (track-mouse + (mac-scroll-ignore-events) + (scroll-down 1))) + +(defun mac-scroll-up () + (track-mouse + (mac-scroll-ignore-events) + (scroll-up))) + +(defun mac-scroll-up-line () + (track-mouse + (mac-scroll-ignore-events) + (scroll-up 1))) + + +;;;; Others + +(unless (eq system-type 'darwin) + ;; This variable specifies the Unix program to call (as a process) to + ;; deteremine the amount of free space on a file system (defaults to + ;; df). If it is not set to nil, ls-lisp will not work correctly + ;; unless an external application df is implemented on the Mac. + (setq directory-free-space-program nil) + + ;; Set this so that Emacs calls subprocesses with "sh" as shell to + ;; expand filenames Note no subprocess for the shell is actually + ;; started (see run_mac_command in sysdep.c). + (setq shell-file-name "sh")) + +;; X Window emulation in macterm.c is not complete enough to start a +;; frame without a minibuffer properly. Call this to tell ediff +;; library to use a single frame. +; (ediff-toggle-multiframe) + +(if (eq system-type 'darwin) + ;; On Darwin filenames are encoded in UTF-8 + (setq file-name-coding-system 'utf-8) + ;; To display filenames in Chinese or Japanese, replace mac-roman with + ;; big5 or sjis + (setq file-name-coding-system 'mac-roman)) + +;; If Emacs is started from the Finder, change the default directory +;; to the user's home directory. +(if (string= default-directory "/") + (cd "~")) + +;; Tell Emacs to use pipes instead of pty's for processes because the +;; latter sometimes lose characters. Pty support is compiled in since +;; ange-ftp will not work without it. +(setq process-connection-type nil) + +;; Assume that fonts are always scalable on the Mac. This sometimes +;; results in characters with jagged edges. However, without it, +;; fonts with both truetype and bitmap representations but no italic +;; or bold bitmap versions will not display these variants correctly. +(setq scalable-fonts-allowed t) + +;; (prefer-coding-system 'mac-roman) + ;;; arch-tag: 71dfcd14-cde8-4d66-b05c-85ec94fb23a6 ;;; mac-win.el ends here diff --git a/lisp/textmodes/texinfmt.el b/lisp/textmodes/texinfmt.el index cc382b70528..470f4d4a1bd 100644 --- a/lisp/textmodes/texinfmt.el +++ b/lisp/textmodes/texinfmt.el @@ -378,6 +378,7 @@ if large. You can use Info-split to do this manually." (find-file outfile) (texinfo-mode) (erase-buffer) + (buffer-disable-undo) (message "Formatting Info file: %s" outfile) (setq texinfo-format-filename diff --git a/lisp/type-break.el b/lisp/type-break.el index ec96ab09fe2..b51a74ea37e 100644 --- a/lisp/type-break.el +++ b/lisp/type-break.el @@ -399,10 +399,6 @@ problems." (type-break-keystroke-reset) (type-break-mode-line-countdown-or-break nil) - (if (boundp 'save-some-buffers-always) - (add-to-list 'save-some-buffers-always - (expand-file-name type-break-file-name))) - (setq type-break-time-last-break (type-break-get-previous-time)) ;; schedule according to break time from session file @@ -437,13 +433,10 @@ problems." (do-auto-save) (with-current-buffer (find-file-noselect type-break-file-name 'nowarn) - (set-buffer-modified-p nil) + (setq buffer-save-without-query t) + (set-buffer-modified-p nil) (unlock-buffer) (kill-this-buffer)) - (if (boundp 'save-some-buffers-always) - (setq save-some-buffers-always - (remove (expand-file-name type-break-file-name) - save-some-buffers-always))) (and (interactive-p) (message "Type Break mode is disabled"))))) type-break-mode) @@ -515,16 +508,18 @@ variable of the same name." (defun type-break-file-keystroke-count () "File keystroke count in `type-break-file-name', unless the file is locked." (if (not (stringp (file-locked-p type-break-file-name))) - (with-current-buffer (find-file-noselect type-break-file-name - 'nowarn) - (save-excursion - (let ((inhibit-read-only t)) - (goto-char (point-min)) - (forward-line) - (delete-region (point) (save-excursion (end-of-line) (point))) - (insert (format "%s" type-break-keystroke-count)) - ;; file saving is left to auto-save - ))))) + ;; Prevent deactivation of the mark in some other buffer. + (let (deactivate-mark) + (with-current-buffer (find-file-noselect type-break-file-name + 'nowarn) + (save-excursion + (let ((inhibit-read-only t)) + (goto-char (point-min)) + (forward-line) + (delete-region (point) (save-excursion (end-of-line) (point))) + (insert (format "%s" type-break-keystroke-count)) + ;; file saving is left to auto-save + )))))) (defun timep (time) "If TIME is in the format returned by `current-time' then diff --git a/lisp/uniquify.el b/lisp/uniquify.el index f106297476c..b2da7971167 100644 --- a/lisp/uniquify.el +++ b/lisp/uniquify.el @@ -188,7 +188,6 @@ If `uniquify-min-dir-content' > 0, always pulls that many file name elements. Arguments BASE, DIRNAME, and NEWBUF specify the new buffer that causes this rationaliztion." - (interactive) (if (null dirname) (with-current-buffer newbuf (setq uniquify-managed nil)) (setq dirname (expand-file-name (directory-file-name dirname))) diff --git a/lisp/wid-edit.el b/lisp/wid-edit.el index c782e4262b8..5e67255eac9 100644 --- a/lisp/wid-edit.el +++ b/lisp/wid-edit.el @@ -3059,7 +3059,7 @@ It will read a directory name from the minibuffer when invoked." (defvar widget-function-prompt-value-history nil "History of input to `widget-function-prompt-value'.") -(define-widget 'function 'sexp +(define-widget 'function 'restricted-sexp "A Lisp function." :complete-function (lambda () (interactive) |