Skip to content

Instantly share code, notes, and snippets.

@DeaR

DeaR/app-menu2.lisp

Created April 25, 2012 04:56
Show Gist options
  • Save DeaR/2486545 to your computer and use it in GitHub Desktop.
Save DeaR/2486545 to your computer and use it in GitHub Desktop.
Download ZIP
2012/2/24に晒した物纏め #xyzzy
Raw
app-menu2.lisp
; (eval-when (:compile-toplevel :load-toplevel :execute)
; (require "app-menu"))
(require "app-menu")
(provide "app-menu2")
(in-package "editor")
(defvar *original-init-app-menus* #'ed::init-app-menus
"ed::init-app-menus の退避")
(defun ed::init-app-menus (&optional f)
(let ((frame (if (featurep :multiple-frames)
(or f
(funcall (intern "selected-frame" :ed)))))
(menu))
(if (featurep :multiple-frames)
(funcall (intern "init-menu-handle" :ed) frame)
(funcall *original-init-app-menus*))
(setf menu
(define-menu
(:popup 'file "&File" ; "ファイル(&F)"
(:item :tag-command "新規作成(&N)"
'new-file)
(:item :tag-command "開く(&O)..."
'open-file-dialog)
(:item :tag-command "閉じる(&C)"
'close-selected-buffer
#'(lambda ()
(if (= (count-buffers) 1) :disable)))
(:item :tag-command "上書き保存(&S)"
'save-buffer-dialog :modified)
(:item :tag-command "名前を付けて保存(&A)..."
'save-as-dialog)
(:item :tag-command "ファイルの挿入(&I)..."
'insert-file-dialog)
(:item :tag-command "名前の変更(&R)..."
'rename-dialog)
(:item :tag-command "全て保存(&V)"
'save-all-buffers)
(:sep :above-session)
(:item :tag-command "セッションを開く(&D)..."
'open-session-dialog)
(:item :tag-command "セッションの保存(&W)..."
'save-session-dialog)
(:item :tag-command "セッションの自動保存(&T)"
'toggle-session-auto-save
'update-session-auto-save-ui)
(:item :tag-command "セッションを閉じる(&Y)"
'close-session-dialog)
(:sep :above-print)
(:item :tag-command "印刷(&P)..."
'print-selected-buffer-dialog)
(:sep :above-recent)
(:menu nil "最近使ったファイル(&F)"
(if (featurep :multiple-frames)
(funcall (intern "get-recent-file-popup-menu" :ed) frame)
*recent-file-popup-menu*))
(:menu nil "最近使ったセッション(&L)"
(if (featurep :multiple-frames)
(funcall (intern "get-recent-session-popup-menu" :ed) frame)
*recent-session-popup-menu*))
(:sep :above-kill-xyzzy)
(:item :tag-command "保存して終了(&E)"
'save-all-buffers-kill-xyzzy)
(:item :tag-command "終了(&X)"
'kill-xyzzy))
(:popup 'edit "&Edit" ; "編集(&E)"
(:item :tag-command "元に戻す(&U)"
'undo :undo)
(:item :tag-command "やっぱり元に戻さない(&R)"
'redo :redo)
(:sep :above-selection)
(:item :tag-command "切り取り(&T)"
'kill-selection-to-clipboard :modify-any-selection)
(:item :tag-command "コピー(&C)"
'copy-selection-to-clipboard :any-selection)
(:item :tag-command "貼り付け(&P)"
'paste-from-clipboard :clipboard)
(:item :tag-command "貼り付け - 矩形(&G)"
'paste-rectangle-from-clipboard :clipboard)
(:menu nil "クリップボードエンコーディング(&E)"
(if (featurep :multiple-frames)
(funcall (intern "get-clipboard-char-encoding-popup-menu" :ed) frame)
*clipboard-char-encoding-popup-menu*))
(:item :tag-command "削除(&L)"
'delete-selection :modify-any-selection)
(:item :tag-command "全てを選択(&S)"
'selection-whole-buffer)
(:sep :above-rectangle)
(:menu nil "矩形(&N)"
(if (featurep :multiple-frames)
(funcall (intern "get-app-rectangle-popup-menu" :ed) frame)
*app-rectangle-popup-menu*))
(:popup :convert-popup "変換(&V)"
(:item :tag-command "大文字(&U)"
'upcase-selection :selection)
(:item :tag-command "小文字(&L)"
'downcase-selection :selection)
(:item :tag-command "単語の先頭を大文字(&C)"
'capitalize-selection :selection)
(:sep :above-space-tab)
(:item :tag-command "スペース -> タブ(&T)"
'tabify-selection :selection)
(:item :tag-command "タブ -> スペース(&S)"
'untabify-selection :selection)
(:sep :above-full->half)
(:popup :full->half-popup "全角 -> 半角(&H)"
(:item :tag-command "すべて(&A)"
'map-all-to-half-width-selection :selection)
(:item :tag-command "英数・ひらがな・カタカナ(&S)"
'map-to-half-width-selection :selection)
(:item :tag-command "英数・ひらがな(&R)"
'map-ascii-and-hiragana-to-half-width-selection :selection)
(:item :tag-command "英数・カタカナ(&T)"
'map-ascii-and-katakana-to-half-width-selection :selection)
(:item :tag-command "英数(&N)"
'map-ascii-to-half-width-selection :selection)
(:item :tag-command "ひらがな(&H)"
'map-hiragana-to-half-width-selection :selection)
(:item :tag-command "カタカナ(&K)"
'map-katakana-to-half-width-selection :selection)
(:item :tag-command "ギリシア文字(&G)"
'map-greek-to-half-width-selection :selection)
(:item :tag-command "キリル文字(&C)"
'map-cyrillic-to-half-width-selection :selection))
(:popup :half->full-popup "半角 -> 全角(&Z)"
(:item :tag-command "すべて(ｶﾅ -> ひらがな)(&A)"
'map-all-to-full-width-hiragana-selection :selection)
(:item :tag-command "すべて(ｶﾅ -> カタカナ)(&L)"
'map-all-to-full-width-katakana-selection :selection)
(:item :tag-command "英数・ｶﾅ(ｶﾅ -> ひらがな)(&R)"
'map-to-full-width-hiragana-selection :selection)
(:item :tag-command "英数・ｶﾅ(ｶﾅ -> カタカナ)(&T)"
'map-to-full-width-katakana-selection :selection)
(:item :tag-command "英数(&N)"
'map-ascii-to-full-width-selection :selection)
(:item :tag-command "ｶﾅ -> ひらがな(&H)"
'map-kana-to-full-width-hiragana-selection :selection)
(:item :tag-command "ｶﾅ -> カタカナ(&K)"
'map-kana-to-full-width-katakana-selection :selection)
(:item :tag-command "ギリシア文字(&G)"
'map-greek-to-full-width-selection :selection)
(:item :tag-command "キリル文字(&C)"
'map-cyrillic-to-full-width-selection :selection))
(:popup :char-encoding-popup "漢字コード(&K)"
(:item :tag-command "自動判定(&A)"
'map-char-encoding-selection :selection)
(:item :tag-command "JISから(&J)"
'map-jis-selection :selection)
(:item :tag-command "EUCから(&E)"
'map-euc-selection :selection)))
(:popup :paragraph-popup "段落(&H)"
(:item :tag-command "前の段落(&B)"
'backward-paragraph)
(:item :tag-command "次の段落(&F)"
'forward-paragraph)
(:item :tag-command "選択(&S)"
'selection-paragraph)
(:item :tag-command "削除(&L)"
'kill-paragraph)
(:item :tag-command "入れ替え(&T)"
'transpose-paragraphs)
(:item :tag-command "詰め込み(&I)"
'fill-paragraph))
(:sep :above-not-modified)
(:item :tag-command "変更マークを消す(&M)"
'not-modified :modified)
(:item :tag-command "最初からやり直し(&O)"
'revert-buffer))
(:popup 'search "&Search" ; "検索(&S)"
(:item :tag-command "検索(&F)..."
'search-dialog)
(:item :tag-command "次を検索(&N)"
'repeat-forward-search
#'(lambda () (or *last-search-p* :disable)))
(:item :tag-command "前を検索(&P)"
'repeat-backward-search
#'(lambda () (or *last-search-p* :disable)))
(:item :tag-command "置換(&R)..."
'replace-dialog)
(:item :tag-command "一致する文字列を数える(&C)..."
'count-matches-dialog)
(:sep :above-first-error)
(:item :tag-command "最初のタグ(&I)"
'first-error)
(:item :tag-command "次のタグ(&E)"
'next-error)
(:sep :above-goto-line)
(:item :tag-command "指定行(&J)..."
'goto-line-dialog)
(:item :tag-command "ファイルの先頭(&T)"
'beginning-of-buffer)
(:item :tag-command "ファイルの最後(&B)"
'end-of-buffer)
(:item :tag-command "マーク(&M)..."
'mark-dialog-box)
(:item :tag-command "関数の先頭(&D)"
'beginning-of-defun)
(:item :tag-command "関数の最後(&U)"
'end-of-defun)
(:sep :above-gresreg)
(:item :tag-command "Gresreg(&S)..."
'gresreg-dialog)
(:item :tag-command "Grep(&G)..."
'grep-dialog))
(:popup 'view "&View" ; "表示(&V)"
(:item :tag-command "折り返さない(&N)"
'set-buffer-fold-type-none
'set-buffer-fold-type-none-update)
(:item :tag-command "指定位置で折り返す(&C)"
'set-buffer-fold-type-column
'set-buffer-fold-type-column-update)
(:item :tag-command "ウィンドウ幅で折り返す(&W)"
'set-buffer-fold-type-window
'set-buffer-fold-type-window-update)
(:sep :above-command-bar)
(:menu nil "ツールバー(&Q)"
(if (featurep :multiple-frames)
(funcall (intern "get-command-bar-popup-menu" :ed) frame)
*command-bar-popup-menu*))
(:sep :above-frame)
(:item :tag-command "新しいフレーム(&F)"
'new-pseudo-frame 'new-pseudo-frame-menu-update)
(:item :tag-command "現在のフレームを閉じる(&D)"
'delete-pseudo-frame 'pseudo-frame-menu-update)
(:item :tag-command "次のフレーム(&T)"
'other-pseudo-frame 'pseudo-frame-menu-update)
(:item :tag-command "前のフレーム(&R)"
'previous-pseudo-frame 'pseudo-frame-menu-update))
(:popup 'window "&Window" ; "ウィンドウ(&W)"
(:item :tag-command "横に分割(&S)"
'split-window 'split-window-menu-update)
(:item :tag-command "縦に分割(&V)"
'split-window-vertically 'split-window-menu-update)
(:item :tag-command "他のウィンドウを閉じる(&O)"
'delete-other-windows 'close-window-menu-update)
(:item :tag-command "現在のウィンドウを閉じる(&C)"
'delete-window 'close-window-menu-update)
(:item :tag-command "次のウィンドウ(&N)"
'other-window 'move-window-menu-update)
(:item :tag-command "前のウィンドウ(&P)"
'move-previous-window 'move-window-menu-update)
(:sep :above-next-xyzzy)
(:item :tag-command "次のxyzzy(&X)"
'next-xyzzy-window
#'(lambda () (if (< (count-xyzzy-instance) 2) :disable)))
(:item :tag-command "前のxyzzy(&Y)"
'previous-xyzzy-window
#'(lambda () (if (< (count-xyzzy-instance) 2) :disable)))
(:item :tag-command "xyzzy選択(&Z)..."
'select-xyzzy
#'(lambda () (if (< (count-xyzzy-instance) 2) :disable)))
(:sep :above-select-buffer)
(:item :tag-command "バッファ選択(&B)..."
'select-buffer))
(:popup 'tools "&Tool" ; "ツール(&T)"
(:item :tag-command "コンソールプログラムを非同期で実行(&A)..."
'execute-subprocess-dialog)
(:item :tag-command "非同期プログラムを死なす(&K)"
'kill-subprocess
#'(lambda ()
(let ((proc (buffer-process (selected-buffer))))
(unless (and proc
(eq (process-status proc) :run))
:disable))))
(:item :tag-command "コンソールプログラムの実行(&P)..."
'pipe-command-dialog)
(:item :tag-command "Windowsプログラムの実行(&W)..."
'launch-application-dialog)
(:item :tag-command (if (featurep :windows-nt)
"NTプロンプト(&D)"
"DOSプロンプト(&D)")
'run-console)
(:sep :above-kbd-macro)
(:item :tag-command "キーボードマクロ記録開始(&S)"
'start-kbd-macro)
(:item :tag-command "キーボードマクロ記録終了(&E)"
'end-kbd-macro
:end-macro)
(:item :tag-command "キーボードマクロ実行(&X)"
'call-last-kbd-macro
#'(lambda () (if (null *last-kbd-macro*) :disable)))
(:popup :kbd-macro-popup "キーボードマクロおまけ(&O)"
(:item :tag-command "保存(&V)..."
'save-last-kbd-macro
#'(lambda () (if (null *last-kbd-macro*) :disable)))
(:item :tag-command "読み込み(&L)..."
'load-kbd-macro)
(:item :tag-command "ファイルへ保存(&S)..."
'save-kbd-macro-to-file))
(:sep :above-property-sheet)
(:item :tag-command "共通設定(&C)..."
'option-property-sheet)
(:item :tag-command "ローカル設定(&L)..."
'local-option-property-sheet)
(:sep :above-box-drawings)
(:item :tag-command "罫線モード(&R)"
'box-drawings-mode
#'(lambda () (if *box-drawings-mode* :check)))
(:item :tag-command "太い罫線(&T)"
'box-drawings-toggle-line-type
#'(lambda ()
(values (unless *box-drawings-mode*
:disable)
(if (eq *box-drawings-line-type* '*box-drawings-thick-line*)
:check))))
(:sep :above-insert-date)
(:item :tag-command "日付と時刻の挿入(&M)..."
'insert-date-string)
(:item :tag-command "ファイラ(&F)..."
'open-filer)
(:menu nil "辞書(&I)"
(if (featurep :multiple-frames)
(funcall (intern "get-dictionary-popup-menu" :ed) frame)
*dictionary-popup-menu*))
(:sep :above-make-tags)
(:item :tag-command "TAGSファイルの作成(&G)..."
'make-tags-file-dialog)
(:item :tag-command "タグジャンプ(&J)"
'jump-tag
#'(lambda () (unless (and tags-find-target tags-find-point) :disable)))
(:item :tag-command "ダイレクトタグジャンプ(&U)"
'direct-tag-jump
#'(lambda () (unless (and tags-find-target tags-find-point) :disable)))
(:item :tag-command "バックタグジャンプ(&B)"
'back-tag-jump
#'(lambda () (if (null *global-mark-list*) :disable)))
(:sep :|above-(>_<)|)
(:popup :|(>_<)-popup| "(>&_<)"
(:item :tag-command "ニフティのログを読む(&N)"
'view-nifty-log)
(:item :tag-command "電卓(&T)"
'calc)
(:item :tag-command "カレンダー(&A)"
'calendar)
(:item :tag-command "ハノイの塔(&H)"
'hanoi)
(:item :tag-command "五目(&G)"
'gomoku)
(:item :tag-command "ライフ(&L)"
'life)
(:item :tag-command "C曲線(&C)"
'c-curve)
(:item :tag-command "ドラゴン曲線(&R)"
'dragon-curve)))
(:popup 'help "&Help" ; "ヘルプ(&?)"
(:item :tag-command "キー割り当て一覧(&K)"
'describe-bindings-0)
(:item :tag-command "最近入力したキー(&L)"
'view-lossage)
(:sep :above-about)
(:item :tag-command "について(&A)..."
'about-dialog))))
(if (featurep :multiple-frames)
(let* ((tools (get-menu menu 'tools))
(pos (get-menu-position tools ':|above-(>_<)|)))
(insert-menu-item tools pos
:tag-command "アップデートの確認"
'check-update)
(insert-menu-separator tools pos
:above-check-update)
(funcall (intern "set-app-menu" :ed) frame menu)
(run-hooks '*init-app-menus-hook*)
(set-menu (funcall (intern "get-app-menu" :ed) frame) frame))
(progn
(setf *app-menu* menu)
(run-hooks '*init-app-menus-hook*)
(set-menu *app-menu*)))
(add-file-history-to-menu)
(add-session-history-to-menu)))
(defun describe-bindings-0 ()
(interactive)
(if (modulep "describe-bindings-mode")
(funcall (intern "describe-bindings-mode" :ed))
(describe-bindings)))
Raw
colordiff-mode.lisp
;; -*- Mode: Lisp; Package: ed -*-
(provide "colordiff-mode")
(in-package :ed)
(export
'(colordiff-mode
*colordiff-new-text-color*
*colordiff-old-text-color*
*colordiff-diff-stuff-color*
*colordiff-cvs-stuff-color*
*colordiff-mode-map*
*colordiff-mode-hook*
*colordiff-tag*
*colordiff-style-unified*
*colordiff-style-context*
*colordiff-style-normal*
*colordiff-select-file-new*
*colordiff-select-file-old*
*colordiff-default-style*))
(defvar *colordiff-new-text-color* 4
"追加行の文字色")
(defvar *colordiff-old-text-color* 1
"削除行の文字色")
(defvar *colordiff-diff-stuff-color* 5
"変更箇所表示の文字色")
(defvar *colordiff-cvs-stuff-color* 2
"ヘッダの文字色")
(defvar *colordiff-mode-map* nil
"colordiff-mode の keymap")
(unless *colordiff-mode-map*
(setf *colordiff-mode-map* (make-sparse-keymap))
(define-key *colordiff-mode-map* '(#\C-c #\C-c) 'colordiff-jump)
(define-key *colordiff-mode-map* '(#\C-c #\C-s) 'colordiff-set-style)
(define-key *colordiff-mode-map* '#\RET 'colordiff-newline-and-repaint-context)
(define-key *colordiff-mode-map* '#\+ 'colordiff-self-insert-and-repaint-context)
(define-key *colordiff-mode-map* '#\- 'colordiff-self-insert-and-repaint-context)
(define-key *colordiff-mode-map* '#\! 'colordiff-self-insert-and-repaint-context))
(defvar *colordiff-mode-hook* nil
"colordiff-mode 変更時の hook")
(defvar *colordiff-tag* 'colordiff-tag
"colordiff-mode の色付けタグ")
(defvar *colordiff-style-unified* 'colordiff-style-unified
"unified形式")
(defvar *colordiff-style-context* 'colordiff-style-context
"context形式")
(defvar *colordiff-style-normal* 'colordiff-style-normal
"通常diff")
(defvar *colordiff-select-file-new* 'colordiff-select-file-new
"新しいファイルのファイル名")
(defvar *colordiff-select-file-old* 'colordiff-select-file-old
"古いファイルのファイル名")
(defvar *colordiff-default-style* *colordiff-style-unified*
"diffのデフォルト形式(*colordiff-style-unified*, *colordiff-style-context*, *colordiff-style-normal*)")
(defvar *colordiff-mode-keywords-unified*
(compile-regexp-keyword-list
`(("^\\(Index: \\|=\\{4,\\}\\|RCS file: \\|retrieving \\|diff \\).*$" t (:color ,*colordiff-cvs-stuff-color*))
("^\\+\\+\\+ .*$" t (:color ,*colordiff-new-text-color*))
("^--- .*$" t (:color ,*colordiff-old-text-color*))
("^\\+.*$" t (:color ,*colordiff-new-text-color*))
("^-.*$" t (:color ,*colordiff-old-text-color*))
("^@@ -[0-9]+,[0-9]+ \\+[0-9]+,[0-9]+ @@.*$" t (:color ,*colordiff-diff-stuff-color*)))))
(defvar *colordiff-mode-keywords-context*
(compile-regexp-keyword-list
`(("^\\(Index: \\|=\\{4,\\}\\|RCS file: \\|retrieving \\|diff \\).*$" t (:color ,*colordiff-cvs-stuff-color*))
("^--- [^\t]+\t.*$" t (:color ,*colordiff-new-text-color*))
("^\\*\\*\\* [^\t]+\t.*$" t (:color ,*colordiff-old-text-color*))
("^\\*\\*\\*\\*\\*\\*\\*\\*\\*\\*\\*\\*\\*\\*\\*.*$" t (:color ,*colordiff-diff-stuff-color*))
("^--- [0-9]+,[0-9]+ ----.*$" t (:color ,*colordiff-diff-stuff-color*))
("^\\*\\*\\* [0-9]+,[0-9]+ \\*\\*\\*\\*.*$" t (:color ,*colordiff-diff-stuff-color*)))))
(defvar *colordiff-mode-keywords-normal*
(compile-regexp-keyword-list
`(("^\\(Index: \\|=\\{4,\\}\\|RCS file: \\|retrieving \\|diff \\).*$" t (:color ,*colordiff-cvs-stuff-color*))
("^> .*$" t (:color ,*colordiff-new-text-color*))
("^< .*$" t (:color ,*colordiff-old-text-color*))
("^[0-9]+\\(,[0-9]+\\)?[acd][0-9]+\\(,[0-9]+\\)?.*$" t (:color ,*colordiff-diff-stuff-color*)))))
(defun colordiff-mode ()
"diffファイル読み(書き)モード"
(interactive)
(kill-all-local-variables)
(colordiff-set-style (save-excursion
(goto-char (point-min))
(cond ((scan-buffer "^--- .*\n\\+\\+\\+ [^\t]+")
*colordiff-style-unified*)
((scan-buffer "^\\*\\*\\* .*\n--- [^\t]+")
*colordiff-style-context*)
((scan-buffer "^[0-9]+\\(,[0-9]+\\)?[acd][0-9]+\\(,[0-9]+\\)?")
*colordiff-style-normal*)
(t
*colordiff-default-style*))))
(setf buffer-mode 'colordiff-mode)
(setf mode-name "ColorDiff")
(use-keymap *colordiff-mode-map*))
(defun colordiff-set-style (style)
"diffスタイルの変更"
(interactive (list (progn
(second (assoc (completing-read "Diff-style: "
'("unified" "context" "normal")
:must-match t)
'(("unified" *colordiff-style-unified*)
("context" *colordiff-style-context*)
("normal" *colordiff-style-normal*)))))))
(make-local-variable 'colordiff-style)
(setf colordiff-style style)
(make-local-variable 'regexp-keyword-list)
(setf regexp-keyword-list
(cond ((eq style *colordiff-style-unified*)
*colordiff-mode-keywords-unified*)
((eq style *colordiff-style-context*)
(colordiff-repaint-context)
*colordiff-mode-keywords-context*)
((eq style *colordiff-style-normal*)
*colordiff-mode-keywords-normal*))))
(defun colordiff-newline-and-repaint-context (&optional (arg 1))
"改行し、contextスタイルの再着色"
(interactive "*p")
(insert #\LFD arg)
(when (eq colordiff-style *colordiff-style-context*)
(colordiff-repaint-context)))
(defun colordiff-self-insert-and-repaint-context (&optional (arg 1))
"入力されたキーを出力し、contextスタイルの再着色"
(interactive "*p")
(unless (prog1
(parse-point-syntax)
(self-insert-command arg))
(when (eq colordiff-style *colordiff-style-context*)
(colordiff-repaint-context)))
t)
(defun colordiff-jump ()
"ジャンプ"
(interactive)
(multiple-value-bind (old-file-name old-file-line old-file-exist-p new-file-name new-file-line new-file-exist-p select-file)
(colordiff-get-value)
(let ((file) (line))
(cond ((and (eq select-file *colordiff-select-file-old*)
old-file-exist-p)
(setf file old-file-name)
(setf line old-file-line))
((and (eq select-file *colordiff-select-file-new*)
new-file-exist-p)
(setf file new-file-name)
(setf line new-file-line))
((and (not select-file)
old-file-exist-p
new-file-exist-p)
(let ((old (format nil "0 :\"~A\": Old-file" (merge-pathnames old-file-name)))
(new (format nil "1 :\"~A\": New-file" (merge-pathnames new-file-name))))
(if (string-equal old
(completing-read "Open-file: "
(list old new)
:must-match t
:history nil))
(progn
(setf file old-file-name)
(setf line old-file-line))
(progn
(setf file new-file-name)
(setf line new-file-line)))))
(t
(setf file (read-file-name "Open-file: "
:default (cond (old-file-exist-p
old-file-name)
(new-file-exist-p
new-file-name)
(t
"")
)
:history nil))
(setf line (if old-file-exist-p
old-file-line
new-file-line))))
(find-file file)
(goto-line line))))
(defun colordiff-repaint-context ()
"contextスタイルの再着色"
(delete-text-attributes *colordiff-tag*)
(save-excursion
(goto-char (point-min))
(let ((regexp1 (compile-regexp "^[!+-]"))
(regexp2 (compile-regexp "^\\(\\*\\*\\* [0-9]+,[0-9]+ \\*\\*\\*\\*\\|--- [0-9]+,[0-9]+ ----\\)"))
(regexp3 (compile-regexp "^\\*"))
(regexp4 (compile-regexp "^-")))
(while (scan-buffer regexp1)
(let ((color)
(p (point)))
(save-excursion
(when (scan-buffer regexp2 :reverse t)
(cond ((looking-at regexp3)
(setf color *colordiff-old-text-color*))
((looking-at regexp4)
(setf color *colordiff-new-text-color*)))))
(goto-eol)
(set-text-attribute p (point) *colordiff-tag* :foreground color))))))
(defun colordiff-get-value ()
"ファイル名や行番号の取得"
(let ((old-file-name) (old-file-line)
(new-file-name) (new-file-line)
(select-file) (s1) (s2) (p))
(save-excursion
(goto-bol)
(setf p (point))
(cond ((eq colordiff-style *colordiff-style-unified*)
(when (looking-at "^\\(@@\\|\\+\\+\\+\\|---\\)")
(return-from colordiff-get-value))
(cond ((looking-at "^\\+")
(setf select-file *colordiff-select-file-new*))
((looking-at "^-")
(setf select-file *colordiff-select-file-old*)))
(unless (scan-buffer "^@@ -\\([0-9]+\\),[0-9]+ \\+\\([0-9]+\\),[0-9]+ @@" :reverse t)
(error "行番号指定が見つからない…。"))
(setf s1 (parse-integer (match-string 1)))
(setf s2 (parse-integer (match-string 2)))
(save-restriction
(narrow-to-region (point) p)
(setf old-file-line (+ s1
(count-matches "^[ -]")))
(setf new-file-line (+ s2
(count-matches "^[ +]"))))
(unless (scan-buffer "^--- \\([^\t]+\\)\t.*\n\\+\\+\\+ \\([^\t]+\\)" :reverse t)
(error "ファイル名指定が見つからない…。"))
(setf old-file-name (match-string 1))
(setf new-file-name (match-string 2)))
((eq colordiff-style *colordiff-style-context*)
(when (looking-at "^\\(\\*\\*\\*\\|---\\)")
(return-from colordiff-get-value))
(let ((regexp1 (compile-regexp "^\\(\\*\\*\\*\\*\\*\\*\\*\\*\\*\\*\\*\\*\\*\\*\\*\\|\\*\\*\\* [0-9]+,[0-9]+ \\*\\*\\*\\*\\|--- [0-9]+,[0-9]+ ----\\)"))
(regexp2 (compile-regexp "^\\*\\*\\*\\*"))
(regexp3 (compile-regexp "^\\*\\*\\* \\([0-9]+\\)"))
(regexp4 (compile-regexp "^--- \\([0-9]+\\)")))
(loop
(unless (scan-buffer regexp1 :reverse t)
(error "行番号指定が見つからない…。"))
(cond ((looking-at regexp2)
(unless old-file-line
(error "行番号指定が見つからない…。"))
(unless new-file-line
(if (scan-buffer "^--- \\([0-9]+\\),[0-9]+ ----")
(setf new-file-line (+ (parse-integer (match-string 1))
s1))
(error "行番号指定が見つからない…。")))
(return))
((looking-at regexp3)
(unless select-file
(setf select-file *colordiff-select-file-old*))
(save-restriction
(narrow-to-region (point) p)
(setf old-file-line (+ (parse-integer (match-string 1))
(if s2
s2
(setf s1(count-matches "^[ !+-] ")))))))
((looking-at regexp4)
(unless select-file
(setf select-file *colordiff-select-file-new*))
(save-restriction
(narrow-to-region (point) p)
(setf new-file-line (+ (parse-integer (match-string 1))
(setf s2 (count-matches "^[ !+-] ")))))))
(backward-char)))
(unless (scan-buffer "^\\*\\*\\* \\([^\t]+\\)\t.*\n--- \\([^\t]+\\)" :reverse t)
(error "ファイル名指定が見つからない…。"))
(setf old-file-name (match-string 1))
(setf new-file-name (match-string 2)))
((eq colordiff-style *colordiff-style-normal*)
(unless (looking-at "^[<>]")
(return-from colordiff-get-value))
(cond ((looking-at "^>")
(setf select-file *colordiff-select-file-new*))
((looking-at "^<")
(setf select-file *colordiff-select-file-old*)))
(unless (scan-buffer "^\\([0-9]+\\)\\(,[0-9]+\\)?[acd]\\([0-9]+\\)\\(,[0-9]+\\)?" :reverse t)
(error "行番号指定が見つからない…。"))
(setf s1 (parse-integer (match-string 1)))
(setf s2 (parse-integer (match-string 3)))
(save-restriction
(narrow-to-region (point) p)
(setf old-file-line (+ s1
(count-matches "^<")))
(setf new-file-line (+ s2
(count-matches "^>"))))
(when (and (scan-buffer "^diff " :reverse t)
(scan-buffer " [^-]")
(= (length (setf s1 (split-string (buffer-substring (point)
(save-excursion
(goto-eol)
(point)))
#\SPC)))
2))
(setf old-file-name (first s1))
(setf new-file-name (second s1))))))
(values old-file-name old-file-line (file-exist-p old-file-name)
new-file-name new-file-line (file-exist-p new-file-name)
select-file)))
Raw
ctags2.lisp
;; -*- Mode: Lisp; Package: ed -*-
(eval-when (:compile-toplevel :load-toplevel :execute)
(require "ctags"))
(provide "ctags2")
(in-package :ed)
(export '(*ctags-read-tags-alist*))
(defvar *ctags-read-tags-alist* nil
"ctags: tags ファイルの場所(Project directory . Tags directory)")
(define-history-variable *ctags-file-history* nil)
(setf (get 'ctags-file 'ed::minibuffer-history-variable)
'*ctags-file-history*)
(defun ed::ctags-make-tags-map (dir)
"ctags: tags ファイルの読み込み(ディレクトリ指定)"
(interactive
(list (or (rest (assoc (default-directory) *ctags-read-tags-alist*
:test #'(lambda (x y) (string-matchp (append-trail-slash (namestring y)) x))))
(read-directory-name "ReadTagsFrom: " :default (default-directory) :history 'ctags-file))))
(setf dir (merge-pathnames dir))
(cond ((and (null *ctags-tags-buffer-name*)
(not (file-exist-p (merge-pathnames "tags" dir))))
(when (yes-or-no-p "tags ファイルがありません。作成しますか?")
(call-interactively 'ctags-make-tags-file-recursive)))
((or (null *ctags-tags-buffer-name*)
(yes-or-no-p "既に tags を読み込んでます。上書きしますか?"))
(progn
(let* ((file-path (merge-pathnames "tags" dir))
(buffer (concatenate 'string *ctags-tags-buffer-prefix* file-path))
(e (buffer-fileio-encoding)))
(setf *ctags-tags-buffer-name* buffer)
(get-buffer-create buffer)
(erase-buffer buffer)
(save-excursion
(switch-to-buffer buffer)
(push buffer *ctags-tags-buffer-list*)
(make-local-variable 'ctags-tags-file-dir-path)
(setf ctags-tags-file-dir-path dir)
(make-local-variable 'need-not-save)
(setf need-not-save t)
(make-local-variable 'auto-save)
(setf auto-save nil)
(cond ((eq e *encoding-euc-jp*)
(read-file file-path *encoding-euc-jp*))
((or (eq e *encoding-utf8*)
(eq e *encoding-utf8n*))
(read-file file-path *encoding-utf8n*))
(t
(read-file file-path *encoding-sjis*)))
(goto-char 0)
(do ((line (ctags-get-current-line)
(ctags-get-current-line)))
((not (string-match "^!_TAG_" (first line))))
(delete-region (second line) (rest (rest line)))
(delete-char)))))))
t) ; t を返さないと ctags: cannot create tags file って言われるので…
(defvar *original-ctags-make-tags-file* #'ed::ctags-make-tags-file)
(defun ed::ctags-make-tags-file (dir &optional encoding)
"ctags: tags ファイルの作成(サブディレクトリ抜き)"
(interactive
(list (or (rest (assoc (default-directory) *ctags-read-tags-alist*
:test #'(lambda (x y) (string-matchp (append-trail-slash (namestring y)) x))))
(let ((s (read-directory-name "MakeTagsTo: " :default (default-directory) :history *ctags-file-history*)))
(add-history s '*ctags-file-history*)
s))
(if *prefix-args*
(completing-read "Encoding: " *char-encoding-list* :must-match t :case-fold t)
(setf encoding (buffer-fileio-encoding)))))
(let ((bak (or *ctags-command-option* "")))
(setf *ctags-command-option*
(concat bak
" --jcode="
(cond ((eq encoding *encoding-sjis*)
"sjis")
((eq encoding *encoding-euc-jp*)
"euc")
((or (eq encoding *encoding-utf8*)
(eq encoding *encoding-utf8n*))
"utf8")
(t
"ascii"))))
(funcall *original-ctags-make-tags-file* (merge-pathnames dir))
(setf *ctags-command-option* bak)))
(defvar *original-ctags-make-tags-file-recursive* #'ed::ctags-make-tags-file-recursive)
(defun ed::ctags-make-tags-file-recursive (dir &optional encoding)
"ctags: tags ファイルの作成(サブディレクトリ含む)"
(interactive
(list (or (rest (assoc (default-directory) *ctags-read-tags-alist*
:test #'(lambda (x y) (string-matchp (append-trail-slash (namestring y)) x))))
(let ((s (read-directory-name "MakeTagsTo: " :default (default-directory) :history *ctags-file-history*)))
(add-history s '*ctags-file-history*)
s))
(if *prefix-args*
(completing-read "Encoding: " *char-encoding-list* :must-match t :case-fold t)
(setf encoding (buffer-fileio-encoding)))))
(let ((bak (or *ctags-command-option* "")))
(setf *ctags-command-option*
(concat bak
" --jcode="
(cond ((eq encoding *encoding-sjis*)
"sjis")
((eq encoding *encoding-euc-jp*)
"euc")
((or (eq encoding *encoding-utf8*)
(eq encoding *encoding-utf8n*))
"utf8")
(t
"ascii"))))
(funcall *original-ctags-make-tags-file-recursive* (namestring dir))
(setf *ctags-command-option* bak)))
(defvar *make-ctags-encoding-list*
(list *encoding-sjis*
*encoding-euc-jp*
*encoding-iso-8859-1*
*encoding-utf8*))
(defvar *make-ctags-file-dialog-template*
'(dialog 0 0 226 81
(:caption "タグファイルを作る")
(:font 9 "MS UI Gothic")
(:control
(:static nil "ソースディレクトリ(&S):" #x50020000 7 7 58 8)
(:edit src nil #x50810080 7 19 148 14)
(:button subdir "ついでにサブディレクトリも(&U)" #x50010003 7 48 102 10)
(:static nil "エンコード(&Q):" #x50020000 9 63 50 8)
(:combobox encoding nil #x50210843 59 60 65 14)
(:button IDOK "OK" #x50010001 169 7 50 14)
(:button IDCANCEL "キャンセル" #x50010000 169 24 50 14)
(:button ref "参照(&R)..." #x50010000 169 41 50 14))))
(defvar *make-ctags-menu-p* t)
(define-history-variable *make-ctags-file-subdir* t)
(add-hook '*init-app-menus-hook*
#'(lambda ()
(when *make-ctags-menu-p*
(let* ((*app-menu* (if (featurep :multiple-frames)
(funcall (intern "get-app-menu" :ed) (funcall (intern "selected-frame" :ed)))
ed::*app-menu*))
(tools (get-menu *app-menu* 'tools))
(pos (get-menu-position tools ':above-make-tags)))
(insert-menu-item tools pos
'ctags "スタックを選択して戻る(&S)" 'ctags-select-stack
#'(lambda () (or *ctags-tags-stack* :disable)))
(insert-menu-item tools pos
'ctags "バックタグジャンプ(&B)" 'ctags-back-tag-jump
#'(lambda () (or *ctags-tags-stack* :disable)))
(insert-menu-item tools pos
'ctags "タグジャンプ(&J)" 'ctags-jump-tag)
(insert-menu-item tools pos
'ctags "CTAGSファイルの作成(&G)" 'make-ctags-file-dialog)
(insert-menu-separator tools pos)))))
(defun make-ctags-file-dialog ()
"ctags: tags ファイルの作成"
(interactive)
(let ((char-encoding-name-list (mapcar #'char-encoding-name *make-ctags-encoding-list*))
(char-encoding-display-name-list (mapcar #'char-encoding-display-name *make-ctags-encoding-list*)))
(multiple-value-bind (result data)
(dialog-box *make-ctags-file-dialog-template*
(list (cons 'src (default-directory))
(cons 'subdir *make-ctags-file-subdir*)
(cons 'encoding char-encoding-display-name-list)
(cons 'encoding
(let ((e (buffer-fileio-encoding)))
(cond ((eq e *encoding-sjis*)
0)
((eq e *encoding-euc-jp*)
1)
((or (eq e *encoding-utf8*)
(eq e *encoding-utf8n*))
3)
(t
2)))))
'((src :non-null "ソースディレクトリ(&S)" :enable (IDOK))
(ref :related src :directory-name-dialog (:title "参照"))))
(when result
(setf *make-ctags-file-subdir* (rest (assoc 'subdir data)))
(let ((e (nth (position (rest (assoc 'encoding
data))
char-encoding-display-name-list :test 'string=)
*make-ctags-encoding-list*)))
(if *make-ctags-file-subdir*
(ctags-make-tags-file-recursive (rest (assoc 'src data)) e)
(ctags-make-tags-file (rest (assoc 'src data)) e)))))))
Raw
cygterm.lisp
;; -*- Mode: Lisp; Package: tterm -*-
(eval-when (:compile-toplevel :load-toplevel :execute)
(require "tterm"))
(provide "cygterm")
(in-package :tterm)
(export
'(*cygwin-dir*
*cygterm-exe*
*cygterm-options*
*cygterm-xyzzy-exe*
*cygterm-register-menu-p*
cygterm
cygterm-run-tterm
*tterm-ssh-favorite-hosts*
tterm-ssh
tterm-autossh))
(defvar *cygwin-dir* "C:/cygwin"
"cygwin のインストールディレクトリ")
(defvar *cygterm-exe* (merge-pathnames "bin/cygterm.exe" (si:system-root))
"cygterm.exe の場所")
(defvar *cygterm-options* nil
"cygterm.exe の追加オプション")
(defvar *cygterm-xyzzy-exe* (merge-pathnames "xyzzycli.exe" (si:system-root))
"cygterm.exe から呼ばれる xyzzycli.exe の場所")
(defvar *cygterm-register-menu-p* t
"メニューに Cygwin を登録するか")
(defun cygterm (&optional (options *cygterm-options*))
"cygterm を開く"
(interactive)
(call-process (format nil "\"~A\" -t '~A -f cygterm-run-tterm %s %d'~{ ~A~}"
*cygterm-exe* *cygterm-xyzzy-exe* options)
:no-std-handles t :show :minimize))
(defun cygterm-run-tterm ()
"cygterm 起動"
(let* ((host (pop si:*command-line-args*))
(port (parse-integer (pop si:*command-line-args*)))
(*tterm-input-encoding* (or (pop si:*command-line-args*)
"utf8"))
(*tterm-output-encoding* (or (when #1=(pop si:*command-line-args*) (symbol-value (find-symbol #1#)))
*encoding-utf8n*)))
(tterm host port)
(tterm-char-mode t)
(tterm-toggle-local-echo)
(tterm-toggle-meta-emu)))
(defun cygterm-setup-menu ()
"メニューに cygwin を登録"
(when *cygterm-register-menu-p*
(let* ((*app-menu* (if (featurep :multiple-frames)
(funcall (intern "get-app-menu" :ed) (funcall (intern "selected-frame" :ed)))
ed::*app-menu*))
(tools (get-menu *app-menu* 'ed::tools)))
(insert-menu-item tools
(get-menu-position tools ':above-kbd-macro)
'cygterm "Cygwin(&C)" 'cygterm)
(insert-menu-item tools
(get-menu-position tools ':above-kbd-macro)
'tterm-ssh "SSH(&S)" 'tterm-ssh)
(insert-menu-item tools
(get-menu-position tools ':above-kbd-macro)
'tterm-autossh "AutoSSH(&S)" 'tterm-autossh))))
(add-hook '*init-app-menus-hook* 'cygterm-setup-menu)
(defvar *tterm-ssh-favorite-hosts*
'(("hostname" 22 "username" "identity-file-path"))
"SSH 接続設定")
(defun tterm-ssh (&optional host port &key user identity)
"cygterm と cygwin の OpenSSH を利用して SSH 接続する"
(interactive)
(unless host
(setf host (completing-read "Host: " (mapcar #'first *tterm-ssh-favorite-hosts*))))
(let* ((conf (assoc host *tterm-ssh-favorite-hosts* :test #'string=))
(port (or port
(when (string-match ".*:\\([0-9]+\\)" host)
(match-string 1))
(second conf)
22))
(user (or user
(when (string-match "\\(.*\\)@.*" host)
(match-string 1))
(third conf)))
(identity (or identity
(when *prefix-args*
(read-exist-file-name "Identity: "))
(fourth conf))))
(cygterm (list (format nil "-s '/bin/ssh -p ~D ~A ~A ~A'"
port
(if identity (format nil "-i %A" identity) "")
(if user (format nil "-l ~A" user) "")
host)))))
(defun tterm-autossh (&optional host port &key user identity)
"cygterm と cygwin の autossh を利用して SSH 接続する"
(interactive)
(unless host
(setf host (completing-read "Host: " (mapcar #'first *tterm-ssh-favorite-hosts*))))
(let* ((conf (assoc host *tterm-ssh-favorite-hosts* :test #'string=))
(port (or port
(when (string-match ".*:\\([0-9]+\\)" host)
(match-string 1))
(second conf)
22))
(user (or user
(when (string-match "\\(.*\\)@.*" host)
(match-string 1))
(third conf)))
(identity (or identity
(when *prefix-args*
(read-exist-file-name "Identity: "))
(fourth conf))))
(cygterm (list (format nil "-s '/bin/autossh -p ~D ~A ~A ~A'"
port
(if identity (format nil "-i %A" identity) "")
(if user (format nil "-l ~A" user) "")
host)))))
Raw
hideif2.lisp
;; -*- Mode: Lisp; Package: ed -*-
(provide "hideif2")
(in-package :ed)
(export '*hide-ifdef-parameter-alist*)
(defvar *hide-ifdef-parameter-alist* nil
"パラメータのリスト(Project directory (Include directory list) (Define list) (Undefine list))")
(define-history-variable *hide-ifdef-include-history* nil)
(define-history-variable *hide-ifdef-define-history* nil)
(define-history-variable *hide-ifdef-undefine-history* nil)
(setf (get 'hide-ifdef-include 'ed::minibuffer-history-variable)
'*hide-ifdef-include-history*)
(setf (get 'hide-ifdef-define 'ed::minibuffer-history-variable)
'*hide-ifdef-define-history*)
(setf (get 'hide-ifdef-undefine 'ed::minibuffer-history-variable)
'*hide-ifdef-undefine-history*)
(defvar *original-hide-ifdef* #'ed::hide-ifdef)
(defun ed::hide-ifdef (include define undefine)
"#if 0～#endif等を隠す"
(interactive
(list (let ((l (assoc (default-directory) *hide-ifdef-parameter-alist*
:test #'(lambda (x y) (string-matchp (append-trail-slash (namestring y)) x)))))
(if l
(second l)
(loop
(let ((s (remove-trail-slash (read-directory-name "Directory: "
:default (default-directory)
:history 'hide-ifdef-include))))
(pushnew s l)
(when (string-equal s (remove-trail-slash (default-directory)))
(return l))))))
(let ((l (assoc (default-directory) *hide-ifdef-parameter-alist*
:test #'(lambda (x y) (string-matchp (append-trail-slash (namestring y)) x)))))
(if l
(third l)
(loop
(let ((s (read-string "Define: " :history 'hide-ifdef-define)))
(when (string= s "")
(return l))
(pushnew s l)))))
(let ((l (assoc (default-directory) *hide-ifdef-parameter-alist*
:test #'(lambda (x y) (string-matchp (append-trail-slash (namestring y)) x)))))
(if l
(fourth l)
(loop
(let ((s (read-string "Undefine: " :history 'hide-ifdef-undefine)))
(when (string= s "")
(return l))
(pushnew s l)))))))
(let ((bak (or *hide-ifdef-cpp-flags* "")))
(setf *hide-ifdef-cpp-flags*
(concat bak
(apply #'concat
(when include
(mapcar #'(lambda (x) (concat " -I\"" (namestring x) "\""))
include)))
(apply #'concat
(when define
(mapcar #'(lambda (x) (concat " -D" x))
define)))
(apply #'concat
(when undefine
(mapcar #'(lambda (x) (concat " -U" x))
undefine)))))
(funcall *original-hide-ifdef*)
(setf *hide-ifdef-cpp-flags* bak)))
Raw
meadow-func.lisp
;; -*- Mode: Lisp; Package: ed -*-
(provide "meadow-func")
(in-package :ed)
(export
'(*help-map*
help-prefix
*local-help-alist*
*help-for-help-text*
*help-for-help-height*
*parens-require-spaces*
*list-directory-directory-on-the-top*
*list-directory-sort-method*
*list-directory-sort-ascending*
kill-whole-line
kill-buffer-and-window
scroll-other-window-down
beginning-of-buffer-other-window
end-of-buffer-other-window
previous-error
find-file-read-only-other-window
count-lines-page
count-lines-region
def-show-html-help
display-local-help
help-for-help
indent-rigidly
narrow-to-defun
narrow-to-page
revert-buffer-with-coding-system
list-directory
insert-register
view-register
number-to-register
set-format-register
increment-register
find-file-other-pseudo-frame
find-file-read-only-pseudo-other-frame
delete-other-pseudo-frames
display-buffer-other-pseudo-frame
switch-to-buffer-other-pseudo-frame
kbd-macro-insert-counter
kbd-macro-set-counter
kbd-macro-add-counter
kbd-macro-set-format
start-kbd-macro-or-insert-counter
end-and-call-last-kbd-macro
end-or-call-last-kbd-macro
jump-tag-other-pseudo-frame
insert-parentheses
move-past-close-and-reindent))
; F1
(defvar *help-map* (make-sparse-keymap))
(setf (symbol-function 'help-prefix) *help-map*)
; (global-set-key #\F1 'help-prefix)
; (define-key *help-map* #\C-a 'about-dialog)
; (define-key *help-map* #\. 'display-local-help)
; (define-key *help-map* #\? 'help-for-help)
; (define-key *help-map* #\S 'user::immr)
; (define-key *help-map* #\b 'describe-bindings)
; (define-key *help-map* #\c 'describe-key-briefly)
; (define-key *help-map* #\f 'describe-function)
; (define-key *help-map* #\i 'user::reference-show)
; (define-key *help-map* #\k 'describe-key)
; (define-key *help-map* #\s 'user::imm1)
; (define-key *help-map* #\v 'describe-variable)
; (define-key *help-map* #\F1 'help-for-help)
(defvar-local local-help-variable nil
"Local Help の関数シンボル or ファイル名(.chm)")
(defvar *help-for-help-text*
(concat "You have typed <f1>, the help character. Type a Help option:\n"
"(Use SPC or DEL to scroll through this text. Type q to exit the Help command.)\n"
"\n"
"b describe-bindings. Display a table of all key bindings.\n"
"c describe-key-briefly. Type a key sequence; it displays the command name run by that key sequence\n"
"f describe-function. Type a function name and you see its documentation.\n"
"i info. The Info documentation reader: read on-line manuals.\n"
"k describe-key. Type a key sequence it displays the full documentation for that key sequence.\n"
"s info-current-symbol. it goes to that symbol in the on-line manual for the programming language used in this buffer.\n"
"S info-lookup-symbol. Type a symbol; it goes to that symbol in the on-line manual for the programming language used in this buffer.\n"
"v describe-variable. Type name of a variable; it displays the variable's documentation and value.\n"
". display-local-help. Display any available local help at point.\n"
"\n"
"C-a Display information about xyzzy.")
"help-for-help の文章")
(defvar *help-for-help-height* 16
"help-for-help のウィンドウの高さ")
(defvar *kbd-macro-format* "~D"
"キーボードマクロカウンターの出力指定子")
(defvar *kbd-macro-counter* 0
"キーボードマクロカウンター")
(defvar *parens-require-spaces* t
"直前にスペースが無かった場合、スペースを挿入")
(defvar *list-directory-directory-on-the-top* t
"ディレクトリツリーの出力でディレクトリを先頭に集める")
(defvar *list-directory-sort-method* 0
"ディレクトリツリーの出力のソート方法(0:名前 1:拡張子 2:日付 3:サイズ)")
(defvar *list-directory-sort-ascending* t
"ディレクトリツリーの出力のソートが昇順か")
; exkey-C-backspace
(defun kill-whole-line (&optional lines)
"行全体を削除[C-BackSpace]"
(interactive "*p")
(goto-bol)
(kill-line (cond (lines lines)
((bolp) 1))))
; C-x 4 0
(defun kill-buffer-and-window ()
"現在のバッファとウィンドウを削除[C-x 4 0]"
(interactive)
(delete-buffer (selected-buffer))
(delete-window))
; ESC PageDown
; ESC C-v
(defun scroll-other-window-down (&optional arg)
"次のウィンドウを上スクロール[ESC C-v], [ESC PageDown]"
(interactive "p")
(scroll-other-window (not arg)))
; ESC Home
(defun beginning-of-buffer-other-window ()
"次のウィンドウのカーソルをバッファの先頭に移動[ESC Home]"
(interactive)
(other-window 1)
(beginning-of-buffer)
(other-window -1))
; ESC End
(defun end-of-buffer-other-window ()
"次のウィンドウのカーソルをバッファの末尾に移動[ESC End]"
(interactive)
(other-window 1)
(end-of-buffer)
(other-window -1))
; ESC g p
(defun previous-error (&optional arg)
"前のエラーの該当行にジャンプ[ESC g p]"
(interactive "p")
(next-error (if arg (- arg) -1)))
; C-x 4 r
(defun find-file-read-only-other-window (filename &optional encoding nomsg)
"指定されたファイルを別のウィンドウで書き込み禁止で開く[C-x 4 r]"
(interactive "lFind file read-only other window: \n0zEncoding: "
:title0 "Find file read-only other window")
(find-file-other-window filename encoding nomsg)
(toggle-read-only t))
; C-x l
(defun count-lines-page ()
"ページの行数, 文字数を取得[C-x l]"
(interactive)
(let ((s) (e)
(c (current-line-number)))
(save-excursion
(goto-char (point-min))
(setf s (current-line-number))
(goto-char (point-max))
(setf e (current-line-number)))
(message "Page has ~D lines (~D + ~D)" (+ (- e s) 1) (- c s) (- e c))))
; ESC =
(defun count-lines-region (from to)
"リージョンの行数, 文字数を取得[ESC =]"
(interactive "r")
(let ((s) (e))
(save-excursion
(goto-char from)
(setf s (current-line-number))
(goto-char to)
(setf e (current-line-number)))
(message "Region has ~D lines, ~D charactors" (+ (- e s) 1) (+ (- to from) 1))))
(defun buffer-substring-at-point (&optional prompt)
"カーソル下の単語を取得する"
(save-excursion
(cond ((and prompt
*prefix-args*)
(read-string prompt))
((pre-selection-p)
(selection-start-end (s e)
(buffer-substring s e)))
((and (mark t)
(modulep "rv-region")
(find (intern "rv-region") *post-command-hook*))
(buffer-substring (region-beginning) (region-end)))
(t
(buffer-substring (progn
(or (skip-syntax-spec-forward "w_")
(skip-syntax-spec-backward "^w_"))
(point))
(progn
(skip-syntax-spec-backward "w_")
(point)))))))
(defmacro def-show-html-help (func-name help-path)
"HTML Help を参照する関数生成マクロ"
`(defun ,func-name (&optional str)
,(concat (file-namestring (eval help-path)) " を表示")
(interactive)
(when (and ,help-path
(file-exist-p ,help-path))
(html-help ,help-path (ed::buffer-substring-at-point "Reference: ")))))
; F1 .
(defun display-local-help ()
"Local Help を表示[F1 .]"
(interactive)
(cond ((stringp local-help-variable)
(when (file-exist-p local-help-variable)
(html-help local-help-variable (buffer-substring-at-point "Reference: "))))
((fboundp local-help-variable)
(funcall (symbol-function local-help-variable)))
(t
(message "No local help."))))
; F1 F1
(defun help-for-help ()
"HelpのHelp[F1 F1]"
(interactive)
(let ((name "*Help*")
(buff (selected-buffer))
(c) (f))
(save-window-excursion
(delete-other-windows)
(split-window (- *help-for-help-height*))
(other-window)
(with-output-to-temp-buffer (name)
(insert *help-for-help-text*)
(goto-char (point-min))
(make-local-variable 'buffer-read-only)
(setf buffer-read-only t)
(make-local-variable 'need-not-save)
(setf need-not-save t)
(make-local-variable 'auto-save)
(setf auto-save nil)
(make-local-variable 'kept-undo-information)
(setf kept-undo-information nil))
(loop
(minibuffer-prompt "Type one of the options listed, or SPC or Delete to scroll: ")
(case (setf c (read-char ed:*keyboard*))
((#\SPC)
(next-page))
((#\Delete)
(previous-page))
(t
(return))))
(delete-buffer name))
(when (setf f (lookup-keymap *help-map* c))
(call-interactively f))))
; C-x TAB
(defun indent-rigidly (from to arg)
"全ての行を字下げ[C-x TAB]"
(interactive "*r\nNHow many colmns to indent by?: ")
(let ((space "")
(regexp (compile-regexp "^")))
(dotimes (i arg)
(setf space (concat space " ")))
(save-excursion
(goto-char from)
(scan-buffer regexp :tail t)
(while (< (point) to)
(insert space)
(scan-buffer regexp :tail t)))))
; C-x r d
(defun narrow-to-defun (&optional move-count)
"指定した関数以外を移動・編集できないように[C-x r d]"
(interactive)
(let ((from) (to))
(save-excursion
(beginning-of-defun)
(setf from (point))
(end-of-defun)
(setf to (point)))
(narrow-to-region from to)))
; C-x r p
(defun narrow-to-page (&optional move-count)
"指定したページ以外を移動・編集できないように[C-x r p]"
(interactive)
(let ((from) (to)
(p *page-scroll-half-window*)
(old-point (point)))
(setf *page-scroll-half-window* t)
(save-excursion
(previous-page)
(goto-bol)
(setf from (point))
(goto-char old-point)
(goto-eol)
(next-page)
(setf to (point)))
(setf *page-scroll-half-window* p)
(narrow-to-region from to)))
; C-x RET r
(defun revert-buffer-with-coding-system (encoding)
"文字コード指定して再読み込み[C-x RET r]"
(interactive "zEncoding: ")
(revert-buffer encoding))
; C-x C-d
(defun list-directory (dirname pattern &optional file-info)
"ディレクトリツリーを出力[C-x C-d]"
(interactive "Ddirectory: \nsPattern: \np"
:default0 (if (get-buffer-file-name)
(directory-namestring (get-buffer-file-name))
(default-directory))
:default1 ".*")
(with-output-to-temp-buffer ("*directory*")
(save-excursion
(format t "Directory ~A~%~%" (merge-pathnames dirname))
(let ((len 3) (s)
(regexp1 (compile-regexp pattern))
(regexp2 (compile-regexp "[^.]+\\.\\([^.]+\\)$"))
(regexp3 (compile-regexp "\\.[^.]+$")))
(mapcar #'(lambda (x)
(when (string-match regexp1 (first x))
(if file-info
(format t
(format nil
"~~[-~~:;d~~]r~~[w~~:;-~~]~~[-~~:;x~~]~~[-~~:;h~~]~~[-~~:;s~~]~~[-~~:;c~~] ~~~D:D ~~A ~~A~~%"
len)
(logand (second x) *file-attribute-directory*)
(logand (second x) *file-attribute-readonly*)
(logand (second x) *file-attribute-archive*)
(logand (second x) *file-attribute-hidden*)
(logand (second x) *file-attribute-system*)
(logand (second x) *file-attribute-compressed*)
(fourth x)
(format-date-string "%Y-%m-%d %H:%M:%S" (third x))
(first x))
(format t "~A~%" (first x)))))
(sort (directory dirname :file-info t)
(if *list-directory-sort-ascending*
#'string-lessp
#'string-greaterp)
:key #'(lambda (x)
(when (< len (setf s (length (format nil "~:D" (fourth x)))))
(setf len s))
(concat (when *list-directory-directory-on-the-top*
(if *list-directory-sort-ascending*
(format nil "~[1~:;0~]" (logand (second x) *file-attribute-directory*))
(format nil "~[0~:;1~]" (logand (second x) *file-attribute-directory*))))
(case *list-directory-sort-method*
(0 (first x))
(1 (cond ((string-match regexp2 (first x))
(match-string 1))
((string-match regexp3 (first x))
(match-string 0))
(t
(concat "/" (first x)))))
(2 (format nil "~D" (third x)))
(3 (format nil "~15,'0D" (fourth x)))
(t (first x)))))))))
(make-local-variable 'buffer-read-only)
(setf buffer-read-only t)
(make-local-variable 'need-not-save)
(setf need-not-save t)
(make-local-variable 'auto-save)
(setf auto-save nil)
(make-local-variable 'kept-undo-information)
(setf kept-undo-information nil)))
; C-x r g
; C-x r i
(defun ed::insert-register (r)
"レジスタ R の内容をバッファに挿入[C-x r g], [C-x r i]" ; 数値対応
(interactive "cInsert register: ")
(let ((val (ed::get-register r)))
(cond ((and (consp val)
(not (eq (first val) 'window-configuration)))
(let ((*rectangle-kill-buffer* val))
(yank-rectangle)))
((and (consp val)
(numberp (first val))
(stringp (second val)))
(insert (format nil (second val) (first val))))
((stringp val)
(insert val))
((null val)
(error "レジスタ~Aが設定されていません" r))
(t
(error "レジスタにテキストが入っていません")))))
; C-x r v
(defun ed::view-register (r)
"レジスタ R の中身をバッファ *output* に表示[C-x r v]" ; 数値対応
(interactive "cView register: ")
(let ((val (ed::get-register r)))
(if (null val)
(message "Register ~A is empty" r)
(with-output-to-temp-buffer ("*output*")
(format t "Register \"~A\" contains " r)
(cond ((markerp val)
(let ((buffer (marker-buffer val)))
(if (null buffer)
(princ "a marker in deleted buffer.")
(format t "a buffer position:\nbuffer ~A, position ~A"
(buffer-name buffer) (marker-point val)))))
((and (consp val)
(eq (first val) 'window-configuration))
(princ "a window configuration."))
((and (consp val)
(numberp (first val))
(stringp (second val)))
(format t "the number:\n~A (~D)" (format nil (second val) (first val)) (first val)))
((consp val)
(format t "the rectangle:\n~{~A~^\n~}" val))
((stringp val)
(format t "the text:\n~A" val))
(t
(format t "Garbage:\n~S" val)))
(make-local-variable 'buffer-read-only)
(setf buffer-read-only t)
(make-local-variable 'need-not-save)
(setf need-not-save t)
(make-local-variable 'auto-save)
(setf auto-save nil)
(make-local-variable 'kept-undo-information)
(setf kept-undo-information nil)))))
; C-x r n
(defun number-to-register (r &optional num)
"レジスタ R に数値をセット[C-x r n]"
(interactive "cNumber to register: \np")
(let ((val (ed::get-register r)))
(if (and (consp val)
(numberp (first val))
(stringp (second val)))
(setf val (list (if num num 0) (second val)))
(setf val (list (if num num 0) "~D")))
(ed::set-register r val)
(message "Register ~A: ~A (~D)" r (format nil (second val) (first val)) (first val))))
; C-x r f
(defun set-format-register (r fs)
"レジスタ R の数値の出力指定子の変更[C-x r f]"
(interactive "cSet format register: \nsRegister format (xyzzy format): ")
(let ((val (ed::get-register r)))
(cond ((and (consp val)
(numberp (first val))
(stringp (second val)))
(setf val (list (first val) fs))
(ed::set-register r val)
(message "Register ~A: ~A (~D)" r (format nil (second val) (first val)) (first val)))
((null val)
(setf val (list 0 fs))
(ed::set-register r val)
(message "Register ~A: ~A (~D)" r (format nil (second val) (first val)) (first val)))
(t
(error "レジスタに数値が入っていません")))))
; C-x r +
(defun increment-register (r &optional num)
"レジスタ R の数値をインクリメント[C-x r +]"
(interactive "cIncrement register: \np")
(let ((val (ed::get-register r)))
(cond ((and (consp val)
(numberp (first val))
(stringp (second val)))
(setf val (list (+ (first val) 1) (second val)))
(ed::set-register r val)
(message "Register ~A: ~A (~D)" r (format nil (second val) (first val)) (first val)))
((null val)
(error "レジスタ~Aが設定されていません" r))
(t
(error "レジスタに数値が入っていません")))))
; C-x 5 f
; C-x 6 f
(defun find-file-other-pseudo-frame (name filename &optional encoding nomsg)
"指定されたファイルを新しいフレームで開く[C-x 5 f], [C-x 6 f]"
(interactive (list (progn
(pseudo-frame-check-minibuffer)
(make-pseudo-frame-name))
(read-file-name-list "Find file other pseudo frame: "
:title "Find file other pseudo frame")
(when *prefix-args*
(read-char-encoding "Encoding: "))))
(new-pseudo-frame name t)
(find-file filename encoding nomsg))
; C-x 5 r
; C-x 6 r
(defun find-file-read-only-pseudo-other-frame (name filename &optional encoding nomsg)
"指定されたファイルを新しいフレームで書き込み禁止で開く[C-x 5 r], [C-x 6 r]"
(interactive (list (progn
(pseudo-frame-check-minibuffer)
(make-pseudo-frame-name))
(read-file-name-list "Find file read-only other pseudo frame: "
:title "Find file read-only other pseudo frame")
(when *prefix-args*
(read-char-encoding "Encoding: "))))
(new-pseudo-frame name t)
(find-file filename encoding nomsg)
(toggle-read-only t))
; C-x 5 1
; C-x 6 1
(defun delete-other-pseudo-frames ()
"他のフレームを削除[C-x 5 1], [C-x 6 1]"
(interactive)
(let ((f (selected-pseudo-frame)))
(next-pseudo-frame)
(loop
(when (eq f (selected-pseudo-frame))
(return))
(delete-pseudo-frame))))
; C-x 5 C-o
; C-x 6 C-o
(defun display-buffer-other-pseudo-frame (name buffer &optional not-this-window)
"新しいフレームに、指定されたバッファをポップアップ[C-x 5 C-o], [C-x 6 C-o]"
(interactive (list (progn
(pseudo-frame-check-minibuffer)
(make-pseudo-frame-name))
(read-buffer-name "Display buffer: ")
*prefix-args*))
(new-pseudo-frame name t)
(display-buffer buffer not-this-window))
; C-x 5 b
; C-x 6 b
(defun switch-to-buffer-other-pseudo-frame (name buffer &optional nowarn)
"指定されたバッファに移動し、新しいフレームに移動[C-x 5 b], [C-x 6 b]"
(interactive (list (progn
(pseudo-frame-check-minibuffer)
(make-pseudo-frame-name))
(read-buffer-name "Switch to buffer: " :default (other-buffer))))
(new-pseudo-frame name t)
(switch-to-buffer buffer nowarn))
; C-x C-k TAB
(defun kbd-macro-insert-counter (&optional num)
"キーボードマクロカウンターの挿入[C-x C-k TAB]"
(interactive "p")
(insert (format nil "~D" *kbd-macro-counter*))
(setf *kbd-macro-counter* (+ *kbd-macro-counter* (if num num 1)))
(message "New macro counter: ~A (~D)" (format nil *kbd-macro-format* *kbd-macro-counter*) *kbd-macro-counter*))
; C-x C-k C-c
(defun kbd-macro-set-counter (&optional num)
"キーボードマクロカウンターへ値を代入[C-x C-k C-c]"
(interactive (list (if *prefix-args*
*prefix-value*
(read-integer "Macro counter value: "))))
(setf *kbd-macro-counter* num)
(message "New macro counter: ~A (~D)" (format nil *kbd-macro-format* *kbd-macro-counter*) *kbd-macro-counter*))
; C-x C-k C-a
(defun kbd-macro-add-counter (&optional num)
"キーボードマクロカウンターへ値を加算[C-x C-k C-a]"
(interactive (list (if *prefix-args*
*prefix-value*
(read-integer "Add to macro counter: "))))
(setf *kbd-macro-counter* (+ *kbd-macro-counter* num))
(message "New macro counter: ~A (~D)" (format nil *kbd-macro-format* *kbd-macro-counter*) *kbd-macro-counter*))
; C-x C-k C-f
(defun kbd-macro-set-format (fs)
"キーボードマクロカウンターの出力指定子の変更[C-x C-k C-f]"
(interactive "sMacro counter Format (xyzzy format): ")
(setf *kbd-macro-format* fs)
(message "New macro counter: ~A (~D)" (format nil *kbd-macro-format* *kbd-macro-counter*) *kbd-macro-counter*))
; F3
(defun start-kbd-macro-or-insert-counter (&optional arg)
"キーボードマクロの定義開始、もしくはカウンターの挿入[F3]"
(interactive "p")
(if (kbd-macro-saving-p)
(kbd-macro-insert-counter arg)
(start-kbd-macro arg)))
; C-x e
(defun end-and-call-last-kbd-macro (&optional arg)
"キーボードマクロの定義終了をして、実行[C-x e]"
(interactive "p")
(when (kbd-macro-saving-p)
(end-kbd-macro arg))
(when *last-kbd-macro*
(call-last-kbd-macro arg)))
; F4
; C-x C-k C-k
(defun end-or-call-last-kbd-macro (&optional arg)
"キーボードマクロの定義終了、もしくは実行[F4], [C-x C-k C-k]"
(interactive "p")
(if (kbd-macro-saving-p)
(end-kbd-macro arg)
(when *last-kbd-macro*
(call-last-kbd-macro arg))))
; C-x 5 .
; C-x 6 .
(defun jump-tag-other-pseudo-frame (name)
"新しいフレームでタグジャンプ[C-x 5 .], [C-x 6 .]"
(interactive (list (progn
(pseudo-frame-check-minibuffer)
(make-pseudo-frame-name))))
(new-pseudo-frame name t)
(jump-tag))
; ESC (
(defun insert-parentheses ()
"括弧を挿入し、カーソルをその間に移動[ESC (]"
(interactive)
(when *parens-require-spaces*
(unless (string-match "[ \t\r\n(]" (buffer-substring (- (point) 1) (point)))
(insert " ")))
(insert "()")
(backward-char))
; ESC )
(defun move-past-close-and-reindent ()
"つぎの閉じ括弧のうしろへ移動してから字下げ[ESC )]"
(interactive)
(let ((regexp (compile-regexp "[()]"))
(bracket 1) (p (point)))
(save-excursion
(while (> bracket 0)
(unless (scan-buffer regexp)
(quit))
(cond ((string= (match-string 0) "(")
(setf bracket (+ bracket 1)))
((string= (match-string 0) ")")
(setf bracket (- bracket 1))
(when (<= bracket 0)
(forward-char)
(setf p (point))
(newline)
(forward-char)
(indent-region p (point))
(setf p (point)))))
(forward-char)))
(goto-char p)))
Raw
mercurial-cygwin.lisp
; (eval-when (:compile-toplevel :load-toplevel :execute)
; (require "mercurial"))
(require "mercurial")
(provide "mercurial-cygwin")
(in-package :ed)
(export
'(*hg-cyg-shell*
*hg-encoding*
*hg-default-diff*
def-hg-extdiff
hg-diff-repo
hg-log-repo
hg-register
hg-next-action
hg-version-other-window
hg-pop-commit-message))
(setf *hg-binary* "hg")
(defvar *hg-cyg-shell* "bash -c"
"mercurial で使用するshell")
(defvar *hg-encoding* *encoding-utf8n*
"mercurial の encoding")
(defvar *hg-default-diff* "diff"
"mercurial で使用するdiff")
(defmacro def-hg-extdiff (sym)
"extdiff の定義"
`(progn
(export (intern (concat "hg-" ,sym) :ed) :ed)
(export (intern (concat "hg-" ,sym "-repo") :ed) :ed)
(defun ,(intern (concat "ed::hg-" sym)) ()
,(concat "ファイルのdiff表示 (" sym ")")
(interactive)
(hg-command-wrapper ,sym *prefix-args* t))
(defun ,(intern (concat "ed::hg-" sym "-repo")) ()
,(concat "リポジトリのdiff表示 (" sym ")")
(interactive)
(hg-command-wrapper ,sym *prefix-args*))))
(defun cyg-command-line (cmd dir)
"bash でのコマンドラインを返す"
(values (format nil "~A \"~A\""
*hg-cyg-shell*
(substitute-string cmd "\\([a-z]\\):\/" "/cygdrive/\\1/" :case-fold t))
dir))
(defun ed::execute-shell-command-no-popup (command &optional infile output environ directory)
"画面分割しない execute-shell-command"
(save-excursion
(let ((outfile))
(unless directory
(setf directory (default-directory)))
(pushnew '("LANG" . "ja_JP.UTF-8") environ :test #'equal)
(pushnew '("HGENCODING" . "utf-8") environ :test #'equal)
(pushnew '("CYGWIN" . "nodosfilewarning") environ :test #'equal)
(unwind-protect
(prog2
(when output
(setf outfile (make-temp-file-name)))
(multiple-value-bind (cmdline dir)
(cyg-command-line command directory)
(call-process cmdline
:input infile
:output outfile
:exec-directory dir
:environ environ
:show :hide
:wait t))
(when output
(let ((new))
(unless (bufferp output)
(setf output (or (find-buffer output)
(progn
(setf new t)
(create-new-buffer output)))))
(erase-buffer output)
(update-visited-file-modtime)
(set-buffer output)
(insert-file outfile *hg-encoding*)
(and new
(setf need-not-save t))
(set-buffer-modified-p nil)
(set-default-directory directory))))
(when outfile
(delete-file outfile))))))
(defun ed::hg-encode-filename (filename)
".hg/store用にファイル名をエンコード"
(let ((str ""))
(dolist (c (coerce filename 'list))
(let* ((cc (char-unicode (character c)))
(c (cond ((<= cc #x007f)
cc)
((<= cc #x07ff)
(logior (ash (logand cc #x07c0) 2)
(logand cc #x003f)
#xc080))
((<= cc #xffff)
(logior (ash (logand cc #xf000) 4)
(ash (logand cc #x0fc0) 2)
(logand cc #x003f)
#xe08080))
((<= cc #x1fffff)
(logior (ash (logand cc #x1c0000) 6)
(ash (logand cc #x03f000) 4)
(ash (logand cc #x000fc0) 2)
(logand cc #x00003f)
#xf0808080))
(t
(error "UTF-8の範囲外 : ~A" c))))
(uu_bit (ash c -24))
(l_bit (ash (logand c #xff0000) -16))
(m_bit (ash (logand c #xff00) -8))
(l_bit (logand c #xff)))
(cond ((> cc #x007f)
(cond ((<= cc #x07ff)
(setf str (format nil "~A~~~X~~~X" str m_bit l_bit)))
((<= cc #xffff)
(setf str (format nil "~A~~~X~~~X~~~X" str l_bit m_bit l_bit)))
((<= cc #x1fffff)
(setf str (format nil "~A~~~X~~~X~~~X~~~X" str ul_bit l_bit m_bit l_bit)))))
((not (setf l (code-char l_bit)))
(setf str (format nil "~A~A" str l_bit)))
((upper-case-p l)
(setf str (format nil "~A_~A" str (char-downcase l))))
((char-name l)
(setf str (format nil "~A~A" str l)))
(t
(setf str (format nil "~A~~~X" str l_bit))))))
str))
(defun ed::hg-string-in-file (str file)
"ファイルに文字列が含まれているかチェック"
(save-excursion
(let ((buf (get-buffer-create *hg-tmp-bufname*)))
(set-buffer buf)
; (set-buffer-fileio-encoding *hg-encoding*)
(insert-file file *hg-encoding*)
(goto-char (point-min))
(prog1
(scan-buffer str)
(delete-buffer buf)))))
(defun ed::hg-show-output (output &optional to-buffer error-p)
"アウトプットウィンドウの表示"
(let* ((curbuf (selected-buffer))
(output-buffer (or to-buffer
(get-buffer-create *hg-output-bufname*)))
(need-split (and (not (get-buffer-window output-buffer))
(= (count-windows) 1))))
(set-buffer output-buffer)
(hg-output-mode)
(when (get-buffer-file-name curbuf)
(set-default-directory (directory-namestring (get-buffer-file-name curbuf))))
(setf buffer-read-only nil)
(delete-region (point-min) (point-max))
; (insert (substitute-string output "\n" "")) ;do i need this?
(insert output)
(setf buffer-read-only t)
(goto-char (point-min))
(when error-p
(set-text-attribute (point-min) (point-max) 'error
:foreground *hg-output-color-error*))
(undo-boundary)
(set-buffer curbuf)
(when need-split
(split-window nil *hg-output-split-vertically*))
(pop-to-buffer output-buffer nil t)))
(defun ed::hg-show-commit-files (repo)
"コミットファイルウィンドウの表示"
(let ((filesbuf (get-buffer-create *hg-commit-files-bufname*)))
(set-buffer filesbuf)
(hg-show-commit-files-mode)
(setf buffer-read-only nil)
(erase-buffer filesbuf)
(insert "Click or SPC to select. Files in bold will be committed.\n")
(insert (rest (hg-execute "status -mard" repo)))
(goto-char (point-min))
(while (forward-line)
(hg-scf-select-file))
(goto-char (point-min))
(setf buffer-read-only t)
(setf hg-repo repo)))
(defun ed::hg-show-commit-message ()
"コミットメッセージウィンドウの表示"
(let ((buf (get-buffer-create *hg-commit-bufname*)))
(split-window nil nil)
(other-window)
(set-buffer buf)
(use-keymap hg-commit-message-map)
(erase-buffer buf)
(set-buffer-fileio-encoding *hg-encoding*)
; (insert "HG: Commit Message Comes Here. C-c C-g to CANCEL commit.")
(pop-to-buffer (find-buffer *hg-commit-files-bufname*) nil)))
(defun ed::hg-commit (&optional arg)
"コミット"
(interactive "p")
(if *prefix-args*
;When called with prefix-args
(let ((s (selected-buffer)))
(and (hg-command-wrapper "commit" t)
; (y-or-n-p "~A" s)
(hg-set-modes-after-operation s)))
;else show 3-pane commit session
(when (and (setf f (get-buffer-file-name))
(hg-find-repo-directory f))
(let ((curbuf (selected-buffer)))
(setf *hg-winconf-before-commit* (current-window-configuration))
(setf *hg-commit-repo* (hg-find-repo-directory (get-buffer-file-name)))
(delete-other-windows)
(hg-show-commit-files *hg-commit-repo*)
(hg-show-output (rest (hg-execute *hg-default-diff* *hg-commit-repo*)))
(other-window)
(hg-show-commit-message)))))
(defun ed::hg-scf-update-diff ()
"コミット時の diff の更新"
(message "Updating diff...")
(let* ((selected-files (hg-scf-selected-files))
(opts (format nil "~{ -I ~A~}" selected-files)))
(if selected-files
(hg-show-output (rest (hg-execute (concat *hg-default-diff* opts) hg-repo)))
(hg-show-error "No diff output.")))
(message "Updating diff... Done."))
(defun hg-diff-repo ()
"リポジトリのdiff表示"
(interactive)
(hg-command-wrapper "diff" *prefix-args*))
(defun hg-log-repo (&optional arg)
"リポジトリのログ閲覧"
(interactive)
(setf option (if (numberp *hg-log-default-limit*)
(format nil "-l ~A" *hg-log-default-limit*)
""))
(hg-command-wrapper (format nil "log ~A" option) *prefix-args*))
(defun hg-register (&optional arg)
"リポジトリの初期化・ファイルの登録"
(interactive "p")
(let ((f (get-buffer-file-name)))
(cond ((not (hg-find-repo-directory f))
(hg-init)
(message "hg init ~A" (hg-find-repo-directory f)))
((not (hg-tracked-p f))
(hg-add arg)
(message "hg add ~A" (substitute-string f (hg-find-repo-directory f) ""))))))
(defun hg-next-action (&optional arg)
"リポジトリの初期化・ファイルの登録・更新"
(interactive "p")
(let ((f (get-buffer-file-name)))
(cond ((not (hg-find-repo-directory f))
(hg-init)
(message "hg init ~A" (hg-find-repo-directory f)))
((not (hg-tracked-p f))
(hg-add arg)
(message "hg add ~A" (substitute-string f (hg-find-repo-directory f) "")))
(t
(hg-commit arg)))))
(defun hg-version-other-window (&optional arg)
"リビジョンのファイル表示"
(interactive
(list (unless *prefix-args*
(let ((l) (s 0)
(argument (concat "\"" (get-buffer-file-name) "\""))
(option (concat (if (numberp *hg-log-default-limit*)
(format nil "-l ~A " *hg-log-default-limit*)
"")
"--style compact")))
(setf hg-output (hg-execute (format nil "log ~A ~A" option argument)))
(while (string-match "^\\([0-9]+\\)[ \\[]" (rest hg-output) s)
(setf s (match-end 1))
(pushnew (match-string 1) l))
(completing-read "NVersion to visit (default is workfile version): " l :must-mutch t)))))
(let ((option (if (or (null arg)
(string= arg ""))
""
(format nil "-r ~A" arg))))
(hg-command-wrapper (format nil "cat ~A" option) nil t)))
(defun hg-pop-commit-message ()
"コミットメッセージウィンドウへ移動"
(interactive)
(pop-to-buffer (find-buffer *hg-commit-bufname*) nil))
(define-key hg-show-commit-files-map #\TAB 'hg-pop-commit-message)
Raw
module-definition-mode.lisp
;; -*- Mode: Lisp; Package: ed -*-
(provide "module-definition-mode")
(in-package :ed)
(export
'(module-definition-mode
*module-definition-tab-always-indent*
*module-definition-indent-tabs-mode*
*module-definition-comment-column*
*module-definition-mode-hook*))
(unless (boundp 'module-definition-indent-level)
(setf module-definition-indent-level 8)
(setf module-definition-label-offset -8))
(defvar *module-definition-tab-always-indent* nil)
(defvar *module-definition-indent-tabs-mode* nil)
(defvar *module-definition-comment-column* nil)
(defvar *module-definition-mode-hook* nil)
(defvar *module-definition-beginning-of-label-regexp*
(compile-regexp
(concat "^[ \t]*\\("
"EXPORTS\\|"
"HEAPSIZE\\|"
"LIBRARY\\|"
"NAME\\|"
"SECTIONS\\|"
"STACKSIZE\\|"
"STUB\\|"
"VERSION\\)") t))
(defvar *module-definition-mode-map* nil)
(unless *module-definition-mode-map*
(setq *module-definition-mode-map* (make-sparse-keymap))
(define-key *module-definition-mode-map* #\TAB 'module-definition-indent-line)
(define-key *module-definition-mode-map* #\RET 'module-definition-newline-and-indent))
(defvar *modile-definition-keywords*
(compile-regexp-keyword-list
`(("^EXPORTS" t (:keyword 0))
("^HEAPSIZE" t (:keyword 0))
("^LIBRARY" t (:keyword 0))
("^NAME" t (:keyword 0))
("^SECTIONS" t (:keyword 0))
("^STACKSIZE" t (:keyword 0))
("^STUB" t (:keyword 0))
("^VERSION" t (:keyword 0))
("@[0-9]+" t (:color 2)))))
(defvar *module-definition-mode-syntax-table* nil)
(unless *module-definition-mode-syntax-table*
(setf *module-definition-mode-syntax-table* (make-syntax-table))
(do ((x #x21 (1+ x)))((>= x #x7f))
(let ((c (code-char x)))
(unless (alphanumericp c)
(set-syntax-punctuation *module-definition-mode-syntax-table* c))))
(set-syntax-string *module-definition-mode-syntax-table* #\")
(set-syntax-string *module-definition-mode-syntax-table* #\')
(set-syntax-escape *module-definition-mode-syntax-table* #\\)
(set-syntax-symbol *module-definition-mode-syntax-table* #\_)
(set-syntax-symbol *module-definition-mode-syntax-table* #\#)
(set-syntax-match *module-definition-mode-syntax-table* #\( #\))
(set-syntax-match *module-definition-mode-syntax-table* #\{ #\})
(set-syntax-match *module-definition-mode-syntax-table* #\[ #\])
(set-syntax-start-comment *module-definition-mode-syntax-table* #\;)
(set-syntax-end-comment *module-definition-mode-syntax-table* #\LFD))
(defun module-definition-mode ()
"モジュール定義ファイル読み書きモード"
(interactive)
(kill-all-local-variables)
(setf buffer-mode 'module-definition-mode)
(setf mode-name "ModuleDefinition")
(use-syntax-table *module-definition-mode-syntax-table*)
(use-keymap *module-definition-mode-map*)
(make-local-variable 'regexp-keyword-list)
(setf regexp-keyword-list *modile-definition-keywords*)
(make-local-variable 'paragraph-start)
(setf paragraph-start "^$\\|\f")
(make-local-variable 'paragraph-separate)
(setf paragraph-separate paragraph-start)
(make-local-variable 'indent-tabs-mode)
(setf indent-tabs-mode *module-definition-indent-tabs-mode*)
(make-local-variable 'mode-specific-indent-command)
(setq mode-specific-indent-command 'module-definition-indent-line)
(setf comment-start "; ")
(setf comment-end "")
(setf comment-start-skip ";+[ \t]*")
(when *module-definition-comment-column*
(setf comment-column *module-definition-comment-column*))
(run-hooks '*module-definition-mode-hook*))
(defun module-definition-indent-line ()
"現在行をインデント"
(interactive "*")
(if (or (not (interactive-p))
*module-definition-tab-always-indent*
(save-excursion
(skip-chars-backward " \t")
(bolp)))
(let ((column module-definition-indent-level))
(save-excursion
(goto-bol)
(if (looking-at *module-definition-beginning-of-label-regexp*)
(setf column (+ column module-definition-label-offset))))
(when (integerp column)
(smart-indentation column)))
(insert "\t"))
t)
(defun module-definition-newline-and-indent (&optional (arg 1))
"改行し、インデント"
(interactive "*p")
(delete-trailing-spaces)
(insert #\LFD arg)
(module-definition-indent-line))
Raw
multiple-frames-fix.lisp
;; -*- mode: lisp; package: user; encoding: shift_jis -*-
;; @name multiple-frames-fix.l
;; @description マルチフレーム版対応
;; @namespace http://kuonn.mydns.jp/
;; @author DeaR
;; @timestamp <2012-04-09 18:05:35 DeaR>
(provide "multiple-frames-fix")
(export
(mapcar #'(lambda (s)
(intern (symbol-name s) :ed))
'(#:*app-menu*
#:*app-popup-menu*))
:ed)
(in-package :user)
;;--------------------------------------------------------------------------------
;; macro
(defmacro merge-app-menu (&body body)
"*app-menu*をマージして実行"
`(progn
(let ((original-app-menu ed::*app-menu*))
(when (hash-table-p original-app-menu)
(setf ed::*app-menu* (ed::get-app-menu (ed::selected-frame))))
,@body
(when (hash-table-p original-app-menu)
(setf ed::*app-menu* original-app-menu)))))
(defmacro merge-clipboard-char-encoding-popup-menu (&body body)
"*clipboard-char-encoding-popup-menu*をマージして実行"
`(progn
(let ((original-clipboard-char-encoding-popup-menu ed::*clipboard-char-encoding-popup-menu*))
(when (hash-table-p original-clipboard-char-encoding-popup-menu)
(setf ed::*clipboard-char-encoding-popup-menu* (ed::get-clipboard-char-encoding-popup-menu (ed::selected-frame))))
,@body
(when (hash-table-p original-clipboard-char-encoding-popup-menu)
(setf ed::*clipboard-char-encoding-popup-menu* original-clipboard-char-encoding-popup-menu)))))
(defmacro merge-dictionary-popup-menu (&body body)
"*dictionary-popup-menu*をマージして実行"
`(progn
(let ((original-dictionary-popup-menu ed::*dictionary-popup-menu*))
(when (hash-table-p original-dictionary-popup-menu)
(setf ed::*dictionary-popup-menu* (ed::get-dictionary-popup-menu (ed::selected-frame))))
,@body
(when (hash-table-p original-dictionary-popup-menu)
(setf ed::*dictionary-popup-menu* original-dictionary-popup-menu)))))
(defmacro merge-paste-rectangle-popup-menu (&body body)
"*paste-rectangle-popup-menu*をマージして実行"
`(progn
(let ((original-paste-rectangle-popup-menu ed::*paste-rectangle-popup-menu*))
(when (hash-table-p original-paste-rectangle-popup-menu)
(setf ed::*paste-rectangle-popup-menu* (ed::get-paste-rectangle-popup-menu (ed::selected-frame))))
,@body
(when (hash-table-p original-paste-rectangle-popup-menu)
(setf ed::*paste-rectangle-popup-menu* original-paste-rectangle-popup-menu)))))
(defmacro merge-app-popup-menu (&body body)
"*app-popup-menu*をマージして実行"
`(progn
(let ((original-app-popup-menu ed::*app-popup-menu*))
(when (hash-table-p original-app-popup-menu)
(setf ed::*app-popup-menu* (ed::get-app-popup-menu (ed::selected-frame))))
,@body
(when (hash-table-p original-app-popup-menu)
(setf ed::*app-popup-menu* original-app-popup-menu)))))
(defmacro merge-app-rectangle-popup-menu (&body body)
"*app-rectangle-popup-menu*をマージして実行"
`(progn
(let ((original-app-rectangle-popup-menu ed::*app-rectangle-popup-menu*))
(when (hash-table-p original-app-rectangle-popup-menu)
(setf ed::*app-rectangle-popup-menu* (ed::get-app-rectangle-popup-menu (ed::selected-frame))))
,@body
(when (hash-table-p original-app-rectangle-popup-menu)
(setf ed::*app-rectangle-popup-menu* original-app-rectangle-popup-menu)))))
(defmacro merge-fset (&body body)
"si:*fsetをマージして実行"
`(progn
(let ((original-fset #'si:*fset))
(defun si:*fset (name def)
(cond ((eq name 'ed::select-frame)
(funcall original-fset name #'(lambda (f))))
((eq name 'ed::selected-frame))
(t
(funcall original-fset name def))))
,@body
(setf si:*fset original-fset))))
;;--------------------------------------------------------------------------------
;; load-ahead
(require "elisp")
(require "info")
(require "isearch")
;;--------------------------------------------------------------------------------
;; browserex
(merge-app-menu
(require "browserex"))
(defvar *original-insert-browserex-menu* #'bx::insert-browserex-menu)
(defun bx::insert-browserex-menu (&key (menu (current-menu)) (position bx::*browserex-menu-position*) (menu-name bx::*browserex-menu-name*))
"browserex メニューを追加"
(unless menu
(if (menup ed::*app-menu*)
(setf menu ed::*app-menu*)
(setf menu (ed::get-app-menu (ed::selected-frame)))))
(funcall *original-insert-browserex-menu* :menu menu :position position :menu-name menu-name))
(add-hook '*init-app-menus-hook* 'bx::insert-browserex-menu)
(defvar *original-browserex-startup* #'bx::browserex-startup)
(defun bx::browserex-startup ()
(merge-app-menu
(funcall *original-browserex-startup*)))
(defvar *original-browserex-mouse-menu-popup* #'bx::browserex-mouse-menu-popup)
(defun bx::browserex-mouse-menu-popup (&optional apps)
(interactive)
(merge-app-popup-menu
(merge-app-rectangle-popup-menu
(funcall *original-browserex-mouse-menu-popup* apps))))
;;--------------------------------------------------------------------------------
;; buf2html
(require "buf2html")
(defvar *original-buf2html-insert-menu-items* #'ed::buf2html-insert-menu-items)
(defun ed::buf2html-insert-menu-items (&key menu pre-tag position head-sep tail-sep)
"buf2html: HTML形式で名前を付けて保存ダイアログをメニューに追加"
(merge-app-menu
(funcall *original-buf2html-insert-menu-items* :menu menu :position position :head-sep head-sep :tail-sep tail-sep)))
(defvar *original-buf2html-delete-menu* #'ed::buf2html-delete-menu)
(defun ed::buf2html-delete-menu (&optional menu)
"buf2html: HTML形式で名前を付けて保存ダイアログをメニューから削除"
(merge-app-menu
(funcall *original-buf2html-delete-menu* menu)))
(defvar *original-buf2html-set-app-menu* #'ed::buf2html-set-app-menu)
(defun ed::buf2html-set-app-menu (&optional position)
"buf2html: HTML形式で名前を付けて保存を *app-menu* に追加"
(merge-app-menu
(funcall *original-buf2html-set-app-menu* position)))
(defvar *original-buf2html-set-app-popup-menu* #'ed::buf2html-set-app-popup-menu)
(defun ed::buf2html-set-app-popup-menu (&optional position)
"buf2html: buf2html の操作を *app-popup-menu* に追加"
(merge-app-popup-menu
(funcall *original-buf2html-set-app-popup-menu* position)))
;;--------------------------------------------------------------------------------
;; csv-mode
(merge-app-menu
(require "csv-mode"))
(add-hook '*init-app-menus-hook* 'ed::init-csv-menu)
;;--------------------------------------------------------------------------------
;; ggrep
(merge-app-menu
(require "ggrep"))
(defvar *original-ggrep-insert-menu-items* #'ed::ggrep-insert-menu-items)
(defun ed::ggrep-insert-menu-items (&key menu pre-tag position head-sep tail-sep)
(merge-app-menu
(funcall *original-ggrep-insert-menu-items* :menu menu :position position :head-sep head-sep :tail-sep tail-sep)))
(defvar *original-ggrep-delete-menu* #'ed::ggrep-delete-menu)
(defun ed::ggrep-delete-menu (&optional menu)
(merge-app-menu
(funcall *original-ggrep-delete-menu* menu)))
;;--------------------------------------------------------------------------------
;; guidgen
(require "guidgen")
(defun ed::guidgen-setup-menu (root-menu &optional path offset)
(if (eq root-menu 'ed::*app-menu*)
(merge-app-menu
(ed::guidgen-with-menu 'ed::*app-menu*
#'(lambda ()
(merge-app-menu
(ed::guidgen-setup-menu0 'ed::*app-menu* path offset)))))
(merge-app-popup-menu
(ed::guidgen-with-menu 'ed::*app-popup-menu*
#'(lambda ()
(merge-app-popup-menu
(ed::guidgen-setup-menu0 'ed::*app-popup-menu* path offset)))))))
(defun ed::guidgen-remove-menu (root-menu &optional path)
(if (eq root-menu 'ed::*app-menu*)
(merge-app-menu
(ed::guidgen-with-menu 'ed::*app-menu*
#'(lambda ()
(merge-app-menu
(ed::guidgen-remove-menu0 'ed::*app-menu* path)))))
(merge-app-popup-menu
(ed::guidgen-with-menu 'ed::*app-popup-menu*
#'(lambda ()
(merge-app-popup-menu
(ed::guidgen-remove-menu0 'ed::*app-popup-menu* path)))))))
;;--------------------------------------------------------------------------------
;; katex
(pushnew (merge-pathnames "site-lisp/katex/" (si:system-root)) *load-path* :test #'string-equal)
(merge-fset
(require "katex"))
(require "katexmen")
(defvar *original-KaTeX-add-menu* #'el::KaTeX-add-menu)
(defun el::KaTeX-add-menu (&optional force)
(merge-app-menu
(funcall *original-KaTeX-add-menu* force)))
;;--------------------------------------------------------------------------------
;; makefile-mode
(merge-fset
(require "make-mode"))
;;--------------------------------------------------------------------------------
;; multiple-replace
(merge-app-menu
(require "multiple-replace"))
(defvar *original-multiple-replace-insert-menu-items* #'ed::multiple-replace-insert-menu-items)
(defun ed::multiple-replace-insert-menu-items (&key menu pre-tag position head-sep tail-sep)
(merge-app-menu
(funcall *original-multiple-replace-insert-menu-items* :menu menu :position position :head-sep head-sep :tail-sep tail-sep)))
(defvar *original-multiple-replace-delete-menu* #'ed::multiple-replace-delete-menu)
(defun ed::multiple-replace-delete-menu (&optional menu)
(merge-app-menu
(funcall *original-multiple-replace-delete-menu* menu)))
;;--------------------------------------------------------------------------------
;; py-mode
(merge-app-menu
(require "py-mode"))
(defvar *original-py-get-menu* #'ed::py-get-menu)
(defun ed::py-get-menu ()
"py-mode: 状況に応じたローカルメニューの作成"
(merge-app-menu
(funcall *original-py-get-menu*)))
;;--------------------------------------------------------------------------------
;; tterm
(require "tterm")
(defvar *original-tterm-popup-menu* #'tterm::tterm-popup-menu)
(defun tterm::tterm-popup-menu ()
(interactive)
(merge-app-popup-menu
(funcall *original-tterm-popup-menu*)))
;;--------------------------------------------------------------------------------
;; reference.chm
(require "ni-autoload/reference.chm")
(defvar *original-reference-add-menu-function* #'user::reference-add-menu-function)
(defun user::reference-add-menu-function ()
(merge-app-menu
(funcall *original-reference-add-menu-function*)))
;;--------------------------------------------------------------------------------
;; session-ext
(require "session-ext")
(defun ed::save-session-info (s)
(ed::save-current-pseudo-frame)
(let ((finfo (mapcan #'(lambda (frame)
(when (ed::pseudo-frame-save-p frame)
(list (list (ed::pseudo-frame-name frame)
(ed::winconf-to-readable-winconf
(ed::pseudo-frame-winconf frame))
(eq frame (ed::get-current-pseudo-frame (ed::selected-frame)))))))
(ed::get-pseudo-frame-list (ed::selected-frame))))
(binfo (ed::list-buffer-info)))
(princ ";;; xyzzy session file.\n;;; This file is generated automatically. do not edit.\n" s)
(write `(in-package ,(package-name *package*)) :stream s :escape t)
(terpri s)
(write `(ed::restore-session ',binfo ',finfo) :stream s :escape t)
(terpri s))
(run-hook-with-args 'ed::*save-session-hook* s))
;;--------------------------------------------------------------------------------
;; xtal-mode
(merge-app-menu
(require "xtal-mode"))
Raw
outline-tree-ctags.lisp
;; -*- Mode: Lisp; Package: outline-tree2 -*-
(eval-when (:compile-toplevel :load-toplevel :execute)
(require "outline-tree/defs"))
(provide "outline-tree-ctags")
(in-package :outline-tree2)
(setf *outline-tree-create-outline-ctags-list-maps*
"Ant build.xml
Asm *.asm *.s *.A51 *.29k *.[68][68][ksx] *.x[68][68] *.app *.inc *.mac *.src
Asp *.as[ap]
Awk *.[gm]?awk
Basic *.bas *.b[ib] *.pb *.vbs?
BETA *.bet
C *.cc? *.hh? *.[ch]++ *.[ch]pp? *.[ch]xx
C# *.cs
Cobol *.cbl *.cob
D *.ds?
DosBatch *.bat *.cmd
Eiffel *.e
Erlang *.[eh]rl
Flex *.as *.mxml
Fortran *.f *.for *.ftn *.f77 *.f9[05]
HTML *.html?
Java *.java
JavaScript *.jsx? *.jsfl? *.json *.pac
Lisp *.[ce]?l *.clisp *.li?sp
Lua *.lua
Make *.ma?k makefile GNUmakefile
MATLAB *.m
Ocaml *.mli?
Pascal *.p *.pas
Perl *.plx? *.pm *.perl *.cgi
PHP *.php3? *.phtml
Python *.pyx? *.px[di] *.scons
REXX *.cmd *.rexx *.rx
Ruby *.rb *.ruby
Scheme *.sc[mh] *.sm *.scheme
Sh *.[bkz]?sh *.bash
SLang *.sl
SML *.sml *.sig
SQL *.sql
Tcl *.i?tcl *.tk *.wish
Tex *.tex
Vera *.vr[ih]?
Verilog *.v
VHDL *.vhdl?
Vim *.vim
YACC *.y")
(setf *outline-tree-create-outline-ctags-list-kinds*
"Ant
p projects
t targets
Asm
d defines
l labels
m macros
t types (structs and records)
Asp
d constants
c classes
f functions
s subroutines
v variables
Awk
f functions
Basic
c constants
f functions
l labels
t types
v variables
g enumerations
BETA
f fragment definitions
p all patterns [off]
s slots (fragment uses)
v patterns (virtual or rebound)
C
c classes
d macro definitions
e enumerators (values inside an enumeration)
f function definitions
g enumeration names
l local variables [off]
m class, struct, and union members
n namespaces
p function prototypes [off]
s structure names
t typedefs
u union names
v variable definitions
x external and forward variable declarations [off]
C#
c classes
d macro definitions
e enumerators (values inside an enumeration)
E events
f fields
g enumeration names
i interfaces
l local variables [off]
m methods
n namespaces
p properties
s structure names
t typedefs
Cobol
d data items
f file descriptions (FD, SD, RD)
g group items
p paragraphs
P program ids
s sections
D
c classes
d macro definitions
e enumerators (values inside an enumeration)
f function definitions
g enumeration names
l local variables [off]
m class, struct, and union members
M modules
n namespaces
p function prototypes [off]
s structure names
t typedefs
T templates
u union names
v variable definitions
x external and forward variable declarations [off]
X mixins
V versions
DosBatch
l labels
v variables
Eiffel
c classes
f features
l local entities [off]
Erlang
d macro definitions
f functions
m modules
r record definitions
Flex
f functions
c classes
m methods
p properties
v variables
x mxtags
Fortran
b block data
c common blocks
e entry points
f functions
i interface contents, generic names, and operators [off]
k type and structure components
l labels
L local, common block, and namelist variables [off]
m modules
n namelists
p programs
s subroutines
t derived types and structures
v program (global) and module variables
HTML
a named anchors
f JavaScript functions
Java
c classes
e enum constants
f fields
g enum types
i interfaces
l local variables [off]
m methods
p packages
JavaScript
f functions
c classes
m methods
p properties
v global variables
I inner functions
Lisp
f functions
Lua
f functions
Make
m macros
MATLAB
f functions
Ocaml
c classes
m methods
M modules
v variables
t types
f functions
C constructors
r record fields
e exceptions
Pascal
f functions
p procedures
Perl
c constants
f formats
l labels
p packages
s subroutines
d subroutine declarations [off]
PHP
c classes
i interfaces
d constant definitions
f functions
v variables
j javascript functions
Python
c classes
f functions
m class members
v variables
i namespaces
REXX
s subroutines
Ruby
c classes
f methods
m modules
F singleton methods
Scheme
f functions
s sets
Sh
f functions
SLang
f functions
n namespaces
SML
e exception declarations
f function definitions
c functor definitions
s signature declarations
r structure declarations
t type definitions
v value bindings
SQL
c cursors
d prototypes [off]
f functions
F record fields
l local variables [off]
L block label
P packages
p procedures
r records [off]
s subtypes
t tables
T triggers
v variables
i indexes
e events
U publications
R services
D domains
V views
n synonyms
x MobiLink Table Scripts
y MobiLink Conn Scripts
Tcl
c classes
m methods
p procedures
Tex
C chapters
s sections
u subsections
b subsubsections
p parts
P paragraphs
G subparagraphs
Vera
c classes
d macro definitions
e enumerators (values inside an enumeration)
f function definitions
g enumeration names
l local variables [off]
m class, struct, and union members
p programs
P function prototypes [off]
t tasks
T typedefs
v variable definitions
x external variable declarations [off]
Verilog
c constants (define, parameter, specparam)
e events
f functions
m modules
n net data types
p ports
r register data types
t tasks
VHDL
c constants
t types
T subtypes
r records
e entities
C components
d prototypes
f functions
p procedures
P packages
l local entities
Vim
a autocommand groups
c user-defined commands
f function definitions
m maps
v variable definitions
YACC
l labels")
(defvar *outline-tree-create-outline-ctags-auto-maps-alist* nil)
(setf *outline-tree-create-outline-ctags-auto-maps-alist*
(let (line map language extensions alist)
(dolist (line (split-string *outline-tree-create-outline-ctags-list-maps* "\n"))
(setf map (split-string line " "))
(setf language (first map))
(setf extensions (rest map))
(dolist (ext extensions)
(when (string-match "^\\(.*\\)\\(\\..+\\)" ext)
(setf ext (concat (unless (string= "*" (match-string 1)) (match-string 1)) "\\" (match-string 2) "$"))
(push (cons ext (copy-string language)) alist))))
(nreverse alist)))
(defvar *outline-tree-create-outline-ctags-list-kinds-list* nil)
(setf *outline-tree-create-outline-ctags-list-kinds-list*
(let (line language alist kind-pairs kind kind-fullname)
(dolist (line (split-string *outline-tree-create-outline-ctags-list-kinds* "\n"))
(cond
((string-match "^[^ ]" line)
(when kind-pairs
(push (cons language (nreverse kind-pairs)) alist)
(setf kind-pairs nil))
(setf language line))
((string-match "^ +\\([^ ]\\) +\\(.+\\)" line)
(setf kind (match-string 1)
kind-fullname (match-string 2))
(when (string-match "\\(.+\\) *\\[off\\] *$" kind-fullname)
(setf kind-fullname (match-string 1)))
(push (cons kind kind-fullname) kind-pairs))))
(push (cons language (nreverse kind-pairs)) alist)
(nreverse alist)))
@DeaR
Copy link
Author

DeaR commented Apr 25, 2012

マルチフレーム版へ移行したどー - こんなに月も紅いのに

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment