#:g1: CommonObjectsをつくろう(0)

Posted 2021-08-02 01:30:52 GMT

先日bitsaversにHP Common Lisp(HPCL)のマニュアルがアップされました。

HPCLには二種類の系統があり、ユタ大学のPortable Standard Lisp(PSL)のエコシステム一式がCommon Lisp化した最初の版と、Lucid社のOEM処理系で実質Lucid CLの第二版があります。

今回アップロードされたマニュアルは、PSLベースのもので、独自の系統だけに結構貴重です(Lispマニア的には)。

ユタ大学のPSLのエコシステムには処理系以外にもエディタや、オブジェクト指向システム、エキスパートシステムのツールキット等が1980年代中半までには確立していたようなのですが、その辺りの一式もCommon Lispに移植されていたようです。

アップロードされたマニュアルの一つにNMODEというLisp実装のEmacsのマニュアルが含まれていますが、元はPSL上で稼動していたものの様子

1980年代中後半の商用Lispシステムといえば、エキスパートシステム需要が大きかったことを反映してか、定番構成として、

のようなものが鉄板だったようです。HPもHP 9000/300を中心にそのようなLispシステムの販売を展開していた様子。

CommonObjects

そんなHPCLですが、マニュアルを眺めてみるとオブジェクト指向システムとしてCommonObjectsとみられる解説がありました。

CommonObjectsは、Common Lispのオブジェクト指向システムの歴史には良く出てくるシステムなのですが、オンラインで入手できる文献が非常に少ないので、こちらも結構貴重です。

1987年にPortable CommonLoops上にCommonObjectsを実装したcoolというのがあり、個人的にANSI CLで動くようにしてみていたことがありますが、マニュアルをざっと眺める限り大体の機能はCLOS MOPで実装できそうな気がするので、適当にCommonObjectsを再現していくことにしました。

クラス定義構文の実装

何も考えずにマニュアルの先頭から実装していきますが、まずは、define-typeというdefclassに相当する機能の説明があるので、これを作成してみようと思います。
define-type構文は眺める限り、standard-classや、standard-slot-definition以上の機能は特にないようです。
gettablesettableinitableのオプションはFlavorsの影響かなと思いますが、これはアクセサを生成するかどうかのオプションです。

ということで、マニュアルの冒頭を適当に動かして遊んでみるレベルから開始すると下記のようになりました。

(defpackage "https://github.com/g000001/zrco"
  (:use)
  (:export
   =>
   apply-method
   assignedp
   call-method
   define-method
   define-type
   instance
   instancep
   ;; make-instance
   rename-type
   self
   send?
   supports-operation-p
   undef
   undefine-method
   undefine-type
   import-specialized-functions
   ))

(defpackage "https://github.com/g000001/zrco#internals" (:use "https://github.com/g000001/zrco" c2cl) (:shadowing-import-from "https://github.com/g000001/zrco" call-method))

(cl:in-package "https://github.com/g000001/zrco#internals")

(defclass common-objects-class (standard-class) ())

(defmethod validate-superclass ((sub common-objects-class) (sup standard-class)) T)

(defclass common-objects-object (standard-object) () (:metaclass common-objects-class))

(defclass common-objects-direct-slot-definition (standard-direct-slot-definition) ((init :initarg :init) (var :initarg :var) (initable :initarg :initable :reader slot-definition-initable) (gettable :initarg :gettable :reader slot-definition-gettable) (settable :initarg :settable :reader slot-definition-settable)))

(defun make-keyword (name) (intern (string name) :keyword))

(defgeneric => (obj msg &rest opts))

(defgeneric (setf =>) (val obj msg &rest opts))

(defmethod initialize-instance ((class common-objects-direct-slot-definition) &rest initargs &key (init nil initp) initable var gettable settable) (when (or settable gettable) (eval `(defmethod => ((obj common-objects-object) (msg (eql ,(make-keyword var))) &rest opts) (slot-value obj ',var)))) (when settable (eval `(progn (defmethod (setf =>) (val (obj common-objects-object) (msg (eql ,(make-keyword var))) &rest opts) (setf (slot-value obj ',var) val)) (defmethod => ((obj common-objects-object) (msg (eql ,(make-keyword (concatenate 'string (string 'set-) (string var))))) &rest opts) (setf (slot-value obj ',var) (car opts)))))) (apply #'call-next-method class (append (and var `(:name ,var)) (and initp `(:initform ,init)) (and initp `(:initfunction ,(lambda () init))) (and (or initable gettable settable) `(:initargs (,(make-keyword var)))) initargs)))

(defmethod direct-slot-definition-class ((class common-objects-class) &rest initargs) (find-class 'common-objects-direct-slot-definition))

(defun parse-slot (slot-form) (destructuring-bind (var name &rest opts) slot-form (check-type var (eql :var)) (check-type name symbol) (list* 'list :name `',name ;kludge :var `',name (mapcan (lambda (s) (typecase s (keyword (list s T)) (cons (copy-list s)))) opts))))

(defun ensure-common-objects-class (name &rest args &key environment documentation direct-slots &allow-other-keys) (declare (ignore environment)) (apply #'ensure-class-using-class (class-prototype (find-class 'common-objects-class)) name :documentation documentation :direct-superclasses (list (find-class 'common-objects-object)) :direct-slots direct-slots :metaclass (find-class 'common-objects-class) args))

(defmacro define-type (type-name &optional doc-string &body slots &environment environment) (declare (ignore environment)) (if (typep doc-string 'string) (setq slots (cdr slots)) (setq slots (cons doc-string slots) doc-string nil)) `(ensure-common-objects-class ',type-name :documentation ,doc-string :direct-slots (list ,@(mapcar #'parse-slot slots))))

=>(send)を定義する場所がinitialize-instanceの中というのも変ですが、initialize-instanceの中でdefmethodを呼ぶのもまた嫌です。
しかし、make-methodで扱うmethod-functionの引数の形式がポータブルでなかった気がするので、defmethodにしました。
また、毎度のことですが、構文のスコープの扱い(名前⇔オブジェクト)が面倒臭いです。この辺りは、Schemeのようにオブジェクトだけだと統一感もあって楽なのですが。

試してみる

define-type構文が作るスコープの詳細が不明なのですが、defunと同じく周囲の変数は取り込めるようにしてみました。

(define-type foo
  (:var x (:type 'list) (:init '(0 1 2 3)) :settable)
  (:var y (:type 'integer) (:init 0) :initable))

(let ((obj (make-instance 'foo :x '(0 0 0 0) :y 42))) (list (=> obj :x) (setf (=> obj :x) '(1 1 1 1)) (=> obj :x) (=> obj :set-x '(2 2 2 2)) (=> obj :x)))((0 0 0 0) (1 1 1 1) (1 1 1 1) (2 2 2 2) (2 2 2 2))

(let ((x 33)) (define-type bar (:var x (:init x) :settable)))

(=> (make-instance 'bar) :x) → 33

まとめ

色々、改善したい点はありますが、とりあえずは、マニュアルの内容が一式動くようになるまで雑に作ってみたいと思います。


HTML generated by 3bmd in LispWorks 7.0.0

comments powered by Disqus