cgit.sxemacs.org Git - sxemacs/blob - lisp/lisp.el

   1 ;;; lisp.el --- Lisp editing commands for SXEmacs
   2
   3 ;; Copyright (C) 1985, 1986, 1994, 1997 Free Software Foundation, Inc.
   4
   5 ;; Maintainer: FSF
   6 ;; Keywords: lisp, languages, dumped
   7
   8 ;; This file is part of SXEmacs.
   9
  10 ;; SXEmacs is free software: you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation, either version 3 of the License, or
  13 ;; (at your option) any later version.
  14
  15 ;; SXEmacs is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
  22
  23 ;;; Synched up with: Emacs/Mule zeta.
  24
  25 ;;; Commentary:
  26
  27 ;; This file is dumped with SXEmacs.
  28
  29 ;; Lisp editing commands to go with Lisp major mode.
  30
  31 ;; 06/11/1997 - Use char-(after|before) instead of
  32 ;;  (following|preceding)-char. -slb
  33
  34 ;;; Code:
  35
  36 ;; Note that this variable is used by non-lisp modes too.
  37 (defcustom defun-prompt-regexp nil
  38   "*Non-nil => regexp to ignore, before the character that starts a defun.
  39 This is only necessary if the opening paren or brace is not in column 0.
  40 See `beginning-of-defun'."
  41   :type '(choice (const :tag "none" nil)
  42                  regexp)
  43   :group 'lisp)
  44
  45 (make-variable-buffer-local 'defun-prompt-regexp)
  46
  47 (defcustom parens-require-spaces t
  48   "Non-nil => `insert-parentheses' should insert whitespace as needed."
  49   :type 'boolean
  50   :group 'editing-basics
  51   :group 'lisp)
  52
  53 (defun forward-sexp (&optional arg)
  54   "Move forward across one balanced expression (sexp).
  55 With argument, do it that many times.  Negative arg -N means
  56 move backward across N balanced expressions."
  57   ;; XEmacs change (for zmacs regions)
  58   (interactive "_p")
  59   (or arg (setq arg 1))
  60   ;; XEmacs: evil hack! The other half of the evil hack below.
  61   (if (and (> arg 0) (looking-at "#s(\\|#r[uU]?\"\\|#p\\["))
  62     (goto-char (1+ (- (point) (- (match-end 0) (match-beginning 0))))))
  63   (goto-char (or (scan-sexps (point) arg) (buffer-end arg)))
  64   (when (< arg 0)
  65     (backward-prefix-chars)
  66     ;; XEmacs: evil hack! Skip back over #[sr] so that structures and raw
  67     ;; strings are read properly.  the current cheesified syntax tables just
  68     ;; aren't up to this.
  69     (let* ((diff (- (point) (point-min)))
  70            (subject (buffer-substring (- (point) (min diff 3))
  71                                       (1+ (point))))
  72            (matched (string-match "#s(\\|#r[uU]?\"\\|#p\\[" subject)))
  73       (if matched
  74         (goto-char (1+ (- (point) (- (length subject) matched))))))))
  75
  76 (defun backward-sexp (&optional arg)
  77   "Move backward across one balanced expression (sexp).
  78 With argument, do it that many times.  Negative arg -N means
  79 move forward across N balanced expressions."
  80   ;; XEmacs change (for zmacs regions)
  81   (interactive "_p")
  82   (forward-sexp (- (or arg 1))))
  83
  84 (defun mark-sexp (&optional arg)
  85   "Set mark ARG sexps from point.
  86 The place mark goes is the same place \\[forward-sexp] would
  87 move to with the same argument.
  88 Repeat this command to mark more sexps in the same direction."
  89   (interactive "p")
  90   (mark-something 'mark-sexp 'forward-sexp (or arg 1)))
  91
  92 (defun forward-list (&optional arg)
  93   "Move forward across one balanced group of parentheses.
  94 With argument, do it that many times.
  95 Negative arg -N means move backward across N groups of parentheses."
  96   ;; XEmacs change
  97   (interactive "_p")
  98   (goto-char (or (scan-lists (point) (or arg 1) 0) (buffer-end (or arg 1)))))
  99
 100 (defun backward-list (&optional arg)
 101   "Move backward across one balanced group of parentheses.
 102 With argument, do it that many times.
 103 Negative arg -N means move forward across N groups of parentheses."
 104   ;; XEmacs change (for zmacs regions)
 105   (interactive "_p")
 106   (forward-list (- (or arg 1))))
 107
 108 (defun down-list (&optional arg)
 109   "Move forward down one level of parentheses.
 110 With argument, do this that many times.
 111 A negative argument means move backward but still go down a level."
 112   ;; XEmacs change (for zmacs regions)
 113   (interactive "_p")
 114   (or arg (setq arg 1))
 115   (let ((inc (if (> arg 0) 1 -1)))
 116     (while (/= arg 0)
 117       (goto-char (or (scan-lists (point) inc -1) (buffer-end arg)))
 118       (setq arg (- arg inc)))))
 119
 120 (defun backward-up-list (&optional arg)
 121   "Move backward out of one level of parentheses.
 122 With argument, do this that many times.
 123 A negative argument means move forward but still to a less deep spot."
 124   (interactive "_p")
 125   (up-list (- (or arg 1))))
 126
 127 (defun up-list (&optional arg)
 128   "Move forward out of one level of parentheses.
 129 With argument, do this that many times.
 130 A negative argument means move backward but still to a less deep spot.
 131 In Lisp programs, an argument is required."
 132   ;; XEmacs change (for zmacs regions)
 133   (interactive "_p")
 134   (or arg (setq arg 1))
 135   (let ((inc (if (> arg 0) 1 -1)))
 136     (while (/= arg 0)
 137       (goto-char (or (scan-lists (point) inc 1) (buffer-end arg)))
 138       (setq arg (- arg inc)))))
 139
 140 (defun kill-sexp (&optional arg)
 141   "Kill the sexp (balanced expression) following the cursor.
 142 With argument, kill that many sexps after the cursor.
 143 Negative arg -N means kill N sexps before the cursor."
 144   (interactive "p")
 145   (let ((opoint (point)))
 146     (forward-sexp (or arg 1))
 147     (kill-region opoint (point))))
 148
 149 (defun backward-kill-sexp (&optional arg)
 150   "Kill the sexp (balanced expression) preceding the cursor.
 151 With argument, kill that many sexps before the cursor.
 152 Negative arg -N means kill N sexps after the cursor."
 153   (interactive "p")
 154   (kill-sexp (- (or arg 1))))
 155
 156 ;; XEmacs change (optional buffer parameter)
 157 (defun buffer-end (arg &optional buffer)
 158   "Return `point-max' of BUFFER if ARG is > 0; return `point-min' otherwise.
 159 BUFFER defaults to the current buffer if omitted."
 160   (if (> arg 0) (point-max buffer) (point-min buffer)))
 161
 162 \f
 163 ;; derived stuff from GNU Emacs
 164 (defvar beginning-of-defun-function nil
 165   "If non-nil, this function will be called by `beginning-of-defun-raw'.
 166 It will be called with one argument, which is a repetition count.
 167 It provides an alternative algorithm to find the beginning of the current
 168 defun instead of using the standard one implemented by `beginning-of-defun'.
 169 See also `defun-prompt-regexp' for minor tweaks.")
 170 (make-variable-buffer-local 'beginning-of-defun-function)
 171
 172 (defvar end-of-defun-function nil
 173   "If non-nil, this function will be called by `end-of-defun'.
 174 It will be called with no arguments.  \(Repetition is implemented in
 175 `end-of-defun' by calling this function that many times.)
 176 This function provides an alternative algorithm to find the end
 177 of the current defun instead of using the standard one implemented by
 178 `end-of-defun'.
 179 ")
 180 (make-variable-buffer-local 'end-of-defun-function)
 181
 182 (defun beginning-of-defun (&optional count)
 183   "Move backward to the beginning of the current defun COUNT times.
 184 COUNT defaults to 1.  COUNT < 0 means move forward to COUNTth following
 185 beginning of defun.
 186 Returns t unless search stops due to beginning or end of buffer.
 187
 188 In the default implementation provided by `beginning-of-defun-raw',
 189 a defun starts at a char with open-parenthesis syntax at the beginning
 190 of a line.  If `defun-prompt-regexp' is non-nil, then a string which
 191 matches that regexp may precede the open-parenthesis.  Alternatively,
 192 if `beginning-of-defun-function' is non-nil, that function is called,
 193 and none of the default processing is done.
 194
 195 If the beginning of defun function returns t, point moves to the
 196 beginning of the line containing the beginning of defun."
 197   ;; XEmacs change (for zmacs regions)
 198   (interactive "_p")
 199   (and (beginning-of-defun-raw count)
 200        (progn (beginning-of-line) t)))
 201
 202 (defun beginning-of-defun-raw (&optional count)
 203   "Move point to the character that starts a defun.
 204 This is identical to beginning-of-defun, except that point does not move
 205 to the beginning of the line when `defun-prompt-regexp' is non-nil."
 206   (interactive "p")
 207   (unless count (setq count 1))
 208   (if beginning-of-defun-function
 209       (funcall beginning-of-defun-function count)
 210     (and (< count 0) (not (eobp)) (forward-char 1))
 211     (and
 212      (re-search-backward (if defun-prompt-regexp
 213                              (concat "^\\s(\\|"
 214                                      "\\(" defun-prompt-regexp "\\)\\s(")
 215                            "^\\s(")
 216                          nil 'move count)
 217      (progn (goto-char (1- (match-end 0)))) t)))
 218
 219 (defun end-of-defun (&optional count)
 220   "Move forward to next end of defun COUNT times.
 221 COUNT defaults to 1.  Negative COUNT means move back to COUNT-th preceding
 222 end of defun.
 223
 224 In the default implementation, the end of a defun is the end of the
 225 s-expression started at the character identified by `beginning-of-defun'.
 226
 227 If `end-of-defun-function' is non-nil, none of the default processing is
 228 done.  For COUNT < 1, `end-of-defun-function' is called that many times.
 229 If COUNT < 1, nothing is done.  \(This is a bug.)"
 230   ;; XEmacs change (for zmacs regions)
 231   (interactive "_p")
 232   (if (or (null count) (= count 0)) (setq count 1))
 233   (if end-of-defun-function
 234       (if (> count 0)
 235           (dotimes (i count)
 236             (funcall end-of-defun-function)))
 237   (let ((first t))
 238     (while (and (> count 0) (< (point) (point-max)))
 239       (let ((pos (point))) ; XEmacs -- remove unused npos.
 240         (while (progn
 241                 (if (and first
 242                          (progn
 243                           (end-of-line 1)
 244                           (beginning-of-defun-raw 1)))
 245                     nil
 246                   (or (bobp) (backward-char 1))
 247                   (beginning-of-defun-raw -1))
 248                 (setq first nil)
 249                 (forward-list 1)
 250                 (skip-chars-forward " \t")
 251                 (if (looking-at "\\s<\\|\n")
 252                     (forward-line 1))
 253                 (<= (point) pos))))
 254       (setq count (1- count)))
 255     (while (< count 0)
 256       (let ((pos (point)))
 257         (beginning-of-defun-raw 1)
 258         (forward-sexp 1)
 259         (forward-line 1)
 260         (if (>= (point) pos)
 261             (if (beginning-of-defun-raw 2)
 262                 (progn
 263                   (forward-list 1)
 264                   (skip-chars-forward " \t")
 265                   (if (looking-at "\\s<\\|\n")
 266                       (forward-line 1)))
 267               (goto-char (point-min)))))
 268       (setq count (1+ count))))))
 269
 270 (defun mark-defun ()
 271   "Put mark at end of this defun, point at beginning.
 272 The defun marked is the one that contains point or follows point."
 273   (interactive)
 274   (push-mark (point))
 275   (end-of-defun)
 276   (push-mark (point) nil t)
 277   (beginning-of-defun)
 278   (re-search-backward "^\n" (- (point) 1) t))
 279
 280 (defun narrow-to-defun (&optional arg)
 281   "Make text outside current defun invisible.
 282 The defun visible is the one that contains point or follows point."
 283   (interactive)
 284   (save-excursion
 285     (widen)
 286     (end-of-defun)
 287     (let ((end (point)))
 288       (beginning-of-defun)
 289       (narrow-to-region (point) end))))
 290
 291 (defun insert-parentheses (arg)
 292   "Enclose following ARG sexps in parentheses.  Leave point after open-paren.
 293 A negative ARG encloses the preceding ARG sexps instead.
 294 No argument is equivalent to zero: just insert `()' and leave point between.
 295 If `parens-require-spaces' is non-nil, this command also inserts a space
 296 before and after, depending on the surrounding characters."
 297   (interactive "P")
 298   (if arg (setq arg (prefix-numeric-value arg))
 299     (setq arg 0))
 300   (cond ((> arg 0) (skip-chars-forward " \t"))
 301         ((< arg 0) (forward-sexp arg) (setq arg (- arg))))
 302   (and parens-require-spaces
 303        (not (bobp))
 304        (memq (char-syntax (char-before (point))) '(?w ?_ ?\) ))
 305        (insert " "))
 306   (insert ?\()
 307   (save-excursion
 308     (or (eq arg 0) (forward-sexp arg))
 309     (insert ?\))
 310     (and parens-require-spaces
 311          (not (eobp))
 312          (memq (char-syntax (char-after (point))) '(?w ?_ ?\( ))
 313          (insert " "))))
 314
 315 (defun move-past-close-and-reindent ()
 316   "Move past next `)', delete indentation before it, then indent after it."
 317   (interactive)
 318   (up-list 1)
 319   (backward-char 1)
 320   (while (save-excursion                ; this is my contribution
 321            (let ((before-paren (point)))
 322              (back-to-indentation)
 323              (= (point) before-paren)))
 324     (delete-indentation))
 325   (forward-char 1)
 326   (newline-and-indent))
 327 \f
 328 (defun lisp-complete-symbol ()
 329   "Perform completion on Lisp symbol preceding point.
 330 Compare that symbol against the known Lisp symbols.
 331
 332 The context determines which symbols are considered.
 333 If the symbol starts just after an open-parenthesis, only symbols
 334 with function definitions are considered.  Otherwise, all symbols with
 335 function definitions, values or properties are considered."
 336   (interactive)
 337   (let* ((end (point))
 338          (buffer-syntax (syntax-table))
 339          (beg (unwind-protect
 340                   (save-excursion
 341                     ;; XEmacs change
 342                     (if emacs-lisp-mode-syntax-table
 343                         (set-syntax-table emacs-lisp-mode-syntax-table))
 344                     (backward-sexp 1)
 345                     (while (eq (char-syntax (char-after (point))) ?\')
 346                       (forward-char 1))
 347                     (point))
 348                 (set-syntax-table buffer-syntax)))
 349          (pattern (buffer-substring beg end))
 350          (predicate
 351           (if (eq (char-after (1- beg)) ?\()
 352               'fboundp
 353             ;; XEmacs change
 354             #'(lambda (sym)
 355                 (or (boundp sym) (fboundp sym)
 356                     (symbol-plist sym)))))
 357          (completion (try-completion pattern obarray predicate)))
 358     (cond ((eq completion t))
 359           ((null completion)
 360            (message "Can't find completion for \"%s\"" pattern)
 361            (ding))
 362           ((not (string= pattern completion))
 363            (delete-region beg end)
 364            (insert completion))
 365           (t
 366            (message "Making completion list...")
 367            (let ((list (all-completions pattern obarray predicate))
 368                  ;FSFmacs crock unnecessary in XEmacs
 369                  ;see minibuf.el
 370                  ;(completion-fixup-function
 371                  ; (function (lambda () (if (save-excursion
 372                  ;              (goto-char (max (point-min)
 373                  ;                              (- (point) 4)))
 374                  ;              (looking-at " <f>"))
 375                  ;            (forward-char -4))))
 376                  )
 377              (or (eq predicate 'fboundp)
 378                  (let (new)
 379                    (while list
 380                      (setq new (cons (if (fboundp (intern (car list)))
 381                                          (list (car list) " <f>")
 382                                        (car list))
 383                                      new))
 384                      (setq list (cdr list)))
 385                    (setq list (nreverse new))))
 386              (with-output-to-temp-buffer "*Completions*"
 387                (display-completion-list list)))
 388            (message "Making completion list...%s" "done")))))
 389
 390 ;;; lisp.el ends here