psyclpc/etc/lpc-mode.el

;; LPC mode
;;
;; Emacs Lisp Archive Entry
;; Package: lpc-mode
;; Filename: lpc-mode.el
;; Version: 0.12
;; 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
;; Last-Updated: Tue 2002-09-17 23:59:51 +0100

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

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

(defconst lpc-mode-version "0.12")

(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"))

  (lpc-defsyntax specifier
		 "LPC declaration specifier keywords."
		 ("nomask" "private" "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-C++-comment-start-regexp)
(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
    (progn
      ;;(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     ))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; 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 "\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 "\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")

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

(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))
    
    (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))))
    ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    ;; and now native LPC highlighting:
    '("\\('.'\\|'\\\\.'\\)"             1 font-lock-string-face  keep)
    ;; lambda thingies
    '("{\\s-*\\(#\\)"                   1 font-lock-builtin-face keep)
    '("'\\([^}, \t;]+\\)"               1 lpc-reference-face     keep)
    '("'\\(,\\)[,} \t\n]"               1 lpc-reference-face     keep)
    ;; 
    '("\\(\\binherit\\)\\s-+\\s\".+\";" 1 font-lock-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:

(defun lpc-mode ()
  (interactive)
  (c-initialize-cc-mode)
  (kill-all-local-variables)
  (set-syntax-table lpc-mode-syntax-table)
  (make-variable-buffer-local 'parse-sexp-lookup-properties)
  (set 'parse-sexp-lookup-properties t)
  (setq major-mode             'lpc-mode
 	mode-name              "LPC")
  (use-local-map lpc-mode-map)
  (c-common-init)
  (setq c-keywords             (c-identifier-re lpc-all-regex)
	c-special-brace-lists  lpc-special-brace-lists
	comment-start          "// "
 	comment-end            ""
 	c-conditional-key      lpc-conditional-regex
	c-comment-start-regexp lpc-comment-start-regex
	c-extra-toplevel-key   lpc-other-decl-regex
  	;; c-class-key         nil ;; cannot set this to nil or ""
	c-method-key           nil
 	c-baseclass-key        nil
	c-recognize-knr-p      nil
	c-lambda-key           nil
	c-inexpr-block-key     nil
	c-inexpr-class-key     nil)
  (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