xemacs-beta: lisp/simple.el comparison

comparison lisp/simple.el @ 219:262b8bb4a523 r20-4b8

Import from CVS: tag r20-4b8

author	cvs
date	Mon, 13 Aug 2007 10:09:35 +0200
parents	1f0dabaa0855
children	2c611d1463a6

comparison

equal deleted inserted replaced

-:c9f226976f56
+:262b8bb4a523
 (barf-if-buffer-read-only nil (point))
 ;; Inserting a newline at the end of a line produces better redisplay in
 ;; try_window_id than inserting at the beginning of a line, and the textual
 ;; result is the same.  So, if we're at beginning of line, pretend to be at
 ;; the end of the previous line.
+;; #### Does this have any relevance in XEmacs?
 (let ((flag (and (not (bobp))
 		   (bolp)
 		   ;; Make sure the newline before point isn't intangible.
 		   (not (get-char-property (1- (point)) 'intangible))
 		   ;; Make sure the newline before point isn't read-only.
 (if (markerp end) (setq end (marker-position end)))
 (or (and beg end) (if zmacs-regions ;; rewritten for I18N3 snarfing
 			(error "The region is not active now")
 		      (error "The mark is not set now")))
 (if verbose (if buffer-read-only
-		  (display-message
+		  (lmessage 'command "Copying %d characters"
-		   'command
+			    (- (max beg end) (min beg end)))
-		   (format "Copying %d characters"
+		(lmessage 'command "Killing %d characters"
-			   (- (max beg end) (min beg end))))
+			  (- (max beg end) (min beg end)))))
-		(display-message
-		 'command
-		 (format "Killing %d characters"
-			 (- (max beg end) (min beg end))))))
 (cond
 ;; I don't like this large change in behavior -- jwz
 ;; Read-Only text means it shouldn't be deleted, so I'm restoring
 ;; this code, but only for text-properties and not full extents. -sb
 (interactive "_")
 (if (interactive-p)
 (progn
 	(setq this-command 'kill-region)
 	(display-message 'command
-			 "If the next command is a kill, it will append"))
+	  "If the next command is a kill, it will append"))
 (setq last-command 'kill-region)))
 (defun yank-pop (arg)
 "Replace just-yanked stretch of killed text with a different stretch.
 This command is allowed only immediately after a `yank' or a `yank-pop'.
 (defvar temporary-goal-column 0
 "Current goal column for vertical motion.
 It is the column where point was
 at the start of current run of vertical motion commands.
 When the `track-eol' feature is doing its job, the value is 9999.")
+(make-variable-buffer-local 'temporary-goal-column)
 ;XEmacs: not yet ported, so avoid compiler warnings
 (eval-when-compile
 (defvar inhibit-point-motion-hooks))
 	    (re-search-backward comment-start-skip)
 	    (beginning-of-line)
 	    (re-search-forward comment-start-skip)
 	    (goto-char (match-beginning 0))
 	    (setq comment-column (current-column))
-	    (display-message
+	    (lmessage 'command "Comment column set to %d" comment-column))
-	     'command
-	     (format "Comment column set to %d" comment-column)))
 	  (indent-for-comment))
 (setq comment-column (current-column))
-(display-message
+(lmessage 'command "Comment column set to %d" comment-column))))
-'command
-(format "Comment column set to %d" comment-column)))))
 (defun kill-comment (arg)
 "Kill the comment on this line, if any.
 With argument, kill comments on that many lines starting with this one."
 ;; this function loses in a lot of situations.  it incorrectly recognises
 	((consp arg)
 	 (setq fill-column (current-column)))
 	;; Disallow missing argument; it's probably a typo for C-x C-f.
 	(t
 	 (error "set-fill-column requires an explicit argument")))
-(display-message 'command (format "fill-column set to %d" fill-column)))
+(lmessage 'command "fill-column set to %d" fill-column))
 (defcustom comment-multi-line t ; XEmacs - this works well with adaptive fill
 "*Non-nil means \\[indent-new-comment-line] should continue same comment
 on new line, with no new terminator or starter.
 This is obsolete because you might as well use \\[newline-and-indent]."
 		    (and blink-matching-paren-on-screen
 			 (progn
 			   (auto-show-make-point-visible)
 			   (sit-for blink-matching-delay)))
 		  (goto-char blinkpos)
-		  (display-message
+		  (lmessage 'command "Matches %s"
-		   'command
-		   (format
-		    "Matches %s"
 		    ;; Show what precedes the open in its line, if anything.
 		    (if (save-excursion
 			  (skip-chars-backward " \t")
 			  (not (bolp)))
 			(buffer-substring (progn (beginning-of-line) (point))
 						      (point)))
 			     ;; Replace the newline and other whitespace with `...'.
 			     "..."
 			     (buffer-substring blinkpos (1+ blinkpos)))
 			  ;; There is nothing to show except the char itself.
-			  (buffer-substring blinkpos (1+ blinkpos)))))))))
+			  (buffer-substring blinkpos (1+ blinkpos))))))))
 	     (cond (mismatch
 		    (display-message 'no-log "Mismatched parentheses"))
 		   ((not blink-matching-paren-distance)
 		    (display-message 'no-log "Unmatched parenthesis"))))))))
 "Default value of log-message-filter-function.
 Mesages whose text matches one of the log-message-ignore-regexps
 or whose label appears in log-message-ignore-labels are not saved."
 (let ((r  log-message-ignore-regexps)
 	(ok (not (memq label log-message-ignore-labels))))
-(while (and r ok)
+(save-match-data
-(if (save-match-data (string-match (car r) message))
+(while (and r ok)
+	(when (string-match (car r) message)
 	  (setq ok nil))
-(setq r (cdr r)))
+	(setq r (cdr r))))
 ok))
 (defun log-message-filter-errors-only (label message)
 "For use as the log-message-filter-function.  Only logs error messages."
 (eq label 'error))
 (defun log-message (label message)
 "Stuff a copy of the message into the \" *Message-Log*\" buffer,
 if it satisfies the log-message-filter-function.
 For use on remove-message-hook."
-(if (and (not noninteractive)
+(when (and (not noninteractive)
-	   (funcall log-message-filter-function label message))
+	     (funcall log-message-filter-function label message))
-(save-excursion
+(with-current-buffer (get-buffer-create " *Message-Log*")
-	(set-buffer (get-buffer-create " *Message-Log*"))
+(goto-char (point-max))
-	(goto-char (point-max))
+;; (insert (concat (upcase (symbol-name label)) ": "  message "\n"))
-	;; (insert (concat (upcase (symbol-name label)) ": "  message "\n"))
+(insert message "\n")
-	(insert message "\n")
+(when (> (point-max) (max log-message-max-size (point-min)))
-	(if (> (point-max) (max log-message-max-size (point-min)))
+	;; trim log to ~90% of max size
-	    (progn
+	(goto-char (max (- (point-max)
-	      ;; trim log to ~90% of max size
+			   (truncate (* 0.9 log-message-max-size)))
-	      (goto-char (max (- (point-max)
+			(point-min)))
-				 (truncate (* 0.9 log-message-max-size)))
+	(forward-line 1)
-			      (point-min)))
+	(delete-region (point-min) (point))))))
-	      (forward-line 1)
-	      (delete-region (point-min) (point)))))))
 (defun message-displayed-p (&optional return-string frame)
 "Return a non-nil value if a message is presently displayed in the\n\
 minibuffer's echo area.  If optional argument RETURN-STRING is non-nil,\n\
 return a string containing the message, otherwise just return t."
 (if clear-stream
 	(send-string-to-terminal ?\n stdout-p))
 (if no-restore
 	nil			; just preparing to put another msg up
 (if message-stack
-	  (let ((oldmsg  (cdr (car message-stack))))
+	  (let ((oldmsg (cdr (car message-stack))))
 	    (raw-append-message oldmsg frame stdout-p)
 	    oldmsg)
 	;; ### should we (redisplay-echo-area) here?  messes some things up.
 	nil))))
 (while log
 (condition-case e
 	  (run-hook-with-args 'remove-message-hook
 			      (car (car log)) (cdr (car log)))
 	(error (setq remove-message-hook nil)
-	       (message "remove-message-hook error: %s" e)
+	       (lwarn 'message-log 'warning
-	       (sit-for 2)
+		 "Error caught in `remove-message-hook': %s"
+		 (error-message-string e))
 	       (let ((inhibit-read-only t))
 		 (erase-buffer (get-buffer " *Echo Area*")))
 	       (signal (car e) (cdr e))))
 (setq log (cdr log)))))
 ;; really append the message to the echo area.  no fiddling with message-stack.
 (defun raw-append-message (message &optional frame stdout-p)
 (if (eq message "") nil
 (let ((buffer (get-buffer " *Echo Area*"))
 	  (zmacs-region-stays zmacs-region-stays)) ; preserve from change
-(save-excursion
+(with-current-buffer buffer
-	(set-buffer buffer)
 	(let ((inhibit-read-only t))
 	  (insert message)))
 ;; Conditionalizing on the device type in this way is not that clean,
 ;; but neither is having a device method, as I originally implemented
 ;; it: all non-stream devices behave in the same way.  Perhaps
 minibuffer contents show."
 ;; questionable junk in the C code
 ;; (if (framep default-minibuffer-frame)
 ;;     (make-frame-visible default-minibuffer-frame))
 (if (and (null fmt) (null args))
-(progn
+(prog1 nil
-	(clear-message nil)
+	(clear-message nil))
-	nil)
 (let ((str (apply 'format fmt args)))
 (display-message 'message str)
 str)))
+(defun lmessage (label fmt &rest args)
+"Print a one-line message at the bottom of the frame.
+First argument LABEL is an identifier for this message.  The rest of the
+arguments are the same as to `format'.
+See `display-message' for a list of standard labels."
+(if (and (null fmt) (null args))
+(prog1 nil
+	(clear-message label nil))
+(let ((str (apply 'format fmt args)))
+(display-message label str)
+str)))
 ;;;;;;
 ;;;;;; warning stuff
 ;;;;;;
 (defun display-warning (class message &optional level)
 "Display a warning message.
 CLASS should be a symbol describing what sort of warning this is, such
 as `resource' or `key-mapping'.  A list of such symbols is also
 accepted. (Individual classes can be suppressed; see
-`display-warning-suppressed-classes'.) Optional argument LEVEL can
+`display-warning-suppressed-classes'.)  Optional argument LEVEL can
 be used to specify a priority for the warning, other than default priority
 `warning'. (See `display-warning-minimum-level').  The message is
 inserted into the *Warnings* buffer, which is made visible at appropriate
 times."
 (or level (setq level 'warning))
 	(if (< level-num (cdr (assq log-warning-minimum-level
 				    warning-level-alist)))
 	    (throw 'ignored nil))
 	(if (intersection class log-warning-suppressed-classes)
 	    (throw 'ignored nil))
 	(if (< level-num (cdr (assq display-warning-minimum-level
 				    warning-level-alist)))
 	    (setq display-p nil))
 	(if (and display-p
 		 (intersection class display-warning-suppressed-classes))
 	    (setq display-p nil))
-	(save-excursion
+	(let ((buffer (get-buffer-create "*Warnings*")))
-	  (let ((buffer (get-buffer-create "*Warnings*")))
+	  (when display-p
-	    (when display-p
+	    ;; The C code looks at display-warning-tick to determine
-	      ;; The C code looks at display-warning-tick to determine
+	    ;; when it should call `display-warning-buffer'.  Change it
-	      ;; when it should call `display-warning-buffer'.  Change it
+	    ;; to get the C code's attention.
-	      ;; to get the C code's attention.
+	    (incf display-warning-tick))
-	      (incf display-warning-tick))
+	  (with-current-buffer buffer
-	    (set-buffer buffer)
 	    (goto-char (point-max))
-	    (setq warning-count (1+ warning-count))
+	    (incf warning-count)
 	    (princ (format "(%d) (%s/%s) "
 			   warning-count
 			   (mapconcat 'symbol-name class ",")
-			   level) buffer)
+			   level)
+		   buffer)
 	    (princ message buffer)
 	    (terpri buffer)
 	    (terpri buffer)))))))
 (defun warn (&rest args)
 The message is constructed by passing all args to `format'.  The message
 is placed in the *Warnings* buffer, which will be popped up at the next
 redisplay.  The class of the warning is `warning'.  See also
 `display-warning'."
 (display-warning 'warning (apply 'format args)))
+(defun lwarn (class level &rest args)
+"Display a labeled warning message.
+CLASS should be a symbol describing what sort of warning this is, such
+as `resource' or `key-mapping'.  A list of such symbols is also
+accepted. (Individual classes can be suppressed; see
+`display-warning-suppressed-classes'.)  If non-nil, LEVEL can be used
+to specify a priority for the warning, other than default priority
+`warning'. (See `display-warning-minimum-level').  The message is
+inserted into the *Warnings* buffer, which is made visible at appropriate
+times.
+The rest of the arguments are passed to `format'."
+(display-warning class (apply 'format args)
+		   (or level 'warning)))
 (defvar warning-marker nil)
 ;; When this function is called by the C code, all non-local exits are
 ;; trapped and C-g is inhibited; therefore, it would be a very, very

Mercurial > hg > xemacs-beta

comparison lisp/simple.el @ 219:262b8bb4a523 r20-4b8