;;
;;  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プロジェクトは，本ソフトウェアに関して，特定の使用目的
;;  に対する適合性も含めて，いかなる保証も行わない．また，本ソフトウェ
;;  アの利用により直接的または間接的に生じたいかなる損害に関しても，そ
;;  の責任を負わない．
;; 
;; 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;  tf-mode for xyzzy
;;
;;
;;  ロード方法．
;;  1. tf-mode.l を site-lisp/ の下に，
;;     tf を etc/ の下にそれぞれおく．
;;  2. 下記を .xyzzy に追加する．
;;  
;; (require "tf-mode")
;; (push '("\\.tf$" . tf-mode) *auto-mode-alist*)
;;

(provide "tf-mode")

(in-package "editor")

(export '(tf-mode
         *tf-mode-hook* *tf-indent-column*
	 *tf-tab-always-indent*))

(defvar *tf-mode-hook* nil)

;; (add-hook '*tf-mode-hook* #'(lambda()
;;   (set-syntax-match (syntax-table) #\( #\))
;;   (set-syntax-match (syntax-table) #\{ #\})
;;   (set-syntax-match (syntax-table) #\[ #\])
;; ))

(defvar *tf-mode-map* nil)
(unless *tf-mode-map*
  (setq *tf-mode-map* (make-sparse-keymap))
  (define-key *tf-mode-map* #\TAB 'tf-indent-line)
  )

(defvar *tf-mode-syntax-table* nil)
(unless *tf-mode-syntax-table*
  (setq *tf-mode-syntax-table* (make-syntax-table)))
;;  (set-syntax-start-comment *tf-mode-syntax-table* #\$\t t)
;;  (set-syntax-end-comment *tf-mode-syntax-table* #\LFD nil t))


;; etc/tfのキーワードを参照

(defvar *tf-keyword-hash-table* nil)
(defvar *tf-keyword-file* "tf")

;; 色づけするキーワード

(defvar *tf-regexp-keyword-list* nil)
(setq *tf-regexp-keyword-list*
     (compile-regexp-keyword-list
      '(
	 ("^\$[ \t].*" nil (:keyword :comment :line) nil nil nil)
	 ("\\([\$]\\)\\(IF\\|FOREACH\\|JOINEACH\\)\\([ \t]\\)" nil (:keyword 0 :bold) nil 2 nil)
	 ("\\([\$]\\)\\(END\\|ELSE\\)\\([\$]\\)" nil (:keyword 0 :bold) nil 2 2)
	 ("\\([\$]\\)\\(FUNCTION\\|FILE\\|INCLUDE\\)\\([ \t]\\)" nil (:keyword 1 :bold) nil 2 nil)
	 ("\\([\$]\\)\\(ERROR\\|WORNING\\)\\([ \t\$]\\)" nil (:keyword 1 :bold) nil 2 2)
	 ("\\([\$]\\)\\(SPC\\|TAB\\|NL\\|ARGC\\|ARGV\\|RESULT\\)\\([\$]\\)" nil (:keyword :string :bold) nil 2 2)
	 ("\\([\"]\\)\\([^\"]\\)*\\([\"]\\)" nil (:keyword :string) nil nil nil)
	 ("\\([\']\\)\\([^\']\\)*\\([\']\\)" nil (:keyword :string) nil nil nil)
	)
      ))
;	("正規表現" 大文字小文字の区別をしない？ color 有効範囲 どこから どこまで)


;;--------------------------------------------------------------------------
;;
;;  インデントに関する定義
;;
;;--------------------------------------------------------------------------

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

(defvar *tf-block-beg-re*
  "[\$]\\(IF\\|FOREACH\\|JOINEACH\\|FUNCTION\\)[ ]")
(defvar *tf-block-mid-re*
  "\$ELSE[\$]")
(defvar *tf-block-end-re* "\$END[\$]")

(defvar *tf-indent-column* 4)

(defun tf-space-line ()
  "空行かどうか"
  (save-excursion
    (goto-bol)
    (looking-at "\\([ \t]*$\\|^\$[ \t]\\)")))

(defun tf-previous-line ()
  "空行じゃない行まで戻る"
  (while (forward-line -1)
    ;(message-box (format nil "=> ~D" (current-line-number)))
    (unless (tf-space-line)
	(return-from tf-previous-line t))))

(defun calc-tf-indent ()
  "インデントする数を数える"
  (let ((column 0) (curp (point)))
    (save-excursion
      ;前の行を調べる
      (when (tf-previous-line)
	(goto-bol)
	(skip-chars-forward " \t")
	; インデント数
	(setq column (current-column))
	;(message-box (format nil "column1: ~D" column))
	(save-restriction
	  (narrow-to-region (progn (goto-eol) (point))
			    (progn (goto-bol) (point)))
	  (skip-chars-forward " \t")
	  ; 開きものがあればインデント数を増やす
	  (cond
	   ((looking-at *tf-block-beg-re*)
	    (setq column (+ column *tf-indent-column*)))
	   ((looking-at *tf-block-mid-re*)
	    (setq column (+ column *tf-indent-column*)))
	  )
	)))
    ;(message-box (format nil "column2: ~D" column))
    ; 現在の行を調べる
    (save-excursion
      (save-restriction
	(narrow-to-region (progn (goto-eol) (point))
			  (progn (goto-bol) (point)))
	(goto-bol)
	(skip-chars-forward " \t")
	; 閉じものがあればインデント数を減らす
	(cond
	 ((looking-at *tf-block-end-re*)
	  (setq column (- column *tf-indent-column*)))
	 ((looking-at *tf-block-mid-re*)
	  (setq column (- column *tf-indent-column*)))
	)))
    column
  ))

(defun tf-not-comment-line ()
  (save-excursion
    (progn
      (beginning-of-line)
      (if (looking-at "^\$[ \t]")
	  nil
	  t
	  )
      )
    ))

(defun tf-indent-line ()
  (interactive "*")
  (if (or (not (interactive-p))
	  *tf-tab-always-indent*
	  (save-excursion
	    (skip-chars-backward " \t")
	    (bolp)))
    (if (tf-not-comment-line) ;; コメント行でなければ実行する
      ; ここを変えただけ
      (let ((column (calc-tf-indent)))
	(when (integerp column)
	  (save-excursion
	    (goto-bol)
	    (delete-region (point)
			   (progn
			     (skip-chars-forward " \t")
			     (point)))
	    (indent-to column)))
	(if (and (bolp) column)
	    (skip-chars-forward " \t")))
	 )
    (insert "\t"))
  t)

;; -------------------------------------------------------------------------
;;
;;  tf-mode本体
;;
;; -------------------------------------------------------------------------

(defun tf-mode ()
 (interactive)
 (kill-all-local-variables)
 (setq buffer-mode 'tf-mode)
 (setq mode-name "tf")
 (use-keymap *tf-mode-map*)
 (make-local-variable 'mode-specific-indent-command)
 (setq mode-specific-indent-command #'tf-indent-line)
 (use-syntax-table *tf-mode-syntax-table*)
 (and *tf-keyword-file*
    (null *tf-keyword-hash-table*)
    (setq *tf-keyword-hash-table*
      (load-keyword-file *tf-keyword-file*)))
 (when *tf-keyword-hash-table*
    (make-local-variable 'keyword-hash-table)
    (setq keyword-hash-table *tf-keyword-hash-table*))
 (make-local-variable 'regexp-keyword-list)
 (setq regexp-keyword-list *tf-regexp-keyword-list*)
 (run-hooks '*tf-mode-hook*))

;; -------------------------------------------------------------------------
;;
;;  $END$の対応を探す
;;
;; -------------------------------------------------------------------------

;; 対応を探すための正規表現
(defvar *tf-block-keyword* "[\$]\\(IF[ \t]\\|FOREACH[ \t]\\|JOINEACH[ \t]\\|FUNCTION[ \t]\\|END[\$]\\)")
(defvar *tf-block-tag* 'tf-block)


(defvar-local *stored-text-attributes* nil)

(defun save-text-attributes (&optional start end)
  (setq *stored-text-attributes*
        (list-text-attributes start end)))

(defun restore-text-attributes ()
  (mapc (lambda (attr) (apply #'set-text-attribute attr))
        *stored-text-attributes*)
  (setq *stored-text-attributes* nil))


(defun tf-block-pre-hook ()
  (delete-text-attributes *tf-block-tag*)
  (restore-text-attributes)
  )


(defun tf-block-hook ()
  (progn
    (if (string-match "tf" mode-name) ;; tf-modeのときだけ
	(let (now)
	  (save-excursion
	    (progn
	      (setq now (point))
	      (if (string-match "\$END\$" (buffer-substring (- now 5) (- now 1))) ;; $END$の後ろにカーソル
		  (progn
		    (goto-char now)
		    (save-text-attributes)
		    (do-tf-block) ;; 本体呼び出し
		    )
		)
	      )
	    )
	  )
      )
    )
  )

(defun do-tf-block ()
  (let (from to end_depth line_no line_string tmp_string now)
    (save-excursion
      (setq from (point))
      (backward-char 1)
      (if (scan-buffer *tf-block-keyword* :reverse t :regexp t)
	  (progn
	    (setq end_depth 1) ;; $END$の深さ
	    (while (> end_depth 0) ;; $END$の対応が見つかるまで
	      (progn
		(if (scan-buffer *tf-block-keyword* :reverse t :regexp t :no-dup t)
		    (progn
		      (setq tmp_string (match-string 0))
		      (setq now (point))
		      (beginning-of-line)
		      (if (not (string-match "^$[ \t]" (buffer-substring (point) (+ (point) 2)))) ;; コメントアウト中かチェック
			  (progn
			    (goto-char now)
			    (if (string-match "[\$]END[\$]" tmp_string) ;; $END$が見つかった
				 (setq end_depth (+ end_depth 1)) ;; 深さ+1
			      (progn ;; $END$以外が見つかった
			  	 (setq end_depth (- end_depth 1)) ;; 深さ-1
				  ))
			    )
			)
		      )
		  (setq end_depth -1) ;; $END$の対応がない
		  )))
	    (if (= end_depth 0) ;; $END$の対応があった
		(progn
		  (setq to (point))
		  (setq line_no (current-line-number))
		  (end-of-line)
		  (setq line_string (buffer-substring to (point)))
		  (message "~d : ~s" line_no line_string) ;; 行番号,行内容を表示
		  (set-text-attribute from to *tf-block-tag* :bold t) ;; 囲まれた範囲を強調
		  )
	      (message "ないかもだよ") ;; $END$の対応がなかった
	      )
	    )
	)
      )
    )
  )


(add-hook '*pre-command-hook* 'tf-block-pre-hook) ;; post-command-hookに追加
(add-hook '*post-command-hook* 'tf-block-hook) ;; post-command-hookに追加