home *** CD-ROM | disk | FTP | other *** search
/ Education Sampler 1992 [NeXTSTEP] / Education_1992_Sampler.iso / NeXT / GnuSource / emacs-15.0.3 / lisp / register.el < prev    next >
Lisp/Scheme  |  1990-07-19  |  6KB  |  177 lines
  1. ;; Register commands for Emacs.
  2. ;; Copyright (C) 1985 Free Software Foundation, Inc.
  3.  
  4. ;; This file is part of GNU Emacs.
  5.  
  6. ;; GNU Emacs is distributed in the hope that it will be useful,
  7. ;; but WITHOUT ANY WARRANTY.  No author or distributor
  8. ;; accepts responsibility to anyone for the consequences of using it
  9. ;; or for whether it serves any particular purpose or works at all,
  10. ;; unless he says so in writing.  Refer to the GNU Emacs General Public
  11. ;; License for full details.
  12.  
  13. ;; Everyone is granted permission to copy, modify and redistribute
  14. ;; GNU Emacs, but only under the conditions described in the
  15. ;; GNU Emacs General Public License.   A copy of this license is
  16. ;; supposed to have been given to you along with GNU Emacs so you
  17. ;; can know your rights and responsibilities.  It should be in a
  18. ;; file named COPYING.  Among other things, the copyright notice
  19. ;; and this notice must be preserved on all copies.
  20.  
  21.  
  22. (defvar register-alist nil
  23.   "Alist of elements (NAME . CONTENTS), one for each Emacs register.
  24. NAME is a character (a number).  CONTENTS is a string, number,
  25. mark or list.  A list represents a rectangle; its elements are strings.")
  26.  
  27. (defun get-register (char)
  28.   "Return contents of Emacs register named CHAR, or nil if none."
  29.   (cdr (assq char register-alist)))
  30.  
  31. (defun set-register (char value)
  32.   "Set contents of Emacs register named CHAR to VALUE."
  33.   (let ((aelt (assq char register-alist)))
  34.     (if aelt
  35.     (setcdr aelt value)
  36.       (setq aelt (cons char value))
  37.       (setq register-alist (cons aelt register-alist)))))
  38.  
  39. (defun point-to-register (char)
  40.   "Store current location of point in a register.
  41. Argument is a character, naming the register."
  42.   (interactive "cPoint to register: ")
  43.   (set-register char (point-marker)))
  44.  
  45. (defun register-to-point (char)
  46.   "Move point to location stored in a register.
  47. Argument is a character, naming the register."
  48.   (interactive "cRegister to point: ")
  49.   (let ((val (get-register char)))
  50.     (if (markerp val)
  51.     (progn
  52.       (switch-to-buffer (marker-buffer val))
  53.       (goto-char val))
  54.       (error "Register doesn't contain a buffer position"))))
  55.  
  56. ;(defun number-to-register (arg char)
  57. ;  "Store a number in a register.
  58. ;Two args, NUMBER and REGISTER (a character, naming the register).
  59. ;If NUMBER is nil, digits in the buffer following point are read
  60. ;to get the number to store.
  61. ;Interactively, NUMBER is the prefix arg (none means nil)."
  62. ;  (interactive "P\ncNumber to register: ")
  63. ;  (set-register char 
  64. ;        (if arg
  65. ;            (prefix-numeric-value arg)
  66. ;          (if (looking-at "[0-9][0-9]*")
  67. ;              (save-excursion
  68. ;               (save-restriction
  69. ;            (narrow-to-region (point)
  70. ;                      (progn (skip-chars-forward "0-9")
  71. ;                         (point)))
  72. ;            (goto-char (point-min))
  73. ;            (read (current-buffer))))
  74. ;            0))))
  75.  
  76. ;(defun increment-register (arg char)
  77. ;  "Add NUMBER to the contents of register REGISTER.
  78. ;Interactively, NUMBER is the prefix arg (none means nil)." 
  79. ;  (interactive "p\ncNumber to register: ")
  80. ;  (or (integerp (get-register char))
  81. ;      (error "Register does not contain a number"))
  82. ;  (set-register char (+ arg (get-register char))))
  83.  
  84. (defun view-register (char)
  85.   "Display what is contained in register named REGISTER.
  86. REGISTER is a character."
  87.   (interactive "cView register: ")
  88.   (let ((val (get-register char)))
  89.     (if (null val)
  90.     (message "Register %s is empty" (single-key-description char))
  91.       (with-output-to-temp-buffer "*Output*"
  92.     (princ "Register ")
  93.     (princ (single-key-description char))
  94.     (princ " contains ")
  95.     (if (integerp val)
  96.         (princ val)
  97.       (if (markerp val)
  98.           (progn
  99.         (princ "a buffer position:\nbuffer ")
  100.         (princ (buffer-name (marker-buffer val)))
  101.         (princ ", position ")
  102.         (princ (+ 0 val)))
  103.         (if (consp val)
  104.         (progn
  105.           (princ "the rectangle:\n")
  106.           (while val
  107.             (princ (car val))
  108.             (terpri)
  109.             (setq val (cdr val))))
  110.           (princ "the string:\n")
  111.           (princ val))))))))
  112.  
  113. (defun insert-register (char &optional arg)
  114.   "Insert contents of register REG.  REG is a character.
  115. Normally puts point before and mark after the inserted text.
  116. If optional second arg is non-nil, puts mark before and point after.
  117. Interactively, second arg is non-nil if prefix arg is supplied."
  118.   (interactive "cInsert register: \nP")
  119.   (push-mark)
  120.   (let ((val (get-register char)))
  121.     (if (consp val)
  122.     (insert-rectangle val)
  123.       (if (stringp val)
  124.       (insert val)
  125.     (if (or (integerp val) (markerp val))
  126.         (princ (+ 0 val) (current-buffer))
  127.       (error "Register does not contain text")))))
  128.   (or arg (exchange-point-and-mark)))
  129.  
  130. (defun copy-to-register (char start end &optional delete-flag)
  131.   "Copy region into register REG.
  132. With prefix arg, delete as well.
  133. Called from program, takes four args:
  134. REG, START, END and DELETE-FLAG.
  135. START and END are buffer positions indicating what to copy."
  136.   (interactive "cCopy to register: \nr\nP")
  137.   (set-register char (buffer-substring start end))
  138.   (if delete-flag (delete-region start end)))
  139.  
  140. (defun append-to-register (char start end &optional delete-flag)
  141.   "Append region to text in register REG.
  142. With prefix arg, delete as well.
  143. Called from program, takes four args:
  144. REG, START, END and DELETE-FLAG.
  145. START and END are buffer positions indicating what to append."
  146.   (interactive "cAppend to register: \nr\nP")
  147.   (or (stringp (get-register char))
  148.       (error "Register does not contain text"))
  149.   (set-register char (concat (get-register char)
  150.                  (buffer-substring start end)))
  151.   (if delete-flag (delete-region start end)))
  152.  
  153. (defun prepend-to-register (char start end &optional delete-flag)
  154.   "Prepend region to text in register REG.
  155. With prefix arg, delete as well.
  156. Called from program, takes four args:
  157. REG, START, END and DELETE-FLAG.
  158. START and END are buffer positions indicating what to prepend."
  159.   (interactive "cPrepend to register: \nr\nP")
  160.   (or (stringp (get-register char))
  161.       (error "Register does not contain text"))
  162.   (set-register char (concat (buffer-substring start end)
  163.                  (get-register char)))
  164.   (if delete-flag (delete-region start end)))
  165.  
  166. (defun copy-rectangle-to-register (char start end &optional delete-flag)
  167.   "Copy rectangular region into register REG.
  168. With prefix arg, delete as well.
  169. Called from program, takes four args:
  170. REG, START, END and DELETE-FLAG.
  171. START and END are buffer positions giving two corners of rectangle."
  172.   (interactive "cCopy rectangle to register: \nr\nP")
  173.   (set-register char
  174.         (if delete-flag
  175.             (delete-extract-rectangle start end)
  176.           (extract-rectangle start end))))
  177.