Posted 2021-01-24 15:41:27 GMT
Common Lispでもたまに列挙型が欲しいことがありますが、そもそも列挙型はある要素の集合のことを指すようで、連続的な整数の一連の別名というわけではない様子。
そういった場合は、型記述子member
で記述できるのですが、
(typep 'a '(member a b c))
→ t
大抵の場合は、数値の連続に別名が付いたものが欲しかったりするので、member
では数値との対応が実現できません。
連続した数値に別名を付与しつつ、これらと組み合わせて使うことが多いcase
系の構文でも使い勝手良いものをと考えると、シンボルマクロで数値に別名を付与しつつ型の宣言もつけたらどうかと思い試してみました。
具体的には下記のようになります。
(deftype foo () '(eql 0))
(define-symbol-macro foo 0)(typep foo 'foo)
→ t
少し規模が大き目なものの場合、
(macrolet ((defenum (&rest args)
`(progn
,@(loop :for idx :from 1
:for name :in args
:collect `(progn
(define-symbol-macro ,name ,idx)
(deftype ,name () '(eql ,idx)))))))
(defenum H He Li Be B C N O F Ne Na Mg Al Si P S Cl
Ar K Ca Sc Ti V Cr Mn Fe Co Ni Cu Zn Ga Ge As Se Br
Kr Rb Sr Y Zr Nb Mo Tc Ru Rh Pd Ag Cd In Sn Sb Te I
Xe Cs Ba La Ce Pr Nd Pm Sm Eu Gd Tb Dy Ho Er Tm Yb
Lu Hf Ta W Re Os Ir Pt Au Hg Tl Pb Bi Po At Rn Fr Ra
Ac Th Pa U Np Pu Am Cm Bk Cf Es Fm Md No Lr Rf Db Sg
Bh Hs Mt Ds Rg Cn Nh Fl Mc Lv Ts Og))
(typecase F
((or F Cl Br I At Ts) 'yes)
(T 'no))
→ yes
(deftype Halogens ()
(list 'member F Cl Br I At Ts))
(typecase F
(Halogens 'yes)
(T 'no))
→ yes
ちなみに、定数宣言して、case
と#.
の組み合わせを使うというのを目にしたことはありますが、#.
を書くのが面倒だったり、評価タイミングを考えたりする必要があったりで、あまり使い勝手は良くないという印象です。
(case .F
((#.F #.Cl #.Br #.I #.At #.Ts) 'yes)
(otherwise 'no))
→ yes
cl-enumerationのようなライブラリもありますが、一般的な言語の所謂enum
とは微妙に目指すところが違うようです。
Common Lispだけで完結している場合には、あまり必要にならないのですが、既存のデータ定義を取り込んだり、別言語のコードを流用したりする場合に、enum
欲しいなあとなることが多いですね。
■
HTML generated by 3bmd in LispWorks 7.0.0
Posted 2021-01-21 01:55:42 GMT
こちらの記事を読んで、自分が考えているオブジェクト指向とは随分違う何かがC++やJavaのオブジェクト指向プログラミングなんだなあと思いましたが、それと同時に、パラダイムがどうこうというより特定のパラダイムやシステムに囚われてしまう状況では、そこから抜け出すには、既存のものを捨てて他のパラダイムに移行せざるを得ないと考えてしまうのかもなあと感じました。
Common Lispはマルチパラダイムですが、
あたりが組込み機能です。
データがコードなため、メタプログラミングが容易で、組み込み言語のDSLで、Prologや、プロダクションシステム等を組込んで使ったりすることも可能です。 まあ、DSLが元言語とどこまで違和感なく連携するかはまた別の話ではありますが。
goto廃止論争が華やかだった時代も、マクロで構文を拡張できるLispは、gotoを廃止するということもなく、go
を直接手書きしないような構文をマクロで言語標準機能として構築して迂回。
オブジェクト指向システムはSmalltalkの影響下で二三の実装がありましたが、最終的には総称関数という関数呼び出しにメッセージ送信を融合したような形式に収める、などなど、色々なパラダイムを吸収してきてはいますが、オブジェクト指向システムをほぼ使わずに書くことも可能ですし、関数がファーストクラスなので関数型的に書くことも容易です。
もともと対話環境が強力ですが、対話形式でも使えますし、バッチ形式でも使えます。
様々なパラダイムを強力なメタプログラミング機構がゆるくまとめているところもあるかもしれません。
こういうCommon Lispみたいな逃げ場が沢山ある言語が流行ると嬉しいですね。
■
HTML generated by 3bmd in LispWorks 7.0.0
Posted 2021-01-11 20:32:42 GMT
こちらの記事を目にして、IDEでコードを自動生成するのって格好良いと思ったので、Common Lispだとどうなるか考えてみました。
とりあえず構造体の場合は何もしなくてもコンストラクタのinitarg
がスロット名に応じて決定されてしまうので、何もしなくてもOKです。
勝手に決まってしまうことについては賛否がありますが、便利な局面は多いかと思います。
(defstruct codable-struct)(defstruct (sample-struct (:include codable))
int
title
body
thumbnail-url
tags
categories
created-at
updated-at
comment
favoritedp
bookmarkedp
url)
(make-sample-struct :int 0
:title "title"
:body "body"
:thumbnail-url "https://example.com/image.jpg"
:tags '("tag")
:categories "cat"
:created-at 0
:updated-at 0
:comment "comment"
:favoritedp nil
:bookmarkedp nil
:url "https://example.com")
→ #S(sample-struct :int 0
:title "title"
:body "body"
:thumbnail-url "https://example.com/image.jpg"
:tags ("tag")
:categories "cat"
:created-at 0
:updated-at 0
:comment "comment"
:favoritedp nil
:bookmarkedp nil
:url "https://example.com")
クラスの場合は、構造体と違って全部指定してやらないといけません。
定義していない初期化のためのキーワード(:initarg
)を指定しない場合はもちろんエラーです。
(defclass codable ()
())(defclass sample-class (codable)
(int
title
body
thumbnail-url
tags
categories
created-at
updated-at
comment
favoritedp
bookmarkedp
url))
(make-instance 'sample-class)
→ #<sample-class 402018AA93>
(make-instance 'sample-class
:int 0
:title "title"
:body "body"
:thumbnail-url "https://example.com/image.jpg"
:tags '("tag")
:categories "cat"
:created-at 0
:updated-at 0
:comment "comment"
:favoritedp nil
:bookmarkedp nil
:url "https://example.com")
→ #<error>
Common Lispだとコンストラクタのコードを生成するようなことはマクロで実現してしまうのですが、IDEが補完してくれるのが格好良いという話なので、IDE側でコードを生成して挿入したいところです。
ということで、initialize-instance
のコードを生成して、エディタのコマンドで挿入してみることにしました。
(let* ((keys (mapcar (lambda (s)
(let ((s (slot-definition-name s)))
`(,s nil ,(intern (format nil "~A?" (string s))))))
(class-slots (find-class 'sample-class)))))
`(defmethod initialize-instance ((obj sample-class) &key ,@keys)
(let ((obj (call-next-method)))
,@(mapcar (lambda (k)
(destructuring-bind (name init namep)
k
(declare (ignore init))
`(and ,namep (setf (slot-value obj ',name) ,name))))
keys)
obj)))
した結果をエディタ(LispWorksのHemlock)からバッファに挿入します。
パッケージとシンボルの扱いのあれこれがあるので大分ごちゃごちゃになりました。
(defcommand "Generate Memberwise Initializer" (p)
"Generate Memberwise Initializer"
"Generate Memberwise Initializer"
(declare (ignore p))
(let ((def (current-top-level-definition-maybe)))
(if (and (listp def)
(eq (first def) 'defclass))
(progn
(end-of-defun-command 1)
(insert-string
(current-point)
(with-output-to-string (out)
(pprint
(let ((.class-name. (second def)))
(declare (special editor::.class-name.))
(eval
(read-from-string
"(let* ((keys (mapcar (lambda (s)
(let ((s (slot-definition-name s)))
`(,s nil ,(intern (format nil \"~A?\" (string s))))))
(class-slots (find-class editor::.class-name.)))))
`(defmethod initialize-instance ((obj sample-class) &key ,@keys)
(let ((obj (call-next-method)))
,@(mapcar (lambda (k)
(destructuring-bind (name init namep)
k
(declare (ignore init))
`(and ,namep (setf (slot-value obj ',name) ,name))))
keys)
obj)))")))
out))))
(message "~S is not a defclass" def))))
これで、defclass
の上で、“Generate Memberwise Initializer” します。
(defmethod initialize-instance
((obj sample-class)
&key
(int nil int?)
(title nil title?)
(body nil body?)
(thumbnail-url nil thumbnail-url?)
(tags nil tags?)
(categories nil categories?)
(created-at nil created-at?)
(updated-at nil updated-at?)
(comment nil comment?)
(favoritedp nil favoritedp?)
(bookmarkedp nil bookmarkedp?)
(url nil url?))
(let ((obj (call-next-method)))
(and int? (setf (slot-value obj 'int) int))
(and title? (setf (slot-value obj 'title) title))
(and body? (setf (slot-value obj 'body) body))
(and thumbnail-url? (setf (slot-value obj 'thumbnail-url) thumbnail-url))
(and tags? (setf (slot-value obj 'tags) tags))
(and categories? (setf (slot-value obj 'categories) categories))
(and created-at? (setf (slot-value obj 'created-at) created-at))
(and updated-at? (setf (slot-value obj 'updated-at) updated-at))
(and comment? (setf (slot-value obj 'comment) comment))
(and favoritedp? (setf (slot-value obj 'favoritedp) favoritedp))
(and bookmarkedp? (setf (slot-value obj 'bookmarkedp) bookmarkedp))
(and url? (setf (slot-value obj 'url) url))
obj))
defclass
で定義した挙動とは厳密には違いますが、こんな感じに初期化できるようになりました。
(make-instance 'sample-class
:int 0
:title "title"
:body "body"
:thumbnail-url "https://example.com/image.jpg"
:tags '("tag")
:categories "cat"
:created-at 0
:updated-at 0
:comment "comment"
:favoritedp nil
:bookmarkedp nil
:url "https://example.com")
→ #<sample-class 4020240C13>
#||
int 0
title "title"
body "body"
thumbnail-url "https://example.com/image.jpg"
tags ("tag")
categories "cat"
created-at 0
updated-at 0
comment "comment"
favoritedp nil
bookmarkedp nil
url "https://example.com"
||#
初期化手続きの生成はどうもいまひとつな気がするので、スロット定義を自動生成する方法を試してみます。
とりあえず、
:initarg
を生成としてみます。
クラスのスロット定義からスロット名を抜き出し:initarg
を生成するのはこのようになります。
(defun add-initargs (class-name)
(dolist (s (class-direct-slots (find-class class-name)))
(setf (slot-definition-initargs s)
(list (intern (string (string (slot-definition-name s)))
:keyword))))
(reinitialize-instance (find-class class-name)))
次にdefclass
フォームの生成
(defun gen-defclass (class-name)
(let ((class (find-class class-name)))
`(defclass ,(class-name class)
(,@(mapcar #'class-name (class-direct-superclasses class)))
,(mapcar (lambda (s)
(append (list (slot-definition-name s))
(mapcan (lambda (i)
(list :initarg i))
(slot-definition-initargs s))))
(class-direct-slots class))
(:documentation ,(documentation class 'type))
(:metaclass ,(class-name (class-of class)))
(:default-initargs ,@(class-default-initargs class)))))
エディタのコマンドにまとめる
(defcommand "Generate Memberwise Initializer" (p)
"Generate Memberwise Initializer"
"Generate Memberwise Initializer"
(declare (ignore p))
(let ((def (current-top-level-definition-maybe)))
(if (and (listp def)
(string-equal (first def) 'defclass))
(let ((*package* (get-buffer-current-package (current-buffer))))
(add-initargs (print (second def)))
(let ((dc (gen-defclass (second def))))
(end-of-defun-command 1)
(insert-form-at-point (current-point)
dc))
(values))
(message "~S is not a defclass" def))))
これで、コマンド実行でスロット名がキーワードパッケージになった:initarg
が追加されたdefclass
がバッファに挿入されます。
ちなみに、:initarg
以外も処理する必要がありますが今回は面倒なので省略します……。
(defclass sample-class (codable)
((int :initarg :int)
(title :initarg :title)
(body :initarg :body)
(thumbnail-url :initarg :thumbnail-url)
(tags :initarg :tags)
(categories :initarg :categories)
(created-at :initarg :created-at)
(updated-at :initarg :updated-at)
(comment :initarg :comment)
(favoritedp :initarg :favoritedp)
(bookmarkedp :initarg :bookmarkedp)
(url :initarg :url))
(:documentation nil)
(:metaclass standard-class)
(:default-initargs))
色々考えてみましたが、defclass
の派生マクロを作る方が楽だなと思いました。
マクロを基準に考えると、IDE側の方は展開したコードから元のコードへ戻す知識が失われるという欠点があり、マクロは派生した構文の使い方をおぼえるのが手間という欠点があります。
プログラム生成の知識をIDEが持つのかマクロが持つのかの違いでしかないと考えれば、プロジェクトごとに派生した定義構文があっても別に良いのかなと思ったりしました。
■
HTML generated by 3bmd in LispWorks 7.0.0
Posted 2021-01-09 03:32:39 GMT
LispWorksを他のCommon Lispの処理系と比較した場合の特徴としては、Lisp処理系とIDEが密に連携している点です。
1989年のHarlequinのLispWorksの紹介によると、言語処理系の設計に先行してIDEの設計をしたとありますが、この辺りがLispWorksがIDE然としてしている所以ではないでしょうか。
LispWorks
=========...
The Approach
By designing the programming environment before the underlying language system,
Harlequin has engineered an unrivalled degree of internal cohesion into the
product. Programming tools are firmly embedded in the environment and both are
supported by sophisticated facilities for compilation and interpretation,
together with unobtrusive ephemeral garbage collection. The whole package is
written in Lisp to enhance consistency, maintainability and extensibility.
Lispマシンの環境も単なるLisp処理系ではなくIDEを指向していましたが、その後に擡頭してくる安価なUnixワークステーション上でのCommon Lisp環境もLispマシンを手本とし、IDEとしての完成度を追求していました。
似たような文化の言語にはSmalltalkがありますが、Common Lispの方は、Smalltalkと違って時代が下るにつれ処理系の言語処理系のコア以外の部分がどんどん落ちてしまい、Emacs+Common Lisp処理系(SLIME)というLispマシン以前に近いところまで遡ってしまいました。
その点では、LispWorksはIDEとしてのCommon Lisp環境として生き残った数少ない例かなと思います。
類似のものには、MCLがありましたが、2009年にIDEとしては終焉を迎えています。
LispWorksのIDEの詳細な解説はマニュアルにゆずるとして、便利な機能をピックアップして紹介してみます。
Tools > Inspector
からインスペクタを開けます。
下記のように*inspect-through-gui* T
の状態でinspect
を使うとinspect
の実行履歴が、Previous
、Next
ボタンで参照できます。
(setq *inspect-through-gui* T)(defun foo-loop (n)
(dotimes (i n)
(inspect (* i 8))))
(foo-loop 8)
オブジェクトの状態変化の追跡等に非常に便利です。
Definitions > Function Calls
で呼び出しをツリー構造で眺めることが可能です。
所謂、who-calls
、calls-who
の機能なのですが、GUIの操作でソースの参照も簡便に実現されているため、ソース参照M-x .
およびM-x ,
の発展版としても利用可能です。
GUI画面でステップ実行が可能です。
現在メジャーな開発環境であるSBCL+SLIME等ではステップ実行は苦手としているためか、ステップ実行自体がCommon Lispでは無理という印象がありますが、LispWorksでは普通にGUIから対話的に操作可能です。
Common Lispの関数でいうと(break)
ですが、LispWorksでは、IDEとして統合されていて、メニューや、エディタのM-x Toggle Breakpoint
で該当箇所に印をつけることで、(break)
をコードに差し込まなくともブレイクすることが可能です。他の言語のIDEとしてもメジャーな機能かと思います。
ブレイクした後は、IDEのデバッガでリスタートや脱出、値の調査が可能です。
また、インスタンスオブジェクトのスロットのアクセスにもブレイクポイントを仕掛けることが可能です。こちらはインスペクタからブレイクポイントとその種類を設定可能ですがデバッグには便利でしょう。
主に印字出力の確認ですが、LispWorksをSLIME的に使うのであれば、エディタ+アウトプットブラウザのウィンドウの二枚開きか、エディタ+リスナーの二枚開きという感じになります。
アウトプットブラウザにはプリントの結果やマクロ展開やtime
の結果が上から下へ流れて表示されます。
コンパイラの警告を一覧でみることができるブラウザです。
エラーメッセージをクリックしてエラー箇所の関数にジャンプし修正、等が可能です。
Common Lispでいう(trace)
をGUIから操作できるようにしたものです。
テキスト表示とそれほど違いはありませんが、視認性と操作性は向上しているかと思います。
テキストのコピペのクリップボード機能のようにオブジェクトをクリップボードに保存し、任意の場所に貼り付けることが可能です。
リスナー上でmake-instance
したオブジェクトを保存しておき、インスペクタで変化を確認したり、値を設定したりするのに便利です。
結果の確認ツールとして、リスナー(REPL)や、インスペクタが活躍しますが、ツール間でリンクすることにより、あるツールの結果をインスペクタやリスナーと同期させることが可能です。
マニュアルに紹介されている例では、クラスブラウザでクラスを眺めつつ、Tools Clone
でクラスブラウザを複製し、主になるクラスブラウザとEdit > Link from
でリンクし、サブの方は同期したスロット定義を眺める、という使い方が紹介されています。
リスナーとの連携は、リスナー上の*
変数を仲介した連携が主で、インスペクタとリンクすることにより、リスナーの*
変数が更新される度にインスペクタのオブジェクトも更新される、ということが可能です。
ちなみに、エディタともリンク可能ですが、バッファオブジェクトが共有されるため、いまいち使いどころが難しくなっています。もしかしたら、バッファオブジェクト経由でのエディタの一括編集の実行等で活躍できたりするのかもしれません。
def
系の構文の上でM-x Undefine
コマンドを実行することにより、定義を取り消すことが可能です。
特に便利なのは、defmethod
の場合ですが,定義のメソッドだけ削除してくれるところが便利でしょう。
このためLispWorks上では、総称関数をfmakunbound
して一式を再定義するようなことは皆無です。
また、定義系の構文がIDEと統合されていて拡張可能なため、任意の定義構文用のUndefine
操作をユーザーが設定可能です。
エディタはこのブログでも何度か紹介していますが、元は、Spice LispのHemlockというEmacsのCommon Lisp実装です。
この記事もLispWorksのHemlockで書いていますが、Emacsとしてもそこそこ普通に使えます。
ユーザー定義のコマンド等は、当然ながらCommon Lispで拡張を書きますが、LispWorksの機能をフルに活用できるのがメリットでしょうか。
ざっと、普段使っていて便利なLispWorks IDEの機能を紹介してみました。
細かい便利機能は沢山あるので、機会があればまた紹介してみたいと思います。
■
HTML generated by 3bmd in LispWorks 7.0.0
Posted 2021-01-03 21:49:53 GMT
LispWorksのKnowledgeWorksでは、オブジェクトシステムと組み込みPrologが統合されています。
Prologの複合項(構造体)に相当するものをオブジェクトや構造体で表現しますが、この知識ベースクラスのオブジェクトや構造体はワーキングメモリという場所に蓄積されます。
ワーキングメモリに蓄積されたオブジェクトは、(class名 ?obj スロット名 ?slot ...)
という形式でパターンマッチで問い合わせ可能になります。
読み込んだJSONや、plistで表現したデータ、ORMでSQLで問い合わせした結果のオブジェクト等、様々な形式のデータをワーキングメモリに格納し、Prologで問い合わせするのが割合に便利なのですが、今回は、LispWorksではなくPAIPrologのようなものでも似たようなことができないか試してみたいと思います。
今回は、ウェブページのスクレイピングをPrologの問い合わせでやってみます。
利用する組み込みPrologは、PAIPrologですが、単一化がeql
だったり、オブジェクトを項として登録するのに結局改造しないといけなかったので、実験用にPAIPrologからフォークして別パッケージを作成してみました。
(ql:quickload '(clss plump dexador zrpaiprolog))(defpackage "d7aba921-29b4-5320-acaa-13531caa1f16"
(:use c2cl zrlog)
(:shadowing-import-from zrlog ignore debug symbol))
(cl:in-package "d7aba921-29b4-5320-acaa-13531caa1f16")
今回、DOMオブジェクトにはplumpを利用します。
plump:element
が基本となるオブジェクトなので、plump:element
という名前とオブジェクトを項として登録するadd-object-clause
というものを定義し、オブジェクト生成時のフックに登録します。
(defmethod initialize-instance :after ((obj plump:element) &rest initargs)
(add-object-clause 'plump:element obj))
add-object-clause
は、PAIPrologのadd-clause
を少し改造しただけのものです。
項が増えるとシンボルにぶら下がる情報が多くなり過ぎる気がしますが、とりあえず実験なのでこれでよしとします。
(defun add-object-clause (name obj &key asserta)
(let ((pred name))
(assert (and (symbolp pred) (not (variable-p pred))))
(pushnew pred *db-predicates*)
(pushnew pred *uncompiled*)
(setf (get pred 'clauses)
(if asserta
(nconc (list (list (list name obj))) (get-clauses pred))
(nconc (get-clauses pred) (list (list (list name obj))))))
pred))
これで、ウェブページを取得し、plump:parse
した時点でPrologの項が登録されます。
(plump:parse (dex:get "https://www.shop-shimamura.com/disp/itemlist/001002001/"))
→ #<plump-dom:root 4250272873>
CSS Selectorでの問い合わせ的にするために、問い合わせのユーティリティとして、ノードの"class"
属性を根の方向に探索するclass-named
というのを定義してみます。
なお、子→親の方向で検索するのは、要素を項としている都合上です。
(defun class-named (class node)
(typecase node
(plump:root NIL)
(T (cond ((plump:attribute node "class")
(and (equal class (plump:attribute node "class"))
node))
(T (and (class-named class (plump:parent node))
node))))))
これでこんな風に書けます。
(prolog
(plump::element ?elt)
(is ?tag (plump:tag-name ?elt))
(= ?tag "img")
(is ?ans (class-named "card__thumb" ?elt))
(is T (not (null ?ans)))
(lisp (format T
"~A: ~A~%"
(plump:attribute ?ans "alt")
(plump:attribute ?ans "src"))))
▻ メンズ ワッフルトレーナー(SEASON REASON): https://img.shop-shimamura.com/items/images/01/0120800000660/01_0120800000660_111_l.jpg
▻ メンズ ワッフルトレーナー(SEASON REASON): https://img.shop-shimamura.com/items/images/01/0120800000660/01_0120800000660_113_l.jpg
▻ メンズ ワッフルトレーナー(SEASON REASON): https://img.shop-shimamura.com/items/images/01/0120800000660/01_0120800000660_215_l.jpg
▻ メンズ トレーナー(SEASON REASON): https://img.shop-shimamura.com/items/images/01/0120800000659/01_0120800000659_111_l.jpg
▻ メンズ トレーナー(SEASON REASON): https://img.shop-shimamura.com/items/images/01/0120800000659/01_0120800000659_113_l.jpg
▻ メンズ トレーナー(SEASON REASON): https://img.shop-shimamura.com/items/images/01/0120800000659/01_0120800000659_214_l.jpg
▻ メンズ トレーナー(SEASON REASON): https://img.shop-shimamura.com/items/images/01/0120800000659/01_0120800000659_305_l.jpg
▻ メンズ プルパーカ(SEASON REASON): https://img.shop-shimamura.com/items/images/01/0120800000657/01_0120800000657_312_l.jpg
▻ メンズ プルパーカ(SEASON REASON): https://img.shop-shimamura.com/items/images/01/0120800000657/01_0120800000657_305_l.jpg
▻ メンズ プルパーカ(SEASON REASON): https://img.shop-shimamura.com/items/images/01/0120800000657/01_0120800000657_307_l.jpg
▻ メンズ裏毛プルパーカ(呪術廻戦): https://img.shop-shimamura.com/items/images/01/0128200004027/01_0128200004027_213_l.jpg
▻ メンズ裏毛プルパーカ(呪術廻戦): https://img.shop-shimamura.com/items/images/01/0128200004026/01_0128200004026_212_l.jpg
▻ キャラクタートレーナー(呪術廻戦): https://img.shop-shimamura.com/items/images/01/0123200005469/01_0123200005469_212_l.jpg
▻ キャラクタートレーナー(呪術廻戦): https://img.shop-shimamura.com/items/images/01/0123200005468/01_0123200005468_213_l.jpg
▻ キャラクタートレーナー(にゃんこ大戦争): https://img.shop-shimamura.com/items/images/01/0123200005379/01_0123200005379_213_l.jpg
▻ キャラクタートレーナー(にゃんこ大戦争): https://img.shop-shimamura.com/items/images/01/0123200005378/01_0123200005378_212_l.jpg
▻ キャラクターパーカ(にゃんこ大戦争): https://img.shop-shimamura.com/items/images/01/0123200005377/01_0123200005377_211_l.jpg
▻ メンズ裏毛トレーナー(ブラッククローバー): https://img.shop-shimamura.com/items/images/01/0128200004042/01_0128200004042_112_l.jpg
▻ メンズ裏毛プルパーカ(ブラッククローバー): https://img.shop-shimamura.com/items/images/01/0128200004041/01_0128200004041_211_l.jpg
▻ メンズ裏毛プルパーカ(ブラッククローバー): https://img.shop-shimamura.com/items/images/01/0128200004040/01_0128200004040_213_l.jpg
▻ しまむらロゴパーカ: https://img.shop-shimamura.com/items/images/01/0123200005278/01_0123200005278_201_l.jpg
▻ しまむらロゴトレーナー: https://img.shop-shimamura.com/items/images/01/0123200005277/01_0123200005277_212_l.jpg
→ nil
clssでCSS Selectorで書くと
(clss:select ".card__thumb img")
一行ですが、CSS Selectorの細かい規則を覚えるのも大変ですし、組み込みPrologで一本化できると嬉しいと思いたい。
木構造オブジェクトの問い合わせ言語は様々あるのですが、これをどうにか組み込みPrologで一本化できないか今後も探っていきたいと思います。
とりあえずは、PrologでJSON等の木構造の問い合わせをどうやっているか調査した方が良いかもしれない……。
■
HTML generated by 3bmd in LispWorks 7.0.0
Posted 2020-12-31 14:50:55 GMT
恒例になっているので今年も振り返りのまとめを書きます。
昨年は自分的にMOPブームでしたが、今年はMOPでプログラミングできる知識が大体揃って来た感じで、実際のプログラムでも普通に活用できたりするようになりました。
といっても大した応用ではないのですが、普通の道具になった、位のところです。
CLOS MOPだと大別すると、
位が大きなトピックで他は上記の組み合わせか、細々としたところなので、クックブック的な感じでまとめておくと便利かなと思ったりしています。
今年書いた記事は62記事でした。
まあまあ書いた方だとは思いますが、ネタ自体はストックが100記事分位はあるので、一旦全部出し切りたいところです。
LispWorksを購入してから五年半経過しましたが、すっかりSLIME+SBCLの環境よりLispWorksで書く方が楽になってしまいました。
単なる慣れというところもありますが、IDEとしてはSLIME+SBCLより統合されていて便利なところが多いです。まあもちろんエディタ単体ではHemlock(LispWorksのエディタ)よりGNU Emacsの方が高機能ですが。
仕事では、LispWorksで社内アプリ(Macのデスクトップアプリ)を量産していて、直近の業務で必要なツールを作成していていつの間にか20種類位になりました。
エンジニアでない人にGitHubを使ってもらうのに、GUIで簡単なラッパーを作成したり、社内業務のオートメーションでLispWorksが使えそうなところを見付けたら即投入しています。
Unixのシェルスクリプト、Google Apps Script、等々オートメーションのツールはありますが、手早く書捨てのGUIのアプリを作成できるという点では割とLispWorksは良いと思っています。
Lisp界隈もだいぶ盛り下がってきた感じで、当ブログももう誰も読んでない感じになってきました。
盛り上げる方法は多分ないのですが、文章のアウトプットは好きな方なので、ニッチなネタを垂れ流していきたいと思います。
また、13年位Lispコミュニティを眺めていますが、いまだLispに関する知識が1980年代な人を多く目にするのが不思議です。
恐らく古い書籍の情報をソースにしたものが再生成されているのではないかと思うのですが、このような傾向をアップデートすべく、2021年はWikipedia等の化石化した情報も更新したりすることにも取り組んでみようかなと思います(がWikipediaの更新は手間がかかる)
■
HTML generated by 3bmd in LispWorks 7.0.0
Posted 2020-12-28 22:07:24 GMT
いつものようにCommon Lisp情報を求めてインターネットを徘徊していたのですが、ECLのマニュアルににCRSというのがあるのが気になって調べてみました。
ECL is based on a Common Runtime Support (CRS) which provides basic facilities for memory management, dynamic loading and dumping of binary images, support for multiple threads of execution.
ECLのマニュアルの説明では、CRSは、メモリ管理やスレッド等の実行時に必要なものがモジュール化されたものという感じですが、CRSはECLとも独立した存在のようで、CRSについて別途論文も書かれていました。
こちらの論文を読むと、CRSとはCを中間言語として、実行時に必要な言語機能をモジュール化したり、データ形式を統一したものだったようで、CRSを基盤にCや、Lisp、Prologの環境が構築可能で、それぞれの言語が双方向に呼び出し可能な仕組みだったようです。
;;; Prolog機能を使ったCommon Lispのコード例
(defun reverse (x y)
(trail-mark)
(or (and (get-nil x) ;reverse([],[]).
(get-nil y)
(success))
(trail-restore)
(let (x1 x2 (y2 (make-variable)))
(and
(get-cons x)
(unify-variable x1)
(unify-variable x2)
(goals
(reverse x2 y2) ; :- reverse(X2,Y2),
(concat y2 (list x1) y)))))
(trail-unmark))
この論文の後ろの方に出てくるCommon Lispの処理系はECLではなく、Delphi Common Lisp(DCL)というECLの作者であるAttardi先生が1985年に起業したイタリアのベンチャーが販売していた商用処理系なのですが、古いECLのソースを確認すると、ECLは元々はこのDCLのCLOS部やCRS部分がECoLispとしてGPLライセンスで公開されたもののようです。
ECoLisp(Embeddable Common Lispの略)の略でECLとしていたものが、いつのまにかEmbeddable Common Lispの略でECLになったらしいのですが、別にECoLispのままでも良かったような……。
This is ECoLisp (ECL), an Embeddable Common Lisp implementationCopyright (c) 1990, 1991, 1993 Giuseppe Attardi
Authors:
KCL: Taiichi Yuasa and Masami Hagiya
Dynamic loader: William F. Schelter
Conservative GC: William F. Schelter
Top-level, trace, stepper: Giuseppe Attardi
Compiler: Giuseppe Attardi
CLOS: Giuseppe Attardi with excepts from PCL by Gregor Kiczales
Multithread: Giuseppe Attardi, Stefano Diomedi, Tito Flagella
Unification: Giuseppe Attardi, Mauro Gaspari
なお、現状資料が見当たらないので推測に過ぎませんが、KCLにマルチスレッドやCLOS、X11のGUIを付けて商用化されたものがDCLで、ECLは、それをCRSとAKCLをベースに構築しなおしたものなのかなと考えています。
ECoLisp 0.12をSunOSのエミュレータでビルドして確認してみましたが、この頃までは、CRS部はまだ独立していますが、既にユニフィケーション部はほぼ残骸だけとなり、上記のLispからProlog機能を使うようなコードは書けなくなっています。
CLOS部もPortable CommonLoops(PCL)とは独立の実装で、class-prototype
の代わりに、先にmetaclass
クラスを作っておくという独自方式でしたが、徐々にAMOP準拠に書き換えられた様子。
とはいえ、まだ結構な量が健在です。
折角面白い機能であったCRSとProlog連携でしたが、どうも1990年代中盤には、ECLのコードからも削除されつつあり利用できなくなっていたようです。残念!
Poplogも共通の言語基盤を通して、Common LispとProlog、ML、Pop-11が連携しますが、あまりこういうのは流行らないのでしょうか。割合に面白いと思うのですが……。
なお、今回始めて知りましたが、Attardi先生は、元々はHewitt先生の元でアクター理論を研究していた方だったようです。
Delphi Common Lispも1980年代中後半にCLOSとX11上のGUI、マルチスレッド機能が使えたワークステーション上の処理系ということで大分時代を先取りしていたようですね。
■
HTML generated by 3bmd in LispWorks 7.0.0
Posted 2020-12-24 20:30:34 GMT
Lispの調べ物をしてインターネットを彷徨っていたところ、井田昌之先生が公開されている歴史的資料のページに辿り着きました。
なんとCommon Lisp系を中心として歴史的な資料が満載ではないですか。
下記にLisp系の資料を抜粋したリンクを適当なコメントと共に並べてみます。
1970年代は、Lisp 1.5 との出会いから、Intel 8080上で動くLispマシンである、ALPS/Iの開発を中心に研究されていたようです。
所謂マイコンといわれていたCPU上でLispを動かす研究としてはかなり初期の取り組みではないでしょうか。
1980年代前半は、ALPS/Iの開発と並行して当時擡頭してきたAIマシン(Lispマシン)も研究されていたようです。
1984年にCommon Lispが登場しますが、それまでのマイコンLispの研究をバックグラウンドに、Common Lispのサブセットを検討されたり、Common Lispのオブジェクトシステムについて研究をされていたようです。
1986年あたりから電子メールを基盤とした議論について等も研究されている様子、また、ISO版Lispについての議論が盛り上がりつつあったことが判ります。
ANSI CLに取り込まれる予定のCLOSがかなりまとまった頃で、CLOS的にはかなり熱い時期だったようです。
ネットワーク透過なウィンドウツールキットであるYYonXの研究、ヨーロッパで擡頭してきた米国Common Lispへの対抗馬であるEuLisp等が熱い時期だったようです。
ワークステーション文化も花盛りという感もあり、キャンパスネットワーク等の研究もされていたようです。
この辺りからLisp関連の研究は一段落され、当時擡頭してきたJavaの方に研究の軸足を移された様子。
また自由ソフトウェア運動の紹介等もされていたようです。
Emacsでは、レキシカルスコープは遅いのでダイナミックスコープを採用した、というのが通説ですが、この下記のインタビューではレキシカルスコープは速度と名前の競合回避には良いが、実装が簡単なのでダイナミックスコープを採用したとありますね。
レキシカルスコープは遅い説はどこが出所だったかな(History of T)だったような。
まだまだ資料を全部は読み込めていないのですが、1980年代後半のCLOS系の資料や、Lispの国際規格化での各国の思惑等が伺える資料はかなり貴重だと思います。
■
HTML generated by 3bmd in LispWorks 7.0.0
Posted 2020-12-24 15:00:00 GMT
allocate-instance Advent Calendar 2020 25日目の記事です。
アドベントカレンダーも参加者が少ないと最後に総括エントリーという必殺技を使ってエントリーを埋めることができます。
オブジェクトのアロケーションなら原理は簡単なので、ニッチすぎるアドベントカレンダーでも参加者もそこそこいたりするかなと思いましたが、結局一人で完走ということになりました。
なんとなくですが、最後まで何故allocate-instance
に着目したのかが判らない、という感じだったかもしれません。
私としては、アドベントカレンダー開幕で書いたとおり、スロットストレージにベクタ以外が使うというアイデアがあまり活用されていないところに着目したわけですが、活用されないだけあったアイデアであることを証明してしまったのかもしれません。
また、Common Lispではアロケートより後のプロトコルでできることが強力で、オブジェクトのIDとクラス情報だけあれば後はどうとでもできるのがallocate-instance
をいじる意義を低下させている気がします。
実際の活用例でいうと、オブジェクトの永続化あたりでallocate-instance
の話も少し出てきたりもしますが、allocate-instance
は基本的にオブジェクトIDの割り付け程度かなと思います。
振り返ってみると、allocate-instance
のinitargsを活用する例を追求しなかったのが若干悔まれます。
といっても、allocate-instance
にストレージの種類を伝える程度な気はしますが。
あとはハッシュテーブルのストレージがベクタであることを利用して、先頭をオブジェクトのストレージにして、残りをハッシュテーブルにするというのを考えましたが、別に一本にする必要もないかなというところです。
他にも、どうしようもないアイデアはありますが、そのうち試してブログに書いてみたいと思います。
さて、次にアドベントカレンダーを企画した際にはさらにニッチなところを攻めたいと思います。
次回までごきげんよう!
■
HTML generated by 3bmd in LispWorks 7.0.0
Posted 2020-12-23 18:10:10 GMT
allocate-instance Advent Calendar 2020 24日目の記事です。
引き続き、allocate-instance
が関係してくるInstance Structure Protocol(ISP)周りを中心に色々なCLOS MOP系の処理系で確認していきたいと思います。
今回は、Tiny CLOSのallocate-instance
周りを眺めます。
Tiny CLOSは、CLOS風のオブジェクトシステムを採用しているSchemeではTiny CLOSかその派生が採用されていることが多いようです。
作者が、CLOSおよびに参照実装であったPortable CommonLoopsに深く関わり、AMOPの著者でもあるKiczales先生というのもポイントが高いかもしれません。
大体の構成は、先日紹介したKiczales先生が1990年代前半に考えていた新しいInstance Structure Protocolの構成と同一のようです。
allocate-instance
make
initialize
Tiny CLOSでのインスタンスの構成ですが、instance-tag
、class
という先頭二つの部分と後半のスロット要素からなるベクタ表現されています。ベクタにしたかったというより、1992年のSchemeに構造体がないので、こういう構成にしたのかもしれません。
CLOSの実装でいうwrapper部は、そのままクラスメタオブジェクトの表現です。
ベクタ一本の表現なので、スロット部のベクタだけ取り出すようなことはなく、基本的に先頭2つのオフセットでアクセスする感じになります。
なお、Tiny CLOSはScheme(Common Lisp版もある)の実装なので、allocate-instance
の中身をいじれますが、OOPSが融合している処理系ではC等の実装言語レベルに直結していることが多いようで、安直に下請け関数がアロケートするスロットストレージをベクタからハッシュにすげかえてみる、等のことはやりにくいようです。
なお、Common LispでもECL等がそういう実装になっています。
slot-ref
slot-set!
lookup-slot-info
compute-getter-and-setter
スロットストレージの並び順は、CLと同様compute-slots
で確定するようです。
スロットの名前と位置の変換は、compute-getter-and-setter
でゲッターとセッターのクロージャー生成する際にクロージャーの中に位置が埋め込まれる方式です。
slot-ref
内で、lookup-slot-info
によりこのgetters-n-setters情報からゲッター/セッターを取り出してオブジェクトに適用、という流れになっています。
Tiny CLOSは、スロット名とスロット位置変換の仕組みとして、位置情報を含んだゲッター/セッターをクラスメタオブジェクト内にまとめて管理、という方式のようです。
CLOS系OOPSそれぞれ微妙に違いますが、位置情報をクロージャーに閉じ込める方式の方が若干速いかなとは思います。
アクセサを定義すれば、標準のケースでは最適化された場合、スロットストレージへの直接アクセスになると思うので、Common Lispでは速度にこだわるなら、slot-value
は使うなというところなのでしょうか。この辺りどこかでそんな文献読んだことがある気がするのですが思い出せない……。
■
HTML generated by 3bmd in LispWorks 7.0.0
Posted 2020-12-23 02:46:42 GMT
allocate-instance Advent Calendar 2020 23日目の記事です。
引き続き、allocate-instance
が関係してくるInstance Structure Protocol(ISP)周りを中心に色々なCLOS MOP系の処理系で確認していきたいと思います。
今回は、TELOSのallocate-instance
周りを眺めます。
TELOSは、EuLispのオブジェクトシステムで、EuLispもCommon Lispより簡潔な作りを指向しています。
EuLispとCommon Lispとの目立った違いは、EuLispがLisp1であることで、クラスの表記も他のシンボルと競合しないように、<foo>
のように表記する慣習があります。
ちなみに、ISLISPは、EuLispの影響下にあるので、Lisp2なのに<foo>
と表記します。
allocate
make
initialize
まず、インスタンスの構成ですが、class
、slots
という二つの部分からなるprimitive-class
構造体で表現されています。CLOSの実装でいうとwrapper部は、そのままクラスメタオブジェクトで表現されています。
インスタンスのストレージは標準でベクタ。
スロットストレージへは、primitive-class-slots
、wrapperの取り出しは、primitive-class-of
で行えますが、クラスそのものなので別に必要ないかも?
CLOS MOPと異なる点としては、クラスがスロット数を保持するclass-instance-length
を有します。
slot-value
(setf slot-value)
primitive-slot-value
(setf primitive-slot-value)
slot-value-using-slot
find-slot
slot-reader
slot-writer
compute-slots
primitive-ref
setter-primitive-ref
primitive-find-slot-position
スロットストレージの並び順は、CLと同様compute-slots
で確定するようです。
CLOSのslot-definition
に相当する<slot>
クラスがあり、class-slots
に格納されていますが、スロットの位置を計算するには、primitive-find-slot-position
を使います。
特に最適化はされておらず、class-slots
の中を順に探しているだけです。
(primitive-find-slot-position <simple-class> 'c (class-slots <foo>) 0)
→ 2
CLのstandard-instance-access
に相当するものは、primitive-ref
になります。
slot-value
の中で、標準のメタクラスかどうかを判定するようになっており、標準であれば、slot-value-using-slot
が、スロットのslot-reader
/writer
を呼び出しを値を取り出します。
slot-reader
は最終的にはprimitive-ref
を呼びます。
slot-value
は
(slot-value-using-slot (find-slot (class-of obj) name)
obj)
と展開されるので、何もしなければ、find-slot
が探索してスロット名→スロット位置の変換をするので遅いですが総称関数なので(find-slot obj 'a)
等を特定化して定義してやれば高速化はできそうです。
CLOS系OOPSでスロット名からスロットの位置を割り出す方法にそれぞれ色々と工夫があるようです。
アクセサに比べてslot-value
の方がプリミティブな雰囲気があり、速度もアクセサより速そうな印象がありますが、MOPの仕組みからして、スロットの位置割り出しが計算済みの分アクセサの方が速いですね。
■
HTML generated by 3bmd in LispWorks 7.0.0
Posted 2020-12-21 20:53:44 GMT
allocate-instance Advent Calendar 2020 22日目の記事です。
前回に引き続き、allocate-instance
が関係してくるInstance Structure Protocol(ISP)周りを中心に色々なCLOS MOP系の処理系で確認していきたいと思います。
今回は、MCSのallocate-instance
周りを眺めます。
まず、MCSですが、The Meta Class Systemの略で、ObjVlispの流れをくみつつCLOSとの互換性も高いシステムです。
MOPも大体同じような構成になっていますが、MCSの方がシンプルでありつつ抽象クラスやmixinクラス等も用意されていて色々整理されているようにも見えます。
allocate-instance
make-instance
initialize-instance
change-class
change-class-using-class
さてまず、インスタンスの構成ですが、isit
、slots
という二つの部分からなる構造体で表現されています。isit
というのはCLOSの実装でいうとwrapperですが、クラスメタオブジェクトを一つ含んだリストで表現されていて、wrapperとclassのオブジェクトがほぼ一本化されています。
インスタンスのストレージは標準ではベクタです。
スロットストレージへは、mcs%-slots
、wrapperの取り出しは、mcs%-isit
で行えます。
CLOS MOPと異なる点として、スロット名から、スロットストレージの位置を割り出す関数がクラスの中に格納されている点で、標準では、general-slot-position
関数が、class-slot-accessor
に格納されています。
slot-exists-p
slot-boundp
slot-makunbound
slot-value
mcs%slot-value
(setf slot-value)
mcs%set-slot-value
mcs%set-slot-value-low
compute-slots
mcs%local-slot-indexed
mcs%local-slot-indexed-low
スロットストレージの並び順は、CLと同様compute-slots
で確定するようです。
スロットの位置を計算する関数がクラスに含まれているので、slot-definition-location
は存在せず、%slot-location-of
が位置計算用関数を呼び出して計算します。
CLのstandard-instance-access
に相当するものは、mcs%local-slot-indexed-low
になりますが、slot unboundのサポートありのmcs%local-slot-indexed
も用意されています。
CLと違ってslot-value
はマクロになっており、slot-value-using-
系メソッドはなく、mcs%slot-value
に展開か、メソッド内部での最適化として、mcs%local-slot-indexed-low
を用いたアクセスになるよう展開するようです(なお実装ではそこまで最適化されていない)
mcs%slot-value
は、上述のスロット位置を名前から割り出す関数を呼び出して、インスタンスのストレージを添字でアクセスします。
なお、-low
が掴ないものは、slot unboundをサポートせずslot missingのみサポートします。
MCSではslot-value-using-class
が省略されていますが、その代わりにクラスがスロット名→ストレージの位置の変換関数を保持するというのが面白いと思いました。
この辺りの方式の違いをそのうち比較してみたいところです。
■
HTML generated by 3bmd in LispWorks 7.0.0
Posted 2020-12-20 17:40:41 GMT
allocate-instance Advent Calendar 2020 21日目の記事です。
ネタ切れも甚しいのでallocate-instance
が関係してくるInstance Structure Protocol(ISP)周りを中心に色々なCLOS MOP系の処理系で確認していきたいと思います。
まずは、本家Common Lispです。
slot-exists-p
slot-boundp
slot-boundp-using-class
slot-makunbound
slot-makunbound-using-class
slot-value
slot-value-using-class
(setf slot-value)
(setf slot-value-using-class)
compute-slots :around
slot-definition-location
standard-instance-access
funcallable-standard-class
funcallable-standard-instance-access
ISPで列挙されているのは、スロットアクセス系の関数/メソッドになり、allocate-instance
等は埒外です。
ます、関係してくる順序としては、スロットストレージの並び順がcompute-slots :around
で確定し、インスタンスのストレージとスロットの位置が確定します。それに伴なって、slot-definition-location
の値も決まり、standard-instance-access
でのアクセスの添字も決まる、という感じです。
slot-value
の下請けが、slot-value-using-class
で、更に下請けが、standard-instance-access
とされていますが、処理系によっては、slot-value
からインスタンスのストレージに直通の場合もあるようです(LispWorksでスロットアクセスの最適化が有効になっている場合など)
standard-instance-access
は、インスタンスのストレージに添字でアクセスする低レベルの関数ですが、standard-
と付いていることから判るように、standard-object
を想定しています。
standard-object
とはインスタンスのストレージ構成が違う場合には使えないと考えた方が良いでしょう。
class-finalized-p
finalize-inheritance
継承関係の確定のプロトコルですが、インスタンスがアロケートされる前に確定している必要があるとされており、allocate-instance
が呼ばれる前にclass-finalized-p
で調べて確定していなければ、finalize-inheritance
が呼ばれるとされています。
この判定のタイミングですが、Robert Strandh先生によれば、allocate-instance
の引数のinitargs
は確定後の計算結果になるので呼ばれる前に確定している筈としていてPCLでも、make-instance
がfinalize-inheritance
を呼んでいると註記していますが、PCL系であるSBCL等では、allocate-instance
の中で呼ばれています(ensure-class-finalized
経由)。
大抵の処理系では、finalize-inheritance
を呼んでいるので、実際のところ必須なのかそうでないのか。ちなみに自分はStrandh先生を信じて今回のアドベントカレンダでは呼ばないスタイルで通しました。
make-instance
shared-initialize
change-class
update-instance-for-different-class
update-instance-for-redefined-class
あたりですが、インスタンスストレージの構成が標準と異なる場合は、初期化/再初期化の手続を別途記述する必要が出てきます。
また、標準的な構成とカスタマイズしたものとでchange-class
する場合は、インスタンスストレージの確保も別途記述する必要も出てきます。
大抵は、上記メソッドと標準メソッドコンビネーションでどうにかできますが、もしかしたら、標準から外れる場合は、Dependent maintenance protocolでストレージ形式の修正をしたりした方が良いのかもしれません。
関係プロトコルをざっと眺めてみましたが、allocate-instance
をカスタマイズする例がほとんどないですね。
思えば、allocate-instance
のカスタマイズは、大抵は初期の文献に見付かるのですが何故なのか(共通仕様をまとめるのが難しいとか?)
■
HTML generated by 3bmd in LispWorks 7.0.0
Posted 2020-12-19 21:12:58 GMT
allocate-instance Advent Calendar 2020 20日目の記事です。
MOPの応用として、仮想的なアロケーションの場所を指定する例があります。
大抵は、スロットの:allocation
指定で、:virtual
等を指定するという感じですが、allocate-instance
内でどうにかできないか考えてみます。
allocate-instance
内でどうにかするという縛りなので、スロットストレージに関数を詰めて呼び出すという作戦で実行時にデータを取得できるようにしてみます。
(defpackage "f53e7180-1934-50c0-9c43-7c6a79b7a5e2"
(:use c2cl slotted-objects))
(cl:in-package "f53e7180-1934-50c0-9c43-7c6a79b7a5e2")
(defclass virtual-class (slotted-class)
())
(defclass virtual-object (slotted-object)
()
(:metaclass virtual-class))
(defmethod allocate-slot-storage ((class virtual-class) size initial-value)
(let ((storage (make-sequence 'vector size))
(fctns (make-sequence 'vector size)))
(dotimes (index size fctns)
(setf (elt fctns index)
(let ((index index))
(lambda (op value)
(case op
(:get (elt storage index))
(:set (setf (elt storage index) value)))))))))
(defmethod slot-value-using-class ((class virtual-class) instance (slotd slot-definition))
(funcall (elt (instance-slots instance) (slot-definition-location slotd))
:get 'ignore))
(defmethod (setf slot-value-using-class) (value (class virtual-class) instance (slotd slot-definition))
(funcall (elt (instance-slots instance) (slot-definition-location slotd))
:set value))
微妙に使い勝手が悪いですが、とりあえず下記のように書けます。 スロット読み出しが発生すると、スロットストレージに詰められたクロージャーが呼ばれ、値を計算します。
(defclass 56nyan (virtual-object)
((name)
(code :initarg :item-code)
(price))
(:metaclass virtual-class))
(defun get-56nyan-page (code)
(babel:octets-to-string
(drakma:http-request (format nil "https://www.56nyan.com/fs/goronyan/~A" code)
:force-binary T)
:encoding :cp932))
(defmethod allocate-slot-storage ((class (eql (find-class '56nyan))) size initial-value)
(let* ((fcns (call-next-method))
(slotds (class-slots class)))
(labels ((name->loc (name)
(slot-definition-location (find name slotds :key #'slot-definition-name)))
(slot-fctn (name)
(elt fcns (name->loc name)))
((setf slot-fctn) (fctn name)
(setf (elt fcns (name->loc name)) fctn))
(code ()
(funcall (elt fcns (name->loc 'code)) :get nil)))
(setf (slot-fctn 'name)
(lambda (op value)
(declare (ignore value))
(case op
(:get (plump:attribute (elt (clss:select "meta[property=og:title]" (plump:parse (get-56nyan-page (code)))) 0)
"content"))
(:set nil))))
(setf (slot-fctn 'price)
(lambda (op value)
(declare (ignore value))
(case op
(:get (plump:text (elt (clss:select ".itemPrice" (plump:parse (get-56nyan-page (code)))) 0)))
(:set nil)))))
fcns))
allocate-instance
レベルで実現する意義を考えてみましたが、change-class
しても値がスムースに移行可能なのではないでしょうか。
(defclass 56nyan-static ()
((name)
(code :initarg :item-code)
(price)))
(let ((obj (make-instance '56nyan :code "7e003-001")))
(change-class obj '56nyan-static)
(describe obj))
⇒
#<56nyan-static 42000B7D3B> is a 56nyan-static
name "アカナ グラスランド キャット 340g (42341) 【正規品】"
code "7e003-001"
price "1,093円"
そもそも、Common Lispの場合、スロットのリーダ/ライタでメソッドコンビネーションが使えるので、Virtual Slotsのようなものはあまり必要ないような気もします。
ちなみに、今回のchange-class
の用法ですが、Common Lisp Proメーリングリストのchange-class
の議論で、とりあえずデータをロードして、change-class
で正規化するのが便利、という用例紹介をちょっと真似してみました(今回は正規化してませんが)
自分も以前、change-class
の使い方として試してみたことがあった気がしますが、こういう応用も無くはないのかなと思います。
■
HTML generated by 3bmd in LispWorks 7.0.0
Posted 2020-12-19 10:56:17 GMT
allocate-instance Advent Calendar 2020 19日目の記事です。
以前、LW Dylan TranslatorというLispWorks上のDylanのシミュレーターのソースコードを眺めた時に、内部関数を使ってスロットをnil
でfill
していたのが印象に残っていたのですが、未束縛スロットの扱いが面倒なので、とりあえず:initform nil
しておくというコードもたまに見掛けたりもするので、そこそこ常套句なのかもしれません。
ということで、今回は、allocate-instance
でスロットのデフォルト値をnil
にしてみましょう。
(defpackage "cafc9fa3-5687-537e-839a-424c9b589974"
(:use c2cl slotted-objects))(cl:in-package "cafc9fa3-5687-537e-839a-424c9b589974")
(defclass default-to-nil-class (slotted-class)
())
(defmethod allocate-instance :around ((class default-to-nil-class) &key &allow-other-keys)
(let ((instance (call-next-method)))
(fill (instance-slots instance) nil)
instance))
これで下記のような動作になります。
(defclass foo (slotted-object)
((a :initform 'a)
b
c)
(:metaclass default-to-nil-class))(describe (make-instance 'foo))
⇒
#<foo 40203E71A3> is a foo
a a
b nil
c nil
当然ですが、明示的に設定したnil
なのか、暗黙のnil
なのか区別が付かなくなるので、その辺りは注意です。
そう考えると、取扱が面倒ではありますが未束縛値で埋めておくというのは妥当ではありますね。
■
HTML generated by 3bmd in LispWorks 7.0.0
Posted 2020-12-17 19:59:09 GMT
allocate-instance Advent Calendar 2020 18日目の記事です。
これまで、スロットのストレージを二次元配列にしてみたり、構造体にしてみたりと妙なことを試してきましたが、標準的なスロットストレージを持つオブジェクト(standard-object
等)とのchange-class
での相互運用を考慮した場合、スロットストレージも伸展や縮退をサポートする必要があります。
この辺りを司るのは、change-class
の下請けのupdate-instance-for-different-class
になりますが、滅多に使わない機能というか、私個人もメソッド定義する必要に遭遇したことがありません。
それはさておき、とりあえずの例として、スロットストレージが拡張された、a-class
、b-class
と、標準構成の三つのクラスを定義したとします。
(defpackage "fd84d50c-3573-5d37-aed2-73e7d98bb52d"
(:use c2cl slotted-objects))
(cl:in-package "fd84d50c-3573-5d37-aed2-73e7d98bb52d")
(defclass a-class (slotted-class)
())
(defclass a-object (slotted-object)
()
(:metaclass a-class))
(defclass b-class (slotted-class)
())
(defclass b-object (slotted-object)
()
(:metaclass a-class))
(defmethod allocate-instance ((class a-class) &key &allow-other-keys)
(allocate-slotted-instance (class-wrapper class)
(make-array `(2 ,(length (class-slots class)))
:initial-element (make-unbound-marker))))
(defmethod allocate-instance ((class b-class) &key &allow-other-keys)
(allocate-slotted-instance (class-wrapper class)
(make-array `(4 ,(length (class-slots class)))
:initial-element (make-unbound-marker))))
(defmethod slot-value-using-class ((class a-class) instance (slotd slot-definition))
(aref (instance-slots instance) 0 (slot-definition-location slotd)))
(defmethod (setf slot-value-using-class) (value (class a-class) instance (slotd slot-definition))
(setf (aref (instance-slots instance) 0 (slot-definition-location slotd))
value))
(defmethod slot-value-using-class ((class b-class) instance (slotd slot-definition))
(aref (instance-slots instance) 1 (slot-definition-location slotd)))
(defmethod (setf slot-value-using-class) (value (class b-class) instance (slotd slot-definition))
(setf (aref (instance-slots instance) 1 (slot-definition-location slotd))
value))
とりあえず、インスタンスのクラスを変更することがなければ、別段このままでも問題ありません。
(defclass foo (a-object)
((a :initform 0)
(b :initform 1)
(c :initform 2))
(:metaclass a-class))
(defclass bar (b-object)
((a :initform 4)
(b :initform 5)
(c :initform 6))
(:metaclass b-class))
(defclass baz (standard-object)
((a :initform 7)
(b :initform 8)
(c :initform 9)))
(progn
(describe (make-instance 'foo))
(describe (make-instance 'bar))
(describe (make-instance 'baz)))
#<foo 402005E1FB> is a foo
a 0
b 1
c 2
#<bar 402005E59B> is a bar
a 4
b 5
c 6
#<baz 402005E8D3> is a baz
a 7
b 8
c 9
しかし、change-class
するとなると、インスタンスのストレージが違うので、違いを吸収するメソッドをupdate-instance-for-different-class
に定義してやる必要があります。
standard-object
にchange-class
する分には拡張したスロットストレージが削られることになるので、特に難しいことはありません。
(defmethod update-instance-for-different-class
((pre slotted-object) (cur standard-object) &key &allow-other-keys)
(dolist (slotd (class-slots (class-of cur)))
(let ((slot-name (slot-definition-name slotd)))
(when (slot-exists-p pre slot-name)
(setf (slot-value cur slot-name)
(slot-value pre slot-name))))))
standard-object
から拡張したものにchange-class
する分には拡張したスロットストレージを使うことになるので、ストレージのアロケートをして、新しいストレージ側に値をコピーする必要があります。
ストレージのアロケーションをメタクラスで切り替えたいとすると、allocate-instance
の下請けとして共通のメソッドを定義するのが良さそうです。
今回は、allocate-slot-storage
というメソッドを定義して使うことにしてみました。
(defgeneric allocate-slot-storage (class size initial-value))
(defmethod allocate-slot-storage ((class a-class) size initial-value)
(make-array `(2 ,size) :initial-element initial-value))
(defmethod allocate-slot-storage ((class b-class) size initial-value)
(make-array `(4 ,size) :initial-element initial-value))
;; ... allocate-instanceの書き換えは略 ...
(defmethod update-instance-for-different-class
((pre standard-object) (cur slotted-object) &key &allow-other-keys)
(let ((cur-class (class-of cur)))
(setf (instance-slots cur)
(allocate-slot-storage cur-class
(length (class-slots cur-class))
(make-unbound-marker)))
(dolist (slotd (class-slots cur-class))
(let ((slot-name (slot-definition-name slotd)))
(when (slot-exists-p pre slot-name)
(setf (slot-value cur slot-name)
(slot-value pre slot-name)))))))
標準→拡張と内容は同じなのですが、このパターンも用意しておく必要があります。
(defmethod update-instance-for-different-class
((pre slotted-object) (cur slotted-object) &key &allow-other-keys)
(let ((cur-class (class-of cur)))
(setf (instance-slots cur)
(allocate-slot-storage cur-class
(length (class-slots cur-class))
(make-unbound-marker)))
(dolist (slotd (class-slots cur-class))
(let ((slot-name (slot-definition-name slotd)))
(when (slot-exists-p pre slot-name)
(setf (slot-value cur slot-name)
(slot-value pre slot-name)))))))
なお、基本的に拡張への移行は、新しくインスタンスのストレージを確保する部分だけなので、update-instance-for-different-class
の:before
メソッドで、ストレージの置き換えを定義するだけで良いのかもしれません。
このあたりの参考資料が見付けられないので良く分からず……。
以上で相互変換が可能になります。
(progn
(progn
;; slotted-object → standard-object
(describe (change-class (make-instance 'foo) 'baz))
(describe (change-class (make-instance 'bar) 'baz))
(describe (change-class (make-instance 'baz) 'baz)))
(progn
;; standard-object → slotted-object
(describe (change-class (make-instance 'bar) 'foo))
(describe (change-class (make-instance 'baz) 'foo)))
(progn
;; slotted-object → slotted-object
(describe (change-class (make-instance 'foo) 'bar))
(describe (change-class (make-instance 'bar) 'bar))))#<baz 402005EC43> is a baz
a 0
b 1
c 2
#<baz 402005F163> is a baz
a 4
b 5
c 6
#<baz 402005F64B> is a baz
a 7
b 8
c 9
#<foo 402005FB33> is a foo
a 4
b 5
c 6
#<foo 4020060073> is a foo
a 7
b 8
c 9
#<bar 4020060583> is a bar
a 0
b 1
c 2
#<bar 4020230B2B> is a bar
a 4
b 5
c 6
allocate-
なんとかのメソッドを上手い感じに命名してまとめたいところなのですが難しい……。
一応今回は、Closetteを参考に命名してみました。
■
HTML generated by 3bmd in LispWorks 7.0.0
Posted 2020-12-16 23:30:16 GMT
allocate-instance Advent Calendar 2020 17日目の記事です。
完全なるネタ切れですが、今回はアンドゥ可能なスロットを実現してみたいと思います。
以前に紹介した履歴付きスロットと似たような感じですが、こちらは限定された回数スロットの状態をアンドゥできることをメインに考えます!
仕様としては、どこかのスロットが変更された場合、スロット全部を保存することにします。
内部では、16セットのスロットを二次元配列で表現したものと現在の位置を、オブジェクトのストレージとします。
また、ユーティリティとしてundo-slots
とreset-slots
も用意してみます。
(defclass foo (undoable-slots-object)
((a :initform 0)
(b :initform 1)
(c :initform 2))
(:metaclass undoable-slots-class))
(defparameter *foo* (make-instance 'foo))
(describe *foo*)
#<foo 4020002193> is a foo
a 0
b 1
c 2
;; 乱数を任意のスロットに代入 x 15回
(dotimes (i 15)
(setf (slot-value *foo* (elt #(a b c) (mod i 3)))
(random 1000)))
;; 15回状態を戻す
(dotimes (i 15)
(describe (undo-slots *foo*)))
#<foo 4020002193> is a foo
a 930
b 743
c 626
#<foo 4020002193> is a foo
a 930
b 365
c 626
#<foo 4020002193> is a foo
a 571
b 365
c 626
#<foo 4020002193> is a foo
a 571
b 365
c 695
#<foo 4020002193> is a foo
a 571
b 92
c 695
#<foo 4020002193> is a foo
a 895
b 92
c 695
#<foo 4020002193> is a foo
a 895
b 92
c 905
#<foo 4020002193> is a foo
a 895
b 139
c 905
#<foo 4020002193> is a foo
a 841
b 139
c 905
#<foo 4020002193> is a foo
a 841
b 139
c 859
#<foo 4020002193> is a foo
a 841
b 342
c 859
#<foo 4020002193> is a foo
a 10
b 342
c 859
#<foo 4020002193> is a foo
a 10
b 342
c 2
#<foo 4020002193> is a foo
a 10
b 1
c 2
#<foo 4020002193> is a foo
a 0
b 1
c 2
nil
(defpackage "955b5b51-173a-50c3-82f6-7add63d9b29a"
(:use c2cl slotted-objects))
(cl:in-package "955b5b51-173a-50c3-82f6-7add63d9b29a")
(defconstant undo-limit 16.)
(defclass undoable-slots-storage ()
((slots :initarg :slots :accessor undoable-slots-storage-slots)
(history# :initform 0 :accessor undoable-slots-storage-history#)))
(defclass undoable-slots-class (slotted-class)
()
(:metaclass standard-class))
(defclass undoable-slots-object (slotted-object)
()
(:metaclass undoable-slots-class))
(defmethod allocate-instance ((class undoable-slots-class) &key &allow-other-keys)
(allocate-slotted-instance (class-wrapper class)
(make-instance 'undoable-slots-storage
:slots (make-array `(,undo-limit ,(length (class-slots class)))
:initial-element (make-unbound-marker)))))
(defclass undoable-slots-object (slotted-object)
()
(:metaclass undoable-slots-class))
(defmethod slot-value-using-class ((class undoable-slots-class) instance (slotd slot-definition))
(let ((storage (instance-slots instance)))
(aref (undoable-slots-storage-slots storage)
(undoable-slots-storage-history# storage)
(slot-definition-location slotd))))
(defmethod (setf slot-value-using-class) (value (class undoable-slots-class) instance (slotd slot-definition))
(let* ((storage (instance-slots instance))
(curpos (mod (undoable-slots-storage-history# storage) undo-limit))
(loc (slot-definition-location slotd)))
(flet ((backup ()
(dotimes (idx (length (class-slots class)))
(let ((new (mod (1+ curpos) undo-limit))
(old curpos))
(setf (aref (undoable-slots-storage-slots storage) new idx)
(aref (undoable-slots-storage-slots storage) old idx)))))
(incpos ()
(setf (undoable-slots-storage-history# storage)
(mod (1+ curpos) undo-limit))))
(backup)
(incpos)
(setf (aref (undoable-slots-storage-slots storage)
(undoable-slots-storage-history# storage)
loc)
value))))
(defmethod initialize-slot-from-initarg ((class undoable-slots-class) instance slotd initargs)
(let ((slot-initargs (slot-definition-initargs slotd)))
(loop :for (initarg value) :on initargs :by #'cddr
:do (when (member initarg slot-initargs)
(let ((storage (instance-slots instance)))
(setf (aref (undoable-slots-storage-slots storage)
(undoable-slots-storage-history# storage)
(slot-definition-location slotd))
value))
(return T)))))
(defmethod initialize-slot-from-initfunction ((class undoable-slots-class) instance slotd)
(let ((initfun (slot-definition-initfunction slotd)))
(unless (not initfun)
(let ((storage (instance-slots instance)))
(setf (aref (undoable-slots-storage-slots storage)
(undoable-slots-storage-history# storage)
(slot-definition-location slotd))
(funcall initfun))))))
(defun undo-slots (obj)
(let ((storage (instance-slots obj)))
(setf (undoable-slots-storage-history# storage)
(mod (1- (undoable-slots-storage-history# storage)) undo-limit)))
obj)
(defun reset-slots (obj)
(let ((storage (instance-slots obj)))
(setf (undoable-slots-storage-history# storage)
0))
obj)
■
HTML generated by 3bmd in LispWorks 7.0.0
Posted 2020-12-15 19:11:45 GMT
allocate-instance Advent Calendar 2020 16日目の記事です。
何かallocate-instance
ネタがないか、隠しスロットの応用がないか、と探しまわっていますが、そういえば、defstruct
にはスロットの:read-only
オプションがあるのに、defclass
にはないなと思ったので、隠しスロットで実装してみました。
(defclass foo (acl-slots-object)
((a :initform 0 :read-only T :accessor foo-a)
(b :initform 1 :read-only nil)
(c :initform 2 :read-only T))
(:metaclass acl-slots-class))
(mapcar #'slot-definition-read-only-p (class-slots (find-class 'foo)))
→ (t nil t)
(let ((obj (make-instance 'foo)))
(with-slots (a b c) obj
(list a b c)))
→ (0 1 2)
(let ((obj (make-instance 'foo)))
(with-slots (a b c) obj
(setq b 100)
(list a b c)))
→ (0 100 2)
(let ((obj (make-instance 'foo)))
(with-slots (a b c) obj
(setq a 100)
(list a b c)))
!!! Cannot assign to read only slot a of #<foo 40201234EB>
(let ((obj (make-instance 'foo)))
(setf (foo-a obj) 8))
!!! Cannot assign to read only slot a of #<foo 402020F6C3>
ここまで書いて試してみて、クラスの属性としてスロットにリードオンリー属性を付けるだけならインスタンスに隠しスロットを付ける意味がないという致命的なことに気付いてしまったので、インスタンス生成時にも個別に指定できるようにしてみました。
(make-instance 'bar :read-onlys '(:b))
のように:read-onlys
引数で該当するスロットの:initarg
を指定します。
(defclass bar (acl-slots-object)
((a :read-only T :initform 0 :initarg :a :reader bar-a)
(b :read-only nil :initform 1 :initarg :b :accessor bar-b)
(c :read-only T :initform 2 :initarg :c))
(:metaclass acl-slots-class))
(let ((obj (make-instance 'bar)))
(setf (bar-b obj) 42))
→ 42
(let ((obj (make-instance 'bar :read-onlys '(:b))))
(setf (bar-b obj) 42))
!!! Cannot assign to read only slot b of #<bar 402009983B>
あと九個もネタが捻り出せない。
(defpackage "3d5973f5-7755-5daf-a825-d623a03a4d53" (:use c2cl slotted-objects))
(cl:in-package "3d5973f5-7755-5daf-a825-d623a03a4d53")
(defconstant slot-dim 0)
(defconstant acl-dim 1)
(defclass acl-slots-class (slotted-class)
()
(:metaclass standard-class))
(defmethod allocate-instance ((class acl-slots-class) &rest initargs)
(allocate-slotted-instance (class-wrapper class)
(make-array `(2 ,(length (class-slots class)))
:initial-element (make-unbound-marker))))
(defclass acl-slots-object (slotted-object)
()
(:metaclass acl-slots-class))
(defmethod slot-value-using-class ((class acl-slots-class) instance (slotd slot-definition))
(aref (instance-slots instance)
slot-dim
(slot-definition-location slotd)))
(defmethod (setf slot-value-using-class) (value (class acl-slots-class) instance (slotd slot-definition))
(let* ((slots (instance-slots instance))
(loc (slot-definition-location slotd)))
(when (aref slots acl-dim loc)
(error "Cannot assign to read only slot ~S of ~S" (slot-definition-name slotd) instance))
(setf (aref slots slot-dim loc) value)))
(defun slot-read-only-p (instance slot-name)
(aref (instance-slots instance)
acl-dim
(slot-definition-location
(find slot-name (class-slots (class-of instance))
:key #'slot-definition-name))))
(defclass acl-slots-slot-definition (standard-slot-definition)
((attributes :initform nil
:initarg :read-only
:accessor slot-definition-read-only-p)))
(defclass direct-acl-slots-slot-definition (standard-direct-slot-definition acl-slots-slot-definition)
())
(defmethod direct-slot-definition-class ((class acl-slots-class) &rest initargs)
(find-class 'direct-acl-slots-slot-definition))
(defclass effective-acl-slots-slot-definition (standard-effective-slot-definition acl-slots-slot-definition)
())
(defmethod effective-slot-definition-class ((class acl-slots-class) &rest initargs)
(find-class 'effective-acl-slots-slot-definition))
(defmethod compute-effective-slot-definition ((class acl-slots-class)
name
direct-slot-definitions)
(let ((effective-slotd (call-next-method)))
(dolist (slotd direct-slot-definitions)
(when (typep slotd 'acl-slots-slot-definition)
(setf (slot-definition-read-only-p effective-slotd)
(slot-definition-read-only-p slotd))
(return)))
effective-slotd))
(defmethod initialize-slot-from-initarg ((class acl-slots-class) instance slotd initargs)
(let ((slot-initargs (slot-definition-initargs slotd)))
(loop :for (initarg value) :on initargs :by #'cddr
:do (when (member initarg slot-initargs)
(setf (aref (instance-slots instance) slot-dim (slot-definition-location slotd))
value)
(return T)))))
(defmethod initialize-slot-from-initfunction ((class acl-slots-class) instance slotd)
(let ((initfun (slot-definition-initfunction slotd)))
(unless (not initfun)
(setf (aref (instance-slots instance) slot-dim (slot-definition-location slotd))
(funcall initfun)))))
(defmethod shared-initialize :after ((instance acl-slots-object) slot-names &key read-onlys &allow-other-keys)
(let* ((class (class-of instance))
(slots (class-slots class)))
(dolist (s slots)
(setf (aref (instance-slots instance) acl-dim (slot-definition-location s))
(slot-definition-read-only-p s))
(when (intersection read-onlys (slot-definition-initargs s))
(setf (aref (instance-slots instance) acl-dim (slot-definition-location s))
T)))))
■
HTML generated by 3bmd in LispWorks 7.0.0
Posted 2020-12-14 15:00:00 GMT
allocate-instance Advent Calendar 2020 15日目の記事です。
Java等では、インスタンス化不可な抽象クラスを定義したり、抽象クラスでメソッドの実装を強制したりできますが、Common Lispだとmixinクラスのインスタンス化はマナーとしてしない程度です。さらに、メソッドの実装を強制については、そもそも総称関数なのでクラスが統治の単位でもありません。
また、オブジェクト指向システムがとても動的なので、チェックがコンパイル時ではなく、実行時によってしまうというのもいま一つなところです。
とはいえ、MOPのインスタンス生成プロトコルにフックを掛けてインスタンス化を抑止することは可能で、そのフックのポイントがallocate-instance
からclass-prototype
あたりになります。
allocate-instance
でメソッド実装の強制まあ、allocate-instance
にメソッド実装の強制という責務はないのですが、インスタンスが生成されるポイントなのでフックを掛けるのがこのあたりになってしまいます。
とりあえず:abstract-methods
オプションにメソッドを指定してクラスに該当するメソッドが実装されているかをチェックするのをallocate-instance :before
に仕掛けます。
(defpackage "0cbdbd51-5be8-57c3-9b14-9473f74c8a61" (:use c2cl))
(cl:in-package "0cbdbd51-5be8-57c3-9b14-9473f74c8a61")
(defclass enforcing-abstract-methods-class (standard-class)
((abstract-methods :initform '() :accessor class-abstract-methods)
(direct-abstract-methods :initform '()
:reader class-direct-abstract-methods
:initarg :abstract-methods)))
(defmethod finalize-inheritance :after ((class enforcing-abstract-methods-class))
(setf (class-abstract-methods class)
(remove-duplicates
(loop :for c :in (class-precedence-list class)
:when (typep c 'enforcing-abstract-methods-class)
:append (mapcar #'eval (class-direct-abstract-methods c)))
:from-end T)))
(defmethod allocate-instance :before ((class enforcing-abstract-methods-class)
&key &allow-other-keys)
(dolist (gf (class-abstract-methods class))
(or (some (lambda (x)
(find class (method-specializers x)))
(generic-function-methods gf))
(error "Can't instantiate abstract class ~S with abstract methods ~S."
class
gf))))
ついでに、インスタンス化不可なabstract-class
も定義します。
こちらは、以前ブログで紹介したものになります。
一応仕組みを解説すると、abstract-class
を:metaclass
に指定した場合、class-prototype :around
とallocate-instance
の組み合わせがエラーになりますが、抽象クラスのサブクラスがstandard-class
等を:metaclass
に指定すれば、通常ルートでインスタンス生成が実行されるのでエラーにならない、という流れです。
(defclass abstract-class (standard-class)
())
(defmethod validate-superclass ((class abstract-class) (superclass standard-class))
T)
(defmethod validate-superclass ((class standard-class) (superclass abstract-class))
T)
(defvar *outside-abstract-class* nil)
(defmethod allocate-instance ((class abstract-class) &key &allow-other-keys)
(unless *outside-abstract-class*
(error "There was an attempt to make an instance of abstract class ~S" (class-name class))))
(defmethod class-prototype :around ((class abstract-class))
(let ((*outside-abstract-class* T))
(call-next-method)))
;; 抽象クラス
(defclass foo ()
(a b c)
(:metaclass abstract-class))
;; インスタンス化できない
(make-instance 'foo)
!!! There was an attempt to make an instance of abstract class foo
;; 実装するメソッド
(defgeneric ztesch (x))
(defgeneric bazola (x y))
;; メソッド実装強制クラス
(defclass bar (foo)
()
(:metaclass enforcing-abstract-methods-class)
(:abstract-methods #'ztesch #'bazola))
;; インスタンス化できない
(make-instance 'bar)
!!! Can't instantiate abstract class #<enforcing-abstract-methods-class bar 41C00A64F3> with abstract methods #<common-lisp:standard-generic-function ztesch 41E001C3FC>.
;; 抽象クラス+メソッド実装強制メタクラス
(defclass abstract-class-enforcing-abstract-methods-class (abstract-class enforcing-abstract-methods-class)
())
;; 抽象クラス+メソッド実装強制クラス(が抽象クラスを継承)
(defclass baz (foo)
()
(:metaclass abstract-class-enforcing-abstract-methods-class)
(:abstract-methods #'ztesch #'bazola))
;; インスタンス化できない(なお実装を強制されたメソッドが空の場合、抽象クラス側のエラーとなる)
(make-instance 'baz)
!!! Can't instantiate abstract class #<abstract-class-enforcing-abstract-methods-class baz 42205DAC5B> with abstract methods #<common-lisp:standard-generic-function ztesch 424001B494>.
;; 抽象クラス+メソッド実装強制クラス(が抽象クラスを継承)のサブクラス
(defclass quux (baz)
()
(:metaclass enforcing-abstract-methods-class))
(finalize-inheritance (find-class 'quux))
;; 実装が強制されたメソッドの確認
(class-abstract-methods (find-class 'quux))
→ (#<common-lisp:standard-generic-function ztesch 41E001C3FC> #<common-lisp:standard-generic-function bazola 41E001C434>)
;; メソッドが実装されていないのでエラー
(make-instance 'quux)
!!! Can't instantiate abstract class #<enforcing-abstract-methods-class quux 40201AD06B> with abstract methods #<common-lisp:standard-generic-function ztesch 41E001C3FC>.
;; メソッドの実装
(defmethod ztesch ((q quux))
(with-slots (a b c) q
(setq a 0 b 1 c 2))
q)
(defmethod bazola ((x integer) (y quux))
(with-slots (a b c) y
(* x (+ a b c))))
;; インスタンス化できた
(bazola 10 (ztesch (make-instance 'quux)))
→ 30
今回は抽象クラスとメソッド実装の強制を別々に定義してメタクラスのmixinとしました。
メソッド実装が強制されるという感覚にいま一つ馴染がないのですが、Common Lispにどうなるのが正しいのかは色々コードを書いてみないと分からなさそうです……。
■
HTML generated by 3bmd in LispWorks 7.0.0
Posted 2020-12-13 17:11:41 GMT
allocate-instance Advent Calendar 2020 14日目の記事です。
折り返しを過ぎましたが、完全にネタ切れなのでallocate-instance
でウェブを検索したりしていますが、allocate-instance
関係で以前から不思議に思っていたことを思い出したので調べてみました。
そもそも、CLtL2(Common Lisp the Language 2nd Ed.)は、ANSI Common Lisp規格成立までの中間報告書なので、ANSI CL規格からみて不備があってもしょうがないのですが、CLtL2中にはallocate-instance
の名前だけは出現するものの、項目を立てて定義が解説されてはいません。
この辺りが謎だったのですが、どうも単純に考慮漏れだったようで、CLtL2の出版時まで、処理系内部の関数なのか外部APIなのかで揺れていたようです。
オブジェクトをアロケートする手続きはどんな処理系でも備えているのは確かなのですが、外部API仕様として確立する必要が出たのは、make-load-form
でユーザー定義の手続きの中にallocate-instance
を含まざるを得ないことが判明したからだったようです。
また、ANSI規格のallocate-instance
にstructure-class
の定義があるのが謎だったのですが、これもmake-load-form
の為だと考えれば納得です。
いつもながらANSI CLは細かいところまで良く考えられていると感心します。 また、CLtL2はANSI CL規格の補助資料として参照するに留めるのが吉だと改めて思いました(が人気の根強いことよ)
■
HTML generated by 3bmd in LispWorks 7.0.0
Posted 2020-12-12 18:31:25 GMT
allocate-instance Advent Calendar 2020 13日目の記事です。
今回もECLOSの拡張のアイデアが元ネタですが、ECLOSにはattributed-class
という再帰的な属性を持つクラスが紹介されているので、属性を隠しスロットに格納するという方法で定義してみました。
実際のECLOSのattributed-class
がどういう仕様と実装になっているかは資料が少なく良く分からないのですが、どうもスロットも属性も同じ構造を持つようです。
そうなると、属性の方に再帰的に定義クラスのオブジェクトを詰めれば良さそう、ということで、defclass
のスロット定義に再帰的にdefclass
の定義を詰めてみることにしました。
割と安直ですが、ECLOSの挙動も大体一緒なので実際にこういう構成かもしれません。
(defclass foo (attributed-object)
((x :initform 'x
:attributes
((a :initform 'a
:attributes
((u :initform "u")))
(b :initform (list 0 1))
c))
(y :initform 'y))
(:metaclass attributed-class)
(:default-attributes
((da :initform 'unknown))))
(let ((obj (make-instance 'foo)))
`((,(slot-value obj 'x)
(list ,(slot-value (slot-attribute obj 'x) 'a)
,(slot-value (slot-attribute (slot-attribute obj 'x) 'a) 'u))
,(slot-value (slot-attribute obj 'x) 'b))
,(list (slot-value obj 'y)
(slot-value (slot-attribute obj 'y) 'da))))
→ ((x (list a "u") (0 1)) (y unknown))
(attribute-value (make-instance 'foo) 'x 'a 'u)
→ "u"
(defpackage "0003c1b3-31ed-5d6d-b58a-6d45c62acc5c"
(:use c2cl slotted-objects))
(cl:in-package "0003c1b3-31ed-5d6d-b58a-6d45c62acc5c")
(defclass attributed-class (slotted-class)
((default-attributes :initform 'nil
:initarg :default-attributes
:accessor class-default-attributes))
(:metaclass standard-class))
(defmethod allocate-instance ((class attributed-class) &rest initargs)
(allocate-slotted-instance (class-wrapper class)
(make-array `(2 ,(length (class-slots class)))
:initial-element (make-unbound-marker))))
(defclass attributed-object (slotted-object)
()
(:metaclass attributed-class))
(defun find-named-slot-using-class (class slot-name &optional (no-error-p nil))
#+lispworks
(flet ((wrapper-slot-names (wrapper)
(elt wrapper 4)))
(let ((wrapper (class-wrapper class))
(pos nil))
(cond ((setq pos (position slot-name (elt wrapper 1)))
(elt (wrapper-slot-names wrapper) pos))
(no-error-p nil)
(T (error "~A is not the name of a slotd." slot-name)))))
#-(or lispworks)
(cond ((loop :for slotd :in (class-slots class)
:thereis (and (eq slot-name (slot-definition-name slotd))
slotd)))
(no-error-p nil)
(t (error "~A is not the name of a slotd." slot-name))))
(defconstant slot-dim 0)
(defconstant attribute-dim 1)
(defmethod slot-value-using-class ((class attributed-class) instance (slotd slot-definition))
(aref (instance-slots instance)
slot-dim
(slot-definition-location slotd)))
(defmethod (setf slot-value-using-class) (value (class attributed-class) instance (slotd slot-definition))
(setf (aref (instance-slots instance)
slot-dim
(slot-definition-location slotd))
value))
(defgeneric slot-attribute-using-class (class instance slotd))
(defmethod slot-attribute-using-class ((class attributed-class) instance (slotd slot-definition))
(aref (instance-slots instance)
attribute-dim
(slot-definition-location slotd)))
(defgeneric (setf slot-attribute-using-class) (val class instance slotd))
(defmethod (setf slot-attribute-using-class) (value (class attributed-class) instance (slotd slot-definition))
(setf (aref (instance-slots instance)
attribute-dim
(slot-definition-location slotd))
value))
(defun slot-attribute (instance slot-name)
(let ((class (class-of instance)))
(slot-attribute-using-class class
instance
(find-named-slot-using-class class slot-name))))
(defun (setf slot-attribute) (value instance slot-name)
(let ((class (class-of instance)))
(setf (slot-attribute-using-class class
instance
(find-named-slot-using-class class slot-name))
value)))
(defclass attributed-slot-definition (standard-slot-definition)
((attributes :initform nil
:initarg :attributes
:accessor attributed-slot-definition-attributes)))
(defclass direct-slot/attribute-definition (standard-direct-slot-definition attributed-slot-definition)
())
(defmethod direct-slot-definition-class ((class attributed-class) &rest initargs)
(find-class 'direct-slot/attribute-definition))
#+lispworks
(defmethod clos:process-a-slot-option ((class attributed-class) option value
already-processed-options slot)
(if (eq option :attributes)
(list* :attributes
`(let ((c (defclass ,(gensym (format nil
"ATTRIBUTED-CLASS.A-"
(string (car slot))))
(attributed-object)
,value
(:metaclass attributed-class))))
(finalize-inheritance c)
c)
already-processed-options)
(call-next-method)))
#+lispworks
(defmethod clos:process-a-class-option ((class attributed-class)
(name (eql :default-attributes))
value)
(unless (and value (null (cdr value)))
(error "attributed-class :default-attributes must have a single value."))
(list name
`(let ((c (defclass ,(gensym "DEFAULT-ATTRIBUTES-") (attributed-object)
,(car value)
(:metaclass attributed-class))))
(finalize-inheritance c)
c)))
(defclass effective-slot/attribute-definition (standard-effective-slot-definition attributed-slot-definition)
())
(defmethod effective-slot-definition-class
((class attributed-class) &rest initargs)
(find-class 'effective-slot/attribute-definition))
(defmethod compute-effective-slot-definition ((class attributed-class)
name
direct-slot-definitions)
(let ((effective-slotd (call-next-method)))
(dolist (slotd direct-slot-definitions)
(when (typep slotd 'attributed-slot-definition)
(setf (attributed-slot-definition-attributes effective-slotd)
(attributed-slot-definition-attributes slotd))
(return)))
effective-slotd))
(defmethod shared-initialize :after ((instance attributed-object) slot-names &rest initargs)
(let* ((class (class-of instance))
(slots (class-slots class))
(default-attributes (class-default-attributes class)))
(dolist (s slots)
(let ((attr (attributed-slot-definition-attributes s)))
(if attr
(setf (slot-attribute-using-class class instance s)
(make-instance (attributed-slot-definition-attributes s)))
(and default-attributes
(setf (slot-attribute-using-class class instance s)
(make-instance default-attributes))))))))
(defun attribute-value (instance &rest names)
(let ((ans instance))
(mapl (lambda (n)
(if (cdr n)
(setq ans (slot-attribute ans (car n)))
(setq ans (slot-value ans (car n)))))
names)
ans))
スロットの方で再帰的に展開させるとXMLみたいな感じでしょうか。
DOMの表現はノードと属性とで別クラスになっていることが多いですが、attributed-class
のようなクラスであれば一本化できそうです。
■
HTML generated by 3bmd in LispWorks 7.0.0
Posted 2020-12-12 12:27:46 GMT
allocate-instance Advent Calendar 2020 12日目の記事です。
アドベントカレンダー折り返し地点で既にネタがブチ切れなのですが、どうにかネタを捻り出していきたいと思います。
今回は、スロットのストレージをOSのファイルとして読み書きしてみることにしました。
“objstore”ディレクトリの直下がクラス名、次にインスタンスのディレクトリがあり、その直下にスロットのファイルが配置されます。
アロケートのタイミングでファイルの読み書きをしなくても、スロットの読み書きでフックをかければ似たようなことはできるのですが、ファイルの確保はallocate-instance
が担当する方が素直かなと思いました。
一応論理パスを利用してファイル名との直接のマッピングは避けています。
非常に簡易的な永続化の方法ですが、案外使えるかも?
(defpackage "8a202ea6-99d1-523d-969b-dbf5fb19ffa5"
(:use c2cl slotted-objects))
(cl:in-package "8a202ea6-99d1-523d-969b-dbf5fb19ffa5")
(setf (logical-pathname-translations "objstore")
`(("**;*.*.*" "/tmp/**/*.*")))
(defclass file-slots-class (slotted-class) ())
(defclass file-slots-objects (slotted-object)
()
(:metaclass file-slots-class))
(defun openo (path)
(open path
:direction :output
:if-does-not-exist :create
:if-exists :supersede))
(defmethod allocate-instance ((class file-slots-class) &rest initargs)
(allocate-slotted-instance (class-wrapper class)
(let* ((instance-name (gensym (string (class-name class))))
(files (mapcar (lambda (s)
(ensure-directories-exist
(make-pathname :host "objstore"
:directory
`(:absolute ,(string (class-name class)) ,(string instance-name))
:name (string (slot-definition-name s)))))
(class-slots class))))
(dolist (f files files)
(with-open-stream (out (openo f))
(print nil out))))))
(defmethod slot-value-using-class ((class file-slots-class) instance (slotd slot-definition))
(with-open-file (in (elt (instance-slots instance) (slot-definition-location slotd)))
(read in)))
(defmethod (setf slot-value-using-class) (value (class file-slots-class) instance (slotd slot-definition))
(with-open-stream (out (openo (elt (instance-slots instance) (slot-definition-location slotd))))
(print value out)
(terpri out)
value))
(defclass foo (file-slots-objects)
((a :initform 0)
(b :initform 1)
(c :initform 2))
(:metaclass file-slots-class))
(defclass bar (foo)
((d :initform 3))
(:metaclass file-slots-class))
(let ((obj (make-instance 'bar)))
(setf (slot-value obj 'd)
"こんにちは"))
$ ls /tmp/bar
bar17928740$ cat /tmp/bar/*/*
0
1
2
"こんにちは"
■
HTML generated by 3bmd in LispWorks 7.0.0
Posted 2020-12-10 17:54:31 GMT
allocate-instance Advent Calendar 2020 11日目の記事です。
このブログで度々取り上げているECLOSというMOPの拡張にlazy-class
という初期化をアクセス時まで遅延させる機能があるのですが、今回はこの遅延初期化を二次元配列で実装してみようと思います。
(defclass foo (lazy-init-object)
((a :initform 0 :initialization :read)
(b :initform 1 :initialization :access)
(c :initform 2))
(:metaclass lazy-init-class))
こんな感じに:initialization
でスロット読み取り時(:read
)や、スロット更新時(:access
)が指定された場合、その時まで初期化は遅延されます。
本家ECLOSでは、さらにスロット間の初期化順序の関係性を記述することが可能ですが、論文の記述だけだと若干挙動が不明なのと、かなり複雑になるので、今回は初期化タイミングの機能に絞ります。
今回実装した遅延の仕組みは非常に単純で、二次元配列で隠しスロットを付加し、そこに初期化関数のクロージャーを詰め、指定のタイミングで呼び出すだけです。
詰め込みにはshared-initialize
を使いますが、安易にshared-initialize
の中でslot-value-using-class
を呼ぶと無限ループするので注意しましょう。自分はこのパターンを良くやってしまいます(自分だけか)
大したことはしていないのですが、スロットにオプションを追加すると長くなります……。
(defpackage "2fa9989a-2db4-50b0-953d-4285ca2aaa88"
(:use c2cl slotted-objects))
(cl:in-package "2fa9989a-2db4-50b0-953d-4285ca2aaa88")
(defclass lazy-init-class (slotted-class)
())
#+lispworks
(defmethod clos:process-a-slot-option
((class lazy-init-class) option value already-processed-options slot)
(if (eq option :initialization)
(list* :initialization value already-processed-options)
(call-next-method)))
(defclass lazy-init-object (slotted-object)
()
(:metaclass slotted-class))
(defconstant slot-dim 0)
(defconstant init-dim 1)
(defmethod allocate-instance ((class lazy-init-class) &rest initargs)
(declare (ignore initargs))
(allocate-slotted-instance (class-wrapper class)
(make-array `(2 ,(length (class-slots class)))
:initial-element (make-unbound-marker))))
(defclass lazy-init-slot-definition (slot-definition)
((initialization :initform nil
:accessor slot-definition-initialization
:initarg :initialization)))
(defclass lazy-init-direct-slot-definition (standard-direct-slot-definition lazy-init-slot-definition)
())
(defmethod direct-slot-definition-class ((class lazy-init-class) &rest initargs)
(find-class 'lazy-init-direct-slot-definition))
(defclass lazy-init-effective-slot-definition (standard-effective-slot-definition lazy-init-slot-definition)
())
(defmethod effective-slot-definition-class ((class lazy-init-class) &rest initargs)
(find-class 'lazy-init-effective-slot-definition))
(defmethod compute-effective-slot-definition ((class lazy-init-class) name direct-slot-definitions)
(declare (ignore name))
(let ((eslotd (call-next-method)))
(dolist (dslotd direct-slot-definitions)
(when (typep dslotd (find-class 'lazy-init-slot-definition))
(setf (slot-definition-initialization eslotd)
(slot-definition-initialization dslotd))))
eslotd))
(defmethod initialize-slot-from-initarg ((class lazy-init-class) instance slotd initargs)
(let ((slot-initargs (slot-definition-initargs slotd)))
(loop :for (initarg value) :on initargs :by #'cddr
:do (when (member initarg slot-initargs)
(setf (aref (instance-slots instance) slot-dim (slot-definition-location slotd))
value)
(return T)))))
(defmethod initialize-slot-from-initfunction ((class lazy-init-class) instance slotd)
(let ((initfun (slot-definition-initfunction slotd)))
(unless (not initfun)
(setf (aref (instance-slots instance) slot-dim (slot-definition-location slotd))
(funcall initfun)))))
(defmethod shared-initialize ((instance lazy-init-object) slot-names &rest initargs)
(let* ((class (class-of instance))
(slotds (class-slots class)))
(dolist (slotd slotds)
(setf (aref (instance-slots instance) init-dim (slot-definition-location slotd))
(lambda ()
(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))))))
;; eager init
(dolist (slotd slotds)
(when (null (slot-definition-initialization slotd))
(let ((slots (instance-slots instance))
(loc (slot-definition-location slotd)))
(funcall (aref slots init-dim loc))
(setf (aref slots init-dim loc) nil)))))
instance)
(defmethod slot-value-using-class ((class lazy-init-class) instance (slotd slot-definition))
(let ((loc (slot-definition-location slotd))
(slots (instance-slots instance)))
(case (slot-definition-initialization slotd)
((:read)
(when (aref slots init-dim loc)
(funcall (aref slots init-dim loc))
(setf (aref slots init-dim loc) nil)))
(otherwise nil))
(aref slots slot-dim loc)))
(defmethod (setf slot-value-using-class) (value (class lazy-init-class) instance (slotd slot-definition))
(let ((loc (slot-definition-location slotd))
(slots (instance-slots instance)))
(case (slot-definition-initialization slotd)
((:read :access)
(when (aref slots init-dim loc)
(funcall (aref slots init-dim loc))
(setf (aref slots init-dim loc) nil)))
(otherwise nil))
(setf (aref slots slot-dim loc) value)))
(defclass foo (lazy-init-object)
((a :initform 0 :initialization :read)
(b :initform 1 :initialization :access)
(c :initform 2))
(:metaclass lazy-init-class))
(let ((obj (make-instance 'foo)))
(instance-slots obj)) ;スロットデータの中身を覗いてみる
→
#2A((#<Slot Unbound Marker> #<Slot Unbound Marker> 2)
(#<Closure 1 subfunction of (method shared-initialize (lazy-init-object t)) 4060013B14>
#<Closure 1 subfunction of (method shared-initialize (lazy-init-object t)) 4060013B3C>
#<Closure 1 subfunction of (method shared-initialize (lazy-init-object t)) 4060013B64>))
(let ((obj (make-instance 'foo)))
(with-slots (a b c) obj a b c)
(instance-slots obj))
→
#2A((0 #<Slot Unbound Marker> 2)
(nil #<Closure 1 subfunction of (method shared-initialize (lazy-init-object t)) 406001227C> nil)) ; :read で初期化された
(let ((obj (make-instance 'foo)))
(with-slots (a b c) obj
a
(setq b 42)
c)
(instance-slots obj))
→
#2A((0 42 2) (nil nil nil)) ; :readと:access で初期化された
スロット初期化の遅延ですが、個人的には遅延させたい局面に遭遇したことがないので、いまいちぴんと来ません。大きなリソースを割り付けたい場合などにはできるだけ遅延させると効率が良いのかも。
メタクラスの定義やスロット定義では似たようなものを毎度書くので、defmetaclass
のようなものを定義して使っている人もいます。
Eric L. Peterson氏のdefmetaclass
は、なかなか良い圧縮具合と使い勝手っぽいので真似してみたいところですが、全部のパターンがマクロで上手く纏められるかというと、そうでもないのがなんとも悩ましい。
■
HTML generated by 3bmd in LispWorks 7.0.0
Posted 2020-12-09 17:04:47 GMT
allocate-instance Advent Calendar 2020 10日目の記事です。
毎度ネタ切れになると、先人の活用事例を参考にしたりライブラリ紹介をしたりしていますが、allocate-instance
に限っては、ほとんど事例がない様子。
メソッドコンビネーションでさえそこそこ事例はあったのに……。
とはいえ、とりあえず一つは見付けたので、そちらの紹介をしてみます。
しかし、どうも実験的なものらしく、プロジェクトのゴミ箱フォルダに入っています。
今回紹介するのは、いつも妙なものを作っているhu.dwimの皆さんのhu.dwim.utilの中のcompact-classです。
スロット内容をコンパクトな表現に変換するようですが、とりあえず動作を説明すると、
(defclass foo ()
((a :initform nil :allocation :compact :type boolean)
(b :initform nil :allocation :compact :type boolean)
(c :initform nil :allocation :compact :type boolean)
(d :initform nil :allocation :compact :type boolean))
(:metaclass compact-class))(let ((obj (make-instance 'foo)))
(setf (slot-value obj 'a) T)
(setf (slot-value obj 'b) T)
(with-slots (a b c d) obj
(list a b c d
(instance-slots obj))))
→ (t t nil nil #(3))
—のように:allocation :compact
を指定するとboolean
型のスロット群の(t t nil nil)
のコンパクトな表現として、#(3)
が格納されます。
(t t nil nil)
反転→ (nil nil t t)
→ #b0011
→ 3
という具合になります。
対応している型と圧縮/解凍の手順ですが、スロットのリーダー/ライターの関数を生成する部分に書いてあります。
ちなみに、SBCLに特化した記述になっていますが、現在のSBCLでは動かないようです。
(def function make-compact-slot-reader (slot)
(bind ((compact-word-offset (compact-word-offset-of slot))
(compact-bits-offset (compact-bits-offset-of slot))
(compact-bit-size (compact-bit-size-of slot))
(type (slot-definition-type slot)))
(declare (type (integer 0 #.(integer-length most-positive-fixnum)) compact-bit-size compact-bits-offset)
(type fixnum compact-word-offset))
(flet ((%slot-value (instance)
(declare #.(optimize-declaration))
(the fixnum (ldb (byte compact-bit-size compact-bits-offset)
(the fixnum (standard-instance-access instance compact-word-offset))))))
(declare (inline %slot-value))
(cond ((subtypep type 'boolean)
(lambda (instance)
(declare #.(optimize-declaration))
(= (%slot-value instance) 1)))
((subtypep type 'integer)
(lambda (instance)
(declare #.(optimize-declaration))
(%slot-value instance)))
((subtypep type 'base-char)
(lambda (instance)
(declare #.(optimize-declaration))
(code-char (%slot-value instance))))
((subtypep type 'single-float)
(lambda (instance)
(declare #.(optimize-declaration))
#+sbcl (sb-vm::make-single-float (%slot-value instance))))
((and (subtypep type 'simple-base-string)
(consp type))
(lambda (instance)
(declare #.(optimize-declaration))
(iter (with value = (%slot-value instance))
(with string = (make-string (second type)))
(for index :from 0 :below (the fixnum (second type)))
(for position :initially 0 :then (+ 7 position))
(declare (type fixnum index position))
(setf (aref string index) (code-char (ldb (byte 7 position) value)))
(finally (return string)))))
(t
(aif (type-instance-count-upper-bound type)
(bind ((instance-list (type-instance-list type)))
(lambda (instance)
(elt instance-list (%slot-value instance))))
(error "Unknown compact type ~A" type)))))))
今回は、hu.dwim.util
のcompact-class
を紹介してみました。
結構アグレッシブで面白いと思います。
■
HTML generated by 3bmd in LispWorks 7.0.0
Posted 2020-12-09 01:04:00 GMT
allocate-instance Advent Calendar 2020 9日目の記事です。
以前、初期MOPの文献で、隠しスロットの実例としてスロットにfacetをつけるというのを紹介しましたが、こちらの例では隠しスロットは、本スロットと交代の並びで追加されるので、本スロットの位置×2で位置を求めたりしていました。
しかし、ストレージを一次元配列ではなく、多次元配列にしてしまえば、値のインデックスはそのままで指定の次元アクセスすれば対応した場所にアクセスできて便利なのではないかと思ったので、試してみました。
(defpackage "493c1b0d-ff75-5a3a-9872-43d488f33914"
(:use c2cl slotted-objects))
(in-package "493c1b0d-ff75-5a3a-9872-43d488f33914")
(defclass faceted-slot-class (slotted-class)
())
(defclass faceted-slot-object (slotted-object)
()
(:metaclass faceted-slot-class))
(defconstant slot-dim 0)
(defconstant facet-dim 1)
(defmethod allocate-instance ((class faceted-slot-class) &rest initargs)
(declare (ignore initargs))
(allocate-slotted-instance (class-wrapper class)
(make-array `(2 ,(length (class-slots class)))
:initial-element (make-unbound-marker))))
(defmethod slot-value-using-class ((class faceted-slot-class) instance (slotd slot-definition))
(aref (instance-slots instance) slot-dim (slot-definition-location slotd)))
(defmethod (setf slot-value-using-class) (value (class faceted-slot-class) instance (slotd slot-definition))
(setf (aref (instance-slots instance) slot-dim (slot-definition-location slotd))
value))
(defun facet-missing (instance facet-name)
(error "The facet ~S is missing from the object ~S" facet-name instance))
(defun slot-facet (instance slot-name)
(aref (instance-slots instance)
facet-dim
(slot-definition-location
(or (find slot-name (class-slots (class-of instance)) :key #'slot-definition-name)
(facet-missing instance slot-name)))))
(defun (setf slot-facet) (value instance slot-name)
(setf (aref (instance-slots instance)
facet-dim
(slot-definition-location
(or (find slot-name (class-slots (class-of instance)) :key #'slot-definition-name)
(facet-missing instance slot-name))))
value))
(defclass zot (faceted-slot-object)
((a :initform 42)
(b :initform 43)
(c :initform 44))
(:metaclass faceted-slot-class))(describe (make-instance 'zot))
⇒
#<zot 41601B9CD3> is a zot
a 42
b 43
c 44
;;; facetに値を設定
(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)
(mapcar (lambda (s)
(list (slot-value o s)
(slot-facet o s)))
'(a b c)))
→ ((42 facet-a) (43 facet-b) (44 facet-c))
やはりスロットに一対一で対応するような隠しスロットには一本のベクタで配置を工夫するよりは、多次元配列の方が安直に実装できます。
スロットにフラグを持たせる場所としては便利そうですが、さて実用的にはどうなのか……。
■
HTML generated by 3bmd in LispWorks 7.0.0
Posted 2020-12-07 18:39:35 GMT
allocate-instance Advent Calendar 2020 8日目の記事です。
allocate-instance
でカスタマイズしたいような場面について考えていますが、
あたりがある気がしていますが、今回は、インスタンス群の組織化で考えてみたいと思います。
論理・代数・データベースという本を読んでいて、昔のデータベースの構成方法にCODASYL Setというのがあることを知ったのですが、これはナビゲーショナルデータベースや、ネットワーク型データモデルの先駆けらしいです。
親子関係にあるオブジェクトでリンクトリストを作る感じですが、インスタンス群を組織化するのに隠しスロットが使えそうなので試してみましょう。
オブジェクトはownerとmemberに分かれ、ownerが作る循環リストにメンバーが接続していくという感じです。
CODASYL Setのシンプルな構成は、循環する一方向リストですが、追加や検索の便宜を図ってownerへのポインタと前後のポインタを持つことが多いそうなので、そういう構成で書いてみます。
(defpackage "c247a8da-b119-500b-b556-47ff40b1347a"
(:use c2cl slotted-objects))
(in-package "c247a8da-b119-500b-b556-47ff40b1347a")
(defclass codasyl-class (slotted-class)
((owner :accessor codasyl-class-owner :initform nil :initarg :owner)))
#+lispworks
(defmethod clos:process-a-class-option ((class codasyl-class) (name (eql :owner)) value)
(unless (and value (null (cdr value)))
(error "codasyl-class: :owner must have a single value."))
`(,name ,(car value)))
(defclass codasyl-object (slotted-object)
()
(:metaclass codasyl-class))
(defclass codasyl-element ()
((slots :accessor codasyl-element-slots :initarg :slots)
(owner :accessor codasyl-element-owner :initarg :owner :initform nil)
(next :accessor codasyl-element-next :initform nil)
(prev :accessor codasyl-element-prev :initform nil)))
(defmethod allocate-instance ((class codasyl-class) &rest initargs)
(let* ((slots (make-instance 'codasyl-element
:slots (make-sequence 'vector
(length (class-slots class))
:initial-element (make-unbound-marker))))
(instance (allocate-slotted-instance (class-wrapper class) slots)))
(setf (codasyl-element-owner slots) instance)
(setf (codasyl-element-prev slots) instance)
(setf (codasyl-element-next slots) instance)
instance))
(defmethod slot-value-using-class ((class codasyl-class) instance (slotd slot-definition))
(elt (codasyl-element-slots (instance-slots instance))
(slot-definition-location slotd)))
(defmethod (setf slot-value-using-class) (value (class codasyl-class) instance (slotd slot-definition))
(setf (elt (codasyl-element-slots (instance-slots instance))
(slot-definition-location slotd))
value))
(defun find-last-codasyl-element (owner)
(loop :for elt := (codasyl-element-next (instance-slots owner)) :then (codasyl-element-next (instance-slots elt))
:when (eq (codasyl-element-next (instance-slots elt)) owner)
:return elt))
(defmethod initialize-instance :after ((instance codasyl-object) &rest initargs)
(let ((slot-data (instance-slots instance)))
(let ((default-owner (codasyl-element-owner slot-data))
(new-owner (codasyl-class-owner (class-of instance))))
;; if instance is member type
(and (codasyl-class-owner (class-of instance))
(unless (eq default-owner new-owner)
;; set the new owner
(setf (codasyl-element-owner slot-data) new-owner)
(let ((last (find-last-codasyl-element (codasyl-element-owner slot-data))))
;; concatenate the new member
(setf (codasyl-element-prev slot-data) last)
(setf (codasyl-element-next (instance-slots last)) instance)
(setf (codasyl-element-next slot-data) new-owner)))))))
(defun walk-codasyl-members (owner fn)
(loop :for e := (codasyl-element-next (instance-slots owner)) :then (codasyl-element-next (instance-slots e))
:until (eq e owner)
:do (funcall fn e)))
(defun map-codasyl-members (owner fn)
(loop :for e := (codasyl-element-next (instance-slots owner)) :then (codasyl-element-next (instance-slots e))
:until (eq e owner)
:collect (funcall fn e)))
循環構造を作るので無駄に長くなりました……。
(defclass owner-foo (codasyl-object)
((a :initform 0)
(b :initform 1)
(c :initform 2))
(:metaclass codasyl-class))
(defclass member-foo (codasyl-object)
((a :initform 0)
(b :initform 1)
(c :initform 2))
(:metaclass codasyl-class)
(:owner (class-prototype (find-class 'owner-foo))))
;; 10個生成する
(dotimes (i 10)
(make-instance 'member-foo))
;;
(map-codasyl-members (codasyl-class-owner (find-class 'member-foo))
(lambda (m)
(with-slots (a b c) m
(list a b c))))
→ ((0 1 2) (0 1 2) (0 1 2) (0 1 2) (0 1 2) (0 1 2) (0 1 2) (0 1 2) (0 1 2) (0 1 2))
1970年代のリソース環境では、循環リストにする価値はあったんだと思いますが、普通のリストにすれば結構単純化できそうです。
要素を別途リストで管理すれば良いのですが、今回のポイントは要素内に隠しスロットで前後および親へのポインタを持つということでしょうか。
Linuxのリスト実装の構造体のトリックがありますが、今回のようなクラスを定義してmixinして使うとリストが作れる的なクラスも実現できたりしそうです。
■
HTML generated by 3bmd in LispWorks 7.0.0
Posted 2020-12-06 21:21:25 GMT
allocate-instance Advent Calendar 2020 7日目の記事です。
これまで、allocate-instance
で確保するストレージをスロット付きオブジェクトというところまで拡大して、データ構造を差し替えたりしてみましたが、現時点で考え付くものをまとめてみたいと思います(ネタ切れともいう)
今回も共通の処理は、slotted-objects
にまとめたものを利用します。
(defpackage "e718761d-aab2-548a-aa32-d3ba5e48b3ce"
(:use c2cl slotted-objects))(in-package "e718761d-aab2-548a-aa32-d3ba5e48b3ce")
先日も似たようなことをやっていましたが、symbol-plist
をストレージにしたらどうかという試みです。
(defclass symbol-class (slotted-class)
())
(defclass symbol-object (slotted-object)
()
(:metaclass symbol-class))
(defmethod allocate-instance ((class symbol-class) &rest initargs)
(let ((sym (gentemp (string (class-name class)))))
(setf (symbol-plist sym)
(mapcan (lambda (s)
(list s (make-unbound-marker)))
(class-slots class)))
(allocate-slotted-instance (class-wrapper class)
sym)))
(defmethod slot-value-using-class ((class symbol-class) instance (slotd slot-definition))
(get (instance-slots instance) slotd))
(defmethod (setf slot-value-using-class) (value (class symbol-class) instance (slotd slot-definition))
(setf (get (instance-slots instance) slotd)
value))
(defclass symbol-foo (symbol-object)
((a :initform 0)
(b :initform 1)
(c :initform 2))
(:metaclass symbol-class))
シンボルはplistだけを利用するのですが、インスタンスをシンボルの値にするの方が色々応用がききそうです。
(let ((obj (make-instance 'symbol-foo)))
(set (instance-slots obj) obj)
(instance-slots obj))
→ symbol-foo4symbol-foo4
→ #<symbol-foo 4020099DF3>
(symbol-plist 'symbol-foo4)
→
(#<standard-effective-slot-definition a 42202D39D3>
0
#<standard-effective-slot-definition b 42202D4B93>
1
#<standard-effective-slot-definition c 42202D4D2B>
2)
(incf (slot-value symbol-foo4 'a) 100)
→ 100
(symbol-plist 'symbol-foo4)
→
(#<standard-effective-slot-definition a 42202D39D3>
100
#<standard-effective-slot-definition b 42202D4B93>
1
#<standard-effective-slot-definition c 42202D4D2B>
2)
(defclass alist-class (slotted-class)
())
(defclass alist-object (slotted-object)
()
(:metaclass alist-class))
(defmethod allocate-instance ((class alist-class) &rest initargs)
(allocate-slotted-instance (class-wrapper class)
(mapcar (lambda (s)
(cons s (make-unbound-marker)))
(class-slots class))))
(defmethod slot-value-using-class ((class alist-class) instance (slotd slot-definition))
(cdr (assoc slotd (instance-slots instance))))
(defmethod (setf slot-value-using-class)
(value (class alist-class) instance (slotd slot-definition))
(setf (cdr (assoc slotd (instance-slots instance)))
value))
(defclass alist-foo (alist-object)
((a :initform 0)
(b :initform 1)
(c :initform 2))
(:metaclass alist-class))
構造が似ているだけに、シンボルのplistと大差ありません。
シンボルのplistやリストをオブジェクトと連携させた際の応用としては、古えのAIプログラム等は、シンボルのplistやリスト操作を駆使したものが多いので、そういうリストとシンボルの塊のプログラムにマッピングをして見通しの良いプログラムに段階的に変換したりするのに使えたりするかもしれません。
(let ((obj (make-instance 'alist-foo)))
(incf (slot-value obj 'c) 100)
(instance-slots obj))
→
((#<standard-effective-slot-definition a 402019DFB3> . 0)
(#<standard-effective-slot-definition b 402019E01B> . 1)
(#<standard-effective-slot-definition c 402019E083> . 102))
ハッシュテーブルをストレージにするのは先日試しました
データ効率向上以外の応用としては、クロージャー+ハッシュテーブルなプログラムをクラスを利用したものに変換するのに使えたりするかもしれません。
AoSな構成については先日書きました。
1990年代のMOPの応用例の考察として、LispマシンにあったAREAというGC対象外の手動でメモリ管理する領域にインスタンスのストレージを確保する、というのがちょくちょく出てきます。
大きい配列をそのような領域に確保するという目的には丁度良いかもしれません。
AoSの逆のSoAについてはAoSと似たような応用が考えられますが、配列要素にガッチリ型を指定可能なので、型検査のメリットを活かすスロットの一つの実現方法としてSoAを利用するというのもありかなと思ったりしています。
(defclass struct-class (slotted-class)
())
(defmethod ensure-class-using-class :before ((class struct-class) name &rest initargs)
(eval `(defstruct ,(intern (concatenate 'string (string (class-name class)) (string '-struct)))
,@(mapcar (lambda (s)
(list (slot-definition-name s) (make-unbound-marker)))
(class-slots class)))))
(defclass struct-object (slotted-object)
()
(:metaclass struct-class))
(defmethod allocate-instance ((class struct-class) &rest initargs)
(allocate-slotted-instance (class-wrapper class)
(funcall (fdefinition
(intern
(concatenate 'string
(string 'make-)
(string (class-name class))
(string '-struct)))))))
(defmethod slot-value-using-class ((class struct-class) instance (slotd slot-definition))
(slot-value (instance-slots instance) (slot-definition-name slotd)))
(defmethod (setf slot-value-using-class) (value (class struct-class) instance (slotd slot-definition))
(setf (slot-value (instance-slots instance) (slot-definition-name slotd))
value))
(defclass struct-foo (struct-object)
((a :initform 0)
(b :initform 1)
(c :initform 2))
(:metaclass struct-class))
段々屋上屋っぽくなってきましたが、これも既存の構造体メインで構築したプログラムを、段階的に徐々に変換するのに使えたりもすかもしれません(上例ではクラス定義時に構造体を定義していますが)
(let ((obj (make-instance 'struct-foo)))
(incf (slot-value obj 'c) 100)
(instance-slots obj))
→ #S(struct-foo-struct :a 0 :b 1 :c 102)
(defclass class-class (slotted-class)
())
(defmethod ensure-class-using-class :before ((class class-class) name &rest initargs &key direct-slots)
(ensure-class-using-class (find-class 'standard-class)
(intern (concatenate 'string (string name) (string '-storage)))
:direct-slots direct-slots))
(defclass class-object (slotted-object)
()
(:metaclass class-class))
(defmethod allocate-instance ((class class-class) &rest initargs)
(allocate-slotted-instance (class-wrapper class)
(make-instance (intern (concatenate 'string
(string (class-name class))
(string '-storage))))))
(defmethod slot-value-using-class ((class class-class) instance (slotd slot-definition))
(slot-value (instance-slots instance) (slot-definition-name slotd)))
(defmethod (setf slot-value-using-class) (value (class class-class) instance (slotd slot-definition))
(setf (slot-value (instance-slots instance) (slot-definition-name slotd))
value))
完全に屋上屋ですが、既存の定義をニコイチにしてスロット名をつけかえたりできるかもしれません。
(defclass class-foo (class-object)
((a :initform 0)
(b :initform 1)
(c :initform 2))
(:metaclass class-class))(let ((obj (make-instance 'class-foo)))
(incf (slot-value obj 'c) 100)
(describe (instance-slots obj)))
⇒
#<class-foo-storage 40200BA7F3> is a class-foo-storage
a 0
b 1
c 102
当初の計画ではデータ構造ごとにエントリーを書いていればallocate-instance
アドベントカレンダーの25日間はしのげるかなと思ったのですが、話が広げられないので今回一つにまとめて書いてしまいました。
あと18ネタをどう捻り出すか……。
■
HTML generated by 3bmd in LispWorks 7.0.0
Posted 2020-12-05 23:00:44 GMT
allocate-instance Advent Calendar 2020 6日目の記事です。
今回は、allocate-instance
を含めたInstance Structure Protocol(ISP)について書きたいと思います。
Advances in Object-Oriented Metalevel Architectures and Reflectionというオブジェクト指向プログラミングの本で、ECLOSというCLOS MOPの活用事例の紹介論文があるのですが、この論文の補遺にKiczales先生が1990年代前半に考えていたCLOS MOPのISPの改善案が紹介されています。
改善案では、
compute-getter-and-setter
を導入slot-value-using-class
、standard-instance-access
、funcallable-standard-instance-access
の廃止というのが主なところですが、compute-getter-and-setter
はTiny CLOS系でお馴染です。
ここで紹介されている改善案とTiny CLOSのISP構成を比較してみると、実際そのまま同じ構成でした。
旧プロトコルの問題としては、
slot-value-using-class
とその “setf” にメソッドを定義するユーザ拡張機能方式は、standard-instance-access
のような直のアクセスに比べてパフォーマンスが著しく低かった—等があり、この辺りをcompute-getter-and-setter
でslot-value
の下請けのセッターとゲッターをまとめて管理するようにすることで改善できた、としています。
コンセプトを説明するためのコードも記載されているので、試しに既存のCommon Lisp上で動くかを試してみましたが、ISPをまるごと差し替えるのは、それなりに面倒な様子です。
具体的には、クラスの再定義時のインスタンス情報の更新プロトコルも併せて修正する必要がありそうです。
Tiny CLOS系のMOPと、CLOS MOPで結構違うのがスロットのカスタマイズの作法ですが、Tiny CLOS方式の方が見通し良くコードも簡潔にカスタマイズできます。
パフォーマンスに関しては、Common Lisp処理系でもCLOS MOPの枠内での工夫があるので、そこまでの違いはなさそうな気はします。
AMOPがCommon LispのMOPの決定版の地位を確立したところまでは良かったのですが、それ以降は停滞してしまいました。
CLOS MOPはANSI規格で定義されているわけではないので、処理系ごとに色々できそうですが、AMOPという定番がある故にそこから逸脱することも難しく色々微妙なことになっています……。
(defpackage "899d6e7c-87b9-559a-8075-8452920d48fc"
(:use c2cl slotted-objects)
(:shadow slot-value class-slots))
(in-package "899d6e7c-87b9-559a-8075-8452920d48fc")
(defclass new-standard-class (standard-class)
((nfields :initform nil)
(getters-n-setters :initform '())
(slots :initform '() :accessor class-slots)))
(defmethod validate-superclass ((c new-standard-class) (s standard-class))
T)
(defmethod allocate-instance ((class new-standard-class) &rest initargs)
(allocate-slotted-instance (class-wrapper class)
(make-sequence 'vector (cl:slot-value class 'nfields)
:initial-element (make-unbound-marker))))
(defgeneric compute-getter-and-setter (class eslotd eslotds field-allocator))
(defmethod compute-getter-and-setter ((class standard-class)
(eslotd standard-effective-slot-definition)
eslotds
field-allocator)
(ecase (slot-definition-allocation eslotd)
(:instance (list eslotd
(funcall field-allocator)
(lambda (ignore-obj val)
(declare (ignore ignore-obj))
val)
(lambda (ignore-obj val new)
(declare (ignore val ignore-obj))
new)))
(:class (let ((cell (cons (make-unbound-marker) nil)))
(list eslotd
nil
(lambda (ignore-obj ignore-val)
(declare (ignore ignore-obj ignore-val))
(car cell))
(lambda (ignore-obj ignore-val new)
(declare (ignore ignore-obj ignore-val))
(setf (car cell) new)))))))
#+lispworks
(defun make-wrapper (class eslotds)
(let ((wrapper (clos::make-wrapper-standard (length eslotds))))
(clos::initialize-wrapper wrapper)
(setf (elt wrapper 1)
(mapcar #'slot-definition-name eslotds))
(setf (clos::wrapper-class wrapper)
class)
(setf (elt wrapper 4)
eslotds)
wrapper))
(defmethod finalize-inheritance ((class new-standard-class))
(setf (class-precedence-list class)
(compute-class-precedence-list class))
(setf (cl:slot-value class 'slots) (compute-slots class))
(let* ((eslotds (class-slots class))
(nfields 0)
(field-allocator (lambda ()
(prog1
nfields
(incf nfields)))))
(setf (cl:slot-value class 'getters-n-setters)
(mapcar (lambda (eslotd)
(compute-getter-and-setter class eslotd eslotds field-allocator))
eslotds))
(setf (cl:slot-value class 'nfields) nfields)
(setf (class-default-initargs class)
(compute-default-initargs class))
(setf (clos::class-wrapper class)
(make-wrapper class eslotds)))
nil)
(defgeneric get-field (object field))
(defmethod get-field ((object standard-object) field)
(elt (instance-slots object) field))
(defgeneric set-field (object field value))
(defmethod set-field ((object standard-object) field value)
(setf (elt (instance-slots object) field)
value))
(defun slot-value (object slot-name)
(let* ((class (class-of object))
(eslotd (find slot-name (class-slots class)
:key #'slot-definition-name)))
(destructuring-bind (field getter setter)
(cdr (assoc eslotd (cl:slot-value class 'getters-n-setters)))
(declare (ignore setter))
(funcall getter object (and field (get-field object field))))))
(defun (setf slot-value) (new object slot-name)
(let* ((class (class-of object))
(eslotd (find slot-name (class-slots class)
:key #'slot-definition-name)))
(destructuring-bind (field getter setter)
(cdr (assoc eslotd (cl:slot-value class 'getters-n-setters)))
(declare (ignore getter))
(if field
(set-field object
field
(funcall setter object (get-field object field) new))
(funcall setter object nil new)))))
■
HTML generated by 3bmd in LispWorks 7.0.0
Posted 2020-12-04 18:27:55 GMT
allocate-instance Advent Calendar 2020 5日目の記事です。
allocate-instance
をいじくるネタを捻り出す毎日ですが、今回は履歴付きスロットを実現してみたいと思います。
今回も共通の処理は、slotted-objects
にまとめたものを利用します。
スロットの更新履歴を全部保存しておいて、後から参照できるようなスロットです。
実例はこれまで目にしたことはないもののMOPの文献等でたまに用例として出てきたりします。
履歴を保存するデータ構造は色々な方法で簡単に作成できると思うので、allocate-instance
がそのようなデータ構造を確保してしまう方が、allocate-instance
よりも上のレベルであれこれするより素直で直截的かと思うので、allocate-instance
のカスタマイズ向きな用例かもしれません。
今回は素朴な実装ですが、slot-history
という現在の値と履歴のハッシュテーブルを持つオブジェクトを定義して各スロットがそれを保持することにしてみました。
スロットに値をセットする時にタイムスタンプを押しますが、get-internal-real-time
を適当に使っています。
(defpackage "f9685263-15f6-55c9-a3bb-325737df58f2"
(:use :c2cl :slotted-objects))
(in-package "f9685263-15f6-55c9-a3bb-325737df58f2")
(defclass history-slots-class (slotted-class) ())
(defclass history-slots-object (slotted-object)
()
(:metaclass history-slots-class))
(defclass slot-history ()
((cur :initform (make-unbound-marker) :accessor slot-history-value)
(log :initform (make-hash-table) :accessor slot-history-log)))
(defmethod allocate-instance ((class history-slots-class) &rest initargs)
(allocate-slotted-instance (class-wrapper class)
(map 'vector
(lambda (x)
(declare (ignore x))
(make-instance 'slot-history))
(class-slots class))))
(defmethod slot-value-using-class ((class history-slots-class) instance (slotd slot-definition))
(slot-history-value (elt (instance-slots instance) (slot-definition-location slotd))))
(defmethod (setf slot-value-using-class)
(value (class history-slots-class) instance (slotd slot-definition))
(let ((slot (elt (instance-slots instance) (slot-definition-location slotd))))
(setf (gethash (get-internal-real-time) (slot-history-log slot))
value)
(setf (slot-history-value slot) value)))
(defclass foo (slotted-object)
((a :initform 0)
(b :initform 1)
(c :initform 2))
(:metaclass history-slots-class))
(defun replay-slots (instance)
(let* ((slots (instance-slots instance))
(timestamps (sort
(loop :for s :across slots
:append (loop :for ts :being :the :hash-keys :of (slot-value s 'log) :collect ts))
#'<)))
(dolist (ts timestamps)
(map nil
(lambda (slot name)
(let ((log (gethash ts (slot-value slot 'log))))
(when log
(format T "~&~S: ~S → ~S~%" ts name log))))
slots
(mapcar #'slot-definition-name (class-slots (class-of instance)))))))
(let ((o (make-instance 'foo)))
;; それぞれのスロットに値を10回セット
(dotimes (i 10)
(sleep (/ 1 (1+ (random 100))))
(setf (slot-value o 'a) i)
(sleep (/ 1 (1+ (random 100))))
(setf (slot-value o 'b) i)
(sleep (/ 1 (1+ (random 100))))
(setf (slot-value o 'c) i))
;; スロット変更履歴再生
(replay-slots o))
11530892: a → 0
11530892: b → 1
11530892: c → 2
11530892: a → 0
11530892: b → 1
11530892: c → 2
11530892: a → 0
11530892: b → 1
11530892: c → 2
11530907: a → 0
11530918: b → 0
11530928: c → 0
11530951: a → 1
11530964: b → 1
11530974: c → 1
11531224: a → 2
11531251: b → 2
11531270: c → 2
11531282: a → 3
11531300: b → 3
11531310: c → 3
11531343: a → 4
11531393: b → 4
11531405: c → 4
11531464: a → 5
11531475: b → 5
11531527: c → 5
11531564: a → 6
11531664: b → 6
11531674: c → 6
11531691: a → 7
11531703: b → 7
11531729: c → 7
11531872: a → 8
11531888: b → 8
11531904: c → 8
11531936: a → 9
11531961: b → 9
11531984: c → 9
アクセス時間的にシビアなもので使うには、きっちり実装したものでないと厳しそうですが、デバッグ時に値の変更履歴を確認したい時には、素朴な実装でも活用できそうな気がします。
■
HTML generated by 3bmd in LispWorks 7.0.0
Posted 2020-12-03 16:07:06 GMT
allocate-instance Advent Calendar 2020 4日目の記事です。
インスタンスのストレージをカスタマイズするといっても大抵はスロット付きオブジェクトの値を参照する/設定する、のが基本操作なので、大体の操作をまとめてGitHubに置いてみました。
On Lispや、Let Over Lambdaでは、Common Lispのオブジェクト指向システムは使わず、クロージャーとハッシュテーブルだったりマクロを組合せて「オブジェクト指向システムを越えた!」みたいなことをやっていますが、今回は、逆を行ってクロージャーをインスタンスの中身にしてみます。
ちなみに、Common Lispでは、オブジェクト指向システムは普通に使うので、On Lisp、Let Over Lambdaみたいな偏った本だけ読むのではなく、Quicklisp等で流通している皆のコードを読んでみましょう。普通に皆、defclass
しています。
上記slotted-objects
としてまとめたコードを使えば、スロット付きオブジェクトをインスタンスの中身に設定するには、文末のコードのようにallocate-instance
とslot-value-using-class
あたりを定義すれば実現できます。
インスタンスの中身を関数にすると、リダイレクト等の動的な操作は幾らでも可能になりますが、それはオブジェクトのアロケート時にすることかといわれると微妙です。
(defpackage "72e97df3-26b8-5ff7-b134-8d9338d93e41"
(:use :c2cl :slotted-objects))
(in-package "72e97df3-26b8-5ff7-b134-8d9338d93e41")
(defclass closure-class (slotted-class) ())
(defclass closure-object (slotted-object)
()
(:metaclass closure-class))
(defmethod allocate-instance ((class closure-class) &rest initargs)
(allocate-slotted-instance (class-wrapper class)
(let* ((slotds (class-slots class))
(slot-names (mapcar #'slot-definition-name slotds)))
(eval
`(let (,@(mapcar (lambda (s)
`(,s (make-unbound-marker)))
slot-names))
(lambda (set/get slot val)
(ecase set/get
((:get)
(ecase slot
,@(mapcar (lambda (d n)
`((,d) ,n))
slotds
slot-names)))
((:set)
(ecase slot
,@(mapcar (lambda (d n)
`((,d) (setq ,n val)))
slotds
slot-names))))))))))
(defmethod slot-value-using-class ((class closure-class) instance (slotd slot-definition))
(funcall (instance-slots instance) :get slotd nil))
(defmethod (setf slot-value-using-class)
(value (class closure-class) instance (slotd slot-definition))
(funcall (instance-slots instance) :set slotd value))
(defclass foo (slotted-object)
((a :initform 0)
(b :initform 1)
(c :initform 2))
(:metaclass closure-class))(describe
(make-instance 'foo))
#<foo 4020386BEB> is a foo
a 0
b 1
c 2
(let ((o (make-instance 'foo)))
(let ((slot-a (find 'a (class-slots (find-class 'foo)) :key #'slot-definition-name)))
(funcall (instance-slots o) :set slot-a 100)
(describe o)))
#<foo 4020083683> is a foo
a 100
b 1
c 2
■
HTML generated by 3bmd in LispWorks 7.0.0
Posted 2020-12-02 17:23:01 GMT
allocate-instance Advent Calendar 2020 3日目の記事です。
以前、MOPでSoAというのを試してみたのですが、今回はSoAの逆のAoSを試してみたいと思います。
AoSとは、構造体を並べた配列でArray of Structuresの略ですが、Common Lispにはdisplaced arrayという配列の一部を別の配列として利用する機能があるので、一本の巨大な配列を細切れにして分配してみます。
AoSを確保する部分とallocate-instace
が骨子ですが、その部分だけを抜き出すと下記のようになります。
(defparameter *aos*
(make-array (1- array-total-size-limit) :initial-element *slot-unbound*))
(defmethod allocate-instance ((class aos-slots-class) &rest initargs)
(alloc-fix-instance (class-wrapper class)
(let* ((len (length (class-slots class)))
(obj (make-array len
:displaced-to *aos*
:displaced-index-offset (class-index class))))
(incf (class-index class) len)
obj)))
インスタンスを定義してから10回make-instance
して、ストレージの配列を観察してみます。
(defclass foo (aos-slots-object)
((a :initform 'a)
(b :initform 'b)
(c :initform 'c))
(:metaclass aos-slots-class))
(dotimes (i 10)
(make-instance 'foo))
(subseq *aos* 0 30)
→ #(a b c a b c a b c a b c a b c a b c a b c a b c a b c a b c)
ストレージの配列のを眺めてしまうと、アクセス時に間違って混ざったりちゃいそうに見えますが、displaced arrayのお蔭でインスタンスは個別の領域のみアクセスしています。
大体こんな感じになります。
インスタンスのストレージの中身の操作については、前回の定義を参照してください。
(defclass aos-slots-class (standard-class)
((index :initform 0 :accessor class-index)))
(defmethod shared-initialize :after ((class aos-slots-class) slots &rest initargs)
(setf (class-index class) 0))
(defclass aos-slots-object (standard-object)
()
(:metaclass aos-slots-class))
(defmethod validate-superclass ((class aos-slots-class) (super standard-class))
T)
(defparameter *aos*
(make-array (1- array-total-size-limit) :initial-element *slot-unbound*))
(defmethod allocate-instance ((class aos-slots-class) &rest initargs)
(alloc-fix-instance (class-wrapper class)
(let* ((len (length (class-slots class)))
(obj (make-array len
:displaced-to *aos*
:displaced-index-offset (class-index class))))
(incf (class-index class) len)
obj)))
(defmethod slot-value-using-class
((class aos-slots-class) instance (slotd slot-definition))
(elt (instance-slots instance)
(slot-definition-location slotd)))
(defmethod (setf slot-value-using-class)
(val (class aos-slots-class) instance (slotd slot-definition))
(setf (elt (instance-slots instance)
(slot-definition-location slotd))
val))
(defgeneric initialize-slot-from-initarg (class instance slotd initargs))
(defmethod 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 (member initarg slot-initargs)
(setf (slot-value-using-class class instance slotd)
value)
(return T)))))
(defgeneric initialize-slot-from-initfunction (class instance slotd))
(defmethod initialize-slot-from-initfunction (class instance slotd)
(let ((initfun (slot-definition-initfunction slotd)))
(unless (not initfun)
(setf (slot-value-using-class class instance slotd)
(funcall initfun)))))
(defmethod shared-initialize
((instance aos-slots-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)
似たようなものを色々定義していますが、スロットを有するオブジェクトについては一つslotted-class
&slotted-object
にまとめられそうです。
Lispにおいてスロットを有すると考えられるオブジェクトは沢山ありますが、
—あたりは統一的な操作体系でまとめられるでしょう。
定義が長いのでそのうちGitHub等にでも置こうかなと思います。
■
HTML generated by 3bmd in LispWorks 7.0.0
Posted 2020-12-02 13:03:55 GMT
allocate-instance Advent Calendar 2020 2日目の記事です。
前回は、Metaobject Protocols Why We Want Them and What Else They Can Doに出てくるインスタンスを中身をハッシュテーブルにしてメモリ効率を上げる手法について紹介しましたが、大抵の実装は、インスタンスの確保まではカスタマイズせずにフックをかけてリダイレクトすることが多いということを述べました。
ということで、今回は、実際にallocate-instance
が確保するストレージをハッシュテーブルにしてみましょう。
現在の主な処理系が採用しているオブジェクト指向システムの実装は、大抵PCL(Portable Common Loops)をカスタマイズしたものです。
PCLではstandard-object
は、wrapperというクラス定義の情報とスロットを格納する配列から構成されています。
ということで、スロットを格納するオブジェクトをハッシュテーブルに差し替えれば良いのですが、そのためにstandard-object
の内部構造をいじる関数を定義しておきます。
なお、残念ながらECLは、allocate-instance
の下請け関数がCレベルで配列をアロケートするものになっており、Lispレベルではカスタマイズできないようなので今回はパスします(10行程度のCの定義を加えれば任意のオブジェクトを格納場所にできそうではありますが)。
ちなみに他の処理系も正しい作法かどうかは分からないので、その辺りはご了承ください。特に商用処理系はソースが確認できないのでdisassemble
の結果から想像して作成していたりします。
(defun alloc-fix-instance (wrapper instance-slots)
#+allegro
(excl::.primcall 'sys::new-standard-instance
wrapper
instance-slots)
#+lispworks
(sys:alloc-fix-instance wrapper instance-slots)
#+sbcl
(let* ((instance (sb-pcl::%make-instance (1+ sb-vm:instance-data-start))))
(setf (sb-kernel::%instance-layout instance) wrapper)
(setf (sb-pcl::std-instance-slots instance) instance-slots)
instance)
#+ccl
(let ((instance (ccl::gvector :instance 0 wrapper nil)))
(setf (ccl::instance.hash instance) (ccl::strip-tag-to-fixnum instance)
(ccl::instance.slots instance) instance-slots)
instance))
(defun class-wrapper (class)
#+allegro (excl::class-wrapper class)
#+lispworks (clos::class-wrapper class)
#+sbcl (sb-pcl::class-wrapper class)
#+ccl (ccl::instance-class-wrapper class))
(defun instance-wrapper (ins)
#+allegro (excl::std-instance-wrapper ins)
#+lispworks (clos::standard-instance-wrapper ins)
#+sbcl (sb-kernel::%instance-layout ins)
#+ccl (ccl::instance.class-wrapper ins))
(defun instance-slots (ins)
#+allegro (excl::std-instance-slots ins)
#+lispworks (clos::standard-instance-static-slots ins)
#+sbcl (sb-pcl::std-instance-slots ins)
#+ccl (ccl::instance.slots ins))
上記定義の関数で、standard-object
のスロット格納だけをいじることができるようになったので、hash-table-slots-class
を定義してみます。
今回のような場合、クラスのクラス定義とインスタンスのクラス定義をセットで定義することになります。
インスタンスの初期化周りもインスタンスのスロットへのアクセス方法が変更になるので、別途定義してやる必要があります。
処理系実装によっては、うまくstandard-object
の内容を引き継いでくれることもあるようですが、多分、別に定義しておいた方が良いでしょう。
また今回はslot-unbound
周りは長くなるので端折ります。
(defvar *slot-unbound*
#+lispworks clos::*slot-unbound*)
(defclass hash-table-slots-class (standard-class)
())
(defclass hash-table-slots-object (standard-object)
()
(:metaclass hash-table-slots-class))
(defmethod validate-superclass ((class hash-table-slots-class) (super standard-class))
T)
(defgeneric initialize-slot-from-initarg (class instance slotd initargs))
(defmethod initialize-slot-from-initarg (class instance slotd initargs)
(declare (ignore class))
(let ((slot-initargs (slot-definition-initargs slotd)))
(loop :for (initarg value) :on initargs :by #'cddr
:do (when (member initarg slot-initargs)
(setf (gethash slotd (instance-slots instance))
value)
(return T)))))
(defgeneric initialize-slot-from-initfunction (class instance slotd))
(defmethod initialize-slot-from-initfunction (class instance slotd)
(declare (ignore class))
(let ((initfun (slot-definition-initfunction slotd)))
(unless (not initfun)
(setf (gethash slotd (instance-slots instance))
(funcall initfun)))))
(defmethod shared-initialize
((instance hash-table-slots-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)
(defmethod allocate-instance ((class hash-table-slots-class) &rest initargs)
(alloc-fix-instance (class-wrapper class)
(let ((tab (make-hash-table)))
(dolist (slotd (class-slots class) tab)
(setf (gethash slotd tab) *slot-unbound*)))))
(defmethod slot-value-using-class
((class hash-table-slots-class) instance (slotd slot-definition))
(gethash slotd (instance-slots instance)))
(defmethod (setf slot-value-using-class)
(val (class hash-table-slots-class) instance (slotd slot-definition))
(setf (gethash slotd (instance-slots instance))
val))
これでこんな感じに動きますが、見た目は何もかわりません……。
(describe (make-instance 'foo))
;>> #<foo 402025BBD3> is a foo
;>> a a
;>> b b
;>> c c
もちろん中身はハッシュテーブルになっています。
(let ((o (make-instance 'foo)))
(describe (instance-slots o)))
;>> #<eql Hash Table{3} 4020000D23> is a hash-table
;>> #<standard-effective-slot-definition c 422020876B> c
;>> #<standard-effective-slot-definition b 4220208753> b
;>> #<standard-effective-slot-definition a 4220208723> a
インスタンスの中身を配列からハッシュテーブルにするだけなのですが、slot-unbound周りを省略したのに結構なコード量です。
上層のプロトコルが全部正しく機能するように一式定義するのは結構手間ですが、そうそうカスタマイズする部分でもないので、妥当といえば妥当かもしれません。
■
HTML generated by 3bmd in LispWorks 7.0.0
Posted 2020-11-30 16:26:06 GMT
allocate-instance Advent Calendar 2020 1日目の記事です。
Lisp系のニッチなことをテーマにアドベントカレンダーを開催したりしなかったりしていますが、今年は、allocate-instance
をテーマにしてみることにしました。
allocate-instance
とは所謂Common Lisp系のオブジェクトシステム(CLOS)のインスタンスを確保する部分ですが、AMOPでいうとInstance Structure Protocol(以降ISP)辺りの話題となります。
ISPアドベントカレンダーという名前でも良かったのですが、allocate-instance
の方がわかりやすいかなと思ってこっちの名前にしましたが、どっちにしろ参加者が集まりそうにないので五十歩百歩かもしれません。
それはさておき、AMOPのISPの説明を読むと判るように、どちらかといえばスロットのアクセスを基点として、インスタンスの物理的配置までカスタマイズするための構成が説明されています。
今回は、allocate-instance
を基点に考えてみたら面白いかもしれないというチャレンジですが、STKlosのVirtual Slots等は、スロットアクセスを基点に計算をしたりするので、ISP的にはallocate-instance
がなくても良かったりすることもあります。
ちなみにVirtual Slotsの応用は下記の記事等が参考になります。
他、複数オブジェクトをまとめて扱うような操作を実現するのもISPのカスタマイズの一種かなと思います。
allocate-instance
の拡張についてスロットアクセスからデータの物理配置までの間のプロトコルをカスタマイズするのに、スロットアクセス側に重きをおく上記Virtual Slotのようなものもあれば、逆にデータ構造側に工夫をしてスロットアクセス側はそれほどカスタマイズしないという構成も考えられます。
古典的な書籍であるThe CLOS PerspectiveにもMOPの話が出てきますが、知識表現のように項目が非常に多いけれど、それぞれの利用頻度は非常に低かったりする場合は、スロットを配列にするのではなく、ハッシュテーブルのようなものの方がメモリ効率が良いだろうというアイデアの一つとして、allocate-instance
のカスタマイズが示唆されたりしています。
しかし、この論文でも実際のカスタマイズの詳細については触れられておらず、類似の事例紹介でも大抵はallocate-instance
内部で確保するデータ構造をカスタマイズするのではなく、フックを掛けて別のデータオブジェクトにリダイレクトするようなものが殆どのようです。
フックを掛けて別のデータオブジェクトにリダイレクトするようなものとしては文末のコードのような構成が考えられます。
この場合、allocate-instance
をカスタマイズしてはいますが、デフォルトで確保したものは捨てて、別途確保しているという点で無駄なところがあります。
また、類似のものに、オブジェクトのシリアライズやORマッパーの応用がありますが、これらも確保するデータ構造はノーマルなもので、確保時のフックが眼目になります。
今回のアドベントカレンダーは、このように迂回されることが多いallocate-instance
が確保するデータ構造について正面から向き合ってみようというのが大体の主旨です。
(defpackage "e79ba511-fd06-57f8-9038-132961fa529b" (:use :c2cl))(in-package "e79ba511-fd06-57f8-9038-132961fa529b")
(defvar *hash-slots* (make-hash-table))
(defclass hash-table-representation-class (standard-class)
())
(defmethod allocate-instance ((c hash-table-representation-class) &rest args)
(let ((inst (call-next-method)))
(setf (gethash inst *hash-slots*)
(make-hash-table))
inst))
(defmethod slot-value-using-class
((c hash-table-representation-class)
inst
(slot-name slot-definition))
(gethash slot-name
(gethash inst *hash-slots*)
(slot-definition-initform slot-name)))
(defmethod (setf slot-value-using-class)
(newvalue
(c hash-table-representation-class) inst
(slot-name slot-definition))
(setf (gethash slot-name
(gethash inst *hash-slots*)
(slot-definition-initform slot-name))
newvalue))
(defclass foo ()
((a :initform 0 :accessor foo-a)
(b :initform 0 :accessor foo-b)
(c :initform 0 :accessor foo-c))
(:metaclass hash-table-representation-class))
(defparameter *the-foo* (make-instance 'foo))
(list (foo-a *the-foo*)
(foo-b *the-foo*)
(foo-c *the-foo*))
→ (0 0 0)
(setf (foo-a *the-foo*) 42
(foo-b *the-foo*) 43)
;=> 43
(list (foo-a *the-foo*)
(foo-b *the-foo*)
(foo-c *the-foo*))
→ (42 43 0)
■
HTML generated by 3bmd in LispWorks 7.0.0
Posted 2020-11-24 19:15:57 GMT
MACLISP系Lispではお馴染のキーワード引数ですが、最近だと名前付き引数等々様々な名前で色々な言語に採用されています。
そんなキーワード引数ですが、Lisp族に導入されたのは、いまから丁度40年前の秋の1980-10-05だったようです。
元々はWilliam A. Kornfeld(BAK)氏の発案のDEFUN-KEYED
からMACLISP系Lispに取り込まれCommon Lispでメジャーになった様子。
面白いのが(send foo ':x 42 ':y 30)
のようなコロン付きのシンボルは既にFlavorsのメッセージ式で広く使われていたということです。
キーワード引数はどこが大元なのだろうかと思い、ちょっと調べましたが、同時期だとAda(1983)がありました(6.4.2. Default Parameters)
上述のFlavorsようにメッセージのキーワードをキーワード引数と考えれば、Smalltalkが元祖かもしれませんが、どうなのでしょう。
キーワードといえば、&rest
、&optional
等のlambda list keywordもありますが、これがISLISPのように:rest
、:optional
とキーワードシンボルで統一されなかった理由ですが、1980年当時はキーワードシンボルというものは存在せず、:foo
もuser:foo
の略記(user
パッケージのfoo
シンボル)だったため、:rest
だとシンボルがユーザープログラム中で不意にeq
になってしまう懸念があったりしたようです。
その後Common Lispの仕様の議論でも二回程キーワードシンボルへの統一が話題にのぼりますが、タイミングが悪かったのかスルーされて今に至ります。まあ互換性を尊守したのかもしれませんが。
ちなみに、同時期に範囲コメントの#|...|#
も登場していたようです。発案者はAlan Bawden氏でしたが、#|...|#
は、最初はかなり評判が悪かった様子……。
■
HTML generated by 3bmd in LispWorks 7.0.0
Posted 2020-11-22 21:55:02 GMT
MACLISP系のLispコードのコメント作法については、セミコロンの数の使い分けから丁寧に解説されていることが多いのですが、インラインコメントが複数行になった場合の字下げの習慣については何故か忘れられていることが多いようです。
具体的には下記のようなコードの場合、
;;;; Math Utilities
;;; FIB computes the the Fibonacci function in the traditional
;;; recursive way.
(defun fib (n)
(check-type n integer)
;; At this point we're sure we have an integer argument.
;; Now we can get down to some serious computation.
(cond ((< n 0)
;; Hey, this is just supposed to be a simple example.
;; Did you really expect me to handle the general case?
(error "FIB got ~D as an argument." n))
((< n 2) n) ;fib[0]=0 and fib[1]=1
;; The cheap cases didn't work.
;; Nothing more to do but recurse.
(t (+ (fib (- n 1)) ;The traditional formula
(fib (- n 2)))))) ; is fib[n-1]+fib[n-2].
——のThe traditional formula is fib[n-1]+fib[n-2].
というコメントが二行に渡っているので二行目以降が字下げされているのが分かるでしょうか。
ANSI CLの規格票(やHyperSpec)にも書いてあったりするのですが、何故忘れられてしまうことが多いのか。
ANSI CL規格で言及されているのは、セミコロン一つのインラインコメントの場合だけですが、MIT系のコードでは複数行に渡る場合はセミコロンの数に拘らず二行目以降は下げるというのが多いようです。
PDP-10のMIDASアセンブリのコードでも同様の作法がみられるので、由来はこの辺りかもしれません。
ちなみに、JonL氏にいたっては普段の文章も二行目以降を字下げするというスタイルで書いていたりします(さすがに全部ではありませんが……)
None of Glenn's problems are due to NIL stuff.
None of the new MacLISP development is particularly NIL stuff
(multiple-values have been on the LISPM for years).
Indeed, the "intermediate" MACLISP dump cost us more than 7K of
address space, and is being dropped. As soon as agreement is
reached about XLISP, then XCOMPLR will replace the currently
bloated complr.
なんかこれ似たようなことを書いたことがあった気がするなーと思ったら9年前に書いてました。
当時はインラインコメントでの作法と思っていましたが、インラインに限定はされないようです。
■
HTML generated by 3bmd in LispWorks 7.0.0
Posted 2020-11-11 20:17:34 GMT
前回はstandard-objectとsymbolの融合として、symbol-valueにインスタンスを設定するという方法を試しましたが、今回はsymbolオブジェクトのplistをインスタンスのスロットに見立てたらどうなるかを試してみたいと思います。
(defclass foo ()
((a :initform 0)
(b :initform 1)
(c :initform 2))
(:metaclass symb-class))
(make-instance 'foo)
→ foo0
(symbol-plist 'foo0)
→ (#<standard-effective-slot-definition c 4020015753> 2 #<standard-effective-slot-definition b 40200156EB> 1 #<standard-effective-slot-definition a 4020015683> 0 class #<symb-class foo 41202C6E8B> clos::class-wrapper #(2445 (a b c) nil #<symb-class foo 41202C6E8B> (#<standard-effective-slot-definition a 4020015683> #<standard-effective-slot-definition b 40200156EB> #<standard-effective-slot-definition c 4020015753>) 3))
(with-slots (a b c) 'foo0
(list a b c))
→ (0 1 2)
(with-slots (a b c) 'foo0
(incf a 100)
(incf b 100)
(incf c 100))
→ 102
(symbol-plist 'foo0)
→ (100 101 102)
オブジェクトシステムのツールがシンボルに対して機能するがの面白いといえば、面白いですが、一連のオブジェクトシステムのツール全部をシンボルオブジェクトに対して有効に使えるようにするのはちょっと難しいのであまり旨味はないですね。
(defpackage "a1a9aa2a-8de2-5040-89dc-acd6b4de23f0" (:use :c2cl))
(in-package "a1a9aa2a-8de2-5040-89dc-acd6b4de23f0")
(defclass slotted-class (standard-class)
())
(defclass symb-class (slotted-class)
())
(defclass symb-object ()
()
(:metaclass symb-class))
(defmethod validate-superclass ((class symb-class) (super standard-class))
T)
#+LispWorks
(defmethod allocate-instance ((class symb-class) &rest initargs)
(let* ((class (clos::ensure-class-finalized class))
(instance (gentemp (string (class-name class)))))
(setf (get instance 'clos::class-wrapper)
(clos::class-wrapper class))
(setf (get instance 'class)
class)
instance))
(defmethod slot-value-using-class
((class (eql (find-class 'symbol))) instance (slotd symbol))
(get instance (find slotd (class-slots (get instance 'class)) :key #'slot-definition-name)))
(let ((lw:*handle-warn-on-redefinition* nil))
(defmethod slot-value-using-class
((class (eql (find-class 'symbol))) instance (slotd slot-definition))
(get instance slotd))
(defmethod slot-value-using-class
((class (eql (find-class 'symbol))) instance (slotd symbol))
(get instance (find slotd (class-slots (get instance 'class)) :key #'slot-definition-name)))
(defmethod (setf slot-value-using-class)
(val (class (eql (find-class 'symbol))) instance (slotd slot-definition))
(setf (get instance slotd) val))
(defmethod (setf slot-value-using-class)
(val (class (eql (find-class 'symbol))) instance (slotd symbol))
(setf (get instance (find slotd (class-slots (get instance 'class)) :key #'slot-definition-name)) val))
(defmethod shared-initialize ((instance symbol) slot-names &rest initargs)
(flet ((initialize-slot-from-initarg (class instance slotd)
(let ((slot-initargs (slot-definition-initargs slotd))
(name slotd))
(loop :for (initarg value) :on initargs :by #'cddr
:do (when (member initarg slot-initargs)
(setf (get instance name)
value)
(return t)))))
(initialize-slot-from-initfunction (class instance slotd)
(let ((initfun (slot-definition-initfunction slotd))
(name slotd))
(unless (not initfun)
(setf (get instance name)
(funcall initfun))))))
(let ((class (get instance 'class)))
(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))
)
今回は、シンボルをそのままオブジェクトに見立ててみたのですが、オブジェクトシステムは、コンテナとしてのインスタンスでディスパッチするのが便利というところがあるので、コンテナはそのままにしつつストレージの方を配列からハッシュテーブルにしてみたり、シンボルにしてみたり、という方が発展させ甲斐がありそう、という当たり前の結論に到達しました……。
■
HTML generated by 3bmd in LispWorks Personal Edition 7.1.2
Posted 2020-11-09 20:39:18 GMT
いまを去ること4年前のことですが、Lisp Meet Up presented by Shibuya.lisp #42の「Mathematicaとオブジェクト指向について」をネットで観覧していて、シンボルをオブジェクトのように扱うネタをみて、Common Lispでもシンボルをオブジェクトのストレージにできるんじゃないかなあと思ったのですが、ブログのネタ帳にメモだけ残してすっかり忘れていました。
Common Lispで似たようなものが作れるのではないかというのは、y2q_actionmanさんもブログでリアクションをしています。
y2q_actionmanさんは、シンボルを中心に新しくシステムを構築していますが、自分は既存のオブジェクト指向システムと融合できるのではないか、という感じだったので、そんな感じのものを今回書いてみました。
ちなみに、発表されていたMathematicaの当該機能はUpSetというものらしいですが、オブジェクト指向システムを簡単に実現できる柔軟な仕組みのようなものみたいです。
gentemp
で生成するallocate-instance
で生成したオブジェクトを生成したシンボルに代入する——だけ、なので、make-instance
にフックでも仕掛ければ終了、ともいえますが、インスタンスのオブジェクトに名前(シンボル)を保持するように拡張するという無駄に複雑な方向で実現してみたいと思います。
具体的には、allocate-instance
で確保するベクタの長さを一つ延して先頭に名前を詰めることにします。
こんなクラス定義があるとすると、
(defclass foo (symb-object)
((a :initform 0)
(b :initform 1)
(c :initform 2))
(:metaclass symb-class))
(make-instance 'foo)
→ #<foo foo0> (setf (slot-value foo0 'a) 42)
→ 42
(get 'foo0 'a)
→ 42
(symbol-plist 'foo0)
→ (c 2 b 1 a 42)
——というような挙動にしました。
融合というからには、(setf get)
でのシンボルのplistへの書き込みもオブジェクトと同期させたいところですが、get
を変更するのは大袈裟なので今回は見送っています。
(defpackage "2cd9cb9c-2302-5cc4-9c4c-aafd83e01db4" (:use :c2cl))
(in-package "2cd9cb9c-2302-5cc4-9c4c-aafd83e01db4")
(defclass slotted-class (standard-class)
())
(defclass symb-class (slotted-class)
())
(defclass symb-object ()
()
(:metaclass symb-class))
(defmethod validate-superclass ((class symb-class) (super standard-class))
T)
(defmethod compute-slots :around ((class symb-class))
(let ((slotds (call-next-method)))
(dolist (s slotds)
(setf (slot-definition-location s)
(1+ (position s slotds))))
slotds))
#+LispWorks
(defmethod allocate-instance ((class symb-class) &rest initargs)
(let* ((class (clos::ensure-class-finalized class))
(storage (sys:alloc-g-vector$fixnum
(1+ (length (class-slots class)))
clos::*slot-unbound*))
(instance (sys:alloc-fix-instance (clos::class-wrapper class)
storage))
(name (gentemp (string (class-name class)))))
(setf (elt storage 0) name)
(setf (symbol-value name) instance)
instance))
#+LispWorks
(defun instance-name (instance)
(elt (clos::%svref instance 1) 0))
(defmethod initialize-instance :after ((inst symb-object) &rest initargs)
(let* ((class (class-of inst))
(name (instance-name inst)))
(dolist (slot (class-slots class))
(let ((slot-name (slot-definition-name slot)))
(setf (get name slot-name)
(and (slot-boundp inst slot-name)
(slot-value inst slot-name)))))))
(defmethod slot-value-using-class
((class symb-class) instance (slotd slot-definition))
(standard-instance-access instance
(1+ (position slotd (class-slots class)))))
(defmethod (setf slot-value-using-class)
(val (class symb-class) instance (slotd slot-definition))
(setf (get (instance-name instance) (slot-definition-name slotd))
val)
(setf (standard-instance-access instance
(1+ (position slotd (class-slots class))))
val))
(defmethod print-object ((instance symb-object) stream)
(print-unreadable-object (instance stream :type T)
(format stream "~S" (instance-name instance))))
allocate-instance
でsymbol
を生成してしまうというのが、一番直截的な感はありますが、色々なプロトコルでsymbol
を扱えるようにするのが面倒で今回は妥協しました。
いつかチャレンジしてみたい気もしますが、Common LispのMOPは、そもそもstandard-object
から派生したオブジェクト以外のもの扱うことはできるのでしょうか。
■
HTML generated by 3bmd in LispWorks Personal Edition 7.1.2
Posted 2020-11-08 07:03:01 GMT
Lispの述語(predicate)の名前の末尾には大抵p
が付いていて、これが一つのLisp文化を形成していたりもしますが、atom
とnull
には、末尾には何故かpがついていません。
方言によっては、整合性を持たせるためにatomp
や、nullp
としているものもありますが、大抵は、歴史的理由として、そのままatom
や、null
を継承することが多いようです。
そんな日々でしたが、atom
とnull
にpが付かなかった理由の仮説を思い付きました。
atom
や null
は Propositional Expressions
として記述する気でいたから説Recursive Functions of Symbolic Expressionsand Their Computation by Machine, Part Iや、LISP I Programmer's manualには、
Propositional Expressions
というものが、述語とならんで解説されていますが、いまでいうブーリアンを返す式です(複合可)。
b.Propositional Expressions and Predicates. A propositional expression is an expression whose possible values are T(for truth) and F(for falsity).
We shall assume that the reader is familiar with the propositional connectives ∧(“and”),∨(“or”), and¬(“not”).
Typical propositional expressions are:
x < y
(x < y)∧(b = c)
x is prime
ここで注目したいのは、x is prime
という形式ですが、atom
や、null
はこの形式にぴったりではありませんか。
flat[x] = [x is null → x;
x is atom → list[x];
T → append[flat[car[x]];
flat[cdr[x]]]]
——と記述するのであればp
は不要です。
しかし、残念ながら以降の文献にはis
形式は登場せず用例の解説も皆無です。
predp[x]
という述語形式に吸収されてしまったのか、もしくは記法としての整合性がなかったのか……。
さらには、同文献中にatom[x]
の用例が解説されており、当初はx is atom
形式だった、という痕跡もなく、いまいち説得力もありません。
is
形式の謎の解明が俟たれます。
■
HTML generated by 3bmd in LispWorks Personal Edition 7.1.2
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のcoerce
をdisassemble
してみると、変換の後に指定した型指定子で結果オブジェクトのタイプチェックをしているからのようです。
なるほど、確かに後でチェックすれば間違いはない。
逆に、SBCL等は何の型に変換するかだけを見ているので、型指定子がlist
のサブタイプと判定された後はチェックしていません。
SBCLにもバグ報告しようかなと思ったりはしますが、返り値の型が指定より緩い分には返り値の型チェックをするコードを追加すれば良く、大した害もないですし気が向いたら報告します……。
■
HTML generated by 3bmd in LispWorks Personal Edition 7.1.2
Posted 2020-10-27 16:47:47 GMT
自作のライブラリで、(coerce "foo" 'cons)
や、(coerce "" 'null)
のようなコードがAllegro CLでエラーになるので、おやもしかして処理系依存だったかと思いANSI規格を確認してみましたが、
sequenceIf 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のcoerce
をdisassemble
してみると、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*
自体は、適切にリストに変換できるようですが、前段では、cons
やnull
も出てこずにlist
としか比較していないので、すりぬけてエラーになっているように見えます。
(excl::vector-to-list* "")
→ NIL(excl::vector-to-list* "foo")
→(#\f #\o #\o)
list
のサブタイプはcons
やnull
以外にも複合した指定があるので、別途サブタイプの判定をきっちりしないと
(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
Posted 2020-10-17 21:13:02 GMT
LispWorksのエディタがHemlock由来というのは、LispWorksの歴史のページにも記載されているのですが、フォークされたのも1987年あたりのようですし、原型は留めていないのかと勝手に想像していました。
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と似ているのか具体的に眺めたことはないなあと思ったので、ちょっと突き合せて眺めてみました。
LispWorksに付属してくるエディタのファイルは94、cmucl付属のHemlockのファイルは111ありますが、30ファイルの名前が一致。
外部シンボルで、関数か変数の束縛があるシンボルは、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
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-package
やin-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-file
やload
で変なことが起きがちになる、仕様のクリーンナップというよりはコンパイラ仕様で議論すべきだった、等々、議論が発散してまとまらなかったようです。
KMPが提案してANSI CL規格に入らなかったものは結構ありますが、defsystem
、in-syntax
等は、後世の人達が結局ライブラリとして自作することになったので、標準化されると良かったなと思うことしきりです。
■
HTML generated by 3bmd in LispWorks Personal Edition 7.1.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-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の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
Posted 2020-09-29 01:28:16 GMT
Common Lispには、prog1
、prog2
、progn
とありますが、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
Common Lispには、prog1
、prog2
、progn
とありますが、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
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
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 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のフォームと組合せ可能なものとして、aref
、bit
、sbit
があるので、
(setf (apply #'aref))
(setf (apply #'bit))
(setf (apply #'sbit))
上記の関数フォームに組合せ可能なものとして更にvalues
(setf values)
さらに組合せ可能なものとして、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
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
の活用です。
実際に最近の処理系でも動くように書き直すと下記のようになるでしょうか。
(ついでにloop
のthereis
もfind
に置き換え)
(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))
アナフォリックマクロのit
、when-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を使うまでもない、という感もあるのですが、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)))))
のようなものを書いてしまっても良いでしょう。
provide
、require
と論理パスの組み合わせ論理パスを設定しておけば、あまり利用することもないrequire
やprovide
の機能を活かすことも可能になります。
上記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
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のページで公開されていたようです。
公開されたのは、
の四つで、厳密にいうと他にも草稿はあるようですが、Common Lispの草稿として資料に登場するのは大体この四つです。
興味深いのは、完成版に近いMary Poppins Editionよりは、最初期のColander Editionかと思いますが、例えば、*macroexpand-hook*
は、displace
を導入する目的で導入された、と明記されていたりします。
displace
は主にインタプリタのマクロ展開を速くする機構で、一度展開した展開形を保持するという機構です。
この機能ですが、ANSI CLに至るまでに可搬的に実現するのが困難という結論になり、ANSI CLでは何を目的とした機能なのかの説明もぼんやりしたものになっています。
時系列に並べると
displace
のためとなるのですが、どんどん非推奨な機能に追いやられていることが分かります。
他、スペシャル変数に耳当てがない等、お馴染の慣習も徐々に確定していったことが分かります。 (ちなみに耳当てをつけるのは投票で可決され、定数には特に飾りを付けない、というのも同じ投票で可決されています)
ANSI CL規格だけからは導入の動機が良く分からない機能は結構あるのですが、最初期まで遡ることが可能だと経緯がより鮮明に見えてきます。
現在でも、投票の詳細については資料がオンラインにないのですが、投票の詳細について公開されるとかなり面白いことになると思います。
■
HTML generated by 3bmd in LispWorks Personal Edition 7.1.2
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₂のプログラマの感覚からすると、()
+シンボルという唯一であることが保証されたオブジェクト
の組み合わせで機能するため、定義の度に新しい括弧を定義するのに近いものとなります。
上記で定義した【
の文脈でいうと、(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
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.gitcd bin
export PATH=.:$PATH
makeright x
上記でビルドが完了すると、maiko
ディレクトリの直下のマシンアーキテクチャ名のディレクトリ中にldex
が生成されていますので、medleyのsysoutイメージを指定して起動できます。
./linux.x86_64/ldex full.sysout
sysoutイメージは、interlisp.orgに記載のあるRon’s Interlisp dropboxでも数種類配布されているので、適宜利用してみるのも良いでしょう。
とりあえず、手元では、古いmedleyで動かしていたイメージが起動しました。
OSS化されたということで、処理系のソース等も読めるようになるのかもしれません(既に読める?)
個人的にはLOOPSを触ってみたいと思っています。
■
HTML generated by 3bmd in LispWorks Personal Edition 7.1.2
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式等々……)
■
HTML generated by 3bmd in LispWorks Personal Edition 7.1.2
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
に似た形式です。
q
はquote
のq
ですが、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)
まあでも一つの可能性としては面白いかもしれません。
リスト以外の束縛部のデータといえば、最近だと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)
■
HTML generated by 3bmd in LispWorks Personal Edition 7.1.2
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では値を返すスタイルが古くから基本となっていますが、副作用目的で複数の式をまとめる記述としてprog
やprog2
というフォームも古くから存在しました。
任意の複数の式をまとめるフォームということで落ち着いたのが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
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
として用意されていますが、処理系によって記述方法はまちまちです。
そんな日々でしたが、普段から論理パスを使っているとエディタでファイルを開く際にも使いたくなります。
論理パスでファイルを開けたりしないもんかなと、試しに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
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環境の方が特殊になりつつある昨今なので当然といえば当然ですが、嬉しいところですね。
等々は過去のバージョン同様の制限となっています。
5時間の制限と初期化ファイルを手動で読み込ませる必要があることについては、大して苦労することはないのですが、常用するには利用メモリの制限が結構厳しい。
例えば、ironclad
等はビルドに結構負荷が掛る方ですが、こういうのは途中で終了となってしまいます。
コンパイルできる範囲でちまちまfaslを生成、処理系を立ち上げ直してロード、という作戦で乗り切ることも場合によっては不可能ではありませんが結構手間ですね。
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
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
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
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にも多数ありますが(loop
、format
等)、中途半端なことになりがちな気がします。
(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では問題ないですし、コードの共用という面では別の文字に置き換えたりせずに、\
でエスケープの方が良いかもしれません。
Common LispでS式正規表現だと、cl-irregsexpというのがあります。
IrRegular Expressionsも似たような名前ですが、なんか付けたくなるような名前なのでしょう。
Uncommon Lisp(R3RS Scheme)系の命名に似てますね。
■
HTML generated by 3bmd in LispWorks 7.0.0
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
Posted 2020-04-02 15:44:00 GMT
Practical Scheme サイト20周年おめでとうございます!
といっても実は半年過ぎてしまっていたようなのですが……。
しばらく前から準備していた Schemeのページ をぼちぼちアナウンスすることにする。
今はまだ、公開できそうなSTkの拡張モジュールを置いておくだけだが、 将来はいろんな洗脳ドキュメントも用意して、Scheme言語布教の総本山とするのだはっはっは。
ライブラリさえ揃えば、SchemeもPerlに遜色無い使い勝手になると思うんだよな。
現在の日本のLispコミュニティで目立った活動をしているところといえば、Shibuya.lisp の月一のミートアップや、不定期開催の関西Lispかと思いますが、 Practical Schemeが存在しなければ、約十年前あたりのプログラミング言語ブームの時に Shibuya.lisp がそこそこの規模で立ち上がることはなかったのではないかと思います。
当時のShibuya.lisp立ち上がりの背景には、GaucheNight(2007) 及び gauche.night(2008) の参加者グループのコミュニティ立ち上げへの手応えみたいなものがあったと思いますが、その地盤を固めていたのは、Practical SchemeやWiLiKiでした。
この二十年で色々なLisp系サイトが立ち上がっては消えていきましたが、二十年間安定した基盤として維持され続けてきたというのは、やはり凄いです。
今後も末永くPractical SchemeのコンテンツやWiLiKiを利用させて頂けると嬉しいです。
■
HTML generated by 3bmd in LispWorks 7.0.0
Posted 2020-03-31 17:46:13 GMT
ACM Digital Library が2020-06-30まで無料だそうです。
この機会にLisp系で読んでおきたいお勧めといえば、ACM SIGPLAN Lisp Pointers でしょう。
Lisp Pointers は1987年から1995年までのLisp会報誌といった感じのものです。
等々、内容が濃くて面白い読み物です。
幸か不幸か1995年あたりから古典的なLispはそれほど進歩がありませんので、今でも活用できるような内容も多いと思います(マシンパワーの違いこそあれ)
当時はエキスパートシステムの組み込み言語や、構文拡張等で需要が高かったのか、コードウォーカーの記事がそこそこあるのが、特徴かもしれません。
(Richard C. Waters、Pavel Curtis、Bill van Melle各氏の記事)
古典マクロのコードウォーカー入門記事としては貴重かもしれません。
■
HTML generated by 3bmd in LispWorks 7.0.0
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
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
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に申請するというのも良さそうです。
特に“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
Posted 2019-12-31 15:13:25 GMT
毎年振り返りのまとめを書いているので、今回も書きます。
今年は何故か自分の中ではMOPブームが到来し、後半は特にMOP的な拡張をして遊んでいました。
ECLOSを始めとして、1990年代にはMOPの拡張が色々と試行錯誤されていたようなので、これを暫く追試して行こうかなと思います。
どうもMOPは学習の取っ掛かりがないという印象があり、どう学んでいったら良いのか良く分からない状況が自分も長く続きましたが、結局のところ沢山書けば色々憶えてくるようです。
とりあえず役に立つ応用を考えたりするのは後回しで量を書いていれば段々見通しが付いてくるように思えました。
思えばマクロもナンセンスなものを沢山書いていましたし、自分はとりあえず量を書かないことには身に付かない質かもしれません。
Common LispのMOPも中途半端だったり発展途中(で四半世紀進歩がない)だったりするので、その辺りの状況もまとめてみたいと考えています。
今年書いた記事は38記事でした。
年々記事の量が減っていますが、ネタがない訳ではなく記事にするのが面倒というところです。
世間的にもLispの記事を目にすることは大分少なくなりました。大分ブログというツールも廃れた感がありますが、2020年はもうちょっと書いていきたいと思います。
LispWorksを購入してから早四年半。
それまでSBCL+SLIMEをメインに使っていましたが、購入を機にLispWorksのIDEメインとしました。
しかし、いまだにSLIMEで便利だった機能を越えられていないところがあります。
LispWorksの方が便利なところも多いのですが、2020年は両者の良いとこ取りな環境を構築していきたいところです。
LispWorksでの職場の社内ツール作りもあいかわらず継続していて、利用者もアプリの種類も増えました。
折角なのでLispWorksのCommmon SQLやKnowledgeWorksの機能も使ってみていますが、デザインは古いもののそこそこ便利に使えています。
DBや推論機能はメタクラスが定義されており、これらをmixinして連携させるのが楽しいといえば楽しいです。
ウェブ屋さんが沢山在籍する職場では何かGUIのツールを作成するとなれば、ウェブアプリになると思いますが、そうでなければ、LispWorksみたいなアプリ作成機能もそこそこ有用かなと思います。
特に社内でしか使わないとなれば、ウェブアプリのメンテもそこそこ面倒なので。
2019年の計画では、コンディションシステムアドベントカレンダーを開催したいと思っていましたが、ちょっと試しにQiitaを退会してみたら、記事がごっそり消えてしまったので、アドベントカレンダーを開催するのがめんどうになってしまい2019年はスキップしてしまいました。
コンディションシステムやMOPは今後も深追いしていきたい所存です。
また、1980年代のエキスパートシステムブームとLispについて大体見通しが付いてきたので、2020年は、第二次AIブームでのLispの活躍とは何だったのか等々まとめてみたいと考えています。
■
HTML generated by 3bmd in LispWorks 7.0.0
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
Posted 2019-12-17 17:58:29 GMT
構造体の配列を作成する方法として、
があるようですが、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
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
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実装を確認してみましたが、やはり:around
でlocation
を設定していました。なるほど。
compute-slots
の:around
を乗っ取るには、さらなる:around
を定義するしかないわけですが、どうも可搬性のためにはいじってはいけない場所のようです。
とはいえ、インデックスの設定方法が分かったので、試しに今回は、X3J13-88-003R-DRAFTのコード例にある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-slots
とslot-definition-name
とslot-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のマニュアルのソースを眺めていて、こんな記述をみつけました。
(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
Posted 2019-12-04 20:14:19 GMT
最近はECLOSを再現して遊んでいますが、今回は、self-referent-class
というメタクラスを再現してみます。
なお、self-referent-class
については、ECLOSの論文に詳しいので参照してください。
説明はあるとはいえ、マニュアルや仕様書ではないので、実際実装してみようとすると良くわからないところはありますが、インスタンスの初期化時に他のスロットを参照できること=自己参照、ということのようです。 論文の解説によれば、大体下記のような挙動になります。
self
という変数で参照可能(slot-name self)
という形式で自身の式より左側のスロットを参照可能creator
やparent
の機能なのか判然としない(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
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)))
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
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.lisp
のshould-use-jump-table-p
の中に記述されているようで、
のようです。
(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
Posted 2019-11-17 15:55:00 GMT
前回は、ECLOSが提供するdefclass
の:metaclass
オプション省略時のメタクラスの自動算出について書きましたが、今回はTiny CLOSの流れを汲むSTklos系のメタクラスメタクラスの自動算出です。
Tiny CLOSが動くScheme処理系は結構あるようですが、より処理系と統合されたり構文が改良されたりしているのがSTklos系のようです。
上記あたりがSTklos系のようですが、Tiny CLOSの系譜をいまいち把握できていないので外しているかもしれません。
上記の継承関係は、
(defclass stklos (tiny-clos clos dylan) ())
(defclass guile (stklos) ())
(defclass gauche (stklos guile) ())
(defclass sagitarius (gauche) ())
っぽいですが。
とりあえず、今回のメタクラスの自動算出に関しては、上記処理系で共通なのでSTklos系ということにしましょう。
Gauche: 7.5.1 クラスのインスタンシエーション等に解説されていますが、
define-class
に:metaclass
が明示されていればそれを使うとなります。
メタクラスのクラス順位リスト中をどう調べるのかは、コードは簡単なので詳細はコードを眺めた方が早いでしょう。
下記は、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-class
、b-class
、c-class
とメタクラスを定義し、a-class
をメタクラスとしたa
、b-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
Posted 2019-11-16 21:47:29 GMT
うまいタイトルが考えつかなかったので、「ECLOSのメタクラス継承」というタイトルになりましたが、ECLOSが提供するdefclass
の:metaclass
オプション省略時のメタクラスの自動算出についてです。
なお、ECLOSについては、
に詳しいので参照してください。
Common Lispでは、カスタマイズしたメタクラスをdefclass
で利用する際には明示的に:metaclass
を指定しないといけないのですが、結構めんどうです。
上記文献によれば、ECLOSは、
defclass
に:metaclass
があればそれを使う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-class
、b-class
、c-class
とメタクラスを定義し、a-class
をメタクラスとしたa
、b-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
Posted 2019-11-10 19:19:05 GMT
前回はとりあえず、インスタンスのアクセスにslot-value
を使わないようなメタクラスを定義してみたりしましたが、slot-value
排除を推進してインスタンスの初期化にも細工してみたいと思います。
slot-value
経由でのアクセスの廃止=カプセル化という応用で考えてみます。
本当はインスタンスの初期化からもslot-value
を排除したかったのですが、気付いたらslot-value
を自作していた感があったので、slot-value
は初期化メソッドの内部でしか利用させないという制限を付けることにしました。
制限の手段としては安直にクラスに class-encapsulated-p
を定義して管理します。
slot-value...
系はclass-slots
の情報を元に動作することになるので、大元のclass-slots
に制限を掛けてやることにします。
今回は、class-encapsulated-p
が T
の時はclass-slots
がエラーを発するようにしてみました。
オブジェクトの初期化をカスタマイズするには、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
での制御としましたが、スロットをカスタマイズする方法もありそうです。
ちなみに、カプセル化の方法として、
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
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
Posted 2019-10-14 19:51:18 GMT
先日、RedditでAllegro CLのstandard-object
のスロットのアクセスを高速化するオプションについての投稿があり、記事を読んでみたのですが、
第一感としては、何故standard-instance-access
を使わないのだろうか、というところでした。
それとは別にfixed-index
を新機能として紹介していますが、どうも以前にみたことあるなと思ったので、古いAllegro CL 4.3(1996)を確認してみましたが、やはり存在しました。
(パッケージは、clos
→excl
で移動した模様)
昔からの隠し機能が公になった、というところなのかもしれません。
;;; 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-access
と slot-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-slot
はfixed-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ではバックエンドのベクタをアクセスする方法が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では、アクセサもslot-value
も standard-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 consedEvaluation 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
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
という名前が誤解を招くload
でlisp
ファイルを読み込めば:execute
load
でfasl
ファイルを読み込めば:load-toplevel
位でしょうか。
昔のLispでは、faslを読むのにはfasload
という専用関数が使われ、コンパイルしていないファイルにはload
を使ったりしていたようですが、Common Lispでload
に一本化されたようですね。
以上、eval-when
の考察でした。
■
HTML generated by 3bmd in LispWorks 7.0.0
Posted 2019-10-06 16:39:24 GMT
伝説の処理系であるNILですが、先日ソースが発掘され、Software Preservation Groupで公開されたようです。ありがたや!
このブログでもNILについて何度か記事を書いていますが、要約すれば、MITがMACLISPの後継として作ったLISP処理系で、Common Lispの先祖の一つでありつつ後にNILもCommon Lisp化した処理系です(ややこしい)
NILの概要については、
あたりが一番まとまった記事かなと思います。
早速ソースを眺めてみましたが、雑感をメモしておこうかなと思います。
LOOP
が多用されている。LOOP
で書かれている(CAR
、CDR
、MAPCAR
…)LOOP
のメンテナであるGSB氏が書いているからかもしれない。FEATUREP
がある#T
がある(真値)*
パッケージがある。FLEXURES
がある(スペシャル変数のクロージャー)TAGBODY
の定義でタグ環境の表現にFlavorsが使われている-*- ... -*-
でお馴染み)で指定するらしい"This is NIL including the H compiler"
(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
Posted 2019-09-09 20:09:30 GMT
macOSのLispWorks 7.1をX11 gtk+2のGUIで使おうと色々と試行錯誤していましたが、finkのgtk+2であれば使えばどうにか使えることが分かりました。
何故finkなのかというと、
ので消去法でfinkなのですが、他のパッケージシステムで上手く動かす方法を探求するのも骨が折れるので、finkを導入することで手を打つのが吉でしょう。
macOS版LispWorksのgtk版自体がおまけで付いてきているような感じなのですが、果してgtk版のユーザーっているのでしょうか。
macOS版LispWorksのgtk版は、デフォルトではインストールされません。インストーラにgtk版インストールのオプションがあるので有効にしてインストールしましょう。
finkも最近勢いがないようですが(昔からか)、現時点で最新のmacOS 10.14.6でも使えます。
ただ、brewやportsのような手軽さでインストールすることはできないようです。
下記のリンクを参考にソースインストールを実行しますが、インストールにはJDKが必要です(JREではなく)
JDKを導入した後に、配布されているhelper scriptを実行し、質問にポチポチ答えて行けば、一時間程でインストールできるでしょう。
fink自体のアップデートもできたら、gtk+2のインストールします。
$ /sw/bin/fink install gtk+2
一発でOKですが、macOS 10.14だとバイナリ配布はしていないようなので、暫しビルドに時間が掛ります。
$ 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
Posted 2019-08-15 15:25:34 GMT
Common Lispのdefpackage
というかパッケージ関係の関数全般ですが、intern
やexport
するシンボルの名前の表記に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"
等とそのまま書く流儀です。たまに通な人がこの方式で書いてることがあります。
しかし、そんな特殊な状況のことを考えてコーディングする必要ってあるんですかね?
foo
、bar
等とそのまま書く流儀です。
一番すっきりしてて良さそうですが、案外少ないです
defpackage
したパッケージに余計なシンボルがインターンされるdefpackage
は、大抵cl-user
でされることが多いですが、cl-user
は作業用パッケージなので、多少汚染されても良いんじゃないかという気もしますね。
:foo
、:bar
等と書く流儀です。
よく見かける流儀です。
(defpackage :foo)
、(make-package :foo)
vs (defpackage #:foo)
、(make-package '#:foo)
等々キーワードパッケージが汚染されると開発環境のキーワード補完でゴミが補完されることが多くなるので、案外cl-user
が汚染されるより嫌かもしれないですね。
#:foo
、#:bar
等と書く流儀です。
これも割と見かける流儀です。
#:
がウザい見た目がウザいので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
するのが吉なのかなあ等々考えていますが、作業用パッケージを作成するなら、余計なシンボルのインターンについても考えなくて良さそうですね。
ちなみにこの記事を書くにあたって、文字列、シンボル、キーワード、
読み取りスピード的にも普通のシンボルで書くのが有利っぽいですが、極端なことをしない限りは有意な差にはならないでしょう。
以上、特にまとまりもない記事でした。
■
HTML generated by 3bmd in LispWorks 7.0.0
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
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の原初を紐解いていくという内容なので、とてもお勧めです。
先日は、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*バッファに結果が表示されるようにしてみました。
#!/bin/shINFILE=$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
(defun lisp1.5:load ()
(interactive)
(let ((compile-command (concat "~/bin/load-lisp1.5 " (buffer-file-name))))
(compile compile-command)))
これで若干対話的にコードが書けるようになったので、適当に試してみます。
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 fileHALT 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
Posted 2019-06-14 18:48:50 GMT
Rubyは、Lispである、いや違う。Schemeこそ至高のLisp、いやLispじゃない等々、「○○がLispであるか、そうでないか」は自転車置場の議論ネタとしては定番です。
個人的にこの10年位、MACLISP系方言を中心に色々な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
Posted 2019-05-27 18:01:15 GMT
Sun(今やOracle)のSPARCプロセッサにはLisp向けにタグ命令が実装されている(いた)という話を耳にされたことはないでしょうか。
具体的には、TADDCC
、TSUBCC
系の命令で、タグ付きポインタの演算を支援する機能です(ちなみに残念ながら現在では非推奨の機能らしい)。
それはともかく、ウェブを検索したら、当時の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 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
となり、アリティのチェックが省略されるようです。
さすが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
Posted 2019-05-03 22:17:38 GMT
以前にLucid Common Lispが動く環境を構築していたのですが、久し振りに起動してみようと思ったところ全く手順を忘れていたのでメモしておきたいと思います。
Lucid CLとLucid EmacsのSunOS/SPARC版は両方ともArchive Team: Various Lucid Packagesに含まれているので探してみましょう。
qemu 3からvlan
オプションが廃止されたようで、netdev
オプションを使うことになりましたが、qemu-system-sparc
で上手く指定できなかったので、しょうがなく2系統を使うことにしました。
ソースからは下記のようにオプションを指定してビルド可能です。
$ ./configure --target-list=sparc-softmmu
$ make
QEMU/SunOS 4.1.4のセットアップについては下記を参考にしました。
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-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
のようなオプションで起動します。
起動の手順がめんどうなので、expect
でスクリプトを作成し、それで起動します。
私の手元では、何故かシングルユーザーで起動してからマルチユーザーにしないとおかしなことになりますが、とりあえずスルーすることにします。
#!/bin/shcd /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\"
"
ssh
は存在しない時代ですが、rsh
は存在します。
telnet
より便利なので、rsh
の設定をしておきます。
これまでの設定の場合、
$ rsh 10.0.2.15
で接続可能です。
Lucid CLは、ターミナルでも使えますが、Lucid CL 4.0あたりだとLucid Emacsと組み合わせて使うことが想定されているようで、このLucid EmacsがX環境でしか起動しないので、Xの環境も構築することにします。
SunOSのウィンドウをリモートで表示したいのですが、昔と違ってセキュリティ周りが色々厳しくなっているので、色々と面倒なので、個別のVNCサーバを起動して、そこで表示させることにします。
#!/bin/shvncserver -geometry 1600x900 :41 -listen tcp
export DISPLAY=$(hostname):41.0
xhost +
openbox
上記では、41番ディスプレイを指定した例ですが、-listen tcp
というのがミソで、明示的にこの指定がないとローカルからしか接続できません(リモートホストのアプリがディスプレイを開けない)
(require 'ilisp)