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