; Modula-3 editing support package
; Last edited on 2008-02-07 18:14:36 by stolfi
; Created by Jorge Stolfi on 91-12-05
; Based on modula2.el by Mick Jordan et al.

; TO DO:
;   C-a to logical margin
;   %< only effective if line all blanks up to here
;   fix t-beg in m3-space, m3-newline

(defvar m3-comment-mode nil
  "t means editing comment text---supresses abbrev and template expansion;
nil means editing code proper---expand abbrevs if enabled.
Setting this variable automatically makes it local to the current buffer.")
(make-variable-buffer-local 'm3-comment-mode)

(defvar m3-indent-step 2
  "indentation increment for Modula-3 programs.")

(defvar m3-auto-expand t
  "t means expand abbrevs automatically when not in m3-comment-mode;
nil means expand only on user demand.")

(defun m3-set-comment-mode (value)
  "sets m3-comment-mode to /value/ and enables/disables abbrevs accordingly"
  (setq m3-comment-mode value)
  (if m3-comment-mode
    (setq mode-name "(* Modula-3 *)")
    (setq mode-name "Modula-3")
  )
  (if (or m3-comment-mode (not m3-auto-expand)) 
    (abbrev-mode 0)
    (abbrev-mode 1)
  )
)

(defun m3-set-auto-expand (value)
  "sets m3-auto-expand to /value/ and enables/disables abbrevs accordingly"
  (setq m3-auto-expand value)
  (if (or m3-comment-mode (not m3-auto-expand)) 
    (abbrev-mode 0)
    (abbrev-mode 1)
  )
)

(defvar m3-build-command "m3build -d .."
  "Command to build the package")

(defvar m3-ship-command "m3ship -d .."
  "Command to build and ship the package")

(defvar m3-mode-syntax-table nil
  "Syntax table in use in modula-3-mode buffers.")
  
(require 'compile)
(setq
  compilation-error-regexp-alist
  (append
    '(
      ("\n\"[~./A-Za-z0-9]+\\.[mi]3 => \\([~./A-Za-z0-9]+\\.[mi]g\\)\", line \\([0-9]+\\):" 1 2)
      ("\n\"\\([~./A-Za-z0-9]+\\.[mi]3\\)\", line \\([0-9]+\\):" 1 2)
    )
    compilation-error-regexp-alist
  )
)

(if m3-mode-syntax-table
  ()
  (let ((table (make-syntax-table)))
    (modify-syntax-entry ?\\ "\\" table)
    (modify-syntax-entry ?\( ". 1" table)
    (modify-syntax-entry ?\) ". 4" table)
    (modify-syntax-entry ?* ". 23" table)
    (modify-syntax-entry ?+ "." table)
    (modify-syntax-entry ?- "." table)
    (modify-syntax-entry ?= "." table)
    (modify-syntax-entry ?% "." table)
    (modify-syntax-entry ?< "." table)
    (modify-syntax-entry ?> "." table)
    (modify-syntax-entry ?\' "\"" table)
    (setq m3-mode-syntax-table table)))

(defvar m3-mode-map nil
  "Keymap used in modula-3-mode.")

(if m3-mode-map 
  ()
  (let ((map (make-sparse-keymap)))
    (define-key map "\^i" 'm3-next-slot)
    (define-key map "\M-\^i" 'm3-prev-slot)
    (define-key map " " 'm3-space)
    (define-key map "\015" 'm3-newline)
    (define-key map "\012" 'm3-newline-and-indent)
    (define-key map "\C-a" 'm3-beginning-of-line)
    (define-key map "\C-o" 'm3-open-line)
    (define-key map "*" 'm3-star)
    (define-key map ")" 'm3-close-paren)
    (define-key map "\C-z" 'm3-toggle-comment-mode)
    (define-key map "\M-." 'm3-indent-region)
    (define-key map "\M-," 'm3-exdent-region)
    (define-key map "\C-c\C-v" 'm3-visit)
    (define-key map "\C-c\C-t" 'm3-toggle-files)
    (define-key map "\C-c\C-c" 'm3-build)
    (define-key map "\C-c\C-a" 'm3-build)
    (define-key map "\C-c\C-s" 'm3-ship)
    (define-key map "\C-c`" 'next-error)      ; also (usually) on "\C-x`"
    (setq m3-mode-map map)
  )
)

(defun m3-indent-region (arg)
  "indent region by arg columns (default: m3-indent-step)"
  (interactive "P")
  (stolfi-indent-region (if arg arg m3-indent-step))
)

(defun m3-exdent-region (arg)
  "exdent region by arg columns (default: m3-indent-step)"
  (interactive "P")
  (stolfi-exdent-region (if arg arg m3-indent-step))
)

(defun m3-indent-line (arg)
  "Indent this line to next tab stop."
  (interactive "p")
  (stolfi-indent-line (* arg m3-indent-step))
)

(defun m3-exdent-line (arg)
  "Indent this line to previous tab stop."
  (interactive "p")
  (stolfi-exdent-line (* arg m3-indent-step))
)

(defun m3-toggle-comment-mode ()
  "toggles m3-comment-mode and enables/disables abbrevs accordingly"
  (interactive)
  (m3-set-comment-mode (not m3-comment-mode))
)

(defun m3-toggle-auto-expand ()
  "toggles m3-auto-expand and enables/disables abbrevs accordingly"
  (m3-set-auto-expand (not m3-auto-expand))
)

(defun m3-next-slot ()
  "Skips to the next template slot, if any"
  (interactive)
  (let
    ((chained (equal last-command 'm3-next-prev-slot)))
    (setq this-command 'm3-next-prev-slot)
    (if chained  (insert-char ?~ 1))
    (if
      (stolfi-next-slot "~" (point-max))
      nil
      (progn 
        (if chained (delete-char -1))
        (error "no next slot")
      )
    )
  )
)

(defun m3-prev-slot ()
  "Skips to the previous template slot, if any"
  (interactive)
  (let
    ((chained (equal last-command 'm3-next-prev-slot)))
    (setq this-command 'm3-next-prev-slot)
    (if chained
      (progn (insert-char ?~ 1) (backward-char 1))
    )
    (if
      (stolfi-prev-slot "~" (point-min))
      nil
      (progn
        (if chained (delete-char 1))
        (error "no previous slot")
      )
    )
  )
)

(defun m3-space ()
  "Expands the abbrev to the left of point in short form, or inserts space."
  (interactive)
  (if (or m3-comment-mode (not m3-auto-expand))
    (insert-char ?  1)
    (if 
      (and
        (is-lower-case-letter (preceding-char))
        (expand-abbrev-from-table m3-short-abbrev-table)
      )
      (let ((t-end (point))
            (t-beg last-abbrev-location)
           )
        (m3-expand-template t-beg t-end)
      )
      (progn
        (expand-abbrev)
        (insert-char ?  1)
      )
    )
  )
)

(defun m3-open-line ()
  "Insert a newline after point, attempts to indent it properly"
  (interactive)
  (let ((p-here (point)))
    (m3-newline-and-indent)
    (let ((at-end (m3-looking-at-end)))
      (goto-char p-here)
      (if (and at-end (point-is-in-leading-blanks)) (m3-indent-line 1))
    )
  )
)

(defun m3-newline ()
  "Expands the abbrev to the left of point in long form, or does newline-and-indent."
  (interactive)
  (if (or m3-comment-mode (not m3-auto-expand))
    (progn 
      (m3-newline-and-indent) 
      (m3-exdent-line-if-end)
    )
    (if
      (and
        (is-lower-case-letter (preceding-char))
        (expand-abbrev-from-table m3-long-abbrev-table)
      )
      (let ((t-end (point))
            (t-beg last-abbrev-location)
           )
        (m3-expand-template t-beg t-end)
      )
      (progn
        (expand-abbrev)
        (m3-newline-and-indent)
        (m3-exdent-line-if-end)
      )
    )
  )
)

(defun m3-beginning-of-line ()
  "Moves back to logical left margin, 
or to beginning-of-line if already at or before logical margin."
  (interactive)
  (stolfi-beginning-of-line)
)

(defun m3-exdent-line-if-end ()
  "Exdents this line if the first word is END or some similar Modula-3 delimiter"
  (if (m3-looking-at-end) (m3-exdent-line 1))
)

(defun m3-looking-at-end ()
  "t iff the following word is END or some similar Modula-3 delimiter"
  (looking-at "END\|ELSE\|DO\|THEN\|UNTIL")
)
      
(defun m3-expand-template (t-beg t-end)
  "Expands the % codes in template between t-beg and t-end"
  (let 
    (
      (p-end (copy-marker t-end))
      (p-beg (copy-marker t-beg))
    )
    ; find start of pattern
    (goto-char p-beg)
    ; loop until p-end:
    (while (search-forward "%" p-end t)
      (delete-char -1)
      (let ((nc (following-char)))
        (delete-char 1)
        (cond 
          ( (= nc ?n) 
            (m3-newline-and-indent)
          )
          ( (= nc ?>) 
            (if (point-is-in-leading-blanks) 
              (insert-char ?\  m3-indent-step)
            )
          )
          ( (= nc ?<) 
            (if (point-is-in-leading-blanks) 
              (delete-char (- (min (current-column) m3-indent-step)))
            )
	  )
          ( (= nc ?%)
	    (insert-string "%")
	  )
        )
      )
    )
    (goto-char p-beg)
    (if (stolfi-next-slot "~" p-end)
      nil
      (goto-char p-end)
    )
  )
)

(defun m3-newline-and-indent ()
  "Does newline-and-indent, without expanding abbrev."
  (interactive)
  (let ((hpos (current-indentation)))
    (insert-char ?\n 1)
    (indent-to hpos)
    (delete-forward-space)
  )
)

(define-abbrev-table 'empty-abbrev-table '())

(define-abbrev-table 'm3-abbrev-table
  ; "Simple Modula-3 abbreviations (just convert to uppercase)"
  ; "expanded by any non-alphameric key" 
 '(
    ("abs" "ABS")
    ("address" "ADDRESS")
    ("adr" "ADR")
    ("adrsize" "ADRSIZE")
    ("and" "AND")
    ("any" "ANY")
    ("array" "ARRAY")
    ("as" "AS")
    ("bitsize" "BITSIZE")
    ("bool" "BOOL")
    ("boolean" "BOOLEAN")
    ("branded" "BRANDED")
    ("by" "BY")
    ("bytesize" "BYTESIZE")
    ("cardinal" "CARDINAL")
    ("ceiling" "CEILING")
    ("char" "CHAR")
    ("dec" "DEC")
    ("dispose" "DISPOSE")
    ("div" "DIV")
    ("do" "DO")
    ("end" "END")
    ("exit" "EXIT")
    ("exports" "EXPORTS")
    ("extended" "EXTENDED")
    ("false" "FALSE")
    ("first" "FIRST")
    ("float" "FLOAT")
    ("floor" "FLOOR")
    ("from" "FROM")
    ("generic" "GENERIC")
    ("in" "IN")
    ("inc" "INC")
    ("int" "INT")
    ("integer" "INTEGER")
    ("istype" "ISTYPE")
    ("last" "LAST")
    ("longreal" "LONGREAL")
    ("loophole" "LOOPHOLE")
    ("max" "MAX")
    ("min" "MIN")
    ("mod" "MOD")
    ("nutex" "MUTEX")
    ("narrow" "NARROW")
    ("nat" "NAT")
    ("new" "NEW")
    ("nil" "NIL")
    ("not" "NOT")
    ("null" "NULL")
    ("number" "NUMBER")
    ("of" "OF")
    ("or" "OR")
    ("ord" "ORD")
    ("raise" "RAISE")
    ("readonly" "READONLY")
    ("real" "REAL")
    ("ref" "REF")
    ("refany" "REFANY")
    ("root" "ROOT")
    ("round" "ROUND")
    ("set" "SET")
    ("subarray" "SUBARRAY")
    ("text" "TEXT")
    ("then" "THEN")
    ("to" "TO")
    ("true" "TRUE")
    ("trunc" "TRUNC")
    ("typecode" "TYPECODE")
    ("unsafe" "UNSAFE")
    ("untraced" "UNTRACED")
    ("value" "VALUE")
    ("val" "VAL")
    ; The following are expanded by <space> or <return>
    ; ("assert" "ASSERT")
    ; ("begin" "BEGIN")
    ; ("bits" "BITS")
    ; ("const" "CONST")
    ; ("exception" "EXCEPTION")
    ; ("import" "IMPORT")
    ; ("methods" "METHODS")
    ; ("object" "OBJECT")
    ; ("procedure" "PROCEDURE")
    ; ("raise" "RAISE")
    ; ("record" "RECORD")
    ; ("return" "RETURN")
    ; ("reveal" "REVEAL")
    ; ("type" "TYPE")
    ; ("var" "VAR")
    ; ("while" "WHILE")
    ; ("with" "WITH")
  )
)

(define-abbrev-table 'm3-short-abbrev-table
  ; "Complex Modula-3 abbreviations, single-line form"
  ; "expanded by <space>"
  '(
    ("assert" "<* ASSERT ~ *>~")
    ("begin" "BEGIN ~ END~")
    ("bits" "BITS ~ FOR ~")
    ("case" "CASE ~ OF ~ END~")
    ("const" "CONST ~")
    ("else" "%<ELSE ~")
    ("elsif" "%<ELSIF ~ THEN ~")
    ("end" "%<END~")
    ("eval" "EVAL ~")
    ("except" "%<EXCEPT ~")
    ("exception" "EXCEPTION ~")
    ("fatal" "<* FATAL ~ *>~")
    ("finally" "%<FINALLY ~")
    ("for" "FOR ~ DO ~ END~")
    ("if" "IF ~ THEN ~ END~")
    ("import" "IMPORT ~")
    ("interface" "INTERFACE ~;%n%n~%n%nEND ~.") ; always multiline
    ("lock" "LOCK ~ DO ~ END~")
    ("loop" "LOOP ~ END~")
    ("methods" "METHODS ~")
    ("module" "MODULE ~;%n%n~%n%nBEGIN%n%>~%n%<END ~.") ; always multiline
    ("object" "OBJECT ~ END~")
    ("overrides" "OVERRIDES ~")
    ("procedure" "PROCEDURE ~(~)~")
    ("raise" "RAISE ~")
    ("raises" "RAISES {~}~")
    ("record" "RECORD ~ END~")
    ("repeat" "REPEAT ~ UNTIL ~")
    ("return" "RETURN ~")
    ("reveal" "REVEAL ~")
    ("try" "TRY ~ EXCEPT ~ END~")
    ("type" "TYPE ~")
    ("typecase" "TYPECASE ~ OF ~ END~")
    ("until" "%<UNTIL ~")
    ("var" "VAR ~")
    ("while" "WHILE ~ DO ~ END~")
    ("with" "WITH ~ DO ~ END~")
  )
)

(define-abbrev-table 'm3-long-abbrev-table
  ; "Complex Modula-3 abbreviations, multi-line form"
  ; "expanded by <return>"
  '(
    ("assert" "<* ASSERT%n%>%>~%n%<%<*>~")
    ("begin" "BEGIN%n%>~%n%<END~")
    ("bits" "BITS ~ FOR%n%>~")
    ("case" "CASE ~ OF%n%>~%n%<END~")
    ("const" "CONST%n%>~")
    ("else" "%<ELSE%n%>~")
    ("elsif" "%<ELSIF ~ THEN%n%>~")
    ("eval" "EVAL%n%>~")
    ("except" "%<EXCEPT%n%>~")
    ("exception" "EXCEPTION%n%>~")
    ("fatal" "<* FATAL%n%>%>~%<%<*>~")
    ("finally" "%<FINALLY%n%>~")
    ("for" "FOR ~ DO%n%>~%n%<END~")
    ("if" "IF ~ THEN%n%>~%n%<END~")
    ("import" "IMPORT%n%>~")
    ("interface" "INTERFACE ~;%n%n~%n%nEND ~.")
    ("lock" "LOCK ~ DO%n%>~%n%<END")
    ("loop" "LOOP%n%>~%n%<END~")
    ("methods" "%<METHODS%n%>~")
    ("module" "MODULE ~;%n%n~%n%nBEGIN%n%>~%n%<END ~.")
    ("object" "OBJECT%n%>%>~%n%<END~")
    ("overrides" "%<OVERRIDES%n%>~")
    ("procedure" "PROCEDURE ~(%n%>%>~%n%<)~%n~")
    ("record" "RECORD%n%>%>~%n%<END~")
    ("repeat" "REPEAT%n%>~%n%<UNTIL ~")
    ("return" "RETURN%n%>~")
    ("reveal" "REVEAL%n%>~")
    ("try" "TRY%n%>~%n%<EXCEPT%n%>~%n%<END~")
    ("type" "TYPE%n%>~")
    ("typecase" "TYPECASE ~ OF%n%>~%n%<END~")
    ("until" "%<UNTIL%n%>~")
    ("var" "VAR%n%>~")
    ("while" "WHILE ~ DO%n%>~%n%<END~")
    ("with" "WITH%n%>~%n%<DO%n%>~%n%<END~")
  )
)

(defun modula-3-mode ()
"This is a mode intended to support program development in Modula-3.
\\{m3-mode-map}
   m3-indent-step controls the number of spaces for each indentation.
   m3-build-command holds the command to build the package.
   m3-ship-command holds the command to build and ship the package."
  (interactive)
  ; (setq debug-on-error t) ; DEBUG
  (use-local-map m3-mode-map)
  (setq major-mode 'modula-3-mode)
  (setq mode-name "Modula-3")
  (m3-set-comment-mode nil)
  (set-syntax-table m3-mode-syntax-table)
  (setq local-abbrev-table m3-abbrev-table)
  ;
  ; NO TABS, dammit:
  (setq indent-tabs-mode nil)
  ;
  ; paragraph format:
  (make-local-variable 'paragraph-start)
  (setq paragraph-start "[ \011]*$\\|[ \011]*|")
  (make-local-variable 'paragraph-separate)
  (setq paragraph-separate "[ \011]*$")
  (make-local-variable 'paragraph-ignore-fill-prefix)
  (setq paragraph-ignore-fill-prefix nil)
  ;
  ; line indentation function:
  ; (make-local-variable 'indent-line-function)
  ; (setq indent-line-function 'm3-indent-function)
  ;
  ; files must end with newline:
  (make-local-variable 'require-final-newline)
  (setq require-final-newline t)
  ;
  ; comment format:
  (make-local-variable 'comment-start)
  (setq comment-start "(* ")
  (make-local-variable 'comment-end)
  (setq comment-end " *)")
  (make-local-variable 'comment-column)
  (setq comment-column 41)
  (make-local-variable 'comment-start-skip)
  (setq comment-start-skip "\\*+ *")
  (make-local-variable 'comment-indent-hook)
  (setq comment-indent-hook 'c-comment-indent)
  (make-local-variable 'parse-sexp-ignore-comments)
  (setq parse-sexp-ignore-comments t)
  ;
  ; show matching parenthesis
  (setq blink-paren-function 'blink-matching-open)
  (setq blink-matching-paren t)
  (setq blink-matching-delay 0.1)
  (setq blink-matching-paren-dont-ignore-comments t)
  ;
  ; time stamps:
  (run-hooks 'm3-mode-hook))

(defun m3-star ()
  "Insert '*', set comment mode if previous char is '('"
  (interactive)
  (if (= (preceding-char) ?\()
    (progn (insert-char ?* 1) (m3-set-comment-mode t))
    (progn (expand-abbrev) (insert-char ?* 1))
  )
)

(defun m3-close-paren ()
  "Insert ')', reset comment mode if previous char is '*'"
  (interactive)
  (if (= (preceding-char) ?*)
    (progn (insert-char ?\) 1) (m3-set-comment-mode nil))
    (progn (expand-abbrev) (insert-char ?\) 1))
  )
  (apply blink-paren-function nil)
)

(defun m3-build ()
  "Build the Modula-3 package whose source directory is the current directory"
  (interactive)
  (compile m3-build-command)
)

(defun m3-compile-all ()
  "Build and ship the Modula-3 package whose source directory is the current directory"
  (interactive)
  (compile m3-ship-command)
)

(defun execute-monitor-command (command)
  (let* ((shell shell-file-name)
	 (csh (equal (file-name-nondirectory shell) "csh")))
    (call-process shell nil t t "-cf" (concat "exec " command))
  )
)

(defun m3-visit ()
  (interactive)
  (let ((deffile nil)
	(modfile nil)
	modulename)
    (save-excursion
      (setq modulename
	    (read-string "Module name: "))
      (switch-to-buffer "*Command Execution*")
      (execute-monitor-command (concat "m3whereis " modulename))
      (goto-char (point-min))
      (condition-case ()
	  (progn (re-search-forward "\\(.*\\.i3\\) *$")
		 (setq deffile (buffer-substring (match-beginning 1)
						 (match-end 1))))
	(search-failed ()))
      (condition-case ()
	  (progn (re-search-forward "\\(.*\\.m3\\) *$")
		 (setq modfile (buffer-substring (match-beginning 1)
						 (match-end 1))))
	(search-failed ()))
      (if (not (or deffile modfile))
	  (error "I can find neither definition nor implementation of %s"
		 modulename)))
    (cond (deffile
	    (find-file deffile)
	    (if modfile
		(save-excursion
		  (find-file modfile))))
	  (modfile
	   (find-file modfile)))))

(defun m3-toggle-files ()
  "Toggle between .m3 and .i3 files for the module."
  (interactive)
  (let*
    ( ( this-file (buffer-file-name) )
      ( that-file
        (cond 
          ( (string-equal (substring this-file -3) ".m3")
            (concat (substring this-file 0 -3) ".i3"))
          ( (string-equal (substring this-file -3) ".i3")
            (concat (substring this-file 0 -3)  ".m3"))
          ( (string-equal (substring this-file -3) ".mg")
            (concat (substring this-file 0 -3) ".ig"))
          ( (string-equal (substring this-file -3) ".ig")
            (concat (substring this-file 0 -3)  ".mg"))
          (t nil)
        )
      )
    )
    (if that-file
      (find-file-other-window that-file)
      (error "cannot guess the other file's name")
    )
  )
)