;; himml-mode.el. Major mode for editing HimML. ;; Copyright (C) 1995-1999 Jean Goubault-Larrecq and Bull S.A. ;; Copyright (C) 2000-2004 Jean Goubault-Larrecq ;; and LSV, CNRS UMR 8643 & INRIA Futurs projet Secsi & ENS Cachan. ;; Copyright (C) 1995-1999, Jean Goubault-Larrecq. ;; Copyright (C) 1989, Lars Bo Nielsen. ;; Copyright (C) 1989, Free Software Foundation, Inc. ;; This file is part of GNU Emacs. ;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY. No author or distributor ;; accepts responsibility to anyone for the consequences of using it ;; or for whether it serves any particular purpose or works at all, ;; unless he says so in writing. Refer to the GNU Emacs General Public ;; License for full details. ;; Everyone is granted permission to copy, modify and redistribute ;; GNU Emacs, but only under the conditions described in the ;; GNU Emacs General Public License. A copy of this license is ;; supposed to have been given to you along with GNU Emacs so you ;; can know your rights and responsibilities. It should be in a ;; file named COPYING. Among other things, the copyright notice ;; and this notice must be preserved on all copies. ;; AUTHOR Lars Bo Nielsen ;; Aalborg University ;; Computer Science Dept. ;; 9000 Aalborg ;; Denmark ;; ;; EMAIL lbn@iesd.auc.dk ;; or: ...!mcvax!diku!iesd!lbn ;; or: mcvax!diku!iesd!lbn@uunet.uu.net ;; ;; Modified by Jean Goubault-Larrecq for use with HimML. ;; Jean Goubault-Larrecq ;; G.I.E. Dyade ;; Inria batiment 3 ;; Rocquencourt ;; F-78153 Le Chesnay Cedex ;; ;; EMAIL Jean.Goubault@inria.fr ;; ;; Please let me know if you come up with any ideas, bugs, or fixes. ;; ---------------------------------------------------------------- (provide 'himml-mode) (defconst himml-mode-version-string "HimML-MODE V1.1 (September 1996) (Jean.Goubault@inria.fr), derived from SML-MODE, Version 3.0 (May 1990) (lbn@iesd.auc.dk)") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; CONSTANTS CONTROLLING THE MODE. ;;; ;;; These are the constants you might want to change ;;; (defvar himml-indent-level 4 "*Indentation of blocks in ml.") (defvar himml-pipe-indent -2 "*Extra (negative) indentation for lines beginning with |.") (defvar himml-case-indent nil "*How to indent case-of expressions. If t: case expr If nil: case expr of of exp1 => ... exp1 => ... | exp2 => ... | exp2 => ... The first seems to be the standard in NJ-SML, but the second is the default.") (defvar himml-nested-if-indent t "*If set to t, nested if-then-else expression will have the same indentation as: if exp1 then exp2 else if exp3 then exp4 else if exp5 then exp6 else exp7") (defvar himml-type-of-indent t "*How to indent `let' `struct' etc. If t: fun foo bar = let If nil: fun foo bar = let val p = 4 val p = 4 in in bar + p bar + p end end Will not have any effect if the starting keyword is first on the line.") (defvar himml-electric-semi-mode nil "*If t, a `\;' will insert itself, reindent the line, and perform a newline. If nil, just insert a `\;'. (To insert while t, do: C-q \;).") (defvar himml-paren-lookback 2000 "*Determines how far back (in chars) the indentation algorithm should look for open parenthesis. High value means slow indentation algorithm. A value of 2000 (being the equivalent of 40-60 lines) should suffice most uses. (A value of nil, means do not look at all)") (defvar himml-prog-name "himml" "*Name of program to run as ml.") (defvar himml-prog-name-ask-p nil "*If t, you will be asked which program to run when the inferior shell starts up.") (defvar himml-use-left-delim "\"" "*The left delimiter for the filename when using \"use\". To be set to `\"[\\\"\"' for Edinburgh SML, and `\"\\\"\"' for New Jersey SML. Corresponds to `himml-use-right-delim'.") (defvar himml-use-right-delim "\"" "*The right delimiter for the filename when using \"use\". To be set to `\"\\\"]\"' for Edinburgh SML, and `\"\\\"\"' for New Jersey SML. Corresponds to `himml-use-left-delim'.") (defvar himml-shell-prompt-pattern "^\\(>\\|\\((debug)\\)[ \\t]*\\)+" "*The prompt pattern for the inferior shell running ml.") (defvar himml-tmp-template "/tmp/himml.tmp." "*Template for the temporary files, created when a region is send to the inferior process running ml (by himml-simulate-send-region).") (defvar himml-strip-path t "*If t, then when sending a `use file' to the inferior ml process, the leading path of the filename is stripped of, iff the file is in the same directory as the directory ml was started in. If you change the working directory of the inferior himml, after it has started up you are in trouble. To get out of this trouble, set this variable to nil.") (defvar himml-message-buffer-name "*HimML message*" "*Name of the buffer where all HimML messages will be printed.") (defvar himml-message-buffer-height 7 "*Normal height of HimML's message buffer.") (defvar himml-shell-cd-regexp "cd" "*Regexp to match HimML commands equivalent to cd.") (defvar himml-shell-dirtrackp t "Non-nil in a HimML buffer means directory tracking is enabled.") ;;; ;;; END OF CONSTANTS CONTROLLING THE MODE. ;;; ;;; If you change anything below, you are on your own. ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defvar himml-mode-map nil "The mode map used in himml-mode.") (defvar himml-mode-abbrev-table nil "The table of abbrevs for himml-mode.") (defvar himml-emacs19-p (>= (string-to-number (substring emacs-version 0 2)) 19)) (defvar himml-emacs20-p (>= (string-to-number (substring emacs-version 0 2)) 20)) (if himml-emacs19-p ; emacs 19: then install a menu (defun himml-create-mode-menu (mode-map shellp) (let ((map (make-sparse-keymap "HimML"))) (define-key mode-map [menu-bar] (make-sparse-keymap)) (define-key mode-map [menu-bar himml] (cons "HimML" map)) (if shellp (progn (define-key map [next-error] '("Next Error" . himml-next-error)) (define-key map [prev-error] '("Previous Error" . himml-prev-error)) (define-key map [separator-format] '("--")) ) ) (define-key map [send-buffer] '("Send Buffer" . himml-send-buffer)) (define-key map [send-region] '("Send Region" . himml-send-region)) (define-key map [send-function] '("Send Function" . himml-send-function)) (define-key map [eval] '("Eval..." . himml-eval)) (define-key map [run-on-file] '("Run on File..." . himml-run-on-file)) (if shellp () (define-key map [separator-format] '("--")) (define-key map [electric-pipe] '("Electric Pipe" . himml-electric-pipe)) (define-key map [indent-region] '("Indent Region" . himml-indent-region)) (define-key map [indent-line] '("Indent Line" . himml-indent-line)) (put 'indent-region 'menu-enable 'mark-active)))) (defun himml-create-mode-menu (mode-map shellp)) ) (if himml-mode-map () (setq himml-mode-map (if himml-emacs19-p (make-sparse-keymap "HimML") (make-sparse-keymap))) ;(define-key himml-mode-map "\C-c\C-'" 'himml-next-error) (define-key himml-mode-map "\C-c\C-n" 'himml-next-error) (define-key himml-mode-map "\C-c\C-p" 'himml-prev-error) (define-key himml-mode-map "\C-c\C-v" 'himml-mode-version) (define-key himml-mode-map "\C-c\C-u" 'himml-save-buffer-use-file) (define-key himml-mode-map "\C-c\C-s" 'himml-pop-to-shell) (define-key himml-mode-map "\C-c\C-r" 'himml-send-region) (define-key himml-mode-map "\C-c\C-e" 'himml-eval) (define-key himml-mode-map "\C-c\C-m" 'himml-region) (define-key himml-mode-map "\C-c\C-f" 'himml-run-on-file) (define-key himml-mode-map "\C-c\C-c" 'himml-send-function) (define-key himml-mode-map "\C-c\C-b" 'himml-send-buffer) (define-key himml-mode-map "\e|" 'himml-electric-pipe) (define-key himml-mode-map "\e\t" 'himml-back-to-outer-indent) (define-key himml-mode-map "\C-j" 'reindent-then-newline-and-indent) (define-key himml-mode-map "\177" 'backward-delete-char-untabify) (define-key himml-mode-map "\;" 'himml-electric-semi) (define-key himml-mode-map "\C-c\t" 'himml-indent-region) (define-key himml-mode-map "\t" 'himml-indent-line) (himml-create-mode-menu himml-mode-map nil) ) (defvar himml-mode-syntax-table nil "The syntax table used in himml-mode.") (if himml-mode-syntax-table () (setq himml-mode-syntax-table (make-syntax-table)) ;; Set everything to be "." (punctuation) except for [A-Za-z0-9], ;; which will default to "w" (word-constituent). (let ((i 0)) (while (< i ?0) (modify-syntax-entry i "." himml-mode-syntax-table) (setq i (1+ i))) (setq i (1+ ?9)) (while (< i ?A) (modify-syntax-entry i "." himml-mode-syntax-table) (setq i (1+ i))) (setq i (1+ ?Z)) (while (< i ?a) (modify-syntax-entry i "." himml-mode-syntax-table) (setq i (1+ i))) (setq i (1+ ?z)) (while (< i 128) (modify-syntax-entry i "." himml-mode-syntax-table) (setq i (1+ i)))) ;; Now we change the characters that are meaningful to us. (modify-syntax-entry ?\( "()1" himml-mode-syntax-table) (modify-syntax-entry ?\) ")(4" himml-mode-syntax-table) (modify-syntax-entry ?\[ "(]" himml-mode-syntax-table) (modify-syntax-entry ?\] ")[" himml-mode-syntax-table) (modify-syntax-entry ?{ "(}" himml-mode-syntax-table) (modify-syntax-entry ?} "){" himml-mode-syntax-table) (modify-syntax-entry ?\* ". 23" himml-mode-syntax-table) (modify-syntax-entry ?\" "\"" himml-mode-syntax-table) (modify-syntax-entry ? " " himml-mode-syntax-table) (modify-syntax-entry ?\t " " himml-mode-syntax-table) (modify-syntax-entry ?\n " " himml-mode-syntax-table) (modify-syntax-entry ?\f " " himml-mode-syntax-table) (modify-syntax-entry ?\' "w" himml-mode-syntax-table) (modify-syntax-entry ?\_ "w" himml-mode-syntax-table) (modify-syntax-entry ?| "w" himml-mode-syntax-table) (modify-syntax-entry ?\\ "\\" himml-mode-syntax-table)) (if himml-emacs19-p ; emacs 19: then this is comment-indent-function ; instead of comment-indent-hook (defun set-comment-hook () (make-local-variable 'comment-indent-function) (setq comment-indent-function 'himml-comment-indent)) (defun set-comment-hook () (make-local-variable 'comment-indent-hook) (setq comment-indent-hook 'himml-comment-indent))) (defun himml-mode () "Major mode for editing HimML code. Tab indents for HimML code. Comments are delimited with (* ... *). Paragraphs are separated by blank lines only. Delete converts tabs to spaces as it moves back. Default key bindings: ===================== TAB - Indent current line. C-c TAB - Indent region. LFD - Reindent line, newline and indent. ESC TAB - Back line out one indentation. ESC | - Insert a \"|\". Insert function name, \"=>\" etc. C-c RET - Insert a common used structure. C-c C-n - Find the next error. C-c C-p - Find previous error. C-c C-s - Pop to the himml window. C-c C-u - Save the buffer, and send a \"use file\". C-c C-r - Send region (point and mark) to himml. C-c C-f - Send a \"use file\" to himml. C-c C-c - Send function/region to himml. C-c C-b - Send whole buffer to himml. C-c C-v - Get the version of himml-mode. Variables controlling the indentation ===================================== himml-indent-level (default 4) The indentation of a block of code. himml-pipe-indent (default -2) Extra indentation of a line starting with \"|\". himml-case-indent (default nil) Determine the way to indent case-of expression. If t: case expr If nil: case expr of of exp1 => ... exp1 => ... | exp2 => ... | exp2 => ... The first seems to be the standard in NJ-SML. The second is the default. himml-nested-if-indent (default t) If set to t, nested if-then-else expression will have the same indentation as: if exp1 then exp2 else if exp3 then exp4 else if exp5 then exp6 else exp7 himml-type-of-indent (default t) How to indent `let' `struct' etc. If t: fun foo bar = let If nil: fun foo bar = let val p = 4 val p = 4 in in bar + p bar + p end end Will not have any effect if the starting keyword is first on the line. himml-electric-semi-mode (default nil) If t, a `\;' will reindent line, and perform a newline. himml-paren-lookback (default 2000) Determines how far back (in chars) the indentation algorithm should look for open parenthesis. High value means slow indentation algorithm. A value of 2000 (being the equivalent of 40-60 lines) should suffice most uses. (A value of nil, means do not look at all) Mode map ======== \\{himml-mode-map} See himml-shell for further information. Runs himml-mode-hook if non nil." (interactive) (kill-all-local-variables) (use-local-map himml-mode-map) (setq major-mode 'himml-mode) (setq mode-name "HimML") (define-abbrev-table 'himml-mode-abbrev-table ()) (setq local-abbrev-table himml-mode-abbrev-table) (set-syntax-table himml-mode-syntax-table) ;; A paragraph is seperated by blank lines or ^L only. (make-local-variable 'paragraph-start) (setq paragraph-start (concat "^[\t ]*$\\|" page-delimiter)) (make-local-variable 'paragraph-separate) (setq paragraph-separate paragraph-start) (make-local-variable 'indent-line-function) (setq indent-line-function 'himml-indent-line) (make-local-variable 'require-final-newline) ; Always put a new-line (setq require-final-newline t) ; in the end of file (make-local-variable 'comment-start) (setq comment-start "(* ") (make-local-variable 'comment-end) (setq comment-end " *)") (make-local-variable 'comment-column) ;; Start of comment in this column. Changed from origional 39. ;; I still don't know where I got the 39 from !! (891117 lbn) (setq comment-column 40) (make-local-variable 'comment-start-skip) ;; This matches a start of comment (I sure hope!) (setq comment-start-skip "(\\*+[ \t]?") (set-comment-hook) ;; ;; Adding these will fool the matching of parens. I really don't ;; know why. It would be nice to have comments treated as ;; white-space ;; ;; (make-local-variable 'parse-sexp-ignore-comments) ;; (setq parse-sexp-ignore-comments t) ;; (run-hooks 'himml-mode-hook)) ; Run the hook (defconst himml-pipe-matchers-reg "\\bcase\\b\\|\\bfn\\b\\|\\bfun\\b\\|\\bmemofun\\b\\|\\bmemofn\\b\\|\ \\bhandle\\b\ \\|\\bdatatype\\b\\|\\babstype\\b\\|\\band\\b\\|{\\|\\[\ \\|\\ball\\b\\|\\bexists\\b\\|\\bsome\\b\\|\\biterate\\b\ \\|\\bwith\\b" "The keywords a `|' can follow.") (defconst himml-openings (vector "\\blet\\b\\|\\blocal\\b\\|\\bsig\\b\\|\\bstruct\\b\ \\|\\ball\\b\\|\\bexists\\b\\|\\bsome\\b\\|\\biterate\\b" "{" "\\[" "\\bif\\b" "(") "The vector of opening regular expressions") (defconst himml-closings (vector "\\bend\\b" "}" "]" "\\belse\\b" ")") "The vector of closing regular expressions") (defconst himml-closing-quotes (vector "end" "}" "]" "else" "*)" ")") "The vector of texts corresponding to closing regular expressions") (defconst himml-in-regexp "in\\b\ [ \\t\\n]*\\($\\|\\B\\|\\<\\([^sl]\\|s$\\|s[^e]\\|se$\\|se[^t]\\|set\\B\ \\|l$\\|l[^i]\\|li$\\|li[^s]\\|lis$\\|lis[^t]\\|list\\B\\)\\)" "The regular expression matching 'in' but neither 'in set' nor 'in list'") (defun himml-electric-pipe () "Insert a \"|\". Depending on the context insert the name of function, a \"=>\" etc." (interactive) (let ((case-fold-search nil) ; Case sensitive ;(here (point)) (match (save-excursion (himml-find-matching-starter himml-pipe-matchers-reg) (point))) (tmp " => ") (case-or-handle-exp t)) (if (/= (save-excursion (beginning-of-line) (point)) (save-excursion (skip-chars-backward "\t ") (point))) (insert "\n")) (insert "|") (save-excursion (goto-char match) (cond ;; It was a function, insert the function name ((looking-at "fun\\b") (setq tmp (concat " " (buffer-substring (progn (forward-char 3) (himml-skip-chars-forward "\t\n ") (point)) (progn (forward-word 1) (point))) " ")) (setq case-or-handle-exp nil)) ((looking-at "with\\b") (setq tmp (concat " " (buffer-substring (progn (forward-char 4) (himml-skip-chars-forward "\t\n ") (point)) (progn (forward-word 1) (point))) " ")) (setq case-or-handle-exp nil)) ((looking-at "memofun\\b") (setq tmp (concat " " (buffer-substring (progn (forward-char 7) (himml-skip-chars-forward "\t\n ") (point)) (progn (forward-word 1) (point))) " ")) (setq case-or-handle-exp nil)) ;; It was a datatype, insert nothing ((looking-at "datatype\\b\\|abstype\\b\\|{\\|\\[\\|all\\b\\|exists\\b\\|some\\b\\|iterate\\b") (setq tmp " ") (setq case-or-handle-exp nil)) ;; If it is an and, then we have to see what is was ((looking-at "and\\b") (let (isfun) (save-excursion (condition-case () (progn (re-search-backward "datatype\\b\\|abstype\\b\\|fun\\b") (setq isfun (looking-at "fun\\b"))) (error (setq isfun nil)))) (if isfun (progn (setq tmp (concat " " (buffer-substring (progn (forward-char 3) (himml-skip-chars-forward "\t\n ") (point)) (progn (forward-word 1) (point))) " ")) (setq case-or-handle-exp nil)) (setq tmp " ") (setq case-or-handle-exp nil)))))) (insert tmp) (himml-indent-line) (back-to-indentation) (forward-char (1+ (length tmp))) (if case-or-handle-exp (forward-char -4)))) (defun himml-electric-semi () "Inserts a \;. If himml-electric-semi-mode is t, indent the current line, and newline." (interactive) (insert "\;") (if himml-electric-semi-mode (reindent-then-newline-and-indent))) (defun himml-mode-version () "Message the version of himml-mode." (interactive) (message himml-mode-version-string)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; SHORT CUTS (himml-region) ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defconst himml-region-alist '(("let") ("local") ("signature") ("structure") ("datatype") ("case") ("functor") ("abstype") ("abstraction")) "The list of regions to auto-insert.") (defun himml-region () "Interactive short-cut. Insert a common used structure in himml." (interactive) (let ((newline nil) ; Did we insert a newline (name (completing-read "Region to insert: (default let) " himml-region-alist nil t nil))) ;; default is "let" (if (string= name "") (setq name "let")) ;; Insert a newline if point is not at empty line (himml-indent-line) ; Indent the current line (if (save-excursion (back-to-indentation) (eolp)) () (setq newline t) (insert "\n")) (condition-case () (cond ((string= name "let") (himml-let)) ((string= name "local") (himml-local)) ((string= name "structure") (himml-structure)) ((string= name "signature") (himml-signature)) ((string= name "abstraction") (himml-abstraction)) ((string= name "functor") (himml-functor)) ((string= name "case") (himml-case)) ((string= name "abstype") (himml-abstype)) ((string= name "datatype") (himml-datatype))) (quit (if newline (progn (delete-char -1) (beep))))))) (defun himml-let () "Insert a `let in end'." (interactive) (himml-let-local "let")) (defun himml-local () "Insert a `local in end'." (interactive) (himml-let-local "local")) (defun himml-signature () "Insert a `signature ??? = sig end', prompting for name." (interactive) (himml-structure-signature "signature")) (defun himml-structure () "Insert a `structure ??? = struct end', prompting for name." (interactive) (himml-structure-signature "structure")) (defun himml-case () "Insert a case, prompting for case-expresion." (interactive) (let (indent (expr (read-string "Case expr: "))) (insert (concat "case " expr)) (himml-indent-line) (setq indent (current-indentation)) (end-of-line) (if himml-case-indent (progn (insert "\n") (indent-to (+ 2 indent)) (insert "of ")) (insert " of\n") (indent-to (+ indent himml-indent-level))) (save-excursion (insert " => ")))) (defun himml-let-local (starter) (let (indent) (insert starter) (himml-indent-line) (setq indent (current-indentation)) (end-of-line) (insert "\n") (indent-to (+ himml-indent-level indent)) (insert "\n") (indent-to indent) (insert "in\n") (indent-to (+ himml-indent-level indent)) (insert "\n") (indent-to indent) (insert "end") (previous-line 3) (end-of-line))) (defun himml-structure-signature (which) (let (indent (name (read-string (concat "Name of " which ": ")))) (insert (concat which " " name " =")) (himml-indent-line) (setq indent (current-indentation)) (end-of-line) (insert "\n") (indent-to (+ himml-indent-level indent)) (insert (if (string= which "signature") "sig\n" "struct\n")) (indent-to (+ (* 2 himml-indent-level) indent)) (insert "\n") (indent-to (+ himml-indent-level indent)) (insert "end") (previous-line 1) (end-of-line))) (defun himml-functor () "Insert a `functor ??? () : ??? = struct end', prompting for name and type." (let (indent (name (read-string "Name of functor: ")) (signame (read-string "Signature type of functor: "))) (insert (concat "functor " name " () : " signame " =")) (himml-indent-line) (setq indent (current-indentation)) (end-of-line) (insert "\n") (indent-to (+ himml-indent-level indent)) (insert "struct\n") (indent-to (+ (* 2 himml-indent-level) indent)) (insert "\n") (indent-to (+ himml-indent-level indent)) (insert "end") (previous-line 1) (end-of-line))) (defun himml-abstraction () "Insert a `abstraction ??? : ??? = struct end', prompting for name and type." (let (indent (name (read-string "Name of abstraction: ")) (signame (read-string "Signature type of abstraction: "))) (insert (concat "abstraction " name " : " signame " =")) (himml-indent-line) (setq indent (current-indentation)) (end-of-line) (insert "\n") (indent-to (+ himml-indent-level indent)) (insert "struct\n") (indent-to (+ (* 2 himml-indent-level) indent)) (insert "\n") (indent-to (+ himml-indent-level indent)) (insert "end") (previous-line 1) (end-of-line))) (defun himml-datatype () "Insert a `datatype ??? =', prompting for name." (let (indent (type (read-string (concat "Type of datatype (default none): "))) (name (read-string (concat "Name of datatype: ")))) (insert (concat "datatype " (if (string= type "") "" (concat type " ")) name " =")) (himml-indent-line) (setq indent (current-indentation)) (end-of-line) (insert "\n") (indent-to (+ himml-indent-level indent)))) (defun himml-abstype () "Insert an `abstype 'a ??? = with ... end'" (let (indent (typevar (read-string "Name of typevariable (default 'a): ")) (type (read-string "Name of abstype: "))) (if (string= typevar "") (setq typevar "'a")) (insert (concat "abstype " typevar " " type " =")) (himml-indent-line) (setq indent (current-indentation)) (insert "\n") (indent-to (+ himml-indent-level indent)) (insert "\n") (indent-to indent) (insert "with\n") (indent-to (+ himml-indent-level indent)) (insert "\n") (indent-to indent) (insert "end") (previous-line 3) (end-of-line))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; PARSING ERROR MESSAGES (NOTE: works only with HimML) ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; The reg-expression used when looking for errors. ;; An example of error message is: ;; Error: a.ml, line 2(3)-2(5) : can only apply functions ;; On the Mac, HimML uses error messages like: ;; File "a.ml"; Line 2!3:2!5 # can only apply functions ;; the file and line descriptors follow the MPW Shell conventions; ;; moreover there is no difference between errors and warnings. (defvar himml-error-regexp "\\(Error:\\|Warning:\\|[^\n;]*;in\\)[ \t]*\\([^,\n]+\\),[ ]*lines?[ ]*\\([0-9()-]+\\)" "Regular expression for matching error. If you change this beware of the second to fourth parenthesized expressions. himml-next-error uses these to get the filename, and the line and character offset.") (defvar himml-hilit-face (if (and (fboundp 'make-face) (fboundp 'set-face-background) (fboundp 'copy-face)) (progn (if (or (and (fboundp 'x-color-display-p) (x-color-display-p)) ; Lucid Emacs 19 (and (fboundp 'x-display-color-p) (x-display-color-p))) ; GNU Emacs 19 (progn (make-face 'himml-hilit-face) (set-face-background 'himml-hilit-face "lightblue")) (if (and (fboundp 'facep) (facep 'highlight)) (copy-face 'highlight 'himml-hilit-face) (copy-face 'bold 'himml-hilit-face))) 'himml-hilit-face) nil ;;otherwise, we cannot highlight ) "Face used to highlight regions of text when displaying errors through himml-display-error.") (defvar himml-hilit-extent nil "The current highlighted extent when displaying errors through himml-display-error.") (if (fboundp 'defalias) () (defun defalias (sym func) (fset sym func))) (if himml-emacs19-p ; emacs 19: then ; build a compatibility library with Lucid for highlighting ; Lucid's extents are mapped to GNU's overlays. (if (and (fboundp 'make-overlay) (fboundp 'delete-overlay) (fboundp 'overlay-buffer) (fboundp 'overlayp)) (progn (if (fboundp 'make-extent) () (defalias 'make-extent (symbol-function 'make-overlay))) (if (fboundp 'delete-extent) () (defalias 'delete-extent (symbol-function 'delete-overlay))) (if (fboundp 'set-extent-face) () (defun set-extent-face (extent face) (overlay-put extent 'face face))) (if (fboundp 'extent-buffer) () (defalias 'extent-buffer (symbol-function 'overlay-buffer))) (if (fboundp 'extentp) () (defalias 'extentp (symbol-function 'overlayp))) ) ) ) (defun himml-hilit-p () (and himml-hilit-face (fboundp 'set-extent-face) (fboundp 'delete-extent))) (defun himml-parse-error () ; parses susbtrings given as match-beginning/match-end pairs ; after recognition of himml-error-regexp, and returns ; (filename (line1 . pos1) . (line2 . pos2)) (let ((filename (buffer-substring (match-beginning 2) (match-end 2)) ) (positions (buffer-substring (match-beginning 3) (match-end 3)) ) line1 line2 (pos1 0) (pos2 0) ) (string-match "^\\([0-9]+\\)" positions) ;; should not fail (setq line1 (string-to-int (substring positions (match-beginning 1) (match-end 1)))) (setq line2 line1) (setq positions (substring positions (match-end 0))) (if (string-match "^(\\([0-9]+\\))" positions) (progn (setq pos1 (string-to-int (substring positions (match-beginning 1) (match-end 1)))) (setq positions (substring positions (match-end 0))) (setq pos2 pos1)) ) (if (string-match "^-\\([0-9]+\\)" positions) (progn (setq line2 (string-to-int (substring positions (match-beginning 1) (match-end 1)))) (setq positions (substring positions (match-end 0))) (setq pos2 0)) ) (if (string-match "^(\\([0-9]+\\))" positions) (progn (setq pos2 (string-to-int (substring positions (match-beginning 1) (match-end 1)))) )) (cons filename (cons (cons line1 pos1) (cons line2 pos2))) ) ) (defun himml-delete-extent () (if (himml-hilit-p) (and (extentp himml-hilit-extent) (buffer-name (extent-buffer himml-hilit-extent)) (progn (delete-extent himml-hilit-extent) (setq himml-hilit-extent nil))) (setq overlay-arrow-string nil))) (defun himml-display-error-1 (file line1 pos1 line2 pos2 msg) (let* ((buffer (find-file-noselect file)) (window (display-buffer buffer t)) start end) (save-excursion (set-buffer buffer) (save-restriction (widen) (goto-line line1) (beginning-of-line) (if (himml-hilit-p) () ;; only display overlay arrow if we cannot hilite ;; hiliting is better visually; moreover, the overlay arrow ;; does not appear under Lucid Emacs 19.4.3 (at least) (setq overlay-arrow-string "=>") (or overlay-arrow-position (setq overlay-arrow-position (make-marker))) (set-marker overlay-arrow-position (point) (current-buffer)) ) (forward-char pos1) (setq start (point)) (save-excursion (goto-line line2) (forward-char pos2) (setq end (point))) (if (himml-hilit-p) (progn ;; delete previous extent if it is an extent and its buffer is still alive (himml-delete-extent) (setq himml-hilit-extent (make-extent start end)) (set-extent-face himml-hilit-extent himml-hilit-face)) ) ) (cond ((or (< start (point-min)) (> end (point-max))) (widen) (goto-char start))) (if msg (let* ((buf (get-buffer-create himml-message-buffer-name)) (win (get-buffer-window buf))) (if (null win) (setq win (split-window window (- (window-height) himml-message-buffer-height))) ) (set-window-buffer win buf) (set-buffer buf) (erase-buffer) (insert msg) ) (let ((buf (get-buffer himml-message-buffer-name))) (if buf (let ((win (get-buffer-window buf))) (if win (delete-window win))))) ) ) (set-window-point window start) )) (defun himml-display-error (position) (let* ((pos (car position)) (msg (cdr position)) (file (car pos)) (pos (cdr pos)) (line1 (car (car pos))) (pos1 (cdr (car pos))) (pos (cdr pos)) (line2 (car pos)) (pos2 (cdr pos))) (himml-display-error-1 file line1 pos1 line2 pos2 msg))) (defun himml-get-msg () (if (looking-at " :") ;; this is after an error or a warning (progn (skip-chars-forward "[ :\t\n]+") (buffer-substring (point) (progn (re-search-forward (concat "\\(" himml-shell-prompt-pattern "\\)\\|^Error:\\|^Warning:") (point-max) 'himml-next-error 1) (beginning-of-line) (point))) ) (forward-line) nil)) (defun himml-find-next-error () (condition-case () (progn (beginning-of-line) (re-search-forward himml-error-regexp) ; Search for error (save-excursion (cons (himml-parse-error) (himml-get-msg)))) (error ()))) (defun himml-find-prev-error () (condition-case () (progn (re-search-backward himml-error-regexp) ; Search for error (cons (himml-parse-error) (save-excursion (re-search-forward himml-error-regexp) (himml-get-msg)))) (error ()))) (defun himml-next-error (arg) "Find the next error under a HimML toplevel by parsing the current buffer. A non-nil argument (prefix arg, if interactive) means reparse the error messages from the last erroneous toplevel command down and start at the first error." (interactive "P") (let ((case-fold-search nil) position) (if arg (while (and (re-search-backward himml-shell-prompt-pattern (point-min) 'himml-next-error 1) (let ((p (point))) (setq position (himml-find-next-error)) (if position nil (progn (goto-char p) t))) ) ) (beginning-of-line) (if (looking-at himml-error-regexp) ;;skip current error if we are looking at one (forward-line)) (setq position (himml-find-next-error)) ) (if position (himml-display-error position) (himml-delete-extent) (message "No more errors") ; Or have we passed all errors (beep))) ) (defun himml-prev-error (arg) "Find the previous error under a HimML toplevel by parsing the current buffer. A non-nil argument (prefix arg, if interactive) means reparse the error messages from the bottom of the buffer up and start at the last error." (interactive "P") (let ((case-fold-search nil) position) (if arg (goto-char (point-max)) ) (setq position (himml-find-prev-error)) (if position (himml-display-error position) (message "No more errors") ; Or have we passed all errors (beep))) ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; HIGHLIGHTING ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (if himml-emacs20-p () (if himml-emacs19-p ; emacs 19 (progn (require 'hilit19) (let ((comments '(("(\\*" "\\*)" comment))) (strings '((hilit-string-find ?' string))) (preprocessor '(("^#[ \t]*\\(undef\\|define\\).*$" "[^\\]$" define) ("^#.*$" nil include)))) (hilit-set-mode-patterns 'himml-mode (append comments strings preprocessor '( ;; declarations ("\\b\\(fun\\|memofun\\|with\\)\\b[^\n=]*[\n=]" nil defun) ("\\b\\(extern\\|val\\|and\\|exception\\|type\\|datatype\\|abstype\\|withtype\\)\\b[^\n=]*[\n=]" nil decl) ;; key words ("[^_]\\(\\<\\(\\|if\\|then\\|else\\|fn\\|memofn\\|case\\|of\\|while\\|do\\|all\\|exists\\|some\\|iterate\\|let\\|end\\|handle\\)\\>\\|=>\\|{}\\|{\\|}\\||\\[\\]|\\||\\[\\|\\]|\\|\\[\\]\\|\\[\\|\\]\\||\\)[^_]" 1 keyword) )))))) ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; INDENTATION ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun himml-indent-region (begin end) "Indent region of himml code." (interactive "r") (message "Indenting region...") (save-excursion (goto-char end) (setq end (point-marker)) (goto-char begin) (while (< (point) end) (skip-chars-forward "\t\n ") (himml-indent-line) (end-of-line)) (move-marker end nil)) (message "Indenting region... done")) (defun himml-indent-line1 () (let ((indent (himml-calculate-indentation))) (if (/= (current-indentation) indent) (save-excursion ;; Added 890601 (point now stays) (let ((beg (progn (beginning-of-line) (point)))) (back-to-indentation) (delete-region beg (point)) (indent-to indent)))) ;; If point is before indentation, move point to indentation (if (< (current-column) (current-indentation)) (back-to-indentation)))) (defun himml-indent-line () "Indent current line of himml code." (interactive) (if (eq major-mode 'himml-shell) (if (save-excursion (re-search-backward (concat himml-shell-prompt-pattern " ?") (point-min) t)) (save-restriction (narrow-to-region (match-end 0) (point-max)) (himml-indent-line1)) (himml-indent-line1)) (himml-indent-line1))) (defun himml-back-to-outer-indent () "Unindents to the next outer level of indentation." (interactive) (save-excursion (back-to-indentation) (let ((start-column (current-column)) (indent (current-column))) (if (> start-column 0) (progn (save-excursion (while (>= indent start-column) (if (re-search-backward "^[^\n]" nil t) (setq indent (current-indentation)) (setq indent 0)))) (backward-delete-char-untabify (- start-column indent))))))) (defconst himml-indent-starters-reg (concat "abstraction\\b\\|abstype\\b\\|and\\b\\|case\\b\\|datatype\\b\ \\|else\\b\\|fun\\b\\|memofun\\b\\|fn\\b\\|memofn\\b\\|functor\\b\\|if\\b\\|sharing\\b\\|in\\b\\|sub[ \t]map\\b\ \\|infix\\b\\|infixr\\b\\|let\\b\\|local\\b\ \\|nonfix\\b\\|open\\b\\|raise\\b\\|sig\\b\\|signature\\b\ \\|struct\\b\\|structure\\b\\|then\\b\\|\\btype\\b\\|val\\b\ \\|while\\b\\|with\\b\\|withtype\\b\\|extern\\b\\|such[ \t]that\\b\ \\|[{[(]\\|\\ball\\b\\|\\bsome\\b\\|\\bexists\\b\\|\\biterate\\b") "The indentation starters. The next line, after one starting with one of these, will be indented.") (defconst himml-starters-reg "\\babstraction\\b\\|\\babstype\\b\\|\\bdatatype\\b\ \\|\\bexception\\b\\|\\bfun\\b\\|\\bmemofun\\b\\|\ \\bfunctor\\b\\|\\blocal\\b\ \\|\\binfix\\b\\|\\binfixr\\b\\|\\bsharing\\b\ \\|\\bnonfix\\b\\|\\bopen\\b\\|\\bsignature\\b\\|\\bstructure\\b\ \\|\\btype\\b\\|\\bval\\b\\|\\bwithtype\\b\\|\\bwith\\b\\|\\bextern\\b\ \\|[{[(]\\|\\ball\\b\\|\\bsome\\b\\|\\bexists\\b\\|\\biterate\\b" "The starters of new expressions.") (defconst himml-decl-starters-reg "\\babstraction\\b\\|\\babstype\\b\\|\\bdatatype\\b\ \\|\\bexception\\b\\|\\bfun\\b\\|\\bmemofun\\b\\|\ \\bfunctor\\b\\|\\blocal\\b\ \\|\\binfix\\b\\|\\binfixr\\b\\|\\bsharing\\b\ \\|\\bnonfix\\b\\|\\bopen\\b\\|\\bsignature\\b\\|\\bstructure\\b\ \\|\\btype\\b\\|\\bval\\b\\|\\bwithtype\\b\\|\\bwith\\b\\|\\bextern\\b" "The starters of new declarations.") (defconst himml-end-starters-reg "\\blet\\b\\|\\blocal\\b\\|\\bsig\\b\\|\\bstruct\\b\\|\\bwith\\b\ \\|\\ball\\b\\|\\bexists\\b\\|\\bsome\\b\\|\\biterate\\b" "Matching reg-expression for the \"end\" keyword.") (defconst himml-starters-indent-after "let\\b\\|local\\b\\|struct\\b\\|in\\b\\|sig\\b\\|[{[(]" "Indent after these.") (defconst himml-starters-for-pipe "\\bfun\\b\\|\\bfn\\b\\|\\bmemofun\\b\\|\\bmemofn\\b\\|\\band\\b\ \\|\\bhandle\\b\\|\\bcase\\b\\|\\bdatatype\\b\\|\\bwith\\b\ \\|{\\|\\[\\|\\ball\\b\\|\\bexists\\b\\|\\bsome\\b\\|\\biterate\\b" "Matching reg-expression for the | separator.") (defconst himml-pipe-regexp "|\\($\\|[^[]\\)" "Regexp matching the pipe |, but not the open record delimiter |[.") (defun himml-looking-at-match (prefix) (and (looking-at prefix) (save-excursion (goto-char (match-end 0)) (let ((start (point)) (matchp t)) (while (and matchp (not (looking-at "[ \t]*=>"))) (setq matchp (not (or (looking-at "[ \t]*=") (himml-forward-sexp) (eobp))))) (and matchp (progn (goto-char start) (and (himml-find-matching-starter himml-starters-for-pipe) (looking-at "fn\\b\\|memofn\\|handle\\b\\|case\\b\\|datatype\\b") (point) ))) )) )) (defun himml-indentation-at-starter (offset) (cond ((looking-at "fun\\b") (+ (current-column) 4)) ((looking-at "memofun\\b") (+ (current-column) 8)) ((looking-at "fn\\b") (+ (current-column) 3)) ((looking-at "memofn\\b") (+ (current-column) 7)) ((looking-at "and\\b") (+ (current-column) 4)) ((looking-at "handle\\b") (+ (current-column) 7)) ((looking-at "with") (+ (current-column) 5)) ((looking-at "datatype") (+ (current-column) 9)) ((looking-at "[[{]\\|some\\b\\|exists\\b\\|all\\|iterate\\b") (+ (current-column) 2)) (t (+ (current-column) offset)))) (defun himml-calculate-indentation () (save-excursion (let ((case-fold-search nil) match) (beginning-of-line) (if (bobp) ; Beginning of buffer 0 ; Indentation = 0 (back-to-indentation) (if (himml-inside-comment-or-string-p) (himml-get-paren-indent) (cond ;; Indentation for comments alone on a line, matches the ;; proper indentation of the next line. Search only for the ;; next "*)", not for the matching. ((looking-at "(\\*") (if (not (search-forward "*)" nil t)) (error "Comment not ended.")) (end-of-line) (skip-chars-forward "\n\t ") ;; If we are at eob, just indent 0 (if (eobp) 0 (himml-calculate-indentation))) ;; Continued string ? (Added 890113 lbn) ((looking-at "\\\\") (save-excursion (if (save-excursion (previous-line 1) (beginning-of-line) (looking-at "[\t ]*\\\\")) (progn (previous-line 1) (current-indentation)) (if (re-search-backward "[^\\\\]\"" nil t) (1+ (current-indentation)) 0)))) ;; Are we looking at an alternative (| pattern =>)? ((setq match (himml-looking-at-match himml-pipe-regexp)) (save-excursion (goto-char match) (cond ((looking-at "fn\\b") (1+ (current-column))) ((looking-at "memofn\\b\\|handle\\b") (+ 5 (current-column))) ((looking-at "case\\b") (+ 4 (current-column) himml-pipe-indent)) (t (+ (current-column) himml-pipe-indent))))) ;; Are we looking at the first alternative of a case expression? ((and (save-excursion (himml-backward-sexp) (looking-at "of\\b")) (setq match (himml-looking-at-match ""))) (save-excursion (goto-char match) (+ 4 (current-column)))) ((looking-at "and\\b") (if (himml-find-matching-starter himml-starters-reg) (current-column) 0)) ((looking-at himml-in-regexp) ; Match the beginning let/local (himml-find-match-indent "in" 0 nil "\\blocal\\b\\|\\blet\\b")) ((looking-at "end\\b") ; Match the beginning (himml-find-match-indent "end" 0 nil)) ((and himml-nested-if-indent (looking-at "else\\b") (setq match (save-excursion (and (himml-re-search-backward "\\bif\\b\\|\\belse\\b") (back-to-indentation) (looking-at "\\bif\\b\\|\\belse[\t ]*if\\b") (current-indentation))))) (or match (himml-find-match-indent "else" 3 t))) ((looking-at "else\\b") ; Match the if (himml-find-match-indent "else" 3 t)) ((looking-at "then\\b") ; Match the if or else if + extra indentation (+ (or (and himml-nested-if-indent (save-excursion (and (himml-re-search-backward "\\bif\\b\\|\\belse\\b") (back-to-indentation) (looking-at "\\bif\\b\\|\\belse[\t ]*if\\b") (current-indentation)))) (himml-find-match-indent "then" 3 t)) himml-indent-level)) ((and himml-case-indent (looking-at "of\\b")) (himml-re-search-backward "\\bcase\\b") (+ (current-column) 2)) ((looking-at "such[ \t]that\\b") (while (and (not (bobp)) (himml-find-matching-starter himml-pipe-regexp) (himml-looking-at-match himml-pipe-regexp)) ) (+ (if himml-type-of-indent (current-column) (current-indentation)) himml-indent-level)) ((looking-at himml-decl-starters-reg) (let ((start (point))) (if (himml-find-matching-starter himml-starters-reg) (if (and (looking-at himml-starters-indent-after) (/= start (point))) (+ (if himml-type-of-indent (current-column) (if (progn (back-to-indentation) (looking-at "|\\($\\|[^[]\\)")) (- (current-indentation) himml-pipe-indent) (current-indentation))) himml-indent-level) (let ((c (current-column))) (back-to-indentation) (if (looking-at "extern\\b") (current-column) c))) 0))) (t (let ((indent (himml-get-indent))) (cond ((looking-at himml-pipe-regexp) ;; Lets see if it is the follower of a function definition (if (himml-find-matching-starter himml-starters-for-pipe) (+ (himml-indentation-at-starter 0) himml-pipe-indent) (+ indent himml-pipe-indent))) (t (if himml-paren-lookback ; Look for open parenthesis ? (max indent (himml-get-paren-indent)) indent))))))))))) (defun himml-get-indent () (save-excursion (let ((case-fold-search nil)) (beginning-of-line) (himml-skip-chars-backward "\t\n; ") (if (looking-at ";") (himml-backward-sexp)) (cond ((save-excursion (himml-backward-sexp) (looking-at "end\\b")) ;(- (current-indentation) himml-indent-level) (current-indentation) ) ;((save-excursion (back-to-indentation) ; (looking-at himml-pipe-regexp)) ;(- (current-indentation) himml-pipe-indent)) (t (while (and (/= (current-column) (current-indentation)) (if (himml-backward-sexp) (not (looking-at himml-indent-starters-reg)) (not (looking-at himml-decl-starters-reg))))) ;(himml-skip-chars-forward "\t |") (let ((indent (current-indentation))) (himml-skip-chars-forward "\t ") (cond ;; Started val/fun/structure... ((looking-at "||") (+ indent 3)) ((looking-at "|") (+ indent 2)) ((looking-at "[([{]") indent) ((looking-at himml-indent-starters-reg) (himml-indentation-at-starter himml-indent-level)) ;; else keep the same indentation as previous line (t indent)))))))) (defun himml-get-paren-indent () (save-excursion (let ((levelpar 0) ; Level of "()" (levelcurl 0) ; Level of "{}" (levelsqr 0) ; Level of "[]" (backpoint (max (- (point) himml-paren-lookback) (point-min)))) (catch 'loop (while (and (/= levelpar 1) (/= levelsqr 1) (/= levelcurl 1)) (if (re-search-backward "[][{}()]" backpoint t) (if (not (himml-inside-comment-or-string-p)) (cond ((looking-at "(") (setq levelpar (1+ levelpar))) ((looking-at ")") (setq levelpar (1- levelpar))) ((looking-at "\\[") (setq levelsqr (1+ levelsqr))) ((looking-at "\\]") (setq levelsqr (1- levelsqr))) ((looking-at "{") (setq levelcurl (1+ levelcurl))) ((looking-at "}") (setq levelcurl (1- levelcurl))))) (throw 'loop 0))) ; Exit with value 0 (save-excursion (forward-char 1) (if (looking-at himml-indent-starters-reg) (himml-indentation-at-starter himml-indent-level) (current-column))))))) ;; This is too slow ;; ;; (defun himml-inside-comment-or-string-p () ;; (let ((state (parse-partial-sexp (point-min) (point)))) ;; (or (nth 4 state) (nth 3 state)))) (defun himml-inside-comment-or-string-p () (let ((start (point))) (if (save-excursion (condition-case () (progn (search-backward "(*") (search-forward "*)") (forward-char -1) ; A "*)" is not inside the comment (> (point) start)) (error nil))) t (let ((numb 0)) (save-excursion (save-restriction (narrow-to-region (progn (beginning-of-line) (point)) start) (condition-case () (while t (search-forward "\"") (setq numb (1+ numb))) (error (if (and (not (zerop numb)) (not (zerop (% numb 2)))) t nil))))))))) (defun himml-skip-block () (let ((case-fold-search nil)) (himml-backward-sexp) (if (looking-at "end\\b") (progn (goto-char (himml-find-match-backward "end" 0)) (himml-skip-chars-backward "\n\t ")) ;; Here we will need to skip backward past if-then-else ;; and case-of expression. Please - tell me how !! ))) (defun himml-find-match-backward (unquoted-this this-index &optional start) (save-excursion (let ((case-fold-search nil) (levels (make-vector (length himml-openings) 0)) (goal-levels (make-vector (length himml-openings) 0)) (pattern (concat (himml-make-pattern himml-openings) "\\|" (himml-make-pattern himml-closings)))) (aset levels this-index 1) (if start (goto-char start)) (while (not (equal levels goal-levels)) (if (himml-re-search-backward pattern) (let ((i (himml-indexed-looking-at himml-openings))) (if i (aset levels i (1- (aref levels i))) (let ((i (himml-indexed-looking-at himml-closings))) (aset levels i (1+ (aref levels i)))))) ;; The right match couldn't be found (error (concat "Unbalanced: " unquoted-this)))) (point)))) (defun himml-make-pattern (l) (if (zerop (length l)) "" (concat (aref l 0) (himml-make-pattern-1 l 1 (length l))))) (defun himml-make-pattern-1 (l i n) (if (< i n) (concat "\\|" (aref l i) (himml-make-pattern-1 l (1+ i) n)) "")) (defun himml-indexed-looking-at (l) (himml-indexed-looking-at-1 l 0 (length l))) (defun himml-indexed-looking-at-1 (l i n) (if (< i n) (if (looking-at (aref l i)) i (himml-indexed-looking-at-1 l (1+ i) n)) nil)) (defun himml-find-match-indent (unquoted-this this-index indented &optional check) (save-excursion (goto-char (himml-find-match-backward unquoted-this this-index)) (if (and check (not (looking-at check))) (error "Unbalanced: " unquoted-this)) (if (or himml-type-of-indent indented) (current-column) (if (progn (back-to-indentation) (looking-at "|\\($\\|[^[]\\)")) (- (current-indentation) himml-pipe-indent) (current-indentation))))) (defun himml-find-matching-starter (regexp) (let ((case-fold-search nil) (new-regexp (concat regexp "\\|" (himml-make-pattern himml-closings)))) (himml-re-search-backward-1 new-regexp))) (defun himml-re-search-backward-1 (regexp) (let ((cont t) (found t)) (while cont (if (himml-re-search-backward regexp) (let ((i (himml-indexed-looking-at himml-closings))) (if i (goto-char (himml-find-match-backward (aref himml-closing-quotes i) i)) (setq cont nil))) (setq cont nil found nil))) found)) (defun himml-point-inside-let-etc () (let ((case-fold-search nil) (last nil) (loop t) (found t) (start (point))) (save-excursion (while loop (condition-case () (progn (re-search-forward "\\bend\\b") (while (himml-inside-comment-or-string-p) (re-search-forward "\\bend\\b")) (forward-char -3) (setq last (himml-find-match-backward "end" 0 last)) (if (< last start) (setq loop nil) (forward-char 3))) (error (progn (setq found nil) (setq loop nil))))) (if found last 0)))) (defun himml-re-search-backward (regexpr) (let ((case-fold-search nil) (found t)) (if (re-search-backward regexpr nil t) (progn (condition-case () (while (himml-inside-comment-or-string-p) (re-search-backward regexpr)) (error (setq found nil))) found) nil))) (defun himml-up-list () (save-excursion (condition-case () (progn (up-list 1) (point)) (error 0)))) (defun himml-backward-sexp () (condition-case () (progn (let ((start (point))) (backward-sexp 1) (while (and (/= start (point)) (looking-at "(\\*")) (setq start (point)) (backward-sexp 1)))) (error (forward-char -1) t))) (defun himml-forward-sexp () (condition-case () (progn (let ((start (point))) (forward-sexp 1) (while (and (>= (point) (- start 2)) (save-excursion (backward-char 2) (looking-at "\\*)"))) (setq start (point)) (forward-sexp 1)))) (error t))) (defun himml-comment-indent () (if (looking-at "^(\\*") ; Existing comment at beginning 0 ; of line stays there. (save-excursion (skip-chars-backward " \t") (max (1+ (current-column)) ; Else indent at comment column comment-column)))) ; except leave at least one space. (defun himml-skip-chars-forward (chars) (skip-chars-forward chars) (if (looking-at "(\\*") (progn (forward-sexp 1) (himml-skip-chars-forward chars)))) (defun himml-skip-chars-backward (chars) (skip-chars-backward chars) (if (save-excursion (backward-char 2) (looking-at "\\*)")) (progn (backward-sexp 1) (himml-skip-chars-backward chars)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; INFERIOR SHELL ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defvar himml-shell-working-dir "" "The working directory of himml-shell") (defvar himml-process-name nil "The name of the HimML process") (defvar himml-shell-map nil "The mode map for himml-shell.") (defun himml-startup-ready () (save-excursion (goto-char (point-min)) (re-search-forward himml-shell-prompt-pattern nil t))) (require 'shell) (if (fboundp 'make-comint) () (defalias 'make-comint (symbol-function 'make-shell))) (if (fboundp 'copy-keymap) () (defalias 'copy-keymap (symbol-function 'copy-sequence))) (if himml-emacs19-p (defun himml-cd-command (dir) (format "cd %S" (expand-file-name dir))) (defun himml-cd-command (dir) (concat "cd " (prin1-to-string (expand-file-name dir))))) (defun himml-shell (&optional dir) "Inferior shell invoking HimML. Like the shell mode with the additional command: \\[himml-run-on-file]\t Runs himml on the file. \\{himml-shell-map} Variables controlling the mode: himml-prog-name (default \\[himml-prog-name\\]) The string used to invoke the himml program. himml-prog-name-ask-p (default \\[himml-prog-name-ask-p\\]) If t, you will be asked which program to run when the inferior shell starts up. himml-use-right-delim (default \\[himml-use-right-delim\\]) himml-use-left-delim (default \\[himml-use-left-delim\\]) The left and right delimiter used by your version of himml, for \"use file-name\". himml-shell-prompt-pattern (default \\[himml-shell-prompt-pattern\\]) The prompt pattern. himml-tmp-template (default \\[himml-tmp-template\\]) Template for the temporary files, created when a region is send to the inferior process running himml (by himml-simulate-send-region). `cd' commands given to the HimML process are watched by Emacs to keep this buffer's default directory the same as the shell's default directory. While directory tracking is enabled, the shell's working directory is displayed by \\[list-buffers] or \\[mouse-buffer-menu] in the `File' field. \\[himml-dirs] queries the shell and resyncs Emacs' idea of what the current directory stack is. \\[himml-dirtrack-toggle] turns directory tracking on and off. Runs himml-shell-hook if not nil." (interactive "DHimML in directory: ") (if (and himml-process-name (eq (process-status himml-process-name) 'run)) (if (or (null dir) (string= dir default-directory)) () (himml-eval (himml-cd-command dir))) (message "Starting HimML...") ; start up a new process (save-excursion ; Process is not running (and himml-prog-name-ask-p (setq himml-prog-name (read-file-name (concat "HimML (default " himml-prog-name "): ") (file-name-directory (buffer-file-name)) himml-prog-name))) (setq himml-shell-working-dir default-directory) (if himml-process-name () (setq himml-process-name (concat "" (substring himml-prog-name (string-match "[^/]*$" himml-prog-name) (string-match "$" himml-prog-name))))) (set-buffer (apply (function make-comint) himml-process-name (if (= (string-to-char himml-prog-name) ?~) (expand-file-name himml-prog-name) himml-prog-name) nil "-pwd-prompt" "|%s|%s" (if dir (list "-init" (himml-cd-command dir)) nil))) (erase-buffer) ; Erase the buffer if a previous (if himml-shell-map ; process died in there () (setq himml-shell-map (copy-keymap shell-mode-map)) (define-key himml-shell-map "\C-c\C-f" 'himml-run-on-file) (define-key himml-shell-map "\C-c\C-e" 'himml-eval) (define-key himml-shell-map "\C-c\C-r" 'himml-send-region) (define-key himml-shell-map "\C-c\C-p" 'himml-prev-error) (define-key himml-shell-map "\C-c\C-n" 'himml-next-error) (define-key himml-shell-map "\C-c\C-m" 'himml-region) (define-key himml-shell-map "\e|" 'himml-electric-pipe) (define-key himml-shell-map "\e\t" 'himml-back-to-outer-indent) (define-key himml-shell-map "\C-j" 'reindent-then-newline-and-indent) (define-key himml-shell-map "\177" 'backward-delete-char-untabify) (define-key himml-shell-map "\;" 'himml-electric-semi) (define-key himml-shell-map "\t" 'himml-indent-line) (himml-create-mode-menu himml-shell-map t)) (use-local-map himml-shell-map) (make-local-variable 'shell-prompt-pattern) (setq shell-prompt-pattern himml-shell-prompt-pattern) (make-local-variable 'comint-prompt-regexp) (setq comint-prompt-regexp himml-shell-prompt-pattern) (make-local-variable 'list-buffers-directory) (setq list-buffers-directory (expand-file-name default-directory)) (setq major-mode 'himml-shell) (setq mode-name "HimML-shell") (set-process-filter (get-process himml-process-name) 'himml-startup-filter) (run-hooks 'himml-shell-hook)) )) (defun himml-spy-cd (str) (if (string-match "|\\([^|]*\\)|" str) (let* ((start (match-beginning 0)) (end (match-end 0)) (wd (substring str (match-beginning 1) (match-end 1))) (newstr (concat (substring str 0 start) (substring str end)))) (if (string= himml-shell-working-dir wd) () (setq himml-shell-working-dir wd) (save-excursion (set-buffer (process-buffer (get-process himml-process-name))) (cd wd) (setq list-buffers-directory (file-name-as-directory (expand-file-name wd))) (message "HimML directory: %s" wd)) ) newstr) str)) (defun himml-startup-filter (proc str) ; (save-excursion ; (set-buffer "*scratch*") ; (insert "``" str "''")) (let ((cur (selected-window)) (pop-up-windows t) (process (concat "*" himml-process-name "*"))) (pop-to-buffer process) (goto-char (point-max)) (insert (himml-spy-cd str)) (if (himml-startup-ready) (progn (message "Starting HimML... done.") (set-process-filter (get-process himml-process-name) 'himml-process-filter)) ) (set-marker (process-mark proc) (point-max)) (select-window cur))) (defun himml-process-filter (proc str) ; (save-excursion ; (set-buffer "*scratch*") ; (insert "``" str "''")) (let ((cur (selected-window)) (pop-up-windows t) (process (concat "*" himml-process-name "*"))) (pop-to-buffer process) (goto-char (point-max)) (insert (himml-spy-cd str)) (set-marker (process-mark proc) (point-max)) (select-window cur))) (defun himml-pop-to-shell () "Pop to the buffer running himml." (interactive) (himml-shell) (pop-to-buffer (concat "*" himml-process-name "*"))) (defun himml-run-on-file (file) "Send a use FILE to the inferior shell running himml." (interactive "FUse file: ") (himml-shell) (setq file (expand-file-name file)) (if himml-strip-path (if (string= (substring file 0 (string-match "[^/]*$" file)) himml-shell-working-dir) (setq file (substring file (string-match "[^/]*$" file) (string-match "$" file))))) (save-some-buffers) ;(himml-skip-errors) (send-string himml-process-name (concat "use " himml-use-left-delim file himml-use-right-delim ";\n"))) (defun himml-save-buffer-use-file () "Save the buffer, and send a `use file' to the inferior shell running himml." (interactive) (let (file) (if (setq file (buffer-file-name)) ; Is the buffer associated (progn ; with file ? (save-buffer) (himml-shell) ;(himml-skip-errors) (if himml-strip-path (if (string= (substring file 0 (string-match "[^/]*$" file)) himml-shell-working-dir) (setq file (substring file (string-match "[^/]*$" file) (string-match "$" file))))) (message (concat "use " himml-use-left-delim file himml-use-right-delim)) (send-string himml-process-name (concat "use " himml-use-left-delim file himml-use-right-delim ";\n"))) (error "Buffer not associated with file.")))) (defvar himml-tmp-files-list nil "List of all temporary files created by himml-simulate-send-region. Each element in the list is a list with the format: \n (tmp-filename file-name start-line)") (defvar himml-simulate-send-region-called-p nil "Has himml-simulate-send-region been called previously.") (defvar himml-old-kill-emacs-hook nil "Old value of kill-emacs-hook") (defconst himml-tmp-bug "") (defun himml-simulate-send-region (point1 point2) "Simulate send region. As send-region only can handle what ever the system sets as the default, we have to make a temporary file. Updates the list of temporary files (himml-tmp-files-list)." (let ((file (expand-file-name (make-temp-name (concat himml-tmp-template himml-tmp-bug))))) ;; Remove temporary files when we leave emacs (if (not himml-simulate-send-region-called-p) (progn (setq himml-old-kill-emacs-hook kill-emacs-hook) (setq kill-emacs-hook 'himml-remove-tmp-files) (setq himml-simulate-send-region-called-p t))) ;; As make-temp-name can only make 26 unique file names with the ;; same template (bug in Un*x function mktemp), we add a new ;; letter to himml-tmp-template. (if (zerop (% (1+ (length himml-tmp-files-list)) 25)) (setq himml-tmp-bug (concat himml-tmp-bug "A"))) (save-excursion (goto-char point1) (setq himml-tmp-files-list (cons (list file (buffer-file-name) (save-excursion ; Calculate line no. (beginning-of-line) (1+ (count-lines 1 (point))))) himml-tmp-files-list))) (write-region point1 point2 file nil 'dummy) (himml-shell) (message "Using temporary file: %s" file) (send-string himml-process-name ;; string to send: use file; (concat "use " himml-use-left-delim file himml-use-right-delim ";\n")))) (defun himml-remove-tmp-files () "Remove the temporary files, created by himml-simulate-send-region, if they still exist. Only files recorded in himml-tmp-files-list are removed. This function is put into kill-emacs-hook if any temporary files are used." (message "Removing temporary files created by himml-mode...") (while himml-tmp-files-list (condition-case () (delete-file (car (car himml-tmp-files-list))) (error ())) (setq himml-tmp-files-list (cdr himml-tmp-files-list))) (message "Removing temporary files created by himml-mode... done.") (run-hooks 'himml-old-kill-emacs-hook)) (defun himml-send-region () "Send region to inferior shell running himml." (interactive) (himml-shell) ;(himml-skip-errors) (let (start end) (save-excursion (setq end (point)) (exchange-point-and-mark) (setq start (point))) (himml-simulate-send-region start end))) (defun himml-eval (cmd) (interactive "sHimML: ") (himml-shell) ;(himml-skip-errors) (let* ((s (concat cmd ";\n")) (proc (get-process himml-process-name)) (buf (process-buffer proc))) (save-excursion (set-buffer buf) (goto-char (point-max)) (insert s)) (send-string himml-process-name s))) (defun himml-send-function () "Does *not* send the function, but the paragraph, to inferior shell running himml (sorry)." (interactive) (himml-shell) ;(himml-skip-errors) (let (start end) (save-excursion (condition-case () (progn (backward-paragraph) (setq start (point))) (error (setq start (point-min)))) (condition-case () (progn (forward-paragraph) (setq end (point))) (error (setq end (point-max))))) (himml-simulate-send-region start end))) (defun himml-send-buffer () "Send the buffer, to inferior shell running himml." (interactive) (himml-shell) ;(himml-skip-errors) (himml-simulate-send-region (point-min) (point-max))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; END OF HimML-MODE ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;