;; LPC mode
;;
;; Emacs Lisp Archive Entry
;; Package: lpc-mode
;; Filename: lpc-mode.el
;; Version: 0.17 (maybe, unreleased)
;; Keywords: languages, LPC
;; Author: Vivek Dasmohapatra <vivek@etla.org>
;; Maintainer: Vivek Dasmohapatra <vivek@etla.org>
;; Created: 2002-08-31
;; Description: syntax highlighting/indentation for LPC
;; URL: http://rtfm.etla.org/emacs/lpc-mode/
;; Compatibility: Emacs21, XEmacs21, Emacs22
;; Incompatibility: Emacs20, XEmacs20
;; Last-Updated: Thu 2005-12-29 02:16:37 +0000

;; This file is NOT part of GNU Emacs

;; 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., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA

;; Copyright (C) 2002 Vivek Dasmohapatra <vivek@etla.org>

;; 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.

;; OK Nick: first stab at LPC mode:
;; 0.01: 'foo and 'C' should be handled correctly.
;; 0.02 ... 0.06: intermediates.
;; 0.07: ultra-hairy ({#'[][,&] syntax now scanned for. Bleurgh.
;; 0.08: ({ ... }) syntax added as brace-list
;; 0.09: rip up and rewrite as a proper cc-mode based mode
;; 0.10: miscellaneous bugfixes.
;; 0.11: should compile cleanly now _and_ work as well (I hope)
;; 0.12: bug in `lpc-font-lock-map' keyword/function definition highlighting
;; 0.13: kludges for XEmacs (which is slooow...)
;; 0.14: tweak syntax highlight order, so references to keywords/builtins
;;       are highlighted as references, not functions/keywords/etc.
;; 0.15: added `nosave' and `protected' specifiers
;; 0.16: scanning for closure syntax should not mark the buffer as modified
;; 0.17: support new cc-mode - will /not/ work with the old cc-mode

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; HOW TO INSTALL:
;;
;; ;; either put lpc-mode.el in your load path and use:
;; (autoload 'lpc-mode  "lpc-mode" t)
;;
;; ;; or have:
;; (autoload 'lpc-mode  "/path/to/lpc-mode.el" t)
;;
;; ;; then:
;; (setq auto-mode-alist
;;       (append '(("\\.lpc$" . lpc-mode)) auto-mode-alist)) )
;;
;; Nick: You'll have to do similar things to handler.el to get that to
;; work, let me know if you need this done.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; elisp-dep-block >>
(require 'custom    );(defface)
(require 'cc-mode   );(c-electric-brace)
(require 'regexp-opt);(regexp-opt-depth regexp-opt)
(require 'font-lock )
  ;;(font-lock-add-keywords font-lock-fontify-region font-lock-mode)
;; elisp-dep-block <<
(eval-when-compile
  ;; compile time to get the sources for the language constants.  
  (require 'cc-langs)
  (require 'cc-fonts))
(eval-and-compile
  ;; Register us with the constant system. I guess we are most like pike.
  ;; must be done at compile time also since constants are evaluated then.
  (c-add-language 'lpc-mode 'pike-mode))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(message 
 "interim UNRELEASED copy of lpc-mode, after a major update. ymmv")

(defconst lpc-mode-version "0.17")

(eval-and-compile
  (defmacro lpc-defsyntax (name doc klist)
    "Declare a cc-mode syntax variable of lpc-N-keywords and a regex
lpc-N-regex to go along with it, based on the keyword list K."
    (let* ((n  name )
	   (d  doc  )
	   (k  klist)
	   (ln (format "lpc-%s-keywords" n))
	   (ld (format "%s (list)"       d))
	   (ls (intern                  ln))
	   (rn (format "lpc-%s-regex"    n))
	   (rd (format "%s (regex)"      d))
	   (rs (intern                  rn))
	   (kwds                        nil))
      (setq kwds (if (stringp (car k)) k (eval k)))
      ;;(message "%s" (format "%S" kwds))
      `(progn (defconst ,ls ',kwds              ,ld)
	      (defconst ,rs (regexp-opt ',kwds) ,rd)) ))

  (lpc-defsyntax type
		 "LPC primitive type keywords."
		 ("int"      "mapping" "mixed"  "object" 
		  "status"   "string"  "void"   "float" 
		  "function" "enum"    "struct" "char"  ))

  (lpc-defsyntax specifier
		 "LPC declaration specifier keywords."
		 ("nomask" "nosave" "private" "protected"
		  "public" "static" "varargs"))

  (lpc-defsyntax other-decl
		 "LPC keywords starting other decl-level constructs."
		 ("inherit"))

  (lpc-defsyntax block-stmt-1
		 "LPC keywords followed directly by a block."
		 ("do" "else"))

  (lpc-defsyntax block-stmt-2
		 "LPC keywords followed by a paren sexp and then by a block."
		 ("for" "if" "switch" "while" "foreach"))
  
  (lpc-defsyntax simple-stmt
		 "LPC statement keywords followed by an expression or nothing."
		 ("break" "continue" "return"))

  (lpc-defsyntax label
		 "LPC keywords introducing labels in blocks."
		 ("case" "default"))

  (lpc-defsyntax all
		 "LPC keywords."
		 (append lpc-type-keywords
			 lpc-specifier-keywords
			 lpc-other-decl-keywords
			 lpc-block-stmt-1-keywords
			 lpc-block-stmt-2-keywords
			 lpc-simple-stmt-keywords
			 lpc-label-keywords       ))

  (lpc-defsyntax default-highlight
		 "LPC keywords (for default highlighting)"
		 (append lpc-specifier-keywords
			 lpc-block-stmt-1-keywords
			 lpc-block-stmt-2-keywords
			 lpc-simple-stmt-keywords ))
  
  (lpc-defsyntax conditional
		 "LPC conditional keywords"
		 (append lpc-block-stmt-1-keywords lpc-block-stmt-2-keywords)))

(defconst lpc-comment-start-regex (c-lang-const c-comment-start-regexp c++))
(defconst lpc-special-brace-lists '((?{ . ?})) )
(defconst lpc-magic-quote-comma   '(9))
(defconst lpc-magic-symbol-name   '(3))

(defvar lpc-mode-syntax-table nil)
(if lpc-mode-syntax-table
    nil
  (setq lpc-mode-syntax-table    (make-syntax-table))
  (c-populate-syntax-table     lpc-mode-syntax-table)
  (modify-syntax-entry ?\' "'" lpc-mode-syntax-table) )

(defun lpc-modify-syntax-at (beg end syntax)
  "Apply a syntax-property value syntax from beg to end."
  (if (<= (point-max) end) nil; noop
    (let ((buffer-state (buffer-modified-p)))
      ;;(message "(%d x %d) => %S" beg end syntax)
      (put-text-property beg      end 'syntax-table   syntax)
      (put-text-property (1- end) end 'rear-nonsticky t     )
      (or buffer-state (set-buffer-modified-p  buffer-state))) ))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Code by Seth Golub <seth AT cs DOT wustl DOT edu>, 1996-02-01,
;; no licence.
;;
;; modified slightly to bring this up to date, didn't work quite right
;; out of the box:
(defun lpc-maybe-electric-brace (arg)
  "Insert character and maybe correct line's indentation."
  (interactive "P")
  (if (= last-command-char ?{)
      (if (= (preceding-char) ?\()
          (self-insert-command (prefix-numeric-value arg))
        (c-electric-brace arg))
    ;; (= last-command-char ?})
    (let (start-point state containing-sexp)
      (save-excursion (beginning-of-defun)
                      (setq start-point (point)))
      (save-excursion (setq state (parse-partial-sexp (point) start-point 0)))
      (setq containing-sexp (car (cdr state)))
      (if (and containing-sexp (save-excursion
                                 (goto-char (1- containing-sexp))
                                 (looking-at "(")))
          (progn
            (self-insert-command (prefix-numeric-value arg))
            (lpc-scan-magic-quote))
        (c-electric-brace arg)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defconst lpc-magic-quote-regex "({\\s-*#'\\([^\\s-\n,}]+\\|,\\)\\s-*[,}]")

(defun lpc-magic-comma-p (pt)
  (let ((bol nil) (eol nil) (pos nil) (ret nil))
    (save-excursion
      (goto-char pt)
      (end-of-line)
      (setq eol (point))
      (beginning-of-line)
      (setq bol (point))
      (while (and (not ret)
                  (setq pos (re-search-forward lpc-magic-quote-regex eol t)))
        ;;(message "magic pattern at %d/%d" (1- pos) pt)
        (if (/= (1- pos) pt) nil
          (setq ret (list (- (match-beginning 1) 1)
                          (match-beginning       1)
                          (match-end             1)
                          bol)) ) )) ret))

(defun lpc-scan-magic-quotes ()
  (save-excursion
    (let ((qpos nil) (wbeg nil) (wend nil))
      (while (re-search-forward lpc-magic-quote-regex nil t)
        (setq qpos (+ (match-beginning 0) 3)
              wbeg (match-beginning       1)
              wend (match-end             1))
        (lpc-modify-syntax-at qpos (1+ qpos) lpc-magic-quote-comma)
        (lpc-modify-syntax-at wbeg wend      lpc-magic-symbol-name) )) ))

(defun lpc-scan-magic-quote ()
  (save-excursion
    (let ((coord nil) (qpos nil) (wbeg nil) (wend nil) (bol nil))
      (if (setq coord (lpc-magic-comma-p (1- (point))))
          (progn
            (setq qpos  (car         coord)
                  wbeg  (cadr        coord)
                  wend  (car  (cddr coord))
                  bol   (cadr (cddr coord)))
            ;;(message "magic pattern at (%d %d %d)" qpos wbeg wend)
            (lpc-modify-syntax-at qpos (1+ qpos) lpc-magic-quote-comma)
            (lpc-modify-syntax-at wbeg wend      lpc-magic-symbol-name)
            (font-lock-fontify-region bol wend) )) )) )

(defun lpc-maybe-quote-ref (arg)
  "Kludge to work around multiple syntactic meanings of `,' `[' et al in LPC."
  (interactive "P")
  (self-insert-command (prefix-numeric-value arg))
  (lpc-scan-magic-quote) )

(defvar lpc-mode-map nil "Keymap for LPC mode buffers.")
(if lpc-mode-map
    nil
  (setq lpc-mode-map (c-make-inherited-keymap))
  (define-key lpc-mode-map (kbd "C-c :")   'c-scope-operator)
  (define-key lpc-mode-map "{"             'lpc-maybe-electric-brace)
  (define-key lpc-mode-map "}"             'lpc-maybe-electric-brace)
  (define-key lpc-mode-map ","             'lpc-maybe-quote-ref)
  (define-key lpc-mode-map (kbd "C-c C-e") 'c-macro-expand) )

(defvar lpc-mode-hook nil)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; font-lock support:

(defvar  lpc-reference-face 'lpc-reference-face)
(defface lpc-reference-face
  '((((class color) (background  dark)) (:foreground "bisque"   ))
    (((class color) (background light)) (:foreground "dark blue")))
  "LPC mode face for quoted symbols" :group 'lpc)

(defconst lpc-type-depth (regexp-opt-depth lpc-type-regex))

(defvar lpc-builtin-face nil
  "XEmacs doesn't have `font-lock-builtin-face' \(as of v21.4\)")

(if (not (fboundp 'font-lock-match-c-style-declaration-item-and-skip-to-next))
    (defalias 'font-lock-match-c-style-declaration-item-and-skip-to-next
      'font-lock-match-c++-style-declaration-item-and-skip-to-next))

(cond
 ((facep 'font-lock-builtin-face)
  (setq lpc-builtin-face 'font-lock-builtin-face))
 ((not (facep 'lpc-builtin-face))
  (defface lpc-builtin-face
    '(( ((type    tty)(class      color)) (:foreground "cyan" :weight bold))
      ( ((class color)(background light)) (:foreground "Purple"           ))
      ( ((class color)(background  dark)) (:foreground "Cyan"             ))
      (   t                               (:bold                         t)))
    "XEmacs doesn't have `font-lock-builtin-face' \(as of v21.4\)"
    :group 'lpc)
  (setq lpc-builtin-face 'lpc-builtin-face)) )

(defconst lpc-font-lock-map
  (append
   c-font-lock-keywords-1
   (list
    ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    ;; what follows is mostly ripped from font-lock.el, mostly...
    `(eval . (cons (concat "\\<\\(" ,lpc-type-regex "\\)\\>")
		   'font-lock-type-face))

    ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    ;; native LPC highlighting: quoted character and lambda thingies
    '("\\('.'\\|'\\\\.'\\)"             1 font-lock-string-face  keep)
    '("'\\([^}, \t;]+\\)"               1 lpc-reference-face     keep)

    ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    ;; what follows is mostly ripped from font-lock.el, mostly...
    (concat "\\<\\(" lpc-default-highlight-regex "\\)\\>")

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

    '(":" ("^[ \t]*\\(\\sw+\\)[ \t]*:[ \t]*$"
	   (beginning-of-line) (end-of-line)
	   (1 font-lock-constant-face)))

    `(eval . (list
	      (concat "\\<\\(" ,lpc-type-regex "\\)\\>"
		      "\\([ \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
				 (+ ,lpc-type-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)))))

    ;; Fontify anything at beginning of line as a declaration or definition.
    '("^\\(\\sw+\\)\\>\\([ \t*]+\\sw+\\>\\)*"
      (1 font-lock-type-face)
      (font-lock-match-c-style-declaration-item-and-skip-to-next
       (goto-char (or (match-beginning 2) (match-end 1))) nil
       (1 (if (match-beginning 2)
	      font-lock-function-name-face
	    font-lock-variable-name-face))))
    ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    ;; native LPC highlighting: lambda thingies
    `("{\\s-*\\(#\\)"                   1 ,lpc-builtin-face      keep)
    '("'\\(,\\)[,} \t\n]"               1 lpc-reference-face     keep)
    ;; misc other stuff:
    `("\\(\\binherit\\)\\s-+\\s\".+\";" 1 ,lpc-builtin-face         t)
    )
   )
  )

(defun lpc-set-font-lock-defaults ()
  "Set up LPC mode font-lock stuff."
  (let ((font-lock-defaults '(lpc-font-lock-map 
			      nil
			      nil
			      ((?_  . "w") (?\' . "'"))
			      beginning-of-defun
			      (font-lock-mark-block-function . mark-defun))))
    (font-lock-set-defaults)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; bring it all together:

(c-lang-defconst c-mode-syntax-table   lpc lpc-mode-syntax-table)
(c-lang-defconst c-identifier-ops      lpc '((prefix "::")))
(c-lang-defconst c-string-escaped-newlines lpc t)
(c-lang-defconst c-multiline-string-start-char 'lpc t)
(c-lang-defconst c-special-brace-lists lpc lpc-special-brace-lists)
(c-lang-defconst c-primitive-type-kwds lpc lpc-type-keywords)
(c-lang-defconst c-modifier-kwds       lpc lpc-specifier-keywords)
(c-lang-defconst c-other-decl-kwds     lpc lpc-other-decl-keywords)
(c-lang-defconst c-ref-list-kwds       lpc nil)
(c-lang-defconst c-paren-type-kwds     lpc nil)
(c-lang-defconst c-operators           
  lpc `(;; Preprocessor.
	(prefix     "#" ) 
	(left-assoc "##")
	,@(c-lang-const c-identifier-ops) ;; Primary.
	;; Postfix.
	(left-assoc "." "->")
	(postfix "++" "--" "[" "]" "(" ")")
	;; Unary.
	(prefix "++" "--" "+" "-" "!" "~" "*" "&"
		"(" ")"			; Cast.
		"[" "]")		; Type cast.
	
	(left-assoc "*" "/" "%")       ;; Multiplicative.
	(left-assoc "+" "-") 	       ;; Additive.
	(left-assoc "<<" ">>")         ;; Shift.
	(left-assoc "<" ">" "<=" ">=") ;; Relational.
	(left-assoc "==" "!=")         ;; Equality.
	(left-assoc "&")               ;; Bitwise and.
	(left-assoc "^")               ;; Bitwise exclusive or.
	(left-assoc "|")               ;; Bitwise or.
	(left-assoc "&&")              ;; Logical and.
	(left-assoc "||")              ;; Logical or.
	(right-assoc-sequence "?" ":") ;; Conditional.
	;; Assignment.
	(right-assoc ,@(c-lang-const c-assignment-operators))
	(left-assoc ","))              ;; Sequence.
  )
(c-lang-defconst c-paragraph-start     lpc "$")
(c-lang-defconst c-paragraph-separate  lpc "$")
(c-lang-defconst c-type-list-kwds      lpc lpc-other-decl-keywords)
(c-lang-defconst c-paren-type-kwds     lpc 
		 '("array" "function" "int" "mapping" "object"))
(c-lang-defconst c-block-stmt-2-kwds   lpc '("for" "if" "switch" "while"))
(c-lang-defconst c-constant-kwds       lpc '("NULL"))
(c-lang-defconst c-primary-expr-kwds   lpc nil)
(c-lang-defconst c-inexpr-block-kwds   lpc nil)
(c-lang-defconst c-inexpr-class-kwds   lpc nil)
(c-lang-defconst c-opt-type-concat-key lpc "\\([\+]\\)\\([^+]\\)")

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(easy-menu-define lpc-menu lpc-mode-map 
                  "LPC mode commands"
		  (cons "LPC" (c-lang-const c-mode-menu lpc)))

(defun lpc-mode ()
  (interactive)
  (kill-all-local-variables)
  (c-initialize-cc-mode t)
  (set-syntax-table lpc-mode-syntax-table)
  ;; XEmacs ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  ;; we _have_ to have syntax-table text properties, so force it. Am
  ;; told it is _very_ slow in XEmacs, so make sure it's local only.
  (if (boundp 'parse-sexp-lookup-properties)
      (set (make-local-variable 'parse-sexp-lookup-properties) t)
    (if (boundp 'lookup-syntax-properties)
	  (set (make-local-variable 'lookup-syntax-properties) t)))
  ;; done with Xemacs stuff ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  (setq major-mode             'lpc-mode
 	mode-name              "LPC")
  (use-local-map lpc-mode-map)
  (c-init-language-vars lpc-mode)
  (c-common-init       'lpc-mode)
  (easy-menu-add        lpc-menu)
  (lpc-set-font-lock-defaults)
  (lpc-scan-magic-quotes)
  (if (not noninteractive)
      (turn-on-font-lock)
    (let ((font-lock-mode t) (noninteractive nil))
      (turn-on-font-lock)))
  (run-hooks 'c-mode-common-hook)
  (run-hooks 'lpc-mode-hook)
  (c-update-modeline)
  )

(provide 'lpc-mode)
;; lpc-mode.el ends here