lisp/mim-mode.el

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