Mercurial > emacs
comparison lisp/=mim-mode.el @ 229:2d06c35d1c03
Initial revision
author | Jim Blandy <jimb@redhat.com> |
---|---|
date | Fri, 05 Apr 1991 21:43:40 +0000 |
parents | |
children | 4cd7543be581 |
comparison
equal
deleted
inserted
replaced
228:997a3c98d127 | 229:2d06c35d1c03 |
---|---|
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))) |