なんとなく古いコードを眺めていて、ifの述語部にifが出てくるのを発見。
最近のコードにはあまり見掛けない気がするのですが、値を返すプログラミングスタイル(昔は適用型言語とも呼ばれた)らしいといえば、らしいので、どれくらい使われているのかざっと古いコードを検索してみました。
古いコードでは10万行中20〜30例位の頻度のようです。

具体的にどんなものがあるかというと、下記はNILのデバッガコマンドのコード中のもので、Zippy the Pinheadからの引用を表示するyowという謎コマンドですが(何故デバッガの機能として存在するのか)、 コマンド引数がnilなら、ランダムに引用し、引数で引用の番号が指定されているならば、範囲内かどうか調べ、表示するかエラーとするか、というものです。

(defun com-yow (arg &aux (n (simple-vector-length *yow*)))
  "Prints a Zippy the Pinhead quotation.
With no argument, one is selected at random;  with an argument, selects
that numbered one."
  (if (if (null arg) (setq arg (random n *yow-rs*)) (< -1 arg n))
      (dfmt "~&~A~%" (svref *yow* arg))
    (dfmt "  Out of range -- I know about ~D quotations.~%" n)))

類似の例としては、(if (or (and A B) ...や、(if (cond ...がありますが、(if (or (and A B) ...あたりは、たまに出来ちゃっていることもあるようなないような。

結構慣れないとぱっと思い付いて書くこともできなさそうですが機会があれば使っていきたいですね。

■

HTML generated by 3bmd in LispWorks 7.0.0

Lispのコードを編集している時に式を外側に持ち出す時に囲んでいるスコープの変数も一緒に連れて行きたいことがたまにありました。

(defun foo (&aux x)
  (list x x x x))

の(list x x x x)をコピーする際に、

(let ((x x))
  (list x x x x))

のように式がコピーできたら良いなというところですが、実験で変数環境を展開する無意味なマクロを作成している時に、これを応用すれば環境ごとコピーできるエディタコマンドが作成できるのでは、と思ったので作成してみます。

とりあえず、変数環境を展開する無意味な無意味なマクロとはこのようなものです。

#+LispWorks
(defmacro bind-env (&body body &environment env)
  `(let (,@(mapcar (lambda (x)
                     (if (walker:variable-special-p x env)
                         `(,x ,x)
                         `(,x ,x)))
                   (walker::env-lexical-variables env)))
     '.bind-env.
     ,@body))

LispWorks用ですが、大体の処理系に対応するAPIは備わっていますので移植は簡単です。
こんな感じに使いますが、マクロを展開すると、bind-envの周りの変数をletのフォームとして組み立てます。

(let ((x 42))
  (bind-env
    (list x x)))
===>
(let ((x 42))
  (let ((x x)) 
    '.bind-env.
    (list x x)))

エディタコマンドの作成

上記の謎マクロによって環境をletの式として表現できるようになったので、これをエディタのコマンドにしてみます。
LispWorksのHemlock用のコードですが、環境込みでマクロ展開した部分式をletで囲んだ文字列を作成するだけなので、SLIME等でも作成できると思います。

(defun toplevel-form-to-string (point)
  (let (str form-beg form-end)
    (with-defun-start-end-points (beg end :errorp nil) point
      (setq str (points-to-string beg end))
      (setq form-beg (copy-point beg))
      (setq form-end (copy-point end)))
    (values str form-beg form-end)))

(defun form-to-string (point)
  (let (str form-beg form-end)
    (save-excursion
      (with-point ((beg point))
        (setq form-beg (copy-point beg))
        (forward-form-command 1)
        (setq str (points-to-string beg (current-point)))
        (setq form-end (copy-point (current-point)))))
    (values str form-beg form-end)))

(defmacro bind-env (&body body &environment env)
  `(let (,@(mapcar (lambda (x)
                     (if (walker:variable-special-p x env)
                         `(,x ,x)
                         `(,x ,x)))
                   (walker::env-lexical-variables env)))
     '.bind-env.
     ,@body))

(defun extract-binds (form)
  (labels ((%extract-binds (form)
             (cond ((atom form) form)
                   ((and (consp form)
                         (eq 'let (elt form 0))
                         (equal ''.bind-env. (elt form 2)))
                    (return-from extract-binds (elt form 1)))
                   (T (%extract-binds (print (car form)))
                      (%extract-binds (cdr form))))))
    (%extract-binds form)))

(defcommand "Save Form With Env" (p)
     "Save Form With Env"
     "Save Form With Env"
  (declare (ignore p))
  (multiple-value-bind (killed killed-beg killed-end)
                       (form-to-string (current-point))
    (with-point ((point (current-point)))
      (multiple-value-bind (whole whole-beg whole-end)
                           (toplevel-form-to-string (current-point))
        (declare (ignore whole))
        (let* ((killed/env (concatenate 'string
                                        "(editor::bind-env "
                                        killed 
                                        ")"))
               (whole/env (concatenate 'string
                                       (points-to-string whole-beg killed-beg)
                                       killed/env
                                       (points-to-string killed-end whole-end)))
               (expanded (with-compilation-environment-at-point (point)
                           (walker:walk-form (read-from-string whole/env))))
               (binds (format nil 
                              "~&(let ~A~%  ~A)"
                              (write-to-string (extract-binds expanded))
                              killed)))
          (set-current-cut-buffer-string (current-window) binds))))))

使ってみる

切り取り動作にするかコピー動作にするか迷いましたが、とりあえず今回はコピー動作にしてみました。

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

の(ifの前でM-x Save Form With Envすると、

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

がコピーされるので、適宜貼り付けることが可能です。
こんな感じの手作りインライン展開をする時などに便利なのではないでしょうか(便利か?)

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

まとめ

今回は、letに抜き出しましたが、defunの式をlambdaに抜き出したりしても良さそうですね。

■

HTML generated by 3bmd in LispWorks 7.0.0

こちらの記事を読んで、そういえばSchemeのプログラムをCommon Lispに移植する際などのLisp1→Lisp2変換で似たようなことが必要になるなと思ったので、自分が良く使う方法をまとめてみます。

• 式が再帰的なプログラム

まず、fletは少し特殊なスコープを持つ構文で、defunやlabelsと違って、同じ階層のローカル関数を呼び出すことができません。

(flet ((fib (n)
         (if (< n 2)
             n
             (+ (fib (1- n))
                (fib (- n 2))))))
  (fib 20))
>>>Error: Undefined operator fib in form (fib (1- n)).
(flet ((fib (n) n))
  (flet ((fib (n)
           (if (< n 2)
               n
               (+ (fib (1- n))
                  (fib (- n 2))))))
    (fib 20)))
→ 37

ただ、同じ階層のローカル関数がスコープにないだけなので、ローカル変数として自分自身与えれば再帰できます。

(flet ((fib (n fib)
         (if (< n 2)
             n
             (+ (funcall fib (1- n) fib)
                (funcall fib (- n 2) fib)))))
  (fib 20 #'fib))
→ 6765

Schemeのletrec等の実装方法での常套句のように変数を代入してやる方法もあります。

(let ((fib #'identity))
  (flet ((fib (n)
           (if (< n 2)
               n
               (+ (funcall fib (1- n))
                  (funcall fib (- n 2))))))
    (setq fib #'fib)
    (fib 20)))
→ 6765

この手法はCommon Lispでも古典的なようで、Spice Lisp(1980年初頭)のコンパイラでのlabelsの実装(式変形)もこんな感じみたいです。

• Spice Lisp: CLC.SLISP

(def-cg labels cg-labels (x &body body)
  (let ((*fenv* *fenv*))
    (do ((defs x (cdr defs))
     (new-env *fenv*)
     (let-list nil)
     (setq-list nil)
     (name (new-internal-variable) (new-internal-variable)))
    ((atom defs)
     (setq *fenv* new-env)
     ;; With new *FENV* bindings in effect, compile the functions,
     ;; then the body.
     (cg-form
      `(let ,let-list (setq ,@setq-list) (progn ,@body))
      for-value))
      (push name let-list)
      (push `#'(lambda ,@(cdar defs)) setq-list)
      (push name setq-list)
      (push (cons (caar defs) name) new-env))))

これは、

(labels ((fib (n)
           (if (< n 2)
               n
               (+ (fib (1- n))
                  (fib (- n 2))))))
  (fib 20))

のような式を、大体下記のように変形します。

(let (.fib.)
  (flet ((fib (n) (funcall .fib. n)))
    (setq .fib. #'(lambda (n)
                    (if (< n 2)
                        n
                        (+ (fib (1- n))
                           (fib (- n 2))))))
    (fib 20)))
→ 6765

Common Lispではどういう時に使うか

多分あまり使わないと思いますが、Schemeのletrec系の構文を実装する際などには、Lisp1→Lisp2の変換が必要になるので、大体似たようなものを作ることになると思います。

(letrec ((fib (lambda (n)
                (if (< n 2)
                    n
                    (+ (fib (1- n))
                       (fib (- n 2)))))))
  (fib 20))
→ 6765

■

HTML generated by 3bmd in LispWorks 7.0.0

Eclipse Common Lispのソースを眺めていると、

(declare (ignore initargs) (dynamic-extent initargs))

というのが結構出てきます。

• eclipse-lisp/lisp/mop.lisp

これって果して何かしらの効果あるのだろうかと気になります。
そもそもignoreしているので、dynamic-extentもなにもないのですが、何か深い理由がありそうななさそうな。

Eclispse CLでコンパイル結果を確認してみる

とりあえず、Eclispse CLでコンパイル結果が変化したりするのか確認してみます。

(defun foo (arg)
  (declare (ignore arg) (dynamic-extent arg))
  42)
> (disassemble 'foo)

#include <eclipse.h>

clObject clExtraArgs(clProto), clMissingArgs(clProto);
static clObject I_1, I_42;
clObject usrFoo clVdecl(_ap)
{ clObject arg;
  { clBeginParse(_ap);
    clSetq(arg,
           (_clVp(_ap) ? clVpop(_ap) : clMissingArgs(I_1, clEOA)));
    if (_clVp(_ap)) clExtraArgs(clVargs(_ap), clEOA);
    clEndParse(_ap); }
  return(clValues1(I_42)); }
void clLoader __P((void)) 
{ clDbind(clstarPACKAGEstar);
  clDbind(clstarREADTABLEstar);
  clDbind(clstarLOAD_TRUENAMEstar);
  clDbind(clstarLOAD_PATHNAMEstar);
  clSetq(I_1, clIntFixnum(1));
  clSetq(I_42, clIntFixnum(42));
  clMakeClosure(0, usrFoo, clNULL_HOOK);
  clUnwind(4); }
NIL

(defun bar (arg) 42)
> (disassemble 'bar)

#include <eclipse.h>

clObject clExtraArgs(clProto), clMissingArgs(clProto);
static clObject I_1, I_42;
clObject usrBar clVdecl(_ap)
{ clObject arg;
  { clBeginParse(_ap);
    clSetq(arg,
           (_clVp(_ap) ? clVpop(_ap) : clMissingArgs(I_1, clEOA)));
    if (_clVp(_ap)) clExtraArgs(clVargs(_ap), clEOA);
    clEndParse(_ap); }
  return(clValues1(I_42)); }
void clLoader __P((void)) 
{ clDbind(clstarPACKAGEstar);
  clDbind(clstarREADTABLEstar);
  clDbind(clstarLOAD_TRUENAMEstar);
  clDbind(clstarLOAD_PATHNAMEstar);
  clSetq(I_1, clIntFixnum(1));
  clSetq(I_42, clIntFixnum(42));
  clMakeClosure(0, usrBar, clNULL_HOOK);
  clUnwind(4); }
NIL

上記foo、barで何も変化なしです。

Eclipse CL以外の処理系でもちょっと確認してみましたが、手元の処理系では差が出るものはありませんでした。

推理

色々考えてみましたが、Eclipse CLのコードにはかなりdynamic-extent宣言が多く、何かの雛形から生成されたようなコードも多いので、雛形として(declare (dynamic-extent initarg))が付いているところに、追加で、(declare (ignore initarg))がさらに機械的に付加されたのかもしれません。

(declare (ignore arg) (dynamic-extent arg))で何か面白い応用ができないか色々考えてみましたが、特に思い付かず……。
何か面白い応用があれば是非教えてください。

■

HTML generated by 3bmd in LispWorks 7.0.0

コンパイラへの指示で、assertを無効にした時に消えてしまうのではなくて、unreachableに変化すると最適化のヒントになって良いのではないか、というのを目にしたので、Common Lispで似たようなことができないか試してみます。

Common Lispでは、assertは継続エラーを出すという仕様なので最適化で消えたりはしませんが、ブロックから早期脱出するようにすれば、後続のコードが不達になって不達コードの警告を出すコンパイラもあると思います(SBCL等)

(ql:quickload 'policy-cond)
(defun innermost-block (env)
  (let ((blk (car #+sbcl (sb-c::lexenv-blocks env)
                  #+lispworks (compiler::environment-benv env))))
    (values (car blk) (cdr blk)))))
(defmacro assert* (test-form &environment env)
  (multiple-value-bind (name namep)
                       (innermost-block env)
    (if (or name namep)
        `(policy-cond:policy-if (eql 0 cl:safety)
                                (unless ,test-form (return-from ,name nil))
                                (assert ,test-form))
        `(assert ,test-form))))

policy-condを利用してsafety 0の時だけassertが早期脱出のコードに変換されるようにしてみました。

(defun bar (n)
  (declare ((integer 0 2) n))
  (declare (optimize (safety 0)))
  (assert* (= 3 n))
  (list n))
(bar 1)
→ nil

LispWorksあたりだと、早期脱出のコードに変換される程度ですが、SBCLでは不達コードの警告を出したりはできるようです。
とはいえ、残念ながらコンパイル時に判明している値レベルでしか判定できませんが。

(defun bar (n)
  (assert* (= 3 4))
  (print n))
; processing (DEFUN BAR ...)

; file: /tmp/slimert9DD9
; in: DEFUN BAR
;     (PRINT N)
; ==>
;   N
; 
; note: deleting unreachable code
; 
; compilation unit finished
;   printed 1 note

まとめ

SBCLを始めとするPythonコンパイラ系では、型情報の伝搬や、不達コードの検出等の機能はそこそこありますが、一度どの程度のことをやってくれるのかまとめてみたいところです。

関連

• #:g1: declare type 対 check-type

■

HTML generated by 3bmd in LispWorks 7.0.0

LispといえばS式ですが、S式について語られる際には大抵はM式も一緒に話題にのぼります。
M式は実際の所、正式な仕様は存在しないので処理系製作者が独自に拡張したものをM式としていたことが多いようですが、今回は、そんなM式の魅力の無さについて考えてみましょう。

魅力の無さ その1: 別に中置記法ではない

前置記法のS式を比較対象とするからか、M式は中置記法といわれますが、中置の文法ではっきり決まっていそうなのは関数定義のdefineの=/≡位と、conldで使われる→位で、あとは前置ですし、ユーザー定義の関数は前置です。
後のプログラミング言語のようにユーザーが中置の文法を定義し結合度を定義する、という機構もありません。

M式の構文自体は、当時のFORTRAN I的に書けたら良いのではないか、という程度の構想だったようですが、FORTRAN Iの構文自体がそれ程洗練されたものでもありません。

結局のところ関数名が括弧の外に出ているだけ、という感じです。

fib[n] = [greaterp[2; n] → n;
          T → plus[fib[difference[n; 1]];
                    fib[difference[n; 2]]]]

なお、本格的なプログラミング構文としては、LISP 2でのALGOL構文の採用がありますが、LISP 2は構文としてはALGOLそのものなので中置構文のリッチさに関してはLISP 2が勝るでしょう。

LISP 2

integer function fib(n); integer n;
  if n < 2 
  then n 
  else fib(n - 1) + fib(n - 2);
end;

1960年代当時の次世代LISPであるLISP 2でのALGOL構文の採用が、M式をさらに中途半端な存在にした可能性もなくはないかなと思います。

なお、1960年代に実装されたM式系の構文としては、SDS 930 LISP(1965)のM-languageや中西先生のKLISPがあります。
中西先生の文献にはM言語というのが良く出てきますが、SDS 930 LISP由来なのかもしれません。

SDS 930 LISP

fib [n] : [2 > n # n; 
          T # (fib (n - 1)) + (fib (n - 2))]

ちなみに蛇足ですが、S式はリストで式を表現しているだけなので、リストで中置記法を表現することは可能です。

((fib n) = ((2 > n) → n
            T → ((fib(n - 1)) + (fib(n - 2)))))

魅力の無さ その2: 括弧の数は少ししか減っていない

括弧は外側を囲むことによってグループ化しますが、括弧を減らす記法として、結合する記号を定義して前後を結合する中置記法や、インデントの深さによってグループ化するオフサイドルールや、引数の数を元に括弧を省略する本来のポーランド記法がありますが、上述のようにM式には極僅かしか中置構文が定義されていないので括弧の数は大してかわりません。

数学記号を中置演算子として用意すれば、括弧を減らすことは可能ですが、上述のようにユーザー定義部分は大して変化なしです。

fib[n] = [[2 > n] → n;
          T → fib[n - 1] + fib[n -  2]]]

魅力の無さ その3: 構文の括弧に[]を使っている

LISPの極初期では、構文は()とデリミタの,組み合わせで記述されていたようですが、LISP 1.5の頃には[]と;の組み合わせになってしまいました。

fib(n) = (greaterp(2, n) → n,
          T → plus(fib(difference(n, 1)),
                    fib(difference(n, 2))))
→
fib[n] = [greaterp[2; n] → n;
          T → plus[fib[difference[n; 1]];
                    fib[difference[n; 2]]]]

()と,は、M式内のS式(リスト)の記法に使われることになったようですが、プログラムの記述の方をゴツくしてしまった理由は謎です。

魅力の無さ その4: 構文の記法とデータの記法が未分化

λの仮引数の後に;が必要だったりで構文というよりデータという感じがしてしまいます。
結局M式のこういう中途半端なところがS式へ吸収される原因だったのではないでしょうか。

fib = λ[[n]; 
         [greaterp[2; n] → n
          T → plus[fib[difference[n; 1]];
                    fib[difference[n; 2]]]]]

魅力の無さ その5: データの記法とプログラム構文の記法を覚えないといけない

データからプログラムを作るLispならではの問題ですが、記法が2つあるとどういうルールでどう変換するのか、を覚える必要があります。
この辺りの課題は、M式、ALGOL構文のLISP 2、Dylan、最近だとJuliaにもありますが、プログラム構文としてリッチであれば、データへ変換する際のルールも多くなり直感的でなくなるでしょうし、貧弱であれば、S式で良いじゃんということになってしまいます。

まとめ

結局S式でいいですね。

関連

• #:g1: Lispと中置記法

■

HTML generated by 3bmd in LispWorks 7.0.0

PDP-11上のLISP処理系であるLISP-11のマニュアルを眺めていたところ、括弧の下の行に番号を付与している記述がありました。
1960年代初頭のパンチカード時代に良く利用されていたようですが、編集時の括弧のずれでエラーになった場合に不整合を素早く検知できたりするかもしれないので、そういうエディタコマンドを作成してみます。

(ql:quickload "split-sequence")

(defun numbered-parens (str)
  (with-output-to-string (out)
    (let ((pc 0))
      (format out
              "~&~{~A~^~%~}"
              (mapcan (flet ((subchar (pc)
                               (character (princ-to-string (mod pc 10)))))
                        (lambda (line)
                          (list line
                                (map-into (make-string (length line))
                                          (lambda (c)
                                            (case c
                                              (#\( (prog1 (subchar pc) (incf pc)))
                                              (#\) (prog2 (decf pc) (subchar pc)))
                                              (otherwise #\Space)))
                                          line))))
                      (split-sequence:split-sequence #\Newline str))))))
#+LispWorks
(progn
  (editor:defcommand "Numbered Parens" (p)
       ""
       ""
    (declare (ignore p))
    (editor::with-random-typeout-to-window ()
      (editor::with-defun-start-end-points (beg end)
                                           (editor:current-point)
        (write-string (numbered-parens (editor::points-to-string beg end))))))
  (editor:bind-key "Numbered Parens" "Control-N"))

括弧のエスケープの処理をきちんと処理するのは手間なので実装していませんが、こんな感じに表示します。

(defun numbered-parens (str)
0                      1   1
  (with-output-to-string (out)
  1                      2   2
    (let ((pc 0))
    2    34    43
      (format out
      3        
              "~&~{~A~^~%~}"
              (mapcan (flet ((subchar (pc)
              4       5     67        8  8
                               (character (princ-to-string (mod pc 10)))))
                               8          9                0         09876
                        (lambda (line)
                        6       7    7
                          (list line
                          7         
                                (map-into (make-string (length line))
                                8         9            0           09
                                          (lambda (c)
                                          9       0 0
                                            (case c
                                            0      
                                              (#\( (prog1 (subchar pc) (incf pc)))
                                              1  2 3      4          4 4       432
                                              (#\) (prog2 (decf pc) (subchar pc)))
                                              2  2 2      3       3 3          321
                                              (otherwise #\Space)))
                                              1                 109
                                          line))))
                                              8765
                      (split-sequence:split-sequence #\Newline str))))))
                      5                                           543210

まとめ

近頃だと括弧を虹色に分別して表示する機能があり、LispWorksにも標準で実装されていたりしますが、60年前のrainbow modeというところですね。
個人的には色分けされても括弧対応が判然としないのですが、数字付きだとさすがにはっきりします。
さて、果してデバッグで役に立つかどうか、しばらく使ってみます。

■

HTML generated by 3bmd in LispWorks 7.0.0

Common Lispでsingle-floatを返す関数をdouble-float返すようにする設定はあるか

Common Lispの標準状態の浮動小数点の精度は、単精度(single-float)です。
最近のプログラミング言語の標準の精度は倍精度(double-float)だったりするので、言語間を跨ぐと若干面倒だったりするのですが、標準で倍精度にする設定はないのでしょうか。

# Python
import cmath
cmath.sqrt(-1/3)
→ 0.5773502691896257j

;; Common Lisp
(sqrt -1/3)
→ #C(0.0 0.57735026)

結論:そういう設定はない

結論からいうと、そういう設定はありません。

*read-default-float-format*をdouble-floatにすると良いという話は良く耳にしますが、浮動小数点数の読み取りのデフォルトを設定するのみなので、整数等の読み取りには影響なしです。

(setq *read-default-float-format* 'double-float)
→ double-float

(sqrt -1/3)
→ #C(0.0F0 0.57735026F0)

(expt 1 1/2)
→ 1.0F0

上記のような場合、入力側で整数等を浮動小数点数に変換してやることになります。

(sqrt (float -1/3 0d0))
→ #C(0.0D0 0.5773502691896257D0)
(expt 1 (float 1/2 0d0))
→ 1.0D0

まとめ

結局のところユーティリティパッケージを作成するしかないようですが、そういうパッケージを見掛けない気がするので需要はないのかもしれません。

作成するとしたら、Common Lispの標準関数で該当するものをdouble-float:sqrtのようにまとめることになりそうです。

■

HTML generated by 3bmd in LispWorks 7.0.0

このブログのためのネタ帳をひっくり返して眺めてみると5年位放置しているネタで、HAKMEM: ITEM 59 (Schroeppel)というメモがありました。

HAKMEMはMIT AIラボの人達のメモ集ですが、割合に雑多なメモです。
HAKMEM ITEM 59は、数字の関係だけが記述されていて、メモを残した理由も記述されていません。

• HAKMEM: ITEM 59 (Schroeppel)

                                               2
91038 90995 89338 00226 07743 74008 17871 09376  =
82880 83126 51085 58711 66119 71699 91017 17324
91038 90995 89338 00226 07743 74008 17871 09376

とりあえず、

• 2乗した場合に桁数が倍
• 下半分に自分自身が含まれる

ような数を探してみろということなのかなと思い、例題の40桁の倍の80桁のものを探してみることにします。

(defun fig (x)
  (length (princ-to-string x)))

(defun test-it (x)
  (multiple-value-bind (q r)
                       (floor (expt x 2)
                              (expt 10 (fig x)))
    (= x r)))

(defun pp (x &optional (out *standard-output*))
  (let ((xx (format nil "~,,' ,5:D" x)))
    (format out
            "~%~VD~%~A  =~2%~{~V,,' ,5:D~%~}"
            (1+ (length xx)) 2
            xx
            (multiple-value-bind (q r)
                                 (floor (expt x 2)
                                        (expt 10 (fig x)))
              (list (length xx) 
                    q
                    (length xx)
                    r)))))

(defun compose-num (x base)
  (parse-integer (format nil "~D~D" x base)))

(defun decompose-num (x)
  (maplist (lambda (ns)
             (parse-integer (coerce ns 'string)))
           (coerce (princ-to-string x) 'list)))

(defun hakmem59 (n &optional (limit 80))
  ;;雑な生成
  (loop (when (>= (fig n) limit)
          (return))
        (dotimes (x 1001) ;雑な連続する0への対策
          (let ((xn (compose-num x n)))
            (when (test-it xn)
              (setq n xn)))))
  ;;limit桁に切り詰め
  (setq n (rem n (expt 10 limit)))
  ;;表示
  (dolist (x (reverse (decompose-num n)))
    (when (= (fig (expt x 2))
             (* 2 (fig x)))
      (pp x))))

2乗した場合に、下一桁に自身の数字が出現する数は、0、1、5、6ですが、下半分の桁に自分自身が現われるとなると、5、6しかありません。
ということで、5か6から出発して一桁ずつ数を当て嵌めて探していけば、簡単にみつかります。

(hakmem59 6 80)
...
 ...
                                                                                               2
61490 10993 78334 90419 13618 89994 42576 57676 91038 90995 89338 00226 07743 74008 17871 09376  =
37810 33620 16684 89789 77935 64658 06599 50861 58235 23230 14798 96610 06702 69587 17457 60530
61490 10993 78334 90419 13618 89994 42576 57676 91038 90995 89338 00226 07743 74008 17871 09376

(hakmem59 5 80)
...
 ...
                                                                                               2
38509 89006 21665 09580 86381 10005 57423 42323 08961 09004 10661 99773 92256 25991 82128 90625  =
14830 11632 60015 08951 50697 84669 21446 35507 76157 41238 36122 96157 91215 21570 81715 41779
38509 89006 21665 09580 86381 10005 57423 42323 08961 09004 10661 99773 92256 25991 82128 90625

まとめ

以上、雑な探索をしてみましたが、多分探索しなくても一発でみつかる式があったりするんでしょうね。

■

HTML generated by 3bmd in LispWorks 7.0.0

コンパイラマクロがコンパイル時に展開されることを利用して、非推奨APIの警告を出すというアイデアがあったりしますが、スタイルチェッカー的なものを動かすタイミングとしては丁度良く、また、コンパイラマクロは意味論を変えないことが前提なので親和性も高いと思います。

ということで、コンパイラマクロが構文チェッカーとして使えないか考えてみたいと思います。

定義

まず、letの別名のmyというものを定義します。

(defmacro my ((&rest binds) &body body)
  `(let (,@binds) ,@body))

これに対し、

• 変数名の重複はエラー
• 変数束縛部では(変数 値)という形式を強制

というのをコンパイラマクロで追加してみます。

(define-compiler-macro my (&whole whole (&rest binds) &body body)
  (declare (ignore body))
  (dolist (b binds)
    (check-type b (cons symbol (cons T null))))
  (assert (subsetp binds (remove-duplicates binds :key #'car :from-end T))
          nil
         "Variable name duplicated in bind spec: ~S"
         binds)
  whole)

試してみる

束縛部の形式チェック

(defun foo ()
  (my ((x 3) y)
    (list x y)))
;⏏ Error: The value y of b inside (define-compiler-macro my) is not of type (cons symbol (cons t null)).

束縛部の変数重複チェック

(defun foo ()
  (my ((x 3) (x 4))
    (list x)))
;⏏ Error: Variable name duplicated in bind spec: ((x 3) (x 9)).

まとめ

チェッカーの使い勝手的には元のコードはいじらずに後からチェッカーを追加したりしたいところですが、define-compiler-macro定義は一つだけなので、元のコードをいじらないわけにはいきません。

compiler-macro-function関数をラップするようなインターフェイスを作成して、adviceの真似事をしてみれば可能な気もします。

何にしろコンパイラマクロを定義する場所は一つしかないので、複数のフックが共存できるような仕組みが必要ですね。

関連

• CMU AIレポジトリ探検 (6) LINT: Lint for Common Lisp

■

HTML generated by 3bmd in LispWorks 7.0.0

Common Lispのシークエンス関数のテスト述語はデフォルトでeqlですが、文字列の比較が多い最近では、equalがデフォルトの方が使い勝手が良い気がします。

最近のSBCLだとequalを指定しても最適化でeqlやeqにしたりするようですが、それと似た雰囲気でデフォルトをequalにし、declareでテスト述語の指定をすることにしたらどうかと思い試してみました。

下準備

declarationとdefine-declarationでユーザー宣言のtestを宣言します。
testは、(declare (test #'eql))のように使います。

(defpackage "b85d852d-3639-5467-af00-962feb136730"
  (:use common-lisp)
  (:import-from
   #+lispworks harlequin-common-lisp
   #+sbcl sb-cltl2
   declaration-information
   define-declaration)
  (:shadow find))
(in-package "b85d852d-3639-5467-af00-962feb136730")
(declaim (declaration test))
(define-declaration test (dcl env)
  (declare (ignore env))
  (values :declare dcl))

コンパイラマクロでの最適化

デフォルトはゆるくequalで、宣言でより判定が狭いeqlやeqを指定した場合に、それが使われるようにします。

(defun find (item sequence &key (test #'equal))
  (cl:find item sequence :test test))

(define-compiler-macro find (&whole w item sequence &key (test #'equal)
                             &environment env)
  `(cl:find ,item ,sequence :test
            ,(or (car (declaration-information 'test env))
                 test)))

確認

(defun find-foo  (x)
  (find x '("foo" "bar" "baz")))
(find-foo "foo")
→ "foo" 
(defun find-foo-dcl-eql (x)
  (declare (test #'eql))
  (find x '("foo" "bar" "baz")))
(find-foo-dcl-eql "foo")
→ nil 
(flet ((sequal (x y)
         (string-equal x y)))
  (defun find-foo-dcl-string-equal (x)
    (declare (test #'sequal))
    (find x '("foo" "bar" "baz"))))
(find-foo-dcl-string-equal 'foo)
→ "foo" 

まとめ

最適化の筋書だと、意味論は変えずに効率だけ良くなるような記述体系になる必要がありますが、今回の例だと、任意の述語を指定できるので、意味論が変ってしまうような指定もできてしまいます。

また、define-declarationでdeclaimのようなコンパイル単位ローカルなトップレベルの宣言ができれば、ファイルごとに述語のデフォルトを指定できたりして便利なのですが、どうもSBCLもLispWorksもトップレベルの宣言が定義できない様子。
define-declarationは標準機能ではないため、そういう仕様なのか単に実装の都合なのかは微妙ですが、ちょっと不思議。

■

HTML generated by 3bmd in LispWorks 7.0.0

今日はSNSでEmacs Lispのネイティブコンパイラがメインラインに来たという話題で賑っていたので、早速GNU Emacsを--with-native-compでビルドして、Common Lispのネイテイブコンパイラと比較してどんなものなのか眺めてみました。
眺めるといっても、お馴染のfibのマイクロベンチを走らせるだけですが。

Emacs Lisp で実行形態三種の比較

まず、Emacs Lispで、通常の定義、バイトコンパイル、ネイティブコンパイルで比較してみます。
いまひとつ作法が分かっていないのですが、定義形式を合せるために、(setf symbol-function)しています。
一応defunでの定義をファイルに書き出してからファイルをコンパイルする手順でも確認してみましたが、結果はほぼ同じようです。

最適化設定が良く分からないのですが、

(setq comp-speed 3)

するとCommon Lispでいう、(declaim (optimize speed 3))的なことになるようなので、以下はこの設定の元で実験しています。

(setf (symbol-function 'fib)
      (lambda (n)
        (if (< n 2)
            n
          (+ (fib (1- n))
             (fib (- n 2))))))
(benchmark-call (lambda () (fib 30)) 1)
→ (0.540617072 0 0.0)
(benchmark-call (lambda () (fib 40)) 1)
→ (79.139097209 0 0.0)

(setf (symbol-function 'fib-bc)
      (byte-compile
       (lambda (n)
         (if (< n 2)
             n
           (+ (fib-bc (1- n))
              (fib-bc (- n 2)))))))
(benchmark-call (lambda () (fib-bc 30)) 1)
→ (0.346994376 0 0.0)
(benchmark-call (lambda () (fib-bc 40)) 1)
→ (40.036792254 0 0.0)

(setf (symbol-function 'fib-nc)
      (native-compile
       (lambda (n)
         (if (< n 2)
             n
           (+ (fib-nc (1- n))
              (fib-nc (- n 2)))))))
(benchmark-call (lambda () (fib-nc 30)) 1)
→ (0.253148658 0 0.0)
(benchmark-call (lambda () (fib-nc 40)) 1)
→ (29.594145706 0 0.0)

大体のところですが、

という結果でした。

Common Lispとの比較

大体のタイムは分かったので、似たようなスピードのCommon Lisp処理系ということだとCLISPあたりか、ということで、CLISPで関数をコンパイルした場合と、Emacs Lispのネイティブコンパイルのfibの結果を比較してみたところ、両者の結果は、ほぼ同じになりました。
なお、CLISPはネイティブコンパイラではなくバイトコンパイラの処理系です。

(setf (symbol-function 'fib)
      (lambda (n)
        (if (< n 2)
            n
            (+ (fib (1- n))
               (fib (- n 2))))))
(time (fib 30))
Real time: 0.248056 sec.
Run time: 0.25 sec.
Space: 0 Bytes
→ 832040
(time (fib 40))
Real time: 30.663303 sec.
Run time: 30.59 sec.
Space: 0 Bytes
→ 102334155

Common Lispのネイティブコンパイラとの比較

Common Lispのメジャーな処理系は大体ネイティブコンパイラですが、LispWorksで最適化設定なしの場合は、こんな感じです。

(setf (symbol-function 'fib)
      (lambda (n) 
        (if (< n 2)
            n
            (+ (fib (1- n))
               (fib (- n 2))))))
(compile 'fib)
Timing the evaluation of (fib 40)
User time    =        1.350
System time  =        0.010
Elapsed time =        1.293
Allocation   = 269016 bytes
0 Page faults
→ 102334155

Emacs Lispのネイティブコンパイルfibと比べると大体22倍程度の速さです。
ちなみにLispWorksのインタプリタ実行はかなり遅いことがわかりますが、Common Lisp仕様がコンパイル指向なので、インタプリタはおまけだったり、サポートしていなかったりの処理系が殆どです。

なお、SBCLやLispWorksで型宣言や再帰的なインライン展開を実施して最速を狙うと、ネイティブコンパイルのEmacs Lispの約95倍程度の速度が出ます。
関数呼出しの速度を計測するためのfibのようなマイクロベンチでインライン展開するのは卑怯な気もするのですが、gcc等も展開してくるので、gccに合せるならアリかなと思います。

(defun fib (n)
  (declare (optimize (speed 3) (safety 0) (debug 0) (compilation-speed 0))
           (fixnum n))
  (labels ((fib (n)
             (declare (fixnum n))
             (the fixnum
                  (if (< n 2)
                      n
                      (+ (fib (1- n))
                         (fib (- n 2))))))) 
    (declare (inline fib))
    (fib n)))
CL-USER> (time (fib 40))
Evaluation took:
  0.322 seconds of real time
  0.320000 seconds of total run time (0.320000 user, 0.000000 system)
  99.38% CPU
  1,061,775,900 processor cycles
  0 bytes consed

まとめ

いまのところEmacs Lispの最適化の作法があまり確立していないようなのですが、Common Lisp風に人が指示する手段もそこそこ用意されているようです。
ただ、まだ発展途上のようでCommon Lispの感覚でコンパイラに最適化のヒント与えようとしても上手く行かない様子。
例えば、comp-hint-fixnumは、(the fixnum ...)な雰囲気のもののようですが、(optimize (speed 3))で使うと現状では却って遅くなったりします。

また、Common Lispではdisassembleで結果を確認しつつ追い込んでいくのが普通ですが、Common Lispのネイティブコンパイラのディスアセンブルの結果と違ってCのコンパイラの世界と行き来している感があります。

Emacs Lispが今後Common Lispのように人力チューニングを中心に展開していくのか、JITを中心にしていくのかは分かりませんが、Common Lisp風なシステムを目指すのであれば、もう少し道具が充実する必要がありそうです。

今回のfibのdisassembleの結果は下記のようになります。
なお、現状、AT&T表記決め打ちのようなのですが、disassemble-internalの中でobjdumpを呼んでいるだけのようなので、ここをいじれば好きな表記に変更できるようです。

disassemble-internal:
...
(call-process "objdump" nil (current-buffer) t "-S" "-M" "intel"
                            (native-comp-unit-file (subr-native-comp-unit obj)))
...

0000000000001290 <F6669622d6e63_fib_nc_0>:
    1290:   41 54                   push   r12
    1292:   55                      push   rbp
    1293:   53                      push   rbx
    1294:   48 83 ec 50             sub    rsp,0x50
    1298:   4c 8b 25 49 2d 00 00    mov    r12,QWORD PTR [rip+0x2d49]        # 3fe8 <freloc_link_table@@Base-0x5f8>
    129f:   48 8b 2d 3a 2d 00 00    mov    rbp,QWORD PTR [rip+0x2d3a]        # 3fe0 <d_reloc@@Base-0x580>
    12a6:   49 8b 1c 24             mov    rbx,QWORD PTR [r12]
    12aa:   48 8b 7d 00             mov    rdi,QWORD PTR [rbp+0x0]
    12ae:   ff 93 a8 26 00 00       call   QWORD PTR [rbx+0x26a8]
    12b4:   bf 02 00 00 00          mov    edi,0x2
    12b9:   48 89 e6                mov    rsi,rsp
    12bc:   48 c7 44 24 08 0a 00    mov    QWORD PTR [rsp+0x8],0xa
    12c3:   00 00 
    12c5:   48 89 04 24             mov    QWORD PTR [rsp],rax
    12c9:   ff 93 28 26 00 00       call   QWORD PTR [rbx+0x2628]
    12cf:   48 8b 7d 00             mov    rdi,QWORD PTR [rbp+0x0]
    12d3:   48 85 c0                test   rax,rax
    12d6:   74 18                   je     12f0 <F6669622d6e63_fib_nc_0+0x60>
    12d8:   ff 93 a8 26 00 00       call   QWORD PTR [rbx+0x26a8]
    12de:   48 83 c4 50             add    rsp,0x50
    12e2:   5b                      pop    rbx
    12e3:   5d                      pop    rbp
    12e4:   41 5c                   pop    r12
    12e6:   c3                      ret    
    12e7:   66 0f 1f 84 00 00 00    nop    WORD PTR [rax+rax*1+0x0]
    12ee:   00 00 
    12f0:   ff 93 a8 26 00 00       call   QWORD PTR [rbx+0x26a8]
    12f6:   48 89 c7                mov    rdi,rax
    12f9:   8d 40 fe                lea    eax,[rax-0x2]
    12fc:   a8 03                   test   al,0x3
    12fe:   75 20                   jne    1320 <F6669622d6e63_fib_nc_0+0x90>
    1300:   48 ba 00 00 00 00 00    movabs rdx,0xe000000000000000
    1307:   00 00 e0 
    130a:   48 89 f8                mov    rax,rdi
    130d:   48 c1 f8 02             sar    rax,0x2
    1311:   48 39 d0                cmp    rax,rdx
    1314:   74 0a                   je     1320 <F6669622d6e63_fib_nc_0+0x90>
    1316:   48 8d 04 85 fe ff ff    lea    rax,[rax*4-0x2]
    131d:   ff 
    131e:   eb 0a                   jmp    132a <F6669622d6e63_fib_nc_0+0x9a>
    1320:   49 8b 04 24             mov    rax,QWORD PTR [r12]
    1324:   ff 90 90 25 00 00       call   QWORD PTR [rax+0x2590]
    132a:   48 8b 55 18             mov    rdx,QWORD PTR [rbp+0x18]
    132e:   48 8d 74 24 10          lea    rsi,[rsp+0x10]
    1333:   48 89 44 24 18          mov    QWORD PTR [rsp+0x18],rax
    1338:   bf 02 00 00 00          mov    edi,0x2
    133d:   48 89 54 24 10          mov    QWORD PTR [rsp+0x10],rdx
    1342:   ff 93 e0 1a 00 00       call   QWORD PTR [rbx+0x1ae0]
    1348:   48 8b 7d 00             mov    rdi,QWORD PTR [rbp+0x0]
    134c:   49 89 c4                mov    r12,rax
    134f:   ff 93 a8 26 00 00       call   QWORD PTR [rbx+0x26a8]
    1355:   48 8d 74 24 20          lea    rsi,[rsp+0x20]
    135a:   bf 02 00 00 00          mov    edi,0x2
    135f:   48 c7 44 24 28 0a 00    mov    QWORD PTR [rsp+0x28],0xa
    1366:   00 00 
    1368:   48 89 44 24 20          mov    QWORD PTR [rsp+0x20],rax
    136d:   ff 93 f8 25 00 00       call   QWORD PTR [rbx+0x25f8]
    1373:   48 8b 55 18             mov    rdx,QWORD PTR [rbp+0x18]
    1377:   48 8d 74 24 30          lea    rsi,[rsp+0x30]
    137c:   bf 02 00 00 00          mov    edi,0x2
    1381:   48 89 44 24 38          mov    QWORD PTR [rsp+0x38],rax
    1386:   48 89 54 24 30          mov    QWORD PTR [rsp+0x30],rdx
    138b:   ff 93 e0 1a 00 00       call   QWORD PTR [rbx+0x1ae0]
    1391:   66 49 0f 6e c4          movq   xmm0,r12
    1396:   48 8d 74 24 40          lea    rsi,[rsp+0x40]
    139b:   bf 02 00 00 00          mov    edi,0x2
    13a0:   66 48 0f 6e c8          movq   xmm1,rax
    13a5:   66 0f 6c c1             punpcklqdq xmm0,xmm1
    13a9:   0f 29 44 24 40          movaps XMMWORD PTR [rsp+0x40],xmm0
    13ae:   ff 93 00 26 00 00       call   QWORD PTR [rbx+0x2600]
    13b4:   48 83 c4 50             add    rsp,0x50
    13b8:   5b                      pop    rbx
    13b9:   5d                      pop    rbp
    13ba:   41 5c                   pop    r12
    13bc:   c3                      ret    
    13bd:   0f 1f 00                nop    DWORD PTR [rax]

■

HTML generated by 3bmd in LispWorks 7.0.0

仕事でjsonデータを扱うのですが、データ形式自体が開発中のため、開発者によってキー名のケーススタイルがぶれるという事態が発生しました。
それはとりあえず統一すれば良いのですが、データのぶれにより既存のアプリがデータを上手く扱えなくなってしまったので、当座でアプリを機能させるためには、キー名を正規化する必要があります。
しかし、既存のコードのキー名の正規化がまためんどくさいので、リテラル表記の部分はリーダーマクロを使って正規化してみることにしました。

(ql:quickload 'kebab)

(set-dispatch-macro-character #\# #\^
                              (lambda (srm chr arg)
                                (declare (ignore chr arg))
                                (kebab:to-camel-case (read srm T nil T))))

(st-json:getjso #^"foo_bar_baz" (st-json:jso "fooBarBaz" 42))
→ 42
  t

まあ、急場しのぎですが、こういう時はリーダーマクロが便利ですね。

■

HTML generated by 3bmd in LispWorks 7.0.0

どういう切っ掛けで移植を始めたのか思い出せないのですが、Emacs系エディタでお馴染みのLisp編集支援モードのpareditをLispWorksのエディタ(Hemlock)に移植してみました。

• g000001 / lw-paredit

最近のparedit(version 25)は3000行近くあるのですが、移植したものは300行程度のversion 1です。
誰かが既に移植していた気もするのですが、どうも見付からない……。

最初はちまちまとHemlockのdefcommand形式に書き直していたのですが、途中でめんどくさくなってedefunというEmacsのinteractiveを含んだdefun形式のマクロを作成してコピペしていきました。

versio 25とversion 1では機能に差がありますが、私個人が欲しかったforward-slurp-sexp系の機能は大体version 1で既に完備されていたようです。

Editor Lispがあったら嬉しいが……

Emacs系エディタではLispで拡張できるのは嬉しいのですが、似ているけれど割合に違うAPI群をそれぞれ持っているので、エディタ間でLispコードを共有するのは難しい状況です。

大別すると

• GNU Emacs系
• Hemlock系
• Zmacs系

とありますが、圧倒的多数派のEmacs Lispベースで構わないのでEditor Lispとして標準化されたりすると嬉しいですね。
まあ、Hemlockも、Zmacsもほぼ絶滅しているので、これらのプラットフォームがEmacs Lispの資産を活用したいということもないか……。

■

HTML generated by 3bmd in LispWorks 7.0.0

Common Lispのパッケージ名とシンボル名を区切る:をパッケージマーカーと呼びますが、パッケージシステムの存在しないLisp方言でも擬似的なパッケージ名として接頭辞を付けたりすることがあります。

そんな擬似的なパッケージマーカーを集めてみたり良さそうなパッケージマーカーを考えてみたりしましょう。

package:symbol

:が採用されたのは恐らくLisp Machine Lispが最初ですが、Common Lispに受け継がれました。
Lisp Machine LispとCommon Lispの違う点は、外部に公開するシンボルをpackage:symbolと、一つの:で表現し、二つの場合は、内部シンボルpackage::symbolという風に表現するところと、Common Lispは階層パッケージでない点です。
:の個数の使い分けが案外面倒で、外部に公開するAPIとしてのシンボル名のデザインは結構難しいと感じます。

ちなみに、Common Lisp以外でも、Schemeなどでも区切りとして使われたりしています。

package/symbol

Clojure等が/を使っていますが、他のLispでも疑似パッケージ的に使われることがそこそこある記号かなと思います。

package.symbol

Lisp系ではそんなに使われている感はありませんが、Pythonっぽくもありますし、そこそこ使えそうな気がします。

package-symbol

パッケージが登場する前のLispがこんな感じですが、Emacs Lispの作法ではこのスタイルが推奨されています。
シンボル部に-が良く使われるので、パッケージの区切りかどうかがはっきりしないのが欠点といえば欠点でしょうか。
Common Lispでも、package:subpackage-symbolのような名前は結構使われているかなと思います。

package>symbol

Lispマシン用のCの処理系であるZeta-Cで使われている記法ですが、何故>を使っているのかは良く分かりません。
古えのOSでは>がディレクトリパスの区切りだったりもしたので、/と同じような雰囲気なのかもしれません。

package*symbol

古いLispコードで見掛けたことはありますが、ほぼ見掛けません。
割合に使えそうな気もしますが果して……。

symbol$package

LISP 2で使われていた記法で、LISP 2では正確にはpackageではなくsectionですが、前後が逆なのが特徴です。
大抵は関数名で覚えている気がしますが、パッケージ名が後置だとIDE等での補完が簡単な気もします。

色々考えてみた

package_symbol

Lispでは-の使い勝手の良さから極端に利用頻度が低い_ですが、あまり競合しないので接頭辞の区切りには良いかもしれません

package||symbol
package\Symbol

実質package||symbol、package\Symbolとpackagesymbolは一緒ですが、コードの字面上では区切りが付きます。

<package>subpackage>symbol
<package.subpackage>symbol
[package]symbol

古えのOSのパス区切りを模したものですが、Common Lispではシンボル名に使える文字が多いので結構そのまま書けます。

まとめ

以上、まとまりなく疑似パッケージの区切りを紹介してみたり考えてみたりしました。
個人的に疑似パッケージマーカーが必要になるのは、Schemeのコードで、char-set:alphabetのようなものをCommon Lispにどうにか翻訳するケースが多いですが、これまでは、

• Common Lispのパッケージとして、char-set:alphabetと翻訳(パッケージ作成がめんどう)
• char-set.alphabetと翻訳
• char-set$alphabetと翻訳

等々としてきました。
最近は面倒になってきて、char-set\:alphabetと書くようにもなりましたが、なにか疑似パッケージ記号の決定版みたいなものがあれば、一つの表記に落ち着くのになあと思ったりです。

■

HTML generated by 3bmd in LispWorks 7.0.0

Schemeのcondのelse節はelseを書きますが、古典的なLispでは、condのelse節ではTを書きます。

;; Scheme
(cond (...)
      (else ...))
;; Common Lisp
(cond (...)
      (T ...))

このTは半ば慣用句で真値となるものであれば何でも良いのですが、最近古い文献を眺めていて妙なものをみつけたのでまとめてみます。

1 と書く

(cond (...)
      (1 ...))

LISP 1の頃には、nilが0で、Tが1だったりして、M式にもTの代りに直接1が書いてあったりします。
LISP 1のM式をS式に変換した例などで稀ですが見掛けることがあります。

'T と書く

(cond (...)
      ('T ...))

Tにquoteが付いているのですが、何故付いているのかは謎。
LISP 1.5のM式では大文字はクォートされたシンボルを表わすのでM式のTを正確にS式に翻訳すると(quote T)となりますので、この辺りが由来かもしれません。
MACLISPのコードで良く見掛けます。

'else と書く

(cond (...)
      ('else ...))

真値であれば何でも良いので'elseというシンボルをそのまま使ったもの。
たまに古いコードで見掛けます。

稀ですが、

(cond (...)
      (:else ...))

というキーワードシンボルの場合もあり。

(cond (...)
      ("else" ...))

でも良さそうですが、個人的には目にしたことはありません。

(and)

(cond (...)
      ((and) ...))

List Techniques / Harold V. McIntosh(1963)で良く使われている書法ですが、確かに(and)はTに評価されます。
どちらかというとandよりはorな気分な気がしますが、else節を目立たせる場合には使えたりするかもしれません。

(t)

(cond (...)
      ((t) ...))

MBLISPというLisp 1.5系の古いLispのコード例等に出てくる書き方です。
(t)はTを返すような疑似関数になっています。(true)みたいなものですね。

書かない

(cond (...)
      ((progn ...)))

else節の述語部に直接実行する式を書いてしまうというパターンです。
大抵のLisp処理系では述語部から多値を返すことができないので、注意が必要ですが、1970年代あたりでは結構目にするスタイルです。

arcのifのelse節でも良く見掛けますが多値を考慮しなくて良いのと、括弧がネストしていないのが理由かもしれません。ちなみにclosureだと節が偶数でないとエラーになるのでできないようです。

まとめ

他にも微妙なバリエーションがありますが、1990年代以降はt以外のものを書く人は殆どいないようです。

■

HTML generated by 3bmd in LispWorks 7.0.0

MOPでメタクラスを定義した場合などに定義が必要になるvalidate-superclassですが、処理系によって定義が必要であったりなかったりするので、実際のところどういう動作が正しいのか改めて確認してみました。

メタクラス定義でvalidate-superclassを定義する意味

メタクラスが違う二つのクラスの間で継承関係が成立するかどうかは分からないのでデフォルトでは継承関係は成立しないとしていて、成立させたい場合は明示する仕組みというのが簡単な説明です。

この「デフォルトでは継承関係は成立しない」というのをvalidate-superclassで表現していて、成立させる場合にはTを返すメソッドを定義します。

(defclass my-class (standard-class)
  ())
(validate-superclass (class-prototype (find-class 'my-class))
                     (class-prototype (find-class 'standard-class)))
→ nil

この状態で、my-classをメタクラスとするクラスmy-objectを定義する場合、my-objectはオブジェクトの表現としてstandard-objectを継承して利用するのがデフォルト動作(省略時)なので、

(defclass my-object (standard-object)
  ()
  (:metaclass my-class))

のようなものを書いた場合、

(validate-superclass (class-prototype (find-class 'my-class))
                     (find-class 'standard-object))

のようなチェックが一連のスーパークラスで実施され、全てがTでなければ、エラーとなります。
処理系ごとのvalidate-superclassの動作の違いですが、下記のようになります。

明示的に指定しなければ互換性はないとする処理系

(validate-superclass (class-prototype (find-class 'my-class))
                     (find-class 'standard-object))
→ nil

AMOPに記載の通りの判定ですが、

• CMUCL
• SBCL

あたりがそういう挙動で、validate-superclassをちゃんと書いてやる必要があります。

サブメタクラスがstandard-classのサブクラスで、スーパーメタクラスがstandard-classの場合は互換性あり

(validate-superclass (class-prototype (find-class 'my-class))
                     (find-class 'standard-object))
→ T

• LispWorks
• CLISP

あたりがこの挙動です。
この挙動であれば、validate-superclassを書かなくて良さそうにも思えますが、メタクラスがstandard-classの別のサブクラス同士だと継承関係がない場合があるので、その場合はvalidate-superclassを書いてやる必要があります。

具体的には、下記のコードのような状況でvalidate-superclassの定義が必要になります。

(defclass my-class/ (standard-class)
  ())
(defclass my-object/ (standard-object)
  ()
  (:metaclass my-class/))
(validate-superclass (class-prototype (find-class 'my-class/))
                     (find-class 'my-object))
→ nil
(defmethod validate-superclass ((c my-class/) (s my-class))
  T)
(validate-superclass (class-prototype (find-class 'my-class/))
                     (find-class 'my-object))
→ T
;; 上記の定義がなければエラー
(defclass my-object// (my-object)
  ()
  (:metaclass my-class/))

サブメタクラス、スーパーメタクラスが共にstandard-classのサブクラスなら互換性あり

• Allegro CL
• Eclipse CL

あたりがこの挙動です。
メタクラスがstandard-classのサブクラス同士であれば、validate-superclassの定義を書く必要はありません。
これはこれで便利な挙動で、validate-superclassの定義を書くことは殆ど無くなるのは良いのですが、この挙動が災いしてAllegro CLのコードの移植性の無さの一因になっている気がします。

上記のように処理系によってデフォルトの挙動が違いますが、互換性があることを明示するvalidate-superclassのコードがあっても挙動を変えることはないので、AMOP準拠で全部明示しておくのが吉かなと思います。

クラスに互換性がないとはどういうことか

ANSI CL規格では、互いに素である型が定義されていますが、

• 4.2.2 Type Relationships

defclass、define-condition、defstructで継承関係を定義した型以外は互いに素であるとしています。
integerとconsの間では継承関係を考えようとは思わないのですが、メタクラスをカスタマイズする場合は、メタクラスが異なるのみで他の挙動は継承したいことがほとんどかと思います。

validate-superclass の歴史

validate-superclassは用途が限定されている割には機能としては汎用的なのですが、もともとはcheck-super-metaclass-compatibilityという名前だったようです。
途中で、valid-superclass-p等の名前になったりもしたようですが、1990年頃、validate-superclassで落ち着き現在に至る様子。

check-super-metaclass-compatibilityはvalidate-superclassよりも判定が厳しく、デフォルトの挙動は双方のメタクラスがeqの場合のみTとしていたようです。

現在のvalidate-superclassもcheck-super-metaclass-compatibilityの目的に使うことが殆どですが、CMUCLやSBCLでは互換性の判定用に組み込みクラスについても非互換性のリストをもっているので、

(validate-superclass (find-class 'null)
                     (find-class 'cons))
→ nil

のように判定します。
他の処理系は、大体のところはstandard-classの範疇の判定しか想定していないようなのでTを返しますが、こんな動作でも問題ない程度には汎用的には使われていないということなのかもしれません……。

まとめ

validate-superclassについて掘り下げてみましたが、validate-superclassは用途が限定的ですし、考えるほどcheck-super-metaclass-compatibilityという名前のままでも良かったのではないかと思えてきます。

■

HTML generated by 3bmd in LispWorks 7.0.0

Slackなどの絵文字の入力方法に:+1:と入力して、👍を出すというのがありますが、どうしても手が勝手に:1+:と入力してしまうので、諦めて:1+:を絵文字として登録しました。
これで誤入力のイライラから開放されました。Common Lisp病の方にお勧めしたい解決策です。

■

HTML generated by 3bmd in LispWorks 7.0.0

Common Lispでもたまに列挙型が欲しいことがありますが、そもそも列挙型はある要素の集合のことを指すようで、連続的な整数の一連の別名というわけではない様子。

• Wikipedia:列挙型

そういった場合は、型記述子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とは微妙に目指すところが違うようです。

• #:g1: cl-enumerationの紹介

Common Lispだけで完結している場合には、あまり必要にならないのですが、既存のデータ定義を取り込んだり、別言語のコードを流用したりする場合に、enum欲しいなあとなることが多いですね。

■

HTML generated by 3bmd in LispWorks 7.0.0

• オブジェクト指向には、カメラがやっとついたころのガラケーのイメージがある

こちらの記事を読んで、自分が考えているオブジェクト指向とは随分違う何かがC++やJavaのオブジェクト指向プログラミングなんだなあと思いましたが、それと同時に、パラダイムがどうこうというより特定のパラダイムやシステムに囚われてしまう状況では、そこから抜け出すには、既存のものを捨てて他のパラダイムに移行せざるを得ないと考えてしまうのかもなあと感じました。

Common Lispはマルチパラダイムですが、

• 手続き/命令型(gotoもあり)
• 関数型/適用型/式指向
• とても動的なオブジェクト指向システム
• メタプログラミング(eval、マクロetc)

あたりが組込み機能です。

データがコードなため、メタプログラミングが容易で、組み込み言語のDSLで、Prologや、プロダクションシステム等を組込んで使ったりすることも可能です。 まあ、DSLが元言語とどこまで違和感なく連携するかはまた別の話ではありますが。

goto廃止論争が華やかだった時代も、マクロで構文を拡張できるLispは、gotoを廃止するということもなく、goを直接手書きしないような構文をマクロで言語標準機能として構築して迂回。
オブジェクト指向システムはSmalltalkの影響下で二三の実装がありましたが、最終的には総称関数という関数呼び出しにメッセージ送信を融合したような形式に収める、などなど、色々なパラダイムを吸収してきてはいますが、オブジェクト指向システムをほぼ使わずに書くことも可能ですし、関数がファーストクラスなので関数型的に書くことも容易です。
もともと対話環境が強力ですが、対話形式でも使えますし、バッチ形式でも使えます。 様々なパラダイムを強力なメタプログラミング機構がゆるくまとめているところもあるかもしれません。

こういうCommon Lispみたいな逃げ場が沢山ある言語が流行ると嬉しいですね。

■

HTML generated by 3bmd in LispWorks 7.0.0

• Swiftで大量のメンバ変数があるclassやstructのinitを自動生成する。

こちらの記事を目にして、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

LispWorks IDEの紹介

LispWorksの特長

LispWorksを他のCommon Lispの処理系と比較した場合の特徴としては、Lisp処理系とIDEが密に連携している点です。

1989年のHarlequinのLispWorksの紹介によると、言語処理系の設計に先行してIDEの設計をしたとありますが、この辺りがLispWorksがIDE然としてしている所以ではないでしょうか。

• comp.lang.lisp: Summary: Lucid vs. Allegro

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で便利な機能をピックアップして紹介

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

LispWorksのKnowledgeWorksでは、オブジェクトシステムと組み込みPrologが統合されています。
Prologの複合項(構造体)に相当するものをオブジェクトや構造体で表現しますが、この知識ベースクラスのオブジェクトや構造体はワーキングメモリという場所に蓄積されます。

ワーキングメモリに蓄積されたオブジェクトは、(class名 ?obj スロット名 ?slot ...)という形式でパターンマッチで問い合わせ可能になります。

読み込んだJSONや、plistで表現したデータ、ORMでSQLで問い合わせした結果のオブジェクト等、様々な形式のデータをワーキングメモリに格納し、Prologで問い合わせするのが割合に便利なのですが、今回は、LispWorksではなくPAIPrologのようなものでも似たようなことができないか試してみたいと思います。

ウェブページのスクレイピングを組み込みPrologで

今回は、ウェブページのスクレイピングをPrologの問い合わせでやってみます。
利用する組み込みPrologは、PAIPrologですが、単一化がeqlだったり、オブジェクトを項として登録するのに結局改造しないといけなかったので、実験用にPAIPrologからフォークして別パッケージを作成してみました。

• g000001 / zrpaiprolog

(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")

Prologの項を登録する

今回、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

恒例になっているので今年も振り返りのまとめを書きます。

Lisp的進捗

昨年は自分的にMOPブームでしたが、今年はMOPでプログラミングできる知識が大体揃って来た感じで、実際のプログラムでも普通に活用できたりするようになりました。
といっても大した応用ではないのですが、普通の道具になった、位のところです。

CLOS MOPだと大別すると、

• メタクラスの定義
• メタクラスの継承関係の処理(デフォルトの挙動、メタクラスのmixin時の挙動の定義等々)
• スロット定義
• オブジェクトの(再)初期化
• スロットへのアクセス方法

位が大きなトピックで他は上記の組み合わせか、細々としたところなので、クックブック的な感じでまとめておくと便利かなと思ったりしています。

ブログ

今年書いた記事は62記事でした。
まあまあ書いた方だとは思いますが、ネタ自体はストックが100記事分位はあるので、一旦全部出し切りたいところです。

LispWorks

LispWorksを購入してから五年半経過しましたが、すっかりSLIME+SBCLの環境よりLispWorksで書く方が楽になってしまいました。
単なる慣れというところもありますが、IDEとしてはSLIME+SBCLより統合されていて便利なところが多いです。まあもちろんエディタ単体ではHemlock(LispWorksのエディタ)よりGNU Emacsの方が高機能ですが。

仕事では、LispWorksで社内アプリ(Macのデスクトップアプリ)を量産していて、直近の業務で必要なツールを作成していていつの間にか20種類位になりました。
エンジニアでない人にGitHubを使ってもらうのに、GUIで簡単なラッパーを作成したり、社内業務のオートメーションでLispWorksが使えそうなところを見付けたら即投入しています。
Unixのシェルスクリプト、Google Apps Script、等々オートメーションのツールはありますが、手早く書捨てのGUIのアプリを作成できるという点では割とLispWorksは良いと思っています。

2021年の方向性

Lisp界隈もだいぶ盛り下がってきた感じで、当ブログももう誰も読んでない感じになってきました。
盛り上げる方法は多分ないのですが、文章のアウトプットは好きな方なので、ニッチなネタを垂れ流していきたいと思います。

また、13年位Lispコミュニティを眺めていますが、いまだLispに関する知識が1980年代な人を多く目にするのが不思議です。
恐らく古い書籍の情報をソースにしたものが再生成されているのではないかと思うのですが、このような傾向をアップデートすべく、2021年はWikipedia等の化石化した情報も更新したりすることにも取り組んでみようかなと思います(がWikipediaの更新は手間がかかる)

過去のまとめ

• #:g1: 2019年振り返り
• #:g1: 2018年振り返り
• #:g1: 2017年振り返り
• #:g1: 2016年振り返り
• #:g1: 2015年振り返り
• #:g1: 2014年振り返り
• #:g1: 2013年振り返り
• #:g1: 2012年振り返り
• #:g1: 2011年を振り返る
• #:g1: 2010年を振り返る
• #:g1: 2009年を振り返る
• #:g1: 今年一年をふりかえる

■

HTML generated by 3bmd in LispWorks 7.0.0

いつものようにCommon Lisp情報を求めてインターネットを徘徊していたのですが、ECLのマニュアルににCRSというのがあるのが気になって調べてみました。

• What is ECL

  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.

CRS(Common Runtime Support)

ECLのマニュアルの説明では、CRSは、メモリ管理やスレッド等の実行時に必要なものがモジュール化されたものという感じですが、CRSはECLとも独立した存在のようで、CRSについて別途論文も書かれていました。

• Multilanguage Interoperability(1991)

こちらの論文を読むと、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: Compiles Lisp into C(1994)

ECoLisp(Embeddable Common Lispの略)の略でECLとしていたものが、いつのまにかEmbeddable Common Lispの略でECLになったらしいのですが、別にECoLispのままでも良かったような……。

• The Embeddable Common Lisp, ACM Lisp

This is ECoLisp (ECL), an Embeddable Common Lisp implementation
Copyright (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をベースに構築しなおしたものなのかなと考えています。

CRSとPrologは何処へ

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

Lispの調べ物をしてインターネットを彷徨っていたところ、井田昌之先生が公開されている歴史的資料のページに辿り着きました。

• 井田昌之 公式ページ Dr. Masayuki IDA official portfolio

なんとCommon Lisp系を中心として歴史的な資料が満載ではないですか。
下記にLisp系の資料を抜粋したリンクを適当なコメントと共に並べてみます。

1973

1970年代は、Lisp 1.5 との出会いから、Intel 8080上で動くLispマシンである、ALPS/Iの開発を中心に研究されていたようです。
所謂マイコンといわれていたCPU上でLispを動かす研究としてはかなり初期の取り組みではないでしょうか。

• 197312Lisp1.5ProgrammersManual8thprinting

1976

• 197606カリキュレーションBit資料
• 197611IPSJ大会363
• 197611IPSJ大会364

1977

• 197709箱入り娘パズルの解法IPSJ全国大会
• 197710ALPS1機能IPSJ全国大会
• 197710IPSJ大会214
• 197710SYM02-1

1978

• 197808IPSJ大会2B8
• 197811Lispマシン製作奮戦記Bit

1979

• 197903LispマシンALPS1
• 197903SYM07-1
• 197903コンパクトな処理系が可能な連想情報モデル
• 197903連想情報モデル経営工学会誌
• 197911AdaptableLispMachineIEEECS
• 197911IEEECSConfAnAdaptableLispMachine

1981

1980年代前半は、ALPS/Iの開発と並行して当時擡頭してきたAIマシン(Lispマシン)も研究されていたようです。

• 198109LMICADRmachine

1984

• 198403SYM27-2
• 198408LMILambdaTechSummary
• 198409Lisp05コンパイラの設計
• 198410人工知能新聞記事
• 198412ALPS3の構想

1985

1984年にCommon Lispが登場しますが、それまでのマイコンLispの研究をバックグラウンドに、Common Lispのサブセットを検討されたり、Common Lispのオブジェクトシステムについて研究をされていたようです。

• 198506CommonLispいくつかの話題
• 198507HowtoObtainPCL
• 198508PICON日本語概要LMI
• 198509Lispコンテスト記号処理研究会
• 198509PersonalLispSystemComputersandIEFlorida
• 198511SYM34-4
• 198512InterpretationofCommonLoops
• 198512OOFacilitiesPrinciplesJSSSAnnualConf

1986

• 198601CommonLispパネル
• 198603CLOS原案WOOC86
• 198603PICONLMIOverview
• 198603SYM36-7
• 198604ISOTC97SC22N197NWIproposal
• 198605CommonLisp仕様の現在の論点とその方向
• 198608CommonLispCoreSummary
• 198608日仏ラウンドテーブル協力依頼
• 198609DiscriminatingEvalAnnualConfJSSST
• 198611SYM39-6
• 198611対談高度情報化社会
• 198612AAAI86会議報告
• 198612ICLispRelease
• 198612ISOTC97SC22N276AGRecommendations
• 198612日経オブジェクト指向ハード開発

1987

1986年あたりから電子メールを基盤とした議論について等も研究されている様子、また、ISO版Lispについての議論が盛り上がりつつあったことが判ります。

• 198701JISLisp現状認識と私見
• 198701LispandFP会議報告2
• 198702JeidaLisp技術動向調査計画
• 198703ANSIX3J13CommonLispアラカルト
• 198707CommonLoopsソフトウェア科学会
• 198708電子メール討論
• 198711JohnTeeter対談Bit
• 1987SymbolicsS-SystemLeaflet
• 1987SymbolicsS-SystemLeaflet2
• 1987SymbolicsS-Systemリーフレット

1988

ANSI CLに取り込まれる予定のCLOSがかなりまとまった頃で、CLOS的にはかなり熱い時期だったようです。

• 198801CommonLisp文字オブジェクト
• 198801SYM44-2
• 198803AMEXオーソライザーズアシスタント概要
• 198803ARTOverview
• 198808Jeida視察団報告
• 198808MacIvoryReaflet
• 198808MacIvoryRelease
• 198810CLOSワークショップ予稿集
• 198810SymbolicsIVORYArchitecture
• 198810チャートテスト教材原図Lisp
• 198810チャート型性格診断Lispプログラム

1989

• 198901CLOS仕様書共立出版採択分
• 198901CLOS概説
• 198906Lisp3rdED表紙サイン入り
• 198911SYM53-2

1990

ネットワーク透過なウィンドウツールキットであるYYonXの研究、ヨーロッパで擡頭してきた米国Common Lispへの対抗馬であるEuLisp等が熱い時期だったようです。
ワークステーション文化も花盛りという感もあり、キャンパスネットワーク等の研究もされていたようです。

• 199003Europal90-An-Overview-of-YY-and-YYonX
• 199003Europal招待講演
• 199003IPSJ全国大会YYoX
• 199003YYandYYoXEuropal
• 199004InterAI手探りの国際化
• 199008EULispDefinition
• 1990YY電子図書館孫悟空事例

1991

• 199101SYM58-2
• 199101YYカラーグラフィック機構
• 199102TR90004AnOverviewofYYandYYonX
• 199102YYandYYonX
• 199103ICEERL91PaloAlto
• 199103SYM59-2
• 199105青山学報情報センタ

1992

• 199203SYM64-6
• 199205CommonLispとXWindow共立出版

1993

• 199311SeminarPosterCMU

1994

• 199411ICERL91Record

1995

この辺りからLisp関連の研究は一段落され、当時擡頭してきたJavaの方に研究の軸足を移された様子。
また自由ソフトウェア運動の紹介等もされていたようです。

Emacsでは、レキシカルスコープは遅いのでダイナミックスコープを採用した、というのが通説ですが、この下記のインタビューではレキシカルスコープは速度と名前の競合回避には良いが、実装が簡単なのでダイナミックスコープを採用したとありますね。
レキシカルスコープは遅い説はどこが出所だったかな(History of T)だったような。

• 199505GNUEmacsLispRMS
• 199505RMSGNUEmacsLisp講演記事Bit
• 199512SchemePastPresentandFuture

1996

• 199604Scheme過去現在未来1
• 199605Scheme過去現在未来2
• 199606Emacs解剖学1
• 199607Emacs解剖学2
• 199608Emacs解剖学3
• 199609Emacs解剖学4
• 199610Emacs解剖学5
• 199611Emacs解剖学6
• 199612Emacs解剖学7

1997

• 199701Emacs解剖学8
• 199702Emacs解剖学9
• 199703Emacs解剖学完

2001

• 200102JavaOne98報告記草稿Webサイト
• 200109ANSIX3J13標準作成合意過程

2002

• 200201ANSIX3J13標準作成合意過程2

まとめ

まだまだ資料を全部は読み込めていないのですが、1980年代後半のCLOS系の資料や、Lispの国際規格化での各国の思惑等が伺える資料はかなり貴重だと思います。

■

HTML generated by 3bmd in LispWorks 7.0.0

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

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の構成と同一のようです。

• Tiny CLOS MOPが本家CLOS MOPの進化版だった件

Object Creation and Initialization

• 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等がそういう実装になっています。

Instance Structure Protocol

• 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

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>と表記します。

• 過去記事: #:g1: Telos in Common Lispの紹介

Object Creation and Initialization

• allocate
• make
• initialize

まず、インスタンスの構成ですが、class、slotsという二つの部分からなるprimitive-class構造体で表現されています。CLOSの実装でいうとwrapper部は、そのままクラスメタオブジェクトで表現されています。

インスタンスのストレージは標準でベクタ。 スロットストレージへは、primitive-class-slots、wrapperの取り出しは、primitive-class-ofで行えますが、クラスそのものなので別に必要ないかも?
CLOS MOPと異なる点としては、クラスがスロット数を保持するclass-instance-lengthを有します。

Instance Structure Protocol

• 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

allocate-instance Advent Calendar 2020 22日目の記事です。

前回に引き続き、allocate-instanceが関係してくるInstance Structure Protocol(ISP)周りを中心に色々なCLOS MOP系の処理系で確認していきたいと思います。

今回は、MCSのallocate-instance周りを眺めます。
まず、MCSですが、The Meta Class Systemの略で、ObjVlispの流れをくみつつCLOSとの互換性も高いシステムです。

• 過去記事: #:g1: mcsの紹介

MOPも大体同じような構成になっていますが、MCSの方がシンプルでありつつ抽象クラスやmixinクラス等も用意されていて色々整理されているようにも見えます。

Object Creation and Initialization

• 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に格納されています。

Instance Structure Protocol

• 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

allocate-instance Advent Calendar 2020 21日目の記事です。

ネタ切れも甚しいのでallocate-instanceが関係してくるInstance Structure Protocol(ISP)周りを中心に色々なCLOS MOP系の処理系で確認していきたいと思います。

まずは、本家Common Lispです。

Instance Structure Protocol

• CLOS MOP: Instance Structure Protocol

• 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 finalization protocol

• CLOS MOP: Class finalization protocol

• class-finalized-p

• finalize-inheritance

継承関係の確定のプロトコルですが、インスタンスがアロケートされる前に確定している必要があるとされており、allocate-instanceが呼ばれる前にclass-finalized-pで調べて確定していなければ、finalize-inheritanceが呼ばれるとされています。

• CLOS MOP: allocate-instance

この判定のタイミングですが、Robert Strandh先生によれば、allocate-instanceの引数のinitargsは確定後の計算結果になるので呼ばれる前に確定している筈としていてPCLでも、make-instanceがfinalize-inheritanceを呼んでいると註記していますが、PCL系であるSBCL等では、allocate-instanceの中で呼ばれています(ensure-class-finalized経由)。

大抵の処理系では、finalize-inheritanceを呼んでいるので、実際のところ必須なのかそうでないのか。ちなみに自分はStrandh先生を信じて今回のアドベントカレンダでは呼ばないスタイルで通しました。

Object Creation and Initialization

• 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

allocate-instance Advent Calendar 2020 20日目の記事です。

MOPの応用として、仮想的なアロケーションの場所を指定する例があります。

• STklos: 8.2.1.4 Virtual Slots
• LispWorks User Guide and Reference Manual > 18.4 Implementation of virtual slots

大抵は、スロットの: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

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

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

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