home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Source Code 1993 July / THE_SOURCE_CODE_CD_ROM.iso / languages / elisp / interfaces / Emacs-cl-shell / misc-extensions.el < prev    next >
Encoding:
Text File  |  1991-04-08  |  11.3 KB  |  313 lines
  1. ;;;; This is a file of useful miscellaneous extensions to emacs.
  2. ;;;; NOTE: it does not bind any keys -- it only provides function
  3. ;;;; definitions.  To use it, you should put lines into your .emacs
  4. ;;;; file which will load the file and then setup the desired
  5. ;;;; keybindings.  See example.emacs.
  6.  
  7. ;;;; ---------------- Miscellaneous Command definitions -----------------
  8.  
  9. ;;; Nice little function which rebinds keys which call old-function to
  10. ;;; call new-function.
  11. (defun rebind-keys-which-call (old-function new-function &optional keymap)
  12.   (if keymap
  13.       (mapcar '(lambda (key) (define-key keymap key new-function))
  14.           (where-is-internal old-function keymap))
  15.       (mapcar '(lambda (key) (global-set-key key new-function))
  16.           (where-is-internal old-function))))
  17.  
  18. ;;; Have emacs call the right kind of fill command (i.e.
  19. ;;; fill-paragraph or indent-sexp), depending on whether it is on a
  20. ;;; comment line or a code line.  To do make this work properly, you
  21. ;;; must set the paragraph-start and paragraph-separate variables
  22. ;;; properly (see example.emacs).
  23. (defun lisp-fill-paragraph (&optional justify-p)
  24.   "Fill-paragraph command for lisp-mode that knows how to fill
  25. both comments and code.  To use this, you need to set up the
  26. regular expressions contained in the buffer-variables paragraph-start 
  27. and paragraph-separate correctly."
  28.   (interactive)
  29.   (save-excursion
  30.     (beginning-of-line)
  31.     (cond ((looking-at "[ \t]*;")          ;if comment
  32.        (let ((old-fill-prefix fill-prefix)
  33.          (start (point)))
  34.          (re-search-forward ";+ ?")    ;count semicolons
  35. ;;         (untabify start (point))    ;convert tabs to spaces.
  36.          (setq fill-prefix (buffer-substring start (point)))
  37.          (unwind-protect
  38.           (fill-paragraph justify-p)
  39.            (setq fill-prefix old-fill-prefix))))
  40.       (t (forward-char 1)        ;if on defun, don't go backward
  41.          (beginning-of-defun)
  42.          (indent-sexp)))))
  43.  
  44. ;;; Expand all symlinks in the filename.  Useful for lisp source file
  45. ;;; names, since Lucid Common Lisp expands all symlinks when recording
  46. ;;; source files.
  47. (defun expand-symlinks (file &optional position prev-position)
  48.   (if (null position)            ;first call
  49.       (setq file (expand-file-name file)
  50.         position (or (string-match "/" file 1) (length file))
  51.         prev-position 0))
  52.   (let ((e-file (file-symlink-p (substring file 0 position))))
  53.     (cond (e-file
  54.        (setq e-file (directory-file-name e-file)) ;strip trailing "/"
  55.        (expand-symlinks (concat (substring file 0 (1+ prev-position))
  56.                     e-file
  57.                     (substring file position))))
  58.       ((> (length file) position)
  59.        (expand-symlinks file
  60.                 (or (string-match "/" file (1+ position)) (length file))
  61.                 position))
  62.       (t file))))
  63.  
  64. ;;; Redefine this (from simple.el) to get rid of newlines along with
  65. ;;; tabs and spaces.
  66. (defun my-just-one-space ()
  67.   "Delete all spaces, tabs and newlines around point, leaving one space."
  68.   (interactive "*")
  69.   (skip-chars-backward " \t\n")
  70.   (if (= (following-char) ? )        ; space?
  71.       (forward-char 1) 
  72.       (insert ? ))
  73.   (delete-region (point) (progn (skip-chars-forward " \t\n") (point))))
  74.  
  75. (defun delete-forward-whitespace ()
  76.   "Delete all spaces, tabs and newlines after cursor."
  77.   (interactive)
  78.   (delete-region (point) (progn (skip-chars-forward " \t\n") (point))))
  79.  
  80. ;;; Non-nil optional third arg to set-window-start would inhibit point motion.
  81. (defun reposition-defun-at-top ()
  82.   "Put current defun at top of window."
  83.   (interactive)
  84.   (set-window-start
  85.    (get-buffer-window (current-buffer))
  86.    (save-excursion
  87.      (end-of-defun)
  88.      (beginning-of-defun)
  89.      (point)))) 
  90.  
  91. (defun reposition-point-at-top ()
  92.   "Scroll contents of current window so that point is at top."
  93.   (interactive)
  94.   (recenter 0))
  95.  
  96. ;;; Grep for symbol nearest point in files *.lisp.  Should modify this
  97. ;;; to remember the directory you last grepped in...
  98. (defun cl-grep-for-symbol (grep-args)
  99.   (interactive 
  100.    (list (read-string "Run grep: "
  101.               (let ((default (find-tag-default)))
  102.             (if default
  103.                 (concat "\"" default "\"" " *.lisp")
  104.                 "")))))
  105.    (grep grep-args))
  106.  
  107. ;;; The most useful mouse binding I've seen!  Copies the sexp under
  108. ;;; the mouse to the point.  This is from the TMC emacs extensions.
  109. (defun x-mouse-paste-sexp (arg)
  110.   "Copies sexp containing mouse position to point."
  111.   (let ((current-window (selected-window))
  112.     (current-buffer (current-buffer)))
  113.     (if (x-mouse-select arg)
  114.     (let ((temp
  115.            (save-excursion 
  116.          (x-mouse-set-point arg)
  117.                  ;; get the point to the beginning of this symbol if
  118.                  ;; we are sitting in the middle of one
  119.          (let ((syntax-of-buffer-char 
  120.             (if (= (point) (point-min)) 0
  121.                 (char-syntax
  122.                  (string-to-char
  123.                   (buffer-substring (1- (point)) (point)))))))
  124.            (if (or (= syntax-of-buffer-char (char-syntax ?x))
  125.                (= syntax-of-buffer-char (char-syntax ?:)))
  126.                (forward-sexp -1)))
  127.          (let ((old-point (point)))
  128.            (forward-sexp 1)
  129.            (buffer-substring old-point (point))))))
  130.       ;; This code doesn't work for the minibuffer.  It'd be
  131.       ;; really nice if it did.
  132.       (select-window current-window)
  133.       (switch-to-buffer current-buffer)
  134.       (let ((before-inserted-text (point)))
  135.         ;; maybe put in a blank space
  136.         (let* ((buffer-char
  137.             (if (= (point) (point-min))
  138.             nil
  139.             (string-to-char (buffer-substring (1- (point)) (point)))))
  140.            (syntax-of-buffer-char (if buffer-char (char-syntax buffer-char))))
  141.           (if (and buffer-char (or (= syntax-of-buffer-char (char-syntax ?x))
  142.                        (= syntax-of-buffer-char (char-syntax ?:))
  143.                        (= buffer-char ?\))))
  144.           (insert " ")))
  145.         (let ((temp1 (point)) temp2)
  146.           (insert temp)
  147.           (setq temp2 (point-marker)) ;use a marker since indent-sexp will add chars
  148.           (goto-char temp1)
  149.           (indent-sexp)
  150.           (goto-char temp2))
  151.         (set-mark before-inserted-text))))))
  152.  
  153. ;;; Useful debugging macro for emacs-lisp code.
  154. (defmacro print-db (form &optional pop-up)
  155.   "Insert FORM and its evaluated value at the end of the *debug* buffer.
  156. If optional second arg POP-UP is non-nil, display the buffer.  Returns 
  157. evaluated value of FORM." 
  158.   (list 'let (list (list 'val form)
  159.            '(buf (current-buffer))
  160.            '(db-buf (get-buffer-create "*debug*")))
  161.     (list 'if pop-up '(pop-to-buffer db-buf) '(set-buffer db-buf))
  162.     '(goto-char (point-max))
  163.     (list 'insert (list 'format "%s  %s\n" (list 'quote form) 'val))
  164.     '(set-buffer buf)
  165.     'val))
  166.  
  167. ;;;; ---------------- Mouse commands -----------------
  168.  
  169. ;;; For back-compatibility: this was the old TMC name.
  170. (defun x-mouse-paste-sexp (arg)
  171.   (x-copy-sexp arg))
  172.  
  173. ;;; This one is the most useful mouse binding I've seen!  Copies the
  174. ;;; sexp under the mouse to the point.  This is modified slightly from
  175. ;;; the TMC emacs extensions.  If the sexp is followed by a newline
  176. ;;; character, it is included in the copy.
  177. (defun x-copy-sexp (arg)
  178.   "Copy sexp (and trailing newline) containing the mouse to the point."
  179.   (let ((current-window (selected-window))
  180.     (current-buffer (current-buffer)))
  181.     (if (x-mouse-select arg)
  182.     (let ((sexp (save-excursion
  183.               (x-mouse-set-point arg)
  184.               (get-surrounding-sexp))))
  185.       (select-window current-window)
  186.       (switch-to-buffer current-buffer)
  187.       (insert-indented-sexp sexp)))))
  188.  
  189. (defun x-move-sexp (arg)
  190.   "Move sexp (and trailing newline) containing the mouse to the point."
  191.   (let ((current-window (selected-window))
  192.     (current-buffer (current-buffer)))
  193.     (if (x-mouse-select arg)
  194.     (let ((sexp (save-excursion
  195.               (x-mouse-set-point arg)
  196.               (get-surrounding-sexp 'kill))))
  197.       (select-window current-window)
  198.       (switch-to-buffer current-buffer)
  199.       (insert-indented-sexp sexp)))))
  200.  
  201. ;;; *** Should we also have an x-swap-sexps functions?  No.  Too hairy.
  202. (defun x-replace-sexp (arg)
  203.   "Replace sexp under point with sexp containing mouse."
  204.   (let ((current-window (selected-window))
  205.     (current-buffer (current-buffer)))
  206.     (if (x-mouse-select arg)
  207.     (let ((sexp (save-excursion
  208.               (x-mouse-set-point arg)
  209.               (get-surrounding-sexp))))
  210.       (select-window current-window)
  211.       (switch-to-buffer current-buffer)
  212.       (get-surrounding-sexp 'kill)
  213.       (insert-indented-sexp sexp)))))
  214.  
  215. (defun x-zap-sexp (arg)
  216.   "Cut and wipe the sexp (and trailing newline) containing the mouse."
  217.   (let ((current-window (selected-window))
  218.     (current-buffer (current-buffer)))
  219.     (if (x-mouse-select arg)
  220.     (let ((sexp (save-excursion
  221.               (x-mouse-set-point arg)
  222.               (get-surrounding-sexp 'kill))))
  223.       (select-window current-window)
  224.       (switch-to-buffer current-buffer)))))
  225.  
  226. (defun get-surrounding-sexp (&optional kill)
  227.   "Returns a string containing the surrounding sexp, including the
  228. trailing carriage return (if there is one).  If kill is non-nil, delete
  229. the string and indent the remaining line according to major mode."
  230.   (save-excursion 
  231.     ;; get the point to the beginning of this symbol if
  232.     ;; we are sitting in the middle of one
  233.     (let ((syntax-of-buffer-char 
  234.        (if (= (point) (point-min)) 0
  235.            (char-syntax
  236.         (string-to-char
  237.          (buffer-substring (1- (point)) (point)))))))
  238.       (if (or (= syntax-of-buffer-char (char-syntax ?x))
  239.           (= syntax-of-buffer-char (char-syntax ?:)))
  240.       (forward-sexp -1)))
  241.     (let ((old-point (point))
  242.       sexp)
  243.       (forward-sexp 1)
  244.       ;(if (looking-at "\n") (forward-char 1))
  245.       (setq sexp (buffer-substring old-point (point)))
  246.       (if (not kill)
  247.       nil
  248.     (delete-region old-point (point))
  249.     (indent-according-to-mode))
  250.       sexp)))
  251.  
  252. ;;; This code doesn't work for the minibuffer.  It'd be really nice if
  253. ;;; it did.
  254. (defun insert-indented-sexp (sexp)
  255.   "Insert sexp at point, indenting according to major mode.  Set mark 
  256. before inserted text, and leave point after."
  257.   (let ((before-inserted-text (point)))
  258.     ;; maybe put in a blank space
  259.     (let* ((buffer-char
  260.         (if (= (point) (point-min))
  261.         nil
  262.         (string-to-char (buffer-substring (1- (point)) (point)))))
  263.        (syntax-of-buffer-char (if buffer-char (char-syntax buffer-char))))
  264.       (if (and buffer-char (or (= syntax-of-buffer-char (char-syntax ?x))
  265.                    (= syntax-of-buffer-char (char-syntax ?:))
  266.                    (= buffer-char ?\))))
  267.       (insert " ")))
  268.     (let ((temp1 (point)) temp2)
  269.       (insert sexp)
  270.       (setq temp2 (point-marker))    ;use a marker since indent-sexp will add chars
  271.       (goto-char temp1)
  272.       (indent-sexp)
  273.       (goto-char temp2)
  274.       ;(indent-according-to-mode)
  275.       )
  276.     (set-mark before-inserted-text)))
  277.  
  278. (defun x-line-to-top (arg)
  279.   "Scrolls the line at the mouse to the top of the window."
  280.   (let* ((current-window (selected-window))
  281.      (current-buffer (current-buffer))
  282.      relative-coordinate)
  283.     (save-excursion
  284.       (setq relative-coordinate (x-mouse-select arg)))
  285.     (if relative-coordinate
  286.     (scroll-up (car (cdr relative-coordinate))))))
  287.  
  288. (defun x-line-to-middle (arg)
  289.   "Scrolls the line at the mouse to the middle of the window."
  290.   (let* ((current-window (selected-window))
  291.      (current-buffer (current-buffer))
  292.      relative-coordinate)
  293.     (save-excursion
  294.       (setq relative-coordinate (x-mouse-select arg)))
  295.     (if relative-coordinate
  296.     (scroll-down (- (/ (window-height) 2)
  297.             (car (cdr relative-coordinate))
  298.             1)))))
  299.  
  300. (defun x-line-to-bottom (arg)
  301.   "Scrolls the line at the mouse to the bottom of the window."
  302.   (let* ((current-window (selected-window))
  303.      (current-buffer (current-buffer))
  304.      relative-coordinate)
  305.     (save-excursion
  306.       (setq relative-coordinate (x-mouse-select arg)))
  307.     (if relative-coordinate
  308.     (scroll-down (- (window-height)
  309.             (car (cdr relative-coordinate))
  310.             2)))))
  311.  
  312.  
  313.