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