;; cforall.el --- major mode for editing CForAll (.cf or .cfa) files
;;                (right now, only some syntax highlighting and indentation)

;; This file is *NOT* part of GNU Emacs.

;; Extension to Barry Warsaw's cc-mode (plus fontification)

;; To use, add this file somewhere in `load-path' and put the following lines in .emacs
;;
;;   (autoload 'CFA-mode "cforall" "CForAll mode" t)
;;   (setq auto-mode-alist (append '(("\\.cfa?$" . CFA-mode))
;;				   auto-mode-alist))


(provide 'CFA-mode)

(require 'cc-mode)
(require 'font-lock)

(eval-when-compile
  (require 'cc-mode)
  (require 'font-lock)
)

(defconst c-CFA-extra-toplevel-key c-extra-toplevel-key )
(defconst c-CFA-attrib-key (concat "\[" c-symbol-key "\\(([^)]*)\\)?\]"))
(defconst c-CFA-class-key c-class-key )
(defconst c-CFA-conditional-key c-conditional-key)
(defconst c-CFA-access-key c-access-key)
(defconst c-CFA-comment-start-regexp c-comment-start-regexp )

(defvar CFA-mode-abbrev-table nil
  "Abbreviation table used in CFA-mode buffers.")
(define-abbrev-table 'CFA-mode-abbrev-table ())

(defvar CFA-mode-map ()
  "Keymap used in CFA-mode buffers.")
(if CFA-mode-map
    nil
  (setq CFA-mode-map (c-make-inherited-keymap))
  )

(defvar CFA-mode-syntax-table nil
  "Syntax table used in CFA-mode buffers.")
(if CFA-mode-syntax-table
    ()
  (setq CFA-mode-syntax-table (make-syntax-table))
  (c-populate-syntax-table CFA-mode-syntax-table))
  (modify-syntax-entry ?@ "_" CFA-mode-syntax-table)
  (modify-syntax-entry ?. "_" CFA-mode-syntax-table)
  (modify-syntax-entry ?. "w" CFA-mode-syntax-table)

(easy-menu-define c-CFA-menu CFA-mode-map "CFA Mode Commands"
		  (c-mode-menu "CFA"))

(defcustom CFA-mode-hook nil
  "*Hook called by `CFA-mode'."
  :type 'hook
  :group 'c)

;; Font lock support
(defcustom CFA-font-lock-extra-types
  '()
  "*List of extra types to fontify in CFA mode.
Each list item should be a regexp not containing word-delimiters.
For example, a value of (\"System\") means the word string is treated as a type
name.
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)
(defconst CFA-font-lock-keywords-1 nil
  "Subdued level highlighting for CFA mode.")
(defconst CFA-font-lock-keywords-2 nil
  "Medium level highlighting for CFA mode.
See also `CFA-font-lock-extra-types'.")
(defconst CFA-font-lock-keywords-3 nil
  "Gaudy level highlighting for CFA mode.
See also `CFA-font-lock-extra-types'.")


;; Auxiliary functions (change this)
;; (defun font-lock-match-CFA-style-declaration-item-and-skip-to-next (limit)
;;   ;; Regexp matches after point:		word<word>::word (
;;   ;;						^^^^ ^^^^   ^^^^ ^
;;   ;; Where the match subexpressions are:	  1    3      5  6
;;   ;;
;;   ;; Item is delimited by (match-beginning 1) and (match-end 1).
;;   ;; If (match-beginning 3) is non-nil, that part of the item incloses a `<>'.
;;   ;; If (match-beginning 5) is non-nil, that part of the item follows a `::'.
;;   ;; If (match-beginning 6) is non-nil, the item is followed by a `('.
;;   (when (looking-at (eval-when-compile
;; 		      (concat
;; 		       ;; Skip any leading whitespace.
;; 		       "[ \t*&]*"
;; 		       ;; This is `c++-type-spec' from below.  (Hint hint!)
;; 		       "\\(\\sw+\\)"				; The instance?
;; 		       "\\([ \t]*<\\([^>\n]+\\)[ \t*&]*>\\)?"	; Or template?
;; 		       "\\([ \t]*::[ \t*~]*\\(\\sw+\\)\\)*"	; Or member?
;; 		       ;; Match any trailing parenthesis.
;; 		       "[ \t]*\\((\\)?")))
;;     (save-match-data
;;       (condition-case nil
;; 	  (save-restriction
;; 	    ;; Restrict to the end of line, currently guaranteed to be LIMIT.
;; 	    (narrow-to-region (point-min) limit)
;; 	    (goto-char (match-end 1))
;; 	    ;; Move over any item value, etc., to the next item.
;; 	    (while (not (looking-at "[ \t]*\\(\\(,\\)\\|;\\|$\\)"))
;; 	      (goto-char (or (scan-sexps (point) 1) (point-max))))
;; 	    (goto-char (match-end 2)))
;; 	(error t)))))


(let* ((CFA-keywords
	(eval-when-compile
	  (regexp-opt
	   (list
	    ;; Statements
	    "break" "catch" "choose" "context"
	    "continue" "do" "else" "fallthru" "for"  "if" "return"
	    "sizeof" "switch" "throw" "try" ;c-cfa-typeof-re
	    "while"
	    ;; Storage classes
	    "auto" "extern" "register" "static"
	    "inline" "__inline" "__inline__" "fortran"
	    ;; Typedef
	    "typedef"
	    ;; Type classes
	    "type" "dtype" "ftype"
	    ;; Type qualifiers
	    "const" "__const" "__const__" "restrict" "volatile" "__volatile"
	    "__volatile__" "lvalue" "forall"
	    ) t)))

       (CFA-reserved-words '());(eval-when-compile (regexp-opt '() t)))

       (CFA-type-names
	`(mapconcat 'identity
	  (cons
	   (,@ (eval-when-compile
		 (regexp-opt '("char" "short" "int" "long"
			       "float" "double" "void"
			       "unsigned"
			       ))))
	   CFA-font-lock-extra-types)
	  "\\|"))
       (CFA-type-names-depth `(regexp-opt-depth (,@ CFA-type-names)))

;;        (CFA-ops
;; 	(eval-when-compile
;; 	  (regexp-opt
;; 	   '("." "+" "-" "*" "/" "%" "^" "&" "|" "~" "!" "=" "<" ">" "+=" "-="
;; 	     "*=" "/=" "%=" "^=" "&=" "|=" "<<" ">>" ">>=" "<<=" "==" "!="
;; 	     "<=" ">=" "&&" "||" "++" "--"))))

       (CFA-ops-names
 	(eval-when-compile
 	  (regexp-opt
 	   (list
 	    ;; diadic
 	    "?+?" "\?-\?" "?*?" "?/?" "?%?" "?|?" "?&?" "?^?" "?<<?" "?>>?"
 	    "?<?" "?>?" "?<=?" "?>=?" "?==?" "?!=?" "?=?" "?*=?" "?/=?"
 	    "?%=?" "?+=?" "?-=?" "?<<=?" "?>>=?" "?&=?" "?^=?" "?|=?"
 	    "?[?]"
 	    ;; monadic
 	    "+?" "-?" "*?" "!?" "~?" "++?" "?++" "--?" "?--"
 	    ))))

       ; defined so as to make it independent of the syntax table
       ; (and allow users to knock themselves out figuring out new word definitions)
       (CFA-valid-identifier "[[:alpha:]][[:alnum:]]*")

       (CFA-preprocessor-directives
	(eval-when-compile
	  (regexp-opt
	   '("define"  "elif" "else" "endif" "error" "file" "if" "ifdef"
	     "ifndef" "include" "line" "pragma" "undef"))))
      (CFA-preprocessor-directives-depth
	(regexp-opt-depth CFA-preprocessor-directives))
  )

 (setq CFA-font-lock-keywords-1
  (list
   ;; Fontify function names.
   (list
    (concat "\\(" CFA-ops-names "\\)")
    '(1 font-lock-function-name-face nil t))

  ;;; Preprocessor directives
   ;; Fontify filenames in #include <...> preprocessor directives as strings.
   '("^[ \t]*#[ \t]*\\(include\\)[ \t]*\\(<[^>\"\n]*>?\\)" 2 font-lock-string-face)
   ;; Fontify function macro names.
   '("^#[ \t]*define[ \t]+\\(\\sw+\\)(" 1 font-lock-function-name-face)
;;    ;;
;;    ;; Fontify symbol names in #elif or #if ... defined preprocessor directives.
;;    '("^#[ \t]*\\(elif\\|if\\)\\>"
;;      ("\\<\\(defined\\)\\>[ \t]*(?\\(\\sw+\\)?" nil nil
;;       (1 font-lock-builtin-face) (2 font-lock-variable-name-face nil t)))
;;    ;;
;;    ;; Fontify otherwise as symbol names, and the preprocessor directive names.
   (list
     (concat "^[ \t]*#[ \t]*\\(" CFA-preprocessor-directives ;; check number of spaces surrounding pound sign
	     "\\)\\>[ \t!]*\\(\\sw+\\)?")
     '(1 font-lock-builtin-face))
;;     (list (+ 2 c-preprocessor-directives-depth)
;; 	  'font-lock-variable-name-face nil t))
 ))

 (setq CFA-font-lock-keywords-2
  (append CFA-font-lock-keywords-1
   (list
    ;; Fontify all builtin keywords (except below).
    (concat "\\<\\(" CFA-keywords "\\)\\>")

    ;; Fontify types
    `(eval .
      (cons (concat "\\<\\(" (,@ CFA-type-names) "\\)\\>")
	    '(1 font-lock-type-face)
	    ))
    (list "\\<[fd]?type\\>[ \t]*\\(\\sw+\\)" '(1 font-lock-type-face))

    ;; Fontify labeled labeled loop exits/goto targets.
    (list "\\<\\(break\\|continue\\|goto\\)\\>[ \t]*\\(-?\\sw+\\)?"
	  '(1 font-lock-keyword-face)
	  '(2 font-lock-constant-face nil t)
	  )

    ;; Fontify case labels.
    '("\\<\\(case\\)\\>"
      (1 font-lock-keyword-face)
					;("[ \t]*\\(-?\\sw+[ \t]*\\(\\(~\\)[ \t]*\\sw+\\)?\\)?"
      ("\\(-[0-9]+\\|\\sw+\\)+";\\([ \t]*~[ \t]*\\(-[0-9]+\\|\\sw+\\)\\)?\\)"
       ;; Return limit of search.
       (save-excursion (skip-chars-forward "^:\n") (point))
       nil
       (1 font-lock-constant-face nil t))
					;'(2 font-lock-constant-face nil t)
      )

    ;; This must come after the one for keywords and targets.  (named blocks)
    ;; xxx: gets 'default' and designated initializers
;;     `(":" ( ,(concat "^\\([ \t]*\\(" CFA-valid-identifier "\\)[ \t]*:\\)+")
;; 	    ,@(if (not (string= "default" (match-string 2)))
;; 		  '((message "Check it out: (%s)" (match-data))
;; 		    (error t)
;; 		    (beginning-of-line) (end-of-line)
;; 		    (2 font-lock-constant-face))
;; 		'((2 font-lock-keyword-face)))
;; 	   ))
    `( ,(concat "^\\([ \t]*\\(" CFA-valid-identifier "\\)[ \t]*:\\)+")
       (2 font-lock-constant-face))

    ;; Fontify attributes
    (list "!\\<\\(\\sw+\\)\\>" '(1 font-lock-builtin-face))

    ;; Fontify some literals.
    ;'("\\<\\(false\\|true\\|null\\|undefined\\)\\>" . font-lock-constant-face)
    )))

 (setq CFA-font-lock-keywords-3
  (append CFA-font-lock-keywords-2
   ;;
   ;; More complicated regexps for more complete highlighting for types.
   ;; (Note: Need to revisit the styling here.)
   (list
    ;;
    ;; Fontify random types immediately followed by an item or items.
    `(eval .
      (list (concat "\\<\\(" (,@ CFA-type-names) "\\)\\>"
		    "\\([ \t]*\\[[ \t]*\\]\\)*"
		    "\\([ \t]*\\sw\\)")
	    ;; Fontify each declaration item.
	    (list 'font-lock-match-c++-style-declaration-item-and-skip-to-next
		  ;; Start with point after all type specifiers.
		  (list 'goto-char (list 'or
					 (list 'match-beginning
					       (+ (,@ CFA-type-names-depth) 2))
					 '(match-end 1)))
		  ;; Finish with point after first type specifier.
		  '(goto-char (match-end 1))
		  ;; Fontify as a variable or function name.
		  '(1 (if (match-beginning 2)
			  font-lock-function-name-face
			font-lock-variable-name-face))))))

    ))
 )


(defvar CFA-font-lock-keywords CFA-font-lock-keywords-3
  "Default expressions to highlight in CFA mode.
See also `CFA-font-lock-extra-types'.")


;; (defun print-point ()
;;   (interactive)
;;   (message "The point is: %d" (point)))


(defun CFA-mode ()
  "Major mode for editing CForAll code.
Key bindings:
\\{CFA-mode-map}"
  (interactive)
  (c-initialize-cc-mode)
  (kill-all-local-variables)
  (set-syntax-table CFA-mode-syntax-table)
  (setq major-mode 'CFA-mode
 	mode-name "CFA"
 	local-abbrev-table CFA-mode-abbrev-table)
  (use-local-map CFA-mode-map)
  (c-common-init)
  (setq comment-start "// "
 	comment-end   ""
 	c-conditional-key c-CFA-conditional-key
 	c-comment-start-regexp c-CFA-comment-start-regexp
  	c-class-key c-CFA-class-key
	c-extra-toplevel-key c-CFA-extra-toplevel-key
;	c-method-key c-CFA-method-key
 	c-baseclass-key nil
	c-recognize-knr-p nil
 	c-access-key  c-CFA-access-key
	c-inexpr-class-key nil
	)

  ;; Font lock
  (make-local-variable 'font-lock-defaults)
  (setq font-lock-defaults
	'((CFA-font-lock-keywords CFA-font-lock-keywords-1
				     CFA-font-lock-keywords-2 CFA-font-lock-keywords-3)
	  nil nil ((?_ . "w") (?$ . "w")) nil
	  (font-lock-mark-block-function . mark-defun)))

  ; keybindings
  ;(local-set-key [C-f3] 'print-point)

  ;; hooks
  (run-hooks 'c-mode-common-hook)
  (run-hooks 'CFA-mode-hook)
  (c-update-modeline))