Mercurial > hg > xemacs-beta

comparison lisp/prim/simple.el @ 155:43dd3413c7c7 r20-3b4

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r20-3b4
author cvs
date Mon, 13 Aug 2007 09:39:39 +0200
parents 25f70ba0133c
children 3bb7ccffb0c0
comparison
equal deleted inserted replaced
154:94141801dd7e 155:43dd3413c7c7
1115 (if (markerp beg) (setq beg (marker-position beg))) 1115 (if (markerp beg) (setq beg (marker-position beg)))
1116 (if (markerp end) (setq end (marker-position end))) 1116 (if (markerp end) (setq end (marker-position end)))
1117 (or (and beg end) (if zmacs-regions ;; rewritten for I18N3 snarfing 1117 (or (and beg end) (if zmacs-regions ;; rewritten for I18N3 snarfing
1118 (error "The region is not active now") 1118 (error "The region is not active now")
1119 (error "The mark is not set now"))) 1119 (error "The mark is not set now")))
1120 (if (> beg end) (setq beg (prog1 end (setq end beg))))
1120 (if verbose (if buffer-read-only 1121 (if verbose (if buffer-read-only
1121 (message "Copying %d characters" 1122 (message "Copying %d characters" (- end beg))
1122 (- (max beg end) (min beg end))) 1123 (message "Killing %d characters" (- end beg))))
1123 (message "Killing %d characters"
1124 (- (max beg end) (min beg end)))))
1125 (cond 1124 (cond
1126 1125
1127 ;; I don't like this large change in behavior -- jwz 1126 ;; I don't like this large change in behavior -- jwz
1128 ;; Read-Only text means it shouldn't be deleted, so I'm restoring 1127 ;; Read-Only text means it shouldn't be deleted, so I'm restoring
1129 ;; this code, but only for text-properties and not full extents. -sb 1128 ;; this code, but only for text-properties and not full extents. -sb
1149 (eq last-command 'kill-region) 1148 (eq last-command 'kill-region)
1150 ;; Use = since positions may be numbers or markers. 1149 ;; Use = since positions may be numbers or markers.
1151 (= beg end))) 1150 (= beg end)))
1152 ;; Don't let the undo list be truncated before we can even access it. 1151 ;; Don't let the undo list be truncated before we can even access it.
1153 ;; FSF calls this `undo-strong-limit' 1152 ;; FSF calls this `undo-strong-limit'
1154 (let ((undo-high-threshold (+ (- (max beg end) (min beg end)) 100)) 1153 (let ((undo-high-threshold (+ (- end beg) 100))
1155 ;(old-list buffer-undo-list) 1154 ;(old-list buffer-undo-list)
1156 tail) 1155 tail)
1157 (delete-region beg end) 1156 (delete-region beg end)
1158 ;; Search back in buffer-undo-list for this string, 1157 ;; Search back in buffer-undo-list for this string,
1159 ;; in case a change hook made property changes. 1158 ;; in case a change hook made property changes.
2040 (skip-syntax-backward " " (match-beginning 0)) 2039 (skip-syntax-backward " " (match-beginning 0))
2041 (skip-syntax-backward "^ " (match-beginning 0))))) 2040 (skip-syntax-backward "^ " (match-beginning 0)))))
2042 (setq begpos (point)) 2041 (setq begpos (point))
2043 ;; Compute desired indent. 2042 ;; Compute desired indent.
2044 (if (= (current-column) 2043 (if (= (current-column)
2045 (setq indent (if comment-indent-hook 2044 (setq indent (funcall comment-indent-function)))
2046 (funcall comment-indent-hook)
2047 (funcall comment-indent-function))))
2048 (goto-char begpos) 2045 (goto-char begpos)
2049 ;; If that's different from current, change it. 2046 ;; If that's different from current, change it.
2050 (skip-chars-backward " \t") 2047 (skip-chars-backward " \t")
2051 (delete-region (point) begpos) 2048 (delete-region (point) begpos)
2052 (indent-to indent)) 2049 (indent-to indent))
2381 (setq give-up t))))))) 2378 (setq give-up t)))))))
2382 2379
2383 ;; Put FSF one in until I can one or the other working properly, then the 2380 ;; Put FSF one in until I can one or the other working properly, then the
2384 ;; other one is history. 2381 ;; other one is history.
2385 (defun fsf:do-auto-fill () 2382 (defun fsf:do-auto-fill ()
2386 (let (fc justify bol give-up 2383 (let (fc justify
2384 ;; bol
2385 give-up
2387 (fill-prefix fill-prefix)) 2386 (fill-prefix fill-prefix))
2388 (if (or (not (setq justify (current-justification))) 2387 (if (or (not (setq justify (current-justification)))
2389 (null (setq fc (current-fill-column))) 2388 (null (setq fc (current-fill-column)))
2390 (and (eq justify 'left) 2389 (and (eq justify 'left)
2391 (<= (current-column) fc)) 2390 (<= (current-column) fc))
2392 (save-excursion (beginning-of-line) 2391 (save-excursion (beginning-of-line)
2393 (setq bol (point)) 2392 ;; (setq bol (point))
2394 (and auto-fill-inhibit-regexp 2393 (and auto-fill-inhibit-regexp
2395 (looking-at auto-fill-inhibit-regexp)))) 2394 (looking-at auto-fill-inhibit-regexp))))
2396 nil ;; Auto-filling not required 2395 nil ;; Auto-filling not required
2397 (if (memq justify '(full center right)) 2396 (if (memq justify '(full center right))
2398 (save-excursion (unjustify-current-line))) 2397 (save-excursion (unjustify-current-line)))
2846 ;; XEmacs: Some functions moved to cmdloop.el: 2845 ;; XEmacs: Some functions moved to cmdloop.el:
2847 ;; keyboard-quit 2846 ;; keyboard-quit
2848 ;; buffer-quit-function 2847 ;; buffer-quit-function
2849 ;; keyboard-escape-quit 2848 ;; keyboard-escape-quit
2850 2849
2850 (defun assoc-ignore-case (key alist)
2851 "Like `assoc', but assumes KEY is a string and ignores case when comparing."
2852 (let (element)
2853 (while (and alist (not element))
2854 (if (equal key (downcase (car (car alist))))
2855 (setq element (car alist)))
2856 (setq alist (cdr alist)))
2857 element))
2858
2851 (defun set-variable (var val) 2859 (defun set-variable (var val)
2852 "Set VARIABLE to VALUE. VALUE is a Lisp object. 2860 "Set VARIABLE to VALUE. VALUE is a Lisp object.
2853 When using this interactively, supply a Lisp expression for VALUE. 2861 When using this interactively, supply a Lisp expression for VALUE.
2854 If you want VALUE to be a string, you must surround it with doublequotes. 2862 If you want VALUE to be a string, you must surround it with doublequotes.
2855 2863
3138 message is passed as the first argument, and the text of the message 3146 message is passed as the first argument, and the text of the message
3139 as the second argument.") 3147 as the second argument.")
3140 3148
3141 (defvar log-message-max-size 50000 3149 (defvar log-message-max-size 50000
3142 "Maximum size of the \" *Message-Log*\" buffer. See `log-message'.") 3150 "Maximum size of the \" *Message-Log*\" buffer. See `log-message'.")
3151 (make-compatible-variable 'message-log-max 'log-message-max-size)
3143 3152
3144 (defvar log-message-ignore-regexps 3153 (defvar log-message-ignore-regexps
3145 '("^Mark set$" 3154 '(;; Often-seen messages
3146 "^Undo!$" 3155 "^$" ; empty message
3147 "^Undo\\.\\.\\.$" 3156 "^Mark set$"
3157 "^\\(Beginning\\|End\\) of buffer$"
3148 "^Quit$" 3158 "^Quit$"
3149 "^\\(Beginning\\|End\\) of buffer$" 3159 "^Killing [0-9]+ characters$"
3160 ;; saving
3161 "^Saving file .*\\.\\.\\.$" ; note: cannot ignore ^Wrote, because
3162 ; it would kill off too much stuff.
3163 "^(No changes need to be saved)$"
3164 "^(No files need saving)$"
3165 ;; undo, with the output of redo.el
3166 "^Undo[!.]+$"
3167 "^Redo[!.]+$"
3168 ;; M-x compile
3169 "^Parsing error messages\\.\\.\\."
3170 ;; M-!
3171 "^(Shell command completed with no output)"
3172 ;; font-lock
3150 "^Fontifying" 3173 "^Fontifying"
3174 ;; isearch
3151 "^\\(Failing \\)?\\([Ww]rapped \\)?\\([Rr]egexp \\)?I-search\\( backward\\)?:" 3175 "^\\(Failing \\)?\\([Ww]rapped \\)?\\([Rr]egexp \\)?I-search\\( backward\\)?:"
3152 "^Mark saved where search started$" 3176 "^Mark saved where search started$"
3177 ;; menus
3178 "^Selecting menu item"
3179 ;; completions
3153 "^Making completion list" 3180 "^Making completion list"
3154 "^Matches " ; paren-matching message 3181 "^Matches " ; paren-matching message
3182 ;; help
3155 "^Type .* to \\(remove help\\|restore the other\\) window." 3183 "^Type .* to \\(remove help\\|restore the other\\) window."
3156 "^M-x .* (bound to key" ; teach-extended-commands 3184 "^M-x .* (bound to key" ; teach-extended-commands
3157 "^(No changes need to be saved)$" 3185 ;; VM
3158 "^(No files need saving)$" 3186 "^\\(Parsing messages\\|Reading attributes\\|Generating summary\\|Building threads\\|Converting\\)\\.\\.\\. [0-9]+$"
3159 "^\\(Parsing messages\\|Reading attributes\\|Generating summary\\|Building threads\\|Converting\\)\\.\\.\\. [0-9]+$" ; vm 3187 "^End of message" ; + Gnus
3160 "^End of message \d+" ; vm 3188 ;; Gnus
3161 "^Parsing error messages\\.\\.\\.[0-9]+" ; compile 3189 "^No news is no news$"
3162 "^Parsed [0-9]+ of [0-9]+ ([0-9]+%)$" ; w3 3190 "^No more\\( unread\\)? newsgroups$"
3163 "^\\(Formatting Summary\\|Reading active file\\|Checking new news\\|Looking for crossposts\\|Marking crossposts\\|MHSPOOL:\\|NNSPOOL:\\|NNTP:\\|\\(Uns\\|S\\)ubscribing new newsgroups\\)\\.\\.\\. *[0-9]+%$" ; gnus 3191 "^Opening [^ ]+ server\\.\\.\\."
3164 "^Adding glyphs\\.\\.\\. ([0-9]+%)\\( done\\)?$" ; outl-mouse 3192 "^[^:]+: Reading incoming mail"
3165 "^->" ; bbdb prompt 3193 "^Getting mail from "
3194 "^\\(Generating Summary\\|Sorting threads\\|Making sparse threads\\|Scoring\\|Checking new news\\|Expiring articles\\|Sending\\)\\.\\.\\."
3195 "^\\(Fetching headers for\\|Retrieving newsgroup\\|Reading active file\\)"
3196 "^No more\\( unread\\)? articles"
3197 "^Deleting article "
3198 ;; W3
3199 "^Parsed [0-9]+ of [0-9]+ ([0-9]+%)"
3200 ;; outl-mouse
3201 "^Adding glyphs\\.\\.\\."
3202 ;; bbdb
3203 "^->"
3166 ) 3204 )
3167 "List of regular expressions matching messages which shouldn't be logged. 3205 "List of regular expressions matching messages which shouldn't be logged.
3168 See `log-message'. 3206 See `log-message'.
3169 3207
3170 Ideally, packages which generate messages which might need to be ignored 3208 Ideally, packages which generate messages which might need to be ignored
3455 (while before-init-deferred-warnings 3493 (while before-init-deferred-warnings
3456 (apply 'display-warning (car before-init-deferred-warnings)) 3494 (apply 'display-warning (car before-init-deferred-warnings))
3457 (setq before-init-deferred-warnings 3495 (setq before-init-deferred-warnings
3458 (cdr before-init-deferred-warnings)))) 3496 (cdr before-init-deferred-warnings))))
3459 3497
3460 (add-hook 'after-init-hook 'after-init-display-warnings) 3498 #-infodock (add-hook 'after-init-hook 'after-init-display-warnings)
3461 3499
3462 (defun display-warning (class message &optional level) 3500 (defun display-warning (class message &optional level)
3463 "Display a warning message. 3501 "Display a warning message.
3464 CLASS should be a symbol describing what sort of warning this is, such 3502 CLASS should be a symbol describing what sort of warning this is, such
3465 as `resource' or `key-mapping'. A list of such symbols is also 3503 as `resource' or `key-mapping'. A list of such symbols is also
3470 inserted into the *Warnings* buffer, which is made visible at appropriate 3508 inserted into the *Warnings* buffer, which is made visible at appropriate
3471 times." 3509 times."
3472 (or level (setq level 'warning)) 3510 (or level (setq level 'warning))
3473 (or (listp class) (setq class (list class))) 3511 (or (listp class) (setq class (list class)))
3474 (check-argument-type 'warning-level-p level) 3512 (check-argument-type 'warning-level-p level)
3475 (if (not init-file-loaded) 3513 (if (and (not (featurep 'infodock))
3514 (not init-file-loaded))
3476 (setq before-init-deferred-warnings 3515 (setq before-init-deferred-warnings
3477 (cons (list class message level) before-init-deferred-warnings)) 3516 (cons (list class message level) before-init-deferred-warnings))
3478 (catch 'ignored 3517 (catch 'ignored
3479 (let ((display-p t) 3518 (let ((display-p t)
3480 (level-num (cdr (assq level warning-level-alist)))) 3519 (level-num (cdr (assq level warning-level-alist))))
3532 (setq warning-marker (make-marker)) 3571 (setq warning-marker (make-marker))
3533 (set-marker warning-marker 1 buffer))) 3572 (set-marker warning-marker 1 buffer)))
3534 (set-window-start (display-buffer buffer) warning-marker) 3573 (set-window-start (display-buffer buffer) warning-marker)
3535 (set-marker warning-marker (point-max buffer) buffer))) 3574 (set-marker warning-marker (point-max buffer) buffer)))
3536 3575
3576 (defun emacs-name ()
3577 "Return the printable name of this instance of GNU Emacs."
3578 (cond ((featurep 'infodock) "InfoDock")
3579 ((featurep 'xemacs) "XEmacs")
3580 (t "Emacs")))
3581
3537 ;;; simple.el ends here 3582 ;;; simple.el ends here