#:g1: frontpage

 

続・(coerce "foo" 'cons)は合法か否か

Posted 2020-10-28 13:15:31 GMT

Franzにcoerceの挙動がバグなのではないかと報告してみましたが、なんと報告メールの送信から三時間強で、バグ番号が振られ次期バージョンで修正するという返事が来ました。
暫定パッチは必要か尋ねられましたが、バグ報告が目的なので必要ないと回答。
LispWorksもそうですが商用処理系では、暫定的に処理系の挙動を修正するパッチを作成してくれることが多いようです。

複雑なlistのサブタイプ指定に対してLispWorksの動作が正確な理由

(coerce "foo" '(cons (eql #\f) (cons (eql #\o) (cons (eql #\f) *))))

のような込み入った指定でSBCLがチェックに失敗し、LispWorksが正解する理由ですが、LispWorksのcoercedisassembleしてみると、変換の後に指定した型指定子で結果オブジェクトのタイプチェックをしているからのようです。
なるほど、確かに後でチェックすれば間違いはない。
逆に、SBCL等は何の型に変換するかだけを見ているので、型指定子がlistのサブタイプと判定された後はチェックしていません。

SBCLにもバグ報告しようかなと思ったりはしますが、返り値の型が指定より緩い分には返り値の型チェックをするコードを追加すれば良く、大した害もないですし気が向いたら報告します……。


HTML generated by 3bmd in LispWorks Personal Edition 7.1.2

(coerce "foo" 'cons)は合法か否か

Posted 2020-10-27 16:47:47 GMT

自作のライブラリで、(coerce "foo" 'cons)や、(coerce "" 'null)のようなコードがAllegro CLでエラーになるので、おやもしかして処理系依存だったかと思いANSI規格を確認してみましたが、

sequence

If the result-type is a recognizable subtype of list, and the object is a sequence, then the result is a list that has the same elements as object.

——ということなので、合法のようです。

ちょっと趣味的にAllegro CL 4.3(1996)で確認してみましたが、同様のエラーのようです。
そうなると時代的にCLtL1、CLtL2あたりでははっきり決まっていなかったかもしれないので確認してみましたが、明記されたのはANSI CL規格以降のようです。

無駄に深追いしてみる

とりあえず、Allegro CLのcoercedisassembleしてみると、excl::vector-to-list*という下請けに渡していることが分かります。

1023: 89 da       movl  edx,ebx
1025: 3b 56 26    cmpl  edx,[esi+38]     ; LIST
1028: 0f 85 1e 02 jnz   1576
      00 00 
1034: 8b 45 dc    movl  eax,[ebp-36]     ; EXCL::LOCAL-0
1037: 89 7d f0    movl  [ebp-16],edi
1040: c9          leave
1041: 8b 5e 2a    movl  ebx,[esi+42]     ; EXCL::VECTOR-TO-LIST*

このexcl::vector-to-list*自体は、適切にリストに変換できるようですが、前段では、consnullも出てこずにlistとしか比較していないので、すりぬけてエラーになっているように見えます。

(excl::vector-to-list* "")
→ NIL

(excl::vector-to-list* "foo")(#\f #\o #\o)

listのサブタイプはconsnull以外にも複合した指定があるので、別途サブタイプの判定をきっちりしないと

(coerce "foo" '(cons (eql #\f) (cons (eql #\o) (cons (eql #\f) *))))

のようなものを判定できなさそうです。
ちなみに上記は、LispWorksではエラーになりますが、SBCLではエラーになりません(SBCLのバグもみつけてしまったか?)

バグ報告

Allegro CLへのバグはどこに報告したら良いのかと探してみましたが、報告の仕方の解説ページがあったので、こちらに沿って報告してみました。

まとめ

Allegro CL 4.3(1996)でも同様なので、Allegro CL(ExCL)誕生時(1986)からこの仕様で来たような気がしないでもありません。
果してバグ認定されるのか、はたまたAllegro CLの仕様であるとして修正されないのか。

ちなみに、mapも変なところがありますが、話がややこしくなるので、今回は報告を見送りました。

#+Allegro
(map 'null #'identity "foo")
→(#\f #\o #\o)


HTML generated by 3bmd in LispWorks Personal Edition 7.1.2

LispWorksのエディタが思いの外Hemlockだった

Posted 2020-10-17 21:13:02 GMT

LispWorksのエディタがHemlock由来というのは、LispWorksの歴史のページにも記載されているのですが、フォークされたのも1987年あたりのようですし、原型は留めていないのかと勝手に想像していました。

  • LispWorks® History

    Technically, LispWorks's distant origins include Spice Lisp, while the editor began life as a branch of Hemlock, and the CLOS implementation started out as a branch of PCL (Portable Common Loops).

LispWorksを本格的に使い始めて早五年ですが、どれだけHemlockと似ているのか具体的に眺めたことはないなあと思ったので、ちょっと突き合せて眺めてみました。

30のファイルのファイル名が同じ

LispWorksに付属してくるエディタのファイルは94、cmucl付属のHemlockのファイルは111ありますが、30ファイルの名前が一致。

  • abbrev.lisp
  • auto-save.lisp
  • buffer.lisp
  • charmacs.lisp
  • command.lisp
  • comments.lisp
  • doccoms.lisp
  • echo.lisp
  • echocoms.lisp
  • filecoms.lisp
  • files.lisp
  • fill.lisp
  • highlight.lisp
  • indent.lisp
  • interp.lisp
  • kbdmac.lisp
  • killcoms.lisp
  • lispeval.lisp
  • lispmode.lisp
  • main.lisp
  • morecoms.lisp
  • overwrite.lisp
  • register.lisp
  • screen.lisp
  • searchcoms.lisp
  • streams.lisp
  • struct.lisp
  • table.lisp
  • text.lisp
  • window.lisp

パッケージ内のシンボル名の267が一致

外部シンボルで、関数か変数の束縛があるシンボルは、267。内部シンボルだと292、束縛なしだと857のシンボルが一致

ほぼ内容が同じファイルが結構ある

HemlockもLispWorksのエディタもほぼ同じというファイルがそこそこあります。
例えば、abbrev.lispを眺めると、

;;;          Hemlock Word Abbreviation Mode
;;;               by Jamie W. Zawinski
;;;                24 September 1985

オリジナルの作者は、jwz氏だったようです。
1968年生れのようなので当時16歳でしょうか。

まとめ

日々Abbrev Modeを使っていますが高校生時代のjwz作とは知らなんだ。
LispWorksのエディタとよりLispWorksのHemlockという感じですね。

五年も使っているのに、ファイルを詳しく比較するまで気付かなかった理由ですが、LispWorksがオリジナルのヘッダコメントを全部綺麗に削っているので由来がぱっとみでは判然としなかった、というのがあります。

オリジナルのHemlockは、

;;; This code was written as part of the CMU Common Lisp project at
;;; Carnegie Mellon University, and has been placed in the public domain.

———とパブリックドメインなので、別に問題ないんでしょうけど、同じくHemlock派生のLucidのHelixでは、ちゃんと由来を残していたりします。

;;; -*- Package: Helix; Log: Helix.Log -*-
;;;;
;;;; FILECOMS, Module HELIX
;;;
;;; ***************************************************************************
;;;
;;;        Copyright (C) 1987 by Lucid Inc.,  All Rights Reserved
;;;
;;; ***************************************************************************
;;;
;;; Originally part of the Spice Lisp Hemlock system, by Rob MacLachlan,
;;; Skef Wholey and Bill Chiles, of CMU
;;;
;;; Programmer: Ken D. Olum
;;;
;;; Edit-History:
;;;
;;; Created: Spring 1987

—— このように由来の記載が残っていれば、すぐ判るのですが……。
ちなみに、MCLのFredもHemlock由来らしいですが、こちらはオブジェクト指向な感じに書き直されていてほぼ原型を留めていません。


HTML generated by 3bmd in LispWorks Personal Edition 7.1.2

named-readtables不要論

Posted 2020-10-12 17:25:13 GMT

リードテーブルの切り換えにnamed-readtablesを愛用しているので不要ということもないのですが、リードテーブルの切り換えという中核の機構が外部のライブラリに依存しているのが少し嫌だったりします。
実際、named-readtablesがメンテナ不在時に壊れたままだったり、ECLのような処理系では頻繁に壊れていたりはするのですが、便利といえば便利なので愛用しています。

そもそもCommon Lispの前身であるLisp Machine Lispでは、ファイル先頭の属性リスト-*- mode: lisp -*-で、パッケージとリードテーブルを切り替えるのが基本でしたが、Common Lispではそれを採用しなかったので、(in-package ...)等を書くことになりました。

しかし、(in-package ...)は標準なのに、(in-readtable ..)等は標準でないのは何故なのか。

*readtableを切り換えるin-syntaxも提案されてはいた

実は、*readtableを切り換えるin-syntaxもKent Pitman(KMP)氏によって提案されてはいたようです。

in-syntaxはHyperSpecのイシューまとめにもありますが、cl-cleanupメーリングリストの方が一連の流れが追えるのでそちらを紹介すると、

KMPの提案は、ほぼin-packageに相当するようなシンプルなものだったようです。

(DEFMACRO IN-SYNTAX (READTABLE)
  `(EVAL-WHEN (EVAL COMPILE LOAD)
     (SETQ *READTABLE* ,READTABLE)))

使い方ですが、パッケージ定義の後で、リードテーブルの変数を定義し、それにリードテーブルを設定、

;;; -----File A-----
(DEFPACKAGE ACME ...)
(DEFVAR *ACME-SYNTAX*  (COPY-READTABLE *READTABLE*))

以降のファイルは、先頭に適宜in-packagein-syntaxを書いていくというものです。

(IN-PACKAGE ACME)
(IN-SYNTAX *ACME-SYNTAX*)

(SET-MACRO-CHARACTER #\! ...)

なるほど。

良く考えると、カスタマイズされたリードテーブルを使う頻度からして、三行のマクロを都度書けば良いだけなので、毎度書いても大した手間でもないかなという感じです。
場合によっては、named-readtablesのライブラリの依存関係を記述したり、パッケージにインポートしたりの方が手間かもしれません。

ちなみに、1980年代後半〜90年代前半あたりのCommon Lispの大き目のプロジェクトでは、

(defmacro my-module ()
  `(eval-when (:compile-toplevel :load-toplevel :execute)
     (in-package my-package)
     (setq *readtable* *my-syntax*)))

のようなものを定義して、

;;; -* mode: lisp -*- 

(my-module)

...

のようにファイルの先頭に置いておく作法も割合に目にしますが、外部ライブラリのnamed-readtablesの作法に縛られるよりも自由度が高くて管理も楽かもしれません。

名前付きリードテーブルのメリット

一応、named-readtablesのメリットというか、名前付きリードテーブルのメリットを挙げておくと、名前を付けて管理する機構になっているので、find-readtableで任意のリードテーブルを呼び出すことが可能です。
恐らく、元ネタはAllegro CLのnamed readtableだと思いますが、Allegro CLのさらに元ネタは多分、Lisp Machine Lispのsi:find-readtable-named等、リードテーブルに複数の名前を付けることができたAPI由来かなと思います。

in-syntaxは何故標準化されなかったのか

KMPはシンプルに*readtable*変数を設定するだけの提案だったようですが、名前が良くない、それをいったら、*read-base*read-default-float-format*はどうするんだ、あまり気軽に変更するとcompile-fileloadで変なことが起きがちになる、仕様のクリーンナップというよりはコンパイラ仕様で議論すべきだった、等々、議論が発散してまとまらなかったようです。

まとめ

KMPが提案してANSI CL規格に入らなかったものは結構ありますが、defsystemin-syntax等は、後世の人達が結局ライブラリとして自作することになったので、標準化されると良かったなと思うことしきりです。


HTML generated by 3bmd in LispWorks Personal Edition 7.1.2

マクロに付くコンパイラマクロの使い道 (2)

Posted 2020-10-05 15:45:04 GMT

三年前のブログネタのメモに、「マクロにコンパイラマクロ allegro clのcompose-stringを改良する」とあったので、Allegro CLのcompose-stringの仕様を確認してみましたが、一体何が気に入らなかったのか思い出せません。

compose-stringの仕様ですが、基本的にコンパイル時(マクロ展開時)に文字列を合成してしまおうというもので、展開時に文字列リテラルとして確定できる場合は、文字列を、確定できない場合は、compose-string-fnを呼び出す式へ展開、という仕様です。

(compose-string "foo" "bar" :[ 3042 :] "foo" newline)
===> "foobarあfoo
"

(compose-string "foo" "bar" :[ 3042 :] "foo" newline :eval "foo")
===> (compose-string-fn "foo" "bar" 12354 "foo" #\Newline "foo")

三年前の自分の気持ちを察するに、マクロ展開時に色々やりすぎというところだったのかもしれません。
Common Lispでマクロ展開時とコンパイル時を同一視する人は多いですが、厳密にはマクロ展開は、インタプリタ動作時にも実行されるため、あまりマクロ展開での重い仕事はインタプリタを遅くすることになります。
まあSBCLのような処理系が主流の今となっては誰も気にしていないと思いますが。

マクロ展開での重い仕事をコンパイル時に移行する手段としては、コンパイラマクロがありますが、多分、compose-stringをこのような作りに仕立ててみるということがやりたかった気がするので、そういう風なものを作成してみましょう。

compose-stringのマクロ展開を軽くする

とりあえずですが、下請けの、compose-string-fnを定義します。

(defun compose-string-fn (&rest args)
  (with-output-to-string (out)
    (dolist (a args)
      (typecase a
        (CHARACTER 
         (write-char a out))
        (INTEGER 
         (write-char (code-char a) out))
        (STRING
         (write-string a out))
        (T (write-string (string a) out))))))

次に、compose-stringの引数を、compose-string-fnが解釈できるような形式に変換する関数を作成します。

(defun compose-string-process-args (&rest args)
  (labels ((err (args)
             (error "Invalid argument to compose-string: :] in ~S" args))
           (compstr (args acc)
             (if (endp args)
                 (nreverse acc)
                 (typecase (car args)
                   ((OR STRING CHARACTER INTEGER) 
                    (compstr (cdr args)
                             (cons (car args) acc)))
                   ((EQL :])
                    (err args))
                   ((EQL :[)
                    (let ((pos (position :] (cdr args))))
                      (if pos
                          (compstr (append
                                    (mapcar (lambda (x)
                                              (parse-integer (write-to-string x) :radix 16.))
                                            (subseq (cdr args) 0 pos))
                                    (nthcdr (1+ pos) (cdr args)))
                                   acc)
                          (err args))))
                   ((EQL :EVAL)
                    (compstr (cddr args)
                             (cons (cadr args)
                                   acc)))
                   (SYMBOL 
                    (compstr (cons (name-char (string (car args)))
                                   (cdr args))
                             acc))
                   (T (err args))))))
    (compstr args nil)))

これらをcompose-stringとしてまとめます。

(defmacro compose-string (&rest args)
  `(compose-string-fn ,@(apply #'compose-string-process-args args)))

動作

(compose-string "foo" "bar" :eval 12354 :[ 3042 :] "foo")
===>
(compose-string-fn "foo" "bar" 12354 12354 "foo")

コンパイラマクロを追加

とりあえず上記のような動作ですが、引数処理時に全部が文字列であることが判定できる場合は、展開時に文字列を返すような最適化をコンパイラマクロで追加します。

(define-compiler-macro compose-string (&whole w &rest args)
  (let ((args (apply #'compose-string-process-args args)))
    (if (every #'stringp args)
        (apply #'concatenate 'string args)
        w)))

(compiler-macroexpand '(compose-string "foo" "bar" "foo"))
→ "foobarfoo"

多分三年前の自分はこんな動作をさせたかったのでしょう。

一方Allegro CLでの動作は

元々のAllegro CLのcompose-stringでは、:evalオプションがなければ、マクロ展開時に全部計算してしまいます。

大体、上記コンパイラマクロ版の定義と同じですが、再現するとしたら下記にようになるでしょうか。

(defun compose-string-process-args (&rest args)
  (labels ((err (args)
             (error "Invalid argument to compose-string: :] in ~S" args))
           (compstr (args acc)
             (if (endp args)
                 (nreverse acc)
                 (typecase (car args)
                   (STRING 
                    (compstr (cdr args)
                             (typecase (car acc)
                               (STRING (cons (concatenate 'string
                                                          (car acc)
                                                          (car args))
                                             (cdr acc)))
                               (T (cons (car args) acc)))))
                   (CHARACTER
                    (compstr (cons (string (car args))
                                   (cdr args))
                             acc))
                   ((EQL :])
                    (err args))
                   ((EQL :[)
                    (let ((pos (position :] (cdr args))))
                      (if pos
                          (compstr (append
                                    (mapcar (lambda (x)
                                              (parse-integer (write-to-string x) :radix 16.))
                                            (subseq (cdr args) 0 pos))
                                    (nthcdr (1+ pos) (cdr args)))
                                   acc)
                          (err args))))
                   (INTEGER 
                    (compstr (cons (code-char (car args))
                                   (cdr args))
                             acc))
                   ((EQL :EVAL)
                    (compstr (cddr args)
                             (cons `(:eval ,(cadr args))
                                   acc)))
                   (SYMBOL 
                    (compstr (cons (name-char (string (car args)))
                                   (cdr args))
                             acc))
                   (T (err args))))))
    (compstr args nil)))

(defun strip-eval-mark (args) (mapcar (lambda (x) (etypecase x (STRING x) ((cons (eql :eval) *) (cadr x)))) args))

(defmacro compose-string (&rest args) (let ((args (apply #'compose-string-process-args args))) (if (every #'stringp args) (apply #'concatenate 'string args) `(compose-string-fn ,@(strip-eval-mark args)))))

(compose-string "foo" "bar" :[ 3042 :] "foo") ===> "foobarあfoo"

コンパイラマクロ版を更に改良

前述のマクロにコンパイラマクロを付ける方式だと、compose-string-fnの文字列の融合までは処理されません。
しかし、compose-string-fnの方にもコンパイラマクロを付ければ解決できるでしょう。

(define-compiler-macro compose-string-fn (&whole w &rest args)
  (if (every #'stringp args)
      (apply #'concatenate 'string args)
      w))

(compiler-macroexpand '(compose-string-fn "foobarあfoo
"
                   "foo"))
→ "foobarあfoo
foo" 

まとめ

以上、インタプリタ動作でのマクロ展開は軽くしつつ、コンパイル動作の場合はコンパイル時に最適化処理はしてしまう、というのを考えてみました。
基本的に引数の最適化処理はコンパイラマクロの主要な使い道(&keyの最適化等)なので、使える場所があったら使ってみるのが良いかなと思います。

参照


HTML generated by 3bmd in LispWorks Personal Edition 7.1.2

begin0 prog1 prog2 prognの謎

Posted 2020-09-29 01:28:16 GMT

Common Lispには、prog1prog2prognとありますが、Lispは0オリジンなのに、(nth 0)な場所の値を返すprog1(nth 1)な場所の値を返すprog2、って整合性がないなあ、一方Scheme畑では、美しく、begin0と命名する(Racket等)……という小話がありますが、なぜCommon Lispは1オリジン風なのでしょうか

;;; Welcome to Racket v7.8.
(begin0 0 1 2 3)
→ 0

A. 元々の数字はフォームのアリティだったから

Common Lispには、prog1prog2prognとありますが、Lisp 1.5まで遡ると、prog2しかありませんでした。
この時のprog2は、2つのフォームをとれるフォームで最後の値を返すものでした。

これが、PDP-6 Lisp(1966)で、prog2が可変長の引数を取れるように進化。値を返す場所は変更なし、ということで、「二番目のフォームの値を返す」もの、という感じになってしまいました。

続いて、progn(1968あたり)、prog1(1977あたり)が続きます。

まとめ

可変長のフォームで、N番目のフォームの値を返す、というのは割合に発明だった気がしますが、命名則としてはねじれたことになってしまったようです。


HTML generated by 3bmd in LispWorks 7.0.0

loopにもっと括弧を

Posted 2020-09-27 04:38:31 GMT

以前、ANSI CL規格(INCITS 226-1994)の規格の更新について議論しているログを眺めたことがあったのですが、その中で、Jon L White氏が「loop にもっと括弧を」という意見を出していました。
この議論のログは確かウェブで参照できた筈ですが、今やまったく見付かりません。結構貴重な資料だと思いますが……。

loopをLispyに改善したものといえば、iterateだと思いますが、括弧をつけるだけなら、簡単な処理で実現できるなと思ったので試してみました。

(defmacro for (&rest body)
  `(loop 
    ,@(reduce (lambda (res b)
                (append res (->loop-clause b)))
              body
              :initial-value nil)))

(eval-when (:compile-toplevel :load-toplevel :execute) (defun ->loop-clause (xpr) (case (find (car xpr) '(let) :test #'string-equal) (let (destructuring-bind (let &rest args) xpr (declare (ignore let)) `(for ,@args))) (otherwise xpr))))

要するにloopに余計な括弧を付与するだけですが、まあまあそれっぽくなります。

(for (let i :from 0)
     (let j :from 0)
     (repeat 16)
     (if (oddp i)
         :collect i :into es)
     (collect i :into is)
     (collect j :into js)
     (finally (return (list es is js))))((1 3 5 7 9 11 13 15)
    (0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15)
    (0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15))

loopだと:do節の後にprognを補ったりしがちですが、括弧で囲むと範囲がはっきりするので安定感があります。

(for (repeat 5)
     (do (print 'hello-world)
         (terpri)))
▻ 
▻ hello-world 
▻ 
▻ hello-world 
▻ 
▻ hello-world 
▻ 
▻ hello-world 
▻ 
▻ hello-world 
→ nil

まとめ

もうちょっと凝ったことをしようと思ったら素直にiterateを使う方が良いとは思いますが、案外上手くいっちゃってる感。
もっとも、JonL氏がいう「もっと括弧を」、というのは恐らくiterateのようなものを指しているのだとは思いますので誤解なきよう。


HTML generated by 3bmd in LispWorks Personal Edition 7.1.2

setf可能な場所なのかどうかを確認したい

Posted 2020-09-23 02:00:36 GMT

setf可能な場所なのかどうかを確認したい、というのは、そもそもどういう動機からなのかというと、身近な例では、(setf nthcdr)等と書いた時に、

(let ((x (list 0 1 2 3 4)))
  (setf (nthcdr 1 x) (list 'a 'b 'c))
  x)
!Error: Undefined operator (setf nthcdr) in form ((setf nthcdr) #:|Store-Var-34450| #:g34451 #:g34452).

となってしまい、あれ、(setf nthcdr)って設定されてないんだっけ?というようなことを防止したい、というような動機です。

上記の場合、

(let ((x (list 0 1 2 3 4)))
  (setf (cdr (nthcdr 0 x)) (list 'a 'b 'c))
  x)(0 a b c)

と書き直せば良いのですが。

考えられそうなアプローチ

  • setfできそうな場所は全部setf対応しておく
  • setfの展開を制御するユーティリティマクロで頑張ってみる
  • 標準規格で定義されているsetfの場所以外のものは一切書かない

等々、色々ありますが、まず、setfして回るのは、処理系を改造することになるので、ちょっと嫌なのと、やるとしてもsetfの展開方法が処理系ごとに結構違っているので、setfを設定するコードの可搬性を担保するのが結構難しい。

次に、ユーティリティマクロで囲んだり、setfの類似品を作る的なところですが、この問題をコードウォークして解決するとしても、局所関数/マクロでsetfを定義できたりするので結構大変でしょう。

標準規格で定義されているsetfの場所以外のものは一切書かない、というのは若干寂しいですが、これはこれでありかなと思います。

標準の(setf place)を一覧にする

標準の(setf place)を全部把握したい、ということで、CLHS: 5.1.2 Kinds of Placesで定義されているものを、列記してみます。

変数名全部

これは問題ないでしょう

標準定義の関数フォーム形式

(setf bit)
(setf c[ad]+r) ;car cdr系全部
(setf char)
(setf class-name)
(setf compiler-macro-function)
(setf documentation)
(setf elt)
(setf fdefinition)
(setf fifth)
(setf fill-pointer)
(setf find-class)
(setf first ... tenth) ; firstからtenthまで
(setf rest)
(setf get)
(setf getf)
(setf gethash)
(setf ldb)
(setf logical-pathname-translations)
(setf macro-function)
(setf mask-field)
(setf nth)
(setf readtable-case)
(setf row-major-aref)
(setf sbit)
(setf schar)
(setf slot-value)
(setf subseq)
(setf svref)
(setf symbol-function)
(setf symbol-plist)
(setf symbol-value)

Apply との組み合わせ

上記に加えて、Applyのフォームと組合せ可能なものとして、arefbitsbitがあるので、

(setf (apply #'aref))
(setf (apply #'bit))
(setf (apply #'sbit))

Values との組み合わせ

上記の関数フォームに組合せ可能なものとして更にvalues

(setf values)

the との組み合わせ

さらに組合せ可能なものとして、the

(setf the)

setf系マクロ

decf pop pushnew incf push remf あたりのマクロですが、define-modify-macroで定義したように動くので、valuesと組合せて使うことは想定されていない様子。
LispWorksに至ってはエラーになります。

まとめ

標準の組み合わせだけでも、結構複雑な組み合わせは可能です。

(let ((ba (make-array '(4 4) 
                      :element-type 'bit 
                      :initial-element 1))
      (bb (make-array '(4 4) 
                      :element-type 'bit 
                      :initial-element 1)))
  (setf (values (the bit (apply #'bit ba '(0 0)))
                (the bit (apply #'bit bb '(0 0)))) 
        (values 0 0))
  (values ba bb))
→ #2A((0 1 1 1) (1 1 1 1) (1 1 1 1) (1 1 1 1))
  #2A((0 1 1 1) (1 1 1 1) (1 1 1 1) (1 1 1 1))

(let ((a (make-array '(4 4) :initial-element 0))) (incf (the integer (apply #'aref a '(1 1)))) a) → #2A((0 0 0 0) (0 1 0 0) (0 0 0 0) (0 0 0 0))

便利なsetfマクロですが、あまり複雑なことはしない方が良いのかなと(月並)
ただ、(setf values)については、色々なソースを眺めていても、あまり活用されていない気がするので、もっと活用されても良いかなと思います。


HTML generated by 3bmd in LispWorks 7.0.0

束縛部での変数名の重複

Posted 2020-09-22 00:51:35 GMT

LispWorksでコードを書いていて、

(let ((x 42)
      (x 69))
  x)
→ 42

みたいなものがエラーにならなかったので、コンパイラの最適化のバグか何かかと思って他の処理系でも試してみたところ、SBCLやCMUCL、ECLではエラーになるものの他の処理系では特にエラーにならないようです。

もしや規格上は問題ないのかと思ってHyperSpecを確認してみると、特に記載がない様子。

Common Lispはlambdaに展開される訳ではないので、lambdaでの重複チェックとは別になっているのかなと思い、lambdaも確認してみましたが、

((lambda (x x) x) 42 69)
→ 69

これもSBCLやCMUCL、ECL、CCL以外では、エラーにならない様子(CCLはこちらはエラーにするらしい)

λリストについても、重複については特に記載がない様子。

Scheme(R7RS)ではエラーと規定されているので、そういうものだと思っていましたが、実際の処理系で試してみると、Schemeの処理系でも動作はまちまちでした。
Scheme流の「エラーという定義だけど、どうエラーを処理するかは規定しない」ってやつでしょうか。

まとめ

束縛部の変数名の重複チェックが緩いのは、バグの元になるので、何らかの方法でユーザーに通知して欲しいですね。
マクロでコード生成するのが頻繁なLisp系言語では特にですが。
SBCLで虫取りが捗るのは、割とこういう類のチェックが充実しているというのもあると思います。


HTML generated by 3bmd in LispWorks Personal Edition 7.1.2

thenretの活用

Posted 2020-09-19 23:44:52 GMT

古えのLucid CLのソースを眺めていて、こんなコードに遭遇したのですが、これがなかなか味わい深い。
コードの作者はJonL氏。

(defun find-named-slot (slot-name slotds &optional (no-error-p nil))
  (cond ((loop for slotd in slotds
               thereis (and (eq slot-name (%slotd-name slotd))
                            slotd)))
        (no-error-p nil)
        (t (system-error hhctb))))

condの述語部の返り値を活用しているのですが、Franz Lispのifでいうthenretの活用です。

実際に最近の処理系でも動くように書き直すと下記のようになるでしょうか。
(ついでにloopthereisfindに置き換え)

(ql:quickload "closer-mop")
(in-package c2cl)

(defun find-named-slot (slot-name slotds &optional (no-error-p nil)) (cond ((find slot-name slotds :key #'slot-definition-name)) (no-error-p nil) (t (error "How the hell can this be?!"))))

(defclass foo () (a b c))

(find-named-slot 'a (class-slots (find-class 'foo))) → #<standard-effective-slot-definition a 411021F02B>

(find-named-slot 'z (class-slots (find-class 'foo))) >> Error: How the hell can this be?!

ちなみに、hhctbは、MACLISPのエラーコードで、“How the hell can this be?!”の略みたいです。
色々検索してもヒットしないので、もしかするとJonL氏以外使ってないんじゃないでしょうか。

上記をifの連鎖で書くと下記のようになります。

(defun find-named-slot (slot-name slotds &optional (no-error-p nil))
  (let ((slotd (find slot-name slotds :key #'slot-definition-name)))
    (if (not (null slotd))
        slotd
        (if no-error-p
            nil
            (error "How the hell can this be?!")))))

ifで書き直してみると、no-error-pのあたりも含めて、thenretだけでなくcondを上手く活用していることが分かります。

thenretに類似するところでは、orの返り値を活用するというのがありますが、慣れないと少し解読が難しいかも。

(defun find-named-slot (slot-name slotds &optional (no-error-p nil))
  (let ((slotd (find slot-name slotds :key #'slot-definition-name)))
    (or slotd
        (and (not no-error-p)
             (error "How the hell can this be?!")))))

ちなみにrmsのLispコードではこういうパタンが多用されています。

まとめ

伝統的なLispでの thenret は多値を返さない(せない)のですが、srfi-61では、多値を活かすことができる仕組みになっています。

(cond ((values 0 1) values => values)
      (else #f))

アナフォリックマクロのitwhen-let等もthenretの文脈に近いものがありますが、慣れると結構活用できる気がします。


HTML generated by 3bmd in LispWorks Personal Edition 7.1.2

ボディ部にドキュメンテーション文字列しかない場合について

Posted 2020-09-12 20:14:02 GMT

ボディ部にドキュメンテーション文字列しかない場合について、というのは具体的には、

(lambda (x) "λ[[x]]")

(defun foo (x) "λ[[x]]")

のような場合ですが、上記のように書いてしまうと、ドキュメンテーション文字列ではなくて、返り値(フォームの最後の値)となってしまいます。

(mapcar (lambda (x) "λ[[x]]")
        '(0 1 2 3))("λ[[x]]" "λ[[x]]" "λ[[x]]" "λ[[x]]")

(documentation 'foo 'function) → NIL

この場合、二通りの解決策があり、返り値として、nilを明示的に書く、空のdeclareを書くことで回避可能です。

(defun foo (x)
  "λ[[x]]"
  (declare))

(mapcar #'foo '(0 1 2 3))(NIL NIL NIL NIL)

空のボディを生成してしまうのが悪いのでは?という話もありますが、マクロ等でコード生成した場合に意図せず生成されてしまうことは結構あります。

この場合、(declare)を入れておく方が、明示的にnilという値を入れるより生成するコードが簡単になるかなと思います。

以上、非常にニッチな話でした。


HTML generated by 3bmd in LispWorks Personal Edition 7.1.2

単一ファイル構成のプロジェクトの読み込み

Posted 2020-09-11 19:31:26 GMT

ちょっとした内容を単一ファイルに記述し、それをロードして実行させたいことは結構あります。
こういう場合には論理パスを使うのが便利だということを最近発見したので、それについて書きたいと思いますが、その前に一般的な方法も改めて考察してみましょう。

ASDFを使う

ASDFを使うまでもない、という感もあるのですが、Quickproject等、プロジェクトの雛形をさっと作れるツールがあるので、中身が1ファイルしかないといっても対した手間ではないでしょう。
実際Quicklispにも単一ファイル規模のプロジェクトは結構あります。

ただ、quicklispがセットアップできてなかったり、ASDFのシステムがうまく登録されてなかったりで、すったもんだすることは割とあります。

(ql:quickload 'foo)

(foo::main)

みたいなファイルを、lisp --load foo.lisp したりするわけですが、おや結局foo.lispはどこに置けば良いのだろう、などということにもなったりもします。

スクリプト化する

スクリプト実行と親和性の高いCLISPのような処理系では、手軽に#!スクリプトとしてまとめられます。

#!/usr/bin/clisp -norc -q

(ql:quickload 'foo)

(foo::main)

みたいな感じで書いて、実行可能ファイルにしてパスの通った所に置けば良いので、そこそこお手軽です。ただCLISP以外はCLISP程の手軽さは感じられないことが多いかなと思います。

また、スクリプト的に書くのか、slime上でそこそこLisp的に開発するのかの間で逡巡することもままあるかなという印象です。

読み込み時のパス変数を使う

ファイルを読み込んだ時に、*load-pathname*や、*load-truename*でパスが取得可能なので、このパスから色々することも可能です。
残念ながらLispマシン等で使われていたdefsystemがANSI Common Lispで標準化されなかったため、プロジェクトの読み込み方法が処理系ごとに大きく違ってしまっていた、1990年代〜ASDFというdefsystemが普及する2000年代あたりまでは、これらのロード時/コンパイル時パスをあれこれしてどうにか対処することもあったようです。
全体的にパスを計算する手間が面倒になる上、それに起因するバグも多くなる印象です。

論理パスを使う

論理パスでは物理パスとは独立に任意のパスを新規に定義できます。
例えば、ホームディレクトリのlispディレクトリを“lisp:”という論理ホストに設定することが可能です。

これで何が可能になるのかというと、(load "lisp:foo")で、~/lisp/foo.lispをロードすることが可能になるので、“lisp:”以下に置かれたlispファイルをロードするという行為がかなり手軽になります。
また、論理パスに対応したエディタであれば、論理パスでファイルがすぐ開けるのも便利で開発が捗ります。
(なお対応しているエディタはほぼありません)

論理パスの設定

論理パスは、logical-pathname-translationsで直に設定してしまっても良いですが、ホストマシン全体で設定する方法がCommon Lispの標準に用意されているので、その手順に従うと色々楽だったりします。

“lisp:”を設定する場合、SBCLの場合は、“sys:site;lisp.translations.newest”に

;;; -*- lisp -*-
(("**;*.*.*" #.(merge-pathnames 
                (make-pathname :name :wild
                               :type :wild
                               :version :unspecific
                               :directory '(:relative "LISP" :wild-inferiors)
                               :case :common)
                (user-homedir-pathname)))))

のような記述をすれば、

(load-logical-pathname-translations "lisp")

で上記のファイルを読み込むことが可能です。
“sys:site;lisp.translations.newest”が論理パスですが、

(translate-logical-pathname "sys:site;lisp.translations.newest")

で物理パスに変換できるので確認できるでしょう。

以上は、load-logical-pathname-translationsの作法に則った設定ですが、面倒臭ければ、/etc/sbclrc

(setf (logical-pathname-translations "lisp")
      `(("**;*.*" ,(merge-pathnames 
                    (make-pathname :name :wild :directory '(:relative "LISP") :case :common)
                (user-homedir-pathname)))))

のようなものを書いてしまっても良いでしょう。

providerequireと論理パスの組み合わせ

論理パスを設定しておけば、あまり利用することもないrequireprovideの機能を活かすことも可能になります。

上記foo.lispの例であれば、foo.lispの中に、(provide "lisp:foo")と宣言し、読み込まれたら"foo"モジュールが登録されるようにておきます。

読み込みは、

(require "lisp:foo" "lisp:foo")

のように明示的にパスを指定してやります。
明示的にパスを指定するので、loadと大差ありませんが、loadと違い、再度読み込みの防止機能があるので、まあこれはこれで便利なこともあるでしょう。

ちなみにモジュール名を論理パスと同じにすると管理が楽です。

まとめ

単一ファイル構成のプロジェクトの読み込みについて論理パスが活用できる可能性について書きました。
隅に置いやられている論理パスですが、使い様によっては結構活用できそうなので、今後も活用法を探っていきたいところです。


HTML generated by 3bmd in LispWorks Personal Edition 7.1.2

Common Lisp(1984)の仕様の草稿がCHMで公開

Posted 2020-09-06 16:51:49 GMT

1984年に最初の仕様が公開されたCommon Lispですが、仕様は主に電子メールのメーリングリストで議論し、採用する機能を投票で決めたりと時代を先取りしていました。

Spice Lispのマニュアルを土台に叩き台となる仕様をまとめ、議論して、まとめ、というのを繰り返して、Common Lisp the Language(CLtL1)として出版されたのですが、その中間の草稿についてはネット上には資料が公開されていなかったため色々と謎が多かったりもしました。

そんなCommon Lispの草稿ですが、今年の去る五月にComputer History MusiumのSoftware Preservation Groupのページで公開されていたようです。

公開されたのは、

  • Colander Edition (1982-07-29)
  • Laser Edition (1982-11-16)
  • Excelsior Edition (1983-08-05)
  • Mary Poppins Edition (1983-11-29)

の四つで、厳密にいうと他にも草稿はあるようですが、Common Lispの草稿として資料に登場するのは大体この四つです。

どんなことが分かるか

興味深いのは、完成版に近いMary Poppins Editionよりは、最初期のColander Editionかと思いますが、例えば、*macroexpand-hook*は、displaceを導入する目的で導入された、と明記されていたりします。

displaceは主にインタプリタのマクロ展開を速くする機構で、一度展開した展開形を保持するという機構です。
この機能ですが、ANSI CLに至るまでに可搬的に実現するのが困難という結論になり、ANSI CLでは何を目的とした機能なのかの説明もぼんやりしたものになっています。

時系列に並べると

  • CL草稿: displaceのため
  • CLtL1: マクロ展開をキャッシュ化することによってインタプリタ速度の向上に活用できる
  • CLtL2: 当初の目的を果すのは難しいのでデバッグで主に使いましょう
  • ANSI CL: 大域変数なのでまずい使い方をするとコードの解釈が一意でなくなるという注意書き

となるのですが、どんどん非推奨な機能に追いやられていることが分かります。

他、スペシャル変数に耳当てがない等、お馴染の慣習も徐々に確定していったことが分かります。 (ちなみに耳当てをつけるのは投票で可決され、定数には特に飾りを付けない、というのも同じ投票で可決されています)

関連

まとめ

ANSI CL規格だけからは導入の動機が良く分からない機能は結構あるのですが、最初期まで遡ることが可能だと経緯がより鮮明に見えてきます。

現在でも、投票の詳細については資料がオンラインにないのですが、投票の詳細について公開されるとかなり面白いことになると思います。


HTML generated by 3bmd in LispWorks Personal Edition 7.1.2

Lisp₂のマクロはいうほど不衛生でもない

Posted 2020-08-23 15:18:23 GMT

ざっくりした話ですが、Lisp₁のSchemeには衛生マクロがあるが、Common LispのようなLisp₂は、衛生マクロがないので駄目、みたいな意見を持っている人(主にLisp初学者)はそこそこいると思います。しかし、実際のところ、日々Lisp₂のCommon Lispを使っていてリスト操作のマクロが不衛生で困っちゃうということもありません。
欠点を運用でカバーしているのだ、という話もありますが、これが大した運用でもないというのが実感です。

この実際の感覚のあれこれを説明しようと思っても、Common LispのようなLisp₂のマクロ体系とLisp₁のマクロ体系を比較する、ぱっとした方法がないので、実際のところ比較が難しいのですが、両者でも共通している括弧()のレベルから考えてみることにしました。

関数定義の度に新しい括弧を定義する体系を考えてみる

まず、リスト操作のマクロは、Lisp₂とLisp₁とではあまりにも使い勝手が違います。
端的にいってLisp₂のプログラマの感覚でいうと、Lisp₁上のLisp₂のようなリスト操作のマクロは使い物にならないので一切書かないのが安全という感覚だと思いますが、それについては後述するとして、Lisp₂、Lisp₁で共通の機構を考えてみます。
まず、関数/マクロの定義ごとに新しい括弧の種類を定義するとしてみます。

(defun fib (n)
  (if (< n 2)
      n
      (+ (fib (1- n))
         (fib (- n 2)))))

のようなものを

(defun 【】 (n)
  (if (< n 2)
      n
      (+ 【(1- n)】
         【(- n 2)】)))

と定義し、

【10】
→ 55

のように動くというイメージです。

括弧はリード時に確定するので、それ以降のフェイズで上書きする術を提供しなければ衛生的です。
※なお、Common Lispにはリーダーマクロがあり、ユーザーが新しい括弧を定義することが可能ですが、ユーザー定義部分に関してはプログラマに委ねられています。

Lisp₂の関数/マクロ定義は括弧を定義しているのに感覚として近い

関数/マクロごとに新しい括弧を用意してみることを考えてみましたが、Lisp₂は、Lisp₂のプログラマの感覚からすると、()+シンボルという唯一であることが保証されたオブジェクトの組み合わせで機能するため、定義の度に新しい括弧を定義するのに近いものとなります。

上記で定義したの文脈でいうと、(fibという唯一な括弧を新しく定義している、とも考えられます。

つまり、リスト操作でのマクロがどれだけ衛生的かというと、上記表現でいう括弧が再定義されない限りにおいて衛生的ということになるかと思います。

逆に括弧が再定義可能ということであれば、関数呼び出しの記述からして破綻させることが可能なので、衛生マクロであろうと無力です(括弧を保護する仕組みが必要)

なお、(+シンボルの組で括弧であるとした場合、実際にはシンボルはユーザーが通常のプログラミングの範囲で操作するため二点問題が考えられます。

  • シンボルの競合問題
  • プログラムデータが作るスコープでのシャドウイング問題

生成されたプログラムデータに於て、シンボルの競合については、モジュール管理のフェイズでエラーとすることが可能なためプログラマも管理し易いと思いますが、自動生成されるスコープについては管理が難しいと考えられています。

Lisp₂のCommon Lispで具体的な例を挙げると、

(flet ((list (&rest args)
         (apply #'vector args)))
  (list 0 1 2))

のようなコードが自動生成されることを制御する必要がある、ということになりますが、コード生成をしまくるCommon Lispでも実際には問題となることはあまりありません。

これは上述のように、Lisp₂に於ける関数定義では新しい括弧を定義しているような意味合いが強く、変数名と関数名の競合を意識することがないプログラミングスタイルであることが理由だと考えられます。
換言すれば、関数名と変数名が競合しないのがメリットなので、敢えて競合させるようなコードを生成させた挙句に結果として余計な問題に悩んだりしたくないので避けるということかと思います。

関数名と変数名が同一なのがメリットのSchemeにおいて敢えて名前を競合させてデメリットを助長させるようなことはしないのに似ています(もちろんたまにいますが)

(define (foo list args)
  (list args))

リスト操作のマクロでいうと、Lisp₁の場合は、さらに変数名との競合も考慮する必要があります。
加えてマクロが展開された周辺とも名前の競合を考慮する必要がありますが、Lisp₂のプログラマの感覚からすると制御が難しすぎて実質使い物にならないという感想が多いでしょう。
(だから衛生マクロが登場したともいえますが)

コード生成について

Lisp₂のCommon Lispでは、defmacroが単なるリスト生成であることが殆どですが、マクロでなくともユーザーがプログラムでコードを生成するということが手軽に安直に行なわれています。
この場合、生成されるコードは、機械向けの呪文ではなく、人間が書くようなスタイルのコードが生成されることが多い印象ですが、リスト生成に毛が生えた程度でも人間が読め、制御も可能であるようなコードが生成可能であるというのが大きいと思われます。
defmacroのような手書きのコードから一括生成の大量の自動生成のコードまで連続しているというのがポイントです。
Lisp₂以外で、人間が読めるようなコードを安直に生成している文化はあまり目にしたことがないのですが、どうなのでしょうか。

まとめ

上記では、関数の名前と変数の名前が競合する局面について書きました。
Lisp₂のマクロでの変数名の競合は、一時的な変数名を生成したり(gensym)、スコープを作る構文に展開することで簡単にコントロールできるものとされています。
マクロ展開での変数名(識別子)の競合や生成は、メリットともデメリットともされていて、SchemeでもLisp₂でメリットとされて来たことを取り込もうとする等、人間がコントロールする範囲のものと捉えられている節もあるので今回は省いています。

また、Lisp₁上でも、識別子を展開するのではなく、マクロ定義時に関数オブジェクトを取り込み、それをマクロ展開してしまうことによって、名前の競合を起さないテクニックもあるようです。
これでも良さそうですが、コードの字面とオブジェクトとで乖離してしまうので管理が難しそうです。

結局のところ関数名というのは変数名と違って大域なことが殆どですが、これは大域的な名前を操作してプログラミングするという人間の慣習を反映しているのでしょう。
Lisp₂はこの点とも親和性が高いと思います(たまたま先入観が反映された感は強いですが)


HTML generated by 3bmd in LispWorks Personal Edition 7.1.2

Interlisp-DがOSSになって帰ってきた!

Posted 2020-08-20 00:30:51 GMT

ここ最近Interlisp-D復活のプロジェクトが活発でOSS化が進んでいるらしいというのは眺めていましたが、いつの間にやら仮想Interlisp-D環境であるmedleyが最近のOS上で動くようになっているようです。

以前もmedleyは古いOSを用意すれば動かせたりしましたが、最近のOS上でも動かせるというのは非常に嬉しい。

導入

下記はlinux x86_64で導入する場合です。 clang等が必要ですが適宜インストールしましょう。

git clone https://github.com/Interlisp/maiko.git

cd bin export PATH=.:$PATH

makeright x

上記でビルドが完了すると、maikoディレクトリの直下のマシンアーキテクチャ名のディレクトリ中にldexが生成されていますので、medleyのsysoutイメージを指定して起動できます。

./linux.x86_64/ldex full.sysout

sysoutイメージは、interlisp.orgに記載のあるRon’s Interlisp dropboxでも数種類配布されているので、適宜利用してみるのも良いでしょう。

とりあえず、手元では、古いmedleyで動かしていたイメージが起動しました。

maiko-2020

今後の展開

OSS化されたということで、処理系のソース等も読めるようになるのかもしれません(既に読める?)
個人的にはLOOPSを触ってみたいと思っています。

関連


HTML generated by 3bmd in LispWorks Personal Edition 7.1.2

S式は前置記法でなくても良い

Posted 2020-07-28 21:59:39 GMT

S式といえば、逆ポーランド記法(前置記法)という印象がありますが、肝要なのはS式というデータでコードを記述することなので、特に前置でなければいけないということもない筈です。

そもそも、点対リストの記法は中置じゃないかと思うのですが、どうなのでしょう。

(a . d)

前置であれば、

(. a d)

となりそうですが、これでも特に問題はなさそうに思えます。

ちなみにPrologでは、[a|d]というリスト表記は、'.'(a,d)の糖衣構文らしく'.'は前置記法ですが、Lispに由来したものなのかどうなのか。

% az-prolog
%
| ?-'.'(a,d)=[a|d].
yes

点対リストの発展形

点対リストのドットは中置ではないかと書きましたが、Plasma(1974)には、この点対リストの記法を発展させたような記法(x op y)をメインに使用します。

なお、私個人の解釈では、Hewitt先生は、点対リストのドットをオペレーターとして解釈し、点対リスト記法を発展させているように見えるのですが、Plasmaの文献を眺めていてもドットを発展させたという記述は見付けられていないので、完全に独自解釈かもしれません。予めご了承下さい……。
少なくとも、リストの二番目に特別な記号があれば○○するというような構文の作り方ではない気がするのですが。

メッセージ送信

Plasmaではメッセージ送信は、(A <= M)と記述し、Lispでいう関数呼び出しに相当します。
矢印は逆転して記述することも可能で、(M => A)でも可です。
また、(A <= [x y z])の省略形はLispの関数フォームのように、(A x y z)と書けます。 この矢印がLispの点対リストの.に相当します。
なお、[x y z]は配列です。

四則演算

四則演算の+,-,*,/等もまた特別扱いされます。

(1 + 1) 
→ 2

Common Lispで()を再定義するとしたらこんな感じでしょうか

(progn
  (flet ((rdseq (srm chr)
           (let ((xpr (read-delimited-list #\] srm T)))
             (if (= 3 (length xpr))
                 (let ((op (cadr xpr))
                       (x (car xpr))
                       (y (caddr xpr)))
                   (case op 
                     ((list 'define x y))
                     ((=) 
                      (list x y))
                     (otherwise (coerce xpr 'vector))))
               (coerce xpr 'vector)))))
    (set-macro-character #\[ #'rdseq))
  (set-syntax-from-char #\] #\))
  ;;;
  (flet ((rdparen (srm chr)
             (declare (ignore chr))
             (let ((xpr (read-delimited-list #\) srm T)))
               (if (= 3 (length xpr))
                   (let ((op (cadr xpr))
                         (x (car xpr))
                         (y (caddr xpr)))
                     (case op 
                       (<= (cons x (coerce y 'list)))
                       (=> (cons y (coerce x 'list)))
                       ((+ - * / < > =< >=) 
                        (list op x y))
                       (otherwise xpr)))
                 xpr))))
      (set-macro-character #\( #'rdparen)))

(list 
 (list <= [42])
 (list 42)
 (list 0 1 2 3)
 ([0 1 2 3] => list)
 ([(42 + 69) (42 - 69) (42 * 69) (42 / 69)] => list))((42) (42) (0 1 2 3) (0 1 2 3) (111 -27 2898 14/23))

ちなみに、(の再定義は危険なので、全角括弧ででも試した方が良いかもしれません……。

定義構文

関数(アクタ)定義は、配列+≡の中置です。
Schemeのように、(define fcn (lambda (arg ...) ...))パタンと、左辺?に引数も記述する(define (fcn arg ...) ...)パタンがあります。
思えば、Lisp 1.5の頃からこの二種類は存在するようなのですが、大元はLisp 1.5なのでしょうか。

Plasmaでは下記のように書けます。 (なお、Plasmaにlambdaはありません)

[tak ≡ (lambda (x y z)
         (if (not (x > y))
             z
             ([([(x - 1) y z] => tak)
               ([(y - 1) z x] => tak)
               ([(z - 1) x y] => tak)] => tak)))]

[(tak x y z)(if (not (x > y)) z ([(tak (x - 1) y z) (tak (y - 1) z x) (tak (z - 1) x y)] => tak))]

([18 12 6] => tak) → 7

Common Lispで再現してみるなら、を中置のdefineと考え、二種のパタンそれぞれに展開するマクロにでもなりそうです。

(defmacro define (name expr)
  (etypecase name
    (cons `(defun ,(car name) (,@(cdr name))
             ,expr))
    (symbol 
     `(progn
        (declaim (function ,name))
        (setf (fdefinition ',name) ,expr)))))

まとめ

点対リストの記法の発展形をPlasmaを源流と捉えてつらつら書いてみましたが、点対リストの形式(x op y)には、未だ開拓されていない可能性があるようなないような。

(x op y)と書けると一体何が嬉しいのか、という気もしますが、ではLispがこれまで(a . d)と書いてきて一体何が嬉しかったのか、と思わないでもないです。

Hewitt先生の記法のアイデアは中置のS式に限らず結構面白いものが多いので、今後もちょこちょこ紹介していきたいと思います。
(絵文字や上付き/下付きのS式等々……)

参考

  • A PLASMA PRIMER / Brian C. Smith, Carl Hewitt (1975)


HTML generated by 3bmd in LispWorks Personal Edition 7.1.2

ストリームをreadしてその文字列表現を取り出す

Posted 2020-07-26 16:49:52 GMT

ストリームを読み込んで、一つのS式を得るにはreadを使えば良いのですが、その文字列表現を得るのは結構面倒という話をSNSで見掛けました。

いや、with-output-to-string等を使えばreadの結果を文字列として取り出すのは簡単じゃないかなと思ったのですが、これでは上手く行かない状況があるのかもしれません。

;;; 単純な例
(setq *print-circle* T)

(with-output-to-string (out) (with-input-from-string (in "#0=(0 1 2 3 . #0#)") (print (read in) out))) → " #1=(0 1 2 3 . #1#) "

例えば、存在しないパッケージを含んだ表現を読み込むとエラーになる場合であったり、

(with-output-to-string (out)
  (with-input-from-string (in "(foo:bar baz)")
    (print (read in) out)))
!! Error: Reader cannot find package FOO.

コメントを読み飛ばしたくない場合であったり、

(with-output-to-string (out)
  (with-input-from-string (in "(foo bar #|baz|#)")
    (print (read in) out)))
→ "
(FOO BAR) "

しかし、これらはreadの挙動ではないので、readした結果の文字列ではない気がしますが……。

とはいえ、Lispのプリティプリンタ等を作成する場合等でCommon Lispのreadをうまいこと流用しつつ都合良くreadの標準の挙動を越えた結果が欲しい場合もあります。

make-echo-stream というマイナー機能

上述のように、コメントを読み飛ばしたくない場合や、存在しないパッケージは無視してシンボルのトークンとして読み込みたい場合、元ストリームのecho-streamを作成した状況で、*read-suppress*をTにしてreadを動かし、echo-streamに軌跡を出力するという技が使えます。

具体的には、

(defun read-to-string (&optional (stream *standard-input*)
                                 (eof-error-p T)
                                 eof-value
                                 recursivep
                                 (junk-allowed T))
  (with-output-to-string (outstring)
    (let* ((stream (make-echo-stream stream outstring))
           (*read-suppress* junk-allowed))
      (read stream eof-error-p eof-value recursivep))))

こんな感じのものを作成します。

(setq *print-circle* nil)
(dolist (xpr '("#0=(0 1 2 3 . #0#)"
               "(foo:bar baz)"
               "(foo bar #|baz|#
;; comment

)")) (with-input-from-string (in xpr) (print (read-to-string in)))) ▻ ▻ "#0=(0 1 2 3 . #0#)" ▻ "(foo:bar baz)" ▻ "(foo bar #|baz|#;; comment ▻ ▻ )" → NIL

解説

まず、make-echo-streamですが、read系の関数が読み取ったものを出力するというストリームです。エラーログを出力する場面等で便利な気はしますが、結構マイナーな機能です。
HyperSpecでも読み取ったものを文字列として返す例が紹介されています。

次に*read-suppress*ですが、元来これは、#-#+を処理するための機能であり、Lispのトークンとして読み込めるレベルのものを適切に無視することが可能です。

これらを組み合せるとreadエラーは回避しつつLispのトークンとして読み込み、文字列として出力することが可能です。

参照


HTML generated by 3bmd in LispWorks Personal Edition 7.1.2

束縛部を外から与えるフォーム

Posted 2020-07-23 17:31:13 GMT

bit誌1975-01月号 「連載LISP入門 (13) Backtrack法とLisp」にはbindqというフォームが出てきます。
(1974年から1975年にかけてのbit誌での後藤英一先生のLisp連載)

HLISP独自のようですが、M式で書くと、

bindq[x;y;form]

のような形式でCommon Lispでいうprogvに似た形式です。 qquoteqですが、formがクォートされるので、Common Lispで実装すると、

(defmacro bindq (vars vals form)
  `(let (,@(mapcar #'list 
                   (eval vars)
                   (eval vals)))
     ,form))

となります。

(let ((x 0))
  (bindq (list 'x 'y)
         (list 'x 42)
    (progn (list x y))))(0 42)

という動作ですが、クォートされた変数名がレキシカル変数を捕むという表記はCommon Lispの作法からすると気持ち悪いかもしれません……、と書いているうちに、HLISPはレキシカルスコープじゃないし、要するにprogvではないかとどんどん思えてきました。

この記事を書き始めたときには、とりあえずレキシカルスコープでprogv的なもの、ということを考えていたのですが……、とりあえず、このまま続けることにします。

スコープを作るフォームの束縛部のデータ

前述bindqや、progvではフォームの束縛部のデータ型はリストでした。
letでも((var val))はリストですが、クォートされていて実行時に生成されるリストではありません。

上述で実装したbindqは実行時に評価されそうな見た目ですが、マクロ展開時にフォームは固定されます。
マクロ展開時までに確定できれば変数でも大丈夫ですが、評価フェイズによってはエラーになったりするので、Common Lispの構文作法としてはあまり良くないでしょう。

(defvar *vars* '(x y))
(defvar *vals* '(0 42))

(bindq *vars* *vals* (list x y))(0 42)

まあでも一つの可能性としては面白いかもしれません。

Plasmaでの束縛部のデータ

リスト以外の束縛部のデータといえば、最近だとClojureが配列を採用していますが、古くは、Plasma(1974)があります。
Plasmaでは、sequenceという配列が[]で表記され、setという集合が{}で表記されていますが、これらが、束縛部で使われます。

(let 
   {[x = 42] [y = 0]}
  ...)

(labels {[fib ≡ (cases (≡> [0] 0) (≡> [1] 1) (≡> [=n] (fib (n - 1) + (fib (n - 2)))))]} ...)

束縛部全体は集合で表記され、変数名と値の対は配列で表記されます。

面白いのが、束縛部を変数として与えることが可能なところで、

[math-definitions = 
    {[factorial ≡ ..]
     [fibonacci ≡ ..]
     [cosine ≡ ..]}]

(labels math-definitions body)

という記述が可能とされています。
上記では、labelsのスコープ内に導入しますが、大域環境に定義するenterという機能もあります。

(enter math-definitions)

Plasmaはレキシカルスコープな筈ですが、この辺り実際レキシカルスコープで実現するのは難しそうな機能です。
実際どういう実装がされていたのかは謎……。

ちなみに、Common Lispで真似るならこんな感じでしょうか。
マクロ展開時までに束縛部のデータが確定していれば機能しますが、そうでない可能性を考えると脆弱な仕組みということが分かります。

(progn
  (flet ((rdset (srm chr)
           (let ((tab (make-hash-table :test #'equal)))
             (dolist (elt (read-delimited-list #\} srm T) tab)
               (if (and (typep elt '(vector T 3))
                        (member (elt elt 1) '(= ≡)))
                   (setf (gethash (elt elt 0) tab)
                         (elt elt 2))
                   (setf (gethash elt tab)
                         T))))))
    (set-macro-character #\{ #'rdset))
  (set-syntax-from-char #\} #\))

(flet ((rdseq (srm chr) (coerce (read-delimited-list #\] srm T) 'vector))) (set-macro-character #\[ #'rdseq)) (set-syntax-from-char #\] #\)))

(defpackage plasma (:use) (:export let labels))

(defmacro plasma:let (binds &body body) (let ((binds (eval binds))) (check-type binds hash-table) `(let ,(loop :for var :being :the :hash-keys :of binds :using (:hash-value val) :collect `(,var ,val)) ,@body)))

(plasma:let {[x = 42] [y = 0]} (list x y)) ===> (let ((x 42) (y 0)) (list x y))

(defvar *binds* {[x = 42] [y = 0]})

(plasma:let *binds* (list x y))(42 0)

まとめ

束縛部を実行時データとして与えるというのは動的すぎるとしても、コンパイル時までに与えるというのは活用できる局面があったりするかもしれません。

実際の所、Common Lispではリード時までに与えるというのはたまにありますが、declare等のコンパイラへの指示等が殆どで、束縛部を後で与えたいということは殆どないとは思いますが。

(defvar *bindspec* '((x 42) (y 0)))

(let #.*bindspec* (list x y))(42 0)

参考

  • A PLASMA PRIMER / Brian C. Smith, Carl Hewitt (1975)


HTML generated by 3bmd in LispWorks Personal Edition 7.1.2

暗黙のprognならぬ暗黙のlet

Posted 2020-07-05 21:02:45 GMT

古くからボディ部に複数の式を取れることを暗黙のprognといいますが、別にletでも良いんじゃないかなと思って試してみました。

(defpackage let 
  (:use)
  (:export cond lambda))

(defun implicit-let-form-p (form) (member (car form) '(let let*) :test #'string-equal :key #'princ-to-string))

(defmacro let:cond (&rest clauses) `(cond ,@(mapcar (lambda (c) (if (implicit-let-form-p (cdr c)) `(,(car c) ,(cdr c)) c)) clauses)))

(defmacro let:lambda ((&rest args) &body clauses) `(lambda (,@args) ,@(if (implicit-let-form-p clauses) `(,clauses) clauses)))

(defun fib (n) (let:cond ((< n 2) let ((f n)) f) (T let ((f1 (fib (1- n))) (f2 (fib (- n 2)))) (+ f1 f2))))

(fib 10) → 55

(mapcar (let:lambda (x) let ((y (* 2 x))) y) '(0 1 2 3))(0 2 4 6)

ネストが一つ減らせる位しか御利益がないですが、大抵の言語のブロックは、変数のスコープと複数フォームを纏める機能が合体しているので、prognまで分解されずに、letがビルディングブロックん基本なのかなと思ったり思わなかったりです。

ちなみに、どこかでみたことがある気がしましたが、Conniverのcdefunのボディ部での“AUX”という記述が今回の暗黙のletそのままでした。
(完全に忘却していた……)

("AUX" (x y z) ...)

のように単体フォームでも使えるようですが、詳細は調べきれていません。
もしかしたら、Conniverは暗黙のprognから進んで、暗黙のletだったのかも?

更新:※Conniverのマニュアルで確認してみたところ、フォームの第二要素が予約語“AUX”であった場合、第三要素はprog変数宣言となる、ということみたいです。
つまり暗黙のprogということみたいですが、暗黙のletみたいなものといえるでしょう。

Conniverの“AUX”は、MDLが由来のようですが、受け継いたCommon Lispのように引数部に記述するのではなく、ボディ部に記述するというのが面白いですね。

ちなみに暗黙のprognとは

Lispでは値を返すスタイルが古くから基本となっていますが、副作用目的で複数の式をまとめる記述としてprogprog2というフォームも古くから存在しました。

任意の複数の式をまとめるフォームということで落ち着いたのがprognですが、SDS 930 LISPあたりが最初のようです。

prognは便利だったのか、ついでにcondや、lambdaの既存のフォームのボディ部で、prognのように複数の式を取れるように拡張されました。 これを暗黙のprognと呼びますが、元は1つの式しか記述することができなかったため、暗黙のprognという言葉がうまれ後世まで伝わってしまったのでしょう。

(lambda (x) x)  
↓
(lamba (x) (progn x x x))
↓
(lamba (x) x x x)

今となっては何故1つの式しか元は記述することができなかったのかと思ったりもしますが、複数の式を含むということは、値を返さない式を含む(副作用目的の式を含む)ということになるので、元々のLISPは純粋な関数を指向していたともいえます。
もちろん手続的に記述するprogもあったりはするのですが、元々はsetq等の代入もprogの中でしか使えませんでした。


HTML generated by 3bmd in LispWorks Personal Edition 7.1.2

真のLispエディタでは論理パスが使える

Posted 2020-06-28 19:55:59 GMT

論理パスを設定しておくと便利なこともあるので、良く使うlispファイル置き場のディレクトリ等に“lisp:”なんていう論理パスを設定したりしています。
“~/lisp” であれば下記のように設定可能です。

(setf (logical-pathname-translations "LISP")
      `(("*" ,(merge-pathnames 
               (make-pathname :name :wild :directory '(:relative "LISP") :case :common)
               (user-homedir-pathname)))))

(load "lisp:foo")

で、“~/lisp/foo.lisp”がロードできたりするのが便利です。

quicklispなども論理パスを設定しておけば、

(load "quicklisp:setup")

でロードできたりしますが、まあ便利な時は便利でしょう。

ちなみに初期化ファイルを読み込まない状態で、論理パスをロードする仕組みがCommon Lispには、load-logical-pathname-translationsとして用意されていますが、処理系によって記述方法はまちまちです。

Lispエディタで論理パスは使えるか

そんな日々でしたが、普段から論理パスを使っているとエディタでファイルを開く際にも使いたくなります。
論理パスでファイルを開けたりしないもんかなと、試しにLispWorksのエディタのFind Fileで論理パスで指定してみたところ、普通に開けてしまいました。

素直に開けてしまうのが逆に不思議だったので、Find Fileのソースを眺めてみましたが、文字列がprobe-fileに渡されるので、ここで実ファイルにマッピングされる様子。
当然ながら、Common Lisp製のエディタはCommon Lispのパス処理の関数を使うわけで、意図的かどうかは扨措き、エディタも論理パスを処理できちゃうみたいです。

ちなみに、SymbolicsのZmacsではどうなのかなと思い、論理パスを設定して試してみましたが、Find Fileで普通に論理パスが使えました。
こちらは様々なOSが混在した環境で論理パスを設定していた時代に実際に使われていたと思うので、元からサポートしているのでしょう。

論理パスは、物理的にはばらばらに存在するファイルをツリー状にまとめたりがLisp内で簡単にできます。
色々制限はあるのですが、使い方次第では便利に使えるかもしれません。

まとめ

真のLispエディタでは論理パスが使える。


HTML generated by 3bmd in LispWorks Personal Edition 7.1.2

LispWorks 7.1.2 Personal Edition リリース

Posted 2020-05-21 03:40:49 GMT

LispWorksは商用のCommon Lisp処理系で、お試し版としては、Personal Editionというものがあるのですが、長らくアップデートされていませんでした。
前回リリースされた LispWorks 6.1.1 Personal Edition が、2013-01-19のリリースだったので実に7年ぶりのリリースとなります。

今回リリースされたPersonal Editionのプラットフォームは、x86系とArm。 これら以外のプラットフォームでもLispWorksは稼動しますが、x86系とArm以外を使っている人は稀だと思うので、問題になることはないでしょう。
なお、Personal Edition以外のLispWorksの各エディションは申請すれば一ヶ月評価できるので、マイナープラットフォームの方々でも申請すれば購入前に評価は可能です。

これまで商用処理系の評価版というとLispWorksもFranzのAllegroも32bit版限定でしたが、今回のLispWorks 7.1.2 Personal Editionでは64bit版も配布されています。
32bit環境の方が特殊になりつつある昨今なので当然といえば当然ですが、嬉しいところですね。

LispWorks 7.1.2 Personal Editionの制限

  • 利用メモリの制限
  • 連続起動時間5時間
  • 初期化ファイルが読み込めない

等々は過去のバージョン同様の制限となっています。
5時間の制限と初期化ファイルを手動で読み込ませる必要があることについては、大して苦労することはないのですが、常用するには利用メモリの制限が結構厳しい。
例えば、ironclad等はビルドに結構負荷が掛る方ですが、こういうのは途中で終了となってしまいます。 コンパイルできる範囲でちまちまfaslを生成、処理系を立ち上げ直してロード、という作戦で乗り切ることも場合によっては不可能ではありませんが結構手間ですね。

LispWorks 7.1.2 Personal Editionの使われ方様々

LispWorksを評価するのが本来の目的かと思いますが、意外に大学の授業等での利用が結構あるようです。

PAIPの題材のような古典AIの授業の処理系として活用されているようですが、GUI付きのIDEとしてワンクリックで起動し利用できるので、確かにCommon Lisp入門や学習用途には結構良いと思います。

まとめ

このブログはLispWorksのエディタで書いて、LispWorksからサーバにアップロードという仕組みで更新していますが、今回のブログはLispWorks 7.1.2 Personal Editionで書いてみました。

ちなみに、標準の初期化ファイルを読み込ませるには、リスナーから、

(load *init-file-name*)

とすると楽です。

LispWorksのリスナーでは最外の括弧を記述しなくても良いので、

load *init-file-name*

でもOK。 M-iや、M-C-iで補完も可能なので、load *ini位までの入力で済みます。


HTML generated by 3bmd in LispWorks Personal Edition 7.1.2

CLでSRFI 173

Posted 2020-04-18 20:41:27 GMT

CLでSRFI、今回移植したのは、SRFI 173: Hooksです。

srfi-173は、古典的なLispでお馴染の機構であるフック機構を実現しようというものです。

移植について

参照実装をコピペしただけです。
元がシンプルなので特にソースコードを変更する必要もありませんでした。
テストコードにも手を加えないことにしようかとも思いましたが、テストケースが数個だったのでfiveamの形式にササッと書き直しました。

動作

advice機構のように関数名(シンボル)に関数をぶらさげるのではなく、フックオブジェクトに関数をどんどん登録していきます。
各フックの起動順は不定。フック起動結果の値も不定。
リストに関数をプッシュしていって後で順に呼び出しするのとあまり変らない使い勝手です。

(defvar *hook* (make-hook 0))

(defun one () (print 1)) (defun two () (print 2)) (defun three () (print 3))

(progn (hook-add! *hook* #'one) (hook-add! *hook* #'two) (hook-add! *hook* #'three))(#<Function three 40D005342C> #<Function two 40D00533C4> #<Function one 40D005335C> #<Function three 40D005342C> #<Function two 40D00533C4> #<Function one 40D005335C>)

(hook-run *hook*) ▻ ▻ 3 ▻ 2 ▻ 1 → nil

導入

Ultralispに登録してみたので、

(ql-dist:install-dist "http://dist.ultralisp.org/")

してあれば、

(ql:quickload :srfi-173)

でインストール可能です。


HTML generated by 3bmd in LispWorks 7.1.2

CLでSRFI 145

Posted 2020-04-13 20:47:55 GMT

CLでSRFI、今回移植したのは、SRFI 145: Assumptionsです。

srfi-145はざっくりいえば、Common Lispのassertに相当するもので、定義はassume一つだけです。
Common Lispのassertは再起動等のアクションがありますが、assumeにはありません。

移植について

assumeのようなものを記述メリットのようなものが色々解説されていますが、賢いコンパイラなら最適化するかもしれない、系の記述が殆どで、assume自体に組込まれた機構で何かする、というわけではありません。

assumeが記述されることによってコンパイラへの最適化やエラーチェックのヒントが増える、という話のようです。

色々書いてあるので、srfi-145で可能性として示されていることが実際に実現できないかをSBCLをメインに試してみました。
Common Lispでも大体似たようなことはできますが、srfi-145の例のような書き方ではないので、実現するにはコンパイラに色々仕込む必要があるようです。

Schemeのコンパイラにsrfi-145が記述しているような可能性を実現している/する可能性のあるコンパイラってあるんでしょうか(なさそう)

動作

(assume (= 1 1) "1 = 1")
→ nil

(assume (= 1 2) "1 = 1") >> invalid assumption: (= 1 2) >> 1 = 1

導入

Ultralispに登録してみたので、

(ql-dist:install-dist "http://dist.ultralisp.org/")

してあれば、

(ql:quickload :srfi-145)

でインストール可能です。


HTML generated by 3bmd in LispWorks 7.0.0

CLでSRFI 115

Posted 2020-04-10 21:00:30 GMT

CLでSRFI、今回移植したのは、SRFI 115: Scheme Regular Expressionsです。

srfi-115は、S式で記述する正規表現で、その表現形式は古くからあるThe SRE regular-expression notation記法を軸にしたものです。
作者のAlex Shinn氏は、IrRegular ExpressionsというS式正規表現のライブラリを作成していて、大体そのサブセットがsrfi-115としてまとまったようです。

Common Lispへの移植は、ドラフト時の2013年に一度試してみたのですが、さすがにドラフトだと結構変更があるようなので、ファイナルまで落ち着くまで様子見してたら7年位経過していました。

移植について

参照実装をコピペしただけに近いですが、参照実装には、regexp->sre等の便利ツールが含まれていません。
また仕様自体も核と拡張部分にわかれていますが、参照実装は、核の部分のみのようです。
ドラフトの時はほぼIrRegular Expressionsと同じようなものでしたが、合意が取れなさそうなところはどんどん削って核にしてしまい、残りは拡張部分となったのでしょうか……。

実用面では、IrRegular Expressionsの方が便利なので、Common Lispへの移植し甲斐があるのはIrRegular Expressionsの方でしょう。

ライブラリのサブセットを仕様として定義した例はCommon Lispにも多数ありますが(loopformat等)、中途半端なことになりがちな気がします。

動作

(regexp-search '(w/nocase "foobar") "abcFOOBARdef")
→ #<Regexp-Match 4020002B23> 

(regexp-replace "n" "banana" "k") → "bakana"

(regexp-replace-all '("aeiou") "hello world" "*") ;; or (regexp-replace-all '(or "a" "e" "i" "o" "u") "hello world" "*") → "h*ll* w*rld"

(regexp-split "a" "banana")("b" "n" "n" "")

(regexp-extract '(+ numeric) "192.168.0.1")("192" "168" "0" "1")

導入

Ultralispに登録してみたので、

(ql-dist:install-dist "http://dist.ultralisp.org/")

してあれば、

(ql:quickload :srfi-115)

でインストール可能です。

その他

Common LispにSchemeのコードを移植する際に、どうしようかなと悩むのが、:をシンボル名として使うにはエスケープしなければいけないことだったりするのですが、今回は、:$に置き換えました。
しかし、:をエスケープして\:と書いてもSchemeでは問題ないですし、コードの共用という面では別の文字に置き換えたりせずに、\でエスケープの方が良いかもしれません。

S式正規表現仲間

Common LispでS式正規表現だと、cl-irregsexpというのがあります。
IrRegular Expressionsも似たような名前ですが、なんか付けたくなるような名前なのでしょう。
Uncommon Lisp(R3RS Scheme)系の命名に似てますね。


HTML generated by 3bmd in LispWorks 7.0.0

CLでSRFI 172

Posted 2020-04-05 21:25:09 GMT

CLでSRFI、今回移植したのは、SRFI 172: Two Safer Subsets of R7RSです。

srfi-172の概要ですが、サンドボックス環境の構築を目的としたサブセットの提案で、副作用手続きあり版(srfi 172)となし版(srfi 172 functional)の2つがあります。
(srfi 172 functional)はざっくりいうと!手続きが含まれていないものという感じです。

Common Lispへの移植の際に参照実装には存在するstring->symbolが仕様の方には見当たらず、symbol->stringと対にならないので報告してみたところ、シンボルがGCされない処理系を考慮して入れていないので、参照実装のミスとのことでした。

安全指向のサンドボックスなので、GCを狙った攻撃等に配慮しているということなのでしょう。

移植について

これまで移植したsrfiをベースにまとめてみましたが、100番台以降に改善版が提案されているような古いsrfiが多いので、そのうち新しいsrfiに置き換えたいところ。

導入

Ultralispに登録してみたので、

(ql-dist:install-dist "http://dist.ultralisp.org/")

してあれば、

(ql:quickload :srfi-172)

でインストール可能です。

その他

最近のsrfiはgithubにコードや仕様が置かれていますが、githubのイシューを登録するのか、srfiのメーリングリストにイシューを投げるのか若干謎でした。
結局今回は両方に登録しましたが……。


HTML generated by 3bmd in LispWorks 7.0.0

Practical Scheme 20周年おめでとうございます!

Posted 2020-04-02 15:44:00 GMT

Practical Scheme サイト20周年おめでとうございます!

といっても実は半年過ぎてしまっていたようなのですが……。

しばらく前から準備していた Schemeのページ をぼちぼちアナウンスすることにする。  
今はまだ、公開できそうなSTkの拡張モジュールを置いておくだけだが、 将来はいろんな洗脳ドキュメントも用意して、Scheme言語布教の総本山とするのだはっはっは。  
ライブラリさえ揃えば、SchemeもPerlに遜色無い使い勝手になると思うんだよな。 

Practical Scheme と日本のLispコミュニティ

現在の日本のLispコミュニティで目立った活動をしているところといえば、Shibuya.lisp の月一のミートアップや、不定期開催の関西Lispかと思いますが、 Practical Schemeが存在しなければ、約十年前あたりのプログラミング言語ブームの時に Shibuya.lisp がそこそこの規模で立ち上がることはなかったのではないかと思います。

当時のShibuya.lisp立ち上がりの背景には、GaucheNight(2007) 及び gauche.night(2008) の参加者グループのコミュニティ立ち上げへの手応えみたいなものがあったと思いますが、その地盤を固めていたのは、Practical SchemeWiLiKiでした。

この二十年で色々なLisp系サイトが立ち上がっては消えていきましたが、二十年間安定した基盤として維持され続けてきたというのは、やはり凄いです。
今後も末永くPractical SchemeのコンテンツやWiLiKiを利用させて頂けると嬉しいです。


HTML generated by 3bmd in LispWorks 7.0.0

Lisp Pointersを読め!

Posted 2020-03-31 17:46:13 GMT

ACM Digital Library が2020-06-30まで無料だそうです。

この機会にLisp系で読んでおきたいお勧めといえば、ACM SIGPLAN Lisp Pointers でしょう。

Lisp Pointers は1987年から1995年までのLisp会報誌といった感じのものです。

  • Lispのプログラミング技法紹介
  • エッセイ
  • 処理系紹介
  • 開発環境紹介
  • 書評
  • ANSI Common Lisp 規格進捗報告

等々、内容が濃くて面白い読み物です。

幸か不幸か1995年あたりから古典的なLispはそれほど進歩がありませんので、今でも活用できるような内容も多いと思います(マシンパワーの違いこそあれ)

当時はエキスパートシステムの組み込み言語や、構文拡張等で需要が高かったのか、コードウォーカーの記事がそこそこあるのが、特徴かもしれません。
(Richard C. Waters、Pavel Curtis、Bill van Melle各氏の記事)
古典マクロのコードウォーカー入門記事としては貴重かもしれません。


HTML generated by 3bmd in LispWorks 7.0.0

CLでSRFI 169

Posted 2020-02-19 20:07:29 GMT

先日久々にSRFIをCommon Lispに移植してみてコピペ移植もなかなか楽しいというのを思い出してきたので、また移植してみました。

今回移植したのは、SRFI 169: Underscores in numbersです。

srfi-169の概要ですが、Python、Ruby、C#、Java 7以降ように数値の桁区切りに_を使えるようにするという拡張です。

移植について

オリジナルはリーダーの変更ですが、どうにかリードテーブルをいじる程度で動かせました。
具体的には、数字と+-をマクロ文字にしてしまって、srfi-169のリーダーで読み直すという戦略です。
隅をつつけば、どこかの挙動に影響がある可能性もありますが、まあ良いでしょう。

(setq *readtable* srfi-169:srfi-169-syntax)

'(0123 0_1_2_3 0_123 01_23 012_3 +0123 +0_123 -0123 -0_123 1_2_3/4_5_6_7 12_34/5_678 0_1_23.4_5_6 1_2_3.5e6 1_2e1_2 #b10_10_10 #o23_45_67 #d45_67_89 #xAB_CD_EF #x789_9B_C9_EF #x-2_0 #o+2_345_6)(123 123 123 123 123 123 123 -123 -123 123/4567 617/2839 123.456D0 1.235D8 12000000000000 42 80247 456789 11259375 32373459439 -32 10030)

ちなみに数値の区切りにアンダーバーを許す程度の簡易的な実装であれば、

(let ((stdrt (copy-readtable nil)))
  (defun read-underscores-in-numbers (stm chr)
    (check-type chr character)
    (check-type stm (satisfies input-stream-p))
    (unread-char chr stm)
    (let ((*readtable* stdrt))
      (let ((thing (read stm T nil T)))
        (typecase thing
          (symbol
           (read-from-string
            (remove #\_
                    (string thing))))
          (T thing))))))

(map nil (lambda (c) (set-macro-character c #'read-underscores-in-numbers T)) "+-0123456789")

(list 0123 0_1_2_3 0_123 01_23 012_3 +0123 +0_123 -0123 -0_123 (+ (- 0) -123))(123 123 123 123 123 123 123 -123 -123 -123)

程度でも実現できそうです。

導入

Ultralispに登録してみたので、

(ql-dist:install-dist "http://dist.ultralisp.org/")

してあれば、

(ql:quickload :srfi-169)

でインストール可能です。

まとめ

リードテーブルも結構柔軟なので割と色々できてしまいますが、Common LispもRacketのようにリーダーの差し替えができたら良いのになと思うことはあります。


HTML generated by 3bmd in LispWorks 7.0.0

CLでSRFI 175

Posted 2020-02-16 14:16:07 GMT

九年ほど前からSchemeのSRFIをCommon Lispに移植する遊びをしていますが、久々にコピペ移植してみました。
前回SRFI 118を移植したのは、2005-01-02のようなので、実に五年ぶり。

今回移植したのは、SRFI 175: ASCII character libraryで、ASCIIを扱うライブラリのようで、現時点でファイナルになっているものでは一番番号が大きいものです。

導入

Ultralispに登録してみたので、

(ql-dist:install-dist "http://dist.ultralisp.org/")

してあれば、

(ql:quickload :srfi-175)

でインストール可能です。

動作

ASCIIに関して操作したいことは大体網羅されているので、必要な時には便利に使えるのではないでしょうか。

(ascii-downcase #\G)
→ #\g 

(ascii-alphabetic? #\1) → nil

(remove-if #'ascii-whitespace? "foo bar baz") → "foobarbaz"

まとめ

SRFIの移植については、Scheme→Common Lispなコンパチレイヤーがあると楽なのでボチボチ作ってみたりしていますが、このあたりも作り込むとコピペが捗りそうです。

このrnrs-compatでは関数とマクロで変換していますが、トランスレータでの一括変換も試してみたいところ。


HTML generated by 3bmd in LispWorks 7.0.0

Ultralisp使ってみた

Posted 2020-02-11 19:14:11 GMT

今年は移植したSRFIでもQuicklispに登録してみようかなと思って、Quicklispに三つ四つ登録してみましたが、「登録するは良いけどユーザーいるの?(大意)」という質問がありました。
SRFIのCommon Lispへの移植は90近くあるのですが、いうまでもなくどれも誰得なものなので、まあそうだよなーなど思ったりしていましたが、こういう誰得なものにはUltralispが合っていると思うと教えてもらったので、Ultralispに登録してみることにしました。

Ultralispは、Quicklispの仕組みを利用していて、“dist”の一つという位置付けです。

(ql-dist:install-dist "http://dist.ultralisp.org/" :prompt nil)

で利用できるようになりますが、登録後には“dist”が増えていることが確認できます。

(ql-dist:all-dists)(#<ql-dist:dist quicklisp 2019-12-27> #<ql-dist:dist ultralisp 20200126195012>)

Ultralispの売りは、“dist”を五分毎に更新するので、登録から利用までが非常に早いのと、GitHubのリポジトリを管理画面からポチポチ登録すれば、登録は完了という手軽さのようです。

ちなみに別段Quicklisp本家が俺んちルールでやっているということではなく、各distには管理者がいて、Quicklispのデフォルトの“quicklisp” distにも管理者のポリシーがある、ということで適宜棲み分けするのが宜しかろうというところでしょうか。

暗黙のポリシーも含めてリストにするとこんな感じでしょうか。

“quicklisp” dist “ultralisp” dist
dist更新 約一ヶ月毎 五分毎
登録基準 SBCLでビルドできるか 特になし
除外基準 SBCLでビルドできなくなったら 特になし

現状、Common Lisp界はSBCL一強になりつつありますが、SBCLでビルドできなければ、“quicklisp” distには載らないんだよなーというのは、まあまあ耳にする話だったので、そういう点も“ultralisp”と“quicklisp”の棲み分けの基準になるかもしれません。

また、Ultralispの登録の手軽さを活かして、とりあえずUltralispに登録して暫く運用し、手応えがあったらQuicklispに申請するというのも良さそうです。

Ultralisp使用感とまとめ

特に“quicklisp” distと変わらないですが、手軽に早く登録できるので、複数環境で自作ライブラリを利用するのはかなり手軽になります。
その代わりといってはなんですが、登録レポジトリのコードを壊しちゃたりした場合でも、素早くそのまま流れていくので注意が必要かなと思います。
(素早く修正すれば良いとはいえ)

こんなUltralispなので登録ライブラリはQuicklispのデフォルトより多いんだろうと思いきや現在1253ということでquicklispの約1800より少ないようです。
“quicklisp” distから“ultralisp” distへの取り込みも進んでいるようなのでそのうち包含するのかもしれません。

ちなみにそもそものきっかけになったSRFIのCommon Lisp移植版ですが、ボチボチUltralispに登録しています。
srfi-2やsrfi-19等便利なものも案外あるので折角なのでUltralisp経由で活用していきたいと思います。


HTML generated by 3bmd in LispWorks 7.1.2

2019年振り返り

Posted 2019-12-31 15:13:25 GMT

毎年振り返りのまとめを書いているので、今回も書きます。

Lisp的進捗

今年は何故か自分の中ではMOPブームが到来し、後半は特にMOP的な拡張をして遊んでいました。
ECLOSを始めとして、1990年代にはMOPの拡張が色々と試行錯誤されていたようなので、これを暫く追試して行こうかなと思います。
どうもMOPは学習の取っ掛かりがないという印象があり、どう学んでいったら良いのか良く分からない状況が自分も長く続きましたが、結局のところ沢山書けば色々憶えてくるようです。
とりあえず役に立つ応用を考えたりするのは後回しで量を書いていれば段々見通しが付いてくるように思えました。
思えばマクロもナンセンスなものを沢山書いていましたし、自分はとりあえず量を書かないことには身に付かない質かもしれません。
Common LispのMOPも中途半端だったり発展途中(で四半世紀進歩がない)だったりするので、その辺りの状況もまとめてみたいと考えています。

ブログ

今年書いた記事は38記事でした。
年々記事の量が減っていますが、ネタがない訳ではなく記事にするのが面倒というところです。
世間的にもLispの記事を目にすることは大分少なくなりました。大分ブログというツールも廃れた感がありますが、2020年はもうちょっと書いていきたいと思います。

LispWorks

LispWorksを購入してから早四年半。
それまでSBCL+SLIMEをメインに使っていましたが、購入を機にLispWorksのIDEメインとしました。 しかし、いまだにSLIMEで便利だった機能を越えられていないところがあります。
LispWorksの方が便利なところも多いのですが、2020年は両者の良いとこ取りな環境を構築していきたいところです。

LispWorksでの職場の社内ツール作りもあいかわらず継続していて、利用者もアプリの種類も増えました。
折角なのでLispWorksのCommmon SQLやKnowledgeWorksの機能も使ってみていますが、デザインは古いもののそこそこ便利に使えています。
DBや推論機能はメタクラスが定義されており、これらをmixinして連携させるのが楽しいといえば楽しいです。

ウェブ屋さんが沢山在籍する職場では何かGUIのツールを作成するとなれば、ウェブアプリになると思いますが、そうでなければ、LispWorksみたいなアプリ作成機能もそこそこ有用かなと思います。
特に社内でしか使わないとなれば、ウェブアプリのメンテもそこそこ面倒なので。

2020年やってみたいこと

2019年の計画では、コンディションシステムアドベントカレンダーを開催したいと思っていましたが、ちょっと試しにQiitaを退会してみたら、記事がごっそり消えてしまったので、アドベントカレンダーを開催するのがめんどうになってしまい2019年はスキップしてしまいました。
コンディションシステムやMOPは今後も深追いしていきたい所存です。

また、1980年代のエキスパートシステムブームとLispについて大体見通しが付いてきたので、2020年は、第二次AIブームでのLispの活躍とは何だったのか等々まとめてみたいと考えています。

過去のまとめ


HTML generated by 3bmd in LispWorks 7.0.0

痕跡を残さないS式コメント

Posted 2019-12-21 18:10:57 GMT

コメントをS式で書く方式のcommentは、古くはMACLISPに、最近だとClojureにありますが、中身を無視してnil(MACLISPだと'comment)を返すシンプルなフォームです。

(comment 0 1 2)
→ nil

commentの中身もS式として成立していないといけないのですが、動いているコードをコメントアウトする分には大抵問題になることはないでしょう。

Common Lispで書くとするとこんな感じになります。

(defmacro comment (&body body)
  (declare (ignore body))
  nil)

S式コメントには一つ問題があり、nil等の値を残してしまうので、commentを残す場所には配慮する必要があります。

(vector (list 42))
→ #((42)) 

(vector (comment (list 42))) → #(nil)

ここで一捻りして、nilではなく(values)を置いてみるとどうでしょうか。

(defmacro comment (&body body)
  (declare (ignore body))
  '(values))

(values)は0個の返り値を返しますが、Common Lispの場合は値が評価される場所ではnilとなります。
つまり、nilと書いた場合と大差ないのですが、

(vector (comment (list 42)))
→ #(nil) 

#.を付けると、痕跡を消すことができます。

(vector #.(comment (list 42)))
→ #() 

リーダーマクロの書法の一つとして、値を出力したくない場合は、(values)を使うというのがあるのですが、これを利用した格好です。

まとめ

#.(comment ...)だとちょっと長いので、普段は、(comment ...)で書き、必要になったら#.を足す、という使い方をすれば、そこそこ便利に使えるかもしれません。


HTML generated by 3bmd in LispWorks 7.0.0

MOPでSoA

Posted 2019-12-17 17:58:29 GMT

構造体の配列を作成する方法として、

  • 構造体を配列に配置する(AoS: Array of Structures)
  • 配列の構造体を作る(SoA: Structure of Arrays)

があるようですが、SoAの方が効率が良いらしいです。

Common Lispでいうと、インスタンスの配列を作成するか、インスタンスのスロットを配列にするかになりますが、MOP細工でインスタンスのスロットは配列にはせずに通常のままでSoAな構成にしてみよう、というのが今回の趣旨です。

  • クラスメタオブジェクトにインスタンスのスロットを配列として保持し、
  • allocate-instanceでスロットの配列に配置。
  • インデックスはインスタンスのデータ部が空き地なのでここに格納

といった風に構成してみました。
LispWorks依存ですが、standard-objectの構造はメジャーどころは大体一緒なので移植は簡単だと思います。

動作

(defclass 🐱 (soa-object)
  ((a :initform 0 :type bit :initarg :a)
   (b :initform #\. :type character :initarg :b)
   (c :initform nil :type boolean :initarg :c))
  (:metaclass soa-class)
  (:pool-size 0))

(instance# (class-prototype (find-class '🐱))) → 0

(class-slot-vectors (find-class '🐱))((a . #*) (b . "") (c . #()))

(set '🐱 (make-instance '🐱 :a 0 :b #\- :c T)) → #<🐱 40201E2BFB>

(mapcar (lambda (s) (cons (car s) (elt (cdr s) (instance# 🐱)))) (class-slot-vectors (find-class '🐱)))((a . 0) (b . #\-) (c . t))

(dotimes (i 100) (make-instance '🐱 :a 1 :b #\. :c nil)) → nil

(class-slot-vectors (find-class '🐱))((a . #*001111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111) (b . "^@-....................................................................................................") (c . #(nil t nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil)))

(with-slots (a b c) (make-instance '🐱 :a 1 :b #\. :c nil) (list a b c))(1 #\. nil)

実装

堅牢性に難ありですが、概念実証くらいにはなるかなというところです。

(defpackage "e477e14c-8275-5c00-82d3-82f8adcd1567"
  (:use :c2cl))

(in-package "e477e14c-8275-5c00-82d3-82f8adcd1567")

(defclass soa-class (standard-class) ((pool-size :initform 256 :accessor instance-pool-size :initarg :pool-size) (instance-index :initform 0 :accessor instance-index) (slot-vectors :initform nil :accessor class-slot-vectors)))

(defmethod validate-superclass ((c soa-class) (s standard-class)) T)

(defclass soa-object () () (:metaclass Soa-class))

(defun instance# (soa-object) (clos::%svref Soa-object 1))

(defmethod allocate-instance ((class soa-class) &rest initargs) (let* ((class (clos::ensure-class-finalized class))) (prog1 (sys:alloc-fix-instance (clos::class-wrapper class) (instance-index class)) (incf (instance-index class)))))

(defmethod shared-initialize ((instance soa-object) slot-names &rest initargs) (flet ((initialize-slot-from-initarg (class instance slotd) (let ((slot-initargs (slot-definition-initargs slotd)) (name (slot-definition-name slotd))) (loop :for (initarg value) :on initargs :by #'cddr :do (when (member initarg slot-initargs) (setf (slot-value-using-class class instance name) value) (return t))))) (initialize-slot-from-initfunction (class instance slotd) (let ((initfun (slot-definition-initfunction slotd)) (name (slot-definition-name slotd))) (unless (not initfun) (setf (slot-value-using-class class instance name) (funcall initfun)))))) (let ((class (class-of instance))) (dolist (slotd (class-slots class)) (unless (initialize-slot-from-initarg class instance slotd) (when (or (eq t slot-names) (member (slot-definition-name slotd) slot-names)) (initialize-slot-from-initfunction class instance slotd))))) instance))

(defun soa-instance-access (class obj key) (elt (cdr (assoc key (class-slot-vectors class))) (instance# obj)))

(defun (setf soa-instance-access) (val class obj key) (when (> (instance# obj) (1- (instance-pool-size class))) (setf (instance-pool-size class) (1+ (instance# obj))) (dolist (slot (class-slot-vectors class)) (adjust-array (cdr slot) (instance-pool-size class)))) (setf (elt (cdr (assoc key (class-slot-vectors class))) (instance# obj)) val))

(defmethod slot-value-using-class ((c Soa-class) inst slot-name) (soa-instance-access c inst slot-name))

(defmethod (setf slot-value-using-class) (newvalue (c Soa-class) inst slot-name) (setf (soa-instance-access c inst slot-name) newvalue))

(defmethod ensure-class-using-class :after ((class soa-class) name &rest initargs &key) (when (consp (instance-pool-size class)) (setf (instance-pool-size class) (car (instance-pool-size class)))) (setf (class-slot-vectors class) (mapcar (lambda (s) (cons (slot-definition-name s) (make-array (instance-pool-size class) :element-type (or (slot-definition-type s) T) :adjustable T :initial-element (funcall (slot-definition-initfunction s))))) (class-slots class))))

まとめ

Common LispはC風に効率よく構造体を配列に詰められないのか、等々の質問はたまにみかけるのですが、今回のように高次のデータ構造的に記述して低次のデータ構造にマッピングする方法もなくはないかなとは思います。
直截的な回答としてはFFIでメモリの塊をいじる方法などになりそうですが。


HTML generated by 3bmd in LispWorks 7.0.0

Allegro CLのfixed-indexスロット再現リベンジ

Posted 2019-12-11 17:12:32 GMT

先日書いたAllegro CLのfixed-indexスロットアクセスを真似してみるの記事では、任意の値でslot-definition-loctionを確定させる術を分かっていなかったので、中途半端なことになっていました。
compute-slots :aroundを使った確定方法が分かったのでリベンジします。

動作

(<defclass> foo ()
  ((a :initarg :a fixed-index 2 :accessor foo-a)
   (b :initarg :b fixed-index 4 :accessor foo-b)
   (c :initarg :c :accessor foo-c))
  (:metaclass fixed-index-slot-class))

(mapcar (lambda (s) (list (slot-definition-name s) (slot-definition-location s))) (class-slots <foo>))((c 0) (a 2) (b 4))

(let ((foo (a 'foo))) (setf (foo-a foo) 'a) (setf (foo-b foo) 'b) (setf (foo-c foo) 'c) (std-instance-slots foo)) → #(c #<Slot Unbound Marker> a #<Slot Unbound Marker> b)

実装について

  • インデックスが指定されていないスロットは、先頭から空いている番地に差し込みます。
  • slot-value-using-classがいつものごとくLispWorks依存です(AMOP準拠でない) なおかつ遅そうです。

実装

(eval-when (:compile-toplevel :load-toplevel :execute)
  (ql:quickload :closer-mop))

(defpackage "506dccfc-1d3a-5b8c-9203-948447c433b4" (:use :c2cl))

(in-package "506dccfc-1d3a-5b8c-9203-948447c433b4")

;; utils (eval-when (:compile-toplevel :load-toplevel :execute) (setf (fdefinition 'a) #'make-instance) (defun fintern (package control-string &rest args) (with-standard-io-syntax (intern (apply #'format nil control-string args) (or package *package*)))) (defmacro <defclass> (name supers slots &rest class-options) `(defconstant ,(fintern (symbol-package name) "<~A>" name) (defclass ,name ,supers ,slots ,@class-options))))

(<defclass> fixed-index-slot-class (standard-class) ())

(defmethod validate-superclass ((c fixed-index-slot-class) (s standard-class)) T)

(<defclass> fixed-index-slot-definition (standard-slot-definition) ((fixed-index :initform nil :initarg fixed-index :accessor slot-definition-fixed-index)))

(<defclass> fixed-index-direct-slot-definition (fixed-index-slot-definition standard-direct-slot-definition) ())

(<defclass> fixed-index-effective-slot-definition (fixed-index-slot-definition standard-effective-slot-definition) ())

(defmethod direct-slot-definition-class ((c fixed-index-slot-class) &rest initargs) (declare (ignore initargs)) <fixed-index-direct-slot-definition>)

(defmethod effective-slot-definition-class ((c fixed-index-slot-class) &rest initargs) (declare (ignore initargs)) <fixed-index-effective-slot-definition>)

(defmethod compute-effective-slot-definition ((class fixed-index-slot-class) name direct-slot-definitions) (declare (ignore name)) (let ((effective-slotd (call-next-method))) (dolist (slotd direct-slot-definitions) (when (typep slotd <fixed-index-slot-definition>) #-allegro (setf (slot-definition-fixed-index effective-slotd) (slot-definition-fixed-index slotd)) #+allegro (setf (slot-value effective-slotd 'excl::location) (slot-definition-fixed-index slotd)) (return))) effective-slotd))

(defmethod allocate-instance ((class fixed-index-slot-class) &rest initargs) (let* ((class (clos::ensure-class-finalized class)) (slotds (class-slots class)) (max-index (loop :for s :in slotds :maximize (slot-definition-location s)))) (sys:alloc-fix-instance (clos::class-wrapper class) (sys:alloc-g-vector$fixnum (1+ max-index) clos::*slot-unbound*))))

(defmethod compute-slots :around ((class fixed-index-slot-class)) (let* ((slotds (call-next-method)) (indecies (mapcan (lambda (s) (and (slot-definition-fixed-index s) (list (slot-definition-fixed-index s)))) slotds)) (free-indecies (loop :for i :from 0 :to (apply #'max indecies) :unless (find i indecies) :collect i))) (dolist (s slotds) (if (slot-definition-fixed-index s) (setf (slot-definition-location s) (slot-definition-fixed-index s)) (setf (slot-definition-location s) (pop free-indecies)))) (sort (copy-list slotds) #'< :key #'slot-definition-location)))

(defun standard-instance-boundp (instance index) (not (eq clos::*slot-unbound* (standard-instance-access instance index))))

(defmethod slot-value-using-class ((class fixed-index-slot-class) instance slot-name) (let* ((slotd (find slot-name (class-slots class) :key #'slot-definition-name)) (loc (slot-definition-location slotd))) (cond ((not slotd) (slot-missing class instance slot-name 'slot-makunbound)) ((null (standard-instance-boundp instance loc)) (slot-unbound class instance slot-name)) (T (standard-instance-access instance loc)))))

(defmethod (setf slot-value-using-class) (val (class fixed-index-slot-class) instance slot-name) (let* ((slotd (find slot-name (class-slots class) :key #'slot-definition-name)) (loc (slot-definition-location slotd))) (if (not slotd) (slot-missing class instance slot-name 'slot-makunbound) (setf (standard-instance-access instance loc) val))))

(declaim (inline std-instance-slots)) (defun std-instance-slots (inst) #+allegro (excl::std-instance-slots inst) #+sbcl (sb-pcl::std-instance-slots inst) #+lispworks (clos::standard-instance-static-slots inst))

まとめ

インスタンスのスロットをベクタ上に任意に配置したり、ハッシュテーブルにしてみたり、ということができることは分かりましたが、標準から逸れたことをすると、どうもスロットのアクセス周りを全部書かないといけないっぽいですね。


HTML generated by 3bmd in LispWorks 7.0.0

MOPで隠しスロットの実現

Posted 2019-12-09 19:26:03 GMT

ここ最近、standard-instance-accessでインスタンス内部のベクタに直接アクセスするようなことを試していましたが、インデックスを求める方法があやふやでした。
compute-slotsで並んだ順で確定するのは分かっていたのですが、並び順ということは飛び飛びにはできないわけで、どうしたものかと考えていましたが、compute-slotsの説明を良く読んだら、compute-slotsのプライマリメソッドでスロット定義を並べて、compute-slots:aroundメソッドでslot-definition-locationの内容を確定するようなことが書いてあります。

In the final step, the location for each effective slot definition is
set. This is done by specified around-methods; portable methods cannot
take over this behavior. For more information on the slot definition
locations, see the section ``Instance Structure Protocol.''

ということでSBCLのMOP実装を確認してみましたが、やはり:aroundlocationを設定していました。なるほど。

compute-slots:aroundを乗っ取るには、さらなる:aroundを定義するしかないわけですが、どうも可搬性のためにはいじってはいけない場所のようです。

とはいえ、インデックスの設定方法が分かったので、試しに今回は、X3J13-88-003R-DRAFTのコード例にあるfaceted-slot-classを動かしてみたいと思います。

faceted-slot-class

X3J13-88-003Rのドラフトにはindex-in-instanceというAPIが存在していて、スロット名からインデックスを算出する仕組みになっていたようです。

このindex-in-instanceの利用例として、0、2、4…をスロット、1、3、5…をファセットとして配置するメタクラスを定義しています。

動作は下記のようになります。

(defclass zot ()
  ((a :initform 42)
   (b :initform 43)
   (c :initform 44))
  (:metaclass faceted-slot-class))

(let ((o (make-instance 'zot))) (values (with-slots (a b c) o (list a b c)) (loop :for index :from 0 :repeat (compute-instance-size (class-of o)) :collect (standard-instance-access o index))))(42 43 44) (42 #<Slot Unbound Marker> 43 #<Slot Unbound Marker> 44 #<Slot Unbound Marker>)

;;; ファセットに値を設定 (let ((o (make-instance 'zot))) (setf (slot-facet o 'a) 'facet-a) (setf (slot-facet o 'b) 'facet-b) (setf (slot-facet o 'c) 'facet-c) (values (with-slots (a b c) o (list a b c)) (loop :for index :from 0 :repeat (compute-instance-size (class-of o)) :collect (standard-instance-access o index))))(42 43 44) (42 facet-a 43 facet-b 44 facet-c)

実装

ということで実装ですが、元のコードのAPIをできるだけ残したかったのですが、どうもコンセプトコードのようで実際に動かすと色々矛盾がある様子。
その辺りは適当に辻褄を合せました。
しかし、辻褄が合わないところもあり、

  • compute-slotの中でindex-in-instanceを使って綺麗にカスタマイズしたいが、index-in-instanceが使うスロット情報は遡ればcompute-slotを利用するので循環が発生する

等は、index-in-instanceの内容をcompute-slotの中にベタ書きで展開することで回避しています。

以下、LispWorks依存なコードです。
LispWorks標準のslot-value-using-classは、スロットのインデックスが隙間無く並んでいることを前提としていて、疎な配置にすると動作がおかしくなるので、自前で定義しています。

(ql:quickload :closer-mop)

(defpackage "2f1cccc9-c776-5726-9e68-91d2d9042169" (:use :c2cl))

(in-package "2f1cccc9-c776-5726-9e68-91d2d9042169")

(defgeneric index-in-instance (class description))

(defmethod index-in-instance ((class cl:standard-class) description) (typecase description (symbol (position description (class-slots class) :key #'slot-definition-name)) (T (error "Don't understand the description ~S." description))))

(defgeneric compute-instance-size (class))

(defmethod compute-instance-size ((class cl:standard-class)) (length (class-slots class)))

(defclass faceted-slot-class (standard-class) ())

(defmethod validate-superclass ((c faceted-slot-class) (s standard-class)) T)

(defmethod compute-instance-size ((class faceted-slot-class)) (* 2 (call-next-method)))

(defmethod allocate-instance ((class faceted-slot-class) &rest initargs) (let ((class (clos::ensure-class-finalized class))) (sys:alloc-fix-instance (clos::class-wrapper class) (sys:alloc-g-vector$fixnum (compute-instance-size class) clos::*slot-unbound*))))

(defmethod index-in-instance ((class faceted-slot-class) description) (cond ((symbolp description) (let ((index (call-next-method))) (and index (* 2 index)))) ((and (consp description) (eq (car description) 'facet)) (1+ (index-in-instance class (cadr description)))) (T (error "Don't understand the description ~S." description))))

(defun standard-instance-access* (instance description trap not-bound-function missing-function) (declare (ignore trap)) (let* ((class (class-of instance)) (index (index-in-instance class description))) (cond ((null index) (funcall missing-function instance description)) ((not (numberp index)) (slot-value index 'value)) ((null (standard-instance-boundp instance index)) (funcall not-bound-function instance description)) (T (standard-instance-access instance index)))))

(defun (setf standard-instance-access*) (val instance description trap not-bound-function missing-function) (declare (ignore trap not-bound-function)) (let* ((class (class-of instance)) (index (index-in-instance class description))) (cond ((null index) (funcall missing-function instance description)) ((not (numberp index)) (slot-value index 'value)) (T (setf (standard-instance-access instance index) val)))))

(defun standard-instance-boundp (instance index) (not (eq clos::*slot-unbound* (standard-instance-access instance index))))

(defun slot-facet (instance slot-name) (standard-instance-access* instance (list 'facet slot-name) nil #'facet-unbound #'facet-missing))

(defun (setf slot-facet) (new-value instance slot-name) (setf (standard-instance-access* instance (list 'facet slot-name) nil #'facet-unbound #'facet-missing) new-value))

(defun facet-unbound (instance facet) (error "The facet ~S is unbound in the object ~S" (cadr facet) instance))

(defun facet-missing (instance facet) (error "The facet ~S is missing from the object ~S" (cadr facet) instance))

(defmethod compute-slots :around ((class faceted-slot-class)) (let ((slotds (call-next-method))) (dolist (s slotds) ;; Base case (setf (slot-definition-location s) (* 2 (position s slotds)))) slotds))

(defmethod slot-value-using-class ((class faceted-slot-class) instance slot-name) (let ((index (index-in-instance class slot-name))) (cond ((null index) (slot-missing class instance slot-name 'slot-makunbound)) ((not (numberp index)) (slot-value index 'value)) ((null (standard-instance-boundp instance index)) (slot-unbound class instance slot-name)) (T (standard-instance-access instance index)))))

まとめ

index-in-instanceは、class-slotsslot-definition-nameslot-definition-locationの組み合わせとも大差ないともいえますが、index-in-instanceの方がスロット名とインデックスの関係が明確になる上にカスタマイズしやすそうな気もします。
今回の例では、index-in-instanceを呼びまくっていますが、ちょっと遅そうなので、クラスにインデックスを保持させる方が良いかもしれません。


HTML generated by 3bmd in LispWorks 7.0.0

文字列中にダブルクォートが頻出してエスケープが面倒な時はシンボルで記述して変換

Posted 2019-12-08 19:31:12 GMT

表題の通りなのですが、Clozure CLのマニュアルのソースを眺めていて、こんな記述をみつけました。

  • doc/manual/implementation.ccldoc

(item "r13 is used to hold the TCR on PPC32 systems; it's not used on PPC64."))
(item #:|r14 (symbolic name loc-pc) is used to copy "pc-locative" values between main memory and special-purpose PPC registers (LR and CTR) used intern function-call and return instructions.|)

一応解説すると、マニュアルは文字列のリストで記述されていて、文字列の表記には文字列でもシンボルでも使えるようにしてあるので、ダブルクォートのエスケープが面倒な時にはシンボルで記述する(上記の例ではインターンを嫌ってか自由シンボル)ということです。

上記の例ではマクロ展開時の処理ですが、実行時ならば、

(string '|"""foo "bar" baz"""|)
→ "\"\"\"foo \"bar\" baz\"\"\"" 

となり、リード時処理なら文字列を直に書いているのと同一です。

#.(string '|"""foo "bar" baz"""|)
≡ "\"\"\"foo \"bar\" baz\"\"\"" 

個人的には以前から思い付きでやっていたことなのですが、自分以外にもこんなことしている人をみつけた記念に記事にしてみました。


HTML generated by 3bmd in LispWorks 7.0.0

ECLOSのself-referent-classを再現してみる

Posted 2019-12-04 20:14:19 GMT

最近はECLOSを再現して遊んでいますが、今回は、self-referent-classというメタクラスを再現してみます。

なお、self-referent-classについては、ECLOSの論文に詳しいので参照してください。

挙動を確認してみる

説明はあるとはいえ、マニュアルや仕様書ではないので、実際実装してみようとすると良くわからないところはありますが、インスタンスの初期化時に他のスロットを参照できること=自己参照、ということのようです。 論文の解説によれば、大体下記のような挙動になります。

  • 初期化時に自己のインスタンスをselfという変数で参照可能
  • (slot-name self)という形式で自身の式より左側のスロットを参照可能

    • しかしこれがcreatorparentの機能なのか判然としない

(defclass horizontal-line (self-referent-object)
  ((x1 :accessor x1 :initarg :x1 :type real)
   (x2 :accessor x2 :initarg :x2 :type real)
   (y :accessor y :initarg :y :type real)
   (point1 :initform (make-point (x1 self)
                                 (y self)))
   (point2 :initform (make-point (x2 self)
                                 (y self))))
  (:metaclass self-referent-class))

(set' obj (make-instance 'horizontal-line :x1 1 :x2 2 :y 3))

(slot-value obj 'x1) → 1 (slot-value obj 'x2) → 2

(slot-value obj 'point1)(1 3)

(slot-value obj 'point2)(2 3)

実装のヒント

論文にはCommon LispのMOPについて問題点が何点も指摘されていますが、スロット定義のinitfunctionが引数を取らないことも指摘しています。
この指摘の中で、この問題を回避するためにスペシャル変数経由で渡していると書いてあるのですが、だとすると、shared-initializeの中のスロット初期化関数にスペシャル変数経由でselfを渡しているのでしょう。

shared-initialize:aroundを使ってスペシャル変数の囲いはこんな風に書けるでしょう。

(defmethod shared-initialize :around ((instance self-referent-object) slot-names &rest initargs)
  (let ((*self-referent-object-self* instance))
    (declare (special *self-referent-object-self*))
    (call-next-method)))

あとは、initfunction

(lambda (&aux (self *self-referent-object-self*)) 
  (declare (special *self-referent-object-self*))
  ...)

のようなものに差し替えればOKです。

(slot-name self)のような形式は、スロット名の局所関数を作成し、ensure-class-using-classの周りに展開されるようにすれば良さそうです。

以上で、想像される展開は下記のようになります。

(eval-when (:compile-toplevel :load-toplevel :execute)
  (flet ((x1 (self) (slot-value self 'x1))
         (x2 (self) (slot-value self 'x2))
         (y (self) (slot-value self 'y))
         (point1 (self) (slot-value self 'point1))
         (point2 (self) (slot-value self 'point2)))
    (def:def (lisp:defclass horizontal-line)
      (clos::ensure-class-without-lod 'horizontal-line
                                      :metaclass
                                      'self-referent-class
                                      :direct-slots
                                      (list (list :name 'x1
                                                  :readers '(x1)
                                                  :writers '((setf x1))
                                                  :initargs '(:x1)
                                                  :type 'real)
                                            (list :name 'x2
                                                  :readers '(x2)
                                                  :writers '((setf x2))
                                                  :initargs '(:x2)
                                                  :type 'real)
                                            (list :name 'y
                                                  :readers '(y)
                                                  :writers '((setf y))
                                                  :initargs '(:y)
                                                  :type 'real)
                                            (list :name 'point1
                                                  :initform
                                                  '(make-point (x1 self) (y self))
                                                  :initfunction
                                                  #'(lambda (&aux (self zreclos.meta::*self-referent-object-self*))
                                                      (declare (special zreclos.meta::*self-referent-object-self*))
                                                      (make-point (x1 self) (y self))))
                                            (list :name 'point2
                                                  :initform
                                                  '(make-point (x2 self) (y self))
                                                  :initfunction
                                                  #'(lambda (&aux (self zreclos.meta::*self-referent-object-self*))
                                                      (declare (special zreclos.meta::*self-referent-object-self*))
                                                      (make-point (x2 self) (y self)))))
                                      :direct-superclasses '(self-referent-object)
                                      :location
                                      (def:location)))))

実装してみる

defclassがメタクラスに応じて任意の展開にディスパッチされると便利なのですが、LispWorksだとexpand-defclassというのがあるので、ここに展開メソッドを追加してやることでdefclassの兄弟マクロを定義せずに済みました。

このexpand-defclassですが、X3J13-88-003Rにあるのと同じ大体同じインターフェイスです。

他にもスロットのオプションの展開等にもLispWorksには便利なメソッドがあるので使ってみました(非公開APIですが) ちなみに、これらはclass-prototypeをディスパッチに利用するのですが、昔からこういう使い方は或る種の定番だったようです。

などなどですが、ベタベタにLispWorks依存になっています。

(defclass self-referent-class (standard-class)
  ()
  (:metaclass standard-class))

(defmethod validate-superclass ((c self-referent-class) (s standard-class)) T)

(defun make-creator-function-form (slot-form) (let ((name (car slot-form))) `(,name (self) (slot-value self ',name))))

(defmethod clos::expand-defclass ((prototype self-referent-class) metaclass name superclasses slots class-options) (destructuring-bind (eval-when opts &body body) (call-next-method) `(,eval-when ,opts (flet (,@(mapcar #'make-creator-function-form slots)) ,@body))))

(defclass self-referent-object (standard-object) () (:metaclass self-referent-class))

(defmethod shared-initialize :around ((instance self-referent-object) slot-names &rest initargs) (let ((*self-referent-object-self* instance)) (declare (special *self-referent-object-self*)) (call-next-method)))

;; from alexandria (defun flatten (tree) "Traverses the tree in order, collecting non-null leaves into a list." (let (list) (labels ((traverse (subtree) (when subtree (if (consp subtree) (progn (traverse (car subtree)) (traverse (cdr subtree))) (push subtree list))))) (traverse tree)) (nreverse list)))

(defun non-trivial-initform-initfunction-p (initform) #+lispworks7.1 (loop :for (name ntifif) :on (flatten initform) :thereis (and (eq 'hcl:lambda-name name) (eq 'clos::non-trivial-initform-initfunction ntifif))) #+lispworks7.0 (let ((x initform)) (and (consp x) (eq 'function (car x)) (eq 'lambda (caadr x)))))

(defgeneric make-sr-class-initfunction-form (class ifform))

(defmethod make-sr-class-initfunction-form ((class self-referent-class) ifform) (if (non-trivial-initform-initfunction-p ifform) (destructuring-bind (function (lambda arg &body body)) ifform (declare (ignore arg)) `(,function (,lambda (&aux (self *self-referent-object-self*)) (declare (special *self-referent-object-self*)) ,@body))) ifform))

(defmethod clos::canonicalize-defclass-slot ((prototype self-referent-class) slot) (let* ((plist (copy-list (cdr (call-next-method)))) (ifform (getf plist :initfunction))) (if (getf plist :initform) (progn (remf plist :initfunction) `(list ,@plist :initfunction ,(make-sr-class-initfunction-form prototype ifform))) (progn `(list ,@plist)))))

まとめ

expand-defclassは便利なのでLispWorks限らず他でも使いたいところですが、このあたりは統一されてないんですよねえ。


HTML generated by 3bmd in LispWorks 7.0.0

SBCLにcaseのジャンプテーブル最適化が入ったので試してみる

Posted 2019-11-27 20:02:15 GMT

昨日リリースされたSBCL 1.5.9にcaseのジャンプテーブル最適化が入ったようなので早速どんなものか試してみたいと思います。

とりあえず若干わざとらしいものを試してみます。
caseのキーに0から511までの数値をシャッフルしたものを指定して分岐し、さらに二段目のcaseで元に戻すのを5回繰り返すのを1000繰り返してみます。

(defconstant nbranch 512)

;; alexandria (defun shuffle (sequence &key (start 0) end) "Returns a random permutation of SEQUENCE bounded by START and END. Original sequece may be destructively modified, and share storage with the original one. Signals an error if SEQUENCE is not a proper sequence." (declare (type fixnum start) (type (or fixnum null) end)) (etypecase sequence (list (let* ((end (or end (length sequence))) (n (- end start))) (do ((tail (nthcdr start sequence) (cdr tail))) ((zerop n)) (rotatef (car tail) (car (nthcdr (random n) tail))) (decf n)))) (vector (let ((end (or end (length sequence)))) (loop for i from start below end do (rotatef (aref sequence i) (aref sequence (+ i (random (- end i)))))))) (sequence (let ((end (or end (length sequence)))) (loop for i from (- end 1) downto start do (rotatef (elt sequence i) (elt sequence (+ i (random (- end i))))))))) sequence)

(defmacro casetabletest (x) (let ((xy (loop :for x :across (shuffle (let ((vec (make-sequence 'vector nbranch))) (dotimes (i nbranch vec) (setf (elt vec i) i)))) :for i :from 0 :collect (list i x)))) `(case (case ,x ,@xy (otherwise -1)) ,@(mapcar #'reverse xy) (otherwise -1))))

(defun casetest (&aux (n 0)) (dotimes (i nbranch n) (incf n (casetabletest (casetabletest (casetabletest (casetabletest (casetabletest i))))))))

(compile 'casetest)

(time (dotimes (i 1000) (casetest)))

SBCL 1.5.8

t% /l/sbcl/1.5.8/bin/sbcl --no-sysinit --no-userinit --load /tmp/case.lisp --quit 
This is SBCL 1.5.8, an implementation of ANSI Common Lisp.
More information about SBCL is available at <http://www.sbcl.org/>.

SBCL is free software, provided as is, with absolutely no warranty. It is mostly in the public domain; some portions are provided under BSD-style licenses. See the CREDITS and COPYING files in the distribution for more information. Evaluation took: 1.986 seconds of real time 1.990000 seconds of total run time (1.990000 user, 0.000000 system) 100.20% CPU 6,537,459,720 processor cycles 0 bytes consed

SBCL 1.5.9

t% /l/sbcl/1.5.9/bin/sbcl --no-sysinit --no-userinit --load /tmp/case.lisp --quit 
This is SBCL 1.5.9, an implementation of ANSI Common Lisp.
More information about SBCL is available at <http://www.sbcl.org/>.

SBCL is free software, provided as is, with absolutely no warranty. It is mostly in the public domain; some portions are provided under BSD-style licenses. See the CREDITS and COPYING files in the distribution for more information. Evaluation took: 0.056 seconds of real time 0.060000 seconds of total run time (0.060000 user, 0.000000 system) 107.14% CPU 184,341,012 processor cycles 0 bytes consed

この極端な例では35倍も速くなっています。
まあこんなことはそうそうないですが!

ちなみに類似の最適化を実施するClozure CLでも同じ位のスピードが出るようです。

t% /l/ccl/1.11.5/lx86cl64 -n -l /tmp/case.lisp -e '(quit)'
(DOTIMES (I 1000) (CASETEST))
took 55,783 microseconds (0.055783 seconds) to run.
During that period, and with 8 available CPU cores,
     60,000 microseconds (0.060000 seconds) were spent in user mode
          0 microseconds (0.000000 seconds) were spent in system mode

発動ルールを探る

上記の例では最適化が発動しましたが、caseのジャンプテーブル化ではそんなに大きなテーブルは作らないことがほとんどなので、SBCLではどういう縛りがあるか確認してみます。

発動ルールは、src/compiler/ir2opt.lispshould-use-jump-table-pの中に記述されているようで、

  • キーの最大値から最小値を引いたもの+1がテーブルサイズ
  • テーブルサイズは分岐の数の二倍が上限

のようです。

(defun should-use-jump-table-p (chain &aux (choices (car chain)))
  ;; Dup keys could exist. REMOVE-DUPLICATES from-end can handle that:
  ;;  "the one occurring earlier in sequence is discarded, unless from-end
  ;;   is true, in which case the one later in sequence is discarded."
  (let ((choices (remove-duplicates choices :key #'car :from-end t))) 
    ;; Convert to multiway only if at least 4 key comparisons would be needed.
    (unless (>= (length choices) 4)
      (return-from should-use-jump-table-p nil))
    (let ((values (mapcar #'car choices)))
      (cond ((every #'fixnump values)) ; ok
            ((every #'characterp values)   
             (setq values (mapcar #'sb-xc:char-code values)))
            (t
             (return-from should-use-jump-table-p nil)))
      (let* ((min (reduce #'min values))
             (max (reduce #'max values))
             (table-size (1+ (- max min )))
             (size-limit (* (length values) 2)))
        ;; Don't waste too much space, e.g. {5,6,10,20} would require 16 words
        ;; for 4 entries, which is excessive.
        (when (and (<= table-size size-limit)
                   (can-encode-jump-table-p min max))
          ;; Return the new choices
          (cons choices (cdr chain)))))))

上記ルールからすると、一つ置きで配置された整数のキーは最適化されますが、二つ置きだとルールから外れるので最適化されないことが分かります。
一応試してみましょう。

(defun foo2 (x)
  (declare (type fixnum x))
  #.`(case x
       ,@(loop :for i :from 0 :by 2 :repeat 10
               :collect (list i i))
       (otherwise -1)))

; disassembly for FOO2
; Size: 110 bytes. Origin: #x52DF52DA                         ; FOO2
; 2DA:       498B4510         MOV RAX, [R13+16]               ; thread.binding-stack-pointer
; 2DE:       488945F8         MOV [RBP-8], RAX
; 2E2:       4C8BDB           MOV R11, RBX
; 2E5:       4983FB24         CMP R11, 36
; 2E9:       774E             JNBE L10
; 2EB:       488D0526FFFFFF   LEA RAX, [RIP-218]              ; = #x52DF5218
; 2F2:       42FF2498         JMP QWORD PTR [RAX+R11*4]
; 2F6: L0:   BA04000000       MOV EDX, 4
; 2FB: L1:   488BE5           MOV RSP, RBP
; 2FE:       F8               CLC
; 2FF:       5D               POP RBP
; 300:       C3               RET
; 301: L2:   BA08000000       MOV EDX, #x8                    ; is_lisp_thread
; 306:       EBF3             JMP L1
; 308: L3:   BA0C000000       MOV EDX, 12
; 30D:       EBEC             JMP L1
; 30F: L4:   BA10000000       MOV EDX, 16
; 314:       EBE5             JMP L1
; 316: L5:   BA14000000       MOV EDX, 20
; 31B:       EBDE             JMP L1
; 31D: L6:   BA18000000       MOV EDX, 24
; 322:       EBD7             JMP L1
; 324: L7:   BA1C000000       MOV EDX, 28
; 329:       EBD0             JMP L1
; 32B: L8:   BA20000000       MOV EDX, 32
; 330:       EBC9             JMP L1
; 332: L9:   BA24000000       MOV EDX, 36
; 337:       EBC2             JMP L1
; 339: L10:  48C7C2FEFFFFFF   MOV RDX, -2
; 340:       EBB9             JMP L1
; 342: L11:  31D2             XOR EDX, EDX
; 344:       EBB5             JMP L1
; 346:       CC10             INT3 16                         ; Invalid argument count trap

(defun foo3 (x)
  (declare (type fixnum x))
  #.`(case x
       ,@(loop :for i :from 0 :by 3 :repeat 10
               :collect (list i i))
       (otherwise -1)))

; disassembly for FOO3
; Size: 154 bytes. Origin: #x52DF53CE                         ; FOO3
; 3CE:       498B5D10         MOV RBX, [R13+16]               ; thread.binding-stack-pointer
; 3D2:       48895DF8         MOV [RBP-8], RBX
; 3D6:       4885C0           TEST RAX, RAX
; 3D9:       0F8483000000     JEQ L9
; 3DF:       4883F806         CMP RAX, 6
; 3E3:       750B             JNE L1
; 3E5:       BA06000000       MOV EDX, 6
; 3EA: L0:   488BE5           MOV RSP, RBP
; 3ED:       F8               CLC
; 3EE:       5D               POP RBP
; 3EF:       C3               RET
; 3F0: L1:   4883F80C         CMP RAX, 12
; 3F4:       7507             JNE L2
; 3F6:       BA0C000000       MOV EDX, 12
; 3FB:       EBED             JMP L0
; 3FD: L2:   4883F812         CMP RAX, 18
; 401:       7507             JNE L3
; 403:       BA12000000       MOV EDX, 18
; 408:       EBE0             JMP L0
; 40A: L3:   4883F818         CMP RAX, 24
; 40E:       7507             JNE L4
; 410:       BA18000000       MOV EDX, 24
; 415:       EBD3             JMP L0
; 417: L4:   4883F81E         CMP RAX, 30
; 41B:       7507             JNE L5
; 41D:       BA1E000000       MOV EDX, 30
; 422:       EBC6             JMP L0
; 424: L5:   4883F824         CMP RAX, 36
; 428:       7507             JNE L6
; 42A:       BA24000000       MOV EDX, 36
; 42F:       EBB9             JMP L0
; 431: L6:   4883F82A         CMP RAX, 42
; 435:       7507             JNE L7
; 437:       BA2A000000       MOV EDX, 42
; 43C:       EBAC             JMP L0
; 43E: L7:   4883F830         CMP RAX, 48
; 442:       7507             JNE L8
; 444:       BA30000000       MOV EDX, 48
; 449:       EB9F             JMP L0
; 44B: L8:   4883F836         CMP RAX, 54
; 44F:       48C7C2FEFFFFFF   MOV RDX, -2
; 456:       41BB36000000     MOV R11D, 54
; 45C:       490F44D3         CMOVEQ RDX, R11
; 460:       EB88             JMP L0
; 462: L9:   31D2             XOR EDX, EDX
; 464:       EB84             JMP L0
; 466:       CC10             INT3 16                         ; Invalid argument count trap

まとめ

SBCLのcaseのジャンプテーブル化は、キーをそこそこ密に配置する必要がある様子。
ちなみに、caseの最適化と本記事では書いてきましたが、Clozure CLと同じく、コンパイラが最適化で実施するので、Lispのレベルではifの組み合わせが最適化のルールに合致していれば発動します。

SBCLには最近細かい最適化が入ってきていますが今後も地味に速くなって行きそうです。

関連記事


HTML generated by 3bmd in LispWorks 7.0.0

スロットのアクセス時まで初期化を遅らせる

Posted 2019-11-24 20:54:15 GMT

ECLOSのlazy-classというのを再現してみようかなと思っているのですが、このlazy-slotには初期化のタイミングが、通常の初期化時と、スロット読み取り時直前とで二通りで選択可能です。
lazy-classには、他にも初期化の依存関係を記述する機能があるのですが、とりあえずそれは置いて、初期化タイミングだけ切り出して実現方法を考えてみました。
上手く行けば、初期化の依存関係を記述する機能と、初期化タイミングの指定は後でmixinできるでしょう。

あれこれ考えて作成してみましたが、下記のように動作します。

(defconstant <i@robj>
  (defclass i@robj (initialize-at-read-object)
    ((a :initform 'a :initialize-at-read-p T)
     (b :initform 'b :accessor b)
     (c :initform 'c :accessor c))
    (:metaclass initialize-at-read-class)))

(class-slots <i@robj>)(#<initialize-at-read-effective-slot-definition a 402023D19B> #<initialize-at-read-effective-slot-definition b 402023D37B> #<initialize-at-read-effective-slot-definition c 402023D3EB>)

(class-initialize-at-read-slots <i@robj>)(#<initialize-at-read-effective-slot-definition a 4020235393>)

(let ((o (make-instance <i@robj>))) (list (slot-boundp o 'a) (slot-value o 'a) (slot-value o 'b) (slot-value o 'c)))(nil a b c)

実装した内容としては、

  • 読み取り時初期化のスロットをclass-initialize-at-read-slotsとして取得することにする
  • 読み取り時初期化のスロットはshared-initializeでは初期化を飛す
  • 読み取り時初期化のスロットは、初回の読み取りは未束縛のため、slot-unboundが起動されるので、ここで初期化する
  • スロットの初期化を条件によりスキップしないといけないのでshared-initializeを置き換え

位です。

実現したいことは単純なので、どうにかコードを圧縮したいところですが、MOPのコードはどうも長くなってしまいますね。
まあ、そんなに頻繁に書くものでもないので長くても良いのか……。

今回の場合は、slot-unboundを使ってスロットの初期化をすれば良いので、クラスごとに定義することにはなるもののMOPをカスタマイズしなくてもslot-unboundの定義だけすれば、正味五六行の追加で済みそうではあります。

(eval-when (:compile-toplevel :load-toplevel :execute)
  (ql:quickload :closer-mop))

(defpackage "a86f7ecc-112d-5ccb-9280-20798a2e36b4" (:use :c2cl))

(in-package "a86f7ecc-112d-5ccb-9280-20798a2e36b4")

;; utils (eval-when (:compile-toplevel :load-toplevel :execute) (defun package-symbolconc (package-spec &rest frobs) (values (intern (with-standard-io-syntax (with-output-to-string (out) (dolist (elt frobs) (unless (typep elt '(or symbol string fixnum character)) (error "The value ~A is not of type (OR SYMBOL STRING FIXNUM CHARACTER)." elt)) (princ elt out)))) package-spec))) (defun symbolconc (&rest frobs) (declare (dynamic-extent frobs)) (apply #'package-symbolconc *package* frobs)))

(defclass initialize-at-read-class (standard-class) ((initialize-at-read-slots :initform nil :accessor class-initialize-at-read-slots)) (:metaclass standard-class))

(defclass initialize-at-read-object (standard-object) () (:metaclass initialize-at-read-class))

(defmethod validate-superclass ((c initialize-at-read-class) (s standard-class)) T)

(macrolet ((defslotd (name) (let ((class (symbolconc name '-class)) (slotd (symbolconc name '-slot-definition)) (dslotd (symbolconc name '-direct-slot-definition)) (eslotd (symbolconc name '-effective-slot-definition)) (slotp (symbolconc 'slot-definition- name '-p))) `(progn (defclass ,slotd (standard-slot-definition) ((,(symbolconc name '-p) :initform nil :accessor ,slotp :initarg ,(package-symbolconc :keyword name '-p)))) (defclass ,dslotd (,slotd standard-direct-slot-definition) ()) (defclass ,eslotd (,slotd standard-effective-slot-definition) ()) (defmethod direct-slot-definition-class ((class ,class) &rest initargs) (declare (ignore initargs)) (find-class ',dslotd)) (defmethod effective-slot-definition-class ((class ,class) &rest initargs) (declare (ignore initargs)) (find-class ',eslotd)) (defmethod compute-effective-slot-definition ((class ,class) name direct-slot-definitions) (declare (ignore name)) (let ((eslotd (call-next-method))) (dolist (dslotd direct-slot-definitions) (when (typep dslotd (find-class ',slotd)) (setf (,slotp eslotd) (,slotp dslotd)) (return))) eslotd)) (defmethod slot-unbound ((class ,class) (instance ,(symbolconc name '-object)) name) (let ((slotd (find name (,(symbolconc 'class- name '-slots) class) :key #'slot-definition-name))) (let ((result (funcall (slot-definition-initfunction slotd)))) (setf (slot-value instance name) result) result))) (defmethod compute-slots :around ((class ,class)) (let ((slots (call-next-method))) (setf (,(symbolconc 'class- name '-slots) class) (remove-if-not #',slotp slots)) slots)))))) (defslotd initialize-at-read))

(defun initialize-slot-from-initarg (class instance slotd initargs) (let ((slot-initargs (slot-definition-initargs slotd))) (loop :for (initarg value) :on initargs :by #'cddr :do (when (and (member initarg slot-initargs) (not (slot-definition-initialize-at-read-p slotd))) (setf (slot-value-using-class class instance slotd) value) (return t)))))

(defun initialize-slot-from-initfunction (class instance slotd) (let ((initfun (slot-definition-initfunction slotd))) (unless (or (not initfun) (slot-boundp-using-class class instance slotd)) (unless (slot-definition-initialize-at-read-p slotd) (setf (slot-value-using-class class instance slotd) (funcall initfun))))))

(defmethod shared-initialize ((instance initialize-at-read-object) slot-names &rest initargs) (let* ((class (class-of instance))) (dolist (slotd (class-slots class)) (unless (initialize-slot-from-initarg class instance slotd initargs) (when (or (eq t slot-names) (member (slot-definition-name slotd) slot-names)) (initialize-slot-from-initfunction class instance slotd)))) instance))


HTML generated by 3bmd in LispWorks 7.0.0

STklosのメタクラス継承(をCommon Lispで)

Posted 2019-11-17 15:55:00 GMT

前回は、ECLOSが提供するdefclass:metaclassオプション省略時のメタクラスの自動算出について書きましたが、今回はTiny CLOSの流れを汲むSTklos系のメタクラスメタクラスの自動算出です。

Tiny CLOSが動くScheme処理系は結構あるようですが、より処理系と統合されたり構文が改良されたりしているのがSTklos系のようです。

  • STklos
  • Guile
  • Gauche
  • Sagitarius

上記あたりがSTklos系のようですが、Tiny CLOSの系譜をいまいち把握できていないので外しているかもしれません。
上記の継承関係は、

(defclass stklos (tiny-clos clos dylan) ())
(defclass guile (stklos) ())
(defclass gauche (stklos guile) ())
(defclass sagitarius (gauche) ())

っぽいですが。

とりあえず、今回のメタクラスの自動算出に関しては、上記処理系で共通なのでSTklos系ということにしましょう。

STklosメタクラスの自動算出アルゴリズム

Gauche: 7.5.1 クラスのインスタンシエーション等に解説されていますが、

  1. define-class:metaclassが明示されていればそれを使う
  2. 指定がなければ

    • ダイレクトスーパークラスのメタクラスのクラス順位リスト中を調べて
    • メタクラスが一つに定まればそれを使う
    • 複数なら、その複数のメタクラスをスーパークラスとするメタクラスを生成して使う

となります。

メタクラスのクラス順位リスト中をどう調べるのかは、コードは簡単なので詳細はコードを眺めた方が早いでしょう。
下記は、GuileのコードをCommon Lispに移植したものです。

オリジナルではクラス名をgensymで生成していますが、下記ではスーパークラス名のリストを名前としてみています。

(defpackage "d65706d7-0478-5a48-b39b-0dd8c0ff2563"
  (:use :c2cl))

(in-package "d65706d7-0478-5a48-b39b-0dd8c0ff2563")

(let ((table-of-metas '())) (defun ensure-metaclass-with-supers (meta-supers) (let ((entry (assoc meta-supers table-of-metas :test #'equal))) (if entry ;; Found a previously created metaclass (cdr entry) ;; Create a new meta-class which inherit from "meta-supers" (let* ((name (mapcar #'class-name meta-supers)) (new (make-instance 'standard-class :name name :direct-superclasses meta-supers :direct-slots '()))) (setf (find-class name) new) (push (cons meta-supers new) table-of-metas) new)))))

(defun ensure-metaclass (supers) (if (endp supers) (find-class 'standard-class) (let* ((all-metas (mapcar #'class-of supers)) (all-cpls (mapcan (lambda (m) (copy-list (cdr (class-precedence-list m)))) all-metas)) (needed-metas '())) ;; Find the most specific metaclasses. The new metaclass will be ;; a subclass of these. (mapc (lambda (meta) (when (and (not (member meta all-cpls)) (not (member meta needed-metas))) (setq needed-metas (append needed-metas (list meta))))) all-metas) ;; Now return a subclass of the metaclasses we found. (if (endp (cdr needed-metas)) (car needed-metas) ; If there's only one, just use it. (ensure-metaclass-with-supers needed-metas)))))

(defpackage stklos (:use) (:export defclass))

(defmacro stklos:defclass (name superclasses slots &rest class-options) (let* ((metaclass (ensure-metaclass (mapcar (lambda (s) (or (find-class s nil) (make-instance 'standard-class :name s))) superclasses))) (metaclass (case (class-name metaclass) (forward-referenced-class (find-class 'standard-class)) (otherwise metaclass)))) (clos::expand-defclass (class-prototype metaclass) (class-name metaclass) name superclasses slots class-options)))

動作確認

定義できたので動作を確認していきます。

(defclass a-class (standard-class) ())
(defclass b-class (standard-class) ())
(defclass c-class (a-class b-class) ())
(defmethod validate-superclass ((c a-class) (s standard-class)) T)
(defmethod validate-superclass ((c b-class) (s standard-class)) T)

(defconstant <a> (defclass a () () (:metaclass a-class)))

(defconstant <b> (defclass b () () (:metaclass b-class)))

前回と同じく、a-classb-classc-classとメタクラスを定義し、a-classをメタクラスとしたab-classをメタクラスとしたbを作成します。

ここで、

(defclass c (a b)
  ())

とした場合に、cのメタクラスがどのように求まるかを確認してみます。

(ensure-metaclass (list <a> <b>))
→ #<standard-class (a-class b-class) 42E014EC0B> 

ECLOSではc-classが算出されましたが、STklosでは新たにメタクラスが生成されています。
なお、一度生成されたメタクラスはensure-metaclass-with-supersが保持していて、同様のメタクラスの組み合わせが既に存在すれば、それが使われるので重複して生成することはありません。

(defconstant <c>
  (stklos:defclass c (a b)
    ()))

(defconstant <d> (stklos:defclass d (a b) ()))

(class-name (class-of <c>))(a-class b-class)

(class-name (class-of <d>))(a-class b-class)

(eq (class-of <c>) (class-of <d>)) → t

(find-class (class-name (class-of <d>))) → #<standard-class (a-class b-class) 42E014EC0B>

まとめ

今回は、STklos系のメタクラスの自動算出を眺めてみました。
メタクラスのサブクラス方向を探しに行くECLOSとは違って、STklosは継承の最下層になっているメタクラスを集め、複数なら合成して返す、という感じでした。

ちょっと試してみた感じでは、開発時のようにクラスの再定義や削除、同じ定義が別名で定義されたり(実際には名前を付け替えているつもり)が頻発する環境だと、ECLOSが探索するサブクラスのメンテナンスがなおざりになることが多いので、算出された結果も開発者の直感からすると古い情報に基いてしまったりすることがあるようです。
まあ、正しくクラスを削除、再定義すれば良いのでそういうユーティリティを充実させるのも良いかもしれません。

STklos系は、動的にメタクラスを生成するのと、クラス順位リストがサブクラスに比べてきっちり更新されるので、トラブルらしいトラブルには遭遇していません。

さて、どちらの方式が便利なのか……。 しばらく両方の方式を日々比較検討試していきたいと思います。


HTML generated by 3bmd in LispWorks 7.0.0

ECLOSのメタクラス継承

Posted 2019-11-16 21:47:29 GMT

うまいタイトルが考えつかなかったので、「ECLOSのメタクラス継承」というタイトルになりましたが、ECLOSが提供するdefclass:metaclassオプション省略時のメタクラスの自動算出についてです。

なお、ECLOSについては、

に詳しいので参照してください。

ECLOSのメタクラスの自動算出アルゴリズム

Common Lispでは、カスタマイズしたメタクラスをdefclassで利用する際には明示的に:metaclassを指定しないといけないのですが、結構めんどうです。
上記文献によれば、ECLOSは、

  1. defclass:metaclassがあればそれを使う
  2. 指定がなければ、

    • ダイレクトスーパークラスの集合をSとする。
    • それらのメタクラスの集合をM(S)とする。
    • Sの要素のサブクラス関係の推移閉包の集合をM*(S)とする。
    • M*(S)の要素の共通部分をTとする。
    • Tがサブクラス関係の木を成していれば、その根を、さもなくば、standard-classをメタクラスとする

というアルゴリズムでこの問題を解決します。

いまいち解釈に自信がありませんが、とりあえずそのままコードにしてみました。
推移閉包を求めるコードは、Tiny CLOSのものが手頃だったので、これを利用しています。

(defpackage "31f04d2f-2dc5-523c-a129-1478406e4677" 
  (:use :c2cl))

(in-package "31f04d2f-2dc5-523c-a129-1478406e4677")

(defun build-transitive-closure (get-follow-ons) (lambda (x) (labels ((track (result pending) (if (endp pending) result (let ((next (car pending))) (if (member next result) (track result (cdr pending)) (track (cons next result) (append (funcall get-follow-ons next) (cdr pending)))))))) (track '() (list x)))))

(defun compute-metaclass (dsupers &key (default-metaclass-name nil)) (block nil ;;Let C be a class, if ;;a) the definition of C includes a (:metaclass M) option then M is the metaclass of C. (when default-metaclass-name (return (find-class default-metaclass-name))) (when (endp dsupers) (return (find-class 'standard-class))) ;;b) let S be the set of direct superclasses of C (let* ((| S | dsupers) (| M(S) | (mapcar #'class-of | S |)) ;;and let M*(S) be the set of transitive closures of the subclass relation applied to the elements of M(S) (| M*(S) | (mapcar (build-transitive-closure #'class-direct-subclasses) | M(S) |)) ;;and let T be the intersection of the sets composing M*(S) (| T | (reduce #'intersection | M*(S) |))) ;;then if T forms a tree according to the subclass relation (if (and (not (null | T |)) (every #'subtypep | T | (cdr | T |))) ;;then the root of T is the metaclass of C (car (reverse | T |)) ;;otherwise STANDARD-CLASS is the metaclass of C. (find-class 'standard-class)))))

(defpackage eclos (:use) (:export defclass))

(defun ensure-class-soft (name) (or (find-class name nil) (make-instance 'standard-class :name name)))

#+lispworks (defmacro eclos:defclass (name superclasses slots &rest class-options) (let* ((metaclass-name (cadr (find :metaclass class-options :key #'car))) (metaclass (compute-metaclass (mapcar #'ensure-class-soft superclasses) :default-metaclass-name metaclass-name)) (metaclass (case (class-name metaclass) (forward-referenced-class (find-class 'standard-class)) (otherwise metaclass)))) (clos::expand-defclass (class-prototype metaclass) (class-name metaclass) name superclasses slots class-options)))

動作確認

さて、定義できたので動作を確認していきます。

(defclass a-class (standard-class) ())
(defclass b-class (standard-class) ())
(defclass c-class (a-class b-class) ())
(defmethod validate-superclass ((c a-class) (s standard-class)) T)
(defmethod validate-superclass ((c b-class) (s standard-class)) T)

(defconstant <a> (defclass a () () (:metaclass a-class)))

(defconstant <b> (defclass b () () (:metaclass b-class)))

a-classb-classc-classとメタクラスを定義し、a-classをメタクラスとしたab-classをメタクラスとしたbを作成します。

ここで、

(defclass c (a b)
  ())

とした場合に、cのメタクラスが適切に求まれば良いのですが、上記で定義したcompute-metaclassで確認してみます。

(compute-metaclass (list <a> <b>))
→ #<lisp:standard-class c-class 4160314BC3> 

;; c-classを削除 (progn (reinitialize-instance (find-class 'c-class) :direct-superclasses nil) (setf (find-class 'c-class) nil))

;; メタクラスが求まらなかったので、デフォルト値のstandard-classを返す (compute-metaclass (list <a> <b>)) → #<lisp:standard-class standard-class 41A0997013>

;; メタクラス再作成 (defclass c-class (b-class a-class) ()) → #<lisp:standard-class c-class 40202BE5AB>

(compute-metaclass (list <a> <b>)) → #<lisp:standard-class c-class 40202BE5AB>

とりあえず大丈夫そうなので、eclos:defclassを使ってcを定義してみます。

(eclos:defclass c (a b)
  ())
→ #<c-class c 402072C593> 

まとめ

以上の動作をみて分かるように、メタクラスを多重継承する場合は、予め多重継承したメタクラスを用意しておく必要がありますが、用意さえしておけば勝手に見付けてくれるのが便利といえば便利かもしれません。
メタクラス継承の自動算出は、STklos、Guile、Gauche等のSTklos系OOPSでも行なわれています。
ECLOSとは異なったアルゴリズムが使われているので、次回はそちらを眺めたりCommon Lispで実装してみます。


HTML generated by 3bmd in LispWorks 7.0.0

slot-valueを排除する試み(2)

Posted 2019-11-10 19:19:05 GMT

前回はとりあえず、インスタンスのアクセスにslot-valueを使わないようなメタクラスを定義してみたりしましたが、slot-value排除を推進してインスタンスの初期化にも細工してみたいと思います。
slot-value経由でのアクセスの廃止=カプセル化という応用で考えてみます。

encapsulated-class

本当はインスタンスの初期化からもslot-valueを排除したかったのですが、気付いたらslot-valueを自作していた感があったので、slot-valueは初期化メソッドの内部でしか利用させないという制限を付けることにしました。
制限の手段としては安直にクラスに class-encapsulated-pを定義して管理します。
slot-value...系はclass-slotsの情報を元に動作することになるので、大元のclass-slotsに制限を掛けてやることにします。
今回は、class-encapsulated-pTの時はclass-slotsがエラーを発するようにしてみました。

encapsulated-object

オブジェクトの初期化をカスタマイズするには、standard-objectを派生させる必要があるので、encapsulated-objectを定義し、これの初期化をカスタマイズします。

カプセル化と継承についての問題で、アクセス制限をどう継承するか、というものがあるようですが、今回は継承側の勝手に任せることにしました。

ということでこんな動きになりました。

;; utils
(eval-when (:compile-toplevel :load-toplevel :execute)
  (setf (fdefinition 'a) #'make-instance))

(defconstant <zot> (defclass zot (encapsulated-object) ((a :initform 0 :accessor zot.a)) (:encapsulated-p T) (:metaclass encapsulated-class)))

(class-encapsulated-p <zot>) → T

(slot-value (a <zot>) 'a) !!! Illegal reflective access: #<encapsulated-class zot 4120259C13>.

(zot.a (a <zot>)) → 0

(defconstant <quux> (defclass quux (zot) ((x :initform 42) (y :initform 42) (z :initform 42)) (:encapsulated-p nil) (:metaclass encapsulated-class)))

(class-encapsulated-p <quux>) → nil

(with-slots (a x y z) (a <quux>) (list a x y z))(0 42 42 42)

定義

  • shared-initializeの定義はSBCLのものを参考にしました。

(cl:in-package cl-user)

(load "via-accessor-class")

(eval-when (:compile-toplevel :load-toplevel :execute) (ql:quickload :closer-mop) (when (find-package "a6acd6f5-46a2-51bf-83be-8596ac2d2f35") (delete-package "a6acd6f5-46a2-51bf-83be-8596ac2d2f35")))

(defpackage "a6acd6f5-46a2-51bf-83be-8596ac2d2f35" (:use :c2cl))

(in-package "a6acd6f5-46a2-51bf-83be-8596ac2d2f35")

(defmacro in-syntax (name) `(progn (defvar ,(intern name) (copy-readtable nil)) (setq *readtable* ,(intern name))))

(defmacro local-prefix-setup () `(set-macro-character #\~ (lambda (srm chr) (declare (ignore chr)) (intern (concatenate 'string (string 'encapsulated-) (string (read srm)))))))

(in-syntax "a6acd6f5-46a2-51bf-83be-8596ac2d2f35") (local-prefix-setup)

(define-condition illegal-reflective-access (simple-error) () (:report (lambda (condition stream) (format stream "Illegal reflective access: ~{~S~}." (simple-condition-format-arguments condition)))))

(defclass ~class (|3d0ecf39-dd6c-53f5-9672-58d5f5408cc6|:via-accessor-class) ((~p :initform T :initarg :encapsulated-p :accessor class-encapsulated-p)))

(defmethod ensure-class-using-class :around ((class ~class) name &rest initargs &key (~p T ~p-sup?)) (if (and ~p-sup? (consp ~p)) (apply #'call-next-method class name :encapsulated-p (car ~p) initargs) (call-next-method)))

(defmethod validate-superclass ((class ~class) (super standard-class)) T)

(defmethod class-slots :around ((class ~class)) (if (class-encapsulated-p class) (error 'illegal-reflective-access :format-arguments (list class)) (call-next-method)))

(defclass ~object (standard-object) ())

(defmethod shared-initialize ((instance ~object) slot-names &rest initargs) (flet ((initialize-slot-from-initarg (class instance slotd) (let ((slot-initargs (slot-definition-initargs slotd))) (loop :for (initarg value) :on initargs :by #'cddr :do (when (member initarg slot-initargs) (setf (slot-value-using-class class instance slotd) value) (return t))))) (initialize-slot-from-initfunction (class instance slotd) (let ((initfun (slot-definition-initfunction slotd))) (unless (or (not initfun) (slot-boundp-using-class class instance slotd)) (setf (slot-value-using-class class instance slotd) (funcall initfun)))))) (let* ((class (class-of instance)) (encapsulated-p (class-encapsulated-p class))) (unwind-protect (progn (setf (class-encapsulated-p class) nil) (loop :for slotd :in (class-slots class) :unless (initialize-slot-from-initarg class instance slotd) :do (when (or (eq t slot-names) (member (slot-definition-name slotd) slot-names)) (initialize-slot-from-initfunction class instance slotd)))) (setf (class-encapsulated-p class) encapsulated-p))) instance))

(defmethod finalize-inheritance :around ((class ~class)) (let ((encapsulated-p (class-encapsulated-p class))) (unwind-protect (progn (setf (class-encapsulated-p class) nil) (call-next-method)) (setf (class-encapsulated-p class) encapsulated-p))))

まとめ

slot-value排除の応用としてカプセル化も考えつつも、初期化でのslot-valueの扱いは日和るという中途半端な考察で、slot-valueを排除するのはなかなか面倒ということが分かっただけでした。

今回は、アクセス制限については、class-slotsでの制御としましたが、スロットをカスタマイズする方法もありそうです。

ちなみに、カプセル化の方法として、自由(uninterened)シンボルを使うというのがあるらしいですが、秘匿効果としては微妙な気がしています。
Pythonの命名規約の__foo__みたいなものでしょうか。

;;; importすれば簡単にシンボルは捕捉できる
(defclass foo ()
  (#:a #:b #:c))

(class-slots (find-class 'foo))(#<standard-effective-slot-definition #:a 40201BF60B> #<standard-effective-slot-definition #:b 40201BF673> #<standard-effective-slot-definition #:c 40201BF6DB>)

(mapc (lambda (s) (shadowing-import (slot-definition-name s))) (class-slots (find-class 'foo)))(#<standard-effective-slot-definition a 417024825B> #<standard-effective-slot-definition b 4170248753> #<standard-effective-slot-definition c 4170248C63>)

(setf (slot-value (make-instance 'foo) 'a) 42) → 42


HTML generated by 3bmd in LispWorks 7.1.2

slot-valueを排除する試み(1)

Posted 2019-11-06 19:47:19 GMT

オブジェクトへのアクセスは、slot-valueを使わず、アクセサ経由でを心掛けようとは良くいわれますが、今回は、MOPでslot-valueを回避できないかを探る試みです。

MOPには、standard-instance-accessのようなものがあるので、アクセスはstandard-instance-accessを直接使ってしまえば良かろうと思って下記のようなものを書いてみました。

アクセサがstandard-instance-accessでアクセスするインデックスを保持できれば良いだけなのですが、class-slots実行以降でしかインデックスは確定しないので、アクセサが別途インデックスを保持するように拡張し、インデックス確定後にアクセサに値を格納することにしました。

(in-package cl-user)

(eval-when (:compile-toplevel :load-toplevel :execute) (ql:quickload :closer-mop) (when (find-package "3d0ecf39-dd6c-53f5-9672-58d5f5408cc6") (delete-package "3d0ecf39-dd6c-53f5-9672-58d5f5408cc6")))

(defpackage "3d0ecf39-dd6c-53f5-9672-58d5f5408cc6" (:use :c2cl))

(in-package "3d0ecf39-dd6c-53f5-9672-58d5f5408cc6")

(eval-when (:compile-toplevel :load-toplevel :execute) (macrolet ((in-syntax (name) `(progn (defvar ,(intern name) (copy-readtable nil)) (setq *readtable* ,(intern name)))) (via-accessor-prefix-setup () `(set-macro-character #\~ (lambda (srm chr) (declare (ignore chr)) (intern (concatenate 'string (string 'via-accessor-) (string (read srm)))))))) (in-syntax "3d0ecf39-dd6c-53f5-9672-58d5f5408cc6") (via-accessor-prefix-setup)))

;; utils (eval-when (:compile-toplevel :load-toplevel :execute) (setf (fdefinition 'a) #'make-instance) (defun fintern (package control-string &rest args) (with-standard-io-syntax (intern (apply #'format nil control-string args) (or package *package*)))) (defmacro <defclass> (name supers slots &rest class-options) `(defconstant ,(fintern (symbol-package name) "<~A>" name) (defclass ,name ,supers ,slots ,@class-options))) #+lispworks (editor:setup-indent "<defclass>" 2 2 10) 'eval-when)

(defclass ~class (standard-class) ())

(defmethod validate-superclass ((class ~class) (super standard-class)) T)

(defclass ~accessor-method (standard-accessor-method) ((slot-location :initarg :slot-location :accessor ~accessor-method-location)))

(defclass ~reader-method (~accessor-method standard-reader-method) ())

(defclass ~writer-method (~accessor-method standard-writer-method) ())

(defun ~reader-method-function-maker (method) #+(or lispworks ccl) (lambda (arg &rest next-methods) (declare (ignore next-methods)) (funcall (lambda (instance) (standard-instance-access instance (~accessor-method-location method))) arg)) #+(or sbcl) (lambda (args next-methods) (declare (ignore next-methods)) (apply (lambda (instance) (standard-instance-access instance (~accessor-method-location method))) args)))

(defmethod initialize-instance ((method ~reader-method) &rest initargs) (apply #'call-next-method method :function (~reader-method-function-maker method) initargs))

(defun ~writer-method-function-maker (method) #+(or lispworks ccl) (lambda (val arg &rest next-methods) (declare (ignore next-methods)) (funcall (lambda (val instance) (setf (standard-instance-access instance (~accessor-method-location method)) val)) val arg)) #+(or sbcl) (lambda (args next-methods) (declare (ignore next-methods)) (apply (lambda (val instance) (setf (standard-instance-access instance (~accessor-method-location method)) val)) args)))

(defmethod initialize-instance ((method ~writer-method) &rest initargs) (apply #'call-next-method method :function (~writer-method-function-maker method) initargs))

(defmethod reader-method-class ((class ~class) direct-slot &rest args) (declare (ignore args direct-slot)) (find-class '~reader-method))

(defmethod writer-method-class ((class ~class) direct-slot &rest args) (declare (ignore args direct-slot)) (find-class '~writer-method))

(defmethod finalize-inheritance :after ((class ~class)) (let ((esds (class-slots class))) (dolist (dsd (class-direct-slots class)) (dolist (reader (slot-definition-readers dsd)) (let ((meth (find-method (ensure-generic-function reader :lambda-list '(x)) nil (list class) nil))) (when meth (setf (~accessor-method-location meth) (slot-definition-location (find (slot-definition-name dsd) esds :key #'slot-definition-name)))))) (dolist (writer (slot-definition-writers dsd)) (let ((meth (find-method (ensure-generic-function writer :lambda-list '(val x)) nil (list (find-class T) class) nil))) (when meth (setf (~accessor-method-location meth) (slot-definition-location (find (slot-definition-name dsd) esds :key #'slot-definition-name)))))))))

(defmethod shared-initialize :after ((class ~class) slot-names &rest initargs) (declare (ignore slot-names initargs)) (finalize-inheritance class))

おまけに速くなるのだろうか……

理屈では間接参照のslot-valueと違って直接参照のstandard-instance-accessの方が速くなる筈ですがどうでしょう。
さすがに処理系もslot-valueでのアクセスの最適化はしていると思いますが……。

(<defclass> foo ()
  ((a :initform 0 :accessor .a)
   (b :initform 1)
   (c :initform 2 :accessor .c))
  (:metaclass ~class))

(<defclass> bar (foo) ((d :initform 3 :accessor .d)) (:metaclass ~class))

読み出し速度

LispWorksだと今回の方式の方が若干速くなることもあったりなかったり。 ちなみにSBCL等だと余計なことをするよりslot-valueの方が速いようです……。

(time
 (let ((obj (a <foo>)))
   (dotimes (i (expt 10 6))
     (slot-value obj 'a))))

User time = 1.240 System time = 0.000 Elapsed time = 1.242 Allocation = 1296014992 bytes 0 Page faults Calls to %EVAL 18000041

(time (let ((obj (a <foo>))) (dotimes (i (expt 10 6)) (.a obj))))

User time = 1.100 System time = 0.000 Elapsed time = 1.095 Allocation = 1296011632 bytes 0 Page faults Calls to %EVAL 17000041

書き込み速度

LispWorksだと読み出し同様、今回の方式の方が若干速くなることもあったりなかったり。 ちなみにSBCL等でも若干速くなるかも。

(time
 (let ((obj (a <foo>)))
   (dotimes (i (expt 10 6))
     (setf (slot-value obj 'a) 42))))

User time = 7.260 System time = 0.000 Elapsed time = 7.259 Allocation = 3126471872 bytes 0 Page faults Calls to %EVAL 20000041

(time (let ((obj (a <foo>))) (dotimes (i (expt 10 6)) (setf (.a obj) 42))))

User time = 6.020 System time = 0.060 Elapsed time = 6.074 Allocation = 3118472872 bytes 0 Page faults Calls to %EVAL 22000041

今回のまとめ

明示的にstandard-instance-accessを使うようにしても、slot-value経由より遅くなることもあるようなので、もう少し詰めて対策しないと御利益はなさそうです。
標準のオブジェクトへのアクセスは処理系が結構最適化しているのですが、ユーザー定義のメタクラス等の派生物は標準から外れるので処理系が用意している最適化の適用外になってしまうことも多いようです。

なお今回は、アクセス方法でslot-valueを外す試みでしたが、インスタンス初期化まわりでもslot-valueは使われています。
どうもslot-valueを排除するのは簡単な話ではなさそう。

〜インスタンス生成篇へつづく〜


HTML generated by 3bmd in LispWorks 7.1.2

;|#

Posted 2019-11-02 19:13:57 GMT

;|# はかしこい

どうもiterateのバグを踏んでしまったようなのでソースを眺めていましたが、コード中の ;|# を目にしてこれは賢いなと以前から思っていたことを思い出しました。

#|
;; Optionally set up Slime so that C-c C-c works with #L
#+#.(cl:when (cl:find-package "SWANK") '(:and))
(unless (assoc "ITERATE" swank:*readtable-alist* :test #'string=)
  (bind ((*readtable* (copy-readtable *readtable*)))
    (enable-sharpL-reader)
    (push (cons "ITERATE" *readtable*) swank:*readtable-alist*)))
;|#

賢いというのは、#|;でコメントアウトしさえすれば、後ろの|#のメンテナンス(つまり消す)はしなくても良いというところ。

#|
(list 0 1 2)
;|#

(list 0 1 2)を復活したくなった →

;#|
(list 0 1 2)
;|#

Quicklisp中にどれくらい含まれているか検索してみましたが、iterateの他は、clazy、teepeedee2、で使われているくらいのようです。
案外少ないかも?

このブログはteepeedee2で運用されていますが、;|#は、teepeedee2のソースで最初に目にした気がします。


HTML generated by 3bmd in LispWorks 7.1.2

||パッケージの謎

Posted 2019-10-20 14:41:47 GMT

Common Lispのパッケージは名前を持ち、その名前は文字列となっています。
さて、それでは長さ0の文字列の場合、どのような挙動になるでしょうか。

ざっと調べてみました。

処理系 ""パッケージの扱い
LispWorks 7.1.2 ""パッケージ
Allegro CL 10.1 keywordパッケージ
Lucid CL 4.1 keywordパッケージ
CCL 1.11.5 ""パッケージ
CMUCL 21d ""パッケージ
CMUCL 17f ""パッケージ
SBCL 1.5.7 ""パッケージ
AKCL 1.619 ""パッケージ
GCL ""パッケージ
ECL ""パッケージ
MkCL ""パッケージ

Allegro CLと、Lucid CLは、(find-package "")でkeywordパッケージを返してきます。
パッケージ名の部分が空であればkeywordパッケージとする、という解釈もそれはそれで整合性がありそうではあります。

リーダーの読み取りの挙動が違っているのかと思いましたが、ちょっと調べてみたら、Allegro CLもLucid CLもニックネームに""が指定されているだけでした。

(package-nicknames :keyword)("")

ANSI CL規格を確認してみると、keywordパッケージのニックネームはnoneとなっていて拡張の余地がありそうな記述もないので、処理系の独自拡張ということになりそうです。

まとめ

なかなか面白い処理系拡張です。

(intern "X" "KEYWORD")
→ :x 
   :external 

よりも、

(intern "X" "")
→ :x 
   :external 

の方が直感的な気がしなくもありません。

(rename-package :keyword :keyword '(""))

によってお手軽に実現できますが、""パッケージが使えなくなるので注意しましょう(そんなパッケージ名使われないか)


HTML generated by 3bmd in LispWorks 7.1.2

Allegro CLのfixed-indexスロットアクセスを真似してみる

Posted 2019-10-14 19:51:18 GMT

先日、RedditでAllegro CLのstandard-objectのスロットのアクセスを高速化するオプションについての投稿があり、記事を読んでみたのですが、

第一感としては、何故standard-instance-accessを使わないのだろうか、というところでした。

それとは別にfixed-indexを新機能として紹介していますが、どうも以前にみたことあるなと思ったので、古いAllegro CL 4.3(1996)を確認してみましたが、やはり存在しました。 (パッケージは、closexclで移動した模様)
昔からの隠し機能が公になった、というところなのかもしれません。

;;; Allegro CL 4.3
(defclass foo ()
  ((a :initarg :a clos::fixed-index 2 :accessor foo-a)
   (b :initarg :b clos::fixed-index 3 :accessor foo-b)
   (c :initarg :c :accessor foo-c)))

(defvar *foo-inst* (make-instance 'foo :a 1 :b 2 :c 3))

(defvar *vec* (clos::std-instance-slots *foo-inst*))

USER(13): *vec* #(3 CLOS::..SLOT-UNBOUND.. 1 2) ...

fixed-index系 と standard-instance-access 系は何が違うのか

fixed-index指定は、オブジェクトのスロットの値を保持しているベクタの位置を直に指定するもので、それに加えて、指定されたfixed-indexの最大値とスロットの総数で大きい方をバックエンドのベクタのサイズにするようです。
指定されていない空き地は#<unbound-marker>のようなもので埋まります。

Allegro CLでもAMOPのstandard-instance-accessslot-definition-locationはサポートしており、fixed-indexの値とも連動しています。
fixed-indexが簡単に実装できないか、standard-instance-access & slot-definition-location 系の処理系を眺めてみましたが、大抵はスロット数のサイズのベクタを隙間なく並べ、先頭から番号を振るようです。

fixed-indexを真似してみる

スロットの値を保持するベクタの確保の方法が難という感じですが、とりあえずLispWorks等で真似できるか試してみます。

(ql:quickload :closer-mop))

(defpackage "4fef36ee-23f6-5dff-beb9-070053d5dbbb" (:use :c2cl))

(in-package "4fef36ee-23f6-5dff-beb9-070053d5dbbb")

;; utils (eval-when (:compile-toplevel :load-toplevel :execute) (setf (fdefinition 'a) #'make-instance) (defun fintern (package control-string &rest args) (with-standard-io-syntax (intern (apply #'format nil control-string args) (or package *package*)))) (defmacro <defclass> (name supers slots &rest class-options) `(defconstant ,(fintern (symbol-package name) "<~A>" name) (defclass ,name ,supers ,slots ,@class-options))))

(<defclass> fixed-index-slot-class (standard-class) ())

(defmethod validate-superclass ((c fixed-index-slot-class) (s standard-class)) T)

(<defclass> fixed-index-slot-definition (standard-slot-definition) ((fixed-index :initform nil :initarg fixed-index :accessor slot-definition-fixed-index)))

(<defclass> fixed-index-direct-slot-definition (fixed-index-slot-definition standard-direct-slot-definition) ())

(defmethod direct-slot-definition-class ((c fixed-index-slot-class) &rest initargs) (declare (ignore initargs)) <fixed-index-direct-slot-definition>)

(defmethod compute-effective-slot-definition ((class fixed-index-slot-class) name direct-slot-definitions) (declare (ignore name)) (let ((effective-slotd (call-next-method))) (dolist (slotd direct-slot-definitions) (when (typep slotd <fixed-index-slot-definition>) (setf (slot-definition-location effective-slotd) (slot-definition-fixed-index slotd)) (return))) effective-slotd))

(defmethod compute-slots ((class fixed-index-slot-class)) (let* ((slots (call-next-method))) (loop :for idx :from 0 :repeat (length slots) :do (let* ((s (find idx slots :key #'slot-definition-location))) (unless s (let ((s (find-if (lambda (x) (null (slot-definition-location x))) slots))) (when s (setf (slot-definition-location s) idx)))))) (sort (copy-list slots) #'< :key #'slot-definition-location)))

ちなみに、 effective-slot-definition-class周りを定義していませんが、スロットの順番を指定するだけなので、effective-slotfixed-indexの値を持たせていません。
(アロケーション〜初期化周りを実装するにあたって必要になりそうではあります。)

再現しようとした結果: 飛び飛びに値を保持するベクタをバックエンドにする方法が分からない

→ 方法が分かったので別記事を書きました: Allegro CLのfixed-indexスロット再現リベンジ

上記では、fixed-indexでスロット群の並び順を指定することはできたのですが、LispWorksではアロケーションされたベクタをAllegro CLのfixed-indexの要件を満すように読み書きする方法が分からず仕舞でした。
SBCLはソースが読めるので、そのうち確認してみたいところ。

とりあえず、Allegro CLのfixed-index記事の御題目としては高速化が目的のようなので、速度を計測してみます。

(<defclass> foo ()
  ((a :initarg :a fixed-index 1 :accessor foo-a)
   (b :initarg :b fixed-index 2 :accessor foo-b)
   (c :initarg :c :accessor foo-c))
  (:metaclass fixed-index-slot-class))

;; test
(defparameter *foo-inst* (a <foo> :a 1 :b 2 :c 3))

(declaim (inline std-instance-slots)) (defun std-instance-slots (inst) #+allegro (excl::std-instance-slots inst) #+sbcl (sb-pcl::std-instance-slots inst) #+lispworks (clos::standard-instance-static-slots inst))

(declaim (simple-vector std-instance-slots)) (defparameter *vec* (std-instance-slots *foo-inst*))

(locally (declare (optimize (safety 1) (space 1) (speed 3) (debug 0) (compilation-speed 0))) (defun p1 () (dotimes (i 10000000) (signum (foo-a *foo-inst*)))) (defun p2 () (dotimes (i 10000000) (signum (slot-value *foo-inst* 'a)))) (defun p3 () (dotimes (i 10000000) (signum (svref *vec* 1)))) (defun p4 () (dotimes (i 10000000) (signum (svref (std-instance-slots *foo-inst*) 1)))) (defun p5 () (dotimes (i 10000000) (signum (standard-instance-access *foo-inst* 1)))) )

(progn (time (p1)) (time (p2)) (time (p3)) (time (p4)) (time (p5)) )

LispWorksの場合

LispWorksではバックエンドのベクタをアクセスする方法がstandard-instance-accessなので、Allegro CLの記事のようにバックエンドをベクタを直接取り出してアクセスしたのとほぼ同一な結果になります。
standard-instance-accessがアクセサの60倍強となりAllegro CLの記事の御題目と似たものとなりました。

Timing the evaluation of (p1)

User time = 1.870 System time = 0.000 Elapsed time = 1.868 Allocation = 10816 bytes 0 Page faults ; (top-level-form 15) Timing the evaluation of (p2)

User time = 1.630 System time = 0.000 Elapsed time = 1.619 Allocation = 17584 bytes 0 Page faults ; (top-level-form 15) Timing the evaluation of (p3)

User time = 0.030 System time = 0.000 Elapsed time = 0.033 Allocation = 13184 bytes 0 Page faults ; (top-level-form 15) Timing the evaluation of (p4)

User time = 0.040 System time = 0.000 Elapsed time = 0.035 Allocation = 0 bytes 0 Page faults ; (top-level-form 15) Timing the evaluation of (p5)

User time = 0.040 System time = 0.000 Elapsed time = 0.039 Allocation = 0 bytes 0 Page faults

SBCLの場合

SBCLでは、アクセサもslot-valuestandard-instance-accessでのアクセスと同等まで最適化されるので、どれも速いという結果になりました。
良く考えればこれが理想では?

Evaluation took: (p1)
  0.050 seconds of real time
  0.050000 seconds of total run time (0.050000 user, 0.000000 system)
  100.00% CPU
  163,816,326 processor cycles
  0 bytes consed

Evaluation took: (p2) 0.044 seconds of real time 0.050000 seconds of total run time (0.050000 user, 0.000000 system) 113.64% CPU 145,140,144 processor cycles 0 bytes consed

Evaluation took: (p3) 0.020 seconds of real time 0.020000 seconds of total run time (0.020000 user, 0.000000 system) 100.00% CPU 68,159,274 processor cycles 1,712 bytes consed

Evaluation took: (p4) 0.022 seconds of real time 0.020000 seconds of total run time (0.020000 user, 0.000000 system) 90.91% CPU 71,779,470 processor cycles 0 bytes consed

Evaluation took: (p5) 0.021 seconds of real time 0.020000 seconds of total run time (0.020000 user, 0.000000 system) 95.24% CPU 69,904,809 processor cycles 0 bytes consed

まとめ

Allegro CLのfixed-index機能は面白いとは思うのですが、高速化ということに限っては、SBCLのように何も指定しなくても、 standard-instance-access を使ったのと同等の所まで最適化してくれる方が望ましいでしょう。
fixed-indexでは、特定の位置に特定のデータを配置したものをクラスを跨いで同一のアクセス方法で処理できたりしそうなので、もっと他の使い方があるのでは……、などと思ったり……。


HTML generated by 3bmd in LispWorks 7.0.0

eval-whenのおさらい

Posted 2019-10-07 21:08:30 GMT

Common Lispでは、実行時、コンパイル時、リード時、その他色々なタイミングでの評価を活用しますが、その制御に専ら使われるのが、eval-whenです。

といっても、大抵eval-whenを使わないか、(:compile-toplevel :execute :load-toplevel)を全部付けるかです。

実際の所は全部盛りを知っていれば問題ないのですが、入れ子になった場合や、全部盛り以外の組み合わせの挙動を確認してみようかなと思います。

指定の組み合わせを眺めてみる

こんな感じのコードで、適当なファイルに組み合わせを書き出します。

(setf (logical-pathname-translations "tem")
      '(("**;*.*.*" "/tmp/**/*.*")))

(with-open-file (*standard-output* "tem:ew.lisp" :direction :output :if-does-not-exist :create :if-exists :supersede) (pprint (cons 'progn (loop :for w :in '((progn) (eval-when (:execute)) (eval-when (:compile-toplevel)) (eval-when (:load-toplevel))) :collect `(,@w (eval-when (:compile-toplevel :execute :load-toplevel) (prin1 ',w) (terpri)) ,@(loop :for i :from 0 :for x :in '(nil (:compile-toplevel) (:compile-toplevel :load-toplevel) (:load-toplevel) (:compile-toplevel :execute) (:compile-toplevel :execute :load-toplevel) (:execute) (:execute :load-toplevel)) :collect `(eval-when ,x (prin1 '(,i ,x)) (terpri))))))))

書き出した内容

(progn
  (progn
    (eval-when (:compile-toplevel :execute :load-toplevel) (prin1 '(progn)) (terpri))
    (eval-when nil (prin1 '(0 nil)) (terpri))
    (eval-when (:compile-toplevel) (prin1 '(1 (:compile-toplevel))) (terpri))
    (eval-when (:compile-toplevel :load-toplevel) (prin1 '(2 (:compile-toplevel :load-toplevel))) (terpri))
    (eval-when (:load-toplevel) (prin1 '(3 (:load-toplevel))) (terpri))
    (eval-when (:compile-toplevel :execute) (prin1 '(4 (:compile-toplevel :execute))) (terpri))
    (eval-when (:compile-toplevel :execute :load-toplevel)
      (prin1 '(5 (:compile-toplevel :execute :load-toplevel)))
      (terpri))
    (eval-when (:execute) (prin1 '(6 (:execute))) (terpri))
    (eval-when (:execute :load-toplevel) (prin1 '(7 (:execute :load-toplevel))) (terpri)))
  (eval-when (:execute)
    (eval-when (:compile-toplevel :execute :load-toplevel) (prin1 '(eval-when (:execute))) (terpri))
    (eval-when nil (prin1 '(0 nil)) (terpri))
    (eval-when (:compile-toplevel) (prin1 '(1 (:compile-toplevel))) (terpri))
    (eval-when (:compile-toplevel :load-toplevel) (prin1 '(2 (:compile-toplevel :load-toplevel))) (terpri))
    (eval-when (:load-toplevel) (prin1 '(3 (:load-toplevel))) (terpri))
    (eval-when (:compile-toplevel :execute) (prin1 '(4 (:compile-toplevel :execute))) (terpri))
    (eval-when (:compile-toplevel :execute :load-toplevel)
      (prin1 '(5 (:compile-toplevel :execute :load-toplevel)))
      (terpri))
    (eval-when (:execute) (prin1 '(6 (:execute))) (terpri))
    (eval-when (:execute :load-toplevel) (prin1 '(7 (:execute :load-toplevel))) (terpri)))
  (eval-when (:compile-toplevel)
    (eval-when (:compile-toplevel :execute :load-toplevel) (prin1 '(eval-when (:compile-toplevel))) (terpri))
    (eval-when nil (prin1 '(0 nil)) (terpri))
    (eval-when (:compile-toplevel) (prin1 '(1 (:compile-toplevel))) (terpri))
    (eval-when (:compile-toplevel :load-toplevel) (prin1 '(2 (:compile-toplevel :load-toplevel))) (terpri))
    (eval-when (:load-toplevel) (prin1 '(3 (:load-toplevel))) (terpri))
    (eval-when (:compile-toplevel :execute) (prin1 '(4 (:compile-toplevel :execute))) (terpri))
    (eval-when (:compile-toplevel :execute :load-toplevel)
      (prin1 '(5 (:compile-toplevel :execute :load-toplevel)))
      (terpri))
    (eval-when (:execute) (prin1 '(6 (:execute))) (terpri))
    (eval-when (:execute :load-toplevel) (prin1 '(7 (:execute :load-toplevel))) (terpri)))
  (eval-when (:load-toplevel)
    (eval-when (:compile-toplevel :execute :load-toplevel) (prin1 '(eval-when (:load-toplevel))) (terpri))
    (eval-when nil (prin1 '(0 nil)) (terpri))
    (eval-when (:compile-toplevel) (prin1 '(1 (:compile-toplevel))) (terpri))
    (eval-when (:compile-toplevel :load-toplevel) (prin1 '(2 (:compile-toplevel :load-toplevel))) (terpri))
    (eval-when (:load-toplevel) (prin1 '(3 (:load-toplevel))) (terpri))
    (eval-when (:compile-toplevel :execute) (prin1 '(4 (:compile-toplevel :execute))) (terpri))
    (eval-when (:compile-toplevel :execute :load-toplevel)
      (prin1 '(5 (:compile-toplevel :execute :load-toplevel)))
      (terpri))
    (eval-when (:execute) (prin1 '(6 (:execute))) (terpri))
    (eval-when (:execute :load-toplevel) (prin1 '(7 (:execute :load-toplevel))) (terpri))))

書き出したコードを実際にコンパイルしたりロードしたりで実行してみます。

(progn
  (format T "~2&================ :execute~%")
  (load "tem:ew.lisp" :verbose nil)
  (format T "~2&================ :compile-toplevel~%")
  (compile-file "tem:ew.lisp" :verbose nil :print nil)
  (format T "~2&================ :load-toplevel~%")
  (load "tem:ew" :verbose nil :print nil))

結果の確認

上記の結果を評価タイミングごとに眺めていきます。
なお、-toplevelと付いていることからも想像できるように、:compile-load-はトップレベルに置かれないと評価されません。
また、eval-whenの中はトップレベルなので、入れ子にしてもトップレベル扱いです。

:execute

executeは、実行時の評価です。
式をevalしたり、コンパイルしていないソースファイルをloadした場合のフェイズといえるでしょう。

================ :execute
(progn)
(4 (:compile-toplevel :execute))
(5 (:compile-toplevel :execute :load-toplevel))
(6 (:execute))
(7 (:execute :load-toplevel))

(eval-when (:execute)) (4 (:compile-toplevel :execute)) (5 (:compile-toplevel :execute :load-toplevel)) (6 (:execute)) (7 (:execute :load-toplevel))

トップレベルの式、もしくは :executeが含まれたeval-whenの中だけ評価されているのが分かります。

:compile-toplevel

:compile-toplevelは、コンパイル時です。eval-whenの直下のフォームと入れ子になった:executeが評価されます。
ややこしいのが、コンパイル時には、eval-when:load-toplevel指定の中身も見る(=コンパイルする)ことですが、中身は見ますが、内側に:compile-toplevelを指定しないとコンパイル時には評価されません。

================ :compile-toplevel
(progn)
(1 (:compile-toplevel))
(2 (:compile-toplevel :load-toplevel))
(4 (:compile-toplevel :execute))
(5 (:compile-toplevel :execute :load-toplevel))

(eval-when (:compile-toplevel)) (4 (:compile-toplevel :execute)) (5 (:compile-toplevel :execute :load-toplevel)) (6 (:execute)) (7 (:execute :load-toplevel))

(eval-when (:load-toplevel)) (1 (:compile-toplevel)) (2 (:compile-toplevel :load-toplevel)) (4 (:compile-toplevel :execute)) (5 (:compile-toplevel :execute :load-toplevel))

:load-toplevel

:load-toplevelは、コンパイル済みのファイルであるfaslをロードした場合の評価フェイズです。
ロードというと色々ややこしいので、以降、fasloadと呼びます。
fasloadの場合は、:load-toplevelを入れ子にすれば、:load-toplevelの中は評価しますが、:executeの中身はみません。
上述のように:compile-toplevelは入れ子にしても機能しますが、それはコンパイル時に評価されるものなのでfasload時には評価されません。

================ :load-toplevel
(progn)
(2 (:compile-toplevel :load-toplevel))
(3 (:load-toplevel))
(5 (:compile-toplevel :execute :load-toplevel))
(7 (:execute :load-toplevel))

(eval-when (:load-toplevel)) (2 (:compile-toplevel :load-toplevel)) (3 (:load-toplevel)) (5 (:compile-toplevel :execute :load-toplevel)) (7 (:execute :load-toplevel))

応用の考察

マクロ展開時限定で何かを評価するには

マクロはコンパイル時に展開されますが、実行時でも展開される可能性はある(インタプリタ動作の場合)ので下記のようになるでしょうか。
fasloadではコンパイル済みの筈なので、マクロ展開が起きることはありません。

(eval-when (:compile-toplevel :execute)
  ....)

マクロ展開時限定で何かしたいことがあれば……ですが。

defpackageのシンボル汚染問題を解消する

defpackage展開用のパッケージを作成して、コンパイル時のみの評価とすれば、fasload時には展開用のパッケージは存在しなくても良いことになります。

;;; tem:zzz.lisp ファイル
(in-package :cl-user)

(eval-when (:compile-toplevel) (defpackage "bfa90b48-5531-5245-9256-8dfb8d9119f3" (:use :cl)) (in-package "bfa90b48-5531-5245-9256-8dfb8d9119f3"))

(defpackage foo (:use cl) (:intern a b c))

(compile-file "tem:zzz")
(delete-package "bfa90b48-5531-5245-9256-8dfb8d9119f3")
(load "tem:zzz")

(list (find-symbol "A" :cl-user) (find-symbol "B" :cl-user) (find-symbol "C" :cl-user) (find-symbol "A" :foo))(nil nil nil foo::a)

良く考えれば、コンパイル時にdefpackageによって使われたシンボルも、別のイメージにfasloadした時には居なくても良いので、cl-userで書いたのと大した違いはないですね。
そう考えると、defpackageのシンボル汚染問題もコンパイル時のイメージ限定なのかなと。

まとめ

はまり所としては、

  • :load-toplevelの中の:compile-toplevelがコンパイル時に評価されるというのがややこしい
  • loadという関数名と、:load-toplevelという名前が誤解を招く

    • loadlispファイルを読み込めば:execute
    • loadfaslファイルを読み込めば:load-toplevel

位でしょうか。

昔のLispでは、faslを読むのにはfasloadという専用関数が使われ、コンパイルしていないファイルにはloadを使ったりしていたようですが、Common Lispでloadに一本化されたようですね。

以上、eval-whenの考察でした。


HTML generated by 3bmd in LispWorks 7.0.0

NILのソース発掘される!

Posted 2019-10-06 16:39:24 GMT

伝説の処理系であるNILですが、先日ソースが発掘され、Software Preservation Groupで公開されたようです。ありがたや!

このブログでもNILについて何度か記事を書いていますが、要約すれば、MITがMACLISPの後継として作ったLISP処理系で、Common Lispの先祖の一つでありつつ後にNILもCommon Lisp化した処理系です(ややこしい)

NILの概要については、

あたりが一番まとまった記事かなと思います。

ソースを眺める

早速ソースを眺めてみましたが、雑感をメモしておこうかなと思います。

  • LOOPが多用されている。

    • プリミティブなものもLOOPで書かれている(CARCDRMAPCAR…)
    • 本当に多用されているが、LOOPのメンテナであるGSB氏が書いているからかもしれない。
  • FEATUREPがある
  • Flavorsが組み込み

    • Lisp Machine Lisp、MACLISPの実装ともちょっと違うっぽい
  • ハッシュテーブルがFlavorsで実装されている

    • Lisp Machine Lispも同じく(Flavorsよりハッシュテーブルの方が後で導入されたから?)
  • IOもFlavors実装が中心

    • Lisp Machine Lispも同じく
  • #Tがある(真値)
  • 謎の *パッケージがある。

    • 読みは“STAR”らしい。システムの定数が多い。用途未詳。
  • 階層パッケージが標準(Lisp Machine Lispと同様)
  • FLEXURESがある(スペシャル変数のクロージャー)
  • Extendの定義がある(Flavorsとも違うOOPS)
  • Patch Systemがある。
  • CGOLが内蔵されている

    • MACSYMAユーザーを意識してだろうか
  • TAGBODYの定義でタグ環境の表現にFlavorsが使われている
  • パッケージはattribute list(-*- ... -*-でお馴染み)で指定するらしい
  • コンパイラの名前は H らしい。

    • "This is NIL including the H compiler"
  • NIL版のEmacsであるSteveが同梱
  • LSBが同梱(MACLISP系処理系のポータブルレイヤー&文書化システム)
  • デモプログラムにMYCIN、OPS5、YAQ(Prolog)、FRL(フレーム言語)が同梱
  • (lisp-implementation-type) → "NIL, MIT Common Lisp" らしい

副次的ですが、これまで謎だったLSBシステムのコードが発掘されたというのは結構嬉しいです。

全体的なコードに印象ですが、Lispマシングループとは一味違いつつ、MACLISP寄りでありつつもちょっと違う、という感じでしょうか。

等々、他にも沢山面白そうなところはありますが、今後じっくり眺めていきたいと思います。

関連記事


HTML generated by 3bmd in LispWorks 7.0.0

ハッシュテーブルのキーとしてリストを使う

Posted 2019-09-30 19:51:28 GMT

こちらのエントリーを読んでいて、本筋とはちょっと関係ないのですが、リストに対してのsxhashの返り値が特定の長さからは同じ値を返すということについて興味を持ったので手元の処理系で調べてみました。

調べるのに使ったコードは、下記のようなものです

(loop :for i :from 0 :when (= (sxhash (make-list i)) (sxhash '#0=(nil . #0#))) :return i)

各処理系でリストの sxhash のハッシュ値が区別できなくなる地点

処理系 区別できなくなる地点
LispWorks 7.1.2 14以降
Allegro CL 10.1 14以降
Lucid CL 4.1 9以降
CCL 1.11.5 7以降
CMUCL 21d 7以降
CMUCL 17f 7以降
SBCL 1.5.7 5以降
AKCL 1.619 4以降
GCL 4以降
ECL 3以降
MkCL 3以降

興味本位で、CADR system 78のLisp Machine Lisp(Common Lispの祖先)で試してみたところ、sxhashはどんな長さでも諦めないで計算してくれるようです。
また、循環リストを与えると停止しません。

Lisp Machine Lispと違って、Common Lispで上記のように特定の長さでハッシュ値の計算を打ち切ってしまうのは、sxhashが循環構造のオブジェクトについても停止することが要求されているからでしょう。

それにしても、ECLあたりは3つ目以降は区別できないのでリストをキーとして使うのは難しそうです。

まとめ

リストをハッシュテーブルのキーにしたいことは個人的にはこれまで無かったのですが、リストがキーになっているのを目にしない理由もなんとなく分かった気がします。


HTML generated by 3bmd in LispWorks 7.1.2

macOSのLispWorks 7.1でgtkを使う

Posted 2019-09-09 20:09:30 GMT

結論: macOSのLispWorks 7.1でgtkを使うにはfinkのgtk+2を使う

macOSのLispWorks 7.1をX11 gtk+2のGUIで使おうと色々と試行錯誤していましたが、finkのgtk+2であれば使えばどうにか使えることが分かりました。
何故finkなのかというと、

  • brewでは、XQuartzのgtkが入るのでNG(LispWorksが対応していない)
  • macportsのx11-gtkだとLispWorksのフォント周りがおかしくなるので使えない

ので消去法でfinkなのですが、他のパッケージシステムで上手く動かす方法を探求するのも骨が折れるので、finkを導入することで手を打つのが吉でしょう。
macOS版LispWorksのgtk版自体がおまけで付いてきているような感じなのですが、果してgtk版のユーザーっているのでしょうか。

LispWorks 7.1 macOS gtk + fink のセットアップ

macOS LispWorks 7.1/gtk のインストール

macOS版LispWorksのgtk版は、デフォルトではインストールされません。インストーラにgtk版インストールのオプションがあるので有効にしてインストールしましょう。

fink

finkも最近勢いがないようですが(昔からか)、現時点で最新のmacOS 10.14.6でも使えます。
ただ、brewやportsのような手軽さでインストールすることはできないようです。
下記のリンクを参考にソースインストールを実行しますが、インストールにはJDKが必要です(JREではなく)

JDKを導入した後に、配布されているhelper scriptを実行し、質問にポチポチ答えて行けば、一時間程でインストールできるでしょう。

gtk+2の導入

fink自体のアップデートもできたら、gtk+2のインストールします。

$ /sw/bin/fink install gtk+2

一発でOKですが、macOS 10.14だとバイナリ配布はしていないようなので、暫しビルドに時間が掛ります。

gtk版LispWorksの起動

$ LD_LIBRARY_PATH=/usr/lib:/sw/lib /Applications/LispWorks\ 7.1\ \(64-bit\)/lispworks-7-1-0-amd64-darwin-gtk

のように起動すればOKです。
デフォルトでは起動時にGUI起動してこないので、(env:start-environment)する必要があります。
自動起動したい場合は、初期化ファイルで、

#+(and macosx gtk)
(env:start-environment)

とでもしておけば良いでしょう。

まとめ

macOS版LispWorksをgtkについては、マニュアルにもlibgtk-quartzではなく、libgtk-x11を使えという注意書きがある程度で参考文献が殆どありません。
動いてしまえば、Linux等の通常のgtk版と変わりなく使えるので興味のある方は試してみてはいかがでしょうか。


HTML generated by 3bmd in LispWorks 7.1.2

defpackageでの#:symbolについて

Posted 2019-08-15 15:25:34 GMT

Common Lispのdefpackageというかパッケージ関係の関数全般ですが、internexportするシンボルの名前の表記にstring designatorが使えるので、

(defpackage "FOO" 
  (:use "CL")
  (:export "FOO" "BAR" "BAZ"))

とシンボル名を文字列で書かずにシンボルで書くことも可能です。

(defpackage foo
  (:use cl)
  (:export foo bar baz))

この場合、シンボル名が使われるので、

(defpackage #.(string 'foo) 
  (:use #.(string :cl))
  (:export . #.(mapcar #'string '(foo #:bar baz))))

のようなことになっていると考えれば良いでしょう。

このstring designatorでのシンボルの表記に各人割とこだわりがみられるので考察してみることにしました。

文字列そのまま

"FOO""BAR"等とそのまま書く流儀です。たまに通な人がこの方式で書いてることがあります。

メリットとされること

  • 余計なシンボルがインターンされない

デメリットとされること

  • リーダーの読み取りケースを変更した環境では上手い具合に馴染まない

しかし、そんな特殊な状況のことを考えてコーディングする必要ってあるんですかね?

シンボル

foobar等とそのまま書く流儀です。
一番すっきりしてて良さそうですが、案外少ないです

メリットとされること

  • すっきりしている
  • リーダーのケースの設定が変化しても良い感じに馴染む(と思われている)

デメリットとされること

  • defpackageしたパッケージに余計なシンボルがインターンされる

defpackageは、大抵cl-userでされることが多いですが、cl-userは作業用パッケージなので、多少汚染されても良いんじゃないかという気もしますね。

キーワードシンボル

:foo:bar等と書く流儀です。
よく見かける流儀です。

メリットとされること

  • エディタで良い感じに色付けされる
  • パッケージ系関数で一貫した記述ができる(defpackage :foo)(make-package :foo) vs (defpackage #:foo)(make-package '#:foo) 等々
  • リーダーのケースの設定が変化しても良い感じに馴染む(と思われている)

デメリットとされること

  • キーワードパッケージに余計なシンボルがインターンされる

キーワードパッケージが汚染されると開発環境のキーワード補完でゴミが補完されることが多くなるので、案外cl-userが汚染されるより嫌かもしれないですね。

自由(uninterned)シンボル

#:foo#:bar等と書く流儀です。
これも割と見かける流儀です。 自由(uninterned)シンボルは、不要になったらGCされるので、細かいことを気にする人に好まれています。

メリットとされること

  • 余計なシンボルがインターンされない
  • エディタで良い感じに色付けされる
  • リーダーのケースの設定が変化しても良い感じに馴染む(と思われている)

デメリットとされること

  • #:がウザい

第四の方法を考えてみた

見た目がウザいので自由(uninterned)シンボルで書きたくない、パッケージも汚染したくない、というのを両立させるとしたら、一時パッケージを作成し、その中でdefpackageすれば良いでしょう。

(defpackage "FOO-META" (:use))

(in-package "FOO-META")

(cl:defpackage foo (:use cl) (:export foo bar baz))

(cl:in-package "CL-USER") (delete-package "FOO-META")

SBCLならこんな風に書けたりもします。

foo-meta::
(cl:defpackage foo
  (:use cl)
  (:export foo bar baz))

まあ、でもめんどくさいですね。

まとめ

ファイルをロードする時に、暗黙のうちに*package*cl-user*readtable*を標準のリードテーブルであると仮定しているコードは、Quicklispの大半を占めますが、それに起因するバグも思いの外多いです(Quicklispのパッケージを1000パッケージ位ロードしてみると体験できます)

作業用パッケージ(とリードテーブル)を作成して、そこでdefpackageするのが吉なのかなあ等々考えていますが、作業用パッケージを作成するなら、余計なシンボルのインターンについても考えなくて良さそうですね。

ちなみにこの記事を書くにあたって、文字列、シンボル、キーワード、自由(uninterned)シンボルの大き目のリストを作成して読み取りの速度を計時してみましたが、大抵の処理系ではシンボルや文字列が速く、一番遅いのは自由(uninterned)シンボルのリストでした。
読み取りスピード的にも普通のシンボルで書くのが有利っぽいですが、極端なことをしない限りは有意な差にはならないでしょう。

以上、特にまとまりもない記事でした。


HTML generated by 3bmd in LispWorks 7.0.0

Common Lispでアリティの不整合をコンパイルエラーにする

Posted 2019-08-11 20:29:48 GMT

思えば、Common Lispでアリティ(引数の個数)の不整合でエラーを喰らうのは実行時が多い気がしますが、ANSI Common Lisp規格ではコンパイル時に弾くことってできないんでしょうか。

……と思ってHyperSpecにあたってみましたが、コンパイル時にアリティの不整合を検知した場合には、エラーにしてしまうコンパイラがあっても良さそうではありました。

Common Lispは動的言語なので、実行時でも関数等の再定義が可能ですが、上記の3.2.2.3 Semantic Constraintsを眺める限りでは、どちらかといえば、コンパイラ動作の方に重きを置いているように見え、再定義されなくても良い場合を幾つか挙げています。

逆に再定義が保証されることを主として考えるとすると、少なくともnotinline宣言がついてない場合の再定義は、関数が実行時に確実に置き換わることは期待できなさそうです。

また、コンパイラ/インタプリタ動作の整合性とは別に、アリティのチェックについても記載がありますが、エラーは、実行時もしくはコンパイル時に挙げるとあります。

上記は、関数呼び出し時のエラーについての規定なので、基本的に実行時エラーだけで良さそうにも思えますが、マクロ展開等も考慮するとコンパイル時も含めないといけないのでしょうか。
ともあれ、safe callの観点からもコンパイル時に検出することも可能ではありそうです。

ちなみに、組み込み関数はsafe callの観点からすると、アリティの不整合はコンパイル時にエラーにできそうです。

処理系の実際を確認する

呼出しのアリティに不整合があった場合にコンパイルエラーになっても良さそうではあるのですが、実際の処理系の挙動を確認してみました。

このようなファイルをコンパイルして、

(defun foo (x y)
  (list x y))

(defun bar (x y) (foo x))

下記のように実行してみます。

(bar 1 2)
>>> invalid number of arguments: 1

処理系のメジャーなところは一通り確認してみましたが、コンパイルエラーにする処理系はECLのみのようで、他は警告は出すもののコンパイルは通し、faslをloadして実行したら当然実行時エラーです。
まあ大体Common Lispってこんな感じの動作でしたね、というところ。
むしろECLの動作のほうが意外かもしれません。

処理系 compile-file
SBCL 警告あり
CLISP 警告あり
LispWorks 警告あり
Allegro CL 警告あり
Clozure CL 警告あり
ECL コンパイルエラー
MkCL 警告なし
Clasp 警告なし
CMUCL 警告あり

アリティの不整合をコンパイルエラーにしたい

さて、規格上はコンパイル時にアリティの不整合を検出してエラーにしても良さそうだけれど、実際のところデフォルトでそういう挙動をする処理系は、殆ど存在していないことが分かりました。

コンパイル時でもなんでもできるCommon Lispなので、工夫はあれこれできそうですが、とりあえずコンパイラマクロを試してみましょう。
とりあえずは、何もしないコンパイラマクロを定義するのみですが、展開時に引数チェックでエラーになることが期待できます。

(defun foo (x y)
  (list x y))

(define-compiler-macro foo (x y) `(foo ,x ,y))

(defun bar (x y) (foo x))

処理系 compile-file
SBCL 警告あり
CLISP コンパイルエラー
LispWorks コンパイルエラー
Allegro CL 警告あり
Clozure CL コンパイルエラー
ECL コンパイルエラー
MkCL 警告なし
Clasp コンパイルエラー
CMUCL 警告あり

軒並エラーになると予想していましたが、コンパイルが通ってしまうものもある様子。
これは、積極的にエラーにする他ないのかもしれません。
ということで下記のように書いてみました。

(eval-when (:compile-toplevel :load-toplevel :execute)
  (define-condition argument-mismatch (program-error)
    ((form :initarg :form :reader argument-mismatch-form)
     (text :initarg :text :reader argument-mismatch-text))
    (:report (lambda (c s)
               (format s
                       "~A:~%~S~%"
                       (argument-mismatch-text c)
                       (argument-mismatch-form c))))))

(defun foo (x y) (list x y))

(define-compiler-macro foo (&whole w &rest args) (etypecase (length args) ((eql 2) w) ((integer * 1) (error 'argument-mismatch :text "Too Few Arguments" :form w)) ((integer 3 *) (error 'argument-mismatch :text "Too Many Arguments" :form w))))

(defun bar (x y) (foo x))

しかし、SBCL、Allegro CLはコンパイルを通す様子。

処理系 compile-file
SBCL 警告あり
CLISP コンパイルエラー
LispWorks コンパイルエラー
Allegro CL 警告あり
Clozure CL コンパイルエラー
ECL コンパイルエラー
MkCL 警告なし
Clasp コンパイルエラー
CMUCL 警告あり

SBCLでは、トラップしたいなら、*break-on-signals*を設定しろと警告が出るので、SBCL、Allegro CL、CMUCLはそういうポリシーなのでしょう。

; caught WARNING:
;   Error during compiler-macroexpansion of (FOO X). Use *BREAK-ON-SIGNALS* to
;   intercept.
;   
;    Too Few Arguments:
;   (FOO X)

まとめ

Common Lispでアリティの不整合をコンパイルエラーにする方法を探ってみましたが、

  • アリティの不整合のコンディションを作成
  • *break-on-signals*に適宜設定
  • コンパイラマクロで引数チェック

の組み合わせで大抵の処理系では実現できそうです。

ちなみに、型の不整合もチェックしたいところですが、SBCLであれば、今回のコンパイラマクロの手法を応用して、deftransformあたりを使えばできなくもなさそう。


HTML generated by 3bmd in LispWorks 7.0.0

1960年の処理系 元祖LISP 1.5 を試してみる

Posted 2019-07-14 16:41:02 GMT

先日、LISP 1.5をお題にした、n月刊ラムダノート Vol.1, No.2(2019) / LISP 1.5の風景(川合史朗)が刊行されましたが、この稀にしか来ないLISP 1.5の波に乗らざるを得ない!!ということで、レトロコンピューティング好きの私は、十二年前に書いたLISP 1.5のエミュレータの記事をアップデートすることにしました。
(そういえばそもそも私はレトロコンピューター熱が高じてLispを始めたのでした)

上記記事ではエミュレータ関係のリンク切れ等が多くて、記事の内容を再現できない状態だったので、その辺りを修正しました。

なお、「LISP 1.5の風景」では、Gauche上にMeta*LISPというLISP 1.5の処理系を実装しつつLISPの原初を紐解いていくという内容なので、とてもお勧めです。

1960年の処理系 元祖LISP 1.5 を試してみる

先日は、PDP-1のエミュレータで、PDP-1 Lispを動かしてみましたが、やっぱり元祖である、LISP 1.5も動かしてみたいところ。
でも、さすがに、50年前のIBM7094の環境はかなり厳しいだろうと思いつつ、調べてみたら、なんとこれも簡単に動かせるようにまとめている方がいました。
約60年前の環境が再現できるというのは色々な意味で凄い。まず、データが保存されていて、今日のコンピュータで読めるってのが凄い。

lisp 1.5の環境がまとめられたファイルがあるのでダウンロードし、simhのibm7094で実行できるようにすればOKです。

手短にまとめると、準備するものとしては、

が必要です。

simhのi7094は、Debian GNU/Linuxや、Ubuntuであれば、

$ sudo apt install simh

でインストール可能です。

次にLISP 1.5環境の準備ですが、

$ tar xvf lisp15.tar.gz
$ cd lisp15
$ tar xvf utils-1.1.8.tar.gz
$ cd utils && make

とし、lisptape.ini! txt2bcd -s %1 scratch/lisp.job.mtというのを、! utils/txt2bcd -s %1 scratch/lisp.job.mtに書き換えます。
(txt2bcdをパスの通った所に設置しても良いですが)

上記のファイルを揃えて設定すれば、IBM 7094でLISP 1.5のバッチジョブを流せます。
しかし、若干面倒なので、Emacsのcompileを使って、バッチ処理のシェルスクリプトを起動させてみることにしました。
とはいえ、適当なでっち上げなので、試したい方は各自作成されると良いと思います。
自分の環境では、lisp1.5:loadというcompileをラップした関数と、シェルスクリプトの組み合わせで*compilation*バッファに結果が表示されるようにしてみました。

バッチ用シェルスクリプト(load-lisp1.5)

#!/bin/sh

INFILE=$1 EMUDIR=/l/lisp-1.5 # lisp 1.5セットのディレクトリを指定 TEM=cur.job

cd $EMUDIR pwd [ -f sys.log ] && rm sys.log printf " TEST FOO\n\n" > $TEM cat $INFILE >> $TEM printf "\n\nSTOP))) ))) ))) )))\n FIN END OF LISP RUN\n" >> $TEM i7094 lisptape.ini $TEM cat sys.log

Emacsのcompile関数をラップしたバッチ処理を呼び出す関数

(defun lisp1.5:load ()
  (interactive)
  (let ((compile-command (concat "~/bin/load-lisp1.5 " (buffer-file-name))))
    (compile compile-command)))

これで若干対話的にコードが書けるようになったので、適当に試してみます。

reverseとmapcarを作ってみる

define ((
(r1 (lambda (m l)
      (cond ((null l) m)
        ((quote t) (r1 (cons (car l) m) (cdr l))))))

(reverse (lambda (u) (r1 () u)))

(mapcar (lambda (lst fn) (prog (l res) (setq l lst) again (cond ((null l) (return (reverse res)))) (setq res (cons (fn (car l)) res)) (setq l (cdr l)) (go again)))) ))

mapcar((1 2 3 4) (quote (lambda (x) (plus 10 x))))

cond(((quote t) (print (quote hello))))

今日からみると色々変ったところが多いのですが、まず、トップレベルで関数に外側の括弧が付いてなかったりします。
これは、evalquoteと呼ばれるらしいですが、evalで評価するか、applyで評価するかと考えれば良い、と The Evolution of Lisp に書いてました。ちなみにInterlispでは、evalquoteの形式でコーディングできます。
それで、マニュアルを見る限りではreverseは標準で付いてくるっぽいのですが、見付からないので作ってみました。
mapcarの引数の順番が関数とリストとで逆ですが、元々は、リスト→関数の順番だったようです。これまたInterlisp系では、伝統に則ってCommon Lisp(Maclisp系)とは逆です。

結果

MTA: unit is read only
LPT: creating new file

HALT instruction, PC: 10524 (TRA 10523) Goodbye TAPE SYSTMP,B3

B3 IS NOW LISP SYSTMP. TAPE SYSTAP,A4

A4 IS NOW LISP SYSTAP. TAPE SYSPOT,A3

A3 IS NOW LISP SYSPOT. TAPE SYSPPT,A7

A7 IS NOW LISP SYSPPT. TEST WHATEVER

THE TIME ( 0/ 0 000.0) HAS COME, THE WALRUS SAID, TO TALK OF MANY THI NGS ..... -LEWIS CARROLL- EVALQUOTE OPERATOR AS OF 1 MARCH 1961. INPUT LISTS NOW BEING READ.

THE TIME ( 0/ 0 000.0) HAS COME, THE WALRUS SAID, TO TALK OF MANY THI NGS ..... -LEWIS CARROLL- FUNCTION EVALQUOTE HAS BEEN ENTERED, ARGUMENTS.. DEFINE

(((R1 (LAMBDA (M L) (COND ((NULL L) M) ((QUOTE T) (R1 (CONS (CAR L) M) (CDR L)))))) (REVERSE (LAMBDA (U) (R1 NIL U))) ( MAPCAR (LAMBDA (LST FN) (PROG (L RES) (SETQ L LST) AGAIN (COND ((NULL L ) (RETURN (REVERSE RES)))) (SETQ RES (CONS (FN ( CAR L)) RES)) (SETQ L (CDR L)) (GO AGAIN))))))

END OF EVALQUOTE, VALUE IS .. *TRUE*

FUNCTION EVALQUOTE HAS BEEN ENTERED, ARGUMENTS.. MAPCAR

((1 2 3 4) (QUOTE (LAMBDA (X) (PLUS 10 X))))

END OF EVALQUOTE, VALUE IS .. (11 12 13 14)

FUNCTION EVALQUOTE HAS BEEN ENTERED, ARGUMENTS.. COND

(((QUOTE T) (PRINT (QUOTE HELLO))))

HELLO

END OF EVALQUOTE, VALUE IS .. HELLO

THE TIME ( 0/ 0 000.0) HAS COME, THE WALRUS SAID, TO TALK OF MANY THI NGS ..... -LEWIS CARROLL- END OF EVALQUOTE OPERATOR FIN END OF LISP RUN

なんでか知りませんが、ルイス・キャロルの文言が引用されてたりします。
若干わかりづらいですが、END OF EVALQUOTE, VALUE IS ..の後が評価結果です。なんとなく良い味を醸し出しています。
やっぱり手近に処理系があって手軽に試せるというのは良い!

PDFのマニュアルもあるので、これを見ながらLISP 1.5を探索してみるのも面白いと思います。


HTML generated by 3bmd in LispWorks 7.0.0

ラムダリストでの複雑なパタンマッチ

Posted 2019-06-22 18:59:06 GMT

久々に2ch(5ch)のCommon Lispスレを眺めてみたら面白そうな質問が放置されているのをみつけました。

573デフォルトの名無しさん2019/06/15(土) 16:34:52.25ID:5WxVHbel
defmacroだとdestructuring bind?が使えて
(defmacro test ((a b &optional c) d)
(print (list a b c d))
nil)
(test (1 2) 4) => (1 2 NIL 4)
みたいに書けるけど、&optionalや&keyの後に書こうとしてもSBCLだとdefmacroを評価した時点でエラーになる
&restの後ろには一応書けるっぽい
必須引数と&restの所には書けるけど、&optionalと&keyの所には書けないという認識で良いのか?
もし&optionalの所に書けるなら書き方を教えてくれ 

若干質問の主語が不明瞭ですが、多分、&restや、&optional&keyの後に変数だけでなく再帰的な複合パタンが書けるのかという質問かなと思います。
端的にいうと規格で再帰的な複合パタンが利用できることが定義されているので、規格準拠の処理系なら書けます。

試しに書いてみると、

(defmacro foo (&optional ((a &rest b &key ((^c (c &optional (d "d" d?))) '("c") c?)) '("a") a?))
  `'(,a ,b ,c ,a? ,c? ,d ,d?))

(foo)("a" nil "c" nil nil "d" nil)

(foo (a ^c (c)))(a (^c (c)) c t t "d" nil)

(foo (a :c (c) :allow-other-keys T))(a (:c (c) :allow-other-keys t) "c" t nil "d" nil)

なお、&rest&optional&keyで変数でなく複合パタンを指定した場合、省略時の値がパタンに適合していることに留意する必要があります。


HTML generated by 3bmd in LispWorks 7.0.0

○○がLispであるか、そうでないかの簡単な線引き

Posted 2019-06-14 18:48:50 GMT

Rubyは、Lispである、いや違う。Schemeこそ至高のLisp、いやLispじゃない等々、「○○がLispであるか、そうでないか」は自転車置場の議論ネタとしては定番です。
個人的にこの10年位、MACLISP系方言を中心に色々なLispを眺めてきましたが、LispかLispでないかの簡単な判断基準があると思いはじめました。

言語名にLispと入っていればLisp

簡単な判断基準とは、「言語名にLispと入っていればLisp」です。
馬鹿馬鹿しい程単純な理屈ですが、それなりに個人的には納得感があります。

LISP 1.5を本流とすれば、それを継承せんとする言語は、○○Lispと名乗ってきました。
そこから外れるということは、何らかの分派を表明せんがため、ということが多いように思います。

例えば、Schemeは、Planner→Conniver→(Plasma)→Scheme(→Racket)という命名の流れを踏襲したというのもありますが、全面的なレキシカルスコープの採用等、既存のLispから訣別し新しい流れを作るという点で別の名前になった意味はそれなりに大きかったでしょう(当初はそうでなくても)。
近頃だと、Schemeの流れでRacketが分派しましたが、PLT Schemeから、Racket Schemeにならずに、Racketになったのも、そういった意思表明であると思います。

Schemeと同じく、Algolとの融合を図ってレキシカルスコープの採用や、Algol構文を軸に据えたものにLISP 2がありますが、これはLISP 1.5の流れを分派というより上書きしようとしたと考えられるので、これはこれでLISPを冠した命名の流れでしょう。結局こちらのLISPの流れは成功しませんでしたが。

翻ってLISP 1.5→MACLISP(LISP 1.6)→Lisp Machine Lisp→Common Lisp & Emacs Lisp→ISLISPは、Lisp 1.5から続く資産を活用することに腐心して来たわけですし、実際コードもほぼ修正なしで動きます(Emacsはエディタに特化している所があるので若干苦しいですが)。

newLISPなどは若干変わり種ですが、古来のLispがサポートしていたもののCommon Lispで消滅したfexprをサポートするなど、Common Lispとはまた違った古来のLispを継承している所はあります。

また、ClojureがClojure Lispとしなかったのも、Lispをバックグラウンドとした新言語という意味でしょう。

まとめ

何より設計者、コミュニティがLispと名乗りたいと思って言語にLispと付けているからには、なんらかの設計思想の継承を意図しているのでしょうし、別の名前にするからには、なんらかの訣別があると思いますから、一つの線引きの基準になるでしょう。

ちなみに、類似の話として、Lisp系言語でないものについて「○○は本質的にLisp、いや違う」等の議論ネタがありますが、Lispがプログラミング言語の進化/発明においてあまりにも源流に近すぎるため、影響を排除することが難しく、極言すると同時代に誕生したFortranやAlgol以外、今時の主流のパラダイムのどんな言語にでも成立してしまうので、ほぼ意味がない話かなと思っています。


HTML generated by 3bmd in LispWorks 7.0.0

SPARCプロセッサのLisp向けタグ命令の謎

Posted 2019-05-27 18:01:15 GMT

Sun(今やOracle)のSPARCプロセッサにはLisp向けにタグ命令が実装されている(いた)という話を耳にされたことはないでしょうか。

具体的には、TADDCCTSUBCC系の命令で、タグ付きポインタの演算を支援する機能です(ちなみに残念ながら現在では非推奨の機能らしい)。

それはともかく、ウェブを検索したら、当時のLucidだったEric Benson氏がこの機能についての質問に回答していたメールをみつけました。

Yes, the tagged arithmetic instructions were put in the SPARC architecture
for Lucid Common Lisp. If the low-order two bits of a Lisp object
reference are zero, it is a 30-bit immediate fixnum. If some of those
bits are non-zero, it may be a pointer to a floating point number or a
bignum (arbitrary-precision integer). Generic arithmetic is generally
optimized for the fixnum case, since the overwhelming majority of
arithmetic is performed on small integers. On many machines + is compiled
inline as

Test low order two bits of first operand. If nonzero, use general case. (Operand could be a float or bignum.) Test low order two bits of second operand. If nonzero, use general case. (Operand could be a float or bignum.) Add two operands. If overflow, use general case. (Result is a bignum).

On the SPARC this is done as one instruction (TADDCC) followed by a conditional branch rarely taken.

メールによると、SPARCのこの命令は、Lucid CLのために入ったらしいのですが、Lucidは、SunにCommon Lisp処理系をOEM提供しており、Sun Common Lispとして販売されていたりで、LucidとSunはかなり密接な関係でした。

時代的にも当時は第二次AIブーム末期で、エキスパートシステムやCAD等、高価なSymbolics等の専用マシン上で稼動していたLispベースのアプリケーションを比較的廉価なワークステーション上でも動したいというニーズも高かった頃です。

Lucid Common Lispではどう活用しているのか

Lucid CLのために命令が導入されたのはよしとして、実際にどんな感じで活用されていたのか確認してみましょう。

とりあえず、2引数のfixnumの足し算をコンパイルしてdisassembleしてみます。

> (proclaim '(optimize (compilation-speed 0) (speed 3) (safety 3)))
t
> (disassemble (compile nil '(lambda (x y) (declare (fixnum x y)) (the fixnum (+ x y)))))
;;; You are using the compiler in PRODUCTION mode (compilation-speed = 0)
;;; If you want shorter compile time at the expense of reduced optimization,
;;; you should use the development mode of the compiler, which can be obtained
;;; by evaluating (proclaim '(optimize (compilation-speed 3)))
;;; Generation of full safety checking code is enabled (safety = 3)
;;; Optimization of tail calls is enabled (speed = 3)

        cmp         %u0, 8
        tne         16
        taddcctv    %in0, %in1, %loc0
        move        %loc0, %in0
        jmpl        %0, %ra + 8
        restore     %0, 4, %u0
nil

taddcctv(Tagged Add, modify icc and Trap on Overflow)というのがお目当ての命令ですが、探してみてもどうも専らtaddccではなく、tv付きが使われるようです。

safety 0にしてみると、

> (proclaim '(optimize (compilation-speed 0) (speed 3) (safety 0))) 
t
> (disassemble (compile nil '(lambda (x y) (declare (fixnum x y)) (the fixnum (+ x y)))))
;;; You are using the compiler in PRODUCTION mode (compilation-speed = 0)
;;; If you want shorter compile time at the expense of reduced optimization,
;;; you should use the development mode of the compiler, which can be obtained
;;; by evaluating (proclaim '(optimize (compilation-speed 3)))
;;; Generation of runtime error checking code is disabled (safety = 0)
;;; Optimization of tail calls is enabled (speed = 3)

        taddcctv    %in0, %in1, %loc0
        move        %loc0, %in0
        jmpl        %0, %ra + 8
        restore     %0, 4, %u0
nil

となり、アリティのチェックが省略されるようです。

しかし、CMUCLでも活用されていた

さすがLucid CL用に用意されただけあるなと思いましたが、CMUCL 17fのdisassemble結果を眺めたりしていた所、CMUCLでも活用されているのをみつけてしまいました。

CMU Common Lisp 17f, running on sun4
Send bug reports and questions to cmucl-bugs@cs.cmu.edu.
Loaded subsystems:
    Python 1.0, target SPARCstation/Sun 4
    CLOS based on PCL version:  September 16 92 PCL (f)
* 
* (proclaim '(optimize (compilation-speed 0) (speed 3) (safety 3)))
EXTENSIONS::%UNDEFINED%
* (disassemble (compile nil '(lambda (x y) (declare (fixnum x y)) (the fixnum (+ x y)))))
Compiling LAMBDA (X Y): 
Compiling Top-Level Form: 

070BFCA8: .ENTRY "LAMBDA (X Y)"(x y) ; (FUNCTION (FIXNUM FIXNUM) FIXNUM) C0: ADD -18, %CODE C4: ADD %CFP, 32, %CSP

C8: CMP %NARGS, 8 ; %NARGS = #:G1 CC: BNE L0 D0: NOP D4: TADDCCTV %ZERO, %A0 ; %A0 = #:G2 D8: TADDCCTV %ZERO, %A1 ; %A1 = #:G3 DC: TADDCCTV %A1, %A0 ; No-arg-parsing entry point E0: MOVE %CFP, %CSP E4: MOVE %OCFP, %CFP E8: J %LRA+5 EC: MOVE %LRA, %CODE F0: L0: UNIMP 10 ; Error trap F4: BYTE #x04 F5: BYTE #x19 ; INVALID-ARGUMENT-COUNT-ERROR F6: BYTE #xFE, #xEB, #x01 ; NARGS F9: .ALIGN 4 * (funcall (compile nil '(lambda (x y) (declare (fixnum x y)) (the fixnum (+ x y)))) most-positive-fixnum most-positive-fixnum) Compiling LAMBDA (X Y): Compiling Top-Level Form:

1073741822

しかし、Lucid CLと違うのは、safety 0にすると普通のaddになってしまう所。

(+ most-positive-fixnum most-positive-fixnum)-2になってしまっています。

* (proclaim '(optimize (compilation-speed 0) (speed 3) (safety 0)))
EXTENSIONS::%UNDEFINED%
* (disassemble (compile nil '(lambda (x y) (declare (fixnum x y)) (the fixnum (+ x y)))))
Compiling LAMBDA (X Y): 
Compiling Top-Level Form: 

071A11F8: .ENTRY "LAMBDA (X Y)"(x y) ; (FUNCTION (FIXNUM FIXNUM) FIXNUM) 210: ADD -18, %CODE 214: ADD %CFP, 32, %CSP 218: ADD %A1, %A0 ; No-arg-parsing entry point 21C: MOVE %CFP, %CSP 220: MOVE %OCFP, %CFP 224: J %LRA+5 228: MOVE %LRA, %CODE 22C: UNIMP 0 * (funcall (compile nil '(lambda (x y) (declare (fixnum x y)) (the fixnum (+ x y)))) most-positive-fixnum most-positive-fixnum) Compiling LAMBDA (X Y): Compiling Top-Level Form:

-2

Lucid CLでは、safety 0でもtaddcctvはそのままでbignumに切り替えます。

> (proclaim '(optimize (compilation-speed 0) (speed 3) (safety 0)))
t
> (disassemble (compile nil '(lambda (x y) (declare (fixnum x y)) (the fixnum (+ x y)))))
;;; You are using the compiler in PRODUCTION mode (compilation-speed = 0)
;;; If you want shorter compile time at the expense of reduced optimization,
;;; you should use the development mode of the compiler, which can be obtained
;;; by evaluating (proclaim '(optimize (compilation-speed 3)))
;;; Generation of runtime error checking code is disabled (safety = 0)
;;; Optimization of tail calls is enabled (speed = 3)

        taddcctv    %in0, %in1, %loc0
        move        %loc0, %in0
        jmpl        %0, %ra + 8
        restore     %0, 4, %u0
nil
> (funcall (compile nil '(lambda (x y) (declare (fixnum x y)) (the fixnum (+ x y)))) most-positive-fixnum most-positive-fixnum)
1073741822

この辺りの違いは、Lucid CLの方がtaddccを活用しているといえるのか、それとも処理系のポリシーの違いなのか。

まとめ

まとめらしいまとめはないですが、Common Lispの処理系のためにCPUに命令が追加されたと思うとSPARCが素晴らしいCPUに見えてきました。
(SPARCプロセッサも大分勢いが無くなってきましたが……)


HTML generated by 3bmd in LispWorks 7.0.0

Lucid Common Lisp環境構築 【2019年版】

Posted 2019-05-03 22:17:38 GMT

以前にLucid Common Lispが動く環境を構築していたのですが、久し振りに起動してみようと思ったところ全く手順を忘れていたのでメモしておきたいと思います。

構築する環境

  • SunOS 4.1.4/SPARC
  • Lucid Common Lisp SunOS/SPARC版

用意するもの

Lucid CLとLucid EmacsのSunOS/SPARC版は両方ともArchive Team: Various Lucid Packagesに含まれているので探してみましょう。

qemuの準備

qemu 3からvlanオプションが廃止されたようで、netdevオプションを使うことになりましたが、qemu-system-sparcで上手く指定できなかったので、しょうがなく2系統を使うことにしました。

ソースからは下記のようにオプションを指定してビルド可能です。

$ ./configure --target-list=sparc-softmmu
$ make

QEMU/SunOS 4.1.4のセットアップについては下記を参考にしました。

Linux tapの設定

sudo modprobe tun 
sudo tunctl -t sunostap0 -u $USER
sudo ifconfig sunostap0 10.0.2.2 netmask 255.255.255.0

のようにしてtapを作成しておきます。
sunostap0というのは好きな名前でOKです。

qemuの起動

qemu-system-sparc -bios ss20_v2.25_rom -M SS-20 -nographic -boot d -hda  sunos414.img -m 512 -smp 2,cores=2 -cpu "TI SuperSparc 60" -net nic,vlan=0 -net tap,vlan=0,ifname=sunostap0,script=no,downscript=no

のようなオプションで起動します。

SunOS 4.1.4の起動

起動の手順がめんどうなので、expectでスクリプトを作成し、それで起動します。
私の手元では、何故かシングルユーザーで起動してからマルチユーザーにしないとおかしなことになりますが、とりあえずスルーすることにします。

#!/bin/sh

cd /vm/sunos-4.1.4

expect -c " set timeout -1 spawn /vm/sunos-4.1.4/boot-sun4.sh expect \"ok \" send \"setenv sbus-probe-list f\r\" expect \"ok \" send \"reset\r\" expect \"ok \" send \"boot disk0 -s\r\" expect \"# \" send \"ifconfig le0 10.0.2.15\r\" send \"route add default 10.0.2.2 1\r\" send \"\exit\r\" expect \"Program terminated\" send \"power-off\" "

rshの設定

sshは存在しない時代ですが、rshは存在します。
telnetより便利なので、rshの設定をしておきます。

これまでの設定の場合、

$ rsh 10.0.2.15

で接続可能です。

X環境の設定

Lucid CLは、ターミナルでも使えますが、Lucid CL 4.0あたりだとLucid Emacsと組み合わせて使うことが想定されているようで、このLucid EmacsがX環境でしか起動しないので、Xの環境も構築することにします。
SunOSのウィンドウをリモートで表示したいのですが、昔と違ってセキュリティ周りが色々厳しくなっているので、色々と面倒なので、個別のVNCサーバを起動して、そこで表示させることにします。

#!/bin/sh

vncserver -geometry 1600x900 :41 -listen tcp export DISPLAY=$(hostname):41.0

xhost + openbox

上記では、41番ディスプレイを指定した例ですが、-listen tcpというのがミソで、明示的にこの指定がないとローカルからしか接続できません(リモートホストのアプリがディスプレイを開けない)

ILISPの設定

(require 'ilisp)

(setq cmulisp-program "/usr/local/bin/lisp")

(setq lucid-program "~/bin/xlt-ansi")

この設定の場合、M-x run-ilispすると、Lucid CLかCMUCLかを選択して起動できます。

xltの起動

(xlt:xlt)

で起動します。
XLTは、クラスブラウザ、プロファイラ、Apropos、オブジェクトのクリップボード(xlt:*0*に代入される)、等々の機能があり、Emacsの開発環境を補助するようなGUIのユーティリティ集というところです。
Allegro CLだと、Allegro Composerという類似のツール集があります。
基本的にSymbolicsの使い勝手をUnix+Emacs上で再現するというのが、1990年代初頭の定番だった様子。

190504050357

190504050416

190504050701

関連記事


HTML generated by 3bmd in LispWorks 7.0.0

Common Lispでクラスメソッド

Posted 2019-04-21 09:32:06 GMT

Common Lispにおけるクラスメソッド

SmalltalkやRubyのようにクラスメソッドがある言語のコードをCommon Lispに移植したり、参考にして書いたりしているときに、クラスメソッドに相当する挙動が欲しくなったりするのですが、メタクラスの構成が違うので、そのまま書き写しただけでは、思ったような挙動にはなりません。

Common Lispでそのまま書き下すと大抵以下のようになりますが、

(defclass foo () ())

(defclass bar (foo) ())

(defmethod zot ((c (eql (find-class 'foo)))) "zot")

(zot (find-class 'foo)) → "zot"

(zot (find-class 'bar)) !! No applicable methods

barクラスに対してはfooのクラスメソッドを起動しません。

Smalltalk/Rubyは、クラスごとにメタクラスが存在し、クラスの継承関係とメタクラスの継承関係は同様の構成になりますが、Common Lispでは、クラスメタオブジェクトのクラスをメタクラスと呼んでいるだけなので、同じメタクラスのクラスメタオブジェクト間に継承関係はありません。

Smalltalk/Ruby風のクラスメソッド的なものをどう実現するか

Common LispでもSmalltalk/Rubyのようにクラス生成時に継承関係と同じメタクラスを作ってしまうという方法が一つの解決策です。

以下のリンクは、shiroさんが以前にPython風のクラスメソッドが欲しいという質問に回答した例です

class-prototypeを使う

クラスメソッドは、

  • クラスの継承関係を利用する
  • インスタンスを生成しなくても起動できる

というのがメリットですが、よくよく考えてみれば、クラスの継承関係を利用できて、インスタンスを生成しなくても起動できさえすれば問題は解決とすると、クラス定義ごとに存在するclass-prototypeを利用してディスパッチすれば良さそうです。

クラスメソッドのnewのようなものは以下のように書けるでしょう。

(defmethod new ((o foo))
  (make-instance (class-of (class-prototype (class-of o)))))

(defmethod new ((name symbol)) (new (class-prototype (find-class name))))

(defclass foo () ())

(new 'foo) → #<foo 40200C8273>

(new (class-prototype (find-class 'foo))) → #<foo 40200C87EB>

上記例は大分持って回った感じですが、とりあえずclass-prototypeを経由すればOKです。

もうすこしクラスメソッド的な例を考える

もうすこしクラスメソッド的な例としてインスタンスの集合を扱う例を考えてみます。

(defclass instance-recording-class (standard-class)
  ((instance-record :initform '()
                    :accessor class-instance-record)))

(defmethod validate-superclass ((c instance-recording-class) (sc standard-class)) T)

(defmethod make-instance :around ((class instance-recording-class) &rest initargs) (let ((inst (call-next-method))) (push inst (class-instance-record class)) inst))

(defclass A ()
  ((x :initarg x))
  (:metaclass instance-recording-class))

(defclass B (A) () (:metaclass instance-recording-class))

(dotimes (i 1000) (make-instance 'B 'x (random 100)))

(length (class-instance-record (find-class 'B))) → 1000

(defun prototypep (instance)
  (eq instance (class-prototype (class-of instance))))

(deftype prototype () `(satisfies prototypep))

(defmethod all ((x A)) (check-type x prototype) (class-instance-record (class-of x)))

(defmethod all ((x symbol)) (all (class-prototype (find-class x))))

(defmethod select ((x A) (selector function)) (check-type x prototype) (loop :for i :in (class-instance-record (class-of x)) :when (funcall selector i) :collect i))

(defmethod select ((x symbol) (selector function)) (select (class-prototype (find-class x)) selector))

(length (all 'B)) → 1000

(length (select 'B (lambda (x) (evenp (slot-value x 'x))))) → 490

(loop :repeat 10 :for x :in (select 'B (lambda (x) (evenp (slot-value x 'x)))) :collect (slot-value x 'x))(66 92 38 60 74 80 10 20 76 86)

(all (make-instance 'A)) !! The value #<a 4020099793> is not of type prototype.

生成されたインスタンスとプロトタイプが混ざるという潜在的な問題はあるので、上記では、prototype型を定義して弾いてみることにしました。

プロトタイプを利用しているので、集合に対する演算の度にインスタンスが生成されて母数が変化してしまうような問題もないことが分かるかと思います。

まとめ

Smalltalkでは、クラス生成時にクラスの継承関係保持したメタクラスが生成されますが、Common Lisp(MOP)では、クラス生成時に(当然ながら)継承関係を保持したプロトタイプが生成されます。
この関係を上手く利用すれば、Common Lispでのクラスメソッド問題も解決できそうな気がしていますがどうでしょう。


HTML generated by 3bmd in LispWorks 7.0.0

MOP vs マクロ (8): メソッド定義でselfを使って楽をしたい

Posted 2019-03-31 19:03:15 GMT

今回のMOP vs マクロは、defmethodのカスタマイズネタで比較してみたいと思います。

メソッド定義でselfを使いたい

Common Lispはマルチメソッドなので、シングルメソッドの言語のようなselfはありませんが、なんとなく気分で、

(defmethod foo ((self bar) x y) ...)

のように書いたりすることもあります。

このようにディスパッチは先頭一つでしか行なわない場合に、defmethod内部でselfも使えたら便利なんじゃないか、ということで、そのようなカスタマイズをしてみたいと思います。

マクロ篇

まずはマクロでの実現。とりあえず、安直に下記のように書いてみました。

(ql:quickload :closer-mop)

(defpackage "9ef5d5fa-900d-5269-8012-a9c0d39a1860" (:use :c2cl))

(in-package "9ef5d5fa-900d-5269-8012-a9c0d39a1860")

(defmacro defgeneric-self (name (&rest args) &body body) (destructuring-bind (class name) name `(defgeneric ,name (,class ,@args) ,@body)))

(defmacro defmethod-self (name (&rest args) &body body) (destructuring-bind (class name) name `(defmethod ,name ((self ,class) ,@args) (with-slots ,(mapcar #'slot-definition-name (class-slots (find-class class))) self ,@body))))

selfとなるインスタンスのクラスをどう指定するかですが、Flavors風に(defmethod (class name) ()...)としてみています。

また、defmethod内部では、selfとインスタンスのスロットがスロット名の変数でアクセスできるようにしたいので、with-slotsでボディを囲んでいます。

なお、マクロで実現といってもスロット名を取得したりする必要があるので、MOPを使う必要はあります。

試してみる

(defconstant <foo>
  (defclass foo () 
    ((a :initform nil)
     (b :initform nil)
     (c :initform nil))))

(finalize-inheritance <foo>)

(defmethod-self (foo frob) (a b c) (list self a b c))

(frob (make-instance <foo>) 0 1 2)(#<foo 4020290013> nil nil nil)

クラスのスロット名とメソッドの引数名が被った時にはクラスのスロットに遮蔽されてしまいますが、Flavorsもこんな動作なので良しとします。

MOP篇

(ql:quickload :closer-mop)

(defpackage "a16a6b7f-083d-52aa-a466-d22b941a23c8" (:use :c2cl))

(in-package "a16a6b7f-083d-52aa-a466-d22b941a23c8")

(defclass self-generic-function (standard-generic-function) () (:metaclass funcallable-standard-class))

(defmethod make-method-lambda ((gf self-generic-function) (method standard-method) λxp env) (destructuring-bind (lambda (self &rest args) &body body) λxp (call-next-method gf method (let ((slot-names (mapcar #'slot-definition-name (class-slots (find-class self))))) `(,lambda (,self ,@args) (let ((self ,self)) (declare (ignorable self)) (with-slots ,slot-names self (declare (ignorable ,@slot-names)) ,@body)))) env)))

メソッドのボディのコードをカスタマイズするには、make-method-lambdaが返す、lambda式を編集することになるようです。
ボディのコードをいじる用途には、ちょっと面倒なインターフェイスという印象。

試してみる

(defconstant <foo>
  (defclass foo () 
    ((a :initform nil)
     (b :initform nil)
     (c :initform nil))))

(defgeneric frob (foo a b c) (:generic-function-class self-generic-function))

(defmethod frob (foo a b c) (list self a b c))

(frob (make-instance <foo>) 0 1 2)(#<foo 402028F48B> nil nil nil)

やっていることはマクロ版と殆ど変わりありません。
第一引数のシンボルをクラス名にする必要があるという所が危ういですが、まあ良しとします。

マクロでお化粧することも可能ですが、そうするとMOPで書く意味があまりないなという気分になってしまいます。

(defmacro defgeneric-self (name (&rest args) &body body)
  (destructuring-bind (class name)
                      name
    `(defgeneric ,name (,class ,@args) ,@body
       (:generic-function-class self-generic-function))))

(defmacro defmethod-self (name (&rest args) &body body) (destructuring-bind (class name) name `(defmethod ,name (,class ,@args) ,@body)))

(defgeneric-self (foo bar) ())

(defmethod-self (foo bar) () (list self a b c))

まとめ

クラスの情報を得るのにMOPのイントロスペクション機能を使う必要はありますが、得た情報からコード生成をすることに関しては、マクロの方が単純で明解ですね。


HTML generated by 3bmd in LispWorks 7.0.0

MOP vs マクロ (7): Gaucheのpropagatedスロット再現

Posted 2019-03-04 22:54:25 GMT

今回のMOP vs マクロは、Gaucheのpropagatedスロット再現で比較してみたいと思います。

propagatedスロットについてはブログでの紹介記事に詳しいですが、合成した部品のスロットにアクセスする際に子コンポーネントのスロットが親のスロットとしてアクセスできる、というものです。

マクロ篇

そもそもGaucheのpropagatedスロットが想定している利用法からするとマクロで実現してみようというのは色々と無理があるのですが、色々捨てて挙動だけ同じにしました。

(defpackage "6401746F-BD45-5DB6-BD1D-B29A1EFA0494"
  (:use :c2cl))

(cl:in-package "6401746F-BD45-5DB6-BD1D-B29A1EFA0494")

(defmacro with-slots/propagation ((&rest specs) obj &body body) (etypecase specs (null `(with-slots () ,obj ,@body)) ((cons atom null) (let ((_obj (gensym "_obj"))) `(let ((,_obj ,obj)) (with-slots (,(car specs)) ,_obj (with-slots/propagation (,@(cdr specs)) ,_obj ,@body))))) (cons (destructuring-bind (target-slot slots) (car specs) (let ((_obj (gensym "_obj"))) `(let ((,_obj ,obj)) (with-slots (,@slots) (slot-value ,_obj ',target-slot) (with-slots/propagation (,@(cdr specs)) ,_obj ,@body))))))))

(defclass rect ()
  ((width  :initform 0 :initarg :width)
   (height :initform 0 :initarg :height)))

(defclass viewport () ((dimension :initform (make-instance 'rect)) (width :initarg :width) (height :initarg :height)))

(let ((obj (make-instance 'viewport))) (with-slots/propagation ((dimension (width height))) obj (setq width 42 height 42)) (describe (slot-value obj 'dimension))) ;>> #<rect 40200074CB> is a rect ;>> width 42 ;>> height 42

当初の目的からは外れていますが、局所的にオブジェクトを合成したりするのには使えなくもないかも。
(暗黙の規約が多過ぎますが)

MOP篇

マクロでの実現はやりたいことの中身が全部外側に露出してしまっていますが、これをMOPで内側に収めます。

Gaucheでは、compute-get-n-setという便利なメソッドがあるので圧縮して記述できていますが、AMOP作法だと長くなります。
さらに、standard-instance-accessの利用でアクセス速度向上を狙ってみたので、より長くなりました。

(ql:quickload '(closer-mop))

(defpackage "5ADAD164-D620-594D-A9C7-8E192966CA64" (:use :c2cl))

(cl:in-package "5ADAD164-D620-594D-A9C7-8E192966CA64")

(defclass propagated-slot-class (standard-class) ())

(defmethod validate-superclass ((c propagated-slot-class) (sc standard-class)) T)

(defclass propagated-slot-definition (standard-slot-definition) ((propagate-to :initform nil :initarg :propagate :initarg :propagate-to :accessor propagated-slot-definition-propagate-to) (propagate-to# :initform nil :accessor propagated-slot-definition-propagate-to#)))

(defmethod slot-definition-allocation ((slotd propagated-slot-definition)) :propagated)

(defmethod (setf slot-definition-allocation) (allocation (slotd propagated-slot-definition)) (unless (eq allocation :propagated) (error "Cannot change the allocation of a ~S" slotd)) allocation)

(defconstant <propagated-direct-slot-definition> (defclass propagated-direct-slot-definition (standard-direct-slot-definition propagated-slot-definition) ()))

(defmethod direct-slot-definition-class ((class propagated-slot-class) &rest initargs) (if (eq (getf initargs :allocation) :propagated) <propagated-direct-slot-definition> (call-next-method)))

(defconstant <propagated-effective-slot-definition> (defclass propagated-effective-slot-definition (standard-effective-slot-definition propagated-slot-definition) ()))

(defmethod effective-slot-definition-class ((class propagated-slot-class) &rest initargs) (if (eq :propagated (getf initargs :allocation)) <propagated-effective-slot-definition> (call-next-method)))

(defmethod compute-effective-slot-definition ((class propagated-slot-class) name direct-slot-definitions) (declare (ignore name)) (let ((effective-slotd (call-next-method))) (dolist (slotd direct-slot-definitions) (when (typep slotd 'propagated-slot-definition) (setf (propagated-slot-definition-propagate-to effective-slotd) (propagated-slot-definition-propagate-to slotd)) (return))) effective-slotd))

(defmethod finalize-inheritance :after ((class propagated-slot-class)) (let ((slotds (class-slots class))) (dolist (sd slotds) (when (typep sd 'propagated-slot-definition) (setf (propagated-slot-definition-propagate-to# sd) (slot-definition-location (find (propagated-slot-definition-propagate-to sd) slotds :key #'slot-definition-name)))))))

#-lispworks (defmacro slot-foo (fctn class object slotd) (declare (ignore class)) `(,fctn (standard-instance-access ,object (propagated-slot-definition-propagate-to# slotd)) (slot-definition-name ,slotd)))

#-lispworks (progn (defmethod slot-value-using-class ((class propagated-slot-class) object (slotd propagated-slot-definition)) (slot-foo slot-value class object slotd))

(defmethod (setf slot-value-using-class) (value (class propagated-slot-class) object (slotd propagated-slot-definition)) (setf (slot-foo slot-value class object slotd) value))

(defmethod slot-boundp-using-class ((class propagated-slot-class) object (slotd propagated-slot-definition)) (slot-foo slot-boundp class object slotd))

(defmethod slot-makunbound-using-class ((class propagated-slot-class) object (slotd propagated-slot-definition)) (slot-foo slot-makunbound class object slotd))

(defmethod slot-exists-p-using-class ((class propagated-slot-class) object (slotd propagated-slot-definition)) (slot-foo slot-exists-p class object slotd)))

;;; おまけ:LispWorksの場合 #+lispworks (defmacro slot-foo (fctn class object slot-name) `(let ((slotd (find ,slot-name (class-slots ,class) :key #'slot-definition-name))) (if (typep slotd 'propagated-slot-definition) (,fctn (standard-instance-access ,object (propagated-slot-definition-propagate-to# slotd)) ,slot-name) (call-next-method))))

#+lispworks (progn (defmethod slot-value-using-class ((class propagated-slot-class) object slot-name) (slot-foo slot-value class object slot-name))

(defmethod (setf slot-value-using-class) (value (class propagated-slot-class) object slot-name) (let ((slotd (find slot-name (class-slots class) :key #'slot-definition-name))) (if (typep slotd 'propagated-slot-definition) (setf (slot-value (standard-instance-access object (propagated-slot-definition-propagate-to# slotd)) slot-name) value) (call-next-method))))

(defmethod slot-boundp-using-class ((class propagated-slot-class) object slot-name) (slot-foo slot-boundp class object slot-name))

(defmethod slot-makunbound-using-class ((class propagated-slot-class) object slot-name) (slot-foo slot-makunbound class object slot-name))

(defmethod slot-exists-p-using-class ((class propagated-slot-class) object slot-name) (slot-foo slot-exists-p class object slot-name)))

試してみる

(defclass rect ()
  ((width  :initform 0 :initarg :width)
   (height :initform 0 :initarg :height)))

(defclass viewport () ((dimension :initform (make-instance <rect>)) (width :allocation :propagated :propagate dimension :initarg :width) (height :allocation :propagated :propagate dimension :initarg :height)) (:metaclass propagated-slot-class))

(let ((vp (make-instance 'viewport' :width 42 :height 42))) (describe vp) (describe (slot-value vp 'dimension))) ;>> #<viewport 4020098D8B> is a viewport ;>> dimension #<rect 4020098DBB> ;>> width 42 ;>> height 42 ;>> #<rect 4020098DBB> is a rect ;>> width 42 ;>> height 42

速度比較

LispWorksだと素のインスタンス生成/スロットアクセスに比較して大体1.5倍程度の遅さで済んでいるようです。

(defclass c000001 ()
  ((x :initform 0)
   (y :initform 0)
   (z :initform 0)))

(let ((times 1000000) (ans 0)) (time (dotimes (i times) (slot-value (make-instance 'viewport) 'width))) (time (dotimes (i times) (slot-value (make-instance 'c000001) 'x))) ans) Evaluation took: 0.686 seconds of real time 0.680000 seconds of total run time (0.680000 user, 0.000000 system) 99.13% CPU 2,258,481,555 processor cycles 95,986,800 bytes consed

Evaluation took: 0.413 seconds of real time 0.410000 seconds of total run time (0.410000 user, 0.000000 system) 99.27% CPU 1,360,213,671 processor cycles 64,028,672 bytes consed

まとめ

今回は、マクロ向きのお題ではありませんでしたが、動作の内容はMOPの内側か外側かの違いだけではありました。

MOPで組む前に、マクロで適当に書いてみて動作を考える、というもの場合によっては、悪くないかもしれません。


HTML generated by 3bmd in LispWorks 7.0.0

DEFUN 50歳おめでとう

Posted 2019-02-28 15:00:00 GMT

Common Lispでお馴染のdefun。 ClojureだとdefnでCommon Lispと同じくデ(ィ)ファンと読むらしいですが、Jon L White氏によってMACLISPに導入されたのが、50年前の今日、1969-03-01でした。

3/1/69 JONL

THE CURRENT VERSION OF LISP, "LISP 102", HAS THE FOLLOWING AS-YET UNDOCUMENTED FEATURES:

1)"DEFUN" IS AN FSUBR USED TO DEFINE FUNCTIONS. EXAMPLES ARE (DEFUN ONECONS (X) (CONS 1 X)) WHICH IS EQUIVALENT TO (DEFPROP ONECONS (LAMBDA (X) (CONS 1 X) EXPR)

AND (DEFUN SMASH FEXPR (L) (RPLACD L NIL)) IS EQUIVALENT TO (DEFPROP SMASH (LAMBDA (L) (RPLACD L NIL)) FEXPR) THE NOVEL FEATURE OF "DEFUN" IS THAT ONE NEED NOT BE SO CONCERNED WITH BALANCING PARENTHESES AT THE VERY END OF THE FUNCTION DEFINITION, SINCE THE TYPE FLAG MAY BE OMITTED IF IT IS "EXPR", AND APPEARS NEAR THE FRONT OF THE "DEFUN" LIST IF IT IS SOME OTHER. ALSO, THE "LAMBDA" NEED NOT BE DIRECTLY INSERTED.

defun誕生以前は、defpropでシンボルのexprや、fexprmacroプロパティに関数定義をセットしていたようです。

ちなみに、defunとは別の流儀にdeがありますが、こちらは、MIT LISP 1.6(後のPDP-6 LISP/MACLISP)がスタンフォード大学に導入された後にdefunと同様の目的で考案されたものです。

defunは当初、通常の関数(expr)だけでなくマクロ等の各種関数を定義できました。
exprの定義は、defun foo (x)でfexprの定義はdefun foo fexpr (x)とし、同様にマクロは、defun foo macro (x)で定義可能です。
これらは、Common Lispの祖先のLisp Machine Lispで、各種専用構文に分岐します。

上述のStanford LISP 1.6の場合は、exprは、de、fexprは、df、マクロは、dmと二文字の専用構文となっていますが、defunの方は、先祖のdefpropの影響を引き摺ったのかもしれません。

50年も生き延びたdefun構文ですが、100歳まで生き残るでしょうか。


HTML generated by 3bmd in LispWorks 7.0.0

Common Lispにおいて(lambda (x) ...)は関数の名前なのかどうか

Posted 2019-02-23 18:23:58 GMT

たまに、Common Lispの仕様では(lambda (x) ...)を関数の名前として定められている、というような話がされることがあります。
しかし、結論としては、ANSI Common Lisp規格では関数の名前ではありません。
今回は、その辺りを調べてまとめてみました。

ANSI Common Lisp規格での関数の名前

(lambda (x) ...)は、ANSI Common Lisp規格では、lambda expressionと呼びますが、その説明を読むとfunction nameが位置する場所にあるlambdaから始まるリスト、のように持って回った説明がされています。

とりあえず、lambda expressionの方は置いておいて、function nameの方を確認すると、シンボルもしくは、(setf シンボル)というリストがfunction nameとなっています。

Common Lisp(1984)での関数の名前

しかし、CLtL1でお馴染のCommon Lisp(1984)での記述を確認してみると、ANSI規格に比べると記述は曖昧で、関数名としてのシンボルと、ラムダ式を同一視しているような記述ではありました。

CLtL1: 5.2 Functions

There are two ways to indicate a function to be used in a function call form. One is to use a symbol that names the function. This use of symbols to name functions is completely independent of their use in naming special and lexical variables. The other way is to use a lambda-expression, which is a list whose first element is the symbol lambda. A lambda-expression is not a form; it cannot be meaningfully evaluated. Lambda-expressions and symbols, when used in programs as names of functions, can appear only as the first element of a function-call form, or as the second element of the function special form. Note that symbols and lambda-expressions are treated as names of functions in these two contexts. This should be distinguished from the treatment of symbols and lambda-expressions as function objects, that is, objects that satisfy the predicate functionp, as when giving such an object to apply or funcall to be invoked.

これはANSI規格へ向けての中間報告であるCLtL2(1990)でも同様です。

この記述をうけてか、竹内郁雄先生の1980年代の著作である「初めての人のためのLisp」11章の脚注にもこんな記述があります。

Common Lispではこのリストを,関数実体を表わす一種の"名前"と呼んでいます。

ちなみに、増補改訂版(2010)では、脚注から本文の先生の台詞に昇格して

Common Lispではこのリストを,関数実体を表わす一種の"名前"であるとしておる

となっています。 まあ、「一種の“名前”」となっているので、どうとでも解釈できそうです。

Common Lisp(1984)からANSI Common Lisp(1994)までに何が変化したのか

ANSI Common Lisp(1994)は、オブジェクト指向システムやコンディションシステムの追加等が目立つところですが、それまで曖昧だった概念や記述が大分整理されました。
function nameとlambda expressionが分離した背景については、Issue FUNCTION-NAME Writeupに記録があります。

まず、function nameについての整理があり、functionfdefinitiondefunfboundpfmakunbound等々、関数の名前を取るものの整理がされ、(setf ...)が新しく関数名とされました。

これを推進して、lambda expressionを関数名として扱うかの提案が、FUNCTION-NAME:LARGEの12番にあります。

12. Declare that any lamba expression (i.e., a list whose car is LAMBDA and
    whose cdr is a well-formed lambda argument list and body) is a function
    name. 

lambda expressionが名前となれば、

(fmakunbound (lambda () ...))

のようなケースも考えていくことになると思うのですが、しかし、結局、lambda expressionが無名関数を表す慣習からすると、それをもって名前とするのは矛盾としています。
名は体を表すといいますが、lambda expressionは体が体を表してしまっているというところでしょうか。

Lambda expressions are often thought to denote "anonymous" functions, so
it may seem paradoxical to treat them as names.  The paradox is only
apparent, since the expression itself has the properties of a Lisp
function name: It is (typically) a cons tree which can be read, printed,
and stored in source files, and it denotes a well-defined Lisp function.

ここからどのような投票が行なわれ、どう決定されたかの資料はみあたらないのですが、12番の提案は採用されなかったのは確かで、function nameにlambda expressionは含まれることは無かった、ということでしょう。

まとめ

年配の方々はもうしょうがないと思いますが、若者はANSI Common Lisp規格を読みましょう。
また、CLtL2はCLtL1からANSI Common Lispまでの中間報告であり規格ではありませんので、CLtL1/2で得た知識は一度ANSI Common Lisp規格でどう変更された/されていないのかの確認をしましょう。


HTML generated by 3bmd in LispWorks 7.0.0

MOP vs マクロ (6)

Posted 2019-02-20 18:53:42 GMT

今回は前回に引き続きECLOSネタから、

  • instance-recording-class (get to instances from their class, but allow their garbage collection).

でMOP vs マクロ比較をしてみたいと思います。

インスタンス生成を何らかの形で記録するというのはAMOPの3.1章にも出てくる定番ネタです。

この機能の実現は、インスタンス生成で使うmake-instanceに記録を行う関数のフックをかけてやればOKでしょう。
加えて、ECLOSではインスタンスを記録しつつもGCされたら消えるとのことなのですが、これは弱参照リストかなにかにすれば、これもOKでしょう。

ということで書いてみました。

MOPでの実装

LispWorksとSBCLで弱参照のシークエンスを物色してみましたが、弱参照の配列にしてみました。
LispWorksでは、weak-arrayというものがありadjustableなのですが、SBCLにはないので、結局make-weak-pointerで包んでいます。
trivial-garbageを利用すればいくらか可搬性は増すかもしれません。

(cl:in-package :cl-user)

(ql:quickload :closer-mop)

(defpackage "d5fc135c-3bcf-4976-9a9e-e6b92c12bd9d" (:use :c2cl :alexandria))

(in-package "d5fc135c-3bcf-4976-9a9e-e6b92c12bd9d")

(defun make-weak-vector (size &rest initargs) (declare (dynamic-extent initargs)) #+lispworks (apply #'hcl:make-weak-vector size initargs) #+sbcl (apply #'make-array size :element-type 'sb-ext:weak-pointer initargs))

(defclass instance-recording-class (standard-class) ((instance-record :initform (make-weak-vector 0 :adjustable T :fill-pointer 0) :accessor class-instance-record)))

(defmethod validate-superclass ((c instance-recording-class) (sc standard-class)) T)

(defmethod make-instance :around ((class instance-recording-class) &rest initargs) (let* ((inst (call-next-method)) #+sbcl (inst (sb-ext:make-weak-pointer inst))) (vector-push-extend inst (class-instance-record class)) inst))

(defun reset-instance-record (class) (setf (class-instance-record class) (make-weak-vector 0 :adjustable T :fill-pointer 0)))

試してみる

(defconstant <zot> 
  (defclass zot () 
    ((a :initform 42))
    (:metaclass instance-recording-class)))

(dotimes (i 8) (make-instance <zot>))

(class-instance-record <zot>)

#+sbcl →#(#<weak pointer: #<zot {10349DBA73}>> #<weak pointer: #<zot {10349ECDF3}>> #<weak pointer: #<zot {10349ECE63}>> #<weak pointer: #<zot {10349ECEE3}>> #<weak pointer: #<zot {10349ECF33}>> #<weak pointer: #<zot {10349ECFD3}>> #<weak pointer: #<zot {10349ED023}>> #<weak pointer: #<zot {10349ED073}>>) #+lispworks → #(#<zot 4020034723> #<zot 4020034B43> #<zot 4020034EAB> #<zot 4020035213> #<zot 402003557B> #<zot 40200358E3> #<zot 4020035C4B> #<zot 4020035FB3>)

#+lispworks (hcl:gc-all) #+sbcl (sb-ext:gc :full t)

(class-instance-record <zot>) #+sbcl → #(#<broken weak pointer> #<broken weak pointer> #<broken weak pointer> #<broken weak pointer> #<broken weak pointer> #<broken weak pointer> #<broken weak pointer> #<broken weak pointer>)

#+lispworks → #(nil nil nil nil nil nil nil nil)

;; (clear-instance-record <zot>)

SBCLのほうはweak-pointerオブジェクトで包まれるのでちょっと扱いが面倒ですが、まあこんなものでしょう。

allocate-instanceにフックをかけるのでは駄目なのか

AMOPの例でもこういう記録系の拡張は、make-instanceにフックをかけますが、生成ならばallocate-instanceへのフックでも良さそうです。

両者で何が違うのか考えてみましたが、class-prototypeを実行するとプロトタイプの生成でallocate-instanceが呼ばれるので、クラスのプロトタイプインスタンスも含みたい場合はallocate-instanceの方が良いのでしょう。
恐らく、インスタンス記録系は、クラスのプロトタイプインスタンスは大抵除外して考えそうなので、make-instanceの方が自然かと思います。

allocate-instanceを利用した場合

(defmethod allocate-instance :around ((class instance-recording-class) &rest initargs)
  (let* ((inst (call-next-method))
         #+sbcl (inst (sb-ext:make-weak-pointer inst)))
    (vector-push-extend inst (class-instance-record class))
    inst))

(defconstant <bar> (defclass bar () ((a :initform 42)) (:metaclass instance-recording-class)))

(class-instance-record <bar>) → #()

(class-prototype <bar>) → #<bar 402008BEE3>

(class-instance-record <bar>) → #(#<bar 402008BEE3>)

マクロで考えてみた

あまりこういうのはマクロに向いていない気もしますが、比較のために書いてみました。

(defvar *instance-recording-table*
  (make-hash-table))

(defmacro with-instance-recording ((type) &body form) (with-unique-names (inst) `(let* ((,inst (progn ,@form)) #+sbcl (,inst (sb-ext:make-weak-pointer ,inst))) #-sbcl (check-type ,inst ,type) #+sbcl (check-type (sb-ext:weak-pointer-value ,inst) ,type) (vector-push-extend ,inst (or (gethash ',type *instance-recording-table*) (setf (gethash ',type *instance-recording-table*) (make-weak-vector 0 :adjustable T :fill-pointer 0)))) ,inst)))

(defun get-instance-record (type) (values (gethash type *instance-recording-table*)))

(defun reset-instance-record (type) (setf (gethash type *instance-recording-table*) (make-weak-vector 0 :adjustable T :fill-pointer 0)))

試してみる

(defclass quux ()
  ((x :initform 0)))

(dotimes (i 8) (with-instance-recording (quux) (make-instance 'quux)))

(get-instance-record 'quux) → #(#<quux 40200A1413> #<quux 40200A26A3> #<quux 40200A351B> #<quux 40200A4393> #<quux 40200A520B> #<quux 40200A6083> #<quux 40200A6EFB> #<quux 40200A7D73>)

(hcl:gc-all)

(get-instance-record 'quux) → #(nil nil nil nil nil nil nil nil)

マクロなのでクラスオブジェクト以外にも使えます。
(というかそういう風に作っただけ)

(defstruct sss a b c)

(dotimes (i 8) (with-instance-recording (sss) (make-sss)))

(get-instance-record 'sss) → #(#S(sss :a nil :b nil :c nil) #S(sss :a nil :b nil :c nil) #S(sss :a nil :b nil :c nil) #S(sss :a nil :b nil :c nil) #S(sss :a nil :b nil :c nil) #S(sss :a nil :b nil :c nil) #S(sss :a nil :b nil :c nil) #S(sss :a nil :b nil :c nil))

(hcl:gc-all)

(get-instance-record 'sss) → #(nil nil nil nil nil nil nil nil)

まとめ

インスタンスの記録についてMOPとマクロで比較してみましたが、元がMOP向きな問題だけにさすがにMOPの方がすっきりします。
しかし、実現している内容はマクロ版も大して変わらないので、あとは使い勝手がどうなるか、でしょうか。


HTML generated by 3bmd in LispWorks 7.0.0

MOP vs マクロ (5)

Posted 2019-02-18 21:04:14 GMT

前回let*-like slot initialization semanticsはマクロ主体での実装でしたが、今回はMOP主体でチャレンジです。

しかし、defclassが周囲のレキシカル変数を取り込むので何にせよ全体はマクロでまとめる他なさそうですが、そこは諦めます。

あれこれ試行錯誤しましたが、今回の方針は、

  • let*風の逐次初期化を実行する関数を収めるスロットを付ける (direct-slot-definitionに追加)
  • メタクラスにインスタンスの初期化をする関数を収めるスロットを付ける (class-let*-initfunction)
  • compute-slotsでスロット構成を生成する際に、追加したスロットの初期化関数をまとめる
  • まとめた関数をshared-initializeで呼ぶ

shared-initializeで呼ばれる関数ですが、下記のようなものを生成します。 初期化されるインスタンスを引数に取り、内部では、専らstandard-instance-accessを使って読み書きします。

(lambda (obj)
  (symbol-macrolet ((a (standard-instance-access obj 0))
                    (b (standard-instance-access obj 1)))
    (when (eq unbound-marker (standard-instance-access obj 0))
      (setf (standard-instance-access obj 0)
            (funcall #<Function 1 subfunction of (lw:top-level-form 1) 4060007E8C>
                     nil
                     nil)))
    (when (eq unbound-marker (standard-instance-access obj 1))
      (setf (standard-instance-access obj 1)
            (funcall #<Function 2 subfunction of (lw:top-level-form 1) 4060007E34>
                     a
                     nil)))
    (when (eq unbound-marker (standard-instance-access obj 2))
      (setf (standard-instance-access obj 2)
            (funcall #<Function 3 subfunction of (lw:top-level-form 1) 4060007DAC>
                     a
                     b)))))

そして、下記がMOPチャレンジ版のコードですが、大したことはしていないのに長くなりました。

(cl:in-package :cl-user)

(ql:quickload :closer-mop)

(defpackage :64d0b072-4e6b-44c3-b565-dcf8d4ca63e3 (:use :c2cl) #+sbcl (:shadowing-import-from :cl :defmethod))

(cl:in-package :64d0b072-4e6b-44c3-b565-dcf8d4ca63e3)

(defconstant unbound-marker (if (boundp 'unbound-marker) unbound-marker (gensym "unbound")))

(defclass let*-slot-class (standard-class) ((let*-slots :initform nil :accessor class-let*-slots :initarg :let*-slots) (let*-initfunction :accessor class-let*-initfunction :initarg :let*-initfunction)))

(defmethod validate-superclass ((c let*-slot-class) (sc standard-class)) T)

(defclass let*-standard-object (standard-object) ())

(defun process-a-slot (slot) (loop :with name := (car slot) :for (k v) :on (cdr slot) :by #'cddr :when (eq k :initform) :append `(:initform ,v :initfunction (constantly unbound-marker)) :into initform :when (eq k :initarg) :collect v :into initargs :when (eq k :writer) :collect v :into writers :when (eq k :reader) :collect v :into readers :when (eq k :accessor) :collect v :into readers :and :collect `(setf ,v) :into writers :finally (return `(:name ,name :initargs ,initargs ,@initform :writers ,writers :readers ,readers))))

(defclass let*-direct-slot-definition (standard-direct-slot-definition) ((let*-initfunction :initarg :let*-initfunction :accessor slot-definition-let*-initfunction)))

(defmethod direct-slot-definition-class ((class let*-slot-class) &rest initargs) (find-class 'let*-direct-slot-definition))

(defmethod compute-slots :around ((class let*-slot-class)) (let* ((let*-slots (class-let*-slots class)) (slots (call-next-method)) (let*-slot#s (loop :for s :in let*-slots :for pos := (position s slots :key #'slot-definition-name) :when pos :collect (cons s pos)))) (setf (class-let*-initfunction class) (compile nil `(lambda (obj) (symbol-macrolet (,@(loop :for s :in (butlast let*-slots) :collect `(,s (standard-instance-access obj ,(cdr (assoc s let*-slot#s)))))) ,@(loop :for s :in let*-slots :for pos := (cdr (assoc s let*-slot#s)) :for argpos :from 0 :collect `(when (eq unbound-marker (standard-instance-access obj ,pos)) (setf (standard-instance-access obj ,pos) (funcall ,(slot-definition-let*-initfunction (find s (class-direct-slots class) :key #'slot-definition-name)) ,@(replace (make-list (length (cdr let*-slots))) (subseq (butlast let*-slots) 0 argpos)))))))))) slots))

(defmethod shared-initialize :after ((obj let*-standard-object) slot-names &rest initargs &key &allow-other-keys) (funcall (class-let*-initfunction (class-of obj)) obj))

(defmacro defclass* (name (&rest superclasses) (&rest slots) &rest class-options) (loop :with slot-names := (mapcar (lambda (x) (if (consp x) (car x) x)) slots) :for s :in slots :for cs := (copy-list (process-a-slot s)) :collect `(,@cs :let*-initfunction (lambda (,@(butlast slot-names)) (declare (ignorable ,@(butlast slot-names))) ,(getf cs :initform))) :into canonicalized-slots :finally (return `(eval-when (:compile-toplevel :load-toplevel :execute) (ensure-class ',name :metaclass 'let*-slot-class :direct-superclasses (adjoin 'let*-standard-object ',superclasses) :direct-slots (list ,@(mapcar (lambda (s) (destructuring-bind (&key name initargs initform initfunction writers readers let*-initfunction &allow-other-keys) s `(list :name ',name :initargs ',initargs :initform ',initform :initfunction ,initfunction :writers ',writers :readers ',readers :let*-initfunction ,let*-initfunction))) canonicalized-slots)) :let*-slots ',slot-names ,@class-options)))))

動作

(defclass* qqq ()
  ((a :initform 42 :initarg :a)
   (b :initform a :initarg :b)
   (c :initform (+ a b) :initarg :c)))

(with-slots (a b c) (make-instance 'qqq) (list a b c)) ;=> (42 42 84) (with-slots (a b c) (make-instance 'qqq :c 0) (list a b c)) ;=> (42 42 0) (with-slots (a b c) (make-instance 'qqq :b 0) (list a b c)) ;=> (42 0 42) (with-slots (a b c) (make-instance 'qqq :a 0) (list a b c)) ;=> (0 0 0) (with-slots (a b c) (make-instance 'qqq :a 0 :b 1) (list a b c)) ;=> (0 1 1)

MOPにして良いことがあるのか

マクロ主体の場合は、スロットアクセスが名前参照ベースなので若干非効率効率ですが、MOPを使えば、standard-instance-access等の効率の良いアクセス方法が使えるので速くできるだろうということで、今回は、standard-instance-accessの利用を軸に組み立ててみました。

素のインスタンス生成〜初期化と比較して、マクロ版は、約1.8倍の時間のところをMOP版では、約1.3倍程度にまで抑えることができました。
まあもっと速くできそうではありますが……。

(defclass let-slot ()
  ((a :initform 42)
   (b :initform 42)
   (c :initform 42)))

(defclass* let*-slot () ((a :initform 42 :initarg :a) (b :initform a :initarg :b) (c :initform (+ a b) :initarg :c)))

(dc07f5fa-62ee-40a1-ae1a-d1a0f87d19bb::defclass* let*-slot-macro () ((a :initform 42 :initarg :a) (b :initform a :initarg :b) (c :initform (+ a b) :initarg :c)))

計時

(let ((cnt 1000000))
  (time 
   (dotimes (i cnt)
     (make-instance 'let-slot)))
  (time 
   (dotimes (i cnt)
     (make-instance 'let*-slot)))
  (time 
   (dotimes (i cnt)
     (make-instance 'let*-slot-macro))))

Timing the evaluation of (dotimes (i cnt) (make-instance 'let-slot))

User time = 1.270 System time = 0.000 Elapsed time = 1.258 Allocation = 1352109704 bytes 0 Page faults Calls to %EVAL 17000036 Timing the evaluation of (dotimes (i cnt) (make-instance 'let*-slot))

User time = 1.660 System time = 0.000 Elapsed time = 1.654 Allocation = 1352029784 bytes 0 Page faults Calls to %EVAL 17000036 Timing the evaluation of (dotimes (i cnt) (make-instance 'let*-slot-macro))

User time = 2.260 System time = 0.000 Elapsed time = 2.260 Allocation = 1352020600 bytes 0 Page faults Calls to %EVAL 17000036 nil

継承した場合にスロットのインデックスの位置関係はどうなるのか

具体的には下記のような場合に、standard-instance-accessが指す先がどのような構成になるのかを把握していないと使えないのですが、

(defclass A ()
  ((a :initform 0 :initarg :a)
   (b :initform 1 :initarg :b)
   (c :initform 2 :initarg :c)))

(defclass* B (A) ((x :initform 42 :initarg :x) (y :initform x :initarg :y) (z :initform (+ x y) :initarg :z)))

(with-slots (a b c x y z) (make-instance 'B :y 1) (list a b c x y z)) ;=> (0 1 2 42 1 43)

AMOPのInstance Structure Protocolの例では、compute-slotsの並び順で、standard-instance-accessのインデックスを決められる的なことが書いてあります。
実際に試してみると、継承した場合、上位クラスのスロット数分だけオフセットしたり(SBCL、LispWorks)名前とスロットの値が一致しなかったり(LispWorks)で、compute-slotsで並べた順がすなわちインデックスとはならない実装があるようです。

しょうがないので、結局名前からインデックスを求めるようにしましたが、私が何か勘違いをしているのか、もしくはこの仕様に準拠している処理系が少ないのか。

まとめ

これまでlet*風にスロットの逐次初期化を2パスで考えてみましたが、shared-initializeを差し替えてしまった方が素直なのかもしれません。
そのうち試してみようかなと思います。


HTML generated by 3bmd in LispWorks 7.0.0

MOP vs マクロ (4)

Posted 2019-02-11 15:59:28 GMT

MOP vs マクロなネタを探していますが、古えのメールに面白そうなものがあったので、これをどうにかMOP vs マクロの枠内で再現してみることにします。

ちなみに、このECLOSですが、Metaclass libraryとあるように、MOP的なツールを纏めた商用ライブラリだったようです。
メタクラス関係だけで商品になってたというのが凄い。

告知メールによると主なアイテムは、

  • self-referent class
  • instance-recording-class (get to instances from their class, but allow their garbage collection).
  • operating-class (implement recursive operations like copy-object, equal-object-p with suscint in-class specifications)
  • lazy-class (establish inter-slot/access dependencies to avoid initializing slots until they are needed/make-sense)
  • attributed-class (arbitrary-depth attributes in slots, great for frame-like programming)
  • constrained-class (multi-way constraints and daemons can be stored in and refer transparently to slots).
  • An enhanced Delta-Blue constraint solver with a higher-order architecture for dynamic update of constraint graphs (no propagate as if graph still unchanged semantics).
  • let*-like slot initialization semantics

ですが、定番そうなものから何やら良く分からないものまであります。

今回は、このリストの中からlet*-like slot initialization semanticsをMOPとマクロで再現してみたいと思います。
例のごとくまずはマクロでの実現から始めます。

let*-like slot initialization semantics をマクロで書いてみる

まず、動作の確認ですが、詳細は不明なものの、多分let*のように上方のスロットの値が次のスロットで使えるということなのではないかと思います。

動作例を考えると、下記のようになるかと思いますが、やりたいことが単純な割には実現は面倒臭そうです。

(let ((z 42))
  (defclass* qqq ()
   ((a :initform z :initarg :a :initarg a)
    (b :initform a :initarg :b :initarg b)
    (c :initform (+ a b) :initarg :c :initarg c))))

(with-slots (a b c) (make-instance 'qqq) (list a b c)) ;=> (42 42 84) (with-slots (a b c) (make-instance 'qqq :c 0) (list a b c)) ;=> (42 42 0) (with-slots (a b c) (make-instance 'qqq :b 0) (list a b c)) ;=> (42 0 42) (with-slots (a b c) (make-instance 'qqq :a 0) (list a b c)) ;=> (0 0 0) (with-slots (a b c) (make-instance 'qqq :a 0 :b 1) (list a b c)) ;=> (0 1 1)

一応の解説ですが、上記のクラス定義フォームを素のdefclassで置き換えた場合、bcスロットでabが未束縛でエラーになります。
変数zに関してはdefclassは外側の変数を取り込めるのでzはレキシカル変数になります。

(let ((z 42))
  (defclass ppp ()
   ((a :initform z :initarg :a :initarg a)
    (b :initform a :initarg :b :initarg b)
    (c :initform (+ a b) :initarg :c :initarg c))))

(make-instance 'ppp) ;!!! The variable a is unbound.

このlet*的な初期化構文のポイントは、let*的な順次初期化は、クラス定義時に行なわれるのではなく、インスタンス(再)初期化時に行なわれるということです。

マクロでどうするか考えてみる

あれこれ考えてみましたが、とりあえずスロットの初期化を2パスにするのが一番簡単そうなので、それで行くことにしました。

  • スロットの:initfunctionに設定する関数でクロージャーを返すようにしインスタンス初期化まで評価を遅らせる
  • インスタンス初期化時に、スロットの値が保留になっているかを調べて保留状態ならクロージャーを評価し値を設定

という所です。

マクロ展開を眺めるのが一番早いと思うのですが下記のような展開になります。

(defclass* qqq ()
  ((a :initform 42 :initarg :a)
   (b :initform a :initarg :b)
   (c :initform (+ a b) :initarg :c)))
===>
(eval-when (:compile-toplevel :load-toplevel :execute)
  (let ((#:a368281
         (lambda (obj)
           (with-slots (a b c) obj (declare (ignorable a b c)) 42)))
        (#:b368282
         (lambda (obj) (with-slots (a b c) obj (declare (ignorable a b c)) a)))
        (#:c368283
         (lambda (obj)
           (with-slots (a b c) obj (declare (ignorable a b c)) (+ a b)))))
    (ensure-class 'qqq
                  :direct-superclasses
                  (adjoin 'let*-standard-object 'nil)
                  :direct-slots
                  (list (list :name 'a :initargs '(:a) :initform '42 :initfunction (lambda () #:a368281) :writers 'nil :readers 'nil)
                        (list :name 'b :initargs '(:b) :initform 'a :initfunction (lambda () #:b368282) :writers 'nil :readers 'nil)
                        (list :name 'c :initargs '(:c) :initform '(+ a b) :initfunction (lambda () #:c368283) :writers 'nil :readers 'nil)))
    (defmethod initialize-let*-slots ((obj qqq))
      (let ((sname 'a))
        (when (slot-boundp obj sname)
          (let ((sval (slot-value obj sname)))
            (when (eq #:a368281 sval)
              (setf (slot-value obj sname) (funcall sval obj))))))
      (let ((sname 'b))
        (when (slot-boundp obj sname)
          (let ((sval (slot-value obj sname)))
            (when (eq #:b368282 sval)
              (setf (slot-value obj sname) (funcall sval obj))))))
      (let ((sname 'c))
        (when (slot-boundp obj sname)
          (let ((sval (slot-value obj sname)))
            (when (eq #:c368283 sval)
              (setf (slot-value obj sname) (funcall sval obj)))))))))

マクロ定義(およびクラス定義)

(cl:in-package :cl-user)

(ql:quickload :closer-mop)

(cl:defpackage :dc07f5fa-62ee-40a1-ae1a-d1a0f87d19bb (:use :c2cl))

(cl:in-package :dc07f5fa-62ee-40a1-ae1a-d1a0f87d19bb)

(defclass let*-standard-object (standard-object) ())

(defun process-a-slot (slot) (loop :with name := (car slot) :for (k v) :on (cdr slot) :by #'cddr :when (eq k :initform) :append `(:initform ,v :initfunction ,(coerce `(lambda () ,v) 'function)) :into initform :when (eq k :initarg) :collect v :into initargs :when (eq k :writer) :collect v :into writers :when (eq k :reader) :collect v :into readers :when (eq k :accessor) :collect v :into readers :and :collect `(setf ,v) :into writers :finally (return `(:name ,name :initargs ,initargs ,@initform :writers ,writers :readers ,readers))))

(defgeneric initialize-let*-slots (obj))

(defmethod shared-initialize :after ((obj let*-standard-object) slot-names &rest initargs &key &allow-other-keys) (initialize-let*-slots obj))

(defmacro defclass* (name (&rest superclasses) (&rest slots) &rest class-options) (loop :with slot-names := (mapcar (lambda (x) (if (consp x) (car x) x)) slots) :for s :in slots :for cs := (copy-list (process-a-slot s)) :for ifn := (gensym (string (getf cs :name))) :collect cs :into canonicalized-slots :collect `(,ifn (lambda (obj) (with-slots (,@slot-names) obj (declare (ignorable ,@slot-names)) ,(getf cs :initform)))) :into bvs :collect `(let ((sname ',(getf cs :name))) (when (slot-boundp obj sname) (let ((sval (slot-value obj sname))) (when (eq ,ifn sval) (setf (slot-value obj sname) (funcall sval obj)))))) :into slot-init-forms :do (setf (getf cs :initfunction) `(lambda () ,ifn)) :finally (return `(eval-when (:compile-toplevel :load-toplevel :execute) (let (,@bvs) (ensure-class ',name :direct-superclasses (adjoin 'let*-standard-object ',superclasses) :direct-slots (list ,@(mapcar (lambda (s) (destructuring-bind (&key name initargs initform initfunction writers readers &allow-other-keys) s `(list :name ',name :initargs ',initargs :initform ',initform :initfunction ,initfunction :writers ',writers :readers ',readers))) canonicalized-slots)) ,@class-options) (defmethod initialize-let*-slots ((obj ,name)) ,@slot-init-forms))))))

まとめ

案外ほとんどMOP的な要素を使わずにマクロのみで実現できてしまいましたが、スコープ的なものを扱うのでマクロの方が得意なのかもしれません。

ちなみに、スロットの:initfunctionは、ANSI Common Lispの規格にはなく、MOPで規定されているものですが、まあこれくらいは良しとしましょう。

さてこれを今後MOP的にして行きたいと思います。


HTML generated by 3bmd in LispWorks 7.0.0

MOP vs マクロ (3)

Posted 2019-02-03 20:45:41 GMT

前回は、全面的なマクロから、ensure-classを使って若干のMOP利用へと進めましたが、今回は、ensure-class-using-classを利用して、もう一歩進めてみたいと思います。

ensure-class-using-class を利用してみる

ensure-classは関数ということもあり、プロトコルを成しているメソッド群をカスタマイズするという感じではありませんが、ensure-classの下請けのensure-class-using-classは、standard-classをカスタマイズしたメタクラスでディスパッチさせることが可能です。

(defpackage d34ab7fb-8666-4f9c-ac95-833380ffefee 
  (:use :c2mop :cl)
  (:shadowing-import-from :c2mop
   :defmethod :standard-class :defgeneric 
   :standard-generic-function :funcallable-standard-class))

(in-package d34ab7fb-8666-4f9c-ac95-833380ffefee)

(defun slot-name-conc (prefix name) (let ((pkg (etypecase prefix ((or null string) *package*) (symbol (symbol-package prefix))))) (intern (concatenate 'string (string prefix) (string name)) pkg)))

(defclass conc-name-class (standard-class) ((conc-name :initarg :conc-name :accessor class-conc-name)))

(defmethod validate-superclass ((class conc-name-class) (super standard-class)) T)

上記では、standard-classメタクラスのサブクラスとしてconc-name-classメタクラスを定義してみています。

これで、ensure-class-using-classがディスパッチできるようになります。

(defmethod ensure-class-using-class ((class conc-name-class) name
                                     &rest initargs
                                     &key (conc-name (concatenate 'string (string name) ".") conc-name-sup?)
                                          direct-slots
                                     &allow-other-keys)
  (when conc-name-sup?
    (setq conc-name (car conc-name)))
  (setq direct-slots
        (loop :for s :in direct-slots
              :collect (destructuring-bind (&key name readers writers &allow-other-keys) 
                                           s
                         (let ((aname (slot-name-conc conc-name name)))
                           `(:name ,name
                             :readers (,aname ,@readers)
                             :writers ((setf ,aname) ,@writers))))))
  (let ((class (apply #'call-next-method class name :direct-slots direct-slots
                      initargs)))
    (setf (class-conc-name class) conc-name)
    class))

ensure-classと同じく、ensure-class-using-classが取るキーワード引数は、defclassのクラスオプションが渡ってきますので、以上で下記のように書けます。

(defclass foo ()
  (x 
   y 
   (z :accessor z))
  (:metaclass conc-name-class)
  (:conc-name foo.))

(let ((qqq (make-instance 'foo))) (with-slots (x y z) qqq (setq x 42 y 43 z 44)) (incf (foo.z qqq)) (list (foo.x qqq) (foo.y qqq) (foo.z qqq)))(42 43 45)

マクロ的なアプローチの問題点として

  • defclassの派生構文ができてしまう

というのがありましたが、:metaclassを一々指定するのは面倒臭いもののdefclassの標準構文に収まりました。
また、

  • マクロ内でdefclassのオプションを解析するのがめんどくさい

というのもensure-classが正規化して渡してくれるので、ensure-classよりはすっきりします。

しかし今度もあまりMOP的でない?

しかし、上記のコードを眺めると判るように前回とさして変化ありません。
アクセサの名前に接頭辞を付けるのだから、MOP的にするなら、スロット定義メタオブジェクトをあれこれするのが筋なのではないか、ということになります。

ということで、スロット定義のプロトコルをカスタマイズしてみます。

(defclass conc-name-direct-slot-definition (standard-direct-slot-definition)
  ((conc-name :initform nil :initarg :conc-name)))

(defmethod direct-slot-definition-class ((class conc-name-class) &rest initargs) (find-class 'conc-name-direct-slot-definition))

(defmethod initialize-instance :around ((sd conc-name-direct-slot-definition) &rest args &key name conc-name) (let ((aname (slot-name-conc conc-name name)) (inst (call-next-method))) (pushnew aname (slot-definition-readers sd) :test #'equal) (pushnew `(setf ,aname) (slot-definition-writers sd) :test #'equal) inst))

(defmethod ensure-class-using-class ((class conc-name-class) name &rest initargs &key (default-conc-name (concatenate 'string (string name) ".") default-conc-name-sup?) direct-slots &allow-other-keys) (when default-conc-name-sup? (setq default-conc-name (car default-conc-name))) (apply #'call-next-method class name :default-conc-name default-conc-name :direct-slots (mapcar (lambda (s) (if (getf s :conc-name) s (list* :conc-name default-conc-name s))) direct-slots) initargs))

解説すると、まずデフォルトのstandard-direct-slot-definitionをカスタマイズするために、conc-name-direct-slot-definitionを定義します。
conc-name-direct-slot-definitionの中では、指定された接頭辞をもとにアクセサ名を生成します。
スロット定義では、:conc-nameで接頭辞を指定しますが、スロット定義メタオブジェクトを生成する時のキーワード引数はdefclassのスロットのキーワード引数が正規化されたものになりますので、単純に:conc-nameを追加しておけばOKです。

次に、このスロット定義を呼び出すために、direct-slot-definition-classが返すクラスをconc-name-direct-slot-definitionに設定します。
direct-slot-definition-classが返すクラスでスロット定義を生成するプロトコルなので、スロット定義のサブクラスを作ってカスタマイズしても、これに設定しないと有効にできません。

また、クラス定義の方で指定する接頭辞とスロットで指定する接頭辞を区別したいので、クラス定義の方は、default-conc-nameと変更します。

(defclass conc-name-class (standard-class)
  ((conc-name :initarg :default-conc-name :accessor class-conc-name)))

これでこんな感じに書けます

(defclass bar ()
  ((x :conc-name bar=) 
   (y :conc-name bar_) 
   (z :accessor z))
  (:default-conc-name bar.)
  (:metaclass conc-name-class))

(let ((qqq (make-instance 'bar))) (with-slots (x y z) qqq (setq x 42 y 43 z 44)) (incf (bar.z qqq)) (list (bar=x qqq) (bar_y qqq) (bar.z qqq)))(42 43 45)

スロットごとに接頭辞を付けて便利なことがあるかは不明ですが、スロット定義のプロトコルに従ったお蔭でおまけ的に別個に指定できたりします。

まとめ

以上、マクロだけでの実現からMOP的なものまでを順に考えてきましたが、MOPの方は作法を憶えるのが面倒臭いです。
まあしかし、MOPの作法は一応標準化されていますので、俺マクロの使い方を憶えるよりは、ましだったりするかもしれません。


HTML generated by 3bmd in LispWorks 7.0.0

MOP vs マクロ (2)

Posted 2019-01-23 17:36:05 GMT

長くなりそうなので数回に分けた記事にしようと思っていましたが、前回の記事を書くなかで自分の中では問題は解決してしまったので、続きを書くのをすっかり忘れていました。

それはさておき、前回は、お題を全部マクロで実現した訳ですが、今回は若干MOPよりです。
といっても、MOPが定めている便利ユーティリティを利用するのみでメタオブジェクトをあれこれという訳ではありません。 「マクロだけでがんばる」から「MOPだけでがんばる」の方向に進めて行き、丁度良い落とし所はどの辺りかを探っていければ良いなと考えています。

ensure-class を利用してみる

前回は、defclassのラッパーという感じでしたが、今回はMOPが定めるdefclassを組み立てるための関数であるensure-classを利用します。
ensure-classは、defclassを組み立てるための関数ともいえますし、ensure-classをお化粧したのがdefclassともいえるでしょう。
(setf (fdefinition 'foo) ...)(defun foo (...) ...)のような関係と考えるとわかりやすいかと思います。

コードは長いので後ろに置きますが、ensure-classを使えばこんな感じのものに構成できます。

(defclass/conc-name foo ()
  (x 
   y 
   (z :accessor z))
  (:conc-name foo.))

;;; マクロ展開 ===> (eval-when (:compile-toplevel :load-toplevel :execute) (ensure-class 'foo :direct-superclasses 'nil :direct-slots '((:name x :writers ((setf foo.x)) :readers (foo.x)) (:name y :writers ((setf foo.y)) :readers (foo.y)) (:name z :writers ((setf z) (setf foo.z)) :readers (z foo.z))) :direct-default-initargs 'nil))

(let ((qqq (make-instance 'foo))) (with-slots (x y z) qqq (setq x 42 y 43 z 44)) (incf (foo.z qqq)) (list (foo.x qqq) (foo.y qqq) (foo.z qqq)))(42 43 45)

前回の問題点として

  • defclassの派生構文ができてしまう
  • マクロ内でdefclassのオプションを解析するのがめんどくさい

の二点がありましたが、ensure-classを使っても別段問題は解消されていません。
ensure-classを使った場合、:accessorは、:writer:readerの組み合わせとして正規化する必要があるので、見通しが若干良くなるのかも、というところです。

オプションの解析部分をより拡張性のあるものにすれば(例えば総称関数にする等)、汎用的な構文として綺麗にまとめられるかもしれません。

既にこの辺りが落とし所な気はしますが、次回はさらにMOP的にすべくensure-class-using-classの活用を考えてみます。

付録: ensure-class を使ってみた場合の定義例

(defpackage 05d2b99b-651a-4352-ba04-47593339a944 
  (:use :c2mop :cl)
  (:shadowing-import-from :c2mop :defmethod :standard-class :defgeneric :standard-generic-function))

(in-package 05d2b99b-651a-4352-ba04-47593339a944)

(eval-when (:compile-toplevel :load-toplevel :execute) (defun canonicalize-slots (slots) (labels ((canonicalize-slot (slot) (typecase slot ((and symbol (not null)) (list slot)) (T slot)))) (mapcar #'canonicalize-slot slots)))

(defun slot-name-conc (prefix name) (let ((pkg (etypecase prefix ((or null string) *package*) (symbol (symbol-package prefix))))) (intern (concatenate 'string (string prefix) (string name)) pkg)))

(defun process-a-slot (slot) (loop :with name := (car slot) :for (k v) :on (cdr slot) :by #'cddr :when (eq k :initform) :append `(:initform ,v :initfunction (lambda () ,v)) :into initform :when (eq k :writer) :collect v :into writers :when (eq k :reader) :collect v :into readers :when (eq k :accessor) :collect v :into readers :collect `(setf ,v) :into writers :finally (return `(:name ,name ,@initform :writers ,writers :readers ,readers)))))

(defmacro defclass/conc-name (name superclasses slots &rest class-options) (let* ((conc-name (concatenate 'string (string name) "-")) (class-options (loop :for opt :in class-options :if (eq :conc-name (car opt)) :do (when (cadr opt) (setq conc-name (cadr opt))) :else :collect opt))) `(eval-when (:compile-toplevel :load-toplevel :execute) (ensure-class ',name :direct-superclasses '(,@superclasses) :direct-slots '(,@(loop :for s :in (canonicalize-slots slots) :for aname := (slot-name-conc conc-name (car s)) :collect (process-a-slot `(,@s :accessor ,aname)))) :direct-default-initargs '(,@class-options)))))


HTML generated by 3bmd in LispWorks 7.0.0

MOP vs マクロ (1)

Posted 2019-01-13 21:46:09 GMT

オブジェクト指向システムを拡張する際に、痒い所に微妙に手が届かない気がするMOPと、なんでもできるけど安易なメタプログラミングも嫌だなあというマクロで使い分けに迷うことはないでしょうか。

例えばですが、defstructにはアクセサを自動で生成する機能があり、この機能については善し悪しがありますが、defclassで同様のアクセサの自動生成を実装するとします。
さて、こういう場合、MOPで実現するのが良いのか、マクロでやっつけてしまえば良いのか微妙に悩んだりしないでしょうか(自分だけ?)

defclassでアクセサの生成をするということは、定義時には名前が確定しているということで、マクロが担当するのが良い気もします。
しかしクラスに関することなので、MOPを使った方が既存の構文の枠組みで拡張できたりもしそうです。

どっちもどっちなのですが、とりあえずはマクロで書いてみました。
defclass/conc-nameは、defcassに展開されるマクロですが、:conc-nameでアクセサの接頭辞を指定できます。

(defclass/conc-name foo ()
  (x 
   y 
   (z :accessor z))
  (:conc-name foo.))

;;; マクロ展開
===>
(defclass foo ()
  ((x :accessor foo.x)
   (y :accessor foo.y)
   (z :accessor z :accessor foo.z)))

(let ((qqq (make-instance 'foo)))
  (with-slots (x y z) qqq
    (setq x 42 y 43 z 44))
  (incf (foo.z qqq))
  (list (foo.x qqq)
        (foo.y qqq)
        (foo.z qqq)))(42 43 45) 

defclass/conc-name定義

(defun canonicalize-slots (slots)
  (labels ((canonicalize-slot (slot)
             (typecase slot
               ((and symbol (not null)) (list slot))
               (T slot))))
    (mapcar #'canonicalize-slot slots)))

(defun slot-name-conc (prefix name) (let ((pkg (etypecase prefix ((or null string) *package*) (symbol (symbol-package prefix))))) (intern (concatenate 'string (string prefix) (string name)) pkg)))

(defun ->conc-name (name) (etypecase name (null "") (symbol (string name)) (string name)))

(defmacro defclass/conc-name (name superclasses slots &rest class-options) (let* ((conc-name-p nil) (conc-name (concatenate 'string (string name) "-")) (class-options (loop :for opt :in class-options :if (eq :conc-name (car opt)) :do (setq conc-name-p T conc-name (->conc-name (cadr opt))) :else :collect opt))) `(defclass ,name (,@superclasses) (,@(loop :for s :in (canonicalize-slots slots) :when conc-name-p :do (setf (cdr (last s)) (list :accessor (slot-name-conc conc-name (car s)))) :collect s)) ,@class-options)))

マクロで実装してみた感想

マクロで書いた場合ですが、今回の場合は、

  • defclassの派生構文ができてしまう
  • マクロ内でdefclassのオプションを解析するのがめんどくさい

等々が問題かなと感じます。

defclassのオプションを解析するのがめんどくさいのは、defclassの作法に従おうとした結果で、その方が、使い手も類推できて良かろうという判断なのですが、どうせ拡張された構文なので解析しやすそうな構成にすることも可能かなとは思います。
defstructの作法に近付けるなら、

(defclass/conc-name (foo (:conc-name foo.)) ()
  (x 
   y 
   (z :accessor z)))

のようにできるかもしれません。
問題は、defclass/conc-namedefstructの作法で書くという情報の取扱がめんどう(使う側の人が色々憶えないといけない)ということです。

利用者の負担を減らすということでは、構文乗っ取り型マクロにしてしまう手もなくはありませんが、どうなんでしょう。

(with-conc-name foo.

(defclass foo () (x y (z :accessor z))))

;; or (with-accessor-options ((:conc-name foo.) (:foo opt)) (defclass foo () (x y (z :accessor z)))) ...

この場合は、見掛け上defclassが本体に見えますがwith-conc-namedefclassフォームを引数として処理することになります。

トリッキーですが派生構文を処理する場合には、defclass/conc-nameのような新しい名前を導入せずに既存の作法を継承できるので、一番スマートな方法だったりするかもしれません。

次回はMOPの作法で考えてみます。


HTML generated by 3bmd in LispWorks 7.0.0

Common Lisp標準が利用するキーワードシンボル一覧はどこにある

Posted 2019-01-02 23:43:53 GMT

たまにCommon Lisp標準が利用するキーワードシンボル一覧が欲しい時がありますが、どこにあるんでしょうか。

とりあえずのところは、HyperSpecのインデックスが利用できると思います。

しかし、どこかにキーワードシンボルだけまとめたものがありそうなのですが……。

少し探しても見当らなかったので、HyperSpecを参考に逆引きCommon Lispに記事を作成してみました。

ちなみに、HyperSpecのものは記事からインデックスを自動生成かなにかをしているようでタイポがあったり、コード例に使われているだけのキーワードシンボルも計上されているようです。

まとめ

エディタの補完機能まわりをカスタマイズしているときに関数が利用するキーワードだけを補完して欲しいのですが、まずは補完対象の一覧が欲しいなと思って、ここに至ります。
ひょっとしたら、ANSI Common Lisp規格票には掲載されていたりするかもと思い確認してみましたが、こちらにも無いようです。うーむ。


HTML generated by 3bmd in LispWorks 7.0.0

2018年振り返り

Posted 2018-12-31 18:57:12 GMT

毎年振り返りのまとめを書いているので、今回も書いてみます。

Lisp的進捗

ここ数年マニアックなLispネタでアドベントカレンダーを開催することで、色々調べたりしてLispのマイナー機能に詳しくなるというのをやっていました。
2017年はお休みしたのですが、若干の悔いが残ったので、2018年は、setfとメソッドコンビネーションネタでやってみました。
毎回これ以上はないなという所まで掘り下げられるので良い勉強になります(多分)。

メソッドコンビネーションに関しては、まだ掘り下げて書けることがありそうなので、そのうちちょっと書いてみたいと思います。

ブログ

今年書いた記事は72記事だったようです。
アドベントカレンダーで50記事位書いたのを除けば、大体二週間に一記事書いたり書かなかったりというところです。
近年、ブログを書く人も大分少なくなりましたが、2019年もそこそこ書いていきたいと思います。

LispWorks

LispWorksを購入してから早三年半ですが、持ち前の吝嗇根性からLispWorksを使い倒すべくメインに使い続けています。

ちなみに、以前は、SBCLをメインに使っていました。
SBCLはコンパイラ優秀で、実行速度からいうとほぼ最速の処理系で、ユーザーも一番多く、その上自由ソフトな処理系ということもあり、これ以外の選択はないだろうという感じでもあるのですが、GUIツールキット、Common Lispと統合された開発環境、出荷機能まで一通り揃っている完成度の高い処理系というとLispWorks、Allegro CL、MCL位しかありません。
Allegro CLは個人で使うにはお値段が謎、MCLはPPC Macと共に過去のものになってしまった等で、現実的な統合環境としてはLispWorks位かなと思います。

また、職場の社内ツールをLispWorksで作成してみたところ、色々な条件がたまたま上手くはまり、現在もLispWorksで開発が進んでいます。

  • 社内にLispWorksユーザーがたまたま二人いた
  • MacでGUIのアプリが必要だったので、LispWorksのCAPIに詳しい人がプロトタイプを作ってみたら手早くできちゃった

というところで、まさに偶然ですが、折角の機会なので活用していきたいところです。
ちなみに開発は同僚にお任せしているので、たまに思い付きの機能追加をしてみたりする以外では私はほとんど開発してません😺

2019年やってみたいこと

ここ二三年でLispマシンのエミュレータも、CADR、LMI Lambda、Symbolics Open Genera、TI Explorer、等一通り出揃いましたが、あまりキャッチアップできてないので2019年は力を入れようかなと思っています。

あと年末には、コンディションシステムアドベントカレンダーを開催したいので、色々準備しておきたいところです。

過去のまとめ


HTML generated by 3bmd in LispWorks 7.0.0

setfアドベントカレンダー総括

Posted 2018-12-24 15:00:01 GMT

Lisp SETF Advent Calendar 2018 25日目 》

メソッドコンビネーションでアドベントカレンダーを開催することを決めてから、もう一品と考えてsetfアドベントカレンダーを開催してみましたが、後半はネタを捻り出すのがきつかったです。

よくよく考えれば、ただの代入機構なので、話題が広げられる余地はあまりないのですが、ファーストクラスの参照を持つLISP方言についてもうちょっと掘り下げて書けたかもしれません(といっても一回分位だと思いますが)

setfアドベントカレンダーのを書いたお蔭で、setfの定義構文の使い分けについて、きっちり把握できたのは収穫かなと思います。

-完-


HTML generated by 3bmd in LispWorks 7.0.0

メソッドコンビネーションアドベントカレンダー総括

Posted 2018-12-24 15:00:00 GMT

Lisp メソッドコンビネーション Advent Calendar 2018 25目 》

メソッドコンビネーションでアドベントカレンダーは無謀かなと思いましたが、果してそれなりに無謀でした。

このアドベントカレンダーでの収穫は、eshamsterさんに define-method-combinationの詳細な解説を書いて頂けたことかなと思います。
今後define-method-combinationを書く際には参照することも多くなるのではないでしょうか。

メソッドコンビネーションについて分かったこと

私的にメソッドコンビネーションについて分かったことを纏めると

  • define-method-combinationは、Common Lispには珍しく細部仕様の詰めが甘いらしい
  • :aroundはメソッド周囲をletで囲むような使い方をするもので、:afterや、:beforeとは一線を画す(ので同じ感覚で多用するものではなさそう)
  • 割とカジュアルに定義して使うことを考えていたらしい(New flavorsあたりの論文では)
  • メソッドの分別の単位はメソッド修飾子。なのでクラスの継承関係とは別個に構成可能。かと思えば、メソッドコンビネーションにメソッドを参加させるためにmixinするようなことも行われていたらしい。
  • メソッドの組織化全般に使える

位でしょうか。

メソッドコンビネーションは、まだまだ開拓の余地があると思いますので、今後、さらに活用されることを期待しています。

-完-


HTML generated by 3bmd in LispWorks 7.0.0

X3J13 88-003Rのメソッドコンビネーションを探る

Posted 2018-12-23 20:14:57 GMT

Lisp メソッドコンビネーション Advent Calendar 2018 24目 》

前回、MOPでのメソッドコンビネーションAPIの実現は、紆余曲折ありつつ、曖昧なところを残しているらしい、と書きました。
今回は、ANSI CLでは取り入れられなかったMOP仕様の草案である X3J13-88-003R の 1988-03-11 版にメソッドコンビネーションのAPIについての記述があったので、それを実際に動かしてみて、どのような設計方針であったのかを探ります。

なお、X3J13-88-003R の 1988-03-11版はTeXをPDFにしたものがこちらにありますので、適宜参照してください。

下準備

シンボル名の競合がありそうなので、専用のパッケージを作成します。

(defpackage X3J13-88-003R
  (:use :cl :c2mop)
  (:shadowing-import-from :c2mop
   :defmethod :standard-class :defgeneric :standard-generic-function)
  (:shadow :define-method-combination))

(in-package :X3J13-88-003R)

メソッドコンビネーションクラスの定義

method-combinationのサブクラスにstandard-method-combinationsimple-method-combinationが標準で用意されています。
ただ使い分けについてはいまいちはっきりしません。
とりあえず記述をそのままコードにしています。

(defclass x3j13-88-003r-method-combination (method-combination)
  ((name
    :initarg :name
    :reader method-combination-name)
   (order
    :initarg :order
    :reader method-combination-order)
   (operator
    :initarg :operator
    :reader method-combination-operator)
   (identity-with-one-argument
    :initarg :identity-with-one-argument
    :reader method-combination-identity-with-one-argument)
   (documentation 
    :initarg :documentation))
  (:default-initargs
   :name nil
   :order :most-specific-first
   :operator nil
   :identity-with-one-argument nil
   :documentation nil))

(defclass standard-method-combination (x3j13-88-003r-method-combination) ())

(defclass simple-method-combination (x3j13-88-003r-method-combination) ())

(defclass short-form-method-combination (simple-method-combination) ())

ここでは、x3j13-88-003r-method-combinationmethod-combinationのサブクラスにしていますが、恐らくこの定義が、method-combinationの定義になる予定だったのでしょう。

ANSI CLのdefine-method-combinationで指定するようなオプションが、method-combinationの方で定義されていることが分かります。

メソッドコンビネーションオブジェクトのメソッド

メソッドコンビネーション名からメソッドコンビネーションオブジェクトを引いてくるのにmethod-combination-objectを定義します。
AMOPのfind-method-combinationとほぼ同じですが、こちらは総称関数は指定しません。
中身のコードは大体想像で書いています。

(defgeneric method-combination-object (name options))

(defmethod method-combination-object ((name (eql nil)) options) (class-prototype 'standard-method-combination))

(defmethod method-combination-object ((name (eql nil)) options) (class-prototype 'standard-method-combination))

(defmethod method-combination-object ((name (eql 'standard-method-combination)) options) (class-prototype 'standard-method-combination))

define-method-combinationの定義

define-method-combinationは、名前を指定するだけでmethod-combination-objectを簡便に定義できるような位置付けになっています。

short-form-method-combinationが決め打ちになっているのですが、意図的なものなのか間違いなのかははっきりしません。

(defmacro define-method-combination (name &key (documentation nil)
                                          (operator name)
                                          (identity-with-one-argument nil))
  `(defmethod method-combination-object
              ((name (eql ',name))
               options)
     (apply (lambda (&optional (order ':most-specific-first))
              (check-type order (member :most-specific-first
                                        :most-specific-last))
              (make-instance 'short-form-method-combination
                             :name ',name
                             :order order
                             :documentation ',documentation
                             :operator ',operator
                             :identity-with-one-argument
                             ',identity-with-one-argument))
            options)))

メソッド呼び出しのフォームを作るユーティリティ

make-method-callというユーティリティがあったようですが、このインターフェイスではメソッドの引数を上手く取り扱えないということで廃止になったようです。

ユーティリティが何もない現在は結局ベタ書している状況ですが、このmake-method-callを使っても大抵は問題はなさそうではあります。

なお、このコードも使用例から想像して書いています。

(defun make-method-call (method-list &key operator identity-with-one-argument)
  (case operator
    (:call-next-method `(call-method ,(car method-list)
                                     ,(cdr method-list)))
    (ohterwise `(,operator 
                 ,@(loop :for m :in method-list :collect `(call-method ,m))))))

大体これくらいの定義ですが、これだけでもメソッドコンビネーションが定義できます。

compute-effective-method

define-method-combinationは、メソッドコンビネーションオブジェクトに名前を付けて登録する程度の役割になっていましたが、代りにcompute-effective-methodが式の組み立てのメインになります。

(defmethod compute-effective-method (generic-function
                                     (mc short-form-method-combination)
                                     methods)
  (let ((primary-methods (remove (list (slot-value mc 'name))
                                 methods :key #'method-qualifiers
                                 :test-not #'equal))
        (around-methods (remove '(:around)
                                methods :key #'method-qualifiers
                                :test-not #'equal)))
    (when (eq (slot-value mc 'order) ':most-specific-last)
      (setq primary-methods (reverse primary-methods)))
    (dolist (method (set-difference methods
                                    (union primary-methods around-methods)))
      (error "The qualifiers of ~S, ~:S, are not ~S or ~S"
             method (method-qualifiers method)
             (list (slot-value mc 'name)) '(:around)))
    (make-method-call `(,@around-methods
                        (make-method 
                         ,(make-method-call primary-methods
                                            :operator (slot-value mc 'operator)
                                            :identity-with-one-argument
                                            (slot-value mc 'identity-with-one-argument))))
                      :operator :call-next-method)))

メソッドを定義してみる

ではメソッドを定義して動作を確認してみましょう。
総称関数の:method-combination指定が構文チェックでエラーになったりするのでensure-generic-functionを直に使ってみます。

(define-method-combination foo :operator :call-next-method)

(ensure-generic-function 'zot :lambda-list '(x) :method-combination (method-combination-object 'foo nil))

;; ≡ (defgeneric zot (x)) ;; ;; (setf (generic-function-method-combination #'zot) ;; (method-combination-object 'foo nil))

(defmethod zot foo (x) (list :p x))

(defmethod zot foo ((x integer)) (list :p 'integer (call-next-method)))

(defmethod zot :around (x) (list :around (call-next-method)))

(zot 8)(:around (:p integer (:p 8))) 

  • メソッドコンビネーション展開

(compute-effective-method #'zot 
                          (method-combination-object 'foo nil)
                          (compute-applicable-methods #'zot (list 8)))(call-method
 #<standard-method zot (:around) (t) 41E012FF53>
 ((make-method
   (call-method
    #<standard-method zot (foo) (integer) 41E012FCDB>
    (#<standard-method zot (foo) (t) 41E01306C3>))))) 

上手く動いているようです。

まとめ

以上、X3J13 88-003Rでの定義でしたが、それなりにすっきり纏まっている気がします。
define-method-combination:argumentsオプションについては触れられていないのですが、compute-discriminating-functionの祖先の定義お眺める限りは、compute-discriminating-functioncompute-effective-methodの内容を元に関数オブジェクトを生成する際、総称関数の引数と連結するスコープを差し込むつもりだったのかなと想像しています。

(generic-function (gf-args ...)
  ((lambda (args ...) ;;; define-method-combination の :arguments
     ,@effective-method)
   gf-args ...))

謎が多い、define-method-combinationまわりですが、MOPベースだったら、もうちょっとカスタマイズされたメソッドコンビネーションも活用されていたかもしれません(そうでもないか)


HTML generated by 3bmd in LispWorks 7.0.0

setf-expansionの返り値が憶えられない

Posted 2018-12-23 16:28:40 GMT

Lisp SETF Advent Calendar 2018 24日目 》

これまでも何度かget-setf-expansionや、define-setf-expanderを利用する例を取り上げてきましたが、返り値が5つもあります。
そのお蔭で、多値の何番目がなんの役割だったか毎度調べたりしていますが、これだとちょっと面倒なので、専用構文を作って開発環境のシンタックス補完等の恩恵に与る作戦を考えました。

まずは、get-setf-expansionですが、キーワード引数ならぬ、キーワード多値で値を返すことにしてみました。

(defun get-setf-expansion* (place &optional env)
  (multiple-value-bind (vars vals store-vars writer-form reader-form)
                       (get-setf-expansion place env)
    (values :vars vars
            :vals vals
            :store-vars store-vars
            :writer-form writer-form
            :reader-form reader-form)))

  • 素のget-setf-expansion

(get-setf-expansion '(ldb bytespec i))(#:g255423) 
   (bytespec) 
   (#:g255424) 
   (let ((#:|Store-Var-255422| (dpb #:g255424 #:g255423 i)))
     (setq i #:|Store-Var-255422|)
     #:g255424) 
   (ldb #:g255423 i) 

  • 拡張したget-setf-expansion*

(get-setf-expansion* '(ldb bytespec i))
→ :vars 
   (#:g255429) 
   :vals 
   (bytespec) 
   :store-vars 
   (#:g255430) 
   :writer-form 
   (let ((#:|Store-Var-255428| (dpb #:g255430 #:g255429 i)))
     (setq i #:|Store-Var-255428|)
     #:g255430) 
   :reader-form 
   (ldb #:g255429 i) 

返り値に注釈が付けば、位置とその役割を忘れても大丈夫です。

次に、このキーワード多値を受ける構文を考えてみました。

(defmacro setf-expansion-bind 
          ((&key vars vals store-vars writer-form reader-form)
           setf-expansion-form
           &body body)
  (loop :for (k . v) :in `((:vars . ,vars)
                           (:vals . ,vals)
                           (:store-vars . ,store-vars)
                           (:writer-form . ,writer-form)
                           (:reader-form . ,reader-form))
        :when v :collect `((,k ,v)) :into key-args
        :finally (return 
                  `(macrolet ((setf-expansion-values (&key vars vals store-vars writer-form reader-form)
                                `(values ,vars ,vals ,store-vars ,writer-form ,reader-form)))
                     (multiple-value-call 
                         (lambda (&key ,@key-args &allow-other-keys) 
                           ,@body)
                       ,setf-expansion-form)))))

ボディの中では、setf-expansion-valuesオペレーターで注釈付きで多値を記述できるようにしてあります。

(setf-expansion-bind (:vars vars 
                      :vals vals
                      :store-vars store-vars
                      :writer-form writer-form
                      :reader-form reader-form)
                     (get-setf-expansion* '(ldb bytespec i))
  (setf-expansion-values :vars vars 
                         :vals vals
                         :store-vars store-vars
                         :writer-form writer-form
                         :reader-form reader-form))(#:g255477) 
   (bytespec) 
   (#:g255478) 
   (let ((#:|Store-Var-255476| (dpb #:g255478 #:g255477 i)))
     (setq i #:|Store-Var-255476|)
     #:g255478) 
   (ldb #:g255477 i) 

記述は面倒ですが、たまにしか使わないのとキーワードによる注釈が付くので扱いやすい気がします。
ごちゃごちゃしたキーワード引数はSLIME等でまとめて補完可能なので手打ちする必要はありません。

まとめ

今回は、構文定義 & IDEでの補完 の組み合わせで考えてみましたが、get-setf-expansionのフォームをmultiple-value-bindのフォームで包むような補完ができるIDEの拡張を作ってみても良いかなと思ったりしています。


HTML generated by 3bmd in LispWorks 7.0.0

setf系便利構文紹介

Posted 2018-12-23 11:08:45 GMT

Lisp SETF Advent Calendar 2018 23日目 》

あと三回setfネタで記事を書かないといけないのですが、何が書けるでしょうか。

とりあえず、今回はsetfのような代入構文をさらに便利にしたような構文を紹介してみたいと思います。

自己代入系

これまで自己代入系の定義構文を紹介したりしましたが、都度定義するのではなく、汎用的なものを定義して使う、というパターンです。

Gauche: update!

(update! place proc)という形式ですが、incfみたいなものは、

(let ((x (list 0)))
  (update! (car x) (lambda (v) (+ v 1))) 
  x)(1)

と書けます。
define-modify-macroで一々定義するよりずっと良いですね。

Arc: zap

Gaucheのupdate!とほぼ同じです。引数の順番と名前が違う位です。

(let x (list 0)
  (zap (fn (v) (+ v 1))
       (car x)) 
  x)(1)

TAO/ELIS: !!

以前も紹介しましたが、TAOの!!は自己代入専用の構文です。
!で印を付けた場所に書き戻せます。

(let ((x (list 0)))
  (!!(lambda (v) (+ v 1)) !(car x))
  x)

(let ((x (list 0))) (!!1+ !(car x)) x)

その他便利なユーティリティ

私見ではPaul Graham氏は面白い代入系ユーティリティを定義しているので、2、3眺めてみます。

Arc: pull

Common Lispのremove-ifとsetf`を組合せた感じです。

(let x '(1 100 2 50 3) 
  (pull [< _ 10] x) x)((100 50) foo) 

pushend

pushは先頭に追加なので末尾に追加したい場合に使えます

(let ((x (list 0 1 2)))
  (pushend 100 x)
  x)(0 1 2 100) 

merge-into

述語で場所を探してマージします。

(let ((x (list 0 1 2 0 0 0 8 2 -1)))
  (merge-into x 5 #'<)
  x)(0 1 2 0 0 0 5 8 2 -1) 

元定義は下記のような感じですが、define-modify-macrolambda式を取れるのは処理系拡張なので、可搬的に書くならdefmacroで定義する必要があるでしょう。

しかしdefine-modify-macro版だとpushendの定義のnconcがすっぽ抜け問題が発生しそうな見た目が気持ち悪いですが、define-modify-macroの展開ではplaceに代入し直されるので大丈夫です。

;;; http://lib.store.yahoo.net/lib/paulgraham/utx.lisp

(define-modify-macro pushend (obj)
  (lambda (place obj)
    (nconc place (list obj))))

(define-modify-macro merge-into (obj fn) (lambda (place obj fn) (merge 'list place (list obj) fn)))

  • 可搬的

(defmacro pushend (obj place)
  (let ((p (gensym)))
    `(let ((,p ,place))
       (setf ,p (nconc ,p (list ,obj))))))

(defmacro merge-into (place obj fn) (let ((p (gensym))) `(let ((,p ,place)) (merge 'list ,p (list ,obj) ,fn))))

まとめ

setf系の便利構文を紹介してみました。
色々定義してみるもの面白いかなと思います。


HTML generated by 3bmd in LispWorks 7.0.0

MOPでメソッドコンビネーションの仕組みを実装してみよう

Posted 2018-12-23 10:44:01 GMT

Lisp メソッドコンビネーション Advent Calendar 2018 23目 》

先日、Common Lispのメソッドコンビネーションの実現具合とAMOPでの実現に結構な差異があると書きましたが、今回は、define-method-combinationを使わないでMOP中心でメソッドコンビネーションを定義するとどんな感じになるか、を確かめてみたいと思います。

とりあえず、Common LispとAMOP近辺のメソッドコンビネーションを実現方式を調べてみると5つ位バリエーションがみつかりました。

  • ANSI Common Lisp
  • Closer to MOP
  • X3J13-88-003R Metaobject Protocol (Draft)
  • AMOPの本文、Closetteの実装
  • 各処理系の実装

まず、X3J13-88-003R Metaobject Protocolは草稿どまりですが、AMOPの流儀をベースにしつつも最適化についても考慮していたようなので複雑になっています。
また、define-method-combinationというFlavorsの流れも、MOP上に統合しようとしていたようですがこれも未完です。

次に、ANSI CL規格は、X3J13-88-003Rで練られていた事項を踏まえつつ、MOPの詳細については踏み込まない、という感じになっています。

AMOPの本文、Closetteの実装、は一つの理想形で、ANSI CL規格との兼ね合いのような瑣末なことは考慮されていません(先行しているので当然)

また、各処理系の実装は、概観するとAMOPに準拠しようとしつつ、参照実装の挙動が仕様だ、という感じになっています。
しかし参照実装とはいえ、Portable CommonLoopsの実装が仕様に準拠していない所もあり、その辺りのあやふやさは現在にも受け継がれています。

Closer to MOPは、AMOPの内容を現在メジャーなANSI Common Lisp処理系の上にポータブルな仕様と実装を実現しようとしたものです。

メソッドコンビネーションの枠組み作成

とりあえず、MOP的にメソッドコンビネーションの枠組みを作成してみましょう。

仕様は色々ありますが、compute-effective-methodがメソッドの集合を指定されたメソッドコンビネーションに応じでフォームを組み立てる、というのは共通しています。

なお、以下では、Closer to MOPを利用します。

(ql:quickload :closer-mop)

総称関数の定義

標準では、define-method-combination経由でしかメソッドコンビネーションを定義できないので、総称関数ごと別に作成します。

(defclass mcacgf (standard-generic-function)
  ()
  (:metaclass funcallable-standard-class))

メソッドコンビネーションクラスの定義

ANSI CLには、method-combinationクラスが定義されているのですが、使い方やスロットの詳細は曖昧なままです。
X3J13-88-003Rでは、サブクラスにstandard-method-combinationstandard-simple-method-combinationを定義しているようです。
この流儀に沿っているLispWorksのような実装もある様子。

とりあえずは標準のもののサブクラスにします。

(defclass ac-method-combination (method-combination) ())

メソッドコンビネーションの配置生成定義

effective-methodというとメソッドオブジェクト(メタオブジェクト)っぽいのですが、どうも式(メタプログラム)を指しているようです。

compute-effective-methodが式を生成するので、ここで直接書き下してしまえばOKです。

下記では、単純にするために:aroundなしのstandardにしています。
(Flavorsでいうdaemon)。

define-method-combination構文の便利機能を使わず手書きしている、という感じですね。

(defmethod c2mop:compute-effective-method ((gf mcacgf)
                                           (mc method-combination)
                                           (methods list))
  (loop :for m :in methods
        :for mq := (method-qualifiers m)
        :when (equal '(:before) mq) :collect `(call-method ,m) :into bs
        :when (equal nil mq) :collect m :into ps
        :when (equal '(:after) mq) :collect `(call-method ,m) :into as
        :finally (return `(multiple-value-prog1 
                              (progn (progn :before-daemons ,@bs)
                                :primaries
                                (call-method ,(car ps) (,@(cdr ps))))
                            (progn :after-daemons ,@as)))))

メソッドコンビネーション名の登録

defgeneric:method-combinationオプションで指定できるように登録します。
しかし、find-method-combinationが実装されていない処理系もあるので、フックできないかもしれません(LispWorks等)

(defmethod c2mop:find-method-combination 
           ((gf mcacgf) (type (eql 'mcac)) opts)
  (make-instance 'ac-method-combination))

;;; LispWorksではしょうがないのでテーブルに直に登録 (setf (gethash 'mcac clos::*method-combination-types*) (make-instance 'ac-method-combination))

動かしてみる

(defgeneric foo (x)
  (:generic-function-class mcacgf)
  (:method-combination mcac))

(defmethod foo (x) x) (defmethod foo :after (x) (print (list :after x))) (defmethod foo :before (x) (print (list :before x)))

(foo 42)(:before 42)(:after 42) → 42

  • メソッドコンビネーション展開

(c2mop:compute-effective-method #'foo
                                (make-instance 'ac-method-combination)
                                (compute-applicable-methods #'foo (list t)))(multiple-value-prog1
      (progn
        (progn
          :before-daemons
          (call-method #<standard-method foo (:before) (t) 40E0460B83>))
        :primaries
        (call-method #<standard-method foo nil (t) 40E042A5EB> nil))
    (progn
      :after-daemons
      (call-method #<standard-method foo (:after) (t) 40E0429F9B>)))

困った所

define-method-combinationオプションの:argumentsのサポートが鬼門なのですが、

  1. まともに実装している処理系がないっぽい
  2. MOPでどうするか文献がない

等で、MOPで:argumentsをサポートする場合、どういうAPI構成で書くべきなのか良く分かりません。
ANSI CL規格では、effective method中に展開されるとありますが、このあたりも処理系によって挙動がまちまちのようです。

まとめ

とりあえず、define-method-combinationを経由しないでメソッドコンビネーションを定義してみました。
define-method-combinationのマイナーな機能/オプションについてはCommon Lispの仕様が中途半端なせいか、どうやら忠実に実装できているは処理系がなさそうです。

SICL等は綺麗なCommon Lispを目指しているようなので、今後はSICLあたりも参照してみようかなと思います。


HTML generated by 3bmd in LispWorks 7.0.0

setfとメソッドコンビネーションについて掘り下げる

Posted 2018-12-22 10:49:25 GMT

Lisp メソッドコンビネーション Advent Calendar 2018 22目 》
Lisp SETF Advent Calendar 2018 22日目 》

これまで、メソッドコンビネーションで19記事、setfで17記事程書いてきましたが、もう書くことがないです。

setfでメソッドコンビネーション活用について書けば、一挙両得なのでは!、と考えこのネタでひとつ考えてみたいと思います。

setfとメソッドコンビネーション

まず、setfでメソッドコンビネーションの活用が成立する為には、どう考えてもスロットのライタである必要があります。

(defclass foo ()
  ((x :initarg :x :accessor x :writer (setf x/))))

(defvar *foo* (make-instance 'foo :x 42))

(x *foo*) → 42

(setf (x/ *foo*) 69) (x *foo*) → 69

クラスのスロット定義で、スロットに対して複数のアクセサ総称関数が定義可能ですが、setfが関係するのは、:accessorか、:writterオプションになります。

defclassで定義するアクセサは、デフォルトではstandardになることが規格で定まっています。

そのため、メソッドコンビネーションを指定したい場合は、defclassでアクセサは作らず、別途定義することになると思われます。

試してみましょう

(defgeneric (setf x-list) (val o)
  (:method-combination list))

(defmethod (setf x-list) list (val (o foo)) (setf (c2mop:slot-value-using-class (class-of o) o 'x) val) val)

(defclass bar (foo) ())

(defmethod (setf x-list) list (val (o bar)) (setf (c2mop:slot-value-using-class (class-of o) o 'x) val) val)

(defvar *bar* (make-instance 'bar :x 42))

(x *bar*) → 42

(setf (x-list *bar*) 69)(69 69)

(x *bar*) → 69

上記では、listメソッドコンビネーションを実行し代入の返り値をリストにして返しています。

これは、standardメソッドコンビネーション以外で、役に立ちそうな例を考えるのが難しい……。

setfに関しては、実行前後のフック(daemonメソッドコンビネーション)か、乗っ取り(around)があれば十分そうですね(即ちstandardメソッドコンビネーション)

通常は、同一の値を同一スロットに複数回書き込む挙動は求められていないということからもprogn等で有用なことはできなさそうです。

MOPで

(defclass foo ()
  ((x :initarg :x :accessor x :accessor-method-combination progn)))

のように書けるようにすることも検討してみましたが、これも微妙

一応役に立つ例も紹介

メソッドコンビネーションのカスタマイズの方向で書いてしまいましたが、standardsetfの組み合わせであれば、値の設定前後のフックとして有用な使い方が可能です。

  • 事前事後の値チェック(:before:after)
  • 副作用目的での手続の差し込み(:before:after)
  • 乗っ取りで、アクションを加えたり元動作を削除してしまったり(:around)

(defmethod (setf x/) :after (val (foo foo))
  (write-line "こんにちは"))

(setf (x/ *foo*) 42) ▻ こんにちは → 42

(defmethod (setf x/) :before (val (foo foo)) (check-type val integer))

(setf (x/ *foo*) 'foo) >>> error

(defmethod (setf x/) :around (val (foo foo)) nil)

(setf (x/ *foo*) 'foo) → nil

まとめ

リーダーもを含めたアクセサ全般と、メソッドコンビネーションの組み合わせでは何か有用なことも可能かもしれませんが、setfのライタ限定となると、デフォルトのstandardが必要にして十分だった、ということがわかりました。


HTML generated by 3bmd in LispWorks 7.0.0

メソッドコンビネーションとMOPの関係を整理する

Posted 2018-12-21 17:41:46 GMT

Lisp メソッドコンビネーション Advent Calendar 2018 21目 》

もうメソッドコンビネーションについて書くことがないので、深刻なネタ不足、準備不足と格闘しておりますが、このあたりでMOPとメソッドコンビネーションについて整理してみましょう。

Common Lispの場合

Common Lispの場合というか、MOPがあって、メソッドコンビネーションもあるというのはCommon Lisp位しか存在しないですが……。

まず、MOPはANSI Common Lisp規格外です。
MOPをサポートする処理系があっても良くて、それの場合はAMOP(The Art of the Metaobject Protocol)が拠り所になるでしょう程度の微妙な距離感になっています。

しかし実際にはANSI Common Lispの処理系の殆どが上述のAMOPの仕様を元にある程度互換性のあるMOPを組んで提供しています。
といってもAMOP自体、ANSI Common Lispの規格程かっちり規定できてはいないので、処理系ごとに差異はあり、その差異を埋めようというライブラリがCloser to MOPになります。

MOPの前置きが長くなりましたが、メソッドコンビネーションを定義するdefine-method-combinationはANSI Common Lisp規格で定義されているものでMOPのサポートを前提とはしていません。
メソッドを配置するコードを定義するのが、define-method-combinationですが、配置定義をしているだけで、定義に従ってあれこれするのは処理系依存です。

また、仮にMOPが存在することを前提に考えても、define-method-combinationにMOP的にオーバーライドできるフックポイントがあるわけでもないのでMOPという感じもあまりないかなと思います(MOPを前提としないデザインなので当たり前かもしれません)

たまに、Common LispのメソッドコンビネーションはMOPでカスタマイズする/可能、と説明している人がいますが、ちょっと違うかなと思います。
もしかすると、AMOPでメソッドコンビネーションを実現するのに、define-method-combinationは使わず、MOPの観点からapply-methodや、compute-effective-method-functionというものを定義して、これで解説してみせているのでCommon Lispもそうなっていると誤解していたりするのかもしれません。
実際の所は、メソッドコンビネーションはMOPがないFlavorsにもありますし、別個の概念と考えた方が良いでしょう。
AMOPはメソッドコンビネーションをMOPで実装してみせた例で、メソッドコンビネーションの追加等のカスタマイズはメソッドのオーバーライドで行う等、MOP的です。

Common Lispのメソッドコンビネーションの処理とMOP

Common Lisp場合のMOPとメソッドコンビネーションの兼ね合いですが、

  1. define-method-combinationでメソッド配置を定義(コード生成の定義)
  2. compute-effective-methodがコード生成の定義と、総称関数、メソッド、メソッドコンビネーションの各メタオブジェクトからコード(effective-method)を生成
  3. effective-methodcompute-discriminating-functionが総称関数の関数を作るのに使う

(defmethod foo (x) x)
(defmethod foo :after (x) x)

(set 'ms (compute-applicable-methods #'foo '(8)))(#<standard-method foo (:after) (t) 402053A353> #<standard-method foo nil (t) 402052BAEB>)

(set 'mc (c2mop:find-method-combination #'foo 'standard nil)) → #<clos::standard-method-combination standard 41A10AAD3B>

(c2mop:compute-effective-method #'foo mc ms)(multiple-value-prog1 (call-method #<standard-method foo nil (t) 411000E97B> nil) (call-method #<standard-method foo (:after) (t) 411000E773> nil))

となっています。

ちなみに、AMOPでは、

  1. メソッドコンビネーションごとに、総称関数をサブクラス化する。補助メソッドの特定にはメソッド修飾子を利用。
  2. compute-applicable-methods-using-classesがメソッドを集めてくる
  3. メソッド群を起動するapply-methods(もしくは効率改善のcompute-effective-method-function)をオーバーライドして、メソッドの起動の組織化をカスタマイズ可能。補助メソッドは特定できるので任意に選別し配置可能。

となっていて、上に述べたように、よりMOP的になっています。
下記のコードはclosetteの例ですが、std-compute-effective-method-functionというコード生成のメソッドになっているもののAMOPのcompute-effective-method-functionと同様の雰囲気です。

(defun std-compute-effective-method-function (gf methods)
  (let ((primaries (remove-if-not #'primary-method-p methods))
        (around (find-if #'around-method-p methods)))
    (when (null primaries)
      (error "No primary methods for the~@
             generic function ~S." gf))
    (if around
        (let ((next-emfun
                (funcall
                   (if (eq (class-of gf) the-class-standard-gf)
                       #'std-compute-effective-method-function
                       #'compute-effective-method-function)
                   gf (remove around methods))))
          #'(lambda (args)
              (funcall (method-function around) args next-emfun)))
        (let ((next-emfun (compute-primary-emfun (cdr primaries)))
              (befores (remove-if-not #'before-method-p methods))
              (reverse-afters
                (reverse (remove-if-not #'after-method-p methods))))
          #'(lambda (args)
              (dolist (before befores)
                (funcall (method-function before) args nil))
              (multiple-value-prog1
                (funcall (method-function (car primaries)) args next-emfun)
                (dolist (after reverse-afters)
                  (funcall (method-function after) args nil))))))))

まとめ

Common Lispは、AMOPの記述を基準にするなら、結構Flavors寄りということなのかもしれません。

AMOP的にメソッドコンビネーション定義をするならば、compute-effective-methodをオーバーライドすることになるかなと思います。
ネタ切れなので、AMOP版メソッドコンビネーションを実装してみるかもしれません。


HTML generated by 3bmd in LispWorks 7.0.0

setfで自己代入

Posted 2018-12-19 20:05:20 GMT

Lisp SETF Advent Calendar 2018 20日目 》

今回は、Pythonや、Rubyにある自己代入構文をsetfで再現してみようかなと思います。

自己代入構文とは

a = a + ba += bと書ける構文ですが、起源はCなのでしょうか。
aが二回評価されないので効率が良いなんていう話もあるようです。

setfで再現してみる

それではとりあえず、(setf (op a) b)の形式で定義してみましょう。
下記では、標準のオペレーターと名前が被るのでパッケージを別にしています。

(defpackage :self-assignment
  (:use :cl)
  (:shadow "+" "-" "/" "//" "OR" "AND"))

(in-package :self-assignment)

(defmacro define-self-assignment-setf (op fn) `(define-setf-expander ,op (place) (multiple-value-bind (dv v sv setter getter) (get-setf-expansion place) (values dv v sv `(let ((,@sv (,',fn ,getter ,@sv))) ,setter) getter))))

(define-self-assignment-setf + cl:+) (define-self-assignment-setf - cl:-) (define-self-assignment-setf / cl:/) (define-self-assignment-setf // cl:floor) (define-self-assignment-setf % cl:mod) (define-self-assignment-setf or cl:or) (define-self-assignment-setf and cl:and)

試してみる

(let ((a 100) (b 42))
  (setf (+ a) b) a)
→ 142 

(let ((a 100) (b 42)) (setf (- a) b) a) → 58

(let ((a 100) (b 42)) (setf (/ a) b) a) → 50/21

(let ((a 100) (b 42)) (setf (// a) b) a) → 2

(let ((a 100) (b 42)) (setf (% a) b) a) → 16

(let ((a 100) (b 42)) (setf (or a) b) a) → 100

(let ((a (list (list 100))) (b 42)) (setf (and (caar a)) b) a)((42))

まとめ

Common Lispにはincfdecfがありますが、自己代入のようなものは、(setf place)で考えた場合、placeっぽくないので、define-modify-macroで定義するのがCommon Lisp流だなあ、と作ってみてから思ったりです。


HTML generated by 3bmd in LispWorks 7.0.0

Quicklispのライブラリのメソッドコンビネーションを眺めてみよう

Posted 2018-12-19 18:37:02 GMT

Lisp メソッドコンビネーション Advent Calendar 2018 20日目 》

これまでメソッドコンビネーションの定義方法の解説や実際に定義してみたりをしていましたが、メソッドコンビネーションが実際にはどのように使われているかをQuicklispのライブラリ中から探して眺めてみましょう。

method-versions

メソッドコンビネーション: method-version-method-combination

メソッド修飾子でメソッドのバージョンを表現したというもの。
確かにメソッドのまとまりをメソッドコンビネーションの枠組みを使えばバージョンごとに起動したりの管理ができます。
なかなか面白いアイデアですね。

clweb

メソッドコンビネーション: join-strings

文字列を連結するメソッドコンビネーションのようです。
大分限定された使い方ですが、appendnconcも標準にありますし、そんな感じの気分なのでしょう。

mcclim

メソッドコンビネーション: values-max-min

標準でminmaxはありますが、多値で両方を返してくるというものです。

chanl

メソッドコンビネーション: select

CSPライブラリのchanlですが、プロセスの制御をメソッドコンビネーションで表現しているようです。
並列処理とメソッドコンビネーションで色々探してみたのですが、chanlで使われていたとは。
修飾子にsendrecv がありますが、結構活用している事例かもしれません。

3b-swf

メソッドコンビネーション: swf-part

swfファイル生成ライブラリですが、daemon各々を:most-specific-lastで起動するもののようです。

serapeum / arnesi

standard/context / wrapping-standard

もとネタは、Tim Bradshaw氏のwrapping-standardメソッドコンビネーションのようです。
standardメソッドコンビネーションの周囲を:wrap-aroundでさらに囲みます(serapeumでは:context)
:wrap-aroundはデフォルトでは、:aroundと逆順の:most-specific-lastです。

filtered-functions

filtered-functionsをメソッドコンビネーション活用の方向から眺めてみましたが、どちらかというと、メソッドコンビネーションより前の段階に工夫がある感じでした。
filtered-functionsについては過去に紹介記事がありますので、そちらをどうぞ。

method-combination-utilities

primary / lax / basic / append/nconc

メソッドコンビネーション定義のためのユーティリティと、有用そうなメソッドコンビネーション定義のライブラリです。

すっかり忘れていましたが、過去に紹介記事も書いていました。

このブログでもmc-expandのようなものを定義していましたが、method-combination-expandみたいなものも定義されています。
メソッドコンビネーションを活用するなら試してみて損はなさそうなユーティリティです。
しかし、LispWorksで動かない様子(PR出そうかな)

まとめ

案外使う人はカジュアルに使っている様子。
メソッドコンビネーションを学んで活用しましょう!


HTML generated by 3bmd in LispWorks 7.0.0

メソッドコンビネーションでD風の契約プログラミング: その2

Posted 2018-12-19 12:47:24 GMT

Lisp メソッドコンビネーション Advent Calendar 2018 19日目 》

メソッドコンビネーションでD風の契約プログラミング: その1の続きですが、前回は、不変条件をメソッドコンビネーションでどう組むかというところまででした。

Dでは、不変条件は、クラス内でinvariantで定義され、

  • すべてのコンストラクタの末尾
  • デストラクタの冒頭
  • メソッドの冒頭と末尾

に設置されるらしいです。
総称関数でこれをどう表現するかというところですが、

  • すべてのコンストラクタの末尾 ⇒ スロットアクセスチェックを:afterで起動?
  • デストラクタの冒頭 ⇒ clange-classで起動?
  • メソッドの冒頭と末尾 ⇒ 総称関数なのでスロットアクセスチェックで良いでしょう

位になるでしょうか。

定義してみる

とりあえず、こんなdateクラスがあったとして、

(defclass date () 
  ((year :initarg :year :accessor year)
   (month :initarg :month :accessor month)
   (day  :initarg :day :accessor day))
  (:default-initargs :year 1900 :month 1 :day 1))

(make-instance 'date) → #<date 402026FA73>

invariantメソッドが差し込んで使うようなメソッドコンビネーションを定義します。
andと同じような感じですが、基底クラスから順に適用してandの関係になるようにするので、継承順をreverseし、同じクラスに複数のメソッドを付けたいので、修飾子をワイルドカードにしました。

(define-method-combination invariant ()
  ((pri *))
  `(and ,@(loop :for m :in (reverse pri) :collect `(call-method ,m))))

これで、dateのスロットについてinvariantメソッドで不変条件を記述します。

(defmethod invariant year ((date date))
  (etypecase (year date)
    (integer T)))

(defmethod invariant month ((date date)) (etypecase (month date) ((integer 1 12) T)))

(defmethod invariant day ((date date)) (etypecase (day date) ((eql 29) (or (/= 2 (month date)) (leap-year-p (year date)))) ((eql 30) (/= 2 (month date))) ((eql 31) (typep (month date) '(member 1 3 5 7 8 10 12)))))

このinvariantをスロットに取り付けます。

(defmethod c2mop:slot-value-using-class ((date-class standard-class)
                                         (date date)
                                         slot)
  (invariant date)
  (multiple-value-prog1
    (call-next-method)
    (invariant date)))

(defmethod (setf c2mop:slot-value-using-class) (value (date-class standard-class) (date date) slot) (invariant date) (multiple-value-prog1 (call-next-method) (invariant date)))

これだけでいけるかなと思ったのですが、

(make-instance 'date :year 100 :month 2 :day -2)
→ #<date 4020118C13> 

あれ……?

インスタンス生成もチェックする

インスタンス生成はslot-value-using-classはスルーする(かもしれない)ようなので、clange-classのことも考えて、shared-initializeinvariantを設置しました(もうちょっと細かく設定した方が良いかもしれません)

(defmethod shared-initialize :after ((date date) slots &key)
  (invariant date))

これで生成系はエラーにできます。

(make-instance 'date :year 100 :month 2 :day -2)
>>> error

(defclass date2 () ((year :initform 1900 :initarg :year :accessor year) (month :initform 1 :initarg :month :accessor month) (day :initform 1 :initarg :day :accessor day)))

(change-class (make-instance 'date2 :year 100 :month 2 :day -2) 'date) >>> error

invariantメソッドコンビネーションの展開はこんな感じになります

(defclass datetime (date) 
  ((hour :initarg :hour :accessor hour)
   (minute :initarg :minute :accessor minute)
   (second  :initarg :second :accessor sec))
  (:default-initargs :hour 0 :minute 0 :second 0))

(defmethod invariant hour ((dt datetime)) (etypecase (hour dt) ((integer 0 24) T)))

(defmethod invariant minute ((dt datetime)) (etypecase (minute dt) ((integer 0 59) T)))

(defmethod invariant second ((dt datetime)) (etypecase (sec dt) ((integer 0 59) T)))

(mc-expand #'invariant 'invariant nil (make-instance 'datetime))(and (call-method #<standard-method invariant (year) (date) 41602356B3>) (call-method #<standard-method invariant (month) (date) 40D035A8B3>) (call-method #<standard-method invariant (day) (date) 40D035A113>) (call-method #<standard-method invariant (hour) (datetime) 40D04205BB>) (call-method #<standard-method invariant (minute) (datetime) 402025F913>) (call-method #<standard-method invariant (second) (datetime) 402027434B>))

これらinvariantを付加する作業をどうにかまとめたいのですが、MOPを使うかマクロて手続きを纏めるか悩む所です。 invariant手続きをdefclassで指定した方が良さそうなので、MOPになりそうです。


HTML generated by 3bmd in LispWorks 7.0.0

たまに便利な(setf apply)/(setf values)

Posted 2018-12-19 10:04:13 GMT

Lisp SETF Advent Calendar 2018 19日目 》

今回は、たまに便利な(setf apply)/(setf values)を解説してみたいと思います。

(setf values) | VALUES Forms as Places

(setf values)はそこそこ使われているかと思いますが、Common Lisp(1984)の時代から知識の更新がない年配の方々がmultiple-value-setqしか知らないような場面に遭遇することもままあります。
(古い書籍で勉強してしまったので知らなかった、ということもあります)

multiple-value-setq的な使い方

(let (q r)
  (setf (values q r) (floor 1 2))
  (list q r))(0 1) 

psetqpsetf的な使い方

(let ((a 0) (b 1))
  (setf (values a b) (values b a))
  (list a b))(1 0) 

(setf values)は他のsetfの場所と複合できるのも便利です

(let ((x (list 0 1)))
  (setf (values (car x) (cadr x))
        (values (cadr x) (car x)))
  x)(1 0) 

(setf apply) | APPLY Forms as Places

こちらは、Common Lisp(1984)からありますが、配列を多用する人以外は使う機会もないからか、それほど知られていない機能です。

添字のリストだけあって、それを適用したい、ということはあるのですが、(setf apply)arefを組合せれば可能です。

(let ((subs (list 2 1 0)))
  (setf (apply #'aref *a* subs) 42)
  *a*)
→
#3A(((0 0 0) (0 0 0) (0 0 0))
    ((0 0 0) (0 0 0) (0 0 0))
    ((0 0 0) (42 0 0) (0 0 0))) 

規格では、arefbitsbit(setf apply)の組合せは保証されていますが、他は、処理系依存です。
というのも、(setf fn)は必ずしも関数である必要はないためで、マクロで実装されている場合、applyできない、ということになるからです。

ユーザー定義の#'(setf fn)関数であれば、applyが適用できるので(setf apply)も可能です。

まとめ

(setf values)はもっと知られても良いかなと思っています。
ANSI Common Lispと、それ以前のCLtL2、CLtL1は結構違ってますので、仕様の参照/勉強では、ANSI Common Lisp規格を元にした文献を参照しましょう。


HTML generated by 3bmd in LispWorks 7.0.0

マクロ展開でもメソッドコンビネーション

Posted 2018-12-18 15:32:33 GMT

Lisp メソッドコンビネーション Advent Calendar 2018 18日目 》

メソッドコンビネーションでD風の契約プログラミングの続きを書こうと思いましたが、準備が間に合わないので、思い付きでマクロでもメソッドコンビネーションというネタを書きます。

ANSI Common LispにはAdviceはありませんが、処理系拡張でdefadviceのようなものでadviceを定義することが可能だったりします。
adviceは関数だけでなく、マクロやメソッドにも付けられたりしますが、LispWorksでマクロのadvice定義を利用した例は、こんな感じです。

(defmacro mydefun (name (&rest args) &body body)
  `(defun ,name (,@args) ,@body))

(defadvice (mydefun inline :around) (form env) (destructuring-bind (def name args &body body) form (declare (ignore def args body)) `(progn (declaim (inline ,name)) ,(call-next-advice form env))))

(mydefun foo (n) n) ;===> (PROGN (DECLAIM (INLINE FOO)) (DEFUN FOO (N) N))

標準では、マクロの展開関数は関数なので拡張できないのですが、メソッドにして、好きなメソッドコンビネーションを指定してしまえば良い!ということで、マクロ展開メソッドでメソッドコンビネーションです。

雑ですが、こんな感じに書いてみました。

(defmacro defmacro* (name-&-method-qualifiers (&rest args) &body body)
  (destructuring-bind (name &rest method-qualifiers)
                      (if (consp name-&-method-qualifiers) 
                          name-&-method-qualifiers
                          (list name-&-method-qualifiers))
    (let ((form (gensym "form-"))
          (env (gensym "env-"))
          (xn (or (get name :expander)
                  (setf (get name :expander) 
                        (make-symbol (string name))))))
      `(eval-when (:compile-toplevel :load-toplevel :execute)
         (defmethod ,xn ,@method-qualifiers (,form ,env)
           (macrolet ((call-next-expander (&rest args)
                        `(call-next-method ,@args)))
             (destructuring-bind (,name ,@args)
                                 ,form
               (declare (ignore ,name))
               ,@body)))
         (setf (macro-function ',name)
               #',xn)))))

deという名前でdefunのエイリアス的なものを定義してみる

(defmacro* de (name (&rest args) &body body)
  `(defun ,name (,@args) ,@body))

(de foo (n) (list n n)) ===> (defun foo (n) (list n n))

de周囲をeval-whenで囲みたくなった

(defmacro* (de :around) (name (&rest args) &body body)
  `(eval-when (:compile-toplevel :load-toplevel :execute)
     ,(call-next-expander)))

(de foo (n) (list n n))
===>
(eval-when (:compile-toplevel :load-toplevel :execute)
  (defun foo (n) (list n n)))

deの定義は全部無効にしたくなった

(defmacro* (de :around) (name (&rest args) &body body)
  nil)

(de foo (n) (list n n)) ===> nil

雑なのでメソッドの良さを全然活かせてないですが、使いようによっては便利なこともあるかも、と少しだけ思いました。


HTML generated by 3bmd in LispWorks 7.0.0

拡張setf定義を眺める: 解構篇

Posted 2018-12-17 21:05:17 GMT

Lisp SETF Advent Calendar 2018 18日目 》

今回は、処理系拡張のsetfのうち解構destructuring系の拡張を眺めてみたいと思います。

destructuringの邦訳語はいまいち一定しない感がありますが、中華圏では、ほぼ、解構destructuringで通っているようです。

解構destructuringは短くて意味の通りも良い気がするので、本記事では、解構destructuringで通します。
(しかし流行らなそうな言葉の響き……)

解構destructuring拡張のsetfとは

setf場所place解構destructuringを使うという拡張です。
Lisp Machine Lispには標準装備だったみたいですが、Common Lispで実装している処理系はないかもしれません。
ということで、以下は、Lisp Machine Lispでの例の紹介です。
(Common Lispでも定義はできます)

(setf list)

これまで、左辺値についてCPLを調べたりもしましたが、CPLは左辺にリスト構文が取れたりしました。

x, y, z := 0, 1, 2

これをそのままsetfで書いた感じです。

(let (x y z)
  (setf (list x y z) '(0 1 2))
  (list x y z))(0 1 2)

(setf cons) / (setf list*)

conslist*も使えます。

(let (x y)
  (setf (cons x y) '(0 1 2))
  (list x y))(0 (1 2))

(let (x y z) (setf (list* x y z) '(0 1 2)) (list x y))(0 1 (2))

(setf `(,foo ,@bar))

バッククォート式も使えます。
但し、appendの形には対応していないので、,@はリストの最後の部分にしか使えません。

(let (x y)
  (setf `(,x ,@y) '(0 1 2))
  (list x y))(0 (1 2))

(let (x y z) (setf `(,x ,y ,@z) '(0 1 2)) (list x y))(0 1 (2))

appendの形には対応していないものの、入れ子にすることは可能です。

(let (a b c d e f)
  (setf `(,a (,b (,c ,@d) ,e ,@f))
        `(a (b (c d d d) e f f f)))
  (list a b c d e f))(a (b (c (d d d) e (f f f))))

listlist*consも同様

(let (a b c d e f)
  (setf (list (list* (cons c d) e f))
        `(a (b (c d d d) e f f f)))
  (list a b c d e f))(a (b (c (d d d) e (f f f))))

まとめ

setfとバッククォートの組み合わせはなかなか良いんじゃないかと思うのですが、実際の所、あってもそんなに利用頻度は高くなさそうですね。


HTML generated by 3bmd in LispWorks 7.0.0

メソッドコンビネーションでD風の契約プログラミング: その1

Posted 2018-12-17 14:20:30 GMT

Lisp メソッドコンビネーション Advent Calendar 2018 17日目 》

契約プログラミングをメソッドコンビネーションを表現するネタは既にあるのですが、

もうちょっと簡潔に書けそうな気がしてきたので、試しにD風の契約プログラミングの仕組みを書いてみることにしました。

Dには契約プログラミングが組み込み機能ですが、in節で事前条件のチェック、body節は本体、out節で事後条件をチェックするようになっています。

継承がからんだ場合は、事前条件は、基底クラスから条件をorのでチェック、事後条件は、基底クラスからandでチェック、のようです。

out節で返り値を受け取ってチェックするというのをどう表現するのか厄介ですが、outはチェック関数を返して、プライマリの返り値をチェックすることにしました。

(define-method-combination ddbc ()
  ((in* (:in))
   (out* (:out))
   (pri* () :required T))
  (let ((results (gensym "results-")))
    `(progn
       (or ,@(loop :for in :in (reverse in*) :collect `(call-method ,in))
           (error "in"))
       (let ((,results (multiple-value-list (call-method ,(car pri*) ,(cdr pri*)))))
         (declare (dynamic-extent ,results))
         (or (and ,@(loop :for out :in (reverse out*) :collect `(apply (call-method ,out) ,results)))
             (error "out"))
         (values-list ,results)))))

これでこんな風に書くと、

(defgeneric integer->integer->integer (x y)
  (:method-combination ddbc))

(defmethod integer->integer->integer :in ((x number) (y number)) (and (integerp x) (integerp y) (not (zerop y))))

(defmethod integer->integer->integer ((x number) (y number)) (/ x y))

(defmethod integer->integer->integer :out ((x integer) (y integer)) #'integerp)

こんなメソッドコンビネーション展開になります

(mc-expand #'integer->integer->integer 'ddbc nil 1 2)(progn
  (or (call-method
       #<standard-method integer->integer->integer (:in) (number
                                                          number) 414009E67B>)
      (error "in"))
  (let ((#:|results-166692|
         (multiple-value-list (call-method
                               #<standard-method integer->integer->integer nil (number
                                                                                number) 414009E45B>
                               nil))))
    (declare (dynamic-extent #:|results-166692|))
    (or (and (apply (call-method
                     #<standard-method integer->integer->integer (:out) (integer
                                                                         integer) 40202D35A3>)
                    #:|results-166692|))
        (error "out"))
    (values-list #:|results-166692|)))

実行してみます

(defmacro run (form)
  "結果確認用ユーティリティ"
  `(multiple-value-bind (ans error)
                        (ignore-errors ,form)
     `(,',form :result ,ans :error 
               ,(and error
                     (format nil 
                             (simple-condition-format-control error)
                             nil
                             (simple-condition-format-arguments error))))))

(list (run (integer->integer->integer 1 8)) (run (integer->integer->integer 1 0)) (run (integer->integer->integer 10 2)) (run (integer->integer->integer 10 1/2)))(((integer->integer->integer 1 8) :result nil :error "out") ((integer->integer->integer 1 0) :result nil :error "in") ((integer->integer->integer 10 2) :result 5 :error nil) ((integer->integer->integer 10 1/2) :result nil :error "in"))

まあまあ、動いているようです。

不変条件は、クラスのスロット側にメソッドコンビネーションを付けることになりそうですが、間に合ってないので次回にします。


HTML generated by 3bmd in LispWorks 7.0.0

拡張setf定義を眺める: 制御構造篇

Posted 2018-12-17 00:05:13 GMT

Lisp SETF Advent Calendar 2018 17日目 》

今回は、処理系拡張のsetfのうち制御構造の拡張を眺めてみたいと思います。

処理系拡張のsetfとは

Common Lispの処理系には、setfの拡張が許されていますが、殆ど拡張は入れてない処理系から突飛なものを入れている処理系まで様々です。

CLISPに結構拡張が入っているので、今回はCLISPを中心に眺めてみます。

(setf if)

setfifが使えるのですが、そこそこ便利かもしれません。
ifを使ったマクロ展開がされてもsetfの場所として有効なので、言語コアでsetf展開が可能だと、かなり拡張されることになります。

(let ((x 0)
      (y 1))
  (incf (if (< x y) x y))
  (list x y))(1 1)

  • orifに展開されるので、直接定義されていなくても(setf or)が使える

(let ((x nil)
      (y 1))
  (incf (or x y))
  (list x y))

展開はこんな感じです

(let* ((#:cond-29533 (< x y)) (#:new-29534 (+ (if #:cond-29533 x y) 1)))
  (if #:cond-29533
      (setq x #:new-29534)
      (setq y #:new-29534)))

(setf progn)

prognも言語のコアなので、これもsetf化の底上げになります。

(let ((x 0)
      (y 0)
      (z 0))
  (incf (progn x y z))
  (list x y z))(0 0 1)

(setf locally)

locallyも言語のコアなので、マクロ展開の結果への適用を考えているのだと思いますが、theの代わりに使える気もします。

(let ((x 0)
      (y 1)
      (z 2))
  (setf (locally (declare (fixnum x y z ))
          (values x y z))
        (values 1 1 1))
  (list x y z))(1 1 1)

(setf funcall)

規格では、(setf apply)が使えるので、ちょっとした変種というところです。

(let ((u (list 0 1 2)))
  (incf (funcall #'cadr u))
  u)(0 2 2)

(setf let)

ここからはLisp Machine Lispに実装されていたものですが、locative(参照)が扱えるので、かなり妙なことが可能です。

(let ((x 0)
      f)
  (setf (let ((x x))
          (setq f (lambda () x))
          x)
        42)
  (list x (funcall f)))(0 42)

上記の(setf let)内のxは外側のxをシャドウしていますが、末尾でx変数を返しているので、その参照に42を代入しています。
スコープの外から代入できてる感じなのがエグいですが、ここまで極端な使い方は想定していなそうではあります。

(setf setq)

これはLisp Machine Lispでも有効になっていませんが、コードの断片があるので有効にしてみると、

(let ((x 0)
      (y (list 0 1 2)))
  (setf (setq x (car y)) 42)
  (list x y))(42 (42 1 2))

こんなことを考えていたようです。
setqの場合は、値の方の参照に代入します。なかなかエグい。

まとめ

役に立ちそうなものから、面白機能なものまで紹介してみました。
次回は、リスト操作系の拡張を紹介してみたいと思います。


HTML generated by 3bmd in LispWorks 7.0.0

メソッドコンビネーションで並列実行

Posted 2018-12-15 21:45:07 GMT

Lisp メソッドコンビネーション Advent Calendar 2018 16日目 》

メソッドコンビネーションは、メソッドの集合をあるコンビネーションで実行することなので並列実行も範疇に入ると思われます。

メソッドコンビネーションで並列実行の例は、そこそこあるだろうと思ってネットをしばらく検索してみましたが、どうやらあまり試してみた例はないようです。

NetCLOSの構文の見た目が、メソッドコンビネーションっぽかったのでソースを確認してみましたが、残念ながら、並列実行のパターンに直接メソッドコンビネーションを活用している訳ではない様子(メッセージ送信のシークエンスに活用してはいるようです)
ちなみに、NetCLOSは、ABCL/1にインスパイアされたアクターベースの並列オブジェクト指向なCLOSのネットワーク拡張です。

メソッドコンビネーションと素朴な並列実行

非常に素朴ですが、各メソッドをスレッドに分配して全部実行してジョインというのは簡単に書けます。
コンビネーションとしては、prognメソッドコンビネーションが並列に実行される、という感じでしょうか。

(define-method-combination par ()
  ((ms (:name . *)))
  (let ((ths (loop :for () :in ms 
                   :collect (gensym "thread-"))))
    `(let (,@(mapcar (lambda (m th)
                       `(,th (bt:make-thread 
                              (lambda ()
                                (call-method ,m))
                              :name ,(second (method-qualifiers m)))))
                     ms
                     ths))
       (let ((ans (list ,@ths)))
         (declare (dynamic-extent ans))
         (values-list (mapcar #'bt:join-thread ans))))))

(defgeneric para (x &optional out)
  (:method-combination par))

(defmethod para :name "foo" (x &optional out) (format out "~&start A ...~%") (sleep 3) (format out "~&... end A~%"))

(defmethod para :name "bar" (x &optional out) (format out "~&start B ...~%") (sleep 5) (format out "~&... end B~%"))

  • メソッドコンビネーションの展開

(mc-expand #'para 'par nil 3)(let ((#:|thread-181190|
       (bt:make-thread (lambda ()
                         (call-method #<standard-method para (:name "bar") (t) 40303B7D63>))
                       :name "bar"))
      (#:|thread-181191|
       (bt:make-thread (lambda ()
                         (call-method #<standard-method para (:name "foo") (t) 40303A6263>))
                       :name "foo")))
  (let ((ans (list #:|thread-181190| #:|thread-181191|)))
    (declare (dynamic-extent ans))
    (values-list (mapcar #'bt:join-thread ans))))

  • 実行してみる

(para 3 #.*standard-output*)
start A ...
start B ...
... end A
... end B
→ nil
   nil

上記では、ジョインする手間が省けている程度ですが、やりようによっては役に立つものができるかもしれません……。


HTML generated by 3bmd in LispWorks 7.0.0

実践SETF定義:ローカルなsetf

Posted 2018-12-15 19:31:30 GMT

Lisp SETF Advent Calendar 2018 16日目 》

今回は、ローカルスコープでのsetf定義について考えてみます(ネタがないから)

ローカルスコープでsetfとは

ANSI Common Lispでは、(setf fn)という関数名が使えるということは以前解説したのですが、これはflet/labelsでも勿論使えます。
つまり、ローカルスコープ限定でsetfフォームが書けるということになります。

#'(setf fn)

(let ((u (list 0 1 2 3 4)))
  (flet (((setf kar) (val cons)
           (rplaca cons val)))
    (setf (kar u) 42)
    u))(42 1 2 3 4) 

Macro Forms as Placesのローカル版

macroletはローカルスコープのマクロを作りますが、Macro Forms as Placesもまたローカルで成立することになります。

(let ((u (list 0 1 2 3 4)))
  (macrolet ((kar (list)
               `(car ,list)))
    (setf (kar u) 42)
    u))(42 1 2 3 4) 

defsetfdefine-setf-expanderで定義するもののローカル版

setfletや、setf-expander-bindのような、そのボディ内でsetfフォームが書けるような構文を定義しない限り、無理ではないかなと思います。
特にdefine-setf-expanderの方はmacroletにちょっと細工する位では実現が無理に思えるので、コードウォーカーを駆使する他なさそうです。

まとめ

まあ、ローカルのsetfは、ほぼ使うこともないのですが、setfletや、setf-expander-bindのようなものを作ってみるのは、上級マクロ学習の良い題材になりそうな気はします。
興味のある方は試してみては如何でしょうか。


HTML generated by 3bmd in LispWorks 7.0.0

実践SETF定義:defstruct、defclassで定義できるおまけsetf

Posted 2018-12-15 13:52:03 GMT

Lisp SETF Advent Calendar 2018 15日目 》

setf系構文の紹介ですが、今回は、defstruct、defclassでおまけに定義できるsetfの紹介です。

defstructsetf

MACLISP系Lispではsetfdefstructは誕生から共に歩んできた感じですが、defstructの便利機能の一つに、アクセサを自動生成してくれる、というのがあります。

(defstruct zot x y z)

(let ((z (make-zot))) (setf (zot-x z) 42) z) → #S(zot :x 42 :y nil :z nil)

デフォルトで(setf zot-x)という名前で作成してくれますが、この名前が気に入らない場合は、調整することも可能です。

(defstruct (zot (:conc-name ""))
  x y z)

(let ((z (make-zot))) (setf (x z) 42) z) → #S(zot :x 42 :y nil :z nil)

しかし、定義しない、という選択はできないので、ごく稀に名前の競合などで面倒なことがあったりはします。

defclasssetf

後発のdefclassでは、defstructのように決め打ち動作は抑えられるため名前の競合問題は制御可能です。

スロットの指定で、:accessorを指定すれば、リーダーメソッドと(setf 名前)というセッターメソッドが定義されます。

:writerでは、シンボルと(setf fn)形式が指定可能で、スロットに複数指定可能なので複数の名前が一度に定義できます。

(defclass kiji ()
  ((x :accessor kiji-x)
   (y :accessor kiji-y)
   (z :accessor kiji-z :writer set-kiji-z :writer (setf hyper-kiji-z))))

(let ((o (make-instance 'kiji))) (setf (kiji-x o) 42) (kiji-x o)) → 42

(let ((o (make-instance 'kiji))) (setf (hyper-kiji-z o) 43) (kiji-z o)) → 43

(let ((o (make-instance 'kiji))) (set-kiji-z 43 o) (kiji-z o)) → 43

ちなみに、アクセサの名前ごとに別の総称関数なので個々のメソッドコンビネーションを付与できます(コンビネーションはstandardのみ可能)

(defmethod (setf hyper-kiji-z) :before (val (obj kiji))
  (print 'hyper-kiji-z))

(let ((o (make-instance 'kiji))) (setf (kiji-z o) 43) (kiji-z o)) → 43

(let ((o (make-instance 'kiji))) (setf (hyper-kiji-z o) 43) (kiji-z o)) ▻ hyper-kiji-z → 43

まとめ

改めて確認してみるとdefclassが随分多機能だなと感心します。


HTML generated by 3bmd in LispWorks 7.0.0

New Flavorsのwrapperとwhopperを再現してみよう

Posted 2018-12-15 11:24:57 GMT

Lisp メソッドコンビネーション Advent Calendar 2018 15日目 》

前回、メソッドコンビネーション元祖のFlavorsのdefwrapperの定義と:aroundの比較をしてみましたが、今回は、New Flavorsで登場したwhopperも加えてCommon Lispで再現してみようと思います。

FlavorsとNew Flavorsの違いですが、New FlavorsはSymbolicsがFlavorsを改良したもので、sendでのメッセージパッシング構文から、総称関数ベースに変更になった所が目立った違いです。
といっても、send構文もオブジェクトをfuncallしていたので、ちょっとした発想の転換程度の変化にみえます。
なお、New Flavorsは総称関数、多重継承ですが、マルチメソッドではありません。

Flavorsは、MITで開発され、MACLISP系のLisp(Lisp Machine Lisp、MACLISP、Franz Lisp、Zetalisp、Common Lisp)に実装されましたが、方言を跨ぐオブジェクトシステムというもの良く考えると面白いです。

wrapper/whopperの違い

さて、とりあえず、wrapper、whopperの解説ですが、wrapperはこれまでの記事で解説したように、メソッドの周囲を包むマクロ群です。
whopperは、New Flavorsから登場したようですが、Symbolics Common Lisp(1986)のマニュアルを眺めるとCommon Lispの:aroundと挙動は全く同じようです。バーガーキングのワッパーと何か関係があるのでしょうか。
それはさておき、マニュアルでは、マクロのwhopperは再コンパイルが必要だったりして扱いが若干面倒なので極力関数のwhopperを使おうとあります。

wrapperもwhopperも同一の機能ですが、混ぜて使った場合の説明もあり、その場合はwrapperが最外周を取るようです。
wrapperは、マクロなのでほんのちょっと速くできるとありますが、whopperにもインライン展開の構文もあったりするので本当にそうだったのかは謎です。

wrapper/whopperを再現してみる

defwhopper

Common Lispはマルチメソッドなので、シングルメソッドのFlavorsとは若干引数のインターフェイスを変える必要がありますが、大体こんな感じにしました。

(defmacro defwhopper (name (&rest args) &body body)
  `(defmethod ,name :whopper (,@args)
     (flet ((continue-whopper (&rest args)
              (apply #'call-next-method args))
            (lexper-continue-whopper (&rest args)
              (apply #'apply #'call-next-method args)))
       ,@body)))

defwrapper

wrapperの方は、ボディにマクロ展開を記述するのですが、展開関数をメソッドとは別に管理すると面倒なので、式を展開するメソッドを:wrapperメソッドとして記録することにしてみました。

メソッドコンビネーションの展開時に、:wrapper修飾子のメソッドを集めて、残りのフォームを引数に展開していく方針です。

(defmacro defwrapper (name (margs &body mbody) &body body)
  (let ((form (gensym "form-")))
    `(defmethod ,name :wrapper (,@margs)
       (lambda (,form env)
         (declare (ignore env))
         (destructuring-bind ,mbody ,form
           ,@body)))))

メソッドコンビネーション定義

wrapperは最外周なのとマクロ展開させるので若干特殊な動きをしますが、standardメソッドコンビネーションの:around:whopperに置き換えたものをwrapperで包んでいく感じで大丈夫でしょう。

;;; Symbolics風のユーティリティ
(defmacro multiple-value-prog2 (form1 form2 &body body)
  `(progn
     ,form1
     (multiple-value-prog1 ,form2 ,@body)))

(define-method-combination :wrapper () ((whopper (:whopper)) (before (:before)) (primary () :required t) (after (:after)) (wrapper (:wrapper))) (flet ((call-methods (methods) (mapcar #'(lambda (method) `(call-method ,method)) methods))) (let* ((form (if (or before after (rest primary)) `(multiple-value-prog2 (progn ,@(call-methods before)) (call-method ,(first primary) ,(rest primary)) ,@(call-methods (reverse after))) `(call-method ,(first primary)))) (whopper (if whopper `(call-method ,(first whopper) (,@(rest whopper) (make-method ,form))) form))) (if wrapper (reduce (lambda (w ans) (let ((expander (funcall (method-function w) nil nil))) (funcall expander (list ans) nil))) wrapper :initial-value whopper :from-end T) whopper))))

使ってみる

まずは、プライマリを定義してみます

(defgeneric foo (x)
  (:method-combination :wrapper))

(defmethod foo (x) x)

(foo "42") → "42"

次にwrapperを定義。
stringはプライマリがありませんが、wrapperは動きます。

(defwrapper foo ((x) &body body)
  `(multiple-value-prog2 
     (format T "~A~%" '(foo t :wrapper :in))
     ,@body
     (format T "~A~%" '(foo t :wrapper :out))))

(defwrapper foo (((x string)) &body body) `(multiple-value-prog2 (format T "~A~%" '(foo string :wrapper :in)) ,@body (format T "~A~%" '(foo string :wrapper :out))))

(foo "42")(foo string wrapper in)(foo t wrapper in)(foo t wrapper out)(foo string wrapper out) → "42"

次にstringのプライマリを定義して実行してみます

(defmethod foo ((x string))
  (values (read-from-string x)))

(foo "42")(foo string wrapper in)(foo t wrapper in)(foo t wrapper out)(foo string wrapper out) → 42

次に、whopperを定義してみます。

(defwhopper foo ((x string))
  (let ((*read-base* 5.))
    (continue-whopper x)))

(foo "42")(foo string wrapper in)(foo t wrapper in)(foo t wrapper out)(foo string wrapper out) → 22

メソッドコンビネーションの展開はこんな感じです。
wrapperはcall-methodの連鎖にならずにベタ書きになっているのがわかります。

(mc-expand #'foo
           :wrapper
           nil
           "42")(multiple-value-prog2
  (format t "~A~%" '(foo string :wrapper :in))
  (multiple-value-prog2
    (format t "~A~%" '(foo t :wrapper :in))
    (call-method
     #<standard-method foo (:whopper) (string) 40E01F98B3>
     ((make-method
       (multiple-value-prog2 (progn)
         (call-method
          #<standard-method foo nil (string) 40E01C1253>
          (#<standard-method foo nil (t) 40E00E75EB>))))))
    (format t "~A~%" '(foo t :wrapper :out)))
  (format t "~A~%" '(foo string :wrapper :out)))

まとめ

New Flavorsのwrapper/whopperを再現してみましたが、マクロだったwrapperが使い易く関数のwhopperとしてまとめられ、そこからCommon Lispの:aroundへ統合されたらしいことがわかります。

define-method-combinationのインターフェイスは、New Flavors時代に固まったようですが、どうもwrapperの仕組みが念頭にあった設計に思えてしまいます。
MOP前提なら、もうちょっと違ったインターフェイスにできる気がするのですが、残念ながらANSI Common Lispでは、MOPが規格外になってしまったので、MOP前提ではないdefine-method-combinationのインターフェイスも生き残ったという所なのかもしれません。


HTML generated by 3bmd in LispWorks 7.0.0

FlavorsのdefwrapperとCommon Lispの:aroundの比較

Posted 2018-12-14 14:48:47 GMT

Lisp メソッドコンビネーション Advent Calendar 2018 14日目 》

Flavorsには、Common Lispのメソッドコンビネーションの:aroundが無いようなのですが、その代わりにdefwrapperという構文があったようです。

defwrapperの発展的解消の結果、:aroundに纏められたのかなと思えてきたのですが、CADRのエミュレータ上でdefwrapperの実際の使い勝手と挙動を確認してみることにしました。

挙動確認のお題ですが、先日のstandardメソッドコンビネーションの説明で:before:after、primary、:around全部盛りの定義を紹介したものをFlavorsに書き換えて試してみます。

Flavorsは、(CADR System 78.48 (1982年あたり))のものです。

(progn
  (defflavor f1 () ())
  (defflavor f2 () (f1))
  (defflavor f3 () (f2)))

(progn (defmethod (f1 foo) () (format T "~16T~A~%" '(foo f1))) (defmethod (f2 foo) () (format T "~16T~A~%" '(foo f2)) (funcall #'(:method f1 foo) self)) (defmethod (f3 foo) () (format T "~16T~A~%" '(foo f3)) (funcall #'(:method f2 foo) self)) ;; (defmethod (f1 :before foo) () (format T "~8T~A~%" '(foo f1 :before))) (defmethod (f2 :before foo) () (format T "~8T~A~%" '(foo f2 :before))) (defmethod (f3 :before foo) () (format T "~8T~A~%" '(foo f3 :before))) ;; (defmethod (f1 :after foo) () (format T "~24T~A~%" '(foo f1 :after))) (defmethod (f2 :after foo) () (format T "~24T~A~%" '(foo f2 :after))) (defmethod (f3 :after foo) () (format T "~24T~A~%" '(foo f3 :after))))

(progn (defwrapper (f3 foo) (() . body) `(progn (format T "~A~%" '(foo f3 :wrapper)) . ,body))

(defwrapper (f2 foo) (() . body) `(progn (format T "~A~%" '(foo f2 :wrapper)) . ,body))

(defwrapper (f1 foo) (() . body) `(progn (format T "~A~%" '(foo f1 :wrapper)) . ,body)))

(<- (make-instance 'f3) 'foo)(FOO F3 WRAPPER)(FOO F2 WRAPPER)(FOO F1 WRAPPER)(FOO F3 BEFORE)(FOO F2 BEFORE)(FOO F1 BEFORE)(FOO F3)(FOO F2)(FOO F1)(FOO F1 AFTER)(FOO F2 AFTER)(FOO F3 AFTER)
→ NIL

思えば、Flavorsには、call-next-methodのようなものがない気がするのですが、とりあえず、Common Lispと違ってfunctionの記法が拡張されているので、(funcall #'(:method f2 foo) self) という風にメソッドを直接起動してしのいでいます。

後期のFlavorsや、New Flavorsにはあるのかもしれません。
そもそもFlavorsは標準規格化されてないので、実装によりAPIや挙動がまちまちなので確認が、ちょっとしんどいです。

上記のコードをみて分かるかと思いますが、:aroundの中で、call-next-methodを呼ぶのではなく、defwrapperでは、メソッドのコードをマクロで包み込む、という感じになります。

また、defwrapperはマクロではありますが、Flavorを指定できるので、どのメソッドの外周を包むかを:aroundと同じく指定することが可能です。

まとめ

defwrapper:aroundに置き換わったと考えると、Common Lispのメソッドコンビネーションの動作の謎が解ける気がして、Flavorsのdefwrapperを紹介してみました。

後期Flavors、New Flavors、さらに、defwrapper以外の謎構文、defwhopperとメソッドコンビネーションについても調べて纏めてみたいと思っています。


HTML generated by 3bmd in LispWorks 7.0.0

実践SETF定義:マクロを定義した場合のおまけsetf

Posted 2018-12-13 18:45:56 GMT

Lisp SETF Advent Calendar 2018 14日目 》

setf系構文の紹介ですが、今回は、Macro Forms as Placesの紹介です。
Macro Forms as Placesというと何のことだかさっぱりという感じですが、単にマクロを定義したらsetf定義もオマケで付いてきちゃった、という感じのものです。

例を挙げると、

(defmacro kar (x)
  `(car ,x))

(kar (list 0 1 2)) → 0

という定義があった場合、setfの定義は何もしていませんが、下記のようなものが動きます。

(let ((list (list 0 1 2)))
  (setf (kar list) 42)
  list)(42 1 2) 

ローカルマクロでも可

(macrolet ((qar (x)
             `(car ,x)))
  (let ((list (list 0 1 2)))
    (setf (qar list) '())
    (push 42 (qar list))
    list))((42) 1 2) 

setf場所にマクロで定義したフォームで使えるというのがMacro Forms as Placesです。

Macro Forms as Placesを利用する場合の注意点ですが、マクロ展開後のフォームが、setfで解釈できる状態になっていなければなりません。

具体例を挙げると、prognには、標準ではsetf定義がないので、最外周にprognが現われるような書き方をすればエラーになります。

;; OK

(defmacro kar (x)
  `(car ,x))

;;; NG (defmacro kar (x) `(progn (car ,x)))

まとめ

うまくはまれば、便利に使えるMacro Forms as Places。 活用してみては如何でしょうか。

類似の過去記事


HTML generated by 3bmd in LispWorks 7.0.0

実践SETF定義:define-modify-macroで頻出パターンをまとめる

Posted 2018-12-13 14:28:27 GMT

Lisp SETF Advent Calendar 2018 13日目 》

setf系構文の紹介ですが、今回は、define-modify-macroの紹介です。

define-modify-macroは、簡単に説明するなら、(setq x (fn x))のようなパターンを簡潔に(fnf x)と書けるようにする便利定義構文なのですが、このようなパターンが頻出する訳でもないので、普段はそんなに使うこともない印象があります。

define-modify-macroで何か定義してみる

(setq x (cdr x))

というパターンはそこそこ使いますが、define-modify-macrocdrfでも定義してみましょう。

(define-modify-macro cdrf () cdr)

(let ((x (list 0 1 2))) (cdrf x) x)(1 2)

まあ、実質同じことをするビルトインマクロにpopがありますが……。
一応返り値が違います。

定義構文の注意点として、代入にされる場所となる変数が先頭に来て、さらにそれが定義構文中には現われない、という点です。
cdrの場合は1引数なので、0引数で記述します。

define-modify-macroを使えば役に立ちそうな立たなそうな構文を大量生産できます。

(define-modify-macro listf (&rest args) list)

(let ((x (list 0 1 2))) (list x 1 2))((0 1 2) 2 3 4)

(define-modify-macro =f (&rest args) =)

(let ((x 0) (y 1)) (=f x y ) (list x y))(nil 1)

appendfnconcf等々は定番アイテムで、色々なユーティリティライブラリに含まれています。
まあ、ライブラリを読み込むのが面倒な場合には、簡単なので定義してしまっても良いでしょう。

modify-macrolet

define-modify-macroは大域定義になるのですが、7年程前にローカル構文版を思い付いて作ったことがありました。

これを使うと、

(modify-macrolet ((nconcf (&rest args) nconc))
  (let ((x nil))
    (nconcf x (list 0 1 2 3))
    x))

のように大域の名前を汚染することなくローカルに書くことが可能になります。

ちなみに、個人的には定義してから7年間一度も使ったことはありませんが、ご興味のある方は如何でしょうか。
また、modify-macroletを自作してみるのも一興かなと思います。


HTML generated by 3bmd in LispWorks 7.0.0

Flavorsのメソッドコンビネーションを眺めたり再現してみよう: :pass-on

Posted 2018-12-12 19:45:24 GMT

Lisp メソッドコンビネーション Advent Calendar 2018 13日目 》

前回に引き続き、メソッドコンビネーション元祖のFlavorsに標準装備されていたメソッドコンビネーションを眺めたり再現してみたりしようと思います。

メソッドの返り値を順繰りに次のメソッドに送っていく:pass-onの再現がしたくて苦戦していましたが、なんとか形にできました。

Flavorsの:pass-onの挙動を確認してみる

とりあえず、LMI Lambdaのエミュレータで挙動が確認できたのですが、こんな感じでした。

(defflavor a () ()
  (:method-combination (:pass-on (:base-flavor-last) :m)))

(defflavor b () (a))

(defmethod (a :m) (x y) (values (list :a x) (1+ y)))

(defmethod (b :m) (x y) (values (list :b x) y))

(send (make-instance 'b) :m 0 1)(:a (:b 0)) 2

aを継承するbという2つのflavorに、それぞれm:pass-onで定義し、bのインスタンスでmを呼び出すと、b.mの返り値をa.mが受け取るようになります。
:base-flavor-lastなのでbaの順番ですが、:base-flavor-firstにすれば、逆にもできます。

:pass-onが多値で返す意味が分からなかったのですが、良く考えると、メソッドの引数が複数になる場合は、多値かリストにして対応するしかなく、リストだと受取側の引数のインターフェイスを変更しないといけないので、多値で返すしかないですね。なるほど。

Common Lispで再現してみる

MOPのmake-method-lambdacompute-effective-methodあたりでどうにかできないか検討しましたが、call-methodフォームを作成して、また分解して、という感じになってしまうので、call-methodをスルーして、メソッドの関数をmethod-functionで取り出して直接呼ぶことにしました。

(ql:quickload :closer-mop)

;; LispWorks/Allegro CL (define-method-combination :pass-on () ((ms ())) (:arguments &rest args) (let ((vs (gensym "vars-"))) `(let* ((,vs ,args) ,@(loop :for m :in ms :collect `(,vs (multiple-value-list (apply ,(c2mop:method-function m) ,vs))))) (declare (dynamic-extent ,vs)) (values-list ,vs))))

しかし、メソッドの引数情報が欲しいので、define-method-combination:argumentsを指定しているのですが、SBCLだと:argumentsがちゃんと実装されていないようなので&restが使えません。

また、method-functionが返す関数の引数は、argsnext-methodsの筈なので、(funcall method-function vs nil)とするのが正しそうですが、LispWorksとAllegro CLでは、(apply method-function vs)でないと上手く動かない謎。

そんなこんなで、まともに動くものができているとは言い難いですが、こんな感じに書けます。

(defclass a () ())

(defclass b (a) ())

(defgeneric m (o x y) (:method-combination :pass-on))

(defmethod m ((o a) x y) (values o (list :a x) (1+ y)))

(defmethod m ((o b) x y) (values o (list :b x) y))

(m (make-instance 'b) 0 1) → #<b 40205BA353> (:a (:b 0)) 2

メソッドコンビネーションの展開はこんな感じで別段変なことはしていませんが、どの処理系も何かしらおかしい感じです。
まあ、LispWorksとAllegro CLで動くので良しとしましょう。

(mc-expand #'m :pass-on nil (make-instance 'b) 0 1)(let* ((#:|vars-131621| args)
       (#:|vars-131621|
        (multiple-value-list (apply #<Function (method m (b t t)) 4140032074>
                                    #:|vars-131621|)))
       (#:|vars-131621|
        (multiple-value-list (apply #<Function (method m (a t t)) 41400320FC>
                                    #:|vars-131621|))))
  (declare (dynamic-extent #:|vars-131621|))
  (values-list #:|vars-131621|)) 

まとめ

HyperSpecによると、define-method-combination:argumentsでは、&restの他に&wholeも使えたりするみたいですが、メジャーな処理系を試してみたところ、まともに:argumentsの機能を実装しているものは無いように思えます。

SBCLは、ソースを眺める限り&restを処理できていないのですが、今後修正されれば、今回の:pass-onも動くんじゃないかなと思います。


HTML generated by 3bmd in LispWorks 7.0.0

Flavorsのメソッドコンビネーションを眺めたり再現してみよう: :daemon-with-override

Posted 2018-12-12 13:48:13 GMT

Lisp メソッドコンビネーション Advent Calendar 2018 12日目 》

前回に引き続き、メソッドコンビネーション元祖のFlavorsに標準装備されていたメソッドコンビネーションを眺めたり再現してみたりしようと思います。

本当は、:pass-onの再現がしたいのですが、色々間に合ってないので、:daemon-with-overrideの再現でお茶を濁したいと思います。

:daemon-with-overrideは、Common Lispでいうと、:aroundなしのstandardメソッドコンビネーションの前に門番のメソッドがいるような感じですが、こんな感じに定義できます。

(define-method-combination :daemon-with-override ()
  ((before (:before))
   (after (:after))
   (primary ())
   (override (:override)))
  `(or 
    ,@(and override `((call-method ,(car override))))
    (multiple-value-prog1 
        (progn
          ,@(loop :for m :in before :collect `(call-method ,m))
          (call-method ,(car primary) ,(cdr primary)))
      ,@(loop :for m :in (reverse after) :collect `(call-method ,m)))))

細かいオプションは詰めてないですが、これくらいの定義なら空で書けるようになりました。
難解だと思っていたdefine-method-combination構文ですが、10個位定義を書けば、そこそこ覚えられそうですね。

では、使ってみましょう。

(defgeneric foo (x)
  (:method-combination :daemon-with-override))

(defmethod foo ((x T)) x)

(defmethod foo :before ((x T)) (print :before))

(defmethod foo :after ((x T)) (print :after))

(defmethod foo ((x rational)) `(rational ,(call-next-method)))

(defmethod foo ((x integer)) `(integer ,(call-next-method)))

(defmethod foo :override ((x number)) (evenp x))

(foo 8)
→ t 

(foo 9) ▻ :before ▻ :after → (integer (rational 9))

メソッドコンビネーションを展開してみるとこんな感じになります。

(mc-expand #'foo
           :daemon-with-override
           nil
           1)(or (call-method #<standard-method foo (:override) (number) 40201044DB>)
    (multiple-value-prog1
        (progn
          (call-method #<standard-method foo (:before) (t) 402045306B>)
          (call-method
           #<standard-method foo nil (integer) 4130468943>
           (#<standard-method foo nil (rational) 413046892B>
            #<standard-method foo nil (t) 413046961B>)))
      (call-method #<standard-method foo (:after) (t) 4020462243>)))

まとめ

:daemonメソッドコンビネーションに門番がついているというパターンなので、Common Lispでは、:aroundを使えば実現できるパターンですね。

数あるパターンが、Common Lispでは、:aroundとして集約されたという流れが想像できます。


HTML generated by 3bmd in LispWorks 7.0.0

実践SETF定義: setf placeって多値が取れたり取れなかったりする?

Posted 2018-12-12 13:04:44 GMT

Lisp SETF Advent Calendar 2018 12日目 》

前回の(setf all)を定義していて気付いたのですが、incfや、pushpopvaluesと組み合わせると処理系によって異なる動作をします。

下記のような例は、SBCLやAllegro CLでは中途半端な動きをしますが、LispWorksではマクロ展開時にエラーになります。

(let ((x 0)
      (y 0))
  (incf (values x y))
  (list x y))(1 nil) or error

(let ((x (list 0 1 2)) (y (list 1 2 3))) (pop (values x y)) (list x y))((1 2) nil) or error

もしや、setf以外はvaluesを取れないのかと思い、HyperSpecを確認してみましたが、5.1.2.3 VALUES Forms as Placesでもvaluessetf以外では機能しない、とは書いてありません。

間接的な定義がされている場合もあるので、それらしきものを探してみましたが、setfベースのマクロについての定義があります。

decfpoppushnewincfpushremfdefine-modify-macroで定義されているような挙動をする的な解釈が成立しそうな雰囲気もありますが、 define-modify-macroのAPIからすると、関数の引数として値を処理するので、多値は扱えません。
define-modify-macroで定義すれば、incfのようなものは、

(let ((x 0)
      (y 0))
  (setf (values x y)
        (values (1+ (values x y))))
  (list x y))(1 nil) 

のように展開されると思われるので、中途半端な返り値になっている理由も合点はいきます。

多値を扱いたい

とりあえず、多値を扱えるフォームはどんな感じになるか定義して眺めてみます。

incfの多値版は、こんな感じに定義できるかなと思います。

(defmacro incf* (place &optional (delta 1) &environment env)
  (multiple-value-bind (dummies vals newval setter getter)
                       (get-setf-expansion place env)
    (declare (ignore dummies vals setter))
    (let ((deltas (loop :for () :on newval :collect (gensym))))
      `(multiple-value-bind ,newval
                            ,getter
         (setf (values ,@deltas) 
               ,(if (eql 1 delta)
                    `(values ,@(loop :for () :on deltas :collect 1))
                    delta))
         (setf ,getter
               (values ,@(mapcar (lambda (v d)
                                   `(incf ,v ,d))
                                 newval
                                 deltas)))))))

(let ((x 0) (y 1)) (incf* (values x y) (values 1 10)) (list x y))(1 11)

popの多値版はこんな感じ

(defmacro pop* (place &environment env)
  (multiple-value-bind (dummies vals newval setter getter)
                       (get-setf-expansion place env)
    (declare (ignore dummies vals setter))
    (let ((retvars (loop :for () :on newval :collect (gensym))))
      `(multiple-value-bind ,newval
                            ,getter
         (let (,@(mapcar (lambda (a d)
                           `(,a (car ,d)))
                         retvars
                         newval))
           (setf ,getter
                 (values ,@(mapcar (lambda (v)
                                     `(cdr ,v))
                                   newval)))
           (values ,@retvars))))))

(let ((x (list 0 1 2)) (y (list 0 1 2))) (pop* (values x y)) (list x y))((1 2) (1 2))

VALUES Forms as Placesを処理できるdefine-modify-macro*のようなものを定義してみても良いかもしれません。

まとめ

どうせコンパイル時に展開すると思うのでVALUES Forms as Placesを処理できても良いと思うのですが、何か事情があるのでしょうか。

これらのフォームは、ループ内で頻出しそうなので極力無駄のない定義になる必要があるような気はしますが、展開時に無駄は省けそうですし、さて真相やいかに……。


HTML generated by 3bmd in LispWorks 7.0.0

Flavorsのメソッドコンビネーションを眺めたり再現してみよう: その二

Posted 2018-12-11 14:47:02 GMT

Lisp メソッドコンビネーション Advent Calendar 2018 11日目 》

前回に引き続き、メソッドコンビネーション元祖のFlavorsに標準装備されていたメソッドコンビネーションを眺めたり再現してみたりしようと思います。

前回いきなりcaseメソッドコンビネーションの再現に取り組んでみましたが、改めて、どんなメソッドコンビネーションがあるのか一覧にしてみたくなりました(ネタ切れだから)

調べてみたのは、後期Flavors〜New Flavorsあたりのメソッドコンビネーションです。

前知識

Flavorsのメソッドコンビネーションの標準構成は、Common Lisp版から:aroundを外したようなものです。
:aroundの部分は、defwrapperというメソッドを囲むマクロを定義する感じになります。

また、キーワードシンボルになっていますが、Lisp Machine Lispでは、userパッケージのシンボルの略記になります。
つまり、(eq :progn 'progn)です。
共用シンボルはuserパッケージに置かないで、keywordパッケージに纏めよう、と整理したのがCommon Lispです。

さて、では眺めてみましょう。

:daemon

Common Lispのstandardメソッドコンビネーションから:aroundを外したようなもの。
これを:darmonと呼びます。

:before / :after

Common Lispと同じです、:daemonメソッドコンビネーションの部品を単体で呼び出しているとも考えられます。

:and / :or / :progn

Common Lispから:aroundを外したようなもの。

:append / :nconc / :list

Common Lispから:aroundを外したようなもの。

:inverse-list

listが逆順になって返ってきます。
わざわざ用意しているからには使い道があるのでしょう……。

:max / :min / :sum

Common Lispと同じですが、:sumは、Common Lispでは+になっていますね。

:case

前回紹介した不思議メソッドコンビネーションです。

:daemon-with-and

:andの前後を:before:afterで囲んだものです。
Common Lispではand:daemonは付きません。

:daemon-with-or

:orの前後を:before:afterで囲んだものです。

:daemon-with-override / :override

:overrideで定義したメソッドが:daemonメソッドコンビネーションの前に配置されていて、それがorで結合しています。
つまり、:overridenilを返した場合だけ、:daemonに進むという変ったものです。

:two-pass

プライマリ全部起動の後に:after全部を起動するものらしいです。
make-instanceで良く使うらしいですが、インスタンス初期値の設定とかでしょうか。

:pass-on

メソッドの返り値を次のメソッドに次々と渡していくメソッドコンビネーションのようです。
先日フィルターを作ろうとしていましたが、pass-onならできそうです。 しかし、返り値は何故か多値で返す様子。。
(a b c)という引数を持つメソッドを連鎖させるには、(values a b c)で値を渡さないといけないようですが、何故なのか。

ネタ切れなので、次回からCommon Lispで、Flavorsのメソッドコンビネーションを、`Symbolics Open Genera上のFlavorsの挙動を確認しつつ再現していきます。


HTML generated by 3bmd in LispWorks 7.0.0

実践SETF定義:define-setf-expanderで型破りなsetf構文を作ろう

Posted 2018-12-10 17:46:17 GMT

Lisp SETF Advent Calendar 2018 11日目 》

setf関数、defsetfと紹介してきましたが、今回は一番汎用的なdefine-setf-expanderの紹介です。
実際、defsetfや、define-modify-macroも、define-setf-expanderの定義に展開している処理系も多いです。

define-setf-expanderを簡単に説明すると、

(setf (x y z) a b c)

のようなフォームのxyzabcという部品を好きなように配置することが可能です。

好きなように、といっても一応xyzは変数としての振舞い、abcは値としての振舞いをする必要はありますので、作法に則る必要はあります。

CPLの代入構文のallを作ってみよう

左辺値について調べている際に、CPLが左辺値、右辺値を整理したとWikipediaに書いてあったので、ちょっと眺めてみましたが、Fortran、Algolに比較すれば、左辺値が拡張された感じはします。

左辺値にリスト表現や配列をとって、変数を複数同時に代入できたり、リストを分解して変数に代入できたり、1963年の言語にしては先進的ですが、拡張のバリエーションとして、

all a, b, c := 0

という書法がありました。

上記の場合は、変数全部に0が代入されるわけですが、左辺と右辺で微妙に対称性がなく、イレギュラーなsetf定義の例に良さそうなので、ちょっと考えてみましょう。
まず、構文の見た目ですが、こんな感じになるかなと思います。

(setf (all a b c) 0)

(list a b c)(0 0 0)

構文全体としては直感的なのですが、allというゲッターを考えるに、これは単独では存在できそうにないですが、どうなんでしょう。
それはさておきこんな感じに書いてみました。

(define-setf-expander all (&rest places &environment env)
  (loop :with store := (gensym "all-")
        :for p :in places
        :for (d v sv setter getter) := (multiple-value-list (get-setf-expansion p env))
        :append d :into ds
        :append v :into vs
        :append sv :into svs
        :collect setter :into setters
        :collect getter :into getters
        :finally (return 
                  (values ds
                          vs
                          `(,store)
                          `(let (,@(mapcar (lambda (v)
                                             `(,v ,store))
                                           svs))
                             (values ,@setters))
                          `(values ,@getters)))))

下記のフォームをマクロ展開してみると、

(let ((x 0)
      (y 0)
      (z 0))
  (incf (all x y z) 100)
  (list x y z))(100 100 100)

こんな感じになります。

(let ((x 0) (y 0) (z 0))
  (let* ()
    (let* ()
      (let ((#:|all-128690| (+ (values x y z) 100)))
        (let ((#:|Store-Var-128691| #:|all-128690|)
              (#:|Store-Var-128692| #:|all-128690|)
              (#:|Store-Var-128693| #:|all-128690|))
          (values (setq x #:|Store-Var-128691|)
                  (setq y #:|Store-Var-128692|)
                  (setq z #:|Store-Var-128693|))))))
  (list x y z))

大体の場所でallは機能が成立するようです。

(let ((x (list 0 1 2))
      (y 0)