nptclのブログ

Common Lisp処理系nptの開発メモです。https://github.com/nptcl/npt

オブジェクト指向の難易度を下げる

Common Lisp

Common Lispにはオブジェクト指向のシステムが存在します。
通称、CLOS (Common Lisp Object System)です。
本章は、不完全な知識でCLOSを開発していくことを考えます。

Common Lispでは、CLOSはオプションではなく必須の機能です。
特にエラーで使用します。
つまりconditionです。
とにかくconditionは早く必要な機能なのですけど、 CLOSの実装が意味不明過ぎてなかなか完成しませんでした。
何度も何度も作り直した記憶があります。

これがCommon Lispの開発の難易度を一気に上げていました。
でも分かってしまえば何のことはありません。
本投稿では最低限のCLOSのシステムを構築し、 早急に必要だったconditionの判定を行う方法まで説明します。

1. オブジェクトとはkey-value構造体

「オブジェクト指向」とは全てを「オブジェクト」で作成するという プログラミング言語の哲学のようなものです。
Common Lispはそもそもベースがオブジェクト指向ではないので、 全てがオブジェクトであるという考え方には完全に乗っていません。
でもCLOSというシステムだけ見ると、オブジェクト指向に従っていると言えます。

key-value構造体というのは、keyが与えられたら対応するvalueが返却されるというもの。
幸いにしてCommon Lispには、標準で3つものkey-value構造体が存在します。

  • alist
  • plist
  • hash-table

今回使うのは、alistです。
plistの方が好きっていうならplistでも構いません。
でもhash-tableはやめた方がいいでしょう。

「オブジェクト」というのは、別名インスタンスと呼ばれるものです。
Common Lispに限りませんが、インスタンスは大量に作成されます。
その一つ一つにhash-tableを割り当てるのは、 たぶん容量的に無駄が大きいですし、 しかもオブジェクト指向システムにおいて、そこまで求められていません。
だからhash-tableは、やりたいなら止めませんが、今回はやめておきます。

alist (associate list)というのは、こんな感じのものです。

  ((key1 . value1) (key2 . value2) ...)

plist (property list)というのあ、こんなレイアウト。

  (key1 value1 key2 value2 ...)

見てわかる通り、非常に単純ですが、 データが大量にある場合は、検索に時間がかかるという欠点があります。
あと、key-valueのペアごとにconsが1つ作成されるため、 効率もそれほど良くはありません。
まずは単純という利点を採用し、alistで説明して行きます。

2. CLOSオブジェクト

まずはオブジェクトを作りましょう。
オブジェクトは別名インスタンスです。
インスタンスは次の2つの情報を保有します。

  • class-of
  • key-value構造体

class-ofというのは、そのインスタンスが一体誰から生まれたかという情報です。
Common Lispで書くならば、

(let ((inst (make-instance 'hello)))
  ...)

という文中において、instに束縛されるのがインスタンス、 instのclass-ofが、helloというクラスのインスタンスになります。

それでは、CLOSオブジェクトのレイアウトを示します。
こんな感じにしようかと思います。

(clos-instance (key1 . value1) (key2 . value2) ...)

clos-instanceというシンボルはヘッダーです。
key1, value1, ...はkey-value構造体です。
class-ofは一体どこに行ったのかというと、 keyがclos-class-ofというシンボルの場合を 専用に割り当てることにしました。

それでは、例としてhelloというクラスから作成され、 aaa, bbbというスロットを持つインスタンスのレイアウトを示します。

(clos-instance
  (clos-class-of . #<STANDARD-CLASS HELLO>)
  (aaa . clos-unbound)
  (bbb . clos-unbound))

非常に簡単ですね。
このインスタンスには3つのslotがあり、 名前はそれぞれclos-class-of, aaa, bbbです。
clos-unboundというのは、名の通りslotがunboundであることを意味します。

この構造がオブジェクト指向の全ての基本となります。
もうこれだけで、クラスシステムだろうがジェネリック関数だろうが なんだって構築できます。

では、インスタンスを作成する関数を作成します。

(defun clos-make (&rest args)
  (cons 'clos-instance
        (mapcar
          (lambda (x)
            (cons x 'clos-unbound))
          (cons 'clos-class-of args))))

(defun clos-p (inst)
  (and (consp inst)
       (eq (car inst) 'clos-instance)))

clos-make関数は、引数で指定したslotをもつインスタンスを作成します。
clos-pは、CLOSオブジェクトかどうかを確認します。

例で示したインスタンスを作成するには次のように行います。

(clos-make 'aaa 'bbb)

これで、値が設定されていないインスタンスが作成されました。
ここからclos-class-ofというslotに値#<STANDADR-CLAS HELLO>を 設定しなければなりませんが、設定の説明は省略し、 代わりにslotのアクセス関数について説明します。

3. slotの操作

slotの操作の基本となる関数を下記に示します。

(clos-get inst key)
(clos-set inst key value)
(clos-exists-p inst key)
(clos-boundp inst key)
(clos-makunbound inst key)

なぜCommon Lispの、例えばslot-valueを使用しないのでしょうか？
理由は、slot-valueなどの標準関数はerrorconditionが発生するためです。
今回作成するのは、まだconditionが作成されていないことを前提としています。
とはいっても、エラーは必ず発生するため、 Abortするだけの関数は用意しておこうと思います。

(defun clos-error (x &rest args)
  (format t "~&ERROR: ~S ~S~%" x args)
  (error 'error))

clos-error関数は、エラーを通知します。
目的はシステムを異常終了させるだけなので、好きなように作ってよいと思います。
最後に(error 'error)を実行していますが、適切なAbort関数に置き換えてください。

それではアクセス関数の実装を説明します。

(defun clos-cons (inst key)
  (unless (clos-p inst)
    (clos-error "type error." inst))
  (assoc key (cdr inst)))

(defun clos-get (inst key &optional (default nil default-p))
  (let ((x (clos-cons inst key)))
    (cond (x (cdr x))
          (default-p default)
          (t (clos-error "No slot name." key)))))

clos-get関数は、slotから値を取得するためのものです。
slotが存在しない場合は、異常終了しますが、 第3引数を指定することで、デフォルト値を返却できます。
slot-valueであれば、slotが存在しない場合は 総称関数slot-missingが呼ばれたり、 その結果、errorconditionが発生したりするのですが、 まだそんなシステムは存在しないため、 clos-error関数を呼んで異常終了させています。
もしslotの値がunboundの場合は、clos-unboundというシンボルを返却します。

(defun clos-set (inst key value)
  (let ((x (clos-cons inst key)))
    (if x
      (rplacd x value)
      (clos-error "No slot name." key))
    value))

clos-set関数は、slotの値を設定します。
もしslotが存在しない場合は異常終了します。

(defun clos-exists-p (inst key)
  (and (clos-cons inst key)
       t))

clos-exists-p関数はslotが存在するかどうかを調べます。

(defun clos-boundp (inst key)
  (not (eq (clos-get inst key) 'clos-unbound)))

clos-boundp関数は、slotが値を持っているか、unboundかどうかを調べます。
もしslotが存在しない場合は異常終了します。

(defun clos-makunbound (inst key)
  (clos-set inst key 'clos-unbound))

clos-makunbound関数は、slotをunboundにします。
もしslotが存在しない場合は異常終了します。

(defun clos-class-of (inst)
  (clos-get inst 'clos-class-of nil))

clos-class-of関数は、class-ofを取得します。
clos-getを使って直接値を取得しても良いのですが、 よく使うslotなので、専用の関数を用意しました。

5. CLOSオブジェクトの表示

これからCLOSオブジェクトを用いてクラスの作成をしていきますが、 クラスはslotに自分自身を格納したりしますので、 単純にformatやらprin1関数で表示しようとすると 循環が生じて非常に見づらいです。

pprint-dispatchを操作して、 もう少し見やすいようにします。

(deftype clos ()
  '(cons (eql clos-instance) list))

(defun clos-printer-instance (inst)
  (clos-get inst 'name "..."))

(defun clos-printer-class-of (inst)
  (let ((x (clos-class-of inst)))
    (if x
      (clos-printer-instance x)
      "...")))

(defun clos-printer (stream inst)
  (format stream "#<CLOS: ~A ~A>"
          (clos-printer-class-of inst)
          (clos-printer-instance inst)))

(set-pprint-dispatch 'clos #'clos-printer)

見づらくてもいいやって人は、pprint-dispatchを操作する必要はありません。

6. クラスの作成

クラスとは、インスタンスを作成するための設計書です。
純粋なオブジェクト指向においては、 クラスもインスタンスであり、 他のインスタンスと同様にslotを持っています。

Common Lispでは、最低限次のようなslotが存在します。

name
direct-superclasses
direct-subclasses
precedence-list
direct-slots
slots
direct-initargs
initargs
finalized-p
prototype

つまり、こんな感じで実行すれば、もうそれはクラスです。

(clos-make
  'name
  'direct-superclasses
  'direct-subclasses
  'precedence-list
  'direct-slots
  'slots
  'direct-initargs
  'initargs
  'finalized-p
  'prototype)

ここではもっと内容を詰めます。
とりあえず、クラスの作成は上記のように実行しますが、 使うslotは下記のものだけにします。

  • name
  • precedence-list

2つだけ！
他のやつらはどうしたんだということは、ちゃんと説明して行きます。

まずは次のslotから。

  • direct-superclasses
  • direct-subclasses

これらのslotの大きな仕事は、precedence-listを構築することです。
まず、superclassesが何かというと、

(defclass name (superclasses...) () ...)

上記で言う、スーパークラスを指定する場所です。
superclassesのリストが指定されたら、 クラスを一つずつたどっていき、全てのクラスを寄せ集めて、 「トポロジカルソート」と呼ばれる並び替えを行います。
そうすることによって、最終的にクラスの順番が決定されて、 そのリストをprecedence-listというslotに格納します。

precedence-listというのは、つまりは優先順位リストです。
precedence-listは色んなところで使います。
例えば、slotを作ったり、initargsを作ったり、 あるいはmethodの呼び出し順序を決めるときにも使います。

大抵の処理はprecedence-listだけで何とかなります。
少なくとも、conditionを作成するまでは問題ありません。

subclassesは、superclassesの逆であり、 superclassesで指定されたクラスのsubclassesに、 defclassで作成されたクラスが登録されます。
今回は全く使いません。

本来であればsuperclassesからprecedence-listを求めるのですが、 トポロジカルソートというものを作るのはそれなりに苦労します。
しかし、単純なものなら適当でもそれなりに動作しますし、 Common Lisp標準のクラスなら、規格書にprecedence-listが載っていますので、 それを見て設定してあげるだけで問題ありません。
興味がある方は、ANSI Common Lispやらcltl2eやらに 詳しく載っているのでそちらをご覧ください。

では、話は変わって次のslotはどうなのか。

  • direct-slots
  • slots

これらのslotは、defclassでいう、次の引数です。

(defclass name () (slots ...))

本来、defclassは、これらのslotの情報を読み込んで、 適切なslotを生成するように計算しますが、 今は全部自分で計算してください。
つまり、clos-make関数に指定するslotの名前を、 ちゃんと自分で手で書いてくださいということです。

それでは最後に、次のslotはどうでしょうか。

  • direct-initargs
  • initargs

これらは、make-instanceなどで使われる、 &rest initarg &key &allow-other-keysのことです。
初期化引数リストとも呼ばれます。

今はそもそもinitargを使いません。
つまり、make-instanceを使わず、 全てのインスタンスはclos-makeを使って自分で作成することを考えています。

以上をすべてまとめると、つまりは 下記の2つしかslotが必要ないということになります。

  • name
  • precedence-list

7. 標準クラスの作成

標準クラスというのは、具体的には下記のことです。

  • t
  • class
  • built-in-class
  • standard-class
  • standard-object

今回はstandard-classとstandard-objectしかいりません。
しかし、これらの継承関係は複雑であり、 precedence-listを示すと次のようになっています。

t               -> t
class           -> class standard-object t
built-in-class  -> built-in-class class standard-object t
standard-class  -> standard-class class standard-object t
standard-object -> standard-object t

さらに面白いことに、上記のclass-ofは次のようになります。

t               -> built-in-class
class           -> standard-class
built-in-class  -> standard-class
standard-class  -> standard-class
standard-object -> standard-class

standard-classは、standard-classから産まれたと言っています。
これがオブジェクト指向の面白い所であり、 純粋なオブジェクト指向なら、こういう親と子の閉ループが必ず生じます。
自分が自分を産んだって、細胞分裂でもしたんだろうか。

このような異常な関係は、Common Lispの標準関数では作成できません。
しかし、私たちにはclos-make関数があります。
例え矛盾しまくっているような関係でも簡単に作成できます。

まずは、クラスを登録するシステムを作ります。
いわゆるfind-class関数の別バージョンです。
クラスの登録は、symbol-plistを利用することとします。

;;
;;  clos-class-get  -> (find-class 'name nil)
;;  clos-class-set  -> (setf (find-class 'name) value)
;;
(defun clos-class-get (name &optional (errorp t))
  (let ((x (get name 'clos-instance)))
    (cond ((clos-p x) x)
          (errorp (clos-error "clos-class-get error" name))
          (t nil))))

(defun clos-class-set (name value)
  (setf (get name 'clos-instance) value))

clos-class-get関数は、find-class関数そのものです。
clos-class-set関数は、クラスを登録するものです。

ではクラスを作成していきます。
まずは空のクラスを作成する関数を示します。

(defun clos-class-make ()
  (clos-make
    'name
    'direct-superclasses
    'direct-subclasses
    'precedence-list
    'direct-slots
    'slots
    'direct-initargs
    'initargs
    'finalized-p
    'prototype))

(clos-class-set 't               (clos-class-make))
(clos-class-set 'class           (clos-class-make))
(clos-class-set 'built-in-class  (clos-class-make))
(clos-class-set 'standard-class  (clos-class-make))
(clos-class-set 'standard-object (clos-class-make))

空のクラスを先行して登録することで、 class-ofとprecedecen-listに矛盾が生じたとしても 正しく処理できるようにします。
登録した後にクラスの情報を正しく設定します。

(defun clos-define-class (name args metaclass)
  (let* ((x (clos-class-get name))
         (list (cons x (mapcar #'clos-class-get args)))
         (class-of (clos-class-get metaclass)))
    (clos-set x 'name name)
    (clos-set x 'precedence-list list)
    (clos-set x 'clos-class-of class-of)))

(defmacro clos-class-list (name &rest args)
  `(clos-define-class ',name ',args 'standard-class))

(clos-define-class t nil 'built-in-class)
(clos-class-list class standard-object t)
(clos-class-list built-in-class class standard-object t)
(clos-class-list standard-class class standard-object t)
(clos-class-list standard-object t)

tクラスだけ、class-ofがbuilt-in-classなので処理が変わっています。
それでは、まずはclass-ofの確認から行いましょう。
確認は、単純にformatで出力してみるだけです。

(format t "~S~%" (clos-class-get 't))
(format t "~S~%" (clos-class-get 'class))
(format t "~S~%" (clos-class-get 'built-in-class))
(format t "~S~%" (clos-class-get 'standard-class))
(format t "~S~%" (clos-class-get 'standard-object))

結果は下記の通り。

#<CLOS: BUILT-IN-CLASS T>
#<CLOS: STANDARD-CLASS CLASS>
#<CLOS: STANDARD-CLASS BUILT-IN-CLASS>
#<CLOS: STANDARD-CLASS STANDARD-CLASS>
#<CLOS: STANDARD-CLASS STANDARD-OBJECT>

続いてprecedence-listの確認です。

(format t "~S~%" (clos-get (clos-class-get 't) 'precedence-list))
(format t "~S~%" (clos-get (clos-class-get 'class) 'precedence-list))
(format t "~S~%" (clos-get (clos-class-get 'built-in-class) 'precedence-list))
(format t "~S~%" (clos-get (clos-class-get 'standard-class) 'precedence-list))
(format t "~S~%" (clos-get (clos-class-get 'standard-object) 'precedence-list))

結果は下記の通り。

(#<CLOS: BUILT-IN-CLASS T>)
(#<CLOS: STANDARD-CLASS CLASS> #<CLOS: STANDARD-CLASS STANDARD-OBJECT>
 #<CLOS: BUILT-IN-CLASS T>)
(#<CLOS: STANDARD-CLASS BUILT-IN-CLASS> #<CLOS: STANDARD-CLASS CLASS>
 #<CLOS: STANDARD-CLASS STANDARD-OBJECT> #<CLOS: BUILT-IN-CLASS T>)
(#<CLOS: STANDARD-CLASS STANDARD-CLASS> #<CLOS: STANDARD-CLASS CLASS>
 #<CLOS: STANDARD-CLASS STANDARD-OBJECT> #<CLOS: BUILT-IN-CLASS T>)
(#<CLOS: STANDARD-CLASS STANDARD-OBJECT> #<CLOS: BUILT-IN-CLASS T>)

うまく登録されているのがわかります。

8. コンディションの作成

コンディションとは、エラーを扱った仕組みです。
conditionのクラスがエラーの種別であり、 conditionのインスタンスがエラーそのものになります。

本投稿の目的は、CLOSシステムを使用してconditionの判定を行うことにありました。
例として下記のconditionを作成することを考えます。

  • simple-error
  • program-error

どちらもprecedence-listの内容はそれなりに複雑です。

;;  class-precedence-list
;;    -> condition t
;;    -> serious-condition condition t
;;    -> error serious-condition condition t
;;    -> simple-condition condition t
;;    -> simple-error simple-condition error serious-condition condition t
;;    -> parse-error error serious-condition condition t

標準クラスの時と同様にclos-makeを使って生成して行けばいいだけです。
まずはconditionクラスを作ります。

(clos-class-set 'condition         (clos-class-make))
(clos-class-set 'serious-condition (clos-class-make))
(clos-class-set 'error             (clos-class-make))
(clos-class-set 'simple-condition  (clos-class-make))
(clos-class-set 'simple-error      (clos-class-make))
(clos-class-set 'parse-error       (clos-class-make))

(clos-class-list condition t)
(clos-class-list serious-condition condition t)
(clos-class-list error serious-condition condition t)
(clos-class-list simple-condition condition t)
(clos-class-list simple-error simple-condition error serious-condition condition t)
(clos-class-list parse-error error serious-condition condition t)

では、simple-errorのインスタンスの作成を行います。
本来であればmake-instance関数を使用するのですが、 先ほど説明した通り、今回はクラスのslotを 2つしか作成していないため使用することはできません。

作成する関数を下記に示します。

(defun make-instance-simple-error (control arguments)
  (let ((x (clos-make
             'format-control
             'format-arguments))
        (class-of (clos-class-get 'simple-error)))
    (clos-set x 'format-control control)
    (clos-set x 'format-arguments arguments)
    (clos-set x 'clos-class-of class-of)
    x))

conditionの判定を行うためには、 CLOS専用のsubtypep関数が必要となります。
ただ単純にprecedence-listにクラスが存在するかどうかを確認するだけのものとなります。
確認に使用する関数を下記に示します。

(defun clos-subclass-p (inst super)
  (and (find super (clos-get inst 'precedence-list))
       t))

(defun clos-subtype-p (inst super)
  (clos-subclass-p
    (clos-class-of inst)
    (clos-class-get super)))

それでは、インスタンスの確認を行ってみます。

(defun print-simple-error (x stream)
  (apply #'format stream
         (clos-get x 'format-control)
         (clos-get x 'format-arguments)))

(let ((x (make-instance-simple-error "Hello: ~S~%" '(100))))
  (format t "simple-condition check.~%")
  (when (clos-subtype-p x 'simple-condition)
    (print-simple-error x t))
  (format t "parse-error check.~%")
  (when (clos-subtype-p x 'parse-error)
    (print-simple-error x t)))

実行結果は下記の通り。

simple-condition check.
Hello: 100
parse-error check.

simple-conditionではsubtypepがtとなり、 program-errorではnilとなったのがわかります。

9. まとめ

今回示したかったことは、CLOSシステムが不完全であっても、 単純にconsの操作をするだけで、 クラスの判定をすることができるということです。

defclassやdefgenericは、マクロを作るだけでも相当難しく、 実行する処理を完全に作るためには何日もかかる重労働となります。
だからこそ、本章で説明したような骨組みをあらかじめ作っておいて 後からdefclassなどを作るようにすれば、 手戻りはそれほど生じずに開発して行けるのだと思います。

A. 付録

最後に、実験に使用したコードを示します。

;;
;;  clos
;;
(defun clos-error (x &rest args)
  (format t "~&ERROR: ~S ~S~%" x args)
  (error 'error))

(defun clos-make (&rest args)
  (cons 'clos-instance
        (mapcar
          (lambda (x)
            (cons x 'clos-unbound))
          (cons 'clos-class-of args))))

(defun clos-p (inst)
  (and (consp inst)
       (eq (car inst) 'clos-instance)))

(defun clos-cons (inst key)
  (unless (clos-p inst)
    (clos-error "type error." inst))
  (assoc key (cdr inst)))

(defun clos-get (inst key &optional (default nil default-p))
  (let ((x (clos-cons inst key)))
    (cond (x (cdr x))
          (default-p default)
          (t (clos-error "No slot name." key)))))

(defun clos-set (inst key value)
  (let ((x (clos-cons inst key)))
    (if x
      (rplacd x value)
      (clos-error "No slot name." key))
    value))

(defun clos-exists-p (inst key)
  (and (clos-cons inst key)
       t))

(defun clos-boundp (inst key)
  (not (eq (clos-get inst key) 'clos-unbound)))

(defun clos-makunbound (inst key)
  (clos-set inst key 'clos-unbound))

(defun clos-class-of (inst)
  (clos-get inst 'clos-class-of nil))


;;
;;  dispatch-printer
;;
(deftype clos ()
  '(cons (eql clos-instance) list))

(defun clos-printer-instance (inst)
  (clos-get inst 'name "..."))

(defun clos-printer-class-of (inst)
  (let ((x (clos-class-of inst)))
    (if x
      (clos-printer-instance x)
      "...")))

(defun clos-printer (stream inst)
  (format stream "#<CLOS: ~A ~A>"
          (clos-printer-class-of inst)
          (clos-printer-instance inst)))

(set-pprint-dispatch 'clos #'clos-printer)


;;
;;  clos-class-get  -> (find-class 'name nil)
;;  clos-class-set  -> (setf (find-class 'name) value)
;;
(defun clos-class-get (name &optional (errorp t))
  (let ((x (get name 'clos-instance)))
    (cond ((clos-p x) x)
          (errorp (clos-error "clos-class-get error" name))
          (t nil))))

(defun clos-class-set (name value)
  (setf (get name 'clos-instance) value))


;;
;;  class
;;;
(defun clos-class-make ()
  (clos-make
    'name
    'direct-superclasses
    'direct-subclasses
    'precedence-list
    'direct-slots
    'slots
    'direct-initargs
    'initargs
    'finalized-p
    'prototype))

(defun clos-define-class (name args metaclass)
  (let* ((x (clos-class-get name))
         (list (cons x (mapcar #'clos-class-get args)))
         (class-of (clos-class-get metaclass)))
    (clos-set x 'name name)
    (clos-set x 'precedence-list list)
    (clos-set x 'clos-class-of class-of)))

(defmacro clos-class-list (name &rest args)
  `(clos-define-class ',name ',args 'standard-class))

(clos-class-set 't               (clos-class-make))
(clos-class-set 'class           (clos-class-make))
(clos-class-set 'built-in-class  (clos-class-make))
(clos-class-set 'standard-class  (clos-class-make))
(clos-class-set 'standard-object (clos-class-make))

(clos-define-class t nil 'built-in-class)
(clos-class-list class standard-object t)
(clos-class-list built-in-class class standard-object t)
(clos-class-list standard-class class standard-object t)
(clos-class-list standard-object t)

(format t "~S~%" (clos-class-get 't))
(format t "~S~%" (clos-class-get 'class))
(format t "~S~%" (clos-class-get 'built-in-class))
(format t "~S~%" (clos-class-get 'standard-class))
(format t "~S~%" (clos-class-get 'standard-object))

(format t "~S~%" (clos-get (clos-class-get 't) 'precedence-list))
(format t "~S~%" (clos-get (clos-class-get 'class) 'precedence-list))
(format t "~S~%" (clos-get (clos-class-get 'built-in-class) 'precedence-list))
(format t "~S~%" (clos-get (clos-class-get 'standard-class) 'precedence-list))
(format t "~S~%" (clos-get (clos-class-get 'standard-object) 'precedence-list))


;;
;;  subtypep
;;
(defun clos-subclass-p (inst super)
  (and (find super (clos-get inst 'precedence-list))
       t))

(defun clos-subtype-p (inst super)
  (clos-subclass-p
    (clos-class-of inst)
    (clos-class-get super)))


;;
;;  condition
;;
(clos-class-set 'condition         (clos-class-make))
(clos-class-set 'serious-condition (clos-class-make))
(clos-class-set 'error             (clos-class-make))
(clos-class-set 'simple-condition  (clos-class-make))
(clos-class-set 'simple-error      (clos-class-make))
(clos-class-set 'parse-error       (clos-class-make))

(clos-class-list condition t)
(clos-class-list serious-condition condition t)
(clos-class-list error serious-condition condition t)
(clos-class-list simple-condition condition t)
(clos-class-list simple-error simple-condition error serious-condition condition t)
(clos-class-list parse-error error serious-condition condition t)

(defun make-instance-simple-error (control arguments)
  (let ((x (clos-make
             'format-control
             'format-arguments))
        (class-of (clos-class-get 'simple-error)))
    (clos-set x 'format-control control)
    (clos-set x 'format-arguments arguments)
    (clos-set x 'clos-class-of class-of)
    x))

(defun print-simple-error (x stream)
  (apply #'format stream
         (clos-get x 'format-control)
         (clos-get x 'format-arguments)))

(let ((x (make-instance-simple-error "Hello: ~S~%" '(100))))
  (format t "simple-condition check.~%")
  (when (clos-subtype-p x 'simple-condition)
    (print-simple-error x t))
  (format t "parse-error check.~%")
  (when (clos-subtype-p x 'parse-error)
    (print-simple-error x t)))