simple.el

A framework written in Java for implementing high-level and dynamic languages, compiling them into J

;;; simple.el --- basic editing commands for XEmacs

;; Copyright (C) 1985-7, 1993-5, 1997 Free Software Foundation, Inc.
;; Copyright (C) 1995 Tinker Systems and INS Engineering Corp.
;; Copyright (C) 2000 Ben Wing.

;; Maintainer: XEmacs Development Team
;; Keywords: lisp, extensions, internal, dumped

;; This file is part of XEmacs.

;; XEmacs is free software; you can redistribute it and/or modify it
;; under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.

;; XEmacs is distributed in the hope that it will be useful, but
;; WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;; General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with XEmacs; see the file COPYING.  If not, write to the Free
;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
;; 02111-1307, USA.

;;; Synched up with: FSF 19.34 [But not very closely].

;;; Commentary:

;; This file is dumped with XEmacs.

;; A grab-bag of basic XEmacs commands not specifically related to some
;; major mode or to file-handling.

;; Changes for zmacs-style active-regions:
;;
;; beginning-of-buffer, end-of-buffer, count-lines-region,
;; count-lines-buffer, what-line, what-cursor-position, set-goal-column,
;; set-fill-column, prefix-arg-internal, and line-move (which is used by
;; next-line and previous-line) set zmacs-region-stays to t, so that they
;; don't affect the current region-hilighting state.
;;
;; mark-whole-buffer, mark-word, exchange-point-and-mark, and
;; set-mark-command (without an argument) call zmacs-activate-region.
;;
;; mark takes an optional arg like the new Fmark_marker() does.  When
;; the region is not active, mark returns nil unless the optional arg is true.
;;
;; push-mark, pop-mark, exchange-point-and-mark, and set-marker, and
;; set-mark-command use (mark t) so that they can access the mark whether
;; the region is active or not.
;;
;; shell-command, shell-command-on-region, yank, and yank-pop (which all
;; push a mark) have been altered to call exchange-point-and-mark with an
;; argument, meaning "don't activate the region".  These commands  only use
;; exchange-point-and-mark to position the newly-pushed mark correctly, so
;; this isn't a user-visible change.  These functions have also been altered
;; to use (mark t) for the same reason.

;; 97/3/14 Jareth Hein ([e-mail]) added kinsoku processing (support
;; for filling of Asian text) into the fill code. This was ripped bleeding from
;; Mule-2.3, and could probably use some feature additions (like additional wrap
;; styles, etc)

;; 97/06/11 Steve Baur ([e-mail]) Convert use of
;;  (preceding|following)-char to char-(after|before).

;;; Code:

(defgroup editing-basics nil
  "Most basic editing variables."
  :group 'editing)

(defgroup killing nil
  "Killing and yanking commands."
  :group 'editing)

(defgroup fill-comments nil
  "Indenting and filling of comments."
  :prefix "comment-"
  :group 'fill)

(defgroup paren-matching nil
  "Highlight (un)matching of parens and expressions."
  :prefix "paren-"
  :group 'matching)

(defgroup log-message nil
  "Messages logging and display customizations."
  :group 'minibuffer)

(defgroup warnings nil
  "Warnings customizations."
  :group 'minibuffer)


(defcustom search-caps-disable-folding t
  "*If non-nil, upper case chars disable case fold searching.
This does not apply to \"yanked\" strings."
  :type 'boolean
  :group 'editing-basics)

;; This is stolen (and slightly modified) from FSF emacs's
;; `isearch-no-upper-case-p'.
(defun no-upper-case-p (string &optional regexp-flag)
  "Return t if there are no upper case chars in STRING.
If REGEXP-FLAG is non-nil, disregard letters preceded by `\\' (but not `\\\\')
since they have special meaning in a regexp."
  (let ((case-fold-search nil))
    (not (string-match (if regexp-flag 
			   "\\(^\\|\\\\\\\\\\|[^\\]\\)[A-Z]"
			 "[A-Z]")
		       string))
    ))

#|
(defmacro with-search-caps-disable-folding (string regexp-flag &rest body) "\
Eval BODY with `case-fold-search' let to nil if `search-caps-disable-folding' 
is non-nil, and if STRING (either a string or a regular expression according
to REGEXP-FLAG) contains uppercase letters."
  `(let ((case-fold-search
          (if (and case-fold-search search-caps-disable-folding)
              (no-upper-case-p ,string ,regexp-flag)
            case-fold-search)))
     ,@body))
(put 'with-search-caps-disable-folding 'lisp-indent-function 2)
(put 'with-search-caps-disable-folding 'edebug-form-spec 
     '(sexp sexp &rest form))

(defmacro with-interactive-search-caps-disable-folding (string regexp-flag 
							       &rest body)
  "Same as `with-search-caps-disable-folding', but only in the case of a
function called interactively."
  `(let ((case-fold-search
	  (if (and (interactive-p) 
		   case-fold-search search-caps-disable-folding)
              (no-upper-case-p ,string ,regexp-flag)
            case-fold-search)))
     ,@body))
(put 'with-interactive-search-caps-disable-folding 'lisp-indent-function 2)
(put 'with-interactive-search-caps-disable-folding 'edebug-form-spec 
     '(sexp sexp &rest form))
|#

(defun newline (&optional arg)
  (interactive "*P")
  (insert-char ?\C-j arg))
#|
(defun newline (&optional arg)
  "Insert a newline, and move to left margin of the new line if it's blank.
The newline is marked with the text-property `hard'.
With arg, insert that many newlines.
In Auto Fill mode, if no numeric arg, break the preceding line if it's long."
  (interactive "*P")
  (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.
		   (not (get-char-property (1- (point)) 'read-only))
		   ;; Make sure the newline before point isn't invisible.
		   (not (get-char-property (1- (point)) 'invisible))
		   ;; This should probably also test for the previous char
		   ;;  being the *last* character too.
		   (not (get-char-property (1- (point)) 'end-open))
		   ;; Make sure the newline before point has the same
		   ;; properties as the char before it (if any).
		   (< (or (previous-extent-change (point)) -2)
		      (- (point) 2))))
	(was-page-start (and (bolp)
			     (looking-at page-delimiter)))
	(beforepos (point)))
    (if flag (backward-char 1))
    ;; Call self-insert so that auto-fill, abbrev expansion etc. happens.
    ;; Set last-command-char to tell self-insert what to insert.
    (let ((last-command-char ?\n)
	  ;; Don't auto-fill if we have a numeric argument.
	  ;; Also not if flag is true (it would fill wrong line);
	  ;; there is no need to since we're at BOL.
	  (auto-fill-function (if (or arg flag) nil auto-fill-function)))
      (unwind-protect
	  (self-insert-command (prefix-numeric-value arg))
	;; If we get an error in self-insert-command, put point at right place.
	(if flag (forward-char 1))))
    ;; If we did *not* get an error, cancel that forward-char.
    (if flag (backward-char 1))
    ;; Mark the newline(s) `hard'.
    (if use-hard-newlines
	(let* ((from (- (point) (if arg (prefix-numeric-value arg) 1)))
	       (sticky (get-text-property from 'end-open))) ; XEmacs
	  (put-text-property from (point) 'hard 't)
	  ;; If end-open is not "t", add 'hard to end-open list
	  (if (and (listp sticky) (not (memq 'hard sticky)))
	      (put-text-property from (point) 'end-open ; XEmacs
				 (cons 'hard sticky)))))
    ;; If the newline leaves the previous line blank,
    ;; and we have a left margin, delete that from the blank line.
    (or flag
	(save-excursion
	  (goto-char beforepos)
	  (beginning-of-line)
	  (and (looking-at "[ \t]$")
	       (> (current-left-margin) 0)
	       (delete-region (point) (progn (end-of-line) (point))))))
    (if flag (forward-char 1))
    ;; Indent the line after the newline, except in one case:
    ;; when we added the newline at the beginning of a line
    ;; which starts a page.
    (or was-page-start
	(move-to-left-margin nil t)))
  nil)

(defun set-hard-newline-properties (from to)
  (let ((sticky (get-text-property from 'rear-nonsticky)))
    (put-text-property from to 'hard 't)
    ;; If rear-nonsticky is not "t", add 'hard to rear-nonsticky list
    (if (and (listp sticky) (not (memq 'hard sticky)))
	(put-text-property from (point) 'rear-nonsticky
			   (cons 'hard sticky)))))
|#

(defun open-line (arg)
  "Insert a newline and leave point before it.
If there is a fill prefix and/or a left-margin, insert them on the new line
if the line would have been blank.
With arg N, insert N newlines."
  (interactive "*p")
  (let* ((do-fill-prefix (and fill-prefix (bolp)))
	 (do-left-margin (and (bolp) (> (current-left-margin) 0)))
	 (loc (point)))
    (newline arg)
    (goto-char loc)
    (while (> arg 0)
      (cond ((bolp)
	     (if do-left-margin (indent-to (current-left-margin)))
	     (if do-fill-prefix (insert fill-prefix))))
      (forward-line 1)
      (setq arg (1- arg)))
    (goto-char loc)
    (end-of-line)))

(defun split-line ()
  "Split current line, moving portion beyond point vertically down."
  (interactive "*")
  (skip-chars-forward " \t")
  (let ((col (current-column))
	(pos (point)))
    (newline 1)
    (indent-to col 0)
    (goto-char pos)))

(defun quoted-insert (arg)
  "Read next input character and insert it.
This is useful for inserting control characters.
You may also type up to 3 octal digits, to insert a character with that code.

In overwrite mode, this function inserts the character anyway, and
does not handle octal digits specially.  This means that if you use
overwrite as your normal editing mode, you can use this function to
insert characters when necessary.

In binary overwrite mode, this function does overwrite, and octal
digits are interpreted as a character code.  This is supposed to make
this function useful in editing binary files."
  (interactive "*p")
  (let ((char (if (or (not overwrite-mode)
		      (eq overwrite-mode 'overwrite-mode-binary))
		  (read-quoted-char)
		;; read-char obeys C-g, so we should protect.  FSF
		;; doesn't have the protection here, but it's a bug in
		;; FSF.
		(let ((inhibit-quit t))
		  (read-char)))))
    (if (> arg 0)
	(if (eq overwrite-mode 'overwrite-mode-binary)
	    (delete-char arg)))
    (while (> arg 0)
      (insert char)
      (setq arg (1- arg)))))

(defun delete-indentation (&optional arg)
  "Join this line to previous and fix up whitespace at join.
If there is a fill prefix, delete it from the beginning of this line.
With argument, join this line to following line."
  (interactive "*P")
  (beginning-of-line)
  (if arg (forward-line 1))
  (if (eq (char-before (point)) ?\n)
      (progn
	(delete-region (point) (1- (point)))
	;; If the second line started with the fill prefix,
	;; delete the prefix.
	(if (and fill-prefix
		 (<= (+ (point) (length fill-prefix)) (point-max))
		 (string= fill-prefix
			  (buffer-substring (point)
					    (+ (point) (length fill-prefix)))))
	    (delete-region (point) (+ (point) (length fill-prefix))))
	(fixup-whitespace))))

(defun fixup-whitespace ()
  "Fixup white space between objects around point.
Leave one space or none, according to the context."
  (interactive "*")
  (save-excursion
    (delete-horizontal-space)
    (if (or (looking-at "^\\|\\s)")
	    (save-excursion (forward-char -1)
			    (looking-at "$\\|\\s(\\|\\s'")))
	nil
      (insert ?\ ))))

(defun delete-horizontal-space ()
  "Delete all spaces and tabs around point."
  (interactive "*")
  (skip-chars-backward " \t")
  (delete-region (point) (progn (skip-chars-forward " \t") (point))))

(defun just-one-space ()
  "Delete all spaces and tabs around point, leaving one space."
  (interactive "*")
  (if abbrev-mode ; XEmacs
      (expand-abbrev))
  (skip-chars-backward " \t")
  (if (eq (char-after (point)) ? ) ; XEmacs
      (forward-char 1)
    (insert ? ))
  (delete-region (point) (progn (skip-chars-forward " \t") (point))))

(defun delete-blank-lines ()
  "On blank line, delete all surrounding blank lines, leaving just one.
On isolated blank line, delete that one.
On nonblank line, delete any immediately following blank lines."
  (interactive "*")
  (let (thisblank singleblank)
    (save-excursion
      (beginning-of-line)
      (setq thisblank (looking-at "[ \t]*$"))
      ;; Set singleblank if there is just one blank line here.
      (setq singleblank