diff options
Diffstat (limited to 'lisp/=mim-mode.el')
| -rw-r--r-- | lisp/=mim-mode.el | 848 |
1 files changed, 0 insertions, 848 deletions
diff --git a/lisp/=mim-mode.el b/lisp/=mim-mode.el deleted file mode 100644 index 94e63cb9f48..00000000000 --- a/lisp/=mim-mode.el +++ /dev/null @@ -1,848 +0,0 @@ -;;; mim-mode.el --- Mim (MDL in MDL) mode. - -;; Copyright (C) 1985 Free Software Foundation, Inc. - -;; Author: K. Shane Hartman -;; Maintainer: FSF -;; Keywords: languages - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to -;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - -;;; Code: - -(autoload 'fast-syntax-check-mim "mim-syntax" - "Checks Mim syntax quickly. -Answers correct or incorrect, cannot point out the error context." - t) - -(autoload 'slow-syntax-check-mim "mim-syntax" - "Check Mim syntax slowly. -Points out the context of the error, if the syntax is incorrect." - t) - -(defvar mim-mode-hysterical-bindings t - "*Non-nil means bind list manipulation commands to Meta keys as well as -Control-Meta keys for historical reasons. Otherwise, only the latter keys -are bound.") - -(defvar mim-mode-map nil) - -(defvar mim-mode-syntax-table nil) - -(if mim-mode-syntax-table - () - (let ((i -1)) - (setq mim-mode-syntax-table (make-syntax-table)) - (while (< i ?\ ) - (modify-syntax-entry (setq i (1+ i)) " " mim-mode-syntax-table)) - (while (< i 127) - (modify-syntax-entry (setq i (1+ i)) "_ " mim-mode-syntax-table)) - (setq i (1- ?a)) - (while (< i ?z) - (modify-syntax-entry (setq i (1+ i)) "w " mim-mode-syntax-table)) - (setq i (1- ?A)) - (while (< i ?Z) - (modify-syntax-entry (setq i (1+ i)) "w " mim-mode-syntax-table)) - (setq i (1- ?0)) - (while (< i ?9) - (modify-syntax-entry (setq i (1+ i)) "w " mim-mode-syntax-table)) - (modify-syntax-entry ?: " " mim-mode-syntax-table) ; make : symbol delimiter - (modify-syntax-entry ?, "' " mim-mode-syntax-table) - (modify-syntax-entry ?. "' " mim-mode-syntax-table) - (modify-syntax-entry ?' "' " mim-mode-syntax-table) - (modify-syntax-entry ?` "' " mim-mode-syntax-table) - (modify-syntax-entry ?~ "' " mim-mode-syntax-table) - (modify-syntax-entry ?\; "' " mim-mode-syntax-table) ; comments are prefixed objects - (modify-syntax-entry ?# "' " mim-mode-syntax-table) - (modify-syntax-entry ?% "' " mim-mode-syntax-table) - (modify-syntax-entry ?! "' " mim-mode-syntax-table) - (modify-syntax-entry ?\" "\" " mim-mode-syntax-table) - (modify-syntax-entry ?\\ "\\ " mim-mode-syntax-table) - (modify-syntax-entry ?\( "\() " mim-mode-syntax-table) - (modify-syntax-entry ?\< "\(> " mim-mode-syntax-table) - (modify-syntax-entry ?\{ "\(} " mim-mode-syntax-table) - (modify-syntax-entry ?\[ "\(] " mim-mode-syntax-table) - (modify-syntax-entry ?\) "\)( " mim-mode-syntax-table) - (modify-syntax-entry ?\> "\)< " mim-mode-syntax-table) - (modify-syntax-entry ?\} "\){ " mim-mode-syntax-table) - (modify-syntax-entry ?\] "\)[ " mim-mode-syntax-table))) - -(defconst mim-whitespace "\000- ") - -(defvar mim-mode-hook nil - "*User function run after mim mode initialization. Usage: -\(setq mim-mode-hook '(lambda () ... your init forms ...)).") - -(define-abbrev-table 'mim-mode-abbrev-table nil) - -(defconst indent-mim-function 'indent-mim-function - "Controls (via properties) indenting of special forms. -\(put 'FOO 'indent-mim-function n\), integer n, means lines inside -<FOO ...> will be indented n spaces from start of form. -\(put 'FOO 'indent-mim-function 'DEFINE\) is like above but means use -value of mim-body-indent as offset from start of form. -\(put 'FOO 'indent-mim-function <cons>\) where <cons> is a list or pointed list -of integers, means indent each form in <FOO ...> by the amount specified -in <cons>. When <cons> is exhausted, indent remaining forms by -`mim-body-indent' unless <cons> is a pointed list, in which case the last -cdr is used. Confused? Here is an example: -\(put 'FROBIT 'indent-mim-function '\(4 2 . 1\)\) -<FROBIT - <CHOMP-IT> - <CHOMP-SOME-MORE> - <DIGEST> - <BELCH> - ...> -Finally, the property can be a function name (read the code).") - -(defvar indent-mim-comment t - "*Non-nil means indent string comments.") - -(defvar mim-body-indent 2 - "*Amount to indent in special forms which have DEFINE property on -`indent-mim-function'.") - -(defvar indent-mim-arglist t - "*nil means indent arglists like ordinary lists. -t means strings stack under start of arglist and variables stack to -right of them. Otherwise, strings stack under last string (or start -of arglist if none) and variables stack to right of them. -Examples (for values 'stack, t, nil): - -\(FOO \"OPT\" BAR \(FOO \"OPT\" BAR \(FOO \"OPT\" BAR - BAZ MUMBLE BAZ MUMBLE BAZ MUMBLE - \"AUX\" \"AUX\" \"AUX\" - BLETCH ... BLETCH ... BLETCH ...") - -(put 'DEFINE 'indent-mim-function 'DEFINE) -(put 'DEFMAC 'indent-mim-function 'DEFINE) -(put 'BIND 'indent-mim-function 'DEFINE) -(put 'PROG 'indent-mim-function 'DEFINE) -(put 'REPEAT 'indent-mim-function 'DEFINE) -(put 'CASE 'indent-mim-function 'DEFINE) -(put 'FUNCTION 'indent-mim-function 'DEFINE) -(put 'MAPF 'indent-mim-function 'DEFINE) -(put 'MAPR 'indent-mim-function 'DEFINE) -(put 'UNWIND 'indent-mim-function (cons (* 2 mim-body-indent) mim-body-indent)) - -(defvar mim-down-parens-only t - "*nil means treat ADECLs and ATOM trailers like structures when -moving down a level of structure.") - -(defvar mim-stop-for-slop t - "*Non-nil means {next previous}-mim-object consider any -non-whitespace character in column 0 to be a toplevel object, otherwise -only open paren syntax characters will be considered.") - -(defalias 'mdl-mode 'mim-mode) - -(defun mim-mode () - "Major mode for editing Mim (MDL in MDL) code. -Commands: - If value of `mim-mode-hysterical-bindings' is non-nil, then following -commands are assigned to escape keys as well (e.g. ESC f = ESC C-f). -The default action is bind the escape keys. -\\{mim-mode-map} -Other Commands: - Use \\[describe-function] to obtain documentation. - replace-in-mim-object find-mim-definition fast-syntax-check-mim - slow-syntax-check-mim backward-down-mim-object forward-up-mim-object -Variables: - Use \\[describe-variable] to obtain documentation. - mim-mode-hook indent-mim-comment indent-mim-arglist indent-mim-function - mim-body-indent mim-down-parens-only mim-stop-for-slop - mim-mode-hysterical-bindings -Entry to this mode calls the value of mim-mode-hook if non-nil." - (interactive) - (kill-all-local-variables) - (if (not mim-mode-map) - (progn - (setq mim-mode-map (make-sparse-keymap)) - (define-key mim-mode-map "\e\^o" 'open-mim-line) - (define-key mim-mode-map "\e\^q" 'indent-mim-object) - (define-key mim-mode-map "\e\^p" 'previous-mim-object) - (define-key mim-mode-map "\e\^n" 'next-mim-object) - (define-key mim-mode-map "\e\^a" 'beginning-of-DEFINE) - (define-key mim-mode-map "\e\^e" 'end-of-DEFINE) - (define-key mim-mode-map "\e\^t" 'transpose-mim-objects) - (define-key mim-mode-map "\e\^u" 'backward-up-mim-object) - (define-key mim-mode-map "\e\^d" 'forward-down-mim-object) - (define-key mim-mode-map "\e\^h" 'mark-mim-object) - (define-key mim-mode-map "\e\^k" 'forward-kill-mim-object) - (define-key mim-mode-map "\e\^f" 'forward-mim-object) - (define-key mim-mode-map "\e\^b" 'backward-mim-object) - (define-key mim-mode-map "\e^" 'raise-mim-line) - (define-key mim-mode-map "\e\\" 'fixup-whitespace) - (define-key mim-mode-map "\177" 'backward-delete-char-untabify) - (define-key mim-mode-map "\e\177" 'backward-kill-mim-object) - (define-key mim-mode-map "\^j" 'newline-and-mim-indent) - (define-key mim-mode-map "\e;" 'begin-mim-comment) - (define-key mim-mode-map "\t" 'indent-mim-line) - (define-key mim-mode-map "\e\t" 'indent-mim-object) - (if (not mim-mode-hysterical-bindings) - nil - ;; i really hate this but too many people are accustomed to these. - (define-key mim-mode-map "\e!" 'line-to-top-of-window) - (define-key mim-mode-map "\eo" 'open-mim-line) - (define-key mim-mode-map "\ep" 'previous-mim-object) - (define-key mim-mode-map "\en" 'next-mim-object) - (define-key mim-mode-map "\ea" 'beginning-of-DEFINE) - (define-key mim-mode-map "\ee" 'end-of-DEFINE) - (define-key mim-mode-map "\et" 'transpose-mim-objects) - (define-key mim-mode-map "\eu" 'backward-up-mim-object) - (define-key mim-mode-map "\ed" 'forward-down-mim-object) - (define-key mim-mode-map "\ek" 'forward-kill-mim-object) - (define-key mim-mode-map "\ef" 'forward-mim-object) - (define-key mim-mode-map "\eb" 'backward-mim-object)))) - (use-local-map mim-mode-map) - (set-syntax-table mim-mode-syntax-table) - (make-local-variable 'paragraph-start) - (setq paragraph-start (concat "$\\|" page-delimiter)) - (make-local-variable 'paragraph-separate) - (setq paragraph-separate paragraph-start) - (make-local-variable 'paragraph-ignore-fill-prefix) - (setq paragraph-ignore-fill-prefix t) - ;; Most people use string comments. - (make-local-variable 'comment-start) - (setq comment-start ";\"") - (make-local-variable 'comment-start-skip) - (setq comment-start-skip ";\"") - (make-local-variable 'comment-end) - (setq comment-end "\"") - (make-local-variable 'comment-column) - (setq comment-column 40) - (make-local-variable 'comment-indent-function) - (setq comment-indent-function 'indent-mim-comment) - ;; tell generic indenter how to indent. - (make-local-variable 'indent-line-function) - (setq indent-line-function 'indent-mim-line) - ;; look for that paren - (make-local-variable 'blink-matching-paren-distance) - (setq blink-matching-paren-distance nil) - ;; so people who dont like tabs can turn them off locally in indenter. - (make-local-variable 'indent-tabs-mode) - (setq indent-tabs-mode t) - (setq local-abbrev-table mim-mode-abbrev-table) - (setq major-mode 'mim-mode) - (setq mode-name "Mim") - (run-hooks 'mim-mode-hook)) - -(defun line-to-top-of-window () - "Move current line to top of window." - (interactive) ; for lazy people - (recenter 0)) - -(defun forward-mim-object (arg) - "Move forward across Mim object. -With ARG, move forward that many objects." - (interactive "p") - ;; this function is weird because it emulates the behavior of the old - ;; (gosling) mim-mode - if the arg is 1 and we are `inside' an ADECL, - ;; more than one character into the ATOM part and not sitting on the - ;; colon, then we move to the DECL part (just past colon) instead of - ;; the end of the object (the entire ADECL). otherwise, ADECL's are - ;; atomic objects. likewise for ATOM trailers. - (if (= (abs arg) 1) - (if (inside-atom-p) - ;; Move to end of ATOM or to trailer (!) or to ADECL (:). - (forward-sexp arg) - ;; Either scan an sexp or move over one bracket. - (forward-mim-objects arg t)) - ;; in the multi-object case, don't perform any magic. - ;; treats ATOM trailers and ADECLs atomically, stops at unmatched - ;; brackets with error. - (forward-mim-objects arg))) - -(defun inside-atom-p () - ;; Returns t iff inside an atom (takes account of trailers) - (let ((c1 (preceding-char)) - (c2 (following-char))) - (and (or (= (char-syntax c1) ?w) (= (char-syntax c1) ?_) (= c1 ?!)) - (or (= (char-syntax c2) ?w) (= (char-syntax c2) ?_) (= c2 ?!))))) - -(defun forward-mim-objects (arg &optional skip-bracket-p) - ;; Move over arg objects ignoring ADECLs and trailers. If - ;; skip-bracket-p is non-nil, then move over one bracket on error. - (let ((direction (sign arg))) - (condition-case conditions - (while (/= arg 0) - (forward-sexp direction) - (if (not (inside-adecl-or-trailer-p direction)) - (setq arg (- arg direction)))) - (error (if (not skip-bracket-p) - (signal 'error (cdr conditions)) - (skip-mim-whitespace direction) - (goto-char (+ (point) direction))))) - ;; If we moved too far move back to first interesting character. - (if (= (point) (buffer-end direction)) (skip-mim-whitespace (- direction))))) - -(defun backward-mim-object (&optional arg) - "Move backward across Mim object. -With ARG, move backward that many objects." - (interactive "p") - (forward-mim-object (if arg (- arg) -1))) - -(defun mark-mim-object (&optional arg) - "Mark following Mim object. -With ARG, mark that many following (preceding, ARG < 0) objects." - (interactive "p") - (push-mark (save-excursion (forward-mim-object (or arg 1)) (point)))) - -(defun forward-kill-mim-object (&optional arg) - "Kill following Mim object. -With ARG, kill that many objects." - (interactive "*p") - (kill-region (point) (progn (forward-mim-object (or arg 1)) (point)))) - -(defun backward-kill-mim-object (&optional arg) - "Kill preceding Mim object. -With ARG, kill that many objects." - (interactive "*p") - (forward-kill-mim-object (- (or arg 1)))) - -(defun raise-mim-line (&optional arg) - "Raise following line, fixing up whitespace at join. -With ARG raise that many following lines. -A negative ARG will raise current line and previous lines." - (interactive "*p") - (let* ((increment (sign (or arg (setq arg 1)))) - (direction (if (> arg 0) 1 0))) - (save-excursion - (while (/= arg 0) - ;; move over eol and kill it - (forward-line direction) - (delete-region (point) (1- (point))) - (fixup-whitespace) - (setq arg (- arg increment)))))) - -(defun forward-down-mim-object (&optional arg) - "Move down a level of Mim structure forwards. -With ARG, move down that many levels forwards (backwards, ARG < 0)." - (interactive "p") - ;; another weirdo - going down `inside' an ADECL or ATOM trailer - ;; depends on the value of mim-down-parens-only. if nil, treat - ;; ADECLs and trailers as structured objects. - (let ((direction (sign (or arg (setq arg 1))))) - (if (and (= (abs arg) 1) (not mim-down-parens-only)) - (goto-char - (save-excursion - (skip-mim-whitespace direction) - (if (> direction 0) (re-search-forward "\\s'*")) - (or (and (let ((c (next-char direction))) - (or (= (char-syntax c) ?_) - (= (char-syntax c) ?w))) - (progn (forward-sexp direction) - (if (inside-adecl-or-trailer-p direction) - (point)))) - (scan-lists (point) direction -1) - (buffer-end direction)))) - (while (/= arg 0) - (goto-char (or (scan-lists (point) direction -1) (buffer-end direction))) - (setq arg (- arg direction)))))) - -(defun backward-down-mim-object (&optional arg) - "Move down a level of Mim structure backwards. -With ARG, move down that many levels backwards (forwards, ARG < 0)." - (interactive "p") - (forward-down-mim-object (if arg (- arg) -1))) - -(defun forward-up-mim-object (&optional arg) - "Move up a level of Mim structure forwards -With ARG, move up that many levels forwards (backwards, ARG < 0)." - (interactive "p") - (let ((direction (sign (or arg (setq arg 1))))) - (while (/= arg 0) - (goto-char (or (scan-lists (point) direction 1) (buffer-end arg))) - (setq arg (- arg direction))) - (if (< direction 0) (backward-prefix-chars)))) - -(defun backward-up-mim-object (&optional arg) - "Move up a level of Mim structure backwards -With ARG, move up that many levels backwards (forwards, ARG > 0)." - (interactive "p") - (forward-up-mim-object (if arg (- arg) -1))) - -(defun replace-in-mim-object (old new) - "Replace string in following Mim object." - (interactive "*sReplace in object: \nsReplace %s with: ") - (save-restriction - (narrow-to-region (point) (save-excursion (forward-mim-object 1) (point))) - (replace-string old new))) - -(defun transpose-mim-objects (&optional arg) - "Transpose Mim objects around point. -With ARG, transpose preceding object that many times with following objects. -A negative ARG will transpose backwards." - (interactive "*p") - (transpose-subr 'forward-mim-object (or arg 1))) - -(defun beginning-of-DEFINE (&optional arg move) - "Move backward to beginning of surrounding or previous toplevel Mim form. -With ARG, do it that many times. Stops at last toplevel form seen if buffer -end is reached." - (interactive "p") - (let ((direction (sign (or arg (setq arg 1))))) - (if (not move) (setq move t)) - (if (< direction 0) (goto-char (1+ (point)))) - (while (and (/= arg 0) (re-search-backward "^<" nil move direction)) - (setq arg (- arg direction))) - (if (< direction 0) - (goto-char (1- (point)))))) - -(defun end-of-DEFINE (&optional arg) - "Move forward to end of surrounding or next toplevel mim form. -With ARG, do it that many times. Stops at end of last toplevel form seen -if buffer end is reached." - (interactive "p") - (if (not arg) (setq arg 1)) - (if (< arg 0) - (beginning-of-DEFINE (- (1- arg))) - (if (not (looking-at "^<")) (setq arg (1+ arg))) - (beginning-of-DEFINE (- arg) 'move) - (beginning-of-DEFINE 1)) - (forward-mim-object 1) - (forward-line 1)) - -(defun next-mim-object (&optional arg) - "Move to beginning of next toplevel Mim object. -With ARG, do it that many times. Stops at last object seen if buffer end -is reached." - (interactive "p") - (let ((search-string (if mim-stop-for-slop "^\\S " "^\\s(")) - (direction (sign (or arg (setq arg 1))))) - (if (> direction 0) - (goto-char (1+ (point)))) ; no error if end of buffer - (while (and (/= arg 0) - (re-search-forward search-string nil t direction)) - (setq arg (- arg direction))) - (if (> direction 0) - (goto-char (1- (point)))) ; no error if beginning of buffer - ;; scroll to top of window if moving forward and end not visible. - (if (not (or (< direction 0) - (save-excursion (forward-mim-object 1) - (pos-visible-in-window-p (point))))) - (recenter 0)))) - -(defun previous-mim-object (&optional arg) - "Move to beginning of previous toplevel Mim object. -With ARG do it that many times. Stops at last object seen if buffer end -is reached." - (interactive "p") - (next-mim-object (- (or arg 1)))) - -(defun calculate-mim-indent (&optional parse-start) - "Calculate indentation for Mim line. Returns column." - (save-excursion ; some excursion, huh, toto? - (beginning-of-line) - (let ((indent-point (point)) retry state containing-sexp last-sexp - desired-indent start peek where paren-depth) - (if parse-start - (goto-char parse-start) ; should be containing environment - (catch 'from-the-top - ;; find a place to start parsing. going backwards is fastest. - ;; forward-sexp signals error on encountering unmatched open. - (setq retry t) - (while retry - (condition-case nil (forward-sexp -1) (error (setq retry nil))) - (if (looking-at ".?[ \t]*\"") - ;; cant parse backward in presence of strings, go forward. - (progn - (goto-char indent-point) - (re-search-backward "^\\s(" nil 'move 1) ; to top of object - (throw 'from-the-top nil))) - (setq retry (and retry (/= (current-column) 0)))) - (skip-chars-backward mim-whitespace) - (if (not (bobp)) (forward-char -1)) ; onto unclosed open - (backward-prefix-chars))) - ;; find outermost containing sexp if we started inside an sexp. - (while (< (point) indent-point) - (setq state (parse-partial-sexp (point) indent-point 0))) - ;; find usual column to indent under (not in string or toplevel). - ;; on termination, state will correspond to containing environment - ;; (if retry is nil), where will be position of character to indent - ;; under normally, and desired-indent will be the column to indent to - ;; except if inside form, string, or at toplevel. point will be in - ;; in column to indent to unless inside string. - (setq retry t) - (while (and retry (setq paren-depth (car state)) (> paren-depth 0)) - ;; find innermost containing sexp. - (setq retry nil) - (setq last-sexp (car (nthcdr 2 state))) - (setq containing-sexp (car (cdr state))) - (goto-char (1+ containing-sexp)) ; to last unclosed open - (if (and last-sexp (> last-sexp (point))) - ;; is the last sexp a containing sexp? - (progn (setq peek (parse-partial-sexp last-sexp indent-point 0)) - (if (setq retry (car (cdr peek))) (setq state peek)))) - (if retry - nil - (setq where (1+ containing-sexp)) ; innermost containing sexp - (goto-char where) - (cond - ((not last-sexp) ; indent-point after bracket - (setq desired-indent (current-column))) - ((= (preceding-char) ?\<) ; it's a form - (cond ((> (progn (forward-sexp 1) (point)) last-sexp) - (goto-char where)) ; only one frob - ((> (save-excursion (forward-line 1) (point)) last-sexp) - (skip-chars-forward " \t") ; last-sexp is on same line - (setq where (point))) ; as containing-sexp - ((progn - (goto-char last-sexp) - (beginning-of-line) - (parse-partial-sexp (point) last-sexp 0 t) - (or (= (point) last-sexp) - (save-excursion - (= (car (parse-partial-sexp (point) last-sexp 0)) - 0)))) - (backward-prefix-chars) ; last-sexp 1st on line or 1st - (setq where (point))) ; frob on that line level 0 - (t (goto-char where)))) ; punt, should never occur - ((and indent-mim-arglist ; maybe hack arglist - (= (preceding-char) ?\() ; its a list - (save-excursion ; look for magic atoms - (setq peek 0) ; using peek as counter - (forward-char -1) ; back over containing paren - (while (and (< (setq peek (1+ peek)) 6) - (condition-case nil - (progn (forward-sexp -1) t) - (error nil)))) - (and (< peek 6) (looking-at "DEFINE\\|DEFMAC\\|FUNCTION")))) - ;; frobs stack under strings they belong to or under first - ;; frob to right of strings they belong to unless luser has - ;; frob (non-string) on preceding line with different - ;; indentation. strings stack under start of arglist unless - ;; mim-indent-arglist is not t, in which case they stack - ;; under the last string, if any, else the start of the arglist. - (let ((eol 0) last-string) - (while (< (point) last-sexp) ; find out where the strings are - (skip-chars-forward mim-whitespace last-sexp) - (if (> (setq start (point)) eol) - (progn ; simultaneously keeping track - (setq where (min where start)) - (end-of-line) ; of indentation of first frob - (setq eol (point)) ; on each line - (goto-char start))) - (if (= (following-char) ?\") - (progn (setq last-string (point)) - (forward-sexp 1) - (if (= last-string last-sexp) - (setq where last-sexp) - (skip-chars-forward mim-whitespace last-sexp) - (setq where (point)))) - (forward-sexp 1))) - (goto-char indent-point) ; if string is first on - (skip-chars-forward " \t" (point-max)) ; line we are indenting, it - (if (= (following-char) ?\") ; goes under arglist start - (if (and last-string (not (equal indent-mim-arglist t))) - (setq where last-string) ; or under last string. - (setq where (1+ containing-sexp))))) - (goto-char where) - (setq desired-indent (current-column))) - (t ; plain vanilla structure - (cond ((> (save-excursion (forward-line 1) (point)) last-sexp) - (skip-chars-forward " \t") ; last-sexp is on same line - (setq where (point))) ; as containing-sexp - ((progn - (goto-char last-sexp) - (beginning-of-line) - (parse-partial-sexp (point) last-sexp 0 t) - (or (= (point) last-sexp) - (save-excursion - (= (car (parse-partial-sexp (point) last-sexp 0)) - 0)))) - (backward-prefix-chars) ; last-sexp 1st on line or 1st - (setq where (point))) ; frob on that line level 0 - (t (goto-char where))) ; punt, should never occur - (setq desired-indent (current-column)))))) - ;; state is innermost containing environment unless toplevel or string. - (if (car (nthcdr 3 state)) ; inside string - (progn - (if last-sexp ; string must be next - (progn (goto-char last-sexp) - (forward-sexp 1) - (search-forward "\"") - (forward-char -1)) - (goto-char indent-point) ; toplevel string, look for it - (re-search-backward "[^\\]\"") - (forward-char 1)) - (setq start (point)) ; opening double quote - (skip-chars-backward " \t") - (backward-prefix-chars) - ;; see if the string is really a comment. - (if (and (looking-at ";[ \t]*\"") indent-mim-comment) - ;; it's a comment, line up under the start unless disabled. - (goto-char (1+ start)) - ;; it's a string, dont mung the indentation. - (goto-char indent-point) - (skip-chars-forward " \t")) - (setq desired-indent (current-column)))) - ;; point is sitting in usual column to indent to and if retry is nil - ;; then state corresponds to containing environment. if desired - ;; indentation not determined, we are inside a form, so call hook. - (or desired-indent - (and indent-mim-function - (not retry) - (setq desired-indent - (funcall indent-mim-function state indent-point))) - (setq desired-indent (current-column))) - (goto-char indent-point) ; back to where we started - desired-indent))) ; return column to indent to - -(defun indent-mim-function (state indent-point) - "Compute indentation for Mim special forms. Returns column or nil." - (let ((containing-sexp (car (cdr state))) (current-indent (point))) - (save-excursion - (goto-char (1+ containing-sexp)) - (backward-prefix-chars) - ;; make sure we are looking at a symbol. if so, see if it is a special - ;; symbol. if so, add the special indentation to the indentation of - ;; the start of the special symbol, unless the property is not - ;; an integer and not nil (in this case, call the property, it must - ;; be a function which returns the appropriate indentation or nil and - ;; does not change the buffer). - (if (looking-at "\\sw\\|\\s_") - (let* ((start (current-column)) - (function - (intern-soft (buffer-substring (point) - (progn (forward-sexp 1) - (point))))) - (method (get function 'indent-mim-function))) - (if (or (if (equal method 'DEFINE) (setq method mim-body-indent)) - (integerp method)) - ;; only use method if its first line after containing-sexp. - ;; we could have done this in calculate-mim-indent, but someday - ;; someone might want to format frobs in a special form based - ;; on position instead of indenting uniformly (like lisp if), - ;; so preserve right for posterity. if not first line, - ;; calculate-mim-indent already knows right indentation - - ;; give luser chance to change indentation manually by changing - ;; 1st line after containing-sexp. - (if (> (progn (forward-line 1) (point)) (car (nthcdr 2 state))) - (+ method start)) - (goto-char current-indent) - (if (consp method) - ;; list or pointed list of explicit indentations - (indent-mim-offset state indent-point) - (if (and (symbolp method) (fboundp method)) - ;; luser function - s/he better know what's going on. - ;; should take state and indent-point as arguments - for - ;; description of state, see parse-partial-sexp - ;; documentation the function is guaranteed the following: - ;; (1) state describes the closest surrounding form, - ;; (2) indent-point is the beginning of the line being - ;; indented, (3) point points to char in column that would - ;; normally be used for indentation, (4) function is bound - ;; to the special ATOM. See indent-mim-offset for example - ;; of a special function. - (funcall method state indent-point))))))))) - -(defun indent-mim-offset (state indent-point) - ;; offset forms explicitly according to list of indentations. - (let ((mim-body-indent mim-body-indent) - (indentations (get function 'indent-mim-function)) - (containing-sexp (car (cdr state))) - (last-sexp (car (nthcdr 2 state))) - indentation) - (goto-char (1+ containing-sexp)) - ;; determine which of the indentations to use. - (while (and (< (point) indent-point) - (condition-case nil - (progn (forward-sexp 1) - (parse-partial-sexp (point) indent-point 1 t)) - (error nil))) - (skip-chars-backward " \t") - (backward-prefix-chars) - (if (= (following-char) ?\;) - nil ; ignore comments - (setq indentation (car indentations)) - (if (integerp (setq indentations (cdr indentations))) - ;; if last cdr is integer, that is indentation to use for all - ;; all the rest of the forms. - (progn (setq mim-body-indent indentations) - (setq indentations nil))))) - (goto-char (1+ containing-sexp)) - (+ (current-column) (or indentation mim-body-indent)))) - -(defun indent-mim-comment (&optional start) - "Indent a one line (string) Mim comment following object, if any." - (let* ((old-point (point)) (eol (progn (end-of-line) (point))) state last-sexp) - ;; this function assumes that comment indenting is enabled. it is caller's - ;; responsibility to check the indent-mim-comment flag before calling. - (beginning-of-line) - (catch 'no-comment - (setq state (parse-partial-sexp (point) eol)) - ;; determine if there is an existing regular comment. a `regular' - ;; comment is defined as a commented string which is the last thing - ;; on the line and does not extend beyond the end of the line. - (if (or (not (setq last-sexp (car (nthcdr 2 state)))) - (car (nthcdr 3 state))) - ;; empty line or inside string (multiple line). - (throw 'no-comment nil)) - ;; could be a comment, but make sure its not the only object. - (beginning-of-line) - (parse-partial-sexp (point) eol 0 t) - (if (= (point) last-sexp) - ;; only one object on line - (throw 'no-comment t)) - (goto-char last-sexp) - (skip-chars-backward " \t") - (backward-prefix-chars) - (if (not (looking-at ";[ \t]*\"")) - ;; aint no comment - (throw 'no-comment nil)) - ;; there is an existing regular comment - (delete-horizontal-space) - ;; move it to comment-column if possible else to tab-stop - (if (< (current-column) comment-column) - (indent-to comment-column) - (tab-to-tab-stop))) - (goto-char old-point))) - -(defun indent-mim-line () - "Indent line of Mim code." - (interactive "*") - (let* ((position (- (point-max) (point))) - (bol (progn (beginning-of-line) (point))) - (indent (calculate-mim-indent))) - (skip-chars-forward " \t") - (if (/= (current-column) indent) - (progn (delete-region bol (point)) (indent-to indent))) - (if (> (- (point-max) position) (point)) (goto-char (- (point-max) position))))) - -(defun newline-and-mim-indent () - "Insert newline at point and indent." - (interactive "*") - ;; commented code would correct indentation of line in arglist which - ;; starts with string, but it would indent every line twice. luser can - ;; just say tab after typing string to get same effect. - ;(if indent-mim-arglist (indent-mim-line)) - (newline) - (indent-mim-line)) - -(defun open-mim-line (&optional lines) - "Insert newline before point and indent. -With ARG insert that many newlines." - (interactive "*p") - (beginning-of-line) - (let ((indent (calculate-mim-indent))) - (while (> lines 0) - (newline) - (forward-line -1) - (indent-to indent) - (setq lines (1- lines))))) - -(defun indent-mim-object (&optional dont-indent-first-line) - "Indent object following point and all lines contained inside it. -With ARG, idents only contained lines (skips first line)." - (interactive "*P") - (let (end bol indent start) - (save-excursion (parse-partial-sexp (point) (point-max) 0 t) - (setq start (point)) - (forward-sexp 1) - (setq end (- (point-max) (point)))) - (save-excursion - (if (not dont-indent-first-line) (indent-mim-line)) - (while (progn (forward-line 1) (> (- (point-max) (point)) end)) - (setq indent (calculate-mim-indent start)) - (setq bol (point)) - (skip-chars-forward " \t") - (if (/= indent (current-column)) - (progn (delete-region bol (point)) (indent-to indent))) - (if indent-mim-comment (indent-mim-comment)))))) - -(defun find-mim-definition (name) - "Search for definition of function, macro, or gfcn. -You need type only enough of the name to be unambiguous." - (interactive "sName: ") - (let (where) - (save-excursion - (goto-char (point-min)) - (condition-case nil - (progn - (re-search-forward - (concat "^<\\(DEFINE\\|\\DEFMAC\\|FCN\\|GFCN\\)\\([ \t]*\\)" - name)) - (setq where (point))) - (error (error "Can't find %s" name)))) - (if where - (progn (push-mark) - (goto-char where) - (beginning-of-line) - (recenter 0))))) - -(defun begin-mim-comment () - "Move to existing comment or insert empty comment." - (interactive "*") - (let* ((eol (progn (end-of-line) (point))) - (bol (progn (beginning-of-line) (point)))) - ;; check for existing comment first. - (if (re-search-forward ";[ \t]*\"" eol t) - ;; found it. indent if desired and go there. - (if indent-mim-comment - (let ((where (- (point-max) (point)))) - (indent-mim-comment) - (goto-char (- (point-max) where)))) - ;; nothing there, make a comment. - (let (state last-sexp) - ;; skip past all the sexps on the line - (goto-char bol) - (while (and (equal (car (setq state (parse-partial-sexp (point) eol 0))) - 0) - (car (nthcdr 2 state))) - (setq last-sexp (car (nthcdr 2 state)))) - (if (car (nthcdr 3 state)) - nil ; inside a string, punt - (delete-region (point) eol) ; flush trailing whitespace - (if (and (not last-sexp) (equal (car state) 0)) - (indent-to (calculate-mim-indent)) ; empty, indent like code - (if (> (current-column) comment-column) ; indent to comment column - (tab-to-tab-stop) ; unless past it, else to - (indent-to comment-column))) ; tab-stop - ;; if luser changes comment-{start end} to something besides semi - ;; followed by zero or more whitespace characters followed by string - ;; delimiters, the code above fails to find existing comments, but as - ;; taa says, `let the losers lose'. - (insert comment-start) - (save-excursion (insert comment-end))))))) - -(defun skip-mim-whitespace (direction) - (if (>= direction 0) - (skip-chars-forward mim-whitespace (point-max)) - (skip-chars-backward mim-whitespace (point-min)))) - -(defun inside-adecl-or-trailer-p (direction) - (if (>= direction 0) - (looking-at ":\\|!-") - (or (= (preceding-char) ?:) - (looking-at "!-")))) - -(defun sign (n) - "Returns -1 if N < 0, else 1." - (if (>= n 0) 1 -1)) - -(defun abs (n) - "Returns the absolute value of N." - (if (>= n 0) n (- n))) - -(defun next-char (direction) - "Returns preceding-char if DIRECTION < 0, otherwise following-char." - (if (>= direction 0) (following-char) (preceding-char))) - -(provide 'mim-mode) - -;;; mim-mode.el ends here |