;;
;;  TOPPERS Software
;;      Toyohashi Open Platform for Embedded Real-Time Systems
;; 
;;  Copyright (C) 2010 by TAKUYA
;;              Embedded and Real-Time Systems Laboratory
;;              Graduate School of Information Science, Nagoya Univ., JAPAN
;; 
;;  上記著作権者は，以下の(1)〜(4)の条件を満たす場合に限り，本ソフトウェ
;;  ア（本ソフトウェアを改変したものを含む．以下同じ）を使用・複製・改
;;  変・再配布（以下，利用と呼ぶ）することを無償で許諾する．
;;  (1) 本ソフトウェアをソースコードの形で利用する場合には，上記の著作
;;      権表示，この利用条件および下記の無保証規定が，そのままの形でソー
;;      スコード中に含まれていること．
;;  (2) 本ソフトウェアを，ライブラリ形式など，他のソフトウェア開発に使
;;      用できる形で再配布する場合には，再配布に伴うドキュメント（利用
;;      者マニュアルなど）に，上記の著作権表示，この利用条件および下記
;;      の無保証規定を掲載すること．
;;  (3) 本ソフトウェアを，機器に組み込むなど，他のソフトウェア開発に使
;;      用できない形で再配布する場合には，次のいずれかの条件を満たすこ
;;      と．
;;    (a) 再配布に伴うドキュメント（利用者マニュアルなど）に，上記の著
;;        作権表示，この利用条件および下記の無保証規定を掲載すること．
;;    (b) 再配布の形態を，別に定める方法によって，TOPPERSプロジェクトに
;;        報告すること．
;;  (4) 本ソフトウェアの利用により直接的または間接的に生じるいかなる損
;;      害からも，上記著作権者およびTOPPERSプロジェクトを免責すること．
;;      また，本ソフトウェアのユーザまたはエンドユーザからのいかなる理
;;      由に基づく請求からも，上記著作権者およびTOPPERSプロジェクトを
;;      免責すること．
;; 
;;  本ソフトウェアは，無保証で提供されているものである．上記著作権者お
;;  よびTOPPERSプロジェクトは，本ソフトウェアに関して，特定の使用目的
;;  に対する適合性も含めて，いかなる保証も行わない．また，本ソフトウェ
;;  アの利用により直接的または間接的に生じたいかなる損害に関しても，そ
;;  の責任を負わない．
;; 
;; 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;  cdl-mode for xyzzy
;;
;;
;;  ロード方法．
;;  1. cdl-mode.l を site-lisp/ の下に，
;;     CDL を etc/ の下にそれぞれおく．
;;  2. 下記を .xyzzy に追加する．
;;  
;;  (require "cdl-mode")
;;  (push '("\\.cdl$" . cdl-mode) *auto-mode-alist*)
;;

(provide "cdl-mode")

(in-package "editor")

(export '(*cdl-mode-hook* cdl-indent-level cdl-continued-statement-offset
	  cdl-argdecl-indent cdl-brace-offset cdl-brace-imaginary-offset
	  cdl-label-offset cdl-comment-indent))
(export '(cdl-mode cdl-indent-line cdl-newline-and-indent cdl-electric-insert
	  cdl-electric-close indent-cpp-directive
	  *cdl-keyword-file* *cdl-indent-tabs-mode*
	  *cdl-tab-always-indent* *cdl-comment-column*
	  *cdl-comment-c++-style*))

(defvar *cdl-mode-hook* nil)

(unless (boundp 'cdl-indent-level)
  (setq cdl-indent-level 2)
  (setq cdl-continued-statement-offset 2)
  (setq cdl-argdecl-indent 5)
  (setq cdl-brace-offset 0)
  (setq cdl-brace-imaginary-offset 0)
  (setq cdl-label-offset -2)
  (setq cdl-comment-indent 2))

(defvar *cdl-tab-always-indent* t)

(defvar *cdl-indent-tabs-mode* nil)
(defvar *cdl-comment-column* nil)
(defvar *cdl-comment-c++-style* nil)

(defvar *cdl-keyword-hash-table* nil)
(defvar *cdl-keyword-file* "CDL")

(defvar *cdl-mode-syntax-table* nil)
(unless *cdl-mode-syntax-table*
  (setq *cdl-mode-syntax-table* (make-syntax-table))
  (do ((x #x21 (1+ x)))((>= x #x7f))
    (let ((c (code-char x)))
      (unless (alphanumericp c)
	(set-syntax-punctuation *cdl-mode-syntax-table* c))))
  (set-syntax-option *cdl-mode-syntax-table*
		     *syntax-option-c-preprocessor*)
  (set-syntax-string *cdl-mode-syntax-table* #\")
  (set-syntax-string *cdl-mode-syntax-table* #\')
  (set-syntax-escape *cdl-mode-syntax-table* #\\)
  (set-syntax-symbol *cdl-mode-syntax-table* #\_)
  (set-syntax-symbol *cdl-mode-syntax-table* #\#)
  (set-syntax-match *cdl-mode-syntax-table* #\( #\))
  (set-syntax-match *cdl-mode-syntax-table* #\{ #\})
  (set-syntax-match *cdl-mode-syntax-table* #\[ #\])
  (set-syntax-start-multi-comment *cdl-mode-syntax-table* "/*")
  (set-syntax-end-multi-comment *cdl-mode-syntax-table* "*/")
  (set-syntax-start-c++-comment *cdl-mode-syntax-table* #\/)
  (set-syntax-end-c++-comment *cdl-mode-syntax-table* #\LFD))

(defvar *cdl-mode-map* nil)
(unless *cdl-mode-map*
  (setq *cdl-mode-map* (make-sparse-keymap))
  (define-key *cdl-mode-map* #\{ 'cdl-electric-insert)
  (define-key *cdl-mode-map* #\: 'cdl-electric-insert)
  (define-key *cdl-mode-map* #\# 'cdl-electric-insert)
  (define-key *cdl-mode-map* #\} 'cdl-electric-close)
  (define-key *cdl-mode-map* #\C-h 'backward-delete-char-untabify-or-selection)
  (define-key *cdl-mode-map* #\TAB 'cdl-indent-line)
  (define-key *cdl-mode-map* #\C-M-q 'indent-sexp)
  (define-key *cdl-mode-map* #\RET 'cdl-newline-and-indent))

(defvar *cdl-mode-abbrev-table* nil)
(unless *cdl-mode-abbrev-table*
  (define-abbrev-table '*cdl-mode-abbrev-table*))

(defun cdl-indent-line ()
  (interactive "*")
  (if (or (not (interactive-p))
	  *cdl-tab-always-indent*
	  (save-excursion
	    (skip-chars-backward " \t")
	    (bolp)))
      (case (save-excursion
	      (goto-bol)
	      (parse-point-syntax))
	(:string)
	(:comment
	 (let ((column (calc-cdl-comment-indent)))
	   (when (integerp column)
	     (smart-indentation column))))
	(t
	 (let ((column (calc-c-indent)))
	   (when (integerp column)
	     (smart-indentation column)))))
    (insert "\t"))
  t)

(defun cdl-newline-and-indent (&optional (arg 1))
  (interactive "*p")
  (delete-trailing-spaces)
  (insert #\LFD arg)
  (cdl-indent-line))

(defun cdl-electric-insert (&optional (arg 1))
  (interactive "*p")
  (unless (prog1
	      (parse-point-syntax)
	    (self-insert-command arg))
    (cdl-indent-line))
  t)

(defun cdl-electric-close (&optional (arg 1))
  (interactive "*p")
  (unless (prog1
	      (parse-point-syntax)
	    (self-insert-command arg))
    (cdl-indent-line))
  (save-excursion
    (forward-char -1)
    (and (goto-matched-parenthesis)
	 (show-matched-parenthesis)))
  t)

(defun cpp-indent-to (to)
  (skip-chars-forward " \t")
  (when (/= to (current-column))
    (delete-horizontal-spaces)
    (indent-to to)))

(defun indent-cpp-directive ()
  (interactive)
  (save-excursion
    (let ((column 1))
      (goto-char (point-min))
      (while (scan-buffer "^#" :regexp t)
	(forward-char 1)
	(cond ((looking-at "[ \t]*if")
	       (cpp-indent-to column)
	       (setq column (1+ column)))
	      ((looking-at "[ \t]*el\\(se\\|if\\)")
	       (cpp-indent-to (1- column)))
	      ((looking-at "[ \t]*endif")
	       (setq column (1- column))
	       (when (zerop column)
		 (error "Unmatched \"#endif\" at line ~d" (current-line-number)))
	       (cpp-indent-to column))
	      (t (cpp-indent-to column)
		 (if (looking-for "define")
		     (while (and (progn
				   (goto-eol)
				   (forward-char -1)
				   (looking-for "\\"))
				 (forward-line 1))
		       (cdl-indent-line))))))
      (when (/= column 1)
	(error "Unmatched \"#if\" or \"#ifdef\""))))
  t)

(defun cdl-comment-indent ()
  (save-excursion
    (let ((opoint (point)))
      (goto-bol)
      (cond ((looking-at "/\\*\\|//")
	     0)
	    (t
	     (skip-chars-forward " \t")
	     (cond ((looking-at "}[ \t]*\\($\\|/\\*\\|//\\)")
		    (+ (current-column) 2))
		   ((looking-at "#[ \t]*\\(endif\\|else\\)\\>")
		    (goto-char (match-end 1))
		    (+ (current-column) 2))
		   ((or (looking-at "/\\*\\|//")
			(eolp))
		    (calc-c-indent))
		   ((zerop comment-column)
		    0)
		   (t
		    (goto-char opoint)
		    (skip-chars-backward " \t")
		    (max (1+ (current-column)) comment-column))))))))

(defvar-local cdl-comment-indent-variable 'cdl-comment-indent)

(defun calc-cdl-comment-indent ()
  (save-excursion
    (goto-bol)
    (skip-chars-forward " \t")
    (let ((eolp (eolp)))
      (when (and (or eolp (looking-for "*"))
		 (scan-buffer "/*" :reverse t))
	(while (and (eq (parse-point-syntax) ':comment)
		    (scan-buffer "/*" :reverse t :no-dup t)))
	(+ (current-column)
	   (if eolp
	       (if (symbolp cdl-comment-indent-variable)
		   (symbol-value cdl-comment-indent-variable)
		 0)
	     1))))))

(autoload 'cdl-build-summary-of-functions "cfns" nil)
(autoload 'cdl-maketags "cfns")
(pushnew '(cdl-maketags "*.c" "*.cpp" "*.cxx" "*.cc" "*.h" "*.hpp" "*.hxx" "*.inl")
	 *maketags-list* :key #'car)

(defun cdl-tags-find-target ()
  (let* ((opoint (point))
	 (tail (progn
		 (skip-chars-forward "a-zA-Z0-9_")
		 (point)))
	 (name (buffer-substring tail
				 (progn
				   (skip-chars-backward "a-zA-Z0-9_")
				   (when (or (looking-back "::~")
					     (looking-back "->~")
					     (looking-back ".~"))
				     (forward-char -1))
				   (point))))
	 class)
    (cond ((looking-back "::")
	   (forward-char -2)
	   (let ((point (point)))
	     (when (looking-back ">")
	       (let ((depth 1))
		 (loop
		   (forward-char -1)
		   (skip-chars-backward "^<>")
		   (cond ((looking-back ">")
			  (incf depth))
			 ((looking-back "<")
			  (decf depth)
			  (when (zerop depth)
			    (forward-char -1)
			    (return)))
			 (t
			  (return)))))
	       (skip-chars-backward " \t\n\f")
	       (setq point (point)))
	     (setq class (buffer-substring point
					   (progn
					     (skip-chars-backward "a-zA-Z0-9_")
					     (point))))))
	  (t
	   (goto-char tail)
	   (when (looking-for "::")
	     (forward-char 2)
	     (setq class name)
	     (setq name (buffer-substring
			 (point)
			 (progn
			   (skip-chars-forward "a-zA-Z0-9_")
			   (point)))))))
    (goto-char opoint)
    (values class name '(function structure))))

(defun cdl-tags-find-point-1 (re start reverse structurep lgoal)
  (let* ((limit (if reverse
		    (- start *jump-tag-limit*)
		  (+ start *jump-tag-limit*)))
	 (goal (progn
		 (goto-char start)
		 (while (scan-buffer re :regexp t :limit limit :tail t :reverse reverse)
		   (let ((opoint (point))
			 (point0 (match-beginning 0))
			 (start (match-end 1)))
		     (unless structurep
		       (forward-char -1)
		       (forward-sexp 1 t))
		     (skip-white-forward)
		     (unless (looking-for ";")
		       (return start))
		     (goto-char (if reverse (1- point0) opoint)))))))
    (if lgoal
	(if goal
	    (if (< (abs (- lgoal start)) (abs (- goal start)))
		lgoal goal)
	  lgoal)
      goal)))

(defun cdl-tags-find-point (class name type point)
  (let* ((structurep (eq type 'structure))
	 (re (compile-regexp (if structurep
				 (concat "\\_<\\(?:struct\\|class\\|interface\\)[ \t\n\f]+\\("
					 name "\\)\\_>")
			       (concat "\\_<\\(" name "\\)[ \t\n\f]*("))))
	 goal)
    (setq goal (cdl-tags-find-point-1 re point t structurep nil))
    (setq goal (cdl-tags-find-point-1 re point nil structurep goal))
    goal))

;; 色づけするキーワード（正規表現）

(defvar *cdl-regexp-keyword-list* nil)
(setq *cdl-regexp-keyword-list*
     (compile-regexp-keyword-list
      '(
	 ("\\([\[]\\)\\(in\\|out\\|inout\\|oneway\\)\\([\]]\\)" nil (:keyword 2) nil 2 2)
	)
      ))
;	("正規表現" 大文字小文字の区別をしない？ color 有効範囲 どこから どこまで)

(defun cdl-mode ()
  (interactive)
  (kill-all-local-variables)
  (setq mode-name "CDL")
  (setq buffer-mode 'cdl-mode)
  (use-syntax-table *cdl-mode-syntax-table*)
  (use-keymap *cdl-mode-map*)
  (make-local-variable 'mode-specific-indent-command)
  (setq mode-specific-indent-command 'cdl-indent-line)
  (make-local-variable 'paragraph-start)
  (setq paragraph-start "^$\\|\f")
  (make-local-variable 'paragraph-separate)
  (setq paragraph-separate paragraph-start)
  (make-local-variable 'indent-tabs-mode)
  (setq indent-tabs-mode *cdl-indent-tabs-mode*)
  (make-local-variable 'tags-find-target)
  (setq tags-find-target #'cdl-tags-find-target)
  (make-local-variable 'tags-find-point)
  (setq tags-find-point #'cdl-tags-find-point)
  (make-local-variable 'build-summary-function)
  (setq build-summary-function 'cdl-build-summary-of-functions)
  (and *cdl-keyword-file*
       (null *cdl-keyword-hash-table*)
       (setq *cdl-keyword-hash-table*
	     (load-keyword-file *cdl-keyword-file*)))
  (when *cdl-keyword-hash-table*
    (make-local-variable 'keyword-hash-table)
    (setq keyword-hash-table *cdl-keyword-hash-table*))
  (setq *local-abbrev-table* *cdl-mode-abbrev-table*)
  (if *cdl-comment-c++-style*
      (setq comment-start "// " comment-end "")
    (setq comment-start "/* " comment-end " */"))
  (setq comment-start-skip "/\\(\\*+\\|/\\)[ \t]*")
  (setq comment-indent-function 'cdl-comment-indent)
  (when *cdl-comment-column*
    (setq comment-column *cdl-comment-column*))
  (make-local-variable 'regexp-keyword-list)
  (setq regexp-keyword-list *cdl-regexp-keyword-list*)
  (run-hooks '*cdl-mode-hook*))