;;; sdl-mode.el --- major mode for editing ITU-T Z.100 SDL/PR under Emacs

;; Copyright © 1999 Marko Mäkelä <msmakela@tcs.hut.fi>

;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2 of the License, or
;; (at your option) any later version.
  
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.
  
;; You should have received a copy of the GNU General Public License
;; along with this program; if not, write to the Free Software
;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.

;;; Commentary:

;; This package provides a major mode for editing SDL/PR specifications.
;; It provides mainly syntax highlighting.

;;; Code:

(defvar sdl-mode-abbrev-table nil
  "Abbrev table in use in SDL mode.")
(define-abbrev-table 'sdl-mode-abbrev-table ())

(defvar sdl-mode-syntax-table nil
  "Syntax table in use in SDL mode.")

(defvar sdl-mode-map (make-sparse-keymap)
  "Keymap used in SDL mode.")

(define-key sdl-mode-map [menu-bar] (make-sparse-keymap))
(define-key sdl-mode-map [menu-bar d]
  (cons "SDL" (make-sparse-keymap "SDL")))

(define-key sdl-mode-map [menu-bar d comment-region]
  '("Comment Out Region" . comment-region))

(put 'comment-region 'menu-enable 'mark-active)

(if sdl-mode-syntax-table
    ()
  (setq sdl-mode-syntax-table (make-syntax-table))
  (modify-syntax-entry ?/ ". 14" sdl-mode-syntax-table)
  (modify-syntax-entry ?* ". 23" sdl-mode-syntax-table)
  (modify-syntax-entry ?+ "." sdl-mode-syntax-table)
  (modify-syntax-entry ?- "." sdl-mode-syntax-table)
  (modify-syntax-entry ?= "." sdl-mode-syntax-table)
  (modify-syntax-entry ?% "." sdl-mode-syntax-table)
  (modify-syntax-entry ?< "." sdl-mode-syntax-table)
  (modify-syntax-entry ?> "." sdl-mode-syntax-table)
  (modify-syntax-entry ?& "." sdl-mode-syntax-table)
  (modify-syntax-entry ?| "." sdl-mode-syntax-table)
  (modify-syntax-entry ?\\ "." sdl-mode-syntax-table)
  (modify-syntax-entry ?_ "_" sdl-mode-syntax-table)
  (modify-syntax-entry ?. "_" sdl-mode-syntax-table)
  (modify-syntax-entry ?\' "\"" sdl-mode-syntax-table)
  (modify-syntax-entry ?\" "." sdl-mode-syntax-table))

(defconst sdl-font-lock-keywords-1 nil
  "Subdued level highlighting for sdl-mode.")
(defconst sdl-font-lock-keywords-2 nil
  "Medium level highlighting for sdl-mode.
See also `sdl-font-lock-extra-types'.")
(defconst sdl-font-lock-keywords-3 nil
  "Gaudy level highlighting for sdl-mode.
See also `sdl-font-lock-extra-types'.")
(defcustom sdl-font-lock-extra-types '()
  "*List of extra types to fontify in SDL mode.
Each list item should be a regexp not containing word-delimiters.
For example, a value of (\"SmallInt\" \"\\\\sw+[Ss]ort\") means the word
SmallInt and words ending in Sort or sort are treated as type names.

The value of this variable is used when Font Lock mode is turned on."
  :type 'font-lock-extra-types-widget
  :group 'font-lock-extra-types)
(defvar sdl-imenu-generic-expression
  (list
   '(nil "^[ \t]*procedure[ \t]\\([0-9a-zA-Z.]+\\>\\)" 1)
   '("Processes"
     "^[ \t]*\\(process\\|service\\)[ \t]+\\(type[ \t]+\\)?\\([0-9a-zA-Z.]+\\>\\)"
     3)
   '("Packages"
     "^[ \t]*\\(system\\|package\\)[ \t]+\\(type[ \t]+\\)?\\([0-9a-zA-Z.]+\\>\\)"
     3)
   '("Types"
     "^[ \t]*\\(\\(new\\|syn\\)type\\|generator\\)[ \t]+\\([0-9a-zA-Z.]+\\>\\)"
     3))
  "The regex pattern to use for creating a buffer index for SDL/PR.

See `imenu-generic-expression'.")

(let* ((sdl-keywords
	(eval-when-compile
	  (regexp-opt
	   '("active" "adding" "all" "alternative" "and" "any" "as"
	     "atleast" "axioms" "block" "call" "channel" "comment"
	     "connect" "connection" "constant" "constants" "create"
	     "dcl" "decision" "default" "else" "endalternative"
	     "endblock" "endchannel" "endconnection" "enddecision"
	     "endgenerator" "endnewtype" "endoperator" "endpackage"
	     "endprocedure" "endprocess" "endrefinement" "endselect"
	     "endservice" "endstate" "endsubstructure" "endsyntype"
	     "endsystem" "env" "export" "exported" "external"
	     "fi" "finalized" "for" "fpar" "from" "gate" "generator"
	     "if" "import" "imported" "in" "in" "inherits" "input"
	     "interface" "join" "literal" "literals" "map" "mod"
	     "nameclass" "newtype" "nextstate" "nodelay" "noequality"
	     "none" "not" "now" "offspring" "operator" "operators"
	     "or" "ordering" "out" "output" "package" "parent"
	     "priority" "procedure" "process" "provided" "redefined"
	     "referenced" "refinement" "rem" "remote" "reset" "return"
	     "returns" "revealed" "reverse" "save" "select" "self"
	     "sender" "service" "set" "signal" "signallist"
	     "signalroute" "signalset" "spelling" "start" "state"
	     "stop" "struct" "substructure" "synonym" "syntype"
	     "system" "task" "then" "this" "timer" "to" "type" "use"
	     "via" "viewed" "virtual" "with" "xor") t)))
       (sdl-type-types
	`(mapconcat 'identity
		    (cons
		     (,@ (eval-when-compile
			   (regexp-opt
			    '("Boolean" "Character" "String" "Charstring" 
			      "Integer" "Natural" "Real" "Array" "Powerset"
			      "PId" "Duration" "Time" "struct" "choice"))))
		     sdl-font-lock-extra-types)
		    "\\|"))
       (sdl-errors
	(eval-when-compile (regexp-opt '("error"))))
       (sdl-literals
	(eval-when-compile
	  (regexp-opt
	   '("True" "False" ; Boolean
	     "Null" ; PId
	     "Emptystring" ; String
	     "Empty" ; Powerset
	     ) t)))
       (sdl-operators
	(eval-when-compile
	  (regexp-opt
	   '("Num" "Chr" ; Character
	     "MkString" "Length" "First" "Last" "Substring" ; String
	     "Float" "Fix" ; Integer
	     "Incl" "Del" ; Powerset
	     ) t)))
       (sdl-var-ref
	(eval-when-compile
	  (regexp-opt
	   '("in" "out" "atleast" "with" "dcl" "remote" "fpar" "viewed"
	     "revealed" "exported" "signal" "reverse" "refinement"
	     "synonym" "literals" "input" "output" "timer"))))
       (sdl-entity-ref
	(eval-when-compile
	  (regexp-opt
	   '("type" "system" "endsystem" "package" "endpackage"
	     "operator" "endoperator" "procedure" "endprocedure"
	     "service" "endservice" "process" "endprocess"
	     "signalroute" "channel" "endchannel" "gate"
	     "substructure" "endsubstructure"
	     "block" "endblock" "via" "all" "use"))))
       (sdl-type-ref
	(eval-when-compile
	  (regexp-opt
	   '("syntype" "endsyntype" "newtype" "endnewtype"
	     "generator" "endgenerator")))))
  (setq sdl-font-lock-keywords-1
	(cons (concat "\\<" sdl-keywords "\\>") nil))
  (setq sdl-font-lock-keywords-2
	(append sdl-font-lock-keywords-1
		(list
		 (cons (concat "\\<" sdl-errors "\\>")
		       'font-lock-warning-face)
		 (cons (concat "\\<" sdl-literals "\\>")
		       'font-lock-constant-face)
		 (cons (concat "\\<" sdl-operators
			       "\\>\\|\\<\\sw+!\\B")
		       'font-lock-builtin-face)
		 '("\"\\([^\"]+\\)\""
		   1 font-lock-builtin-face)
		 ; state and label names
		 '("\\<\\(join\\|\\(end\\|next\\)?state\\)[ \t]+\\(\\sw+\\)"
		   (3 font-lock-constant-face))
		 ; labels
		 '("^[ \t]*\\(\\sw+\\):"
		   (1 font-lock-constant-face))
		 ; numeric constants
		 '("\\<[0-9]*\\([0-9]\\|\\.[0-9]+\\)\\>"
		   (0 font-lock-constant-face))
		 ; type names
		 `(eval .
			(cons (concat "\\<\\(" (,@ sdl-type-types) "\\)\\>")
			      'font-lock-type-face)))))
  (setq sdl-font-lock-keywords-3
	(append sdl-font-lock-keywords-2
		(list
		 (cons (concat "\\<\\(" sdl-var-ref "\\)\\>"
			       "\\([ \t]+\\sw+\\)*\\>")
		       ;; Fontify each declaration item.
		       (list 'font-lock-match-c-style-declaration-item-and-skip-to-next
			     ;; Start with point after first specifier.
			     '(goto-char (match-end 1))
			     ;; Finish with point after first specifier.
			     '(goto-char (match-end 1))
			     ;; Fontify as a variable name.
			     '(1 font-lock-variable-name-face)))
		 (cons (concat "\\<\\(" sdl-entity-ref "\\)\\>"
			       "\\([ \t]+\\sw+\\)*\\>")
		       ;; Fontify each declaration item.
		       (list 'font-lock-match-c-style-declaration-item-and-skip-to-next
			     ;; Start with point after first specifier.
			     '(goto-char (match-end 1))
			     ;; Finish with point after first specifier.
			     '(goto-char (match-end 1))
			     ;; Fontify as a function name.
			     '(1 font-lock-function-name-face)))
		 (cons (concat "\\<\\(" sdl-type-ref "\\)\\>"
			       "\\([ \t]+\\sw+\\)*\\>")
		       ;; Fontify each declaration item.
		       (list 'font-lock-match-c-style-declaration-item-and-skip-to-next
			     ;; Start with point after first specifier.
			     '(goto-char (match-end 1))
			     ;; Finish with point after first specifier.
			     '(goto-char (match-end 1))
			     ;; Fontify as a type name.
			     '(1 font-lock-type-face)))))))

(defun sdl-mode-variables ()
  "Initialize buffer-local variables for sdl-mode."
  (set-syntax-table sdl-mode-syntax-table)
  (setq major-mode 'sdl-mode
	mode-name "SDL"
	local-abbrev-table sdl-mode-abbrev-table)
  (make-local-variable 'comment-start)
  (make-local-variable 'comment-end)
  (make-local-variable 'comment-column)
  (make-local-variable 'comment-start-skip)
  (make-local-variable 'comment-multi-line)
  (setq comment-start "/* "
	comment-end " */"
	comment-column 32
	comment-start-skip "/\\*+ *"
	comment-multi-line t)
  (make-local-variable 'font-lock-defaults)
  (setq font-lock-defaults
	'((sdl-font-lock-keywords
	  sdl-font-lock-keywords-1
	  sdl-font-lock-keywords-2
	  sdl-font-lock-keywords-3)
	  nil nil ((?. . "w") (?_ . "w"))))
  (make-local-variable 'imenu-generic-expression)
  (setq imenu-generic-expression sdl-imenu-generic-expression))
;;;###autoload
(defun sdl-mode ()
  "Major mode for editing ITU-T Z.100 SDL/PR specifications.

The hook variable `sdl-mode-hook' is run with no args, if that
variable is bound and has a non-nil value.

Key bindings:
\\{sdl-mode-map}"
  (interactive)
  (kill-all-local-variables)
  (use-local-map sdl-mode-map)
  (sdl-mode-variables)
  (run-hooks 'sdl-mode-hook))

(add-to-list 'auto-mode-alist '("\\.\\(sdl\\|pr\\)\\'" . sdl-mode))
(if (featurep 'speedbar)
    (speedbar-add-supported-extension ".\\(sdl\\|pr\\)"))
(provide 'sdl-mode)
