simple.el

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

    (let ((undo-high-threshold (+ (- end beg) 100))
	  ;(old-list buffer-undo-list)
	  tail)
      (delete-region beg end)
      ;; Search back in buffer-undo-list for this string,
      ;; in case a change hook made property changes.
      (setq tail buffer-undo-list)
      (while (and tail
		  (not (stringp (car-safe (car-safe tail))))) ; XEmacs
	(pop tail))
      ;; Take the same string recorded for undo
      ;; and put it in the kill-ring.
      (and tail
	   (kill-new (car (car tail))))))

   (t
    ;; if undo is not kept, grab the string then delete it (which won't
    ;; add another string to the undo list).
    (copy-region-as-kill beg end)
    (delete-region beg end)))
  (setq this-command 'kill-region))

;; copy-region-as-kill no longer sets this-command, because it's confusing
;; to get two copies of the text when the user accidentally types M-w and
;; then corrects it with the intended C-w.
(defun copy-region-as-kill (beg end)
  "Save the region as if killed, but don't kill it.
Run `kill-hooks'."
  (interactive "r")
  (if (eq last-command 'kill-region)
      (kill-append (buffer-substring beg end) (< end beg))
    (kill-new (buffer-substring beg end)))
  nil)

(defun kill-ring-save (beg end)
  "Save the region as if killed, but don't kill it.
This command is similar to `copy-region-as-kill', except that it gives
visual feedback indicating the extent of the region being copied."
  (interactive "r")
  (copy-region-as-kill beg end)
  ;; copy before delay, for xclipboard's benefit
  (if (interactive-p)
      (let ((other-end (if (= (point) beg) end beg))
	    (opoint (point))
	    ;; Inhibit quitting so we can make a quit here
	    ;; look like a C-g typed as a command.
	    (inhibit-quit t))
	(if (pos-visible-in-window-p other-end (selected-window))
	    (progn
	      ;; FSF (I'm not sure what this does -sb)
;	      ;; Swap point and mark.
;	      (set-marker (mark-marker) (point) (current-buffer))
	      (goto-char other-end)
              (sit-for 1)
;	      ;; Swap back.
;	      (set-marker (mark-marker) other-end (current-buffer))
              (goto-char opoint)
              ;; If user quit, deactivate the mark
	      ;; as C-g would as a command.
	      (and quit-flag (mark)
                   (zmacs-deactivate-region)))
	  ;; too noisy. -- jwz
;	  (let* ((killed-text (current-kill 0))
;		 (message-len (min (length killed-text) 40)))
;	    (if (= (point) beg)
;		;; Don't say "killed"; that is misleading.
;		(message "Saved text until \"%s\""
;			(substring killed-text (- message-len)))
;	      (message "Saved text from \"%s\""
;		      (substring killed-text 0 message-len))))
	  ))))

(defun append-next-kill ()
  "Cause following command, if it kills, to append to previous kill."
  ;; XEmacs
  (interactive "_")
  (if (interactive-p)
      (progn
	(setq this-command 'kill-region)
	(display-message 'command
	  "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'.
At such a time, the region contains a stretch of reinserted
previously-killed text.  `yank-pop' deletes that text and inserts in its
place a different stretch of killed text.

With no argument, the previous kill is inserted.
With argument N, insert the Nth previous kill.
If N is negative, this is a more recent kill.

The sequence of kills wraps around, so that after the oldest one
comes the newest one."
  (interactive "*p")
  (if (not (eq last-command 'yank))
      (error "Previous command was not a yank"))
  (setq this-command 'yank)
  (let ((inhibit-read-only t)
	(before (< (point) (mark t))))
    (delete-region (point) (mark t))
    ;;(set-marker (mark-marker) (point) (current-buffer))
    (set-mark (point))
    (insert (current-kill arg))
    (if before
	;; This is like exchange-point-and-mark, but doesn't activate the mark.
	;; It is cleaner to avoid activation, even though the command
	;; loop would deactivate the mark because we inserted text.
	(goto-char (prog1 (mark t)
		     (set-marker (mark-marker t) (point) (current-buffer))))))
  nil)


(defun yank (&optional arg)
  "Reinsert the last stretch of killed text.
More precisely, reinsert the stretch of killed text most recently
killed OR yanked.  Put point at end, and set mark at beginning.
With just C-u as argument, same but put point at beginning (and mark at end).
With argument N, reinsert the Nth most recently killed stretch of killed
text.
See also the command \\[yank-pop]."
  (interactive "*P")
  ;; If we don't get all the way through, make last-command indicate that
  ;; for the following command.
  (setq this-command t)
  (push-mark (point))
  (insert (current-kill (cond
			 ((listp arg) 0)
			 ((eq arg '-) -1)
			 (t (1- arg)))))
  (if (consp arg)
      ;; This is like exchange-point-and-mark, but doesn't activate the mark.
      ;; It is cleaner to avoid activation, even though the command
      ;; loop would deactivate the mark because we inserted text.
      ;; (But it's an unnecessary kludge in XEmacs.)
      ;(goto-char (prog1 (mark t)
		   ;(set-marker (mark-marker) (point) (current-buffer)))))
      (exchange-point-and-mark t))
  ;; If we do get all the way thru, make this-command indicate that.
  (setq this-command 'yank)
  nil)

(defun rotate-yank-pointer (arg)
  "Rotate the yanking point in the kill ring.
With argument, rotate that many kills forward (or backward, if negative)."
  (interactive "p")
  (current-kill arg))


(defun insert-buffer (buffer)
  "Insert after point the contents of BUFFER.
Puts mark after the inserted text.
BUFFER may be a buffer or a buffer name."
  (interactive
   (list
    (progn
      (barf-if-buffer-read-only)
      (read-buffer "Insert buffer: "
		   ;; XEmacs: we have different args
		   (other-buffer (current-buffer) nil t)
		   t))))
  (or (bufferp buffer)
      (setq buffer (get-buffer buffer)))
  (let (start end newmark)
    (save-excursion
      (save-excursion
	(set-buffer buffer)
	(setq start (point-min) end (point-max)))
      (insert-buffer-substring buffer start end)
      (setq newmark (point)))
    (push-mark newmark))
  nil)

(defun append-to-buffer (buffer start end)
  "Append to specified buffer the text of the region.
It is inserted into that buffer before its point.

When calling from a program, give three arguments:
BUFFER (or buffer name), START and END.
START and END specify the portion of the current buffer to be copied."
  (interactive
   ;; XEmacs: we have different args to other-buffer
   (list (read-buffer "Append to buffer: " (other-buffer (current-buffer)
							 nil t))
	 (region-beginning) (region-end)))
  (let ((oldbuf (current-buffer)))
    (save-excursion
      (set-buffer (get-buffer-create buffer))
      (insert-buffer-substring oldbuf start end))))

(defun prepend-to-buffer (buffer start end)
  "Prepend to specified buffer the text of the region.
It is inserted into that buffer after its point.

When calling from a program, give three arguments:
BUFFER (or buffer name), START and END.
START and END specify the portion of the current buffer to be copied."
  (interactive "BPrepend to buffer: \nr")
  (let ((oldbuf (current-buffer)))
    (save-excursion
      (set-buffer (get-buffer-create buffer))
      (save-excursion
	(insert-buffer-substring oldbuf start end)))))

(defun copy-to-buffer (buffer start end)
  "Copy to specified buffer the text of the region.
It is inserted into that buffer, replacing existing text there.

When calling from a program, give three arguments:
BUFFER (or buffer name), START and END.
START and END specify the portion of the current buffer to be copied."
  (interactive "BCopy to buffer: \nr")
  (let ((oldbuf (current-buffer)))
    (save-excursion
      (set-buffer (get-buffer-create buffer))
      (erase-buffer)
      (save-excursion
	(insert-buffer-substring oldbuf start end)))))

;FSFmacs
;(put 'mark-inactive 'error-conditions '(mark-inactive error))
;(put 'mark-inactive 'error-message "The mark is not active now")

(defun mark (&optional force buffer)
  "Return this buffer's mark value as integer, or nil if no mark.

If `zmacs-regions' is true, then this returns nil unless the region is
currently in the active (highlighted) state.  With an argument of t, this
returns the mark (if there is one) regardless of the active-region state.
You should *generally* not use the mark unless the region is active, if
the user has expressed a preference for the active-region model.

If you are using this in an editing command, you are most likely making
a mistake; see the documentation of `set-mark'."
  (setq buffer (decode-buffer buffer))
;FSFmacs version:
;  (if (or force (not transient-mark-mode) mark-active mark-even-if-inactive)
;      (marker-position (mark-marker))
;    (signal 'mark-inactive nil)))
  (let ((m (mark-marker force buffer)))
    (and m (marker-position m))))

;;;#### FSFmacs
;;; Many places set mark-active directly, and several of them failed to also
;;; run deactivate-mark-hook.  This shorthand should simplify.
;(defsubst deactivate-mark ()
;  "Deactivate the mark by setting `mark-active' to nil.
;\(That makes a difference only in Transient Mark mode.)
;Also runs the hook `deactivate-mark-hook'."
;  (if transient-mark-mode
;      (progn
;	(setq mark-active nil)
;	(run-hooks 'deactivate-mark-hook))))

(defun set-mark (pos &optional buffer)
  "Set this buffer's mark to POS.  Don't use this function!
That is to say, don't use this function unless you want
the user to see that the mark has moved, and you want the previous
mark position to be lost.

Normally, when a new mark is set, the old one should go on the stack.
This is why most applications should use push-mark, not set-mark.

Novice Emacs Lisp programmers often try to use the mark for the wrong
purposes.  The mark saves a location for the user's convenience.
Most editing commands should not alter the mark.
To remember a location for internal use in the Lisp program,
store it in a Lisp variable.  Example:

   (let ((beg (point))) (forward-line 1) (delete-region beg (point)))."

  (setq buffer (decode-buffer buffer))
  (set-marker (mark-marker t buffer) pos buffer))
;; FSF
;  (if pos
;     (progn
;	(setq mark-active t)
;	(run-hooks 'activate-mark-hook)
;	(set-marker (mark-marker) pos (current-buffer)))
;    ;; Normally we never clear mark-active except in Transient Mark mode.
;    ;; But when we actually clear out the mark value too,
;    ;; we must clear mark-active in any mode.
;    (setq mark-active nil)
;    (run-hooks 'deactivate-mark-hook)
;    (set-marker (mark-marker) nil)))

(defvar mark-ring nil
  "The list of former marks of the current buffer, most recent first.")
(make-variable-buffer-local 'mark-ring)
(put 'mark-ring 'permanent-local t)

(defcustom mark-ring-max 16
  "*Maximum size of mark ring.  Start discarding off end if gets this big."
  :type 'integer
  :group 'killing)

(defvar global-mark-ring nil
  "The list of saved global marks, most recent first.")

(defcustom global-mark-ring-max 16
  "*Maximum size of global mark ring.  \
Start discarding off end if gets this big."
  :type 'integer
  :group 'killing)

(defun set-mark-command (arg)
  "Set mark at where point is, or jump to mark.
With no prefix argument, set mark, push old mark position on local mark
ring, and push mark on global mark ring.
With argument, jump to mark, and pop a new position for mark off the ring
\(does not affect global mark ring\).

Novice Emacs Lisp programmers often try to use the mark for the wrong
purposes.  See the documentation of `set-mark' for more information."
  (interactive "P")
  (if (null arg)
      (push-mark nil nil t)
    (if (null (mark t))
	(error "No mark set in this buffer")
      (goto-char (mark t))
      (pop-mark))))

;; XEmacs: Extra parameter
(defun push-mark (&optional location nomsg activate-region buffer)
  "Set mark at LOCATION (point, by default) and push old mark on mark ring.
If the last global mark pushed was not in the current buffer,
also push LOCATION on the global mark ring.
Display `Mark set' unless the optional second arg NOMSG is non-nil.
Activate mark if optional third arg ACTIVATE-REGION non-nil.

Novice Emacs Lisp programmers often try to use the mark for the wrong
purposes.  See the documentation of `set-mark' for more information."
  (setq buffer (decode-buffer buffer)) ; XEmacs
  (if (null (mark t buffer)) ; XEmacs
      nil
    ;; The save-excursion / set-buffer is necessary because mark-ring
    ;; is a buffer local variable
    (save-excursion
      (set-buffer buffer)
      (setq mark-ring (cons (copy-marker (mark-marker t buffer)) mark-ring))