source: tf-mode/trunk/tf-mode.l@ 26

;;
;;  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
;; 
;;  ã‹L’˜ìŒ ŽÒ‚́CˆÈ‰º‚Ì(1)`(4)‚ÌðŒ‚ð–ž‚½‚·ê‡‚ÉŒÀ‚èC–{ƒ\ƒtƒgƒEƒF
;;  ƒAi–{ƒ\ƒtƒgƒEƒFƒA‚ð‰ü•Ï‚µ‚½‚à‚Ì‚ðŠÜ‚ށDˆÈ‰º“¯‚¶j‚ðŽg—pE•¡»E‰ü
;;  •ÏEÄ”z•ziˆÈ‰ºC—˜—p‚ƌĂԁj‚·‚邱‚Ƃ𖳏ž‚Å‹–‘ø‚·‚éD
;;  (1) –{ƒ\ƒtƒgƒEƒFƒA‚ðƒ\[ƒXƒR[ƒh‚ÌŒ`‚Å—˜—p‚·‚éê‡‚ɂ́Cã‹L‚Ì’˜ì
;;      Œ •\Ž¦C‚±‚Ì—˜—pðŒ‚¨‚æ‚щº‹L‚Ì–³•ÛØ‹K’肪C‚»‚Ì‚Ü‚Ü‚ÌŒ`‚Ń\[
;;      ƒXƒR[ƒh’†‚ÉŠÜ‚Ü‚ê‚Ä‚¢‚邱‚ƁD
;;  (2) –{ƒ\ƒtƒgƒEƒFƒA‚ðCƒ‰ƒCƒuƒ‰ƒŠŒ`Ž®‚ȂǁC‘¼‚̃\ƒtƒgƒEƒFƒAŠJ”­‚ÉŽg
;;      —p‚Å‚«‚éŒ`‚ōĔz•z‚·‚éê‡‚ɂ́CÄ”z•z‚É”º‚¤ƒhƒLƒ…
ƒƒ“ƒgi—˜—p
;;      ŽÒƒ}ƒjƒ…
ƒAƒ‹‚Ȃǁj‚ɁCã‹L‚Ì’˜ìŒ •\Ž¦C‚±‚Ì—˜—pðŒ‚¨‚æ‚щº‹L
;;      ‚Ì–³•ÛØ‹K’è‚ðŒfÚ‚·‚邱‚ƁD
;;  (3) –{ƒ\ƒtƒgƒEƒFƒA‚ðC‹@Ší‚É‘g‚ݍž‚ނȂǁC‘¼‚̃\ƒtƒgƒEƒFƒAŠJ”­‚ÉŽg
;;      —p‚Å‚«‚È‚¢Œ`‚ōĔz•z‚·‚éê‡‚ɂ́CŽŸ‚Ì‚¢‚¸‚ê‚©‚ÌðŒ‚ð–ž‚½‚·‚±
;;      ‚ƁD
;;    (a) Ä”z•z‚É”º‚¤ƒhƒLƒ…
ƒƒ“ƒgi—˜—pŽÒƒ}ƒjƒ…
ƒAƒ‹‚Ȃǁj‚ɁCã‹L‚Ì’˜
;;        ìŒ •\Ž¦C‚±‚Ì—˜—pðŒ‚¨‚æ‚щº‹L‚Ì–³•ÛØ‹K’è‚ðŒfÚ‚·‚邱‚ƁD
;;    (b) Ä”z•z‚ÌŒ`‘Ô‚ðC•Ê‚É’è‚ß‚é•û–@‚É‚æ‚Á‚āCTOPPERSƒvƒƒWƒFƒNƒg‚É
;;        •ñ‚·‚邱‚ƁD
;;  (4) –{ƒ\ƒtƒgƒEƒFƒA‚Ì—˜—p‚É‚æ‚è’¼Ú“I‚Ü‚½‚͊ԐړI‚ɐ¶‚¶‚é‚¢‚©‚Ȃ鑹
;;      ŠQ‚©‚ç‚àCã‹L’˜ìŒ ŽÒ‚¨‚æ‚ÑTOPPERSƒvƒƒWƒFƒNƒg‚ð–Ɛӂ·‚邱‚ƁD
;;      ‚Ü‚½C–{ƒ\ƒtƒgƒEƒFƒA‚̃†[ƒU‚Ü‚½‚̓Gƒ“ƒhƒ†[ƒU‚©‚ç‚Ì‚¢‚©‚Ȃ闝
;;      —R‚ÉŠî‚­¿‹‚©‚ç‚àCã‹L’˜ìŒ ŽÒ‚¨‚æ‚ÑTOPPERSƒvƒƒWƒFƒNƒg‚ð
;;      –Ɛӂ·‚邱‚ƁD
;; 
;;  –{ƒ\ƒtƒgƒEƒFƒA‚́C–³•ÛØ‚Å’ñ‹Ÿ‚³‚ê‚Ä‚¢‚é‚à‚Ì‚Å‚ ‚éDã‹L’˜ìŒ ŽÒ‚¨
;;  ‚æ‚ÑTOPPERSƒvƒƒWƒFƒNƒg‚́C–{ƒ\ƒtƒgƒEƒFƒA‚ÉŠÖ‚µ‚āC“Á’è‚ÌŽg—p–Ú“I
;;  ‚ɑ΂·‚é“K‡«‚àŠÜ‚߂āC‚¢‚©‚È‚é•ÛØ‚às‚í‚È‚¢D‚Ü‚½C–{ƒ\ƒtƒgƒEƒF
;;  ƒA‚Ì—˜—p‚É‚æ‚è’¼Ú“I‚Ü‚½‚͊ԐړI‚ɐ¶‚¶‚½‚¢‚©‚Ȃ鑹ŠQ‚ÉŠÖ‚µ‚Ä‚àC‚»
;;  ‚̐ӔC‚𕉂í‚È‚¢D
;; 
;; 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;  tf-mode for xyzzy
;;
;;
;;  ƒ[ƒh•û–@D
;;  1. tf-mode.l ‚ð site-lisp/ ‚̉º‚ɁC
;;     tf ‚ð etc/ ‚̉º‚É‚»‚ꂼ‚ꂨ‚­D
;;  2. ‰º‹L‚ð .xyzzy ‚ɒljÁ‚·‚éD
;;  
;; (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)
  (define-key *tf-mode-map* '(#\C-c #\I) 'tf-indent-region)
  )

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


;; etc/tf‚̃L[ƒ[ƒh‚ðŽQÆ

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

;; F‚¯‚·‚éƒL[ƒ[ƒh

(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)
        )
      ))
;       ("³‹K•\Œ»" ‘啶Žš¬•¶Žš‚Ì‹æ•Ê‚ð‚µ‚È‚¢H color —LŒø”ÍˆÍ ‚Ç‚±‚©‚ç ‚Ç‚±‚Ü‚Å)


;;--------------------------------------------------------------------------
;;
;;  ƒCƒ“ƒfƒ“ƒg‚ÉŠÖ‚·‚é’è‹`
;;
;;--------------------------------------------------------------------------

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

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

(defvar *tf-indent-column* 4)

(defun tf-space-line ()
  "‹ós‚©‚Ç‚¤‚©"
  (save-excursion
    (goto-bol)
    (looking-at "\\([ \t]*$\\|^\$[ \t]\\)")))

(defun tf-previous-line ()
  "‹ós‚¶‚á‚È‚¢s‚Ü‚Å–ß‚é"
  (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 ()
  "ƒCƒ“ƒfƒ“ƒg‚·‚鐔‚𐔂¦‚é"
  (let ((column 0) (curp (point)))
    (save-excursion
      ;‘O‚̍s‚𒲂ׂé
      (when (tf-previous-line)
        (goto-bol)
        (skip-chars-forward " \t")
        ; ƒCƒ“ƒfƒ“ƒg”
        (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")
          ; ŠJ‚«‚à‚Ì‚ª‚ ‚ê‚΃Cƒ“ƒfƒ“ƒg”‚𑝂₷
          (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))
    ; Œ»Ý‚̍s‚𒲂ׂé
    (save-excursion
      (save-restriction
        (narrow-to-region (progn (goto-eol) (point))
                          (progn (goto-bol) (point)))
        (goto-bol)
        (skip-chars-forward " \t")
        ; •Â‚¶‚à‚Ì‚ª‚ ‚ê‚΃Cƒ“ƒfƒ“ƒg”‚ðŒ¸‚ç‚·
        (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) ;; ƒRƒƒ“ƒgs‚Å‚È‚¯‚ê‚ÎŽÀs‚·‚é
      ; ‚±‚±‚ð•Ï‚¦‚½‚¾‚¯
      (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)

(defun tf-indent-region (from to)
  (interactive "*r")
  (if (> from to)
      (rotatef from to))
  (save-excursion
    (save-restriction
      (narrow-to-region (point-min) to)
      (goto-char from)
      (goto-eol)
;;      (delete-trailing-spaces)
      (while (forward-line 1)
        (goto-eol)
;;      (delete-trailing-spaces)
        (unless (bolp)
          (funcall mode-specific-indent-command)))))
  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$‚̑Ήž‚ð’T‚·
;;
;; -------------------------------------------------------------------------

;; ‘Ήž‚ð’T‚·‚½‚߂̐³‹K•\Œ»
(defvar *tf-block-keyword* "[\$]\\(IF[ \t]\\|FOREACH[ \t]\\|JOINEACH[ \t]\\|FUNCTION[ \t]\\|END[\$]\\|ERROR[ \$]\\|WORNING[ \$]\\)")
(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$‚ÌŒã‚ë‚ɃJ[ƒ\ƒ‹
                  (progn
                    (goto-char now)
                    (save-text-attributes)
                    (do-tf-block) ;; –{‘̌Ăяo‚µ
                    )
                )
              )
            )
          )
      )
    )
  )

(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)))) ;; ƒRƒƒ“ƒgƒAƒEƒg’†‚©ƒ`ƒFƒbƒN
                          (progn
                            (goto-char now)
                            (if (string-match "[\$]END[\$]" tmp_string) ;; $END$‚ªŒ©‚‚©‚Á‚½
                                 (setq end_depth (+ end_depth 1)) ;; [‚³+1
                              (progn ;; $END$ˆÈŠO‚ªŒ©‚‚©‚Á‚½
                                 (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) ;; s”ԍ†,s“à—e‚ð•\Ž¦
                  (set-text-attribute from to *tf-block-tag* :bold t) ;; ˆÍ‚܂ꂽ”ÍˆÍ‚ð‹­’²
                  )
              (message "‚È‚¢‚©‚à‚¾‚æ") ;; $END$‚̑Ήž‚ª‚È‚©‚Á‚½
              )
            )
        )
      )
    )
  )


(add-hook '*pre-command-hook* 'tf-block-pre-hook) ;; post-command-hook‚ɒljÁ
(add-hook '*post-command-hook* 'tf-block-hook) ;; post-command-hook‚ɒljÁ