#:g1

Lisp Pointersを読め!

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

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

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

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

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

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

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

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


HTML generated by 3bmd in LispWorks 7.0.0

CLでSRFI 169

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

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

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

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

移植について

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

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

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

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

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

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

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

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

導入

Ultralispに登録してみたので、

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

してあれば、

(ql:quickload :srfi-169)

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

まとめ

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


HTML generated by 3bmd in LispWorks 7.0.0

CLでSRFI 175

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

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

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

導入

Ultralispに登録してみたので、

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

してあれば、

(ql:quickload :srfi-175)

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

動作

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

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

(ascii-alphabetic? #\1) → nil

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

まとめ

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

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


HTML generated by 3bmd in LispWorks 7.0.0

Ultralisp使ってみた

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

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

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

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

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

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

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

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

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

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

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

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

Ultralisp使用感とまとめ

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

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

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


HTML generated by 3bmd in LispWorks 7.1.2

2019年振り返り

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

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

Lisp的進捗

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

ブログ

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

LispWorks

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

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

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

2020年やってみたいこと

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

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

過去のまとめ


HTML generated by 3bmd in LispWorks 7.0.0

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

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

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

(comment 0 1 2)
→ nil

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

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

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

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

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

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

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

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

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

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

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

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

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

まとめ

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


HTML generated by 3bmd in LispWorks 7.0.0

MOPでSoA

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

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

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

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

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

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

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

動作

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

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

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

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

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

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

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

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

実装

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

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

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

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

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

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

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

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

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

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

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

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

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

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

まとめ

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


HTML generated by 3bmd in LispWorks 7.0.0

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

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

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

動作

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

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

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

実装について

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

実装

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

まとめ

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


HTML generated by 3bmd in LispWorks 7.0.0

MOPで隠しスロットの実現

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

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

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

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

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

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

faceted-slot-class

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

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

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

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

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

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

実装

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

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

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

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

(ql:quickload :closer-mop)

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

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

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

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

(defgeneric compute-instance-size (class))

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

まとめ

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


HTML generated by 3bmd in LispWorks 7.0.0

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

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

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

  • doc/manual/implementation.ccldoc

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

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

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

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

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

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

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


HTML generated by 3bmd in LispWorks 7.0.0

Older entries (2323 remaining)