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