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