SSブログ

オブジェクト指向言語の実装 (EOPL の 5.4.1) [Lisp]

EOPL の続き。また進路を変更して今度は第5章のオブジェクト指向言語の実装をやることにした。ここでは4通りの実装を紹介しているのだけどまずは 5.4.1 A Simple Implementation から。

この実装ではオブジェクトを part というデータ型のリストとして表現する。

(define-datatype part part?
  (a-part
    (class-name symbol?)
    (fields vector?)))

一つの part はクラス名とフィールドの配列を持っている。継承されたクラスをインスタンス化した場合、例えば c1 を継承した c2 をインスタンス化した場合は part のリストの car が c2 の part で、c2 に固有ないしはオーバーライドしたフィールドが入り、リストの cadr には c1 のフィールドが入る。

メソッドを呼び出す場合はこの part のリストを元に環境を作ってやり、その環境の下でメソッドの式を評価する。この環境にはさらにメソッドの引数と self と super が見えるようにしてやる。

ただ本の通りに実装するのも単調なのでちょっと自分好みの改変を加えた。EOPL の元の言語ではオブジェクトの初期化を世の多くのオブジェクト指向言語と同様にコンストラクタメソッドの呼び出しで行っている。たとえばこんな風だ。

class c1 extends object
  field i
  field j
  method initialize (x)
    set i = x
    set j = -(0,x)
  end
  method ...(以下略)

この仕様の悪いところは、まずコンストラクタメソッドを書くというのがめんどくさい。次にコンストラクタメソッドの中で初期化を忘れるということを誘発しやすい。これは C++ だと未初期化な値を生む。Java やその他の言語では型ごとの初期値が存在するので問題は小さくなっているけど初期値のままであるのが意図したことなのかどうかは不明だ。

というわけでこういう風に書くようにした。

class c1(x) extends object()
  field i = x
  field j = -(0,x)
  method ...(以下略)

こうすると field の右辺を書くことが強制される。これは OCaml 風で Scala 風でもある(もっとも、どちらの言語もこの形のコンストラクタしかサポートしないということではない)。コンストラクタのオーバーロードをサポートする場合は結構面倒なことになるけど今回の言語では元々オーバーロードは存在しない。

継承するときにはクラス定義のところでスーパークラスの実引数を与えてやる。

class c1(x,y) extends object()
  field i = x
  field j = y
class c2(z) extends c1(+(z,1),777)
  field k = z
new c2(12)

これは ((a-part c2 #(12)) (a-part c1 #(13 777))) という構造になる。

こういう仕様にしたことで、新たな決め事が発生する。スーパークラスに対する引数の式を評価するときと field の右辺の式を評価するときにそれぞれの環境をどうするか。

スーパークラスに対する引数の式を評価するときはサブクラスのコンストラクタの引数(上で言う c2(z) の z)だけを環境として持つ。これはこれで問題ないだろう。

field の右辺の式を評価するときにはそれに加えて self や他のフィールドや super を見えるようにすべきかどうか。スーパークラスは先に初期化されているので super は問題ないように思われる。self や他のフィールドはどうか。先に初期化されたフィールドを使って別のフィールドを初期化するのは計算の節約に便利なときもあるかも知れないが、未初期化なフィールドを使用してしまう恐れもある。元々未初期化問題を改善したかったのでこれはやや片手落ちだ。

OCaml と Scala を参考にしてみよう。OCaml では self や同じクラスの別のフィールドの参照は禁止されているようだ。

# class c1 x = object(self)
    val i = x
    val j = self#get_i()
    method get_i() = i
  end;;
The instance variable self
cannot be accessed from the definition of another instance variable
# class c1 x = object
    val i = x
    val j = i
  end;;
The instance variable i
cannot be accessed from the definition of another instance variable

Scala ではあるフィールドを別のフィールドを使って初期化できる。

scala> class C1(x: Int) {
     |   val i = x
     |   val j = i
     | }
defined class C1

scala> val c1 = new C1(123)
c1: C1 = C1@18a2977

scala> (c1.i, c1.j)
res3: (Int, Int) = (123,123)

順序が逆転すると初期値を使うことになる。

scala> class C2(x: Int) {
     |   val i = j
     |   val j = x
     | }
defined class C2

scala> val c2 = new C2(456)
c2: C2 = C2@6d0085

scala> (c2.i, c2.j)
res4: (Int, Int) = (0,456)

循環が起きた場合はどちらも初期値になる。

scala> class C3(x: Int) {
     |   val i: Int = j
     |   val j: Int = i
     | }
defined class C3

scala> val c3 = new C3(789)
c3: C3 = C3@197f158

scala> (c3.i, c3.j)
res5: (Int, Int) = (0,0)

メソッドを介して循環させた場合も同様。

scala> class C4(x: Int) {
     |   def m(): Int = i
     |   val i: Int = m()
     | }
defined class C4

scala> (new C4(135)).m()
res7: Int = 0

というわけで OCaml に近い仕様にしました。それにしても C++ とか Java でも初期化/コンストラクタ周りの仕様ってややこしい問題の温床な気がする。

完成した言語での REPL 例は以下のような感じ。ソースは後掲。

class oddeven() extends object()
  method even(n) if n then send self odd(sub1(n)) else 1
  method odd(n) if n then send self even(sub1(n)) else 0
let o1 = new oddeven()
in send o1 odd(13)
-->1

class interior(l,r) extends object()
  field left = l
  field right = r
  method sum() +(send left sum(), send right sum())
class leaf(v) extends object()
  field value = v
  method sum() value
let o1 = new interior(
           new interior(
             new leaf(3),
             new leaf(4)),
           new leaf(5))
in send o1 sum()
-->12

class point(initx,inity) extends object()
  field x = initx
  field y = inity
  method move(dx,dy)
    let d = set x = +(x,dx) in
    let d = set y = +(y,dy) in 0
  method getx() x
  method gety() y
class colorpoint(initx,inity,initcolor) extends point(initx,inity)
  field color = initcolor
  method setcolor(c) set color = c
  method getcolor() color
let o1 = new colorpoint(3,4,172) in
send o1 getcolor()
-->172

class c1() extends object()
  method m1() send self m2()
  method m2() 13
class c2() extends c1()
  method m1() 22
  method m2() 23
  method m3() super m1()
class c3() extends c2()
  method m1() 32
  method m2() 33
let o3 = new c3() in
send o3 m3()
-->33

ソース。EOPL ではクロージャとかリスト処理プリミティブとか begin 式がある前提なんだけどブログに載せるために削った。あと構造体のアクセサ的な関数をいっぱい定義しなければならなかったので初めてマクロを書いた。これにより Gauche 依存になってしまっている。

(load "r5rs.scm")
(load "define-datatype.scm")
(load "sllgen.scm")
(use srfi-1)

; reference

(define-datatype reference reference?
  (a-ref
    (position integer?)
    (vec vector?)))

(define primitive-deref
  (lambda (ref)
    (cases reference ref
      (a-ref (pos vec) (vector-ref vec pos)))))

(define primitive-setref!
  (lambda (ref val)
    (cases reference ref
      (a-ref (pos vec) (vector-set! vec pos val)))))

(define deref
  (lambda (ref)
    (primitive-deref ref)))

(define setref!
  (lambda (ref val)
    (primitive-setref! ref val)))

; boolean

(define true-value (lambda () 1))
(define false-value (lambda () 0))
(define true-value?
  (lambda (x)
    (not (= 0 x))))

; environment

(define-datatype environment environment?
  (empty-env-record)
  (extended-env-record
    (syms (list-of symbol?))
    (vals vector?)
    (env environment?))
  )

(define empty-env
  (lambda ()
    (empty-env-record)))

(define extend-env
  (lambda (syms vals env)
    (extended-env-record syms (list->vector vals) env)))

(define extend-env-refs
  (lambda (syms vec env)
    (extended-env-record syms vec env)))

(define apply-env
  (lambda (env sym)
    (deref (apply-env-ref env sym))))

(define apply-env-ref
  (lambda (env sym)
    (cases environment env
      (empty-env-record ()
        (eopl:error 'apply-env "No binding for ~s" sym))
      (extended-env-record (syms vals env)
        (let ((pos (list-find-position sym syms)))
          (if (number? pos)
            (a-ref pos vals)
            (apply-env-ref env sym)))))))

(define list-find-position
  (lambda (sym los)
    (list-index (lambda (sym1) (eqv? sym1 sym)) los)))

(define list-index
  (lambda (pred ls)
    (cond
      ((null? ls) #f)
      ((pred (car ls)) 0)
      (else (let ((list-index-r (list-index pred (cdr ls))))
              (if (number? list-index-r)
                (+ list-index-r 1)
                #f))))))

; interpreter

(define eval-program
  (lambda (pgm)
    (cases program pgm
      (a-program (c-decls exp)
        (elaborate-class-decls! c-decls)
        (eval-expression exp (init-env))))))

(define eval-expression
  (lambda (exp env)
    (cases expression exp
      (lit-exp (datum) datum)
      (var-exp (id) (apply-env env id))
      (primapp-exp (prim rands)
        (let ((args (eval-rands rands env)))
          (apply-primitive prim args)))
      (if-exp (test-exp true-exp false-exp)
        (if (true-value? (eval-expression test-exp env))
          (eval-expression true-exp env)
          (eval-expression false-exp env)))
      (let-exp (ids rands body)
        (let ((args (eval-rands rands env)))
          (eval-expression body (extend-env ids args env))))
      (varassign-exp (id rhs-exp)
        (begin
          (setref!
            (apply-env-ref env id)
            (eval-expression rhs-exp env))
          1))
      (method-app-exp (obj-exp method-name rands)
        (let ((args (eval-rands rands env))
              (obj (eval-expression obj-exp env)))
          (find-method-and-apply
            method-name (object->class-name obj) obj args)))
      (super-call-exp (method-name rands)
        (let ((args (eval-rands rands env))
              (obj (apply-env env 'self)))
          (find-method-and-apply
            method-name (apply-env env '%super) obj args)))
      (new-object-exp (class-name rands)
        (let ((args (eval-rands rands env)))
          (new-object class-name args)))
      )))

(define eval-rands
  (lambda (rands env)
    (map (lambda (x) (eval-rand x env)) rands)))

(define eval-rand
  (lambda (rand env)
    (eval-expression rand env)))

(define apply-primitive
  (lambda (prim args)
    (cases primitive prim
      (add-prim () (+ (car args) (cadr args)))
      (subtract-prim () (- (car args) (cadr args)))
      (mult-prim () (* (car args) (cadr args)))
      (incr-prim () (+ (car args) 1))
      (decr-prim () (- (car args) 1))
      (eq?-prim () (if (eq? (car args) (cadr args)) (true-value) (false-value)))
      )))

; OO-part, a simple implementation

(define the-class-env '())

(define-datatype part part?
  (a-part
    (class-name symbol?)
    (fields vector?)))

(define elaborate-class-decls!
  (lambda (c-decls)
    (set! the-class-env c-decls)))

(define new-object
  (lambda (class-name args)
    (if (eqv? class-name 'object)
      '()
      (let*
        ((c-decl (lookup-class class-name))
         (super-name (class-decl->super-name c-decl))
         (obj (cons (make-first-part c-decl)
                    (new-object
                      super-name
                      (eval-rands
                        (class-decl->real-params c-decl)
                        (extend-env
                          (class-decl->formal-params c-decl)
                          args
                          (empty-env))))))
         (env
           (extend-env
             (cons '%super    (class-decl->formal-params c-decl))
             (cons super-name args)
             (build-field-env
               (view-object-as obj class-name)))))
        (for-each
          (lambda (id rhs-exp)
            (setref!
              (apply-env-ref env id)
              (eval-expression rhs-exp env)))
          (class-decl->field-ids  c-decl)
          (class-decl->field-vals c-decl))
        obj))))

(define make-first-part
  (lambda (c-decl)
    (a-part
      (class-decl->class-name c-decl)
      (make-vector (length (class-decl->field-ids c-decl))))))

(define find-method-and-apply
  (lambda (m-name host-name self args)
    (if (eqv? host-name 'object)
      (eopl:error 'find-method-and-apply
        "No method for ~s" m-name)
      (let ((m-decl (lookup-method-decl m-name
                      (class-name->method-decls host-name))))
        (if (method-decl? m-decl)
          (apply-method m-decl host-name self args)
          (find-method-and-apply
            m-name
            (class-name->super-name host-name)
            self
            args))))))

(define apply-method
  (lambda (m-decl host-name self args)
    (let ((ids (method-decl->ids m-decl))
          (body (method-decl->body m-decl))
          (super-name (class-name->super-name host-name)))
      (eval-expression body
        (extend-env
          (cons '%super    (cons 'self ids))
          (cons super-name (cons self  args))
          (build-field-env
            (view-object-as self host-name)))))))

(define view-object-as
  (lambda (parts class-name)
    (if (eqv? (part->class-name (car parts)) class-name)
      parts
      (view-object-as (cdr parts) class-name))))

(define build-field-env
  (lambda (parts)
    (if (null? parts)
      (empty-env)
      (extend-env-refs
        (part->field-ids (car parts))
        (part->fields    (car parts))
        (build-field-env (cdr parts))))))

(define object->class-name
  (lambda (obj)
    (part->class-name (car obj))))

(define-macro (define-accessor type fields)
  (let ((record (string->symbol (string-append "a-" (symbol->string type)))))
    `(begin
       ,@(map
           (lambda (field)
             (let ((proc-name
                     (string->symbol
                       (string-append
                         (symbol->string type)
                         "->"
                         (symbol->string field)))))
               `(define ,proc-name
                  (lambda (x)
                    (cases ,type x
                      (,record ,fields
                        ,field))))))
           fields))))

; the macro define-accessor defines procedures part->fields ... etc.
(define-accessor part (class-name fields))
(define-accessor class-decl (class-name formal-params super-name real-params
                            field-ids field-vals method-decls))
(define-accessor method-decl (method-name ids body))

(define class-name->super-name
  (lambda (class-name)
    (class-decl->super-name (lookup-class class-name))))

(define class-name->method-decls
  (lambda (class-name)
    (class-decl->method-decls (lookup-class class-name))))

; Exercise 5.1 part->field-ids
(define part->field-ids
  (lambda (p)
    (cases part p
      (a-part (class-name fields)
        (class-decl->field-ids (lookup-class class-name))))))

(define lookup-class
  (lambda (class-name)
    (find
      (lambda (c-decl)
        (eqv? (class-decl->class-name c-decl) class-name))
      the-class-env)))

(define lookup-method-decl
  (lambda (m-name m-decls)
    (find
      (lambda (m-decl)
        (eqv? (method-decl->method-name m-decl) m-name))
      m-decls)))

; etc

(define init-env (lambda () (empty-env)))

(define scanner-spec
  '((white-sp
      (whitespace) skip)
    (comment
      ("%" (arbno (not #\newline))) skip)
    (identifier
      (letter (arbno (or letter digit "?"))) symbol)
    (number
      (digit (arbno digit)) number)))

(define grammar
  '((program
      ((arbno class-decl) expression)
      a-program)
    (class-decl
      ("class" identifier "(" (separated-list identifier ",") ")"
       "extends" identifier "(" (separated-list expression ",") ")"
       (arbno "field" identifier "=" expression)
       (arbno method-decl))
      a-class-decl)
    (method-decl
      ("method" identifier "(" (separated-list identifier ",") ")" expression)
      a-method-decl)
    (expression
      (number)
      lit-exp)
    (expression
      (identifier)
      var-exp)
    (expression
      (primitive "(" (separated-list expression ",") ")" )
      primapp-exp)
    (expression
      ("if" expression "then" expression "else" expression)
      if-exp)
    (expression
      ("let" (arbno identifier "=" expression) "in" expression)
      let-exp)
    (expression
      ("set" identifier "=" expression)
      varassign-exp)
    (expression
      ("new" identifier "(" (separated-list expression ",") ")")
      new-object-exp)
    (expression
      ("send" expression identifier "(" (separated-list expression ",") ")")
      method-app-exp)
    (expression
      ("super" identifier "(" (separated-list expression ",") ")")
      super-call-exp)
    (primitive ("+") add-prim)
    (primitive ("-") subtract-prim)
    (primitive ("*") mult-prim)
    (primitive ("add1") incr-prim)
    (primitive ("sub1") decr-prim)
    (primitive ("eq?") eq?-prim)
    ))

(define scan&parse
  (sllgen:make-string-parser
    scanner-spec
    grammar))

(sllgen:make-define-datatypes scanner-spec grammar)

(define run
  (lambda (string)
    (eval-program
      (scan&parse string))))

(define read-eval-print
  (sllgen:make-rep-loop "-->" eval-program
    (sllgen:make-stream-parser
      scanner-spec
      grammar)))

タグ:EOPL
nice!(0)  コメント(0)  トラックバック(0) 
共通テーマ:パソコン・インターネット

nice! 0

コメント 0

コメントを書く

お名前:
URL:
コメント:
画像認証:
下の画像に表示されている文字を入力してください。

トラックバック 0

この広告は前回の更新から一定期間経過したブログに表示されています。更新すると自動で解除されます。