Commit | Line | Data |
---|---|---|
6594deb0 ER |
1 | ;;; mim-mode.el --- Mim (MDL in MDL) mode. |
2 | ||
9750e079 ER |
3 | ;; Copyright (C) 1985 Free Software Foundation, Inc. |
4 | ||
e5167999 ER |
5 | ;; Author: K. Shane Hartman |
6 | ;; Maintainer: FSF | |
fd7fa35a | 7 | ;; Keywords: languages |
e5167999 | 8 | |
405b4c7a JB |
9 | ;; This file is part of GNU Emacs. |
10 | ||
11 | ;; GNU Emacs is free software; you can redistribute it and/or modify | |
12 | ;; it under the terms of the GNU General Public License as published by | |
e5167999 | 13 | ;; the Free Software Foundation; either version 2, or (at your option) |
405b4c7a JB |
14 | ;; any later version. |
15 | ||
16 | ;; GNU Emacs is distributed in the hope that it will be useful, | |
17 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
18 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
19 | ;; GNU General Public License for more details. | |
20 | ||
21 | ;; You should have received a copy of the GNU General Public License | |
22 | ;; along with GNU Emacs; see the file COPYING. If not, write to | |
23 | ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. | |
24 | ||
e5167999 | 25 | ;;; Code: |
405b4c7a | 26 | |
405b4c7a JB |
27 | (autoload 'fast-syntax-check-mim "mim-syntax" |
28 | "Checks Mim syntax quickly. | |
29 | Answers correct or incorrect, cannot point out the error context." | |
30 | t) | |
31 | ||
32 | (autoload 'slow-syntax-check-mim "mim-syntax" | |
33 | "Check Mim syntax slowly. | |
34 | Points out the context of the error, if the syntax is incorrect." | |
35 | t) | |
36 | ||
37 | (defvar mim-mode-hysterical-bindings t | |
38 | "*Non-nil means bind list manipulation commands to Meta keys as well as | |
39 | Control-Meta keys for historical reasons. Otherwise, only the latter keys | |
40 | are bound.") | |
41 | ||
42 | (defvar mim-mode-map nil) | |
43 | ||
44 | (defvar mim-mode-syntax-table nil) | |
45 | ||
46 | (if mim-mode-syntax-table | |
47 | () | |
48 | (let ((i -1)) | |
49 | (setq mim-mode-syntax-table (make-syntax-table)) | |
50 | (while (< i ?\ ) | |
51 | (modify-syntax-entry (setq i (1+ i)) " " mim-mode-syntax-table)) | |
52 | (while (< i 127) | |
53 | (modify-syntax-entry (setq i (1+ i)) "_ " mim-mode-syntax-table)) | |
54 | (setq i (1- ?a)) | |
55 | (while (< i ?z) | |
56 | (modify-syntax-entry (setq i (1+ i)) "w " mim-mode-syntax-table)) | |
57 | (setq i (1- ?A)) | |
58 | (while (< i ?Z) | |
59 | (modify-syntax-entry (setq i (1+ i)) "w " mim-mode-syntax-table)) | |
60 | (setq i (1- ?0)) | |
61 | (while (< i ?9) | |
62 | (modify-syntax-entry (setq i (1+ i)) "w " mim-mode-syntax-table)) | |
63 | (modify-syntax-entry ?: " " mim-mode-syntax-table) ; make : symbol delimiter | |
64 | (modify-syntax-entry ?, "' " mim-mode-syntax-table) | |
65 | (modify-syntax-entry ?. "' " mim-mode-syntax-table) | |
66 | (modify-syntax-entry ?' "' " mim-mode-syntax-table) | |
67 | (modify-syntax-entry ?` "' " mim-mode-syntax-table) | |
68 | (modify-syntax-entry ?~ "' " mim-mode-syntax-table) | |
69 | (modify-syntax-entry ?\; "' " mim-mode-syntax-table) ; comments are prefixed objects | |
70 | (modify-syntax-entry ?# "' " mim-mode-syntax-table) | |
71 | (modify-syntax-entry ?% "' " mim-mode-syntax-table) | |
72 | (modify-syntax-entry ?! "' " mim-mode-syntax-table) | |
73 | (modify-syntax-entry ?\" "\" " mim-mode-syntax-table) | |
74 | (modify-syntax-entry ?\\ "\\ " mim-mode-syntax-table) | |
75 | (modify-syntax-entry ?\( "\() " mim-mode-syntax-table) | |
76 | (modify-syntax-entry ?\< "\(> " mim-mode-syntax-table) | |
77 | (modify-syntax-entry ?\{ "\(} " mim-mode-syntax-table) | |
78 | (modify-syntax-entry ?\[ "\(] " mim-mode-syntax-table) | |
79 | (modify-syntax-entry ?\) "\)( " mim-mode-syntax-table) | |
80 | (modify-syntax-entry ?\> "\)< " mim-mode-syntax-table) | |
81 | (modify-syntax-entry ?\} "\){ " mim-mode-syntax-table) | |
82 | (modify-syntax-entry ?\] "\)[ " mim-mode-syntax-table))) | |
83 | ||
84 | (defconst mim-whitespace "\000- ") | |
85 | ||
86 | (defvar mim-mode-hook nil | |
87 | "*User function run after mim mode initialization. Usage: | |
88 | \(setq mim-mode-hook '(lambda () ... your init forms ...)).") | |
89 | ||
90 | (define-abbrev-table 'mim-mode-abbrev-table nil) | |
91 | ||
92 | (defconst indent-mim-function 'indent-mim-function | |
93 | "Controls (via properties) indenting of special forms. | |
94 | \(put 'FOO 'indent-mim-function n\), integer n, means lines inside | |
95 | <FOO ...> will be indented n spaces from start of form. | |
96 | \(put 'FOO 'indent-mim-function 'DEFINE\) is like above but means use | |
97 | value of mim-body-indent as offset from start of form. | |
98 | \(put 'FOO 'indent-mim-function <cons>\) where <cons> is a list or pointted list | |
99 | of integers, means indent each form in <FOO ...> by the amount specified | |
100 | in <cons>. When <cons> is exhausted, indent remaining forms by | |
101 | `mim-body-indent' unless <cons> is a pointed list, in which case the last | |
102 | cdr is used. Confused? Here is an example: | |
103 | \(put 'FROBIT 'indent-mim-function '\(4 2 . 1\)\) | |
104 | <FROBIT | |
105 | <CHOMP-IT> | |
106 | <CHOMP-SOME-MORE> | |
107 | <DIGEST> | |
108 | <BELCH> | |
109 | ...> | |
110 | Finally, the property can be a function name (read the code).") | |
111 | ||
112 | (defvar indent-mim-comment t | |
113 | "*Non-nil means indent string comments.") | |
114 | ||
115 | (defvar mim-body-indent 2 | |
116 | "*Amount to indent in special forms which have DEFINE property on | |
117 | `indent-mim-function'.") | |
118 | ||
119 | (defvar indent-mim-arglist t | |
120 | "*nil means indent arglists like ordinary lists. | |
121 | t means strings stack under start of arglist and variables stack to | |
122 | right of them. Otherwise, strings stack under last string (or start | |
123 | of arglist if none) and variables stack to right of them. | |
124 | Examples (for values 'stack, t, nil): | |
125 | ||
126 | \(FOO \"OPT\" BAR \(FOO \"OPT\" BAR \(FOO \"OPT\" BAR | |
127 | BAZ MUMBLE BAZ MUMBLE BAZ MUMBLE | |
128 | \"AUX\" \"AUX\" \"AUX\" | |
129 | BLETCH ... BLETCH ... BLETCH ...") | |
130 | ||
131 | (put 'DEFINE 'indent-mim-function 'DEFINE) | |
132 | (put 'DEFMAC 'indent-mim-function 'DEFINE) | |
133 | (put 'BIND 'indent-mim-function 'DEFINE) | |
134 | (put 'PROG 'indent-mim-function 'DEFINE) | |
135 | (put 'REPEAT 'indent-mim-function 'DEFINE) | |
136 | (put 'CASE 'indent-mim-function 'DEFINE) | |
137 | (put 'FUNCTION 'indent-mim-function 'DEFINE) | |
138 | (put 'MAPF 'indent-mim-function 'DEFINE) | |
139 | (put 'MAPR 'indent-mim-function 'DEFINE) | |
140 | (put 'UNWIND 'indent-mim-function (cons (* 2 mim-body-indent) mim-body-indent)) | |
141 | ||
142 | (defvar mim-down-parens-only t | |
143 | "*nil means treat ADECLs and ATOM trailers like structures when | |
144 | moving down a level of structure.") | |
145 | ||
146 | (defvar mim-stop-for-slop t | |
147 | "*Non-nil means {next previous}-mim-object consider any | |
148 | non-whitespace character in column 0 to be a toplevel object, otherwise | |
149 | only open paren syntax characters will be considered.") | |
150 | ||
31e1d920 | 151 | (defalias 'mdl-mode 'mim-mode) |
405b4c7a JB |
152 | |
153 | (defun mim-mode () | |
154 | "Major mode for editing Mim (MDL in MDL) code. | |
155 | Commands: | |
156 | If value of `mim-mode-hysterical-bindings' is non-nil, then following | |
157 | commands are assigned to escape keys as well (e.g. ESC f = ESC C-f). | |
158 | The default action is bind the escape keys. | |
159 | \\{mim-mode-map} | |
160 | Other Commands: | |
161 | Use \\[describe-function] to obtain documentation. | |
162 | replace-in-mim-object find-mim-definition fast-syntax-check-mim | |
163 | slow-syntax-check-mim backward-down-mim-object forward-up-mim-object | |
164 | Variables: | |
165 | Use \\[describe-variable] to obtain documentation. | |
166 | mim-mode-hook indent-mim-comment indent-mim-arglist indent-mim-function | |
167 | mim-body-indent mim-down-parens-only mim-stop-for-slop | |
168 | mim-mode-hysterical-bindings | |
169 | Entry to this mode calls the value of mim-mode-hook if non-nil." | |
170 | (interactive) | |
171 | (kill-all-local-variables) | |
172 | (if (not mim-mode-map) | |
173 | (progn | |
174 | (setq mim-mode-map (make-sparse-keymap)) | |
175 | (define-key mim-mode-map "\e\^o" 'open-mim-line) | |
176 | (define-key mim-mode-map "\e\^q" 'indent-mim-object) | |
177 | (define-key mim-mode-map "\e\^p" 'previous-mim-object) | |
178 | (define-key mim-mode-map "\e\^n" 'next-mim-object) | |
179 | (define-key mim-mode-map "\e\^a" 'beginning-of-DEFINE) | |
180 | (define-key mim-mode-map "\e\^e" 'end-of-DEFINE) | |
181 | (define-key mim-mode-map "\e\^t" 'transpose-mim-objects) | |
182 | (define-key mim-mode-map "\e\^u" 'backward-up-mim-object) | |
183 | (define-key mim-mode-map "\e\^d" 'forward-down-mim-object) | |
184 | (define-key mim-mode-map "\e\^h" 'mark-mim-object) | |
185 | (define-key mim-mode-map "\e\^k" 'forward-kill-mim-object) | |
186 | (define-key mim-mode-map "\e\^f" 'forward-mim-object) | |
187 | (define-key mim-mode-map "\e\^b" 'backward-mim-object) | |
188 | (define-key mim-mode-map "\e^" 'raise-mim-line) | |
189 | (define-key mim-mode-map "\e\\" 'fixup-whitespace) | |
190 | (define-key mim-mode-map "\177" 'backward-delete-char-untabify) | |
191 | (define-key mim-mode-map "\e\177" 'backward-kill-mim-object) | |
192 | (define-key mim-mode-map "\^j" 'newline-and-mim-indent) | |
193 | (define-key mim-mode-map "\e;" 'begin-mim-comment) | |
194 | (define-key mim-mode-map "\t" 'indent-mim-line) | |
195 | (define-key mim-mode-map "\e\t" 'indent-mim-object) | |
196 | (if (not mim-mode-hysterical-bindings) | |
197 | nil | |
198 | ;; i really hate this but too many people are accustomed to these. | |
199 | (define-key mim-mode-map "\e!" 'line-to-top-of-window) | |
200 | (define-key mim-mode-map "\eo" 'open-mim-line) | |
201 | (define-key mim-mode-map "\ep" 'previous-mim-object) | |
202 | (define-key mim-mode-map "\en" 'next-mim-object) | |
203 | (define-key mim-mode-map "\ea" 'beginning-of-DEFINE) | |
204 | (define-key mim-mode-map "\ee" 'end-of-DEFINE) | |
205 | (define-key mim-mode-map "\et" 'transpose-mim-objects) | |
206 | (define-key mim-mode-map "\eu" 'backward-up-mim-object) | |
207 | (define-key mim-mode-map "\ed" 'forward-down-mim-object) | |
208 | (define-key mim-mode-map "\ek" 'forward-kill-mim-object) | |
209 | (define-key mim-mode-map "\ef" 'forward-mim-object) | |
210 | (define-key mim-mode-map "\eb" 'backward-mim-object)))) | |
211 | (use-local-map mim-mode-map) | |
212 | (set-syntax-table mim-mode-syntax-table) | |
213 | (make-local-variable 'paragraph-start) | |
214 | (setq paragraph-start (concat "^$\\|" page-delimiter)) | |
215 | (make-local-variable 'paragraph-separate) | |
216 | (setq paragraph-separate paragraph-start) | |
217 | (make-local-variable 'paragraph-ignore-fill-prefix) | |
218 | (setq paragraph-ignore-fill-prefix t) | |
219 | ;; Most people use string comments. | |
220 | (make-local-variable 'comment-start) | |
221 | (setq comment-start ";\"") | |
222 | (make-local-variable 'comment-start-skip) | |
223 | (setq comment-start-skip ";\"") | |
224 | (make-local-variable 'comment-end) | |
225 | (setq comment-end "\"") | |
226 | (make-local-variable 'comment-column) | |
227 | (setq comment-column 40) | |
e41b2db1 ER |
228 | (make-local-variable 'comment-indent-function) |
229 | (setq comment-indent-function 'indent-mim-comment) | |
405b4c7a JB |
230 | ;; tell generic indenter how to indent. |
231 | (make-local-variable 'indent-line-function) | |
232 | (setq indent-line-function 'indent-mim-line) | |
233 | ;; look for that paren | |
234 | (make-local-variable 'blink-matching-paren-distance) | |
235 | (setq blink-matching-paren-distance nil) | |
236 | ;; so people who dont like tabs can turn them off locally in indenter. | |
237 | (make-local-variable 'indent-tabs-mode) | |
238 | (setq indent-tabs-mode t) | |
239 | (setq local-abbrev-table mim-mode-abbrev-table) | |
240 | (setq major-mode 'mim-mode) | |
241 | (setq mode-name "Mim") | |
242 | (run-hooks 'mim-mode-hook)) | |
243 | ||
244 | (defun line-to-top-of-window () | |
245 | "Move current line to top of window." | |
246 | (interactive) ; for lazy people | |
247 | (recenter 0)) | |
248 | ||
249 | (defun forward-mim-object (arg) | |
250 | "Move forward across Mim object. | |
251 | With ARG, move forward that many objects." | |
252 | (interactive "p") | |
253 | ;; this function is wierd because it emulates the behavior of the old | |
254 | ;; (gosling) mim-mode - if the arg is 1 and we are `inside' an ADECL, | |
255 | ;; more than one character into the ATOM part and not sitting on the | |
256 | ;; colon, then we move to the DECL part (just past colon) instead of | |
257 | ;; the end of the object (the entire ADECL). otherwise, ADECL's are | |
258 | ;; atomic objects. likewise for ATOM trailers. | |
259 | (if (= (abs arg) 1) | |
260 | (if (inside-atom-p) | |
261 | ;; Move to end of ATOM or to trailer (!) or to ADECL (:). | |
262 | (forward-sexp arg) | |
263 | ;; Either scan an sexp or move over one bracket. | |
264 | (forward-mim-objects arg t)) | |
265 | ;; in the multi-object case, don't perform any magic. | |
266 | ;; treats ATOM trailers and ADECLs atomically, stops at unmatched | |
267 | ;; brackets with error. | |
268 | (forward-mim-objects arg))) | |
269 | ||
270 | (defun inside-atom-p () | |
271 | ;; Returns t iff inside an atom (takes account of trailers) | |
272 | (let ((c1 (preceding-char)) | |
273 | (c2 (following-char))) | |
274 | (and (or (= (char-syntax c1) ?w) (= (char-syntax c1) ?_) (= c1 ?!)) | |
275 | (or (= (char-syntax c2) ?w) (= (char-syntax c2) ?_) (= c2 ?!))))) | |
276 | ||
277 | (defun forward-mim-objects (arg &optional skip-bracket-p) | |
278 | ;; Move over arg objects ignoring ADECLs and trailers. If | |
279 | ;; skip-bracket-p is non-nil, then move over one bracket on error. | |
280 | (let ((direction (sign arg))) | |
281 | (condition-case conditions | |
282 | (while (/= arg 0) | |
283 | (forward-sexp direction) | |
284 | (if (not (inside-adecl-or-trailer-p direction)) | |
285 | (setq arg (- arg direction)))) | |
286 | (error (if (not skip-bracket-p) | |
287 | (signal 'error (cdr conditions)) | |
288 | (skip-mim-whitespace direction) | |
289 | (goto-char (+ (point) direction))))) | |
290 | ;; If we moved too far move back to first interesting character. | |
291 | (if (= (point) (buffer-end direction)) (skip-mim-whitespace (- direction))))) | |
292 | ||
293 | (defun backward-mim-object (&optional arg) | |
294 | "Move backward across Mim object. | |
295 | With ARG, move backward that many objects." | |
296 | (interactive "p") | |
297 | (forward-mim-object (if arg (- arg) -1))) | |
298 | ||
299 | (defun mark-mim-object (&optional arg) | |
300 | "Mark following Mim object. | |
301 | With ARG, mark that many following (preceding, ARG < 0) objects." | |
302 | (interactive "p") | |
303 | (push-mark (save-excursion (forward-mim-object (or arg 1)) (point)))) | |
304 | ||
305 | (defun forward-kill-mim-object (&optional arg) | |
306 | "Kill following Mim object. | |
307 | With ARG, kill that many objects." | |
308 | (interactive "*p") | |
309 | (kill-region (point) (progn (forward-mim-object (or arg 1)) (point)))) | |
310 | ||
311 | (defun backward-kill-mim-object (&optional arg) | |
312 | "Kill preceding Mim object. | |
313 | With ARG, kill that many objects." | |
314 | (interactive "*p") | |
315 | (forward-kill-mim-object (- (or arg 1)))) | |
316 | ||
317 | (defun raise-mim-line (&optional arg) | |
318 | "Raise following line, fixing up whitespace at join. | |
319 | With ARG raise that many following lines. | |
320 | A negative ARG will raise current line and previous lines." | |
321 | (interactive "*p") | |
322 | (let* ((increment (sign (or arg (setq arg 1)))) | |
323 | (direction (if (> arg 0) 1 0))) | |
324 | (save-excursion | |
325 | (while (/= arg 0) | |
326 | ;; move over eol and kill it | |
327 | (forward-line direction) | |
328 | (delete-region (point) (1- (point))) | |
329 | (fixup-whitespace) | |
330 | (setq arg (- arg increment)))))) | |
331 | ||
332 | (defun forward-down-mim-object (&optional arg) | |
333 | "Move down a level of Mim structure forwards. | |
334 | With ARG, move down that many levels forwards (backwards, ARG < 0)." | |
335 | (interactive "p") | |
336 | ;; another wierdo - going down `inside' an ADECL or ATOM trailer | |
337 | ;; depends on the value of mim-down-parens-only. if nil, treat | |
338 | ;; ADECLs and trailers as structured objects. | |
339 | (let ((direction (sign (or arg (setq arg 1))))) | |
340 | (if (and (= (abs arg) 1) (not mim-down-parens-only)) | |
341 | (goto-char | |
342 | (save-excursion | |
343 | (skip-mim-whitespace direction) | |
344 | (if (> direction 0) (re-search-forward "\\s'*")) | |
345 | (or (and (let ((c (next-char direction))) | |
346 | (or (= (char-syntax c) ?_) | |
347 | (= (char-syntax c) ?w))) | |
348 | (progn (forward-sexp direction) | |
349 | (if (inside-adecl-or-trailer-p direction) | |
350 | (point)))) | |
351 | (scan-lists (point) direction -1) | |
352 | (buffer-end direction)))) | |
353 | (while (/= arg 0) | |
354 | (goto-char (or (scan-lists (point) direction -1) (buffer-end direction))) | |
355 | (setq arg (- arg direction)))))) | |
356 | ||
357 | (defun backward-down-mim-object (&optional arg) | |
358 | "Move down a level of Mim structure backwards. | |
359 | With ARG, move down that many levels backwards (forwards, ARG < 0)." | |
360 | (interactive "p") | |
361 | (forward-down-mim-object (if arg (- arg) -1))) | |
362 | ||
363 | (defun forward-up-mim-object (&optional arg) | |
364 | "Move up a level of Mim structure forwards | |
365 | With ARG, move up that many levels forwards (backwards, ARG < 0)." | |
366 | (interactive "p") | |
367 | (let ((direction (sign (or arg (setq arg 1))))) | |
368 | (while (/= arg 0) | |
369 | (goto-char (or (scan-lists (point) direction 1) (buffer-end arg))) | |
370 | (setq arg (- arg direction))) | |
371 | (if (< direction 0) (backward-prefix-chars)))) | |
372 | ||
373 | (defun backward-up-mim-object (&optional arg) | |
374 | "Move up a level of Mim structure backwards | |
375 | With ARG, move up that many levels backwards (forwards, ARG > 0)." | |
376 | (interactive "p") | |
377 | (forward-up-mim-object (if arg (- arg) -1))) | |
378 | ||
379 | (defun replace-in-mim-object (old new) | |
380 | "Replace string in following Mim object." | |
381 | (interactive "*sReplace in object: \nsReplace %s with: ") | |
382 | (save-restriction | |
383 | (narrow-to-region (point) (save-excursion (forward-mim-object 1) (point))) | |
384 | (replace-string old new))) | |
385 | ||
386 | (defun transpose-mim-objects (&optional arg) | |
387 | "Transpose Mim objects around point. | |
388 | With ARG, transpose preceding object that many times with following objects. | |
389 | A negative ARG will transpose backwards." | |
390 | (interactive "*p") | |
391 | (transpose-subr 'forward-mim-object (or arg 1))) | |
392 | ||
393 | (defun beginning-of-DEFINE (&optional arg move) | |
394 | "Move backward to beginning of surrounding or previous toplevel Mim form. | |
395 | With ARG, do it that many times. Stops at last toplevel form seen if buffer | |
396 | end is reached." | |
397 | (interactive "p") | |
398 | (let ((direction (sign (or arg (setq arg 1))))) | |
399 | (if (not move) (setq move t)) | |
400 | (if (< direction 0) (goto-char (1+ (point)))) | |
401 | (while (and (/= arg 0) (re-search-backward "^<" nil move direction)) | |
402 | (setq arg (- arg direction))) | |
403 | (if (< direction 0) | |
404 | (goto-char (1- (point)))))) | |
405 | ||
406 | (defun end-of-DEFINE (&optional arg) | |
407 | "Move forward to end of surrounding or next toplevel mim form. | |
408 | With ARG, do it that many times. Stops at end of last toplevel form seen | |
409 | if buffer end is reached." | |
410 | (interactive "p") | |
411 | (if (not arg) (setq arg 1)) | |
412 | (if (< arg 0) | |
413 | (beginning-of-DEFINE (- (1- arg))) | |
414 | (if (not (looking-at "^<")) (setq arg (1+ arg))) | |
415 | (beginning-of-DEFINE (- arg) 'move) | |
416 | (beginning-of-DEFINE 1)) | |
417 | (forward-mim-object 1) | |
418 | (forward-line 1)) | |
419 | ||
420 | (defun next-mim-object (&optional arg) | |
421 | "Move to beginning of next toplevel Mim object. | |
422 | With ARG, do it that many times. Stops at last object seen if buffer end | |
423 | is reached." | |
424 | (interactive "p") | |
425 | (let ((search-string (if mim-stop-for-slop "^\\S " "^\\s(")) | |
426 | (direction (sign (or arg (setq arg 1))))) | |
427 | (if (> direction 0) | |
428 | (goto-char (1+ (point)))) ; no error if end of buffer | |
429 | (while (and (/= arg 0) | |
430 | (re-search-forward search-string nil t direction)) | |
431 | (setq arg (- arg direction))) | |
432 | (if (> direction 0) | |
433 | (goto-char (1- (point)))) ; no error if beginning of buffer | |
434 | ;; scroll to top of window if moving forward and end not visible. | |
435 | (if (not (or (< direction 0) | |
436 | (save-excursion (forward-mim-object 1) | |
437 | (pos-visible-in-window-p (point))))) | |
438 | (recenter 0)))) | |
439 | ||
440 | (defun previous-mim-object (&optional arg) | |
441 | "Move to beginning of previous toplevel Mim object. | |
442 | With ARG do it that many times. Stops at last object seen if buffer end | |
443 | is reached." | |
444 | (interactive "p") | |
445 | (next-mim-object (- (or arg 1)))) | |
446 | ||
447 | (defun calculate-mim-indent (&optional parse-start) | |
448 | "Calculate indentation for Mim line. Returns column." | |
449 | (save-excursion ; some excursion, huh, toto? | |
450 | (beginning-of-line) | |
451 | (let ((indent-point (point)) retry state containing-sexp last-sexp | |
452 | desired-indent start peek where paren-depth) | |
453 | (if parse-start | |
454 | (goto-char parse-start) ; should be containing environment | |
455 | (catch 'from-the-top | |
456 | ;; find a place to start parsing. going backwards is fastest. | |
457 | ;; forward-sexp signals error on encountering unmatched open. | |
458 | (setq retry t) | |
459 | (while retry | |
460 | (condition-case nil (forward-sexp -1) (error (setq retry nil))) | |
461 | (if (looking-at ".?[ \t]*\"") | |
462 | ;; cant parse backward in presence of strings, go forward. | |
463 | (progn | |
464 | (goto-char indent-point) | |
465 | (re-search-backward "^\\s(" nil 'move 1) ; to top of object | |
466 | (throw 'from-the-top nil))) | |
467 | (setq retry (and retry (/= (current-column) 0)))) | |
468 | (skip-chars-backward mim-whitespace) | |
469 | (if (not (bobp)) (forward-char -1)) ; onto unclosed open | |
470 | (backward-prefix-chars))) | |
471 | ;; find outermost containing sexp if we started inside an sexp. | |
472 | (while (< (point) indent-point) | |
473 | (setq state (parse-partial-sexp (point) indent-point 0))) | |
474 | ;; find usual column to indent under (not in string or toplevel). | |
475 | ;; on termination, state will correspond to containing environment | |
476 | ;; (if retry is nil), where will be position of character to indent | |
477 | ;; under normally, and desired-indent will be the column to indent to | |
478 | ;; except if inside form, string, or at toplevel. point will be in | |
479 | ;; in column to indent to unless inside string. | |
480 | (setq retry t) | |
481 | (while (and retry (setq paren-depth (car state)) (> paren-depth 0)) | |
482 | ;; find innermost containing sexp. | |
483 | (setq retry nil) | |
484 | (setq last-sexp (car (nthcdr 2 state))) | |
485 | (setq containing-sexp (car (cdr state))) | |
486 | (goto-char (1+ containing-sexp)) ; to last unclosed open | |
487 | (if (and last-sexp (> last-sexp (point))) | |
488 | ;; is the last sexp a containing sexp? | |
489 | (progn (setq peek (parse-partial-sexp last-sexp indent-point 0)) | |
490 | (if (setq retry (car (cdr peek))) (setq state peek)))) | |
491 | (if retry | |
492 | nil | |
493 | (setq where (1+ containing-sexp)) ; innermost containing sexp | |
494 | (goto-char where) | |
495 | (cond | |
496 | ((not last-sexp) ; indent-point after bracket | |
497 | (setq desired-indent (current-column))) | |
498 | ((= (preceding-char) ?\<) ; it's a form | |
499 | (cond ((> (progn (forward-sexp 1) (point)) last-sexp) | |
500 | (goto-char where)) ; only one frob | |
501 | ((> (save-excursion (forward-line 1) (point)) last-sexp) | |
502 | (skip-chars-forward " \t") ; last-sexp is on same line | |
503 | (setq where (point))) ; as containing-sexp | |
504 | ((progn | |
505 | (goto-char last-sexp) | |
506 | (beginning-of-line) | |
507 | (parse-partial-sexp (point) last-sexp 0 t) | |
508 | (or (= (point) last-sexp) | |
509 | (save-excursion | |
510 | (= (car (parse-partial-sexp (point) last-sexp 0)) | |
511 | 0)))) | |
512 | (backward-prefix-chars) ; last-sexp 1st on line or 1st | |
513 | (setq where (point))) ; frob on that line level 0 | |
514 | (t (goto-char where)))) ; punt, should never occur | |
515 | ((and indent-mim-arglist ; maybe hack arglist | |
516 | (= (preceding-char) ?\() ; its a list | |
517 | (save-excursion ; look for magic atoms | |
518 | (setq peek 0) ; using peek as counter | |
519 | (forward-char -1) ; back over containing paren | |
520 | (while (and (< (setq peek (1+ peek)) 6) | |
521 | (condition-case nil | |
522 | (progn (forward-sexp -1) t) | |
523 | (error nil)))) | |
524 | (and (< peek 6) (looking-at "DEFINE\\|DEFMAC\\|FUNCTION")))) | |
525 | ;; frobs stack under strings they belong to or under first | |
526 | ;; frob to right of strings they belong to unless luser has | |
527 | ;; frob (non-string) on preceding line with different | |
528 | ;; indentation. strings stack under start of arglist unless | |
529 | ;; mim-indent-arglist is not t, in which case they stack | |
530 | ;; under the last string, if any, else the start of the arglist. | |
531 | (let ((eol 0) last-string) | |
532 | (while (< (point) last-sexp) ; find out where the strings are | |
533 | (skip-chars-forward mim-whitespace last-sexp) | |
534 | (if (> (setq start (point)) eol) | |
535 | (progn ; simultaneously keeping track | |
536 | (setq where (min where start)) | |
537 | (end-of-line) ; of indentation of first frob | |
538 | (setq eol (point)) ; on each line | |
539 | (goto-char start))) | |
540 | (if (= (following-char) ?\") | |
541 | (progn (setq last-string (point)) | |
542 | (forward-sexp 1) | |
543 | (if (= last-string last-sexp) | |
544 | (setq where last-sexp) | |
545 | (skip-chars-forward mim-whitespace last-sexp) | |
546 | (setq where (point)))) | |
547 | (forward-sexp 1))) | |
548 | (goto-char indent-point) ; if string is first on | |
549 | (skip-chars-forward " \t" (point-max)) ; line we are indenting, it | |
550 | (if (= (following-char) ?\") ; goes under arglist start | |
551 | (if (and last-string (not (equal indent-mim-arglist t))) | |
552 | (setq where last-string) ; or under last string. | |
553 | (setq where (1+ containing-sexp))))) | |
554 | (goto-char where) | |
555 | (setq desired-indent (current-column))) | |
556 | (t ; plain vanilla structure | |
557 | (cond ((> (save-excursion (forward-line 1) (point)) last-sexp) | |
558 | (skip-chars-forward " \t") ; last-sexp is on same line | |
559 | (setq where (point))) ; as containing-sexp | |
560 | ((progn | |
561 | (goto-char last-sexp) | |
562 | (beginning-of-line) | |
563 | (parse-partial-sexp (point) last-sexp 0 t) | |
564 | (or (= (point) last-sexp) | |
565 | (save-excursion | |
566 | (= (car (parse-partial-sexp (point) last-sexp 0)) | |
567 | 0)))) | |
568 | (backward-prefix-chars) ; last-sexp 1st on line or 1st | |
569 | (setq where (point))) ; frob on that line level 0 | |
570 | (t (goto-char where))) ; punt, should never occur | |
571 | (setq desired-indent (current-column)))))) | |
572 | ;; state is innermost containing environment unless toplevel or string. | |
573 | (if (car (nthcdr 3 state)) ; inside string | |
574 | (progn | |
575 | (if last-sexp ; string must be next | |
576 | (progn (goto-char last-sexp) | |
577 | (forward-sexp 1) | |
578 | (search-forward "\"") | |
579 | (forward-char -1)) | |
580 | (goto-char indent-point) ; toplevel string, look for it | |
581 | (re-search-backward "[^\\]\"") | |
582 | (forward-char 1)) | |
583 | (setq start (point)) ; opening double quote | |
584 | (skip-chars-backward " \t") | |
585 | (backward-prefix-chars) | |
586 | ;; see if the string is really a comment. | |
587 | (if (and (looking-at ";[ \t]*\"") indent-mim-comment) | |
588 | ;; it's a comment, line up under the start unless disabled. | |
589 | (goto-char (1+ start)) | |
590 | ;; it's a string, dont mung the indentation. | |
591 | (goto-char indent-point) | |
592 | (skip-chars-forward " \t")) | |
593 | (setq desired-indent (current-column)))) | |
594 | ;; point is sitting in usual column to indent to and if retry is nil | |
595 | ;; then state corresponds to containing environment. if desired | |
596 | ;; indentation not determined, we are inside a form, so call hook. | |
597 | (or desired-indent | |
598 | (and indent-mim-function | |
599 | (not retry) | |
600 | (setq desired-indent | |
601 | (funcall indent-mim-function state indent-point))) | |
602 | (setq desired-indent (current-column))) | |
603 | (goto-char indent-point) ; back to where we started | |
604 | desired-indent))) ; return column to indent to | |
605 | ||
606 | (defun indent-mim-function (state indent-point) | |
607 | "Compute indentation for Mim special forms. Returns column or nil." | |
608 | (let ((containing-sexp (car (cdr state))) (current-indent (point))) | |
609 | (save-excursion | |
610 | (goto-char (1+ containing-sexp)) | |
611 | (backward-prefix-chars) | |
612 | ;; make sure we are looking at a symbol. if so, see if it is a special | |
613 | ;; symbol. if so, add the special indentation to the indentation of | |
614 | ;; the start of the special symbol, unless the property is not | |
615 | ;; an integer and not nil (in this case, call the property, it must | |
616 | ;; be a function which returns the appropriate indentation or nil and | |
617 | ;; does not change the buffer). | |
618 | (if (looking-at "\\sw\\|\\s_") | |
619 | (let* ((start (current-column)) | |
620 | (function | |
621 | (intern-soft (buffer-substring (point) | |
622 | (progn (forward-sexp 1) | |
623 | (point))))) | |
624 | (method (get function 'indent-mim-function))) | |
625 | (if (or (if (equal method 'DEFINE) (setq method mim-body-indent)) | |
626 | (integerp method)) | |
627 | ;; only use method if its first line after containing-sexp. | |
628 | ;; we could have done this in calculate-mim-indent, but someday | |
629 | ;; someone might want to format frobs in a special form based | |
630 | ;; on position instead of indenting uniformly (like lisp if), | |
631 | ;; so preserve right for posterity. if not first line, | |
632 | ;; calculate-mim-indent already knows right indentation - | |
633 | ;; give luser chance to change indentation manually by changing | |
634 | ;; 1st line after containing-sexp. | |
635 | (if (> (progn (forward-line 1) (point)) (car (nthcdr 2 state))) | |
636 | (+ method start)) | |
637 | (goto-char current-indent) | |
638 | (if (consp method) | |
639 | ;; list or pointted list of explicit indentations | |
640 | (indent-mim-offset state indent-point) | |
641 | (if (and (symbolp method) (fboundp method)) | |
642 | ;; luser function - s/he better know what's going on. | |
643 | ;; should take state and indent-point as arguments - for | |
644 | ;; description of state, see parse-partial-sexp | |
645 | ;; documentation the function is guaranteed the following: | |
646 | ;; (1) state describes the closest surrounding form, | |
647 | ;; (2) indent-point is the beginning of the line being | |
648 | ;; indented, (3) point points to char in column that would | |
649 | ;; normally be used for indentation, (4) function is bound | |
650 | ;; to the special ATOM. See indent-mim-offset for example | |
651 | ;; of a special function. | |
652 | (funcall method state indent-point))))))))) | |
653 | ||
654 | (defun indent-mim-offset (state indent-point) | |
655 | ;; offset forms explicitly according to list of indentations. | |
656 | (let ((mim-body-indent mim-body-indent) | |
657 | (indentations (get function 'indent-mim-function)) | |
658 | (containing-sexp (car (cdr state))) | |
659 | (last-sexp (car (nthcdr 2 state))) | |
660 | indentation) | |
661 | (goto-char (1+ containing-sexp)) | |
662 | ;; determine wheich of the indentations to use. | |
663 | (while (and (< (point) indent-point) | |
664 | (condition-case nil | |
665 | (progn (forward-sexp 1) | |
666 | (parse-partial-sexp (point) indent-point 1 t)) | |
667 | (error nil))) | |
668 | (skip-chars-backward " \t") | |
669 | (backward-prefix-chars) | |
670 | (if (= (following-char) ?\;) | |
671 | nil ; ignore comments | |
672 | (setq indentation (car indentations)) | |
673 | (if (integerp (setq indentations (cdr indentations))) | |
674 | ;; if last cdr is integer, that is indentation to use for all | |
675 | ;; all the rest of the forms. | |
676 | (progn (setq mim-body-indent indentations) | |
677 | (setq indentations nil))))) | |
678 | (goto-char (1+ containing-sexp)) | |
679 | (+ (current-column) (or indentation mim-body-indent)))) | |
680 | ||
681 | (defun indent-mim-comment (&optional start) | |
682 | "Indent a one line (string) Mim comment following object, if any." | |
683 | (let* ((old-point (point)) (eol (progn (end-of-line) (point))) state last-sexp) | |
684 | ;; this function assumes that comment indenting is enabled. it is caller's | |
685 | ;; responsibility to check the indent-mim-comment flag before calling. | |
686 | (beginning-of-line) | |
687 | (catch 'no-comment | |
688 | (setq state (parse-partial-sexp (point) eol)) | |
689 | ;; determine if there is an existing regular comment. a `regular' | |
690 | ;; comment is defined as a commented string which is the last thing | |
691 | ;; on the line and does not extend beyond the end of the line. | |
692 | (if (or (not (setq last-sexp (car (nthcdr 2 state)))) | |
693 | (car (nthcdr 3 state))) | |
694 | ;; empty line or inside string (multiple line). | |
695 | (throw 'no-comment nil)) | |
696 | ;; could be a comment, but make sure its not the only object. | |
697 | (beginning-of-line) | |
698 | (parse-partial-sexp (point) eol 0 t) | |
699 | (if (= (point) last-sexp) | |
700 | ;; only one object on line | |
701 | (throw 'no-comment t)) | |
702 | (goto-char last-sexp) | |
703 | (skip-chars-backward " \t") | |
704 | (backward-prefix-chars) | |
705 | (if (not (looking-at ";[ \t]*\"")) | |
706 | ;; aint no comment | |
707 | (throw 'no-comment nil)) | |
708 | ;; there is an existing regular comment | |
709 | (delete-horizontal-space) | |
710 | ;; move it to comment-column if possible else to tab-stop | |
711 | (if (< (current-column) comment-column) | |
712 | (indent-to comment-column) | |
713 | (tab-to-tab-stop))) | |
714 | (goto-char old-point))) | |
715 | ||
716 | (defun indent-mim-line () | |
717 | "Indent line of Mim code." | |
718 | (interactive "*") | |
719 | (let* ((position (- (point-max) (point))) | |
720 | (bol (progn (beginning-of-line) (point))) | |
721 | (indent (calculate-mim-indent))) | |
722 | (skip-chars-forward " \t") | |
723 | (if (/= (current-column) indent) | |
724 | (progn (delete-region bol (point)) (indent-to indent))) | |
725 | (if (> (- (point-max) position) (point)) (goto-char (- (point-max) position))))) | |
726 | ||
727 | (defun newline-and-mim-indent () | |
728 | "Insert newline at point and indent." | |
729 | (interactive "*") | |
730 | ;; commented code would correct indentation of line in arglist which | |
731 | ;; starts with string, but it would indent every line twice. luser can | |
732 | ;; just say tab after typing string to get same effect. | |
733 | ;(if indent-mim-arglist (indent-mim-line)) | |
734 | (newline) | |
735 | (indent-mim-line)) | |
736 | ||
737 | (defun open-mim-line (&optional lines) | |
738 | "Insert newline before point and indent. | |
739 | With ARG insert that many newlines." | |
740 | (interactive "*p") | |
741 | (beginning-of-line) | |
742 | (let ((indent (calculate-mim-indent))) | |
743 | (while (> lines 0) | |
744 | (newline) | |
745 | (forward-line -1) | |
746 | (indent-to indent) | |
747 | (setq lines (1- lines))))) | |
748 | ||
749 | (defun indent-mim-object (&optional dont-indent-first-line) | |
750 | "Indent object following point and all lines contained inside it. | |
751 | With ARG, idents only contained lines (skips first line)." | |
752 | (interactive "*P") | |
753 | (let (end bol indent start) | |
754 | (save-excursion (parse-partial-sexp (point) (point-max) 0 t) | |
755 | (setq start (point)) | |
756 | (forward-sexp 1) | |
757 | (setq end (- (point-max) (point)))) | |
758 | (save-excursion | |
759 | (if (not dont-indent-first-line) (indent-mim-line)) | |
760 | (while (progn (forward-line 1) (> (- (point-max) (point)) end)) | |
761 | (setq indent (calculate-mim-indent start)) | |
762 | (setq bol (point)) | |
763 | (skip-chars-forward " \t") | |
764 | (if (/= indent (current-column)) | |
765 | (progn (delete-region bol (point)) (indent-to indent))) | |
766 | (if indent-mim-comment (indent-mim-comment)))))) | |
767 | ||
768 | (defun find-mim-definition (name) | |
769 | "Search for definition of function, macro, or gfcn. | |
770 | You need type only enough of the name to be unambiguous." | |
771 | (interactive "sName: ") | |
772 | (let (where) | |
773 | (save-excursion | |
774 | (goto-char (point-min)) | |
775 | (condition-case nil | |
776 | (progn | |
777 | (re-search-forward | |
778 | (concat "^<\\(DEFINE\\|\\DEFMAC\\|FCN\\|GFCN\\)\\([ \t]*\\)" | |
779 | name)) | |
780 | (setq where (point))) | |
781 | (error (error "Can't find %s" name)))) | |
782 | (if where | |
783 | (progn (push-mark) | |
784 | (goto-char where) | |
785 | (beginning-of-line) | |
786 | (recenter 0))))) | |
787 | ||
788 | (defun begin-mim-comment () | |
789 | "Move to existing comment or insert empty comment." | |
790 | (interactive "*") | |
791 | (let* ((eol (progn (end-of-line) (point))) | |
792 | (bol (progn (beginning-of-line) (point)))) | |
793 | ;; check for existing comment first. | |
794 | (if (re-search-forward ";[ \t]*\"" eol t) | |
795 | ;; found it. indent if desired and go there. | |
796 | (if indent-mim-comment | |
797 | (let ((where (- (point-max) (point)))) | |
798 | (indent-mim-comment) | |
799 | (goto-char (- (point-max) where)))) | |
800 | ;; nothing there, make a comment. | |
801 | (let (state last-sexp) | |
802 | ;; skip past all the sexps on the line | |
803 | (goto-char bol) | |
804 | (while (and (equal (car (setq state (parse-partial-sexp (point) eol 0))) | |
805 | 0) | |
806 | (car (nthcdr 2 state))) | |
807 | (setq last-sexp (car (nthcdr 2 state)))) | |
808 | (if (car (nthcdr 3 state)) | |
809 | nil ; inside a string, punt | |
810 | (delete-region (point) eol) ; flush trailing whitespace | |
811 | (if (and (not last-sexp) (equal (car state) 0)) | |
812 | (indent-to (calculate-mim-indent)) ; empty, indent like code | |
813 | (if (> (current-column) comment-column) ; indent to comment column | |
814 | (tab-to-tab-stop) ; unless past it, else to | |
815 | (indent-to comment-column))) ; tab-stop | |
816 | ;; if luser changes comment-{start end} to something besides semi | |
817 | ;; followed by zero or more whitespace characters followed by string | |
818 | ;; delimiters, the code above fails to find existing comments, but as | |
819 | ;; taa says, `let the losers lose'. | |
820 | (insert comment-start) | |
821 | (save-excursion (insert comment-end))))))) | |
822 | ||
823 | (defun skip-mim-whitespace (direction) | |
824 | (if (>= direction 0) | |
825 | (skip-chars-forward mim-whitespace (point-max)) | |
826 | (skip-chars-backward mim-whitespace (point-min)))) | |
827 | ||
828 | (defun inside-adecl-or-trailer-p (direction) | |
829 | (if (>= direction 0) | |
830 | (looking-at ":\\|!-") | |
831 | (or (= (preceding-char) ?:) | |
832 | (looking-at "!-")))) | |
833 | ||
834 | (defun sign (n) | |
835 | "Returns -1 if N < 0, else 1." | |
836 | (if (>= n 0) 1 -1)) | |
837 | ||
838 | (defun abs (n) | |
839 | "Returns the absolute value of N." | |
840 | (if (>= n 0) n (- n))) | |
841 | ||
842 | (defun next-char (direction) | |
843 | "Returns preceding-char if DIRECTION < 0, otherwise following-char." | |
844 | (if (>= direction 0) (following-char) (preceding-char))) | |
49116ac0 JB |
845 | |
846 | (provide 'mim-mode) | |
847 | ||
6594deb0 | 848 | ;;; mim-mode.el ends here |