deform
let* let labels macrolet は使用頻度が高く、組み合わせて使うことも多い。すると、必然的に入れ子になり、自然にインデントを行うとインデント量が大きくなる。これは見づらいということで、入れ子を解消する書き方を考えてみた。
これらの関数（マクロ、あるいは制御構造）はどれも似た形をしている。
(FN ({NAME VALUE}*) FORM*) (FN1 ({NAME VALUE}*) FORM* (FN2 ({NAME VALUE}*) FORM*))
入れ子にして用いるときは、大体親のFORM*の最後尾に子の関数をおけばいい。だから、全て同列に記述して、あとで望む順番に振り分ければ構造が作れる。
;こういう風に記述する。 (form (fn1-hoge) (fn1-foo) (fn1/form-bar) (fn2-buzz) (fn2/form-fizz)) ;↓変形 (fn1 ((fn1-hoge) (fn1-foo)) (fn1/form-bar) (fn2 ((fn2-buzz)) (fn2/form-fizz)))
このような変形をすると構造が見えにくくなり、可読性が減るので勧めはしない。こういう書き方もできるということを試してみるだけである。
さて、何の手がかりもないのでは、構造の振り分けが行えない。そこで、束縛される変数や関数にラベルを貼り、それに従って振り分けることにする。宣言部は、ラベル単体を付与することで表す。実際には次のような変換になる。
(let ((x1 ~) (x2 ~)) (hoge) (fuga) (flet ((y1 ~) (y2 ~)) (foo) (bar))) ;↑元の構造 ;↓変換後の構造 (form (x let y flet) ((x1 ~) (y1 ~) (y (foo)) (x2 ~) (y2 ~) (y (bar)) (x (hoge) (fuga))))
上の例はわざと適当に書いたが、1つずつ見て振り分けるため、構造間の順番をばらばらに記述できる。関連するfletとmacroletを近くに書いても問題ない。ただし、構造内の順番は明示しないため、実行順に書かなければならない。ラベルがついているため、一様に書いてもそれほどは見づらくはならないだろう。また、宣言全体を囲っているのはラベル宣言と区別したり、拡張するときの利便性のためである。
この仕様を満たすマクロを以下に示す。
(defmacro form (prefix-list body) (let* ((l (group prefix-list 2)) (lst (mapcar (lambda (x) (list (car x) (cadr x) nil nil)) l)) (pat (stable-sort (reverse (mapcar (lambda (x) (list (symbol-name (car x)) (car x) (cadr x))) l)) (lambda (x y) (> (length x) (length y))) :key 'car))) (dolist (arg body) (multiple-value-bind (place class) (form-classify (symbol-name (car arg)) pat) (if class (if place (push (cdr arg) (cadddr (assoc (car class) lst))) (push arg (caddr (assoc (car class) lst))))))) `,(funcall (labels ((rec (lst) (if (cdr lst) (append (f (car lst)) (list (rec (cdr lst)))) (f (car lst)))) (f (x) (f-sub-1 (cdr x))) (f-sub-1 (x) (nconc (list (car x)) (list (nreverse (cadr x))) (f-sub-2 (caddr x)))) (f-sub-2 (x) (apply 'nconc (nreverse x)))) #'rec) lst))) (defun form-classify (name pat) (dolist (p pat (values nil nil)) (if (string= name (car p)) (return (values t (cdr p))) (let ((len (length (car p)))) (if (and (< len (length name)) (string= name (car p) :end1 len)) (return (values nil (cdr p)))))))) (defmacro deff (name lambda &optional doc) `(progn ,@(if doc `((setf (get ',name 'lisp::function-documentation) ,doc))) (setf (symbol-function ',name) (si:*set-function-name ,lambda ',name)))) (defmacro deform (name prefix-list body &optional doc) `(deff ,name (form ,prefix-list ,body) ,doc))
このdeffはこのフォームで関数を返す場合、それを直接関数として定義するためのものである。関数が入れば何でも良いので、lambdaなどでも使える。そして、formとdeffを組合せたものがdeformである。
このマクロを用いて、もっと便利なマーカが欲しい。 - 象徴ヶ淵の拡張を行ってみた。その結果がこれである。
(deform embed-register (/ macrolet ~ labels) ((/new-marker () `(set-marker (make-marker))) (/new-text () `(cons 'text (~copy-region))) (~copy-region () (/region buffer-substring)) (/new-rectangle () `(cons 'rectangle (~copy-rectangle))) (~copy-rectangle () (let ((buffer *rectangle-kill-buffer*)) (/region copy-rectangle) (rotatef *rectangle-kill-buffer* buffer) buffer)) (/new-window-configurationon () `(current-window-configuration)) (/new-keyword-hash-table () `(cons 'keyword-hash-table keyword-hash-table)) (/new-regexp-keyword-list () `(list 'regexp-keyword-list regexp-keyword-list (syntax-table))) (/get () `(gethash n *register-table*)) (/set (arg) `(setf (/get) ,arg)) (/call () `(call-interactively command)) (/command (&rest args) `(lambda (&optional n) (interactive "p") (if n (progn ,@args) (/call)))) (/use (&optional cur) `(let* ((arg (/get)) (class (~chk arg)) ,@(if cur `((new ,cur)))) (/use-case ,(if cur t nil)))) (/region (foo) `(,foo (region-beginning) (region-end))) (~yank-rectangle (arg) (rotatef arg *rectangle-kill-buffer*) (yank-rectangle) (rotatef arg *rectangle-kill-buffer*)) (/use-case (&optional s) `(case class (marker (and (set-buffer (marker-buffer arg)) (goto-marker arg) (recenter) ,@(if s '((/set new))) ,(/use-msg "マーカ"))) (text ,@(if s '((/region delete-region))) (insert (cdr arg)) ,@(if s '((/set new))) ,(/use-msg "リージョンテキスト")) (rectangle ,@(if s '((/region delete-rectangle) (goto-char (region-beginning)))) (~yank-rectangle (cdr arg)) ,@(if s '((/set new))) ,(/use-msg "矩形")) (window-configuration (set-window-configuration arg) ,@(if s '((/set new))) ,(/use-msg "ウィンドウ状態")) (keyword-hash-table (make-local-variable 'keyword-hash-table) (setq keyword-hash-table (cdr arg)) ,@(if s '((/set new))) ,(/use-msg "キーワード")) (regexp-keyword-list (make-local-variable 'regexp-keyword-list) (setq regexp-keyword-list (cadr arg)) (use-syntax-table (caddr arg)) ,@(if s '((/set new))) ,(/use-msg "正規表現キーワード＆シンタックス")) (t (message "そのスロットは使ってないよ。") nil))) (/use-msg (msg) `(if s '(message "~A入れ替え" ,msg) '(message "~A適用" ,msg))) (/cur-case () `(case class (marker (/new-marker)) (text (/new-text)) (rectangle (/new-rectangle)) (window-configuration (/new-window-configurationon)) (keyword-hash-table (/new-keyword-hash-table)) (regexp-keyword-list (/new-regexp-keyword-list)))) (/mem (new msg) `(/command (/set ,new) (message ,msg))) (~chk (arg) (if (markerp arg) 'marker (if (consp arg) (car arg)))) (~gen (direction &optional command) (case direction (syntax (/mem (/new-regexp-keyword-list) "正規表現キーワード＆シンタックスコピー")) (keyword (/mem (/new-keyword-hash-table) "キーワードコピー")) (window (/mem (/new-window-configurationon) "ウィンドウ状態コピー")) (rectangle (/mem (/new-rectangle) "矩形コピー")) (region (/mem (/new-text) "リージョンコピー")) (marker (/mem (/new-marker) "マーカ設定")) (apply (/command (/use))) (swap (/command (/use (/cur-case)))))) (~ #'~gen))) (defvar *register-table* (make-hash-table :size 7))
追記2011-02-05 22:41
embed-registerが間違ってたのでこっそり修正。
使い方は、
(global-set-key #\NUL (embed-register 'marker 'set-mark-command)) (global-set-key #\C-f (embed-register 'apply 'forward-char))
などと書く。Universal argument を与えて C-SPC を入力すると、普通にマーカを設定するのではなく、argの番号にマーカを記憶させる。これを実際のマーカに適用するときは同じ Universal argument を与えて C-f を入力する。というように、embed-registerのキーワードと元のコマンドを使ってコマンドを登録する。元のコマンドのarg指定動作は出来なくなるので注意。使えるキーワードと動作は~genを見れば大体分かると思う。
