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