2014-11-03-01-lambdaでクラス - project-enigma

2014-11-03-01-lambdaでクラス

>> Site top >> weblog >> 月別アーカイブ >> 2014年11月のlog >> 2014-11-03-01-lambdaでクラス

最終更新日付:2014/11/03 23:55:00


lambdaでクラス

2014 年 11 月 03 日

10月は何も書かずに過ぎさってしまった。そのため、とりあえずの適当な近況報告でお茶を濁すことにする。要するに埋め草だ。しかも、以前に同じようなことを書いたような気がしても確かめもしない。そんなもので上手に濁るといいけど。

 

ついやってしまう、Lispマクロでマイオブジェクトシステム作成。自分の出自はC++なので、やはりC++っぽい感じになる。そして、関数オーバーロード的なことをやろうとして、「そこまでやるならCLOSでいいじゃん」てなる。最近、何につけ止め時がわからない。

とりあえず、今イジっているのは CL-CLASS という適当名称なマクロセット。Let Over Lambda の dlambda / plambda あたりをベースにしている、lambda ベースのものだ。基本的に CLOS は使用していないが、コンストラクタについては CL-OVERLOAD というこれまた自作のイビツな関数オーバーロードマクロを使っているので、その部分だけ総称関数になっている。最初に書いた通り、C++ っぽい感じの作りになっていて、最近やった修正は以下の通りだ。

まぁ、なんだ。そもそもの説明ナシに『最近やった修正』とか書かれても、ねぇ。まぁ埋め草なので大目に見て頂くとして、気が向いたらちゃんとした説明を、改めて、そして順序立ててすることにしよう。

とはいえこれで「ハイ終わり」ではあまりにもアレなので、現状でどんな感じの記述になるのか、くらいは示しておこう。

(class:define shape
  :static-members
  ((s-next-id 0 :private fixnum))
  :static-methods
  ((:private s-get-next-id ()
        (prog1 s-next-id
          (incf s-next-id))))
  :members
  ((m-id :private fixnum))
  :constructors
  ((shape () ((m-id (s-get-next-id)))))
  :methods
  ((:public get-id ()
        m-id)
   (:public get-area () = 0)))


(class:define circle :inherits shape
  :members
  ((m-radius :readonly double-float :radius))
  :constructors
  ((circle (radius) ((super)
                     (m-radius radius))))
  :methods
  ((:public get-area ()
        (* pi m-radius m-radius))
   (:public change-radius (new-radius)
        (setf m-radius new-radius))))

 

ここでは2つのクラスを定義している。shape と、そこから派生する circle だな。細かい話は改めてする(かもしれない)として、現状これらがどう展開されるかも示しておこう。それ、macroexpand-1 と。長いぜ。

(let ((s-next-id 0))
  (declare (type fixnum s-next-id))
  (labels ((s-get-next-id ()
             (prog1 s-next-id (incf s-next-id)))
           (#:shape-ctor859 (m-id)
             (declare (type fixnum m-id))
             (macrolet ((local.get-id (&rest #:args857)
                          `(__local.get-id cl-class:this ,@#:args857))
                        (this.get-id (&rest #:args857)
                          `(cl-class:invoke cl-class:this :get-id ,@#:args857))
                        (local.get-area (&rest #:args857)
                          (declare (ignore #:args857))
                          (error "pure virtual method call : ~a." 'get-area))
                        (this.get-area (&rest #:args857)
                          `(cl-class:invoke cl-class:this :get-area
                                            ,@#:args857)))
               (labels ((__local.get-id (cl-class:this)
                          (declare (ignorable cl-class:this))
                          m-id)
                        (cl-class:this (#:this855 #:optype856 &rest #:args857)
                          (declare (ignorable #:this855))
                          (ecase #:optype856
                            ((:get-id)
                             (apply #'__local.get-id #:this855 #:args857))
                            ((:get-area)
                             (error "pure virtual function call : ~a."
                                    'get-area))
                            ((:__get-method)
                             (apply
                              (lambda (#:optype856)
                                (ecase #:optype856
                                  ((:get-id)
                                   (lambda ()
                                     (apply #'__local.get-id #:this855)))))
                              #:args857)))))
                 #'cl-class:this))))
    (cl-overload:declare-constructor shape (0))
    (cl-overload:defmethod-constructor shape
        nil
      (let ((m-id (s-get-next-id)))
        (#:shape-ctor859 m-id)))))

(let ()
  (labels ((#:circle-ctor864 (cl-class:super m-radius)
             (declare (type double-float m-radius))
             (macrolet ((local.get-area (&rest #:args862)
                          `(__local.get-area cl-class:this ,@#:args862))
                        (this.get-area (&rest #:args862)
                          `(cl-class:invoke cl-class:this :get-area
                                            ,@#:args862))
                        (local.change-radius (&rest #:args862)
                          `(__local.change-radius cl-class:this ,@#:args862))
                        (this.change-radius (&rest #:args862)
                          `(cl-class:invoke cl-class:this :change-radius
                                            ,@#:args862)))
               (labels ((__local.get-area (cl-class:this)
                          (declare (ignorable cl-class:this))
                          (* pi m-radius m-radius))
                        (__local.change-radius (cl-class:this new-radius)
                          (declare (ignorable cl-class:this))
                          (setf m-radius new-radius))
                        (cl-class:this (#:this860 #:optype861 &rest #:args862)
                          (declare (ignorable #:this860))
                          (case #:optype861
                            ((:get-area)
                             (apply #'__local.get-area #:this860 #:args862))
                            ((:change-radius)
                             (apply #'__local.change-radius #:this860
                                    #:args862))
                            ((:__get-member)
                             (apply
                              (lambda (#:name865)
                                (case #:name865
                                  ((:radius) m-radius)
                                  (t
                                   (apply cl-class:super #:this860 #:optype861
                                          #:args862))))
                              #:args862))
                            ((:__set-member)
                             (apply
                              (lambda (#:name866 #:newval863)
                                (case #:name866
                                  (t
                                   (apply cl-class:super #:this860 #:optype861
                                          #:args862))))
                              #:args862))
                            ((:__get-method)
                             (apply
                              (lambda (#:optype861)
                                (case #:optype861
                                  ((:get-area)
                                   (lambda ()
                                     (apply #'__local.get-area #:this860)))
                                  ((:change-radius)
                                   (lambda (new-radius)
                                     (apply #'__local.change-radius #:this860
                                            new-radius)))
                                  (t
                                   (apply cl-class:super #:this860 #:optype861
                                          #:args862))))
                              #:args862))
                            (t
                             (apply cl-class:super #:this860 #:optype861
                                    #:args862)))))
                 #'cl-class:this))))
    (cl-overload:declare-constructor circle (1))
    (cl-overload:defmethod-constructor circle
        (radius)
      (let ((cl-class:super (cl-overload:new shape)) (m-radius radius))
        (#:circle-ctor864 cl-class:super m-radius)))))

 

‥‥‥よし、埋め草完了。

 

コメント

このページにコメントする

 

このページのタグ

Page tag : Common Lisp

 

 


Copyright(C) 2005-2017 project-enigma.
Generated by CL-PREFAB.