home *** CD-ROM | disk | FTP | other *** search
/ Education Sampler 1992 [NeXTSTEP] / Education_1992_Sampler.iso / NeXT / GnuSource / emacs-15.0.3 / lisp / mim-mode.el < prev    next >
Lisp/Scheme  |  1990-07-19  |  36KB  |  861 lines
  1. ;; Mim (MDL in MDL) mode.
  2. ;; Copyright (C) 1985 Free Software Foundation, Inc.
  3. ;; Principal author K. Shane Hartman
  4.  
  5. ;; This file is part of GNU Emacs.
  6.  
  7. ;; GNU Emacs is 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 mim-mode-syntax-table
  45.     ()
  46.   (let ((i -1))
  47.     (setq mim-mode-syntax-table (make-syntax-table))
  48.     (while (< i ?\ )
  49.       (modify-syntax-entry (setq i (1+ i)) "    " mim-mode-syntax-table))
  50.     (while (< i 127)
  51.       (modify-syntax-entry (setq i (1+ i)) "_   " mim-mode-syntax-table))
  52.     (setq i (1- ?a))
  53.     (while (< i ?z)
  54.       (modify-syntax-entry (setq i (1+ i)) "w   " 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- ?0))
  59.     (while (< i ?9)
  60.       (modify-syntax-entry (setq i (1+ i)) "w   " mim-mode-syntax-table))
  61.     (modify-syntax-entry ?:  "     " mim-mode-syntax-table) ; make : symbol delimiter
  62.     (modify-syntax-entry ?,  "'    " mim-mode-syntax-table)
  63.     (modify-syntax-entry ?.  "'    " mim-mode-syntax-table)
  64.     (modify-syntax-entry ?'  "'    " mim-mode-syntax-table)
  65.     (modify-syntax-entry ?`  "'    " mim-mode-syntax-table)
  66.     (modify-syntax-entry ?~  "'    " mim-mode-syntax-table)
  67.     (modify-syntax-entry ?\; "'    " mim-mode-syntax-table) ; comments are prefixed objects
  68.     (modify-syntax-entry ?#  "'    " mim-mode-syntax-table)
  69.     (modify-syntax-entry ?%  "'    " mim-mode-syntax-table)
  70.     (modify-syntax-entry ?!  "'    " mim-mode-syntax-table)
  71.     (modify-syntax-entry ?\" "\"   " mim-mode-syntax-table)
  72.     (modify-syntax-entry ?\\ "\\   " mim-mode-syntax-table)
  73.     (modify-syntax-entry ?\( "\()  " mim-mode-syntax-table)
  74.     (modify-syntax-entry ?\< "\(>  " mim-mode-syntax-table)
  75.     (modify-syntax-entry ?\{ "\(}  " mim-mode-syntax-table)
  76.     (modify-syntax-entry ?\[ "\(]  " mim-mode-syntax-table)
  77.     (modify-syntax-entry ?\) "\)(  " mim-mode-syntax-table)
  78.     (modify-syntax-entry ?\> "\)<  " mim-mode-syntax-table)
  79.     (modify-syntax-entry ?\} "\){  " mim-mode-syntax-table)
  80.     (modify-syntax-entry ?\] "\)[  " mim-mode-syntax-table)))
  81.  
  82. (defconst mim-whitespace "\000- ")
  83.  
  84. (defvar mim-mode-hook nil
  85.   "*User function run after mim mode initialization.  Usage:
  86. \(setq mim-mode-hook '(lambda () ... your init forms ...)).")
  87.  
  88. (define-abbrev-table 'mim-mode-abbrev-table nil)
  89.  
  90. (defconst indent-mim-hook 'indent-mim-hook
  91.   "Controls (via properties) indenting of special forms.
  92. \(put 'FOO 'indent-mim-hook n\), integer n, means lines inside
  93. <FOO ...> will be indented n spaces from start of form.
  94. \(put 'FOO 'indent-mim-hook 'DEFINE\) is like above but means use
  95. value of mim-body-indent as offset from start of form.
  96. \(put 'FOO 'indent-mim-hook <cons>\) where <cons> is a list or pointted list
  97. of integers, means indent each form in <FOO ...> by the amount specified
  98. in <cons>.  When <cons> is exhausted, indent remaining forms by
  99. mim-body-indent unless <cons> is a pointted list, in which case the last
  100. cdr is used.  Confused? Here is an example:
  101. \(put 'FROBIT 'indent-mim-hook '\(4 2 . 1\)\)
  102. <FROBIT
  103.      <CHOMP-IT>
  104.    <CHOMP-SOME-MORE>
  105.   <DIGEST>
  106.   <BELCH>
  107.   ...>
  108. Finally, the property can be a function name (read the code).")
  109.  
  110. (defvar indent-mim-comment t
  111.   "*Non-nil means indent string comments.")
  112.  
  113. (defvar mim-body-indent 2
  114.   "*Amount to indent in special forms which have DEFINE property on
  115. indent-mim-hook.")
  116.  
  117. (defvar indent-mim-arglist t
  118.   "*nil means indent arglists like ordinary lists.
  119. t means strings stack under start of arglist and variables stack to
  120. right of them.  Otherwise, strings stack under last string (or start
  121. of arglist if none) and variables stack to right of them.
  122. Examples (for values 'stack, t, nil):
  123.  
  124. \(FOO \"OPT\" BAR             \(FOO \"OPT\" BAR            \(FOO \"OPT\" BAR
  125.            BAZ MUMBLE                 BAZ MUMBLE      BAZ MUMBLE
  126.      \"AUX\"                  \"AUX\"                     \"AUX\"
  127.      BLETCH ...             BLETCH ...                BLETCH ...")
  128.  
  129. (put 'DEFINE 'indent-mim-hook 'DEFINE)
  130. (put 'DEFMAC 'indent-mim-hook 'DEFINE)
  131. (put 'BIND 'indent-mim-hook 'DEFINE)
  132. (put 'PROG 'indent-mim-hook 'DEFINE)
  133. (put 'REPEAT 'indent-mim-hook 'DEFINE)
  134. (put 'CASE 'indent-mim-hook 'DEFINE)
  135. (put 'FUNCTION 'indent-mim-hook 'DEFINE)
  136. (put 'MAPF 'indent-mim-hook 'DEFINE)
  137. (put 'MAPR 'indent-mim-hook 'DEFINE)
  138. (put 'UNWIND 'indent-mim-hook (cons (* 2 mim-body-indent) mim-body-indent))
  139.  
  140. (defvar mim-down-parens-only t
  141.   "*nil means treat ADECLs and ATOM trailers like structures when
  142. moving down a level of structure.")
  143.  
  144. (defvar mim-stop-for-slop t
  145.   "*Non-nil means {next previous}-mim-object consider any
  146. non-whitespace character in column 0 to be a toplevel object, otherwise
  147. only open paren syntax characters will be considered.")
  148.  
  149. (fset 'mdl-mode 'mim-mode)
  150.  
  151. (defun mim-mode ()
  152.   "Major mode for editing Mim (MDL in MDL) code.
  153. Commands:
  154.     If value of mim-mode-hysterical-bindings is non-nil, then following
  155. commands are assigned to escape keys as well (e.g. M-f = M-C-f).
  156. The default action is bind the escape keys.
  157.   Tab        Indents the current line as MDL code.
  158.   Delete     Converts tabs to spaces as it moves back.
  159.   M-C-f      Move forward over next mim object.
  160.   M-C-b      Move backward over previous mim object.
  161.   M-C-p      Move to beginning of previous toplevel mim object.
  162.   M-C-n      Move to the beginning of the next toplevel mim object.
  163.   M-C-a      Move to the top of surrounding toplevel mim form.
  164.   M-C-e      Move to the end of surrounding toplevel mim form.
  165.   M-C-u      Move up a level of mim structure backwards.
  166.   M-C-d      Move down a level of mim structure forwards.
  167.   M-C-t      Transpose mim objects on either side of point.
  168.   M-C-k      Kill next mim object.
  169.   M-C-h      Place mark at end of next mim object.
  170.   M-C-o      Insert a newline before current line and indent.
  171.   M-Delete   Kill previous mim object.
  172.   M-^        Join current line to previous line.
  173.   M-\\        Delete whitespace around point.
  174.   M-;        Move to existing comment or insert empty comment if none.
  175.   M-Tab      Indent following mim object and all contained lines.
  176. Other Commands:
  177.   Use \\[describe-function] to obtain documentation.
  178.   replace-in-mim-object  find-mim-definition  fast-syntax-check-mim
  179.   slow-syntax-check-mim  backward-down-mim-object  forward-up-mim-object
  180. Variables:
  181.   Use \\[describe-variable] to obtain documentation.
  182.   mim-mode-hook  indent-mim-comment  indent-mim-arglist  indent-mim-hook
  183.   mim-body-indent  mim-down-parens-only  mim-stop-for-slop
  184.   mim-mode-hysterical-bindings
  185. Entry to this mode calls the value of mim-mode-hook if non-nil."
  186.   (interactive)
  187.   (kill-all-local-variables)
  188.   (if (not mim-mode-map)
  189.       (progn
  190.     (setq mim-mode-map (make-sparse-keymap))
  191.     (define-key mim-mode-map "\e\^o" 'open-mim-line)
  192.     (define-key mim-mode-map "\e\^q" 'indent-mim-object)
  193.     (define-key mim-mode-map "\e\^p" 'previous-mim-object)
  194.     (define-key mim-mode-map "\e\^n" 'next-mim-object)
  195.     (define-key mim-mode-map "\e\^a" 'beginning-of-DEFINE)
  196.     (define-key mim-mode-map "\e\^e" 'end-of-DEFINE)
  197.     (define-key mim-mode-map "\e\^t" 'transpose-mim-objects)
  198.     (define-key mim-mode-map "\e\^u" 'backward-up-mim-object)    
  199.     (define-key mim-mode-map "\e\^d" 'forward-down-mim-object)     
  200.     (define-key mim-mode-map "\e\^h" 'mark-mim-object)
  201.     (define-key mim-mode-map "\e\^k" 'forward-kill-mim-object)    
  202.     (define-key mim-mode-map "\e\^f" 'forward-mim-object)       
  203.     (define-key mim-mode-map "\e\^b" 'backward-mim-object)
  204.     (define-key mim-mode-map "\e^" 'raise-mim-line)
  205.     (define-key mim-mode-map "\e\\" 'fixup-whitespace)
  206.     (define-key mim-mode-map "\177" 'backward-delete-char-untabify)
  207.     (define-key mim-mode-map "\e\177" 'backward-kill-mim-object)
  208.     (define-key mim-mode-map "\^j" 'newline-and-mim-indent)
  209.     (define-key mim-mode-map "\e;" 'begin-mim-comment)
  210.     (define-key mim-mode-map "\t" 'indent-mim-line)
  211.     (define-key mim-mode-map "\e\t" 'indent-mim-object)
  212.     (if (not mim-mode-hysterical-bindings)
  213.         nil
  214.       ;; i really hate this but too many people are accustomed to these.
  215.       (define-key mim-mode-map "\e!" 'line-to-top-of-window)
  216.       (define-key mim-mode-map "\eo" 'open-mim-line)
  217.       (define-key mim-mode-map "\ep" 'previous-mim-object)
  218.       (define-key mim-mode-map "\en" 'next-mim-object)
  219.       (define-key mim-mode-map "\ea" 'beginning-of-DEFINE)
  220.       (define-key mim-mode-map "\ee" 'end-of-DEFINE)
  221.       (define-key mim-mode-map "\et" 'transpose-mim-objects)
  222.       (define-key mim-mode-map "\eu" 'backward-up-mim-object)
  223.       (define-key mim-mode-map "\ed" 'forward-down-mim-object)
  224.       (define-key mim-mode-map "\ek" 'forward-kill-mim-object)
  225.       (define-key mim-mode-map "\ef" 'forward-mim-object)
  226.       (define-key mim-mode-map "\eb" 'backward-mim-object))))
  227.   (use-local-map mim-mode-map)
  228.   (set-syntax-table mim-mode-syntax-table)
  229.   (make-local-variable 'paragraph-start)
  230.   (setq paragraph-start (concat "^$\\|" page-delimiter))
  231.   (make-local-variable 'paragraph-separate)
  232.   (setq paragraph-separate paragraph-start)
  233.   (make-local-variable 'paragraph-ignore-fill-prefix)
  234.   (setq paragraph-ignore-fill-prefix t)
  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)))
  861.