Return to subr.el CVS log

Up to [Apple XNU] / GNUtools / emacs / lisp

Annotation of GNUtools/emacs/lisp/subr.el, revision 1.1

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

This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.