home *** CD-ROM | disk | FTP | other *** search
/ Education Sampler 1992 [NeXTSTEP] / Education_1992_Sampler.iso / NeXT / GnuSource / emacs-15.0.3 / lisp / subr.el < prev    next >
Lisp/Scheme  |  1990-07-19  |  8KB  |  240 lines
  1. ;; Basic lisp subroutines for Emacs
  2. ;; Copyright (C) 1985, 1986 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. (defun one-window-p (&optional arg)
  23.   "Returns non-nil if there is only one window.
  24. Optional arg NOMINI non-nil means don't count the minibuffer
  25. even if it is active."
  26.   (eq (selected-window)
  27.       (next-window (selected-window) (if arg 'arg))))
  28.  
  29. (defun read-quoted-char (&optional prompt)
  30.   "Like `read-char', except that if the first character read is an octal
  31. digit, we read up to two more octal digits and return the character
  32. represented by the octal number consisting of those digits.
  33. Optional argument PROMPT specifies a string to use to prompt the user."
  34.   (let ((count 0) (code 0) char)
  35.     (while (< count 3)
  36.       (let ((inhibit-quit (zerop count))
  37.         (help-form nil))
  38.     (and prompt (message "%s-" prompt))
  39.     (setq char (read-char))
  40.     (if inhibit-quit (setq quit-flag nil)))
  41.       (cond ((null char))
  42.         ((and (<= ?0 char) (<= char ?7))
  43.          (setq code (+ (* code 8) (- char ?0))
  44.            count (1+ count))
  45.          (and prompt (message (setq prompt
  46.                     (format "%s %c" prompt char)))))
  47.         ((> count 0)
  48.          (setq unread-command-char char count 259))
  49.         (t (setq code char count 259))))
  50.     (logand 255 code)))
  51.  
  52. (defun error (&rest args)
  53.   "Signal an error, making error message by passing all args to `format'."
  54.   (while t
  55.     (signal 'error (list (apply 'format args)))))
  56.  
  57. (defun undefined ()
  58.   (interactive)
  59.   (ding))
  60.  
  61. ;Prevent the \{...} documentation construct
  62. ;from mentioning keys that run this command.
  63. (put 'undefined 'suppress-keymap t)
  64.  
  65. (defun suppress-keymap (map &optional arg)
  66.   "Make MAP override all buffer-modifying commands to be undefined.
  67. Works by knowing which commands are normally buffer-modifying.
  68. Normally also makes digits set numeric arg,
  69. but optional second arg NODIGITS non-nil prevents this."
  70.   (let ((i ? ))
  71.     (while (< i 127)
  72.       (aset map i 'undefined)
  73.       (setq i (1+ i))))
  74.   (or arg
  75.       (let (loop)
  76.     (aset map ?- 'negative-argument)
  77.     ;; Make plain numbers do numeric args.
  78.     (setq loop ?0)
  79.     (while (<= loop ?9)
  80.       (aset map loop 'digit-argument)
  81.       (setq loop (1+ loop))))))
  82.  
  83. ;; now in fns.c
  84. ;(defun nth (n list)
  85. ;  "Returns the Nth element of LIST.
  86. ;N counts from zero.  If LIST is not that long, nil is returned."
  87. ;  (car (nthcdr n list)))
  88. ;
  89. ;(defun copy-alist (alist)
  90. ;  "Return a copy of ALIST.
  91. ;This is a new alist which represents the same mapping
  92. ;from objects to objects, but does not share the alist structure with ALIST.
  93. ;The objects mapped (cars and cdrs of elements of the alist)
  94. ;are shared, however."
  95. ;  (setq alist (copy-sequence alist))
  96. ;  (let ((tail alist))
  97. ;    (while tail
  98. ;      (if (consp (car tail))
  99. ;      (setcar tail (cons (car (car tail)) (cdr (car tail)))))
  100. ;      (setq tail (cdr tail))))
  101. ;  alist)
  102.  
  103. ;Moved to keymap.c
  104. ;(defun copy-keymap (keymap)
  105. ;  "Return a copy of KEYMAP"  
  106. ;  (while (not (keymapp keymap))
  107. ;    (setq keymap (signal 'wrong-type-argument (list 'keymapp keymap))))
  108. ;  (if (vectorp keymap)
  109. ;      (copy-sequence keymap)
  110. ;      (copy-alist keymap)))
  111.  
  112. (defun substitute-key-definition (olddef newdef keymap)
  113.   "Replace OLDDEF with NEWDEF for any keys in KEYMAP now defined as OLDDEF.
  114. In other words, OLDDEF is replaced with NEWDEF where ever it appears."
  115.   (if (arrayp keymap)
  116.       (let ((len (length keymap))
  117.         (i 0))
  118.     (while (< i len)
  119.       (if (eq (aref keymap i) olddef)
  120.           (aset keymap i newdef))
  121.       (setq i (1+ i))))
  122.     (while keymap
  123.       (if (eq (cdr-safe (car-safe keymap)) olddef)
  124.       (setcdr (car keymap) newdef))
  125.       (setq keymap (cdr keymap)))))
  126.  
  127. ;; Avoids useless byte-compilation.
  128. ;; In the future, would be better to fix byte compiler
  129. ;; not to really compile in cases like this,
  130. ;; and use defun here.
  131. (fset 'ignore '(lambda (&rest ignore) nil))
  132.  
  133.  
  134. ; old names
  135. (fset 'make-syntax-table 'copy-syntax-table)
  136. (fset 'dot 'point)
  137. (fset 'dot-marker 'point-marker)
  138. (fset 'dot-min 'point-min)
  139. (fset 'dot-max 'point-max)
  140. (fset 'window-dot 'window-point)
  141. (fset 'set-window-dot 'set-window-point)
  142. (fset 'read-input 'read-string)
  143. (fset 'send-string 'process-send-string)
  144. (fset 'send-region 'process-send-region)
  145. (fset 'show-buffer 'set-window-buffer)
  146.  
  147. ; alternate names
  148. (fset 'string= 'string-equal)
  149. (fset 'string< 'string-lessp)
  150. (fset 'mod '%)
  151. (fset 'move-marker 'set-marker)
  152. (fset 'eql 'eq)
  153. (fset 'not 'null)
  154. (fset 'numberp 'integerp)
  155. (fset 'rplaca 'setcar)
  156. (fset 'rplacd 'setcdr)
  157. (fset 'beep 'ding) ;preserve lingual purtity
  158. (fset 'indent-to-column 'indent-to)
  159. (fset 'backward-delete-char 'delete-backward-char)
  160.  
  161. (defvar global-map nil
  162.   "Default global keymap mapping Emacs keyboard input into commands.
  163. The value is a keymap which is usually (but not necessarily) Emacs's
  164. global map.")
  165.  
  166. (defvar ctl-x-map nil
  167.   "Default keymap for C-x commands.
  168. The normal global definition of the character C-x indirects to this keymap.")
  169.  
  170. (defvar esc-map nil
  171.   "Default keymap for ESC (meta) commands.
  172. The normal global definition of the character ESC indirects to this keymap.")
  173.  
  174. (defvar mouse-map nil
  175.   "Keymap for mouse commands from the X window system.")
  176.  
  177. (defun run-hooks (&rest hooklist)
  178.   "Takes hook names and runs each one in turn.  Major mode functions use this.
  179. Each argument should be a symbol, a hook variable.
  180. These symbols are processed in the order specified.
  181. If a hook symbol has a non-nil value, that value may be a function
  182. or a list of functions to be called to run the hook.
  183. If the value is a function, it is called with no arguments.
  184. If it is a list, the elements are called, in order, with no arguments."
  185.   (while hooklist
  186.     (let ((sym (car hooklist)))
  187.       (and (boundp sym)
  188.        (symbol-value sym)
  189.        (let ((value (symbol-value sym)))
  190.          (if (and (listp value) (not (eq (car value) 'lambda)))
  191.          (mapcar 'funcall value)
  192.            (funcall value)))))
  193.     (setq hooklist (cdr hooklist))))
  194.  
  195. (defun momentary-string-display (string pos &optional exit-char message) 
  196.   "Momentarily display STRING in the buffer at POS.
  197. Display remains until next character is typed.
  198. If the char is EXIT-CHAR (optional third arg, default is SPC) it is swallowed;
  199. otherwise it is then available as input (as a command if nothing else).
  200. Display MESSAGE (optional fourth arg) in the echo area.
  201. If MESSAGE is nil, instructions to type EXIT-CHAR are displayed there."
  202.   (or exit-char (setq exit-char ?\ ))
  203.   (let ((buffer-read-only nil)
  204.     (modified (buffer-modified-p))
  205.     (name buffer-file-name)
  206.     insert-end)
  207.     (unwind-protect
  208.     (progn
  209.       (save-excursion
  210.         (goto-char pos)
  211.         ;; defeat file locking... don't try this at home, kids!
  212.         (setq buffer-file-name nil)
  213.         (insert-before-markers string)
  214.         (setq insert-end (point)))
  215.       (message (or message "Type %s to continue editing.")
  216.            (single-key-description exit-char))
  217.       (let ((char (read-char)))
  218.         (or (eq char exit-char)
  219.         (setq unread-command-char char))))
  220.       (if insert-end
  221.       (save-excursion
  222.         (delete-region pos insert-end)))
  223.       (setq buffer-file-name name)
  224.       (set-buffer-modified-p modified))))
  225.  
  226. (defun undo-start ()
  227.   "Move undo-pointer to front of undo records.
  228. The next call to undo-more will undo the most recently made change."
  229.   (if (eq buffer-undo-list t)
  230.       (error "No undo information in this buffer"))
  231.   (setq pending-undo-list buffer-undo-list))
  232.  
  233. (defun undo-more (count)
  234.   "Undo back N undo-boundaries beyond what was already undone recently.
  235. Call undo-start to get ready to undo recent changes,
  236. then call undo-more one or more times to undo them."
  237.   (or pending-undo-list
  238.       (error "No further undo information"))
  239.   (setq pending-undo-list (primitive-undo count pending-undo-list)))
  240.