mirror of
https://git.savannah.gnu.org/git/emacs.git
synced 2024-11-27 07:37:33 +00:00
849 lines
34 KiB
EmacsLisp
849 lines
34 KiB
EmacsLisp
;;; mim-mode.el --- Mim (MDL in MDL) mode.
|
|
|
|
;; Copyright (C) 1985 Free Software Foundation, Inc.
|
|
|
|
;; Author: K. Shane Hartman
|
|
;; Maintainer: FSF
|
|
;; Keywords: languages
|
|
|
|
;; This file is part of GNU Emacs.
|
|
|
|
;; GNU Emacs is free software; you can redistribute it and/or modify
|
|
;; it under the terms of the GNU General Public License as published by
|
|
;; the Free Software Foundation; either version 2, or (at your option)
|
|
;; any later version.
|
|
|
|
;; GNU Emacs is distributed in the hope that it will be useful,
|
|
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
;; GNU General Public License for more details.
|
|
|
|
;; You should have received a copy of the GNU General Public License
|
|
;; along with GNU Emacs; see the file COPYING. If not, write to
|
|
;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
|
|
|
|
;;; Code:
|
|
|
|
(autoload 'fast-syntax-check-mim "mim-syntax"
|
|
"Checks Mim syntax quickly.
|
|
Answers correct or incorrect, cannot point out the error context."
|
|
t)
|
|
|
|
(autoload 'slow-syntax-check-mim "mim-syntax"
|
|
"Check Mim syntax slowly.
|
|
Points out the context of the error, if the syntax is incorrect."
|
|
t)
|
|
|
|
(defvar mim-mode-hysterical-bindings t
|
|
"*Non-nil means bind list manipulation commands to Meta keys as well as
|
|
Control-Meta keys for historical reasons. Otherwise, only the latter keys
|
|
are bound.")
|
|
|
|
(defvar mim-mode-map nil)
|
|
|
|
(defvar mim-mode-syntax-table nil)
|
|
|
|
(if mim-mode-syntax-table
|
|
()
|
|
(let ((i -1))
|
|
(setq mim-mode-syntax-table (make-syntax-table))
|
|
(while (< i ?\ )
|
|
(modify-syntax-entry (setq i (1+ i)) " " mim-mode-syntax-table))
|
|
(while (< i 127)
|
|
(modify-syntax-entry (setq i (1+ i)) "_ " mim-mode-syntax-table))
|
|
(setq i (1- ?a))
|
|
(while (< i ?z)
|
|
(modify-syntax-entry (setq i (1+ i)) "w " mim-mode-syntax-table))
|
|
(setq i (1- ?A))
|
|
(while (< i ?Z)
|
|
(modify-syntax-entry (setq i (1+ i)) "w " mim-mode-syntax-table))
|
|
(setq i (1- ?0))
|
|
(while (< i ?9)
|
|
(modify-syntax-entry (setq i (1+ i)) "w " mim-mode-syntax-table))
|
|
(modify-syntax-entry ?: " " mim-mode-syntax-table) ; make : symbol delimiter
|
|
(modify-syntax-entry ?, "' " mim-mode-syntax-table)
|
|
(modify-syntax-entry ?. "' " mim-mode-syntax-table)
|
|
(modify-syntax-entry ?' "' " mim-mode-syntax-table)
|
|
(modify-syntax-entry ?` "' " mim-mode-syntax-table)
|
|
(modify-syntax-entry ?~ "' " mim-mode-syntax-table)
|
|
(modify-syntax-entry ?\; "' " mim-mode-syntax-table) ; comments are prefixed objects
|
|
(modify-syntax-entry ?# "' " mim-mode-syntax-table)
|
|
(modify-syntax-entry ?% "' " mim-mode-syntax-table)
|
|
(modify-syntax-entry ?! "' " mim-mode-syntax-table)
|
|
(modify-syntax-entry ?\" "\" " mim-mode-syntax-table)
|
|
(modify-syntax-entry ?\\ "\\ " mim-mode-syntax-table)
|
|
(modify-syntax-entry ?\( "\() " mim-mode-syntax-table)
|
|
(modify-syntax-entry ?\< "\(> " mim-mode-syntax-table)
|
|
(modify-syntax-entry ?\{ "\(} " mim-mode-syntax-table)
|
|
(modify-syntax-entry ?\[ "\(] " mim-mode-syntax-table)
|
|
(modify-syntax-entry ?\) "\)( " mim-mode-syntax-table)
|
|
(modify-syntax-entry ?\> "\)< " mim-mode-syntax-table)
|
|
(modify-syntax-entry ?\} "\){ " mim-mode-syntax-table)
|
|
(modify-syntax-entry ?\] "\)[ " mim-mode-syntax-table)))
|
|
|
|
(defconst mim-whitespace "\000- ")
|
|
|
|
(defvar mim-mode-hook nil
|
|
"*User function run after mim mode initialization. Usage:
|
|
\(setq mim-mode-hook '(lambda () ... your init forms ...)).")
|
|
|
|
(define-abbrev-table 'mim-mode-abbrev-table nil)
|
|
|
|
(defconst indent-mim-function 'indent-mim-function
|
|
"Controls (via properties) indenting of special forms.
|
|
\(put 'FOO 'indent-mim-function n\), integer n, means lines inside
|
|
<FOO ...> will be indented n spaces from start of form.
|
|
\(put 'FOO 'indent-mim-function 'DEFINE\) is like above but means use
|
|
value of mim-body-indent as offset from start of form.
|
|
\(put 'FOO 'indent-mim-function <cons>\) where <cons> is a list or pointed list
|
|
of integers, means indent each form in <FOO ...> by the amount specified
|
|
in <cons>. When <cons> is exhausted, indent remaining forms by
|
|
`mim-body-indent' unless <cons> is a pointed list, in which case the last
|
|
cdr is used. Confused? Here is an example:
|
|
\(put 'FROBIT 'indent-mim-function '\(4 2 . 1\)\)
|
|
<FROBIT
|
|
<CHOMP-IT>
|
|
<CHOMP-SOME-MORE>
|
|
<DIGEST>
|
|
<BELCH>
|
|
...>
|
|
Finally, the property can be a function name (read the code).")
|
|
|
|
(defvar indent-mim-comment t
|
|
"*Non-nil means indent string comments.")
|
|
|
|
(defvar mim-body-indent 2
|
|
"*Amount to indent in special forms which have DEFINE property on
|
|
`indent-mim-function'.")
|
|
|
|
(defvar indent-mim-arglist t
|
|
"*nil means indent arglists like ordinary lists.
|
|
t means strings stack under start of arglist and variables stack to
|
|
right of them. Otherwise, strings stack under last string (or start
|
|
of arglist if none) and variables stack to right of them.
|
|
Examples (for values 'stack, t, nil):
|
|
|
|
\(FOO \"OPT\" BAR \(FOO \"OPT\" BAR \(FOO \"OPT\" BAR
|
|
BAZ MUMBLE BAZ MUMBLE BAZ MUMBLE
|
|
\"AUX\" \"AUX\" \"AUX\"
|
|
BLETCH ... BLETCH ... BLETCH ...")
|
|
|
|
(put 'DEFINE 'indent-mim-function 'DEFINE)
|
|
(put 'DEFMAC 'indent-mim-function 'DEFINE)
|
|
(put 'BIND 'indent-mim-function 'DEFINE)
|
|
(put 'PROG 'indent-mim-function 'DEFINE)
|
|
(put 'REPEAT 'indent-mim-function 'DEFINE)
|
|
(put 'CASE 'indent-mim-function 'DEFINE)
|
|
(put 'FUNCTION 'indent-mim-function 'DEFINE)
|
|
(put 'MAPF 'indent-mim-function 'DEFINE)
|
|
(put 'MAPR 'indent-mim-function 'DEFINE)
|
|
(put 'UNWIND 'indent-mim-function (cons (* 2 mim-body-indent) mim-body-indent))
|
|
|
|
(defvar mim-down-parens-only t
|
|
"*nil means treat ADECLs and ATOM trailers like structures when
|
|
moving down a level of structure.")
|
|
|
|
(defvar mim-stop-for-slop t
|
|
"*Non-nil means {next previous}-mim-object consider any
|
|
non-whitespace character in column 0 to be a toplevel object, otherwise
|
|
only open paren syntax characters will be considered.")
|
|
|
|
(defalias 'mdl-mode 'mim-mode)
|
|
|
|
(defun mim-mode ()
|
|
"Major mode for editing Mim (MDL in MDL) code.
|
|
Commands:
|
|
If value of `mim-mode-hysterical-bindings' is non-nil, then following
|
|
commands are assigned to escape keys as well (e.g. ESC f = ESC C-f).
|
|
The default action is bind the escape keys.
|
|
\\{mim-mode-map}
|
|
Other Commands:
|
|
Use \\[describe-function] to obtain documentation.
|
|
replace-in-mim-object find-mim-definition fast-syntax-check-mim
|
|
slow-syntax-check-mim backward-down-mim-object forward-up-mim-object
|
|
Variables:
|
|
Use \\[describe-variable] to obtain documentation.
|
|
mim-mode-hook indent-mim-comment indent-mim-arglist indent-mim-function
|
|
mim-body-indent mim-down-parens-only mim-stop-for-slop
|
|
mim-mode-hysterical-bindings
|
|
Entry to this mode calls the value of mim-mode-hook if non-nil."
|
|
(interactive)
|
|
(kill-all-local-variables)
|
|
(if (not mim-mode-map)
|
|
(progn
|
|
(setq mim-mode-map (make-sparse-keymap))
|
|
(define-key mim-mode-map "\e\^o" 'open-mim-line)
|
|
(define-key mim-mode-map "\e\^q" 'indent-mim-object)
|
|
(define-key mim-mode-map "\e\^p" 'previous-mim-object)
|
|
(define-key mim-mode-map "\e\^n" 'next-mim-object)
|
|
(define-key mim-mode-map "\e\^a" 'beginning-of-DEFINE)
|
|
(define-key mim-mode-map "\e\^e" 'end-of-DEFINE)
|
|
(define-key mim-mode-map "\e\^t" 'transpose-mim-objects)
|
|
(define-key mim-mode-map "\e\^u" 'backward-up-mim-object)
|
|
(define-key mim-mode-map "\e\^d" 'forward-down-mim-object)
|
|
(define-key mim-mode-map "\e\^h" 'mark-mim-object)
|
|
(define-key mim-mode-map "\e\^k" 'forward-kill-mim-object)
|
|
(define-key mim-mode-map "\e\^f" 'forward-mim-object)
|
|
(define-key mim-mode-map "\e\^b" 'backward-mim-object)
|
|
(define-key mim-mode-map "\e^" 'raise-mim-line)
|
|
(define-key mim-mode-map "\e\\" 'fixup-whitespace)
|
|
(define-key mim-mode-map "\177" 'backward-delete-char-untabify)
|
|
(define-key mim-mode-map "\e\177" 'backward-kill-mim-object)
|
|
(define-key mim-mode-map "\^j" 'newline-and-mim-indent)
|
|
(define-key mim-mode-map "\e;" 'begin-mim-comment)
|
|
(define-key mim-mode-map "\t" 'indent-mim-line)
|
|
(define-key mim-mode-map "\e\t" 'indent-mim-object)
|
|
(if (not mim-mode-hysterical-bindings)
|
|
nil
|
|
;; i really hate this but too many people are accustomed to these.
|
|
(define-key mim-mode-map "\e!" 'line-to-top-of-window)
|
|
(define-key mim-mode-map "\eo" 'open-mim-line)
|
|
(define-key mim-mode-map "\ep" 'previous-mim-object)
|
|
(define-key mim-mode-map "\en" 'next-mim-object)
|
|
(define-key mim-mode-map "\ea" 'beginning-of-DEFINE)
|
|
(define-key mim-mode-map "\ee" 'end-of-DEFINE)
|
|
(define-key mim-mode-map "\et" 'transpose-mim-objects)
|
|
(define-key mim-mode-map "\eu" 'backward-up-mim-object)
|
|
(define-key mim-mode-map "\ed" 'forward-down-mim-object)
|
|
(define-key mim-mode-map "\ek" 'forward-kill-mim-object)
|
|
(define-key mim-mode-map "\ef" 'forward-mim-object)
|
|
(define-key mim-mode-map "\eb" 'backward-mim-object))))
|
|
(use-local-map mim-mode-map)
|
|
(set-syntax-table mim-mode-syntax-table)
|
|
(make-local-variable 'paragraph-start)
|
|
(setq paragraph-start (concat "$\\|" page-delimiter))
|
|
(make-local-variable 'paragraph-separate)
|
|
(setq paragraph-separate paragraph-start)
|
|
(make-local-variable 'paragraph-ignore-fill-prefix)
|
|
(setq paragraph-ignore-fill-prefix t)
|
|
;; Most people use string comments.
|
|
(make-local-variable 'comment-start)
|
|
(setq comment-start ";\"")
|
|
(make-local-variable 'comment-start-skip)
|
|
(setq comment-start-skip ";\"")
|
|
(make-local-variable 'comment-end)
|
|
(setq comment-end "\"")
|
|
(make-local-variable 'comment-column)
|
|
(setq comment-column 40)
|
|
(make-local-variable 'comment-indent-function)
|
|
(setq comment-indent-function 'indent-mim-comment)
|
|
;; tell generic indenter how to indent.
|
|
(make-local-variable 'indent-line-function)
|
|
(setq indent-line-function 'indent-mim-line)
|
|
;; look for that paren
|
|
(make-local-variable 'blink-matching-paren-distance)
|
|
(setq blink-matching-paren-distance nil)
|
|
;; so people who dont like tabs can turn them off locally in indenter.
|
|
(make-local-variable 'indent-tabs-mode)
|
|
(setq indent-tabs-mode t)
|
|
(setq local-abbrev-table mim-mode-abbrev-table)
|
|
(setq major-mode 'mim-mode)
|
|
(setq mode-name "Mim")
|
|
(run-hooks 'mim-mode-hook))
|
|
|
|
(defun line-to-top-of-window ()
|
|
"Move current line to top of window."
|
|
(interactive) ; for lazy people
|
|
(recenter 0))
|
|
|
|
(defun forward-mim-object (arg)
|
|
"Move forward across Mim object.
|
|
With ARG, move forward that many objects."
|
|
(interactive "p")
|
|
;; this function is weird because it emulates the behavior of the old
|
|
;; (gosling) mim-mode - if the arg is 1 and we are `inside' an ADECL,
|
|
;; more than one character into the ATOM part and not sitting on the
|
|
;; colon, then we move to the DECL part (just past colon) instead of
|
|
;; the end of the object (the entire ADECL). otherwise, ADECL's are
|
|
;; atomic objects. likewise for ATOM trailers.
|
|
(if (= (abs arg) 1)
|
|
(if (inside-atom-p)
|
|
;; Move to end of ATOM or to trailer (!) or to ADECL (:).
|
|
(forward-sexp arg)
|
|
;; Either scan an sexp or move over one bracket.
|
|
(forward-mim-objects arg t))
|
|
;; in the multi-object case, don't perform any magic.
|
|
;; treats ATOM trailers and ADECLs atomically, stops at unmatched
|
|
;; brackets with error.
|
|
(forward-mim-objects arg)))
|
|
|
|
(defun inside-atom-p ()
|
|
;; Returns t iff inside an atom (takes account of trailers)
|
|
(let ((c1 (preceding-char))
|
|
(c2 (following-char)))
|
|
(and (or (= (char-syntax c1) ?w) (= (char-syntax c1) ?_) (= c1 ?!))
|
|
(or (= (char-syntax c2) ?w) (= (char-syntax c2) ?_) (= c2 ?!)))))
|
|
|
|
(defun forward-mim-objects (arg &optional skip-bracket-p)
|
|
;; Move over arg objects ignoring ADECLs and trailers. If
|
|
;; skip-bracket-p is non-nil, then move over one bracket on error.
|
|
(let ((direction (sign arg)))
|
|
(condition-case conditions
|
|
(while (/= arg 0)
|
|
(forward-sexp direction)
|
|
(if (not (inside-adecl-or-trailer-p direction))
|
|
(setq arg (- arg direction))))
|
|
(error (if (not skip-bracket-p)
|
|
(signal 'error (cdr conditions))
|
|
(skip-mim-whitespace direction)
|
|
(goto-char (+ (point) direction)))))
|
|
;; If we moved too far move back to first interesting character.
|
|
(if (= (point) (buffer-end direction)) (skip-mim-whitespace (- direction)))))
|
|
|
|
(defun backward-mim-object (&optional arg)
|
|
"Move backward across Mim object.
|
|
With ARG, move backward that many objects."
|
|
(interactive "p")
|
|
(forward-mim-object (if arg (- arg) -1)))
|
|
|
|
(defun mark-mim-object (&optional arg)
|
|
"Mark following Mim object.
|
|
With ARG, mark that many following (preceding, ARG < 0) objects."
|
|
(interactive "p")
|
|
(push-mark (save-excursion (forward-mim-object (or arg 1)) (point))))
|
|
|
|
(defun forward-kill-mim-object (&optional arg)
|
|
"Kill following Mim object.
|
|
With ARG, kill that many objects."
|
|
(interactive "*p")
|
|
(kill-region (point) (progn (forward-mim-object (or arg 1)) (point))))
|
|
|
|
(defun backward-kill-mim-object (&optional arg)
|
|
"Kill preceding Mim object.
|
|
With ARG, kill that many objects."
|
|
(interactive "*p")
|
|
(forward-kill-mim-object (- (or arg 1))))
|
|
|
|
(defun raise-mim-line (&optional arg)
|
|
"Raise following line, fixing up whitespace at join.
|
|
With ARG raise that many following lines.
|
|
A negative ARG will raise current line and previous lines."
|
|
(interactive "*p")
|
|
(let* ((increment (sign (or arg (setq arg 1))))
|
|
(direction (if (> arg 0) 1 0)))
|
|
(save-excursion
|
|
(while (/= arg 0)
|
|
;; move over eol and kill it
|
|
(forward-line direction)
|
|
(delete-region (point) (1- (point)))
|
|
(fixup-whitespace)
|
|
(setq arg (- arg increment))))))
|
|
|
|
(defun forward-down-mim-object (&optional arg)
|
|
"Move down a level of Mim structure forwards.
|
|
With ARG, move down that many levels forwards (backwards, ARG < 0)."
|
|
(interactive "p")
|
|
;; another weirdo - going down `inside' an ADECL or ATOM trailer
|
|
;; depends on the value of mim-down-parens-only. if nil, treat
|
|
;; ADECLs and trailers as structured objects.
|
|
(let ((direction (sign (or arg (setq arg 1)))))
|
|
(if (and (= (abs arg) 1) (not mim-down-parens-only))
|
|
(goto-char
|
|
(save-excursion
|
|
(skip-mim-whitespace direction)
|
|
(if (> direction 0) (re-search-forward "\\s'*"))
|
|
(or (and (let ((c (next-char direction)))
|
|
(or (= (char-syntax c) ?_)
|
|
(= (char-syntax c) ?w)))
|
|
(progn (forward-sexp direction)
|
|
(if (inside-adecl-or-trailer-p direction)
|
|
(point))))
|
|
(scan-lists (point) direction -1)
|
|
(buffer-end direction))))
|
|
(while (/= arg 0)
|
|
(goto-char (or (scan-lists (point) direction -1) (buffer-end direction)))
|
|
(setq arg (- arg direction))))))
|
|
|
|
(defun backward-down-mim-object (&optional arg)
|
|
"Move down a level of Mim structure backwards.
|
|
With ARG, move down that many levels backwards (forwards, ARG < 0)."
|
|
(interactive "p")
|
|
(forward-down-mim-object (if arg (- arg) -1)))
|
|
|
|
(defun forward-up-mim-object (&optional arg)
|
|
"Move up a level of Mim structure forwards
|
|
With ARG, move up that many levels forwards (backwards, ARG < 0)."
|
|
(interactive "p")
|
|
(let ((direction (sign (or arg (setq arg 1)))))
|
|
(while (/= arg 0)
|
|
(goto-char (or (scan-lists (point) direction 1) (buffer-end arg)))
|
|
(setq arg (- arg direction)))
|
|
(if (< direction 0) (backward-prefix-chars))))
|
|
|
|
(defun backward-up-mim-object (&optional arg)
|
|
"Move up a level of Mim structure backwards
|
|
With ARG, move up that many levels backwards (forwards, ARG > 0)."
|
|
(interactive "p")
|
|
(forward-up-mim-object (if arg (- arg) -1)))
|
|
|
|
(defun replace-in-mim-object (old new)
|
|
"Replace string in following Mim object."
|
|
(interactive "*sReplace in object: \nsReplace %s with: ")
|
|
(save-restriction
|
|
(narrow-to-region (point) (save-excursion (forward-mim-object 1) (point)))
|
|
(replace-string old new)))
|
|
|
|
(defun transpose-mim-objects (&optional arg)
|
|
"Transpose Mim objects around point.
|
|
With ARG, transpose preceding object that many times with following objects.
|
|
A negative ARG will transpose backwards."
|
|
(interactive "*p")
|
|
(transpose-subr 'forward-mim-object (or arg 1)))
|
|
|
|
(defun beginning-of-DEFINE (&optional arg move)
|
|
"Move backward to beginning of surrounding or previous toplevel Mim form.
|
|
With ARG, do it that many times. Stops at last toplevel form seen if buffer
|
|
end is reached."
|
|
(interactive "p")
|
|
(let ((direction (sign (or arg (setq arg 1)))))
|
|
(if (not move) (setq move t))
|
|
(if (< direction 0) (goto-char (1+ (point))))
|
|
(while (and (/= arg 0) (re-search-backward "^<" nil move direction))
|
|
(setq arg (- arg direction)))
|
|
(if (< direction 0)
|
|
(goto-char (1- (point))))))
|
|
|
|
(defun end-of-DEFINE (&optional arg)
|
|
"Move forward to end of surrounding or next toplevel mim form.
|
|
With ARG, do it that many times. Stops at end of last toplevel form seen
|
|
if buffer end is reached."
|
|
(interactive "p")
|
|
(if (not arg) (setq arg 1))
|
|
(if (< arg 0)
|
|
(beginning-of-DEFINE (- (1- arg)))
|
|
(if (not (looking-at "^<")) (setq arg (1+ arg)))
|
|
(beginning-of-DEFINE (- arg) 'move)
|
|
(beginning-of-DEFINE 1))
|
|
(forward-mim-object 1)
|
|
(forward-line 1))
|
|
|
|
(defun next-mim-object (&optional arg)
|
|
"Move to beginning of next toplevel Mim object.
|
|
With ARG, do it that many times. Stops at last object seen if buffer end
|
|
is reached."
|
|
(interactive "p")
|
|
(let ((search-string (if mim-stop-for-slop "^\\S " "^\\s("))
|
|
(direction (sign (or arg (setq arg 1)))))
|
|
(if (> direction 0)
|
|
(goto-char (1+ (point)))) ; no error if end of buffer
|
|
(while (and (/= arg 0)
|
|
(re-search-forward search-string nil t direction))
|
|
(setq arg (- arg direction)))
|
|
(if (> direction 0)
|
|
(goto-char (1- (point)))) ; no error if beginning of buffer
|
|
;; scroll to top of window if moving forward and end not visible.
|
|
(if (not (or (< direction 0)
|
|
(save-excursion (forward-mim-object 1)
|
|
(pos-visible-in-window-p (point)))))
|
|
(recenter 0))))
|
|
|
|
(defun previous-mim-object (&optional arg)
|
|
"Move to beginning of previous toplevel Mim object.
|
|
With ARG do it that many times. Stops at last object seen if buffer end
|
|
is reached."
|
|
(interactive "p")
|
|
(next-mim-object (- (or arg 1))))
|
|
|
|
(defun calculate-mim-indent (&optional parse-start)
|
|
"Calculate indentation for Mim line. Returns column."
|
|
(save-excursion ; some excursion, huh, toto?
|
|
(beginning-of-line)
|
|
(let ((indent-point (point)) retry state containing-sexp last-sexp
|
|
desired-indent start peek where paren-depth)
|
|
(if parse-start
|
|
(goto-char parse-start) ; should be containing environment
|
|
(catch 'from-the-top
|
|
;; find a place to start parsing. going backwards is fastest.
|
|
;; forward-sexp signals error on encountering unmatched open.
|
|
(setq retry t)
|
|
(while retry
|
|
(condition-case nil (forward-sexp -1) (error (setq retry nil)))
|
|
(if (looking-at ".?[ \t]*\"")
|
|
;; cant parse backward in presence of strings, go forward.
|
|
(progn
|
|
(goto-char indent-point)
|
|
(re-search-backward "^\\s(" nil 'move 1) ; to top of object
|
|
(throw 'from-the-top nil)))
|
|
(setq retry (and retry (/= (current-column) 0))))
|
|
(skip-chars-backward mim-whitespace)
|
|
(if (not (bobp)) (forward-char -1)) ; onto unclosed open
|
|
(backward-prefix-chars)))
|
|
;; find outermost containing sexp if we started inside an sexp.
|
|
(while (< (point) indent-point)
|
|
(setq state (parse-partial-sexp (point) indent-point 0)))
|
|
;; find usual column to indent under (not in string or toplevel).
|
|
;; on termination, state will correspond to containing environment
|
|
;; (if retry is nil), where will be position of character to indent
|
|
;; under normally, and desired-indent will be the column to indent to
|
|
;; except if inside form, string, or at toplevel. point will be in
|
|
;; in column to indent to unless inside string.
|
|
(setq retry t)
|
|
(while (and retry (setq paren-depth (car state)) (> paren-depth 0))
|
|
;; find innermost containing sexp.
|
|
(setq retry nil)
|
|
(setq last-sexp (car (nthcdr 2 state)))
|
|
(setq containing-sexp (car (cdr state)))
|
|
(goto-char (1+ containing-sexp)) ; to last unclosed open
|
|
(if (and last-sexp (> last-sexp (point)))
|
|
;; is the last sexp a containing sexp?
|
|
(progn (setq peek (parse-partial-sexp last-sexp indent-point 0))
|
|
(if (setq retry (car (cdr peek))) (setq state peek))))
|
|
(if retry
|
|
nil
|
|
(setq where (1+ containing-sexp)) ; innermost containing sexp
|
|
(goto-char where)
|
|
(cond
|
|
((not last-sexp) ; indent-point after bracket
|
|
(setq desired-indent (current-column)))
|
|
((= (preceding-char) ?\<) ; it's a form
|
|
(cond ((> (progn (forward-sexp 1) (point)) last-sexp)
|
|
(goto-char where)) ; only one frob
|
|
((> (save-excursion (forward-line 1) (point)) last-sexp)
|
|
(skip-chars-forward " \t") ; last-sexp is on same line
|
|
(setq where (point))) ; as containing-sexp
|
|
((progn
|
|
(goto-char last-sexp)
|
|
(beginning-of-line)
|
|
(parse-partial-sexp (point) last-sexp 0 t)
|
|
(or (= (point) last-sexp)
|
|
(save-excursion
|
|
(= (car (parse-partial-sexp (point) last-sexp 0))
|
|
0))))
|
|
(backward-prefix-chars) ; last-sexp 1st on line or 1st
|
|
(setq where (point))) ; frob on that line level 0
|
|
(t (goto-char where)))) ; punt, should never occur
|
|
((and indent-mim-arglist ; maybe hack arglist
|
|
(= (preceding-char) ?\() ; its a list
|
|
(save-excursion ; look for magic atoms
|
|
(setq peek 0) ; using peek as counter
|
|
(forward-char -1) ; back over containing paren
|
|
(while (and (< (setq peek (1+ peek)) 6)
|
|
(condition-case nil
|
|
(progn (forward-sexp -1) t)
|
|
(error nil))))
|
|
(and (< peek 6) (looking-at "DEFINE\\|DEFMAC\\|FUNCTION"))))
|
|
;; frobs stack under strings they belong to or under first
|
|
;; frob to right of strings they belong to unless luser has
|
|
;; frob (non-string) on preceding line with different
|
|
;; indentation. strings stack under start of arglist unless
|
|
;; mim-indent-arglist is not t, in which case they stack
|
|
;; under the last string, if any, else the start of the arglist.
|
|
(let ((eol 0) last-string)
|
|
(while (< (point) last-sexp) ; find out where the strings are
|
|
(skip-chars-forward mim-whitespace last-sexp)
|
|
(if (> (setq start (point)) eol)
|
|
(progn ; simultaneously keeping track
|
|
(setq where (min where start))
|
|
(end-of-line) ; of indentation of first frob
|
|
(setq eol (point)) ; on each line
|
|
(goto-char start)))
|
|
(if (= (following-char) ?\")
|
|
(progn (setq last-string (point))
|
|
(forward-sexp 1)
|
|
(if (= last-string last-sexp)
|
|
(setq where last-sexp)
|
|
(skip-chars-forward mim-whitespace last-sexp)
|
|
(setq where (point))))
|
|
(forward-sexp 1)))
|
|
(goto-char indent-point) ; if string is first on
|
|
(skip-chars-forward " \t" (point-max)) ; line we are indenting, it
|
|
(if (= (following-char) ?\") ; goes under arglist start
|
|
(if (and last-string (not (equal indent-mim-arglist t)))
|
|
(setq where last-string) ; or under last string.
|
|
(setq where (1+ containing-sexp)))))
|
|
(goto-char where)
|
|
(setq desired-indent (current-column)))
|
|
(t ; plain vanilla structure
|
|
(cond ((> (save-excursion (forward-line 1) (point)) last-sexp)
|
|
(skip-chars-forward " \t") ; last-sexp is on same line
|
|
(setq where (point))) ; as containing-sexp
|
|
((progn
|
|
(goto-char last-sexp)
|
|
(beginning-of-line)
|
|
(parse-partial-sexp (point) last-sexp 0 t)
|
|
(or (= (point) last-sexp)
|
|
(save-excursion
|
|
(= (car (parse-partial-sexp (point) last-sexp 0))
|
|
0))))
|
|
(backward-prefix-chars) ; last-sexp 1st on line or 1st
|
|
(setq where (point))) ; frob on that line level 0
|
|
(t (goto-char where))) ; punt, should never occur
|
|
(setq desired-indent (current-column))))))
|
|
;; state is innermost containing environment unless toplevel or string.
|
|
(if (car (nthcdr 3 state)) ; inside string
|
|
(progn
|
|
(if last-sexp ; string must be next
|
|
(progn (goto-char last-sexp)
|
|
(forward-sexp 1)
|
|
(search-forward "\"")
|
|
(forward-char -1))
|
|
(goto-char indent-point) ; toplevel string, look for it
|
|
(re-search-backward "[^\\]\"")
|
|
(forward-char 1))
|
|
(setq start (point)) ; opening double quote
|
|
(skip-chars-backward " \t")
|
|
(backward-prefix-chars)
|
|
;; see if the string is really a comment.
|
|
(if (and (looking-at ";[ \t]*\"") indent-mim-comment)
|
|
;; it's a comment, line up under the start unless disabled.
|
|
(goto-char (1+ start))
|
|
;; it's a string, dont mung the indentation.
|
|
(goto-char indent-point)
|
|
(skip-chars-forward " \t"))
|
|
(setq desired-indent (current-column))))
|
|
;; point is sitting in usual column to indent to and if retry is nil
|
|
;; then state corresponds to containing environment. if desired
|
|
;; indentation not determined, we are inside a form, so call hook.
|
|
(or desired-indent
|
|
(and indent-mim-function
|
|
(not retry)
|
|
(setq desired-indent
|
|
(funcall indent-mim-function state indent-point)))
|
|
(setq desired-indent (current-column)))
|
|
(goto-char indent-point) ; back to where we started
|
|
desired-indent))) ; return column to indent to
|
|
|
|
(defun indent-mim-function (state indent-point)
|
|
"Compute indentation for Mim special forms. Returns column or nil."
|
|
(let ((containing-sexp (car (cdr state))) (current-indent (point)))
|
|
(save-excursion
|
|
(goto-char (1+ containing-sexp))
|
|
(backward-prefix-chars)
|
|
;; make sure we are looking at a symbol. if so, see if it is a special
|
|
;; symbol. if so, add the special indentation to the indentation of
|
|
;; the start of the special symbol, unless the property is not
|
|
;; an integer and not nil (in this case, call the property, it must
|
|
;; be a function which returns the appropriate indentation or nil and
|
|
;; does not change the buffer).
|
|
(if (looking-at "\\sw\\|\\s_")
|
|
(let* ((start (current-column))
|
|
(function
|
|
(intern-soft (buffer-substring (point)
|
|
(progn (forward-sexp 1)
|
|
(point)))))
|
|
(method (get function 'indent-mim-function)))
|
|
(if (or (if (equal method 'DEFINE) (setq method mim-body-indent))
|
|
(integerp method))
|
|
;; only use method if its first line after containing-sexp.
|
|
;; we could have done this in calculate-mim-indent, but someday
|
|
;; someone might want to format frobs in a special form based
|
|
;; on position instead of indenting uniformly (like lisp if),
|
|
;; so preserve right for posterity. if not first line,
|
|
;; calculate-mim-indent already knows right indentation -
|
|
;; give luser chance to change indentation manually by changing
|
|
;; 1st line after containing-sexp.
|
|
(if (> (progn (forward-line 1) (point)) (car (nthcdr 2 state)))
|
|
(+ method start))
|
|
(goto-char current-indent)
|
|
(if (consp method)
|
|
;; list or pointed list of explicit indentations
|
|
(indent-mim-offset state indent-point)
|
|
(if (and (symbolp method) (fboundp method))
|
|
;; luser function - s/he better know what's going on.
|
|
;; should take state and indent-point as arguments - for
|
|
;; description of state, see parse-partial-sexp
|
|
;; documentation the function is guaranteed the following:
|
|
;; (1) state describes the closest surrounding form,
|
|
;; (2) indent-point is the beginning of the line being
|
|
;; indented, (3) point points to char in column that would
|
|
;; normally be used for indentation, (4) function is bound
|
|
;; to the special ATOM. See indent-mim-offset for example
|
|
;; of a special function.
|
|
(funcall method state indent-point)))))))))
|
|
|
|
(defun indent-mim-offset (state indent-point)
|
|
;; offset forms explicitly according to list of indentations.
|
|
(let ((mim-body-indent mim-body-indent)
|
|
(indentations (get function 'indent-mim-function))
|
|
(containing-sexp (car (cdr state)))
|
|
(last-sexp (car (nthcdr 2 state)))
|
|
indentation)
|
|
(goto-char (1+ containing-sexp))
|
|
;; determine which of the indentations to use.
|
|
(while (and (< (point) indent-point)
|
|
(condition-case nil
|
|
(progn (forward-sexp 1)
|
|
(parse-partial-sexp (point) indent-point 1 t))
|
|
(error nil)))
|
|
(skip-chars-backward " \t")
|
|
(backward-prefix-chars)
|
|
(if (= (following-char) ?\;)
|
|
nil ; ignore comments
|
|
(setq indentation (car indentations))
|
|
(if (integerp (setq indentations (cdr indentations)))
|
|
;; if last cdr is integer, that is indentation to use for all
|
|
;; all the rest of the forms.
|
|
(progn (setq mim-body-indent indentations)
|
|
(setq indentations nil)))))
|
|
(goto-char (1+ containing-sexp))
|
|
(+ (current-column) (or indentation mim-body-indent))))
|
|
|
|
(defun indent-mim-comment (&optional start)
|
|
"Indent a one line (string) Mim comment following object, if any."
|
|
(let* ((old-point (point)) (eol (progn (end-of-line) (point))) state last-sexp)
|
|
;; this function assumes that comment indenting is enabled. it is caller's
|
|
;; responsibility to check the indent-mim-comment flag before calling.
|
|
(beginning-of-line)
|
|
(catch 'no-comment
|
|
(setq state (parse-partial-sexp (point) eol))
|
|
;; determine if there is an existing regular comment. a `regular'
|
|
;; comment is defined as a commented string which is the last thing
|
|
;; on the line and does not extend beyond the end of the line.
|
|
(if (or (not (setq last-sexp (car (nthcdr 2 state))))
|
|
(car (nthcdr 3 state)))
|
|
;; empty line or inside string (multiple line).
|
|
(throw 'no-comment nil))
|
|
;; could be a comment, but make sure its not the only object.
|
|
(beginning-of-line)
|
|
(parse-partial-sexp (point) eol 0 t)
|
|
(if (= (point) last-sexp)
|
|
;; only one object on line
|
|
(throw 'no-comment t))
|
|
(goto-char last-sexp)
|
|
(skip-chars-backward " \t")
|
|
(backward-prefix-chars)
|
|
(if (not (looking-at ";[ \t]*\""))
|
|
;; aint no comment
|
|
(throw 'no-comment nil))
|
|
;; there is an existing regular comment
|
|
(delete-horizontal-space)
|
|
;; move it to comment-column if possible else to tab-stop
|
|
(if (< (current-column) comment-column)
|
|
(indent-to comment-column)
|
|
(tab-to-tab-stop)))
|
|
(goto-char old-point)))
|
|
|
|
(defun indent-mim-line ()
|
|
"Indent line of Mim code."
|
|
(interactive "*")
|
|
(let* ((position (- (point-max) (point)))
|
|
(bol (progn (beginning-of-line) (point)))
|
|
(indent (calculate-mim-indent)))
|
|
(skip-chars-forward " \t")
|
|
(if (/= (current-column) indent)
|
|
(progn (delete-region bol (point)) (indent-to indent)))
|
|
(if (> (- (point-max) position) (point)) (goto-char (- (point-max) position)))))
|
|
|
|
(defun newline-and-mim-indent ()
|
|
"Insert newline at point and indent."
|
|
(interactive "*")
|
|
;; commented code would correct indentation of line in arglist which
|
|
;; starts with string, but it would indent every line twice. luser can
|
|
;; just say tab after typing string to get same effect.
|
|
;(if indent-mim-arglist (indent-mim-line))
|
|
(newline)
|
|
(indent-mim-line))
|
|
|
|
(defun open-mim-line (&optional lines)
|
|
"Insert newline before point and indent.
|
|
With ARG insert that many newlines."
|
|
(interactive "*p")
|
|
(beginning-of-line)
|
|
(let ((indent (calculate-mim-indent)))
|
|
(while (> lines 0)
|
|
(newline)
|
|
(forward-line -1)
|
|
(indent-to indent)
|
|
(setq lines (1- lines)))))
|
|
|
|
(defun indent-mim-object (&optional dont-indent-first-line)
|
|
"Indent object following point and all lines contained inside it.
|
|
With ARG, idents only contained lines (skips first line)."
|
|
(interactive "*P")
|
|
(let (end bol indent start)
|
|
(save-excursion (parse-partial-sexp (point) (point-max) 0 t)
|
|
(setq start (point))
|
|
(forward-sexp 1)
|
|
(setq end (- (point-max) (point))))
|
|
(save-excursion
|
|
(if (not dont-indent-first-line) (indent-mim-line))
|
|
(while (progn (forward-line 1) (> (- (point-max) (point)) end))
|
|
(setq indent (calculate-mim-indent start))
|
|
(setq bol (point))
|
|
(skip-chars-forward " \t")
|
|
(if (/= indent (current-column))
|
|
(progn (delete-region bol (point)) (indent-to indent)))
|
|
(if indent-mim-comment (indent-mim-comment))))))
|
|
|
|
(defun find-mim-definition (name)
|
|
"Search for definition of function, macro, or gfcn.
|
|
You need type only enough of the name to be unambiguous."
|
|
(interactive "sName: ")
|
|
(let (where)
|
|
(save-excursion
|
|
(goto-char (point-min))
|
|
(condition-case nil
|
|
(progn
|
|
(re-search-forward
|
|
(concat "^<\\(DEFINE\\|\\DEFMAC\\|FCN\\|GFCN\\)\\([ \t]*\\)"
|
|
name))
|
|
(setq where (point)))
|
|
(error (error "Can't find %s" name))))
|
|
(if where
|
|
(progn (push-mark)
|
|
(goto-char where)
|
|
(beginning-of-line)
|
|
(recenter 0)))))
|
|
|
|
(defun begin-mim-comment ()
|
|
"Move to existing comment or insert empty comment."
|
|
(interactive "*")
|
|
(let* ((eol (progn (end-of-line) (point)))
|
|
(bol (progn (beginning-of-line) (point))))
|
|
;; check for existing comment first.
|
|
(if (re-search-forward ";[ \t]*\"" eol t)
|
|
;; found it. indent if desired and go there.
|
|
(if indent-mim-comment
|
|
(let ((where (- (point-max) (point))))
|
|
(indent-mim-comment)
|
|
(goto-char (- (point-max) where))))
|
|
;; nothing there, make a comment.
|
|
(let (state last-sexp)
|
|
;; skip past all the sexps on the line
|
|
(goto-char bol)
|
|
(while (and (equal (car (setq state (parse-partial-sexp (point) eol 0)))
|
|
0)
|
|
(car (nthcdr 2 state)))
|
|
(setq last-sexp (car (nthcdr 2 state))))
|
|
(if (car (nthcdr 3 state))
|
|
nil ; inside a string, punt
|
|
(delete-region (point) eol) ; flush trailing whitespace
|
|
(if (and (not last-sexp) (equal (car state) 0))
|
|
(indent-to (calculate-mim-indent)) ; empty, indent like code
|
|
(if (> (current-column) comment-column) ; indent to comment column
|
|
(tab-to-tab-stop) ; unless past it, else to
|
|
(indent-to comment-column))) ; tab-stop
|
|
;; if luser changes comment-{start end} to something besides semi
|
|
;; followed by zero or more whitespace characters followed by string
|
|
;; delimiters, the code above fails to find existing comments, but as
|
|
;; taa says, `let the losers lose'.
|
|
(insert comment-start)
|
|
(save-excursion (insert comment-end)))))))
|
|
|
|
(defun skip-mim-whitespace (direction)
|
|
(if (>= direction 0)
|
|
(skip-chars-forward mim-whitespace (point-max))
|
|
(skip-chars-backward mim-whitespace (point-min))))
|
|
|
|
(defun inside-adecl-or-trailer-p (direction)
|
|
(if (>= direction 0)
|
|
(looking-at ":\\|!-")
|
|
(or (= (preceding-char) ?:)
|
|
(looking-at "!-"))))
|
|
|
|
(defun sign (n)
|
|
"Returns -1 if N < 0, else 1."
|
|
(if (>= n 0) 1 -1))
|
|
|
|
(defun abs (n)
|
|
"Returns the absolute value of N."
|
|
(if (>= n 0) n (- n)))
|
|
|
|
(defun next-char (direction)
|
|
"Returns preceding-char if DIRECTION < 0, otherwise following-char."
|
|
(if (>= direction 0) (following-char) (preceding-char)))
|
|
|
|
(provide 'mim-mode)
|
|
|
|
;;; mim-mode.el ends here
|