たくさんの閉じ括弧を不快に思う人のためのリーダマクロ

本日(2010/11/27)はShibuya.lisp TT6に参加してきました。

Lisperばかりが70以上も集まるという、とても楽しいイベントでした。運営、発表者、会場、その他参加者の皆様、どうもありがとうございました。

内容についてはきっとどなたかがナイスな感じでまとめてくださるはずなので、帰宅して書いてみたネタを晒そうと思います。

今日のTTで Programming 2.0 という話題がでました。自分の中で要約すると、「おいコンパイラ、そのくらいのタイポでエラーをだすな。俺がやりたいことくらいわかるだろ？」という感じになりましたが、そのあたりに関連して、「Lispのネストした閉じ括弧をたくさん書くのが面倒、わかりにくい」というようなつぶやきが聞こえてきたので、なんとかしてみようと頑張ってみました。

(defparameter *unclose-parenthesis* 0)
(defparameter *super-kokka-sym* (gensym))
(defparameter *kokka-sym* (gensym))

(defun super-kakko-reader (stream ch)
  (let ((*unclose-parenthesis* 0))
    (loop :for s = (read stream t nil t)
       :until (eq s *super-kokka-sym*)
       :collect s)))

(defun super-kokka-reader (stream ch)
  (when (> *unclose-parenthesis* 0) (unread-char ch stream))
  *super-kokka-sym*)

(defun kakko-reader (stream ch)
  (let ((*unclose-parenthesis* (1+ *unclose-parenthesis*)))
    (loop :for s = (read stream t nil t)
       :until (or (eq s *kokka-sym*)
		  (eq s *super-kokka-sym*))
       :collect s)))

(defun kokka-reader (stream ch)
  *kokka-sym*)

(set-macro-character #\{ #'super-kakko-reader)
(set-macro-character #\} #'super-kokka-reader)
(set-macro-character #\) #'kokka-reader)
(set-macro-character #\( #'kakko-reader)

「{」 で始まった式は、どれだけネストしていようと 「}」 が現れた時点で終端だと判断されます。

;; example

'{dotimes (i 3)
  (dotimes (j 3)
    (format t "~A x ~A = ~A~%" i j (* i j}

;; => (DOTIMES (I 3) (DOTIMES (J 3) (FORMAT T "~A x ~A = ~A~%" I J (* I J))))

最大の問題は、エディタのインデント支援の恩恵を受けられなくなるというところ。致命的ですね。

LOLを参考に間接参照

Let Over Lambda(LOL)のalambda,aletあたりを読んで間接参照を定義する単純な方法を考えてみました。

(let ((set-sym (gensym))
      (deref-sym (gensym)))
  (defun ref (fn)
    (let ((this fn))
      (lambda (&rest args)
	(cond
	  ((eq (car args) set-sym)
	   (setf this (cadr args)))
	  ((eq (car args) deref-sym)
	   this)
	  (T (apply this args))))))
  (defun deref (ref)
    (funcall ref deref-sym))
  (defun (setf deref) (fn ref)
    (funcall ref set-sym fn)))

;; example
(ref (lambda (a b) (+ a b)))

(setf (symbol-function 'a) *)

(a 2 3)
;;=> 5

(funcall (deref #'a) 4 5)
;;=> 9

(setf (deref #'a) (lambda () :a))

(a)
;;=> :a

#`..`で外部コマンドの出力を取得する

Perlのバッククオートをパクってみました。

とりあえず、kmrclのcommand-outputを使いめんどくさいところを丸投げします。

(asdf:oos 'asdf:load-op :kmrcl)

(defun |#`-reader| (stream ch numarg)
  (declare (ignore ch numarg))
  (let (acc-fmt acc-args)
    (loop
       :for curr = (read-char stream)
       :until (char= curr #\`)
       :do
       (if (char= curr #\\)
	   (let ((c (read-char stream)))
	     (case c
	       ((#\n) (push #\Newline acc-fmt))
	       ((#\t) (push #\Tab acc-fmt))
	       ((#\{) (push #\{ acc-fmt))
	       ((#\`) (push #\` acc-fmt))
	       (T (error "#`-reader invalid escaped character"))))
	   (if (char= curr #\{)
	       (let ((s (read-delimited-list #\} stream)))
		 (push (car s) acc-args)
		 (push #\~ acc-fmt)
		 (push #\A acc-fmt))
	       (push curr acc-fmt))))
    `(kmrcl:command-output
      ,(coerce (nreverse acc-fmt) 'string)
      ,@(nreverse acc-args))))

(defun enable-sharp-backquote-reader ()
  (set-macro-character
   #\}
   (get-macro-character #\)))
  (set-dispatch-macro-character
   #\# #\`
   #'|#`-reader|))


;;; example
;;' #`ls -a {a}.lisp`
;;> (KMRCL:COMMAND-OUTPUT "ls -a ~A.lisp" A)
;;' #`ls -a {a b}.lisp`
;;> (KMRCL:COMMAND-OUTPUT "ls -a ~A.lisp" A)

ASDF-INSTALLでhttpsからのインストールを行う

asdf-installはURLを指定するとそこからパッケージをダウンロードしてインストールしてくれますが、httpsには対応していません(たぶん)

GitHubがいつの間にかhttpsのみのサポートに切り替わっていたので、 URLを指定してプロジェクトをインストールすることができなくなりました。

とりあえず、CL+SSLを利用してhttpsでも動かせるようなコードを書いてみました。

パッケージ名が文字列かつ"https://"から始まっている場合の動きを若干追加しています。

(asdf:oos 'asdf:load-op :cl+ssl)

(in-package :asdf-install)

(setf (symbol-function 'make-stream-from-url-old)
      #'make-stream-from-url)
(setf (symbol-function 'url-host-old)
      #'url-host)
(setf (symbol-function 'url-port-old)
      #'url-port)
(setf (symbol-function 'request-uri-old)
      #'request-uri)

(defun make-stream-from-url (connect-to-url)
  (let ((sock (make-stream-from-url-old connect-to-url)))
    (if *proxy*
	sock
	(cl+ssl:make-ssl-client-stream sock))))

(defun url-host (url)
  (if (string= url "https://" :end1 8)
      (let* ((port-start (position #\: url :start 8))
	     (host-end (min (or (position #\/ url :start 8) (length url))
			    (or port-start (length url)))))
	(subseq url 8 host-end))
      (url-host-old url)))

(defun url-port (url)
  (if (string= url "https://" :end1 8)
      (let ((port-start (position #\: url :start 8)))
	(if port-start
	    (parse-integer url :start (1+ port-start) :junk-allowed t)
	    443))
      (url-port-old url)))

(defun request-uri (url)
  (if (string-equal url "https://" :end1 8)
      (if *proxy*
	  url
	  (let ((path-start (position #\/ url :start 8)))
	    (assert (and path-start) nil "url does not specify a file.")
	    (subseq url path-start)))
      (request-uri-old url)))

テストツールその2

関数を簡単にテストするなら、このくらい単純で良いような気もしました。

(defvar *test-function-table* (make-hash-table))

;; clause -> ((arg1 arg2 ... ) result) = ((arg1 arg2 ... ) :eq result)
;; clause -> ((arg1 arg2 ... ) :not result)
;; clause -> ((arg1 arg2 ... ) :test test-fn)
(defparameter *test-report-function*
  #'(lambda (fn-name args expected actual)
      (format t "TEST FAILED. Form: (~A ~{~A~^ ~}), Expected: ~A, Actual: ~A~%"
	      fn-name args expected actual)))

(defmacro deftest (fn-name &body clauses)
  (let ((sym (gensym)))
    (labels
	((expander (clause)
	   (let ((result-spec (cdr clause))
		 (test-fn-form `(,fn-name ,@(car clause))))
	     (when (= (length result-spec) 1)
	       (setf result-spec (cons :eq result-spec)))
	     `(let ((,sym ,test-fn-form))
		,(let ((report-form `(funcall *test-report-function*
					      ',fn-name
					      ',(car clause)
					      ',result-spec
					      ,sym)))
		      (case (car result-spec)
			((:eq)
			 `(unless (eq ,sym ,(second result-spec))
			    ,report-form))
			((:eql)
			 `(unless (eql ,sym ,(second result-spec))
			    ,report-form))
			((:equal)
			 `(unless (equal ,sym ,(second result-spec))
			    ,report-form))
			((:not :not-eq)
			 `(when (eq ,sym ,(second result-spec))
			    ,report-form))
			((:not-eql)
			 `(when (eql ,sym ,(second result-spec))
			    ,report-form))
			((:not-equql)
			 `(when (equal ,sym ,(second result-spec))
			    ,report-form))
			((:test)
			 `(unless (funcall ,(second result-spec) ,sym)
			    ,report-form))
			(T (error "invalid test result keyword"))))))))
      `(setf (gethash ',fn-name *test-function-table*)
	     (lambda ()
	       ,@(mapcar #'expander clauses))))))

(defun run-test (fn-name)
  (multiple-value-bind (test-fn ?) (gethash fn-name *test-function-table*)
    (when ?
      (funcall test-fn))))

(defun run-test-all ()
  (maphash
   #'(lambda (key val)
       (when (functionp val)
	 (format t "TEST START : ~A~%" key)
	 (funcall val)))
   *test-function-table*))

;; example
(deftest length
   (('(1 2 3)) 3)
   ((#(1 2)) 2))
(deftest oddp
   ((2) :not-eq t)
   ((3) :eq t))
(deftest symbol-name
   ((:a) :equal "A")
   (('hoge) :equal "hoge"))

(run-test-all)
;; TEST START : LENGTH
;; TEST START : ODDP
;; TEST START : SYMBOL-NAME
;; TEST FAILED. Form: (SYMBOL-NAME 'HOGE), Expected: (EQUAL hoge), Actual: HOGE

Common Lispで図形を描くための27の方法

ありがちなタイトルの付け方ですね。

Common Lispで図形を描くために取り得る手段を列挙してみました。一部現在は使えないか、使うために努力が必要なものがあるかもしれません。

• CUIで充分だよ派
  • 表示されれば良いよ派 format関数
  • Cursesを使うよ派 cl-Ncurses
• ファイルに書き出すよ派
  • Lispで何とかするよ派
    • PNG派 zpng
    • JPEG派 cl-jpeg
    • PDF派 cl-pdf
    • なんでも来いよ派 ch-image, IMAGO
    • ベクタイメージで書いてPNGにするよ派 vecto
  • 外部ライブラリを使うよ派
    • ImageMagic派 cl-magic
    • libpng派 CL-PNG
    • グラフを書くよ派(Graphviz) cl-dot, s-dot, cl-graphviz
    • GDを使うよ派 cl-gd
• ウィンドウに表示するよ派
  • Lispでなんとかするよ派
    • X11プロトコルをしゃべるよ派 CLX
    • LispでCLOSでGUIだよ派 CLIM
    • 処理系に組み込まれてるよ派 LispWorks, Allegro
    • 処理系の実装言語に頼るよ派 ABCL
  • 外部ライブラリを使うよ派
    • OpenGL派 cl-opengl, その他たぶん色々
    • GLFW派 cl-glfw
    • GTK派 cl-gtk, cells-gtk
    • SDL派 CL-SDL, CFFI-SDL, lispbuilder-sdl
    • Tk派 Ltk
    • Qt派 CommonQt, cl-smoke
    • wxWindows派 wxCL
    • Win32で頑張るよ派 lispbuilder-windows
    • .NET FrameworkはGUIライブラリだよ派 RDNZL, Foil
    • JavaはGUIライブラリだよ派 CL+J, Jfli
  • HTML5ならお絵描きもできるよ派
    • S式でJavascriptを書くよ派 Parenscript
    • HTMLごとS式で描くよ派 CL-WHO

注) ネタです。

ユニットテストツールのようななにか

動的言語を使う人達は、簡単なユニットテストくらいなら言語自体の機能をつかってぱぱっと書いてしまうのではないかと想像しています。

私は趣味で適当なプログラムを書いているだけでろくにテストをしませんが、カバレッジのとりかたもわかったことなのでテストツールを書いてみました。

前のエントリでは、SBCLでのカバレッジの結果の出力先はファイルパスと書きましたが、どうもSBCLでもディレクトリのパスっぽいです。どうしてファイルを指定すると思い込んでいたのでしょう。

(defpackage unit-test
  (:use :cl)
  (:shadow cl:assert)
  (:nicknames :utest)
  (:export test-error
	   assert
	   do-as-test
	   define-test-case
	   *unit-test-error-port*
	   *default-assert-error-message*
	   *continue-on-test-error*
	   *assert-count*
	   *assert-error-count*
	   *assert-error-report-function*
	   *coverage-p*
	   *coverage-files*
	   *coverage-path*))

#+SBCL (require 'sb-cover)
#+SBCL (declaim (optimize sb-cover:store-coverage-data))

(in-package :utest)

(define-condition test-error (condition)
  ((msg :accessor message-of :initarg :message)
   (form :accessor form-of :initarg :form)
   (result :accessor result-of :initarg :result))
  (:default-initargs :message "" :form nil :result nil))

(defun make-test-error (msg form result)
  (cerror "continue to eval forms"
	  'test-error
	  :message msg
	  :form form
	  :result result))

(defvar *unit-test-error-port* *standard-output*)
(defparameter *default-assert-error-message*
  "Assertion failed")
(defparameter *continue-on-test-error* nil)
(defparameter *assert-count* 0)
(defparameter *assert-error-count* 0)
(defparameter *coverage-p* nil)
(defparameter *coverage-files* nil)
(defparameter *coverage-path* nil)

(defparameter *assert-error-report-function*
  (lambda (msg form result)
    (format *unit-test-error-port*
	    "Assert failed: ~S~%form: ~S~%result: ~S~%"
	    msg form result)))

(defun compile-and-load (path)
  (compile-file path)
  (load path))

(defun coverage-p ()
  #+SBCL *coverage-p*
  #+CCL *coverage-p*
  #+OPEM-MCL *coverage-p*)

#+SBCL
(defun start-coverage-sbcl ()
  (dolist (file *coverage-files*)
    (compile-and-load file)))

#+SBCL
(defun report-coverage-sbcl ()
  ;; *coverage-path* is file-path
  (sb-cover:report *coverage-path*))

#+CCL
(defun start-coverage-ccl ()
  (setf ccl:*compile-code-coverage* t)
  (dolist (file *coverage-files*)
    (compile-and-load file)))

#+CCL
(defun report-coverage-ccl ()
  ;; *coverage-files* is directory-path
  (ccl:report-coverage *coverage-path*))


(defun report-test ()
  (format *unit-test-error-port*
	  "Assertion ~A,  Success ~A, Fail ~A~%"
	  *assert-count*
	  (- *assert-count* *assert-error-count*)
	  *assert-error-count*)
  (when (and (coverage-p) *coverage-files*)
    #+SBCL (report-coverage-sbcl)
    #+CCL (report-coverage-ccl)))

(defun handler-test-error (e)
  (incf *assert-error-count*)
  (funcall *assert-error-report-function*
	   (message-of e)
	   (form-of e)
	   (result-of e))
  (when *continue-on-test-error*
    (continue)))

(defmacro define-test-case (name lambda-list &body body)
  `(defun ,name ,lambda-list
     (format *unit-test-error-port*
	     "Run test case: ~A~%"
	     ',name)
     (handler-bind ((test-error #'handler-test-error))
       ,@body)))

(defmacro assert (&whole form test-form &optional msg-fmt &rest args)
  (let ((sym (gensym)))
    `(progn
       (incf *assert-count*)
       (let ((,sym ,test-form))
	 (unless ,sym
	   (make-test-error
	    (format nil (or ,msg-fmt *default-assert-error-message*) ,@args)
	    ',form
	    ,sym))
	 ,sym))))

(defmacro do-as-test
    ((&key error-port continue-on-test-error-p
	   assert-error-report-function coverage-p
	   coverage-path coverage-files)
     &body body)
  `(let ((*unit-test-error-port* (or ,error-port *unit-test-error-port*))
	 (*continue-on-test-error*
	  (or ,continue-on-test-error-p *continue-on-test-error*))
	 (*assert-error-report-function*
	  (or ,assert-error-report-function *assert-error-report-function*))
	 (*assert-error-count* 0)
	 (*assert-count* 0)
	 (*coverage-path* (or ,coverage-path *coverage-path*))
	 (*coverage-p* (or ,coverage-p *coverage-p*))
	 (*coverage-files* (or ,coverage-files *coverage-files*)))
     (when (and (coverage-p) *coverage-files*)
       #+SBCL (start-coverage-sbcl)
       #+CCL (start-coverage-ccl))
     (unwind-protect
	  (handler-bind ((test-error #'handler-test-error))
	    ,@body)
       (report-test))))

;; function.lisp

(defun make-add (a)
  (lambda (x)
    (+ x a)))

(defun quoted? (obj)
  (if (and (listp obj)
	   (eq (car obj) 'quote))
      T
      nil))

(defun bad-quoted? (obj)
  (if (and (listp obj)
	   (eq (car obj) 'quote))
      nil
      T))

;; テストコード
(utest:define-test-case test-01 ()
	   (let ((add-5 (make-add 5)))
	     (utest:assert (eq 6 (funcall add-5 1)))))
(utest:define-test-case test-02 ()
	   (utest:assert (eq nil (quoted? :hoge))))
(utest:define-test-case test-03 ()
	   (utest:assert (eq T (bad-quoted? ''hoge)))))

(utest:do-as-test
	     (:continue-on-test-error-p t
	      :coverage-p t
	      :coverage-files '("/path/to/function")
	      :coverage-path "/path/to/dir/")
	   (test-01)
	   (test-02)
	   (test-03))

;;Run test case: TEST-01
;;Run test case: TEST-02
;;Run test case: TEST-03
;;Assert failed: "Assertion failed"
;;form: (UNIT-TEST:ASSERT (EQ T (BAD-QUOTED? ''HOGE)))
;;result: NIL
;;Assertion 3,  Success 2, Fail 1

メソッドがクラスに属しているかのような錯覚をおこす為のマクロ

タイトルどおりのものを作ろうとしてみましたが案の定ぐだぐだに。

Common Lispのインスタンス変数(スロット)は :allocation :class と指定することで同じクラスのオブジェクトで共有されますが、共有されるだけで実際にインスタンスを生成しなければアクセスすることができません(たぶん)。

なので、クラス変数をメタクラスのインスタンス変数とすることで他のオブジェクト指向言語に近付こうとしてみました。

ソースコードはgistに置きました。

https://gist.github.com/662369

;; example
(class <foo> ()
  (def sum ()
    (+ @@a @b))

  (setf @@a 10)

  (def set-b (b)
    (setf @b b)))

(defvar *obj* (make-instance '<foo> :b 20))

(sum *obj*)
;;=> 30

(set-b *obj* 10)

(sum *obj*)
;;=> 20

<foo>
;;=> #<#:META-<FOO>1306 <FOO>>

もっと頑張ってみても面白いかもしれない。

SBCLとCCLでのカバレッジの取りかた

SBCLとClozure Common Lisp(以下CCL)にはファイルのカバレッジを取り、HTMLで出力してくれる機能があるようです。

CCLでは ccl:*compile-code-coverage*をTにしてからカバレッジを取りたいファイルをコンパイル->ロードして、テストの実行とカバレッジの集計結果出力を行います。

SBCLでは、SB-COVERパッケージを読み込んでから、ファイルのコンパイル、ロード、テスト実行、結果の出力を行います。

結果の出力時に指定するパスは、CCLではファイル名ですが、SBCLではディレクトリ名のようです。

(defun compile-and-load (path)
  (compile-file path)
  (load path))

;;; clozure common lisp
(setf ccl:*compile-code-coverage* t)

(compile-and-load "path/to/source")

(run-test)

(ccl:report-coverage "file")

;;; SBCL
(require 'sb-cover)

(declaim (optimize sb-cover:store-coverage-data))

(compile-and-load "path/to/source")

(run-test)


(sb-cover:report "dir")

lengthとeltのgeneric-function版

Common Lispパッケージの内容を上書きするのはよろしく無いのではと思い、適当な名前でタイトル通りのものを書いてみました。

(defun defmethods-args-expander (args specifiers)
  (when (< (length args) (length specifiers))
    (error "Too many specifiers"))
  (labels
      ((inner (ar sr acc)
(if (null ar)
(nreverse acc)
(inner (cdr ar)
(cdr sr)
(cons
(if (null sr)
(car ar)
(list (car ar) (car sr)))
acc)))))
    (inner args specifiers nil)))

(defun defmethods-clause-expander (name args clause)
  (destructuring-bind (specifiers &rest definition)
      clause
      (unless (listp specifiers)
(setf specifiers (list specifiers)))
    `(defmethod ,name
,(defmethods-args-expander args specifiers)
       ,@definition)))

(defmacro defmethods (name (&rest args) &body clauses)
  (when (null args)
    (error "There is no argument"))
  `(progn
     ,@(mapcar
#'(lambda (clause)
(defmethods-clause-expander name args clause))
clauses)))

(defgeneric size (object))

(defmethods size (object)
  (list (length object))
  (integer (integer-length object))
  (file-stream (file-length object)))

(defgeneric ref (object place))

(defmethods ref (object place)
  ((sequence integer) (elt object place))
  ((simple-vector integer) (svref object place))
  ((array integer) (aref object place))
  ((array list) (apply #'aref object place))
  ((list integer) (nth place object))
  ((list T) (assoc place object)))