Common Lispで (object method args...)の形式でメソッド呼び出し

Common Lispのオブジェクトシステムはそのまんまのネーミングで、 Common Lisp Object System (CLOS:シーロス、クロス)と言います。

CLOSでは、メソッド呼び出しが普通の関数呼び出しと同じように (method object args...) という形式になっていますが、これは他のオブジェクト指向言語から見たらへんてこな順序で、わかりにくいかもしれません。 Javaを触ってきた人からすると、(object method args...)と書きたいでしょう。たぶん。

当然、用意されている書き方が気にくわないならば自分で書き換えてしまうのがCommon Lisp なので、解決方法はいくつかあるかと思います。

仕様にはなっていませんが、CLOSに加えて Meta Object Protocol(MOP)という、デファクトスタンダード的なメタプログラミングの方法が用意されています。

マクロを使うのも良いかもしれませんが、たまには違う方法で実現してみましょう、ということで MOPを利用してみました。

MOPには処理系毎の差異を吸収するラッパーライブラリも存在しますが、面倒くさいので処理系依存のコードを書いてしまいます。

(defclass funcallable-base-class ()
  ()
  (:metaclass sb-mop:funcallable-standard-class))

(defmethod initialize-instance :after ((obj funcallable-base-class) &rest args)
  (declare (ignore args))
  (sb-mop:set-funcallable-instance-function
   obj
   #'(lambda (method &rest args)
       (apply method obj args))))

(defun callable-object-reader (stream ch1 ch2)
  (declare (ignore ch1 ch2))
  `(lambda (&rest args)
     (apply ,(read stream) args)))

(set-dispatch-macro-character
 #\# #\^
 'callable-object-reader)

(defmacro defclass! (name direct-superclasses direct-slots &rest options)
  `(defclass ,name (funcallable-base-class ,@direct-superclasses)
     ,direct-slots
     (:metaclass sb-mop:funcallable-standard-class)
     ,@options))


;; example

(defclass! hoge ()
  ((a :accessor a-of :initform 0 :initarg :a)))
(defclass! fuga ()
  ((b :accessor b-of :initform 0 :initarg :b)))

(defmethod dump ((obj hoge))
  (format t "hoge class: ~A~%" (a-of obj)))
(defmethod dump ((obj fuga))
  (format t "fuga class: ~A~%" (b-of obj)))


(defparameter obj (make-instance 'hoge :a 20))

;; 1. funcallで呼び出す
(funcall obj 'dump)
;; : hoge class: 20
;; => nil

;; 2. 関数スロットにセットして関数呼び出し
(setf (symbol-function 'obj) obj)
(obj 'dump)
;; : hoge class: 20
;; => nil

;; 3. リーダマクロを利用してlambdaで包む
(#^obj 'dump)
;; : hoge class: 20
;; => NIL

(#^(make-instance 'fuga :b 10) 'dump)
;; : fuga class: 10
;; => nil

メタクラスにfuncallable-standard-classを指定したクラスのオブジェクトは、 set-funcallable-instance-functionでセットした関数を、普通の関数と同じように呼び出すことができます。

これで、シンボルの関数スロットにオブジェクトをセットすれば、(object method args...)という形式でメソッド呼び出しが出きるようになります。

EmacsからGhostScriptを利用する

make-comintを使ってみたかったので。

(defun postscript-process ()
  (get-buffer-process (get-buffer "*postscript*")))

(defun run-postscript ()
  (interactive)
  (require 'comint)
  (switch-to-buffer (make-comint "postscript" "gs")))
(push '("postscript" . utf-8) process-coding-system-alist)

(defun to-postfix (s)
  (if (atom s) `(,s)
      `(,@(cdr s)
	  ,(car s))))

(defun send-postscript-no-newline (s &optional ps)
  (unless ps
    (setf ps (postscript-process)))
  (unless ps
    (error "no running postscript process"))
  (dolist (obj (to-postfix s))
    (if (listp obj)
	(send-postscript-no-newline obj ps)
	(comint-send-string ps (format "%s " obj)))))

(defun send-postscript (s &optional ps)
  (unless ps
    (setf ps (postscript-process)))
  (unless ps
    (error "no running postscript process"))
  (send-postscript-no-newline s ps)
  (comint-send-string ps "\n"))


(defun ps (&rest ss)
  (dolist (s ss) (send-postscript-no-newline s))
  (unless (postscript-process)
    (error "no running postscript process"))
  (comint-send-string (postscript-process) "\n"))

(defmacro with-ps-context (&rest body)
  `(ps ,@(mapcar (lambda (s) `(quote ,s)) body)))

M-x run-postscriptで起動

;; 線を引く
(with-ps-context
  gsave
  newpath
  (moveto 0 100)
  (lineto 100 100)
  stroke
  grestore)

S式からPostScriptへの変換は、単純に順序を入れ替えているだけなのでたいした意味が無いような気がしますが、括弧にかこわれているほうが精神が落ち着きますね。

ELispでobjdumpを呼んでバイト列を逆アセンブルする

Linuxなどでプログラムを逆アセンブルする際には、objdumpを使うと便利です、たぶん。

Twitterなどでバイナリアンな方々が16進数で会話をしているのについていけなくて困るときのために、 Emacsからobjdumpを呼んでバイト列を逆アセンブルするようなELispを書いてみました。

バイト列といってもリストしか対応していませんが。

(defvar *arch-type* "i386")

(defun make-disasm-command (target file)
  (format "objdump -b binary -m %s -D %s" target file))

(defun make-perl-command (lst tmp-file)
  (concat
   "perl -e 'print \""
   (apply
    'concat
    (mapcar
     (lambda (n)
       (format "\\x%x" n))
     lst))
   "\"' >"
   tmp-file))


(defun disasm-byte-list (lst)
  (let ((tmp-file (make-temp-file "disasm_")))
    (let ((file-buf (find-file-noselect tmp-file))
	  (cmd (make-disasm-command *arch-type* tmp-file)))
      (shell-command (make-perl-command lst tmp-file))
      (let ((buf (get-buffer-create "*disasm*")))
	(shell-command cmd buf)
	(delete-file tmp-file)
	(pop-to-buffer buf)))))

;; example
(disasm-byte-list '(#x90))

超リードマクロに対抗してchar-codeの限界までリードマクロ

CLerはもっと他人のネタに反応すべきらしいので対抗してみた。

元ネタは @nitro_idiot さん の:　SBCLのリーダを上書きして"超リードマクロ"を実装

組み込みのリーダを書き換えるのは敷居が高いので、ごく普通の方法にしました。

正規表現ライブラリのcl-ppcreを利用していますが、それ以外はごく標準的なCommon Lispです。

私はSBCLで動かしましたが、CL処理系なら大抵は動くのではないでしょうか。

(asdf:oos 'asdf:load-op :cl-ppcre)

(defun range-symbol-name-p (str)
  (and (= (length (cl-ppcre:all-matches "\\.\\." str)) 2)
       (= (length (cl-ppcre:split "\\.\\." str)) 2)))

(defun range-name->symbols (str)
  (mapcar #'read-from-string (cl-ppcre:split "\\.\\." str)))

(let ((old (copy-readtable)))
  (defun range-reader (stream ch1)
    (unread-char ch1 stream)
    (if (let ((*readtable* old)) (get-macro-character ch1))
	(let ((*readtable* old)) (read stream))
	(let ((*readtable* old))
	  (let ((sexp (read stream)))
	    (if (and (symbolp sexp)
		     (range-symbol-name-p (format nil "~A" sexp)))
		(let ((syms (range-name->symbols (format nil "~A" sexp)))
		      (tmp (gensym)))
		  `(loop
		      :for ,tmp :from ,(first syms) :to ,(second syms)
		      :collect ,tmp))
		sexp))))))

(let ((old (copy-readtable)))
  (defun enable-range-reader ()
    (loop
       :for i :from 0 :below char-code-limit
       :do (let ((ch (code-char i)))
	     (unless (or (get-macro-character ch)
			 (find ch '(#\Space #\Return #\Newline
				    #\Tab #\Linefeed #\Page
				    #\Backspace)))
	       (set-macro-character ch #'range-reader)))))
  (defun disable-range-reader ()
    (setf *readtable* old)))


;;; example
(enable-range-reader)

'0..10
;;=> (LOOP :FOR #:G1473 :FROM 0 :TO 10
;;       :COLLECT #:G1473)
(remove-if #'oddp 0..10)
;;=> (0 2 4 6 8 10)

おかしい。仕様に乗っ取ったやり方のはずなのにアレゲな気配がぷんぷんする・・・。

list処理マクロ

map系関数のような処理をするマクロを作ってみました。

いつもどおり毒にも薬にもならない感じです。

(defvar *mapping-action-keywords*
  `(:collect :collect-if
     :remove :remove-if
     :reverse :append
     :funcall
     :action))

(defvar *mapping-action-optional-keywords*
  `(:if :key))

(defvar *mapping-action-optional-sub-keywords*
  `(:else))

(defun action-keyword-p (sym)
  (member sym *mapping-action-keywords*))
(defun action-optional-keyword-p (sym)
  (member sym *mapping-action-optional-keywords*))
(defun action-optional-sub-keyword-p (sym)
  (member sym *mapping-action-optional-sub-keywords*))


(defun parse-actions (actions acc)
  (cond
    ((null actions) (nreverse acc))
    ((atom actions) (error "Invalid action form"))
    (T
     (unless (action-keyword-p (car actions))
       (error "Invalid action form"))
     (let ((rest (cdr actions)))
       (let ((act
	      (cons (car actions)
		    (loop
		       :for exp = (car rest)
		       :until (or (null rest) (action-keyword-p exp))
		       :do (pop rest)
		       :collect exp))))
	 (parse-actions rest (cons act acc)))))))

(defun mapping-expander (actions expr)
  (if (null actions)
      expr
      (let ((action (car actions))
	    (rest (cdr actions)))
	(case (car action)
	  (:collect
	      (mapping-expander rest (collect-expander action expr)))
	  (:collect-if
	   (mapping-expander rest (collect-if-expander action expr)))
	  (:remove
	   (mapping-expander rest (remove-expander action expr)))
	  (:remove-if
	   (mapping-expander rest (remove-if-expander action expr)))
	  (:funcall
	   (mapping-expander rest (funcall-expander action expr)))
	  (:reverse
	   (mapping-expander rest `(reverse ,expr)))
	  (:append
	   (mapping-expander rest `(apply #'append ,expr)))
	  (:action
	   (mapping-expander rest (action-expander action expr)))
	  (error "Invalid mapping action keyword")))))

(defun collect-expander (action expr)
  (let ((sym1 (gensym))
	(sym2 (gensym)))
    (destructuring-bind (obj &key if key &allow-other-keys) (cdr action)
      `(remove ,obj ,expr
	       ,@(if key `(:key ,key) nil)
	       ,@(if if `(:test ,if) nil)
	       :test-not (lambda (,sym1 ,sym2) (eq ,sym1 ,sym2))))))

(defun collect-if-expander (action expr)
  (destructuring-bind (fn &key if key &allow-other-keys) (cdr action)
    `(remove-if-not ,fn ,expr
		    ,@(if key `(:key ,key) nil))))

(defun remove-expander (action expr)
  (destructuring-bind (obj &key if key &allow-other-keys) (cdr action)
    `(remove ,obj ,expr
	     ,@(if key `(:key ,key) nil)
	     ,@(if if `(:test ,if) nil))))

(defun remove-if-expander (action expr)
  (destructuring-bind (fn &key if key &allow-other-keys) (cdr action)
    `(remove-if ,fn ,expr
		,@(if key `(:key ,key)))))

(defun funcall-expander (action expr)
  `(funcall ,(second action) ,expr))

(defun action-expander (action expr)
  (let ((sym (gensym)))
  (destructuring-bind (fn &key if key &allow-other-keys) (cdr action)
    (cond
      ((and if key)
       `(mapcar
	 (lambda (,sym)
	   (if (funcall ,if (funcall ,key ,sym))
	       (funcall ,fn (funcall ,key ,sym))
	       ,sym))
	 ,expr))
      (if
       `(mapcar
	 (lambda (,sym)
	   (if (funcall ,if ,sym)
	       (funcall ,fn ,sym)
	       ,sym))
	 ,expr))
      (key
       `(mapcar
	 (lambda (,sym)
	   (funcall ,fn (funcall ,key ,sym)))
	 ,expr))
      (T `(mapcar ,fn ,expr))))))

(defmacro mapping (lst &rest actions)
  (mapping-expander (parse-actions actions nil) lst))

(mapping リスト キーワード 関数[オブジェクト] ...) といった形で利用します。出現順にキーワードごとに決まった処理を行い、リストを操作します。

;; example
(mapping
 `(1 2 3 nil 4 5 9 nil)
 :remove nil)
=> (1 2 3 4 5 9)

(mapping
 `((1 2) (2 3) (3 4) (4 5))
 :collect-if #'oddp :key #'car
 :funcall #'(lambda (lst) (apply #'append lst))
 :action #'1+ :if #'oddp)
=> (2 2 4 4)

古い値を利用する更新処理(Common Lisp)

Clojureのswap!はアトムの古い値を引数にして関数を呼び出し、その結果を新しい値とします。たしか。

似たような値の更新方法をCommon Lispで計4パターン書いてみました。

(defmacro update/fn-1! (generaized-variable update-fn &rest args)
  (let ((old-val (gensym)))
    `(let ((,old-val ,generaized-variable))
       (setf ,generaized-variable (funcall ,update-fn ,old-val ,@args))
       ,old-val)))

(defmacro update/fn-2! (generaized-variable update-fn &rest args)
  `(setf ,generaized-variable
	 (funcall ,update-fn ,generaized-variable ,@args)))

(defmacro update/fn-r-1! (generaized-variable update-fn &rest args)
  (let ((old-val (gensym)))
    `(let ((,old-val ,generaized-variable))
       (setf ,generaized-variable (funcall ,update-fn ,@args ,old-val))
       ,old-val)))

(defmacro update/fn-r-2! (generaized-variable update-fn &rest args)
  `(setf ,generaized-variable
	 (funcall ,update-fn ,@args ,generaized-variable )))

;;example
(let ((a 0)) (update/fn-1! a #'cons 1) a)
=>(0 . 1) ; (cons 古い値 引数)
(let ((a 0)) (update/fn-r-1! a #'cons 1) a)
=>(1 . 0) ; (cons 引数 古い値)

(let ((a 0)) (update/fn-1! a #'cons 1))
=>0 ; 古い値が返る
(let ((a 0)) (update/fn-2! a #'cons 1))
=>(0 . 1) ; 新しい値が返る

fnとfn-rの違いは、古い値が関数の引数として渡される際、第1引数となるか最後の引数となるかです。

1と2の違いは、返り値として古い値を返すか新しい値を返すかです。

どのパターンが有用なのかは、使ってみないことには判断できないような気がします。

Common Lisp でC風switch その2

C風switchをgoを使わない形に書き直して見ました。

caseの実行する式の部分に、後続で処理するすべての式をぶち込んでいます。

今回は明示的にブロックを抜けない限り、最後に評価された値が返ります。

(defmacro switch-2 (val &body clauses)
  (let ((break (gensym)))
    `(block ,break
       (macrolet ((break-switch ()
		    `(return-from ,',break nil)))
	 (case ,val
	   ,@(maplist
	      #'(lambda (rest)
		  `(,(caar rest) ,@(loop :for i in rest
				      :append (cdr i))))
	      clauses))))))

;; example
(switch-2 2
  (2 (print 2))
  (3 (print 3) (break-switch))
  (4 (print 4)))

loopマクロの箇所は、最初はmapcanで書いていたのですが、なぜか処理が止まったので書き換えました。 mapcanが破壊的関数なため、maplistで段階的にアクセスしているリストの構造(clausesの一部)を変更してしまっているのだろうと思っています。

mapcanの非破壊版くらい仕様に入れておいて欲しかったです。

Common Lisp で C 風のswitch

Twitterを眺めていたらネタに出会ったので書いてみました。

(defmacro switch (val &body clauses)
  (let ((syms (loop :repeat (length clauses)
		 :collect (gensym))))
    `(tagbody
	(case ,val
	  ,@(mapcar
	     #'(lambda (clause sym)
		 `(,(car clause) (go ,sym)))
	     clauses
	     syms))
	,@(mapcan
	   #'(lambda (clause sym)
	       `(,sym ,@(cdr clause)))
	   clauses
	   syms)
      break)))

switchのclauses部にはCommon Lispのcaseと同様の式を書くことができます。

caseと異なるのは、条件に一致した場合goで目的の処理の前に飛ぶところです。このため、明示的に(go break)としない限り、一致した箇所以降の式をすべて実行します。

また、caseと異なり、tagbodyに展開するため返り値は常にnilになります。

;; 例
(switch 2
  (2 (print 2) (go break))
  (3 (print 3))
  (4 (print 4)))
2
=> nil

(switch 3
  (2 (print 2) (go break))
  (3 (print 3))
  (4 (print 4)))
3
4
=> nil

Common Lispでforマクロ その2

昨日の続きのforマクロ。

昨日のままだと、外側のletのbinding内でそんなシンボル無いです、と怒られて動かないことがあると思われるので修正．

せっかくなのでgithubを活用する事にしました。

http://github.com/kurohuku/for-loop

現状の動作はこんな感じです。

(for ((a :in (list 1 2))
      (b :range 4 6)
      (c :across #(10 11)))
  (list a b c))
;; => ((1 4 10) (1 4 11) (1 5 10) (1 5 11)
;;     (2 4 10) (2 4 11) (2 5 10) (2 5 11))

Common Lispでオレオレforマクロを定義する

Common Lispにはやたらと高機能なかわりに構文がおかしなloopマクロが存在します。

loopマクロは高機能なのですが、多重ループを処理しようとすると collect や nconc などのキーワードを使ってネストさせる必要があります(多分)。

Clojureのforは多重ループ(のようなもの)を簡潔に記述できるので、似たような構文をマクロで定義してみようと思います。

(defun enumrate (from to)
  (loop :for i from from to to :collect i))

(defun pattern-binding (form pattern)
  (if (/= (length form) (length pattern))
      nil
      (let ((binding
	     (mapcar
	      #'(lambda (f p)
		  (cond
		    ((and (keywordp f) (keywordp p))
		     (if (eq f p)
			 f
			 nil))
		    ((keywordp p) nil)
		    ((symbolp p) (list p f))
		    (T (error "Invalid pattern or form"))))
	      form
	      pattern)))
	(if (member nil binding)
	    nil
	    (remove-if #'keywordp binding)))))

(defmacro keyword-pattern-case (form &body pattern-clauses)
  (if (null pattern-clauses)
      nil
      (let ((binding (pattern-binding form (caar pattern-clauses))))
	(if binding
	    `(let ,binding
	       ,@(cdar pattern-clauses))
	    `(keyword-pattern-case ,form ,@(cdr pattern-clauses))))))


(defun expand-for-forms (forms body)
  (if (null forms)
      `(progn ,@body)
      (let ((form (car forms))
	    (rest (cdr forms))
	    (sym1 (gensym))
	    (sym2 (gensym)))
	(let ((gather (if rest :nconc :collect)))
	  `(keyword-pattern-case ,form
	    ((,(car form) :in ,sym1)
	     (loop :for ,(car form) :in ,sym1
		 ,gather ,(expand-for-forms rest body)))
	    ((,(car form) :range ,sym1 ,sym2)
	     (loop :for ,(car form) :in (enumrate ,sym1 (1- ,sym2))
		 ,gather ,(expand-for-forms rest body))))))))

(defmacro for ((&rest forms) &body body)
  (unless (every #'listp forms)
    (error "Invalid forms"))
  (if (null forms)
      `(progn
	 ,@body)
      (expand-for-forms forms body)))

;; example
(for ((i :in '(1 2 3))
      (j :in '(4 5 6)))
  (list i j))
;; => ((1 4) (1 5) (1 6) (2 4) (2 5) (2 6) (3 4) (3 5) (3 6))

(for ((i :in (list 2 3))
      (j :range 10 13))
  (list i j))
;; =>((2 10) (2 11) (2 12) (3 10) (3 11) (3 12))

現在、formとして許されるのは loopマクロのinに展開されるものと、 for - from - toに展開されるものだけです。また、手抜きパターンマッチのせいで:inや:rangeはキーワードでなければなりません。

展開後の一番外側のletのせいで警告が出てきますし、まだまだ改良が必要なようです。

Common Lisp でC++風出力

githubを試しに使ってみるテスト。

C++のストリーム出力っぽい雰囲気になるように gray streamsを使ってみました。

http://github.com/kurohuku/manip-stream

動作させるには trivial-gray-streams が必要です。

>(<< (make-instance 'manip-output-stream
		   :stream *standard-output*)
    +binary+
    (set-width 8)
    (set-fill #\0)
    +left+
    3)
00000011
#<MANIP-OUTPUT-STREAM {DDF79C9}>

stream-write-stringの引数がstream-manipulatorクラスのオブジェクトの場合、manip-streamを引数としてactionスロットの関数が呼び出され、manip-streamの状態を変化させます。

format関数は高機能なかわりにやたらと複雑なので、こういった書き方のほうが多少はわかりやすくなるかもしれません。