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

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 依存になってしまっている。

続きを読む

タグ：EOPL

Common Lisp からブログに投稿するまで

So-net blog が XML-RPC からの投稿に対応したということで Common Lisp から投稿してみることにしました。

* S-XML-RPC の導入

Common Lisp から XML-RPC を使うためのパッケージとしては S-XML-RPC [1] というのがあるようです。これは S-XML [2] に依存するそうなのでこれも必要です。

Common Lisp で外部ライブラリを使うにはどうするかということがそもそも分からなかったのですが Common Lisp には ASDF という Debian の apt-get みたいな機構があってそれを使えばいいようです。

もともと Windows マシンに入っていた GCL で ASDF を使う方法が分からなかったのでまずは SBCL [3] の Windows 版を入れることにしました。

asdf-install というのを使うと本当に apt-get みたいにネットワークからのダウンロードからやってくれるらしいのですが、これは Windows 上だと tar を使えないといけなかったり、とにかく何かと面倒そうなので単純に S-XML と S-XML-RPC の tar ball を C:\Program Files\Steel Bank Common Lisp\1.0.13 の下に展開して、

(require :asdf)
(require :s-xml)
(require :s-xml-rpc)

としました。これでインストールは完了。

* S-XML-RPC を使う

So-net blog の XML-RPC のエントリポイントは http://blog.so-net.ne.jp/_rpc なので、とりえあず、

(in-package :s-xml-rpc)
(setf *xml-rpc-host* "blog.so-net.ne.jp")
(setf *xml-rpc-url* "/_rpc")

とします。

XML-RPC のリクエストの XML を作るには encode-xml-rpc-call を使います。

* (encode-xml-rpc-call "mt.supportedMethods")

"<methodCall><methodName>mt.supportedMethods</methodName></methodCall>"

これを使ってリモート呼び出しをするには xml-rpc-call を使います。

* (xml-rpc-call (encode-xml-rpc-call "mt.supportedMethods"))

("blogger.newPost" "blogger.editPost" "blogger.getRecentPosts"
 "blogger.getUsersBlogs" "blogger.getUserInfo" "blogger.deletePost"
 "metaWeblog.getPost" "metaWeblog.newPost" "metaWeblog.editPost"
 "metaWeblog.getRecentPosts" "metaWeblog.newMediaObject" "mt.getCategoryList"
 "mt.setPostCategories" "mt.getPostCategories" "mt.supportedTextFilters"
 "mt.getRecentPostTitles" "mt.publishPost")

ところで encode-xml-rpc-call にバグを見つけました（2004-06-17版）。

* (encode-xml-rpc-call "blogger.newPost" "" "rainyday" "rainyday" "password" "test" nil)

"<methodCall><methodName>blogger.newPost</methodName><params><param><value><stri
ng></string></value></param><param><value><string>rainyday</string></value></par
am><param><value><string>rainyday</string></value></param><param><value><string>
password</string></value></param><param><value><string>test</string></value></pa
ram><param><value><string>NIL</string></value></param></params></methodCall>"

nil は <string>NIL</string> ではなくて <boolean>0</boolean> に変換されて欲しいんですが、文字列になってしまっています。

原因究明のためにソースを見ると

(defun encode-xml-rpc-value (arg stream)
  (princ "<value>" stream)
  (cond ((or (stringp arg) (symbolp arg))
	 (princ "<string>" stream)
	 (print-string-xml (string arg) stream)
	 (princ "</string>" stream))
	((integerp arg) (format stream "<int>~d</int>" arg))
	((floatp arg) (format stream "<double>~f</double>" arg))
	((or (null arg) (eq arg t))
	 (princ "<boolean>" stream)
	 (princ (if arg 1 0) stream)
	 (princ "</boolean>" stream))

nil も t も symbolp に対して真なので boolean の条件節まで辿り着かないみたいですね。というわけで修正して順序を変えました。

(defun encode-xml-rpc-value (arg stream)
  (princ "<value>" stream)
  (cond
	((or (null arg) (eq arg t))
	 (princ "<boolean>" stream)
	 (princ (if arg 1 0) stream)
	 (princ "</boolean>" stream))
	((or (stringp arg) (symbolp arg))
	 (princ "<string>" stream)
	 (print-string-xml (string arg) stream)
	 (princ "</string>" stream))

さて、ブログへの投稿には blogger.newPost ではなくて metaWeblog.newPost を使うことにしました。

(xml-rpc-call
  (encode-xml-rpc-call "metaWeblog.newPost"
    "rainyday" "rainyday" "password" 
    (xml-rpc-struct
      "title" "テスト"
      "description" "<p>本文1</p><p>本文2</p>"
      "convert_breaks" nil)
    nil))

投稿内容の構造体を xml-rpc-struct で作っています。これは (xml-rpc-struct :title "テスト" ... のような感じでいいかと思っていたのですが、そうすると XML 上では小文字の title ではなくて大文字の TITLE になってしまうのでアウトでした。

これで投稿に成功すると記事のIDが帰ってきます。

本文は S-XML で書くことにするというのも手かと思ったのですが、それだと日本語が Unicode の実体参照になってしまって不便でした。

他にも XML-RPC のリプライに日本語が含まれると SBCL が「This is probably a bug in SBCL itself.」とかいってエラーになるなどなかなか日本語の扱いは深追いしたくない感があるようです。

* 未整理の事柄

metaWeblog.newPost の最後の nil は記事を公開するかしないかのフラグのはずなのですが、So-net blog はこれを見ていない（？）みたいで関係なく公開になってしまうようです。あと第1引数の blogid と第2引数の username の使い分けもいまいち不明です。カテゴリを指定する方法も良く分からない。

[1] http://common-lisp.net/project/s-xml-rpc/

[2] http://common-lisp.net/project/s-xml/

[3] http://www.sbcl.org/

静的に型チェックするインタプリタ (EOPL の 4.1 と 4.2)

久しぶりに EOPL の練習問題に手をつけた。前回 3.7 節まで終わってたけど 3.8 と 3.9 はいったん飛ばして 4.1 と 4.2 の静的型チェックの導入をやることにした。

ここでは明示的に型を書かせて実行前に型チェックを行うのだけど let の左辺の変数の型なんかは推論する。明示的に書かないといけないのは関数の仮引数と再帰関数の戻り値の型のみ。そういえば Scala もそんな感じだ。

型チェックは「どの変数がどの型か」という情報を環境として持ちながら構文木をトラバースしていく。

型の記述の文法は EOPL だと proc (int x) のような C 風だったのだが、個人的な好みにより proc (x: int) のように変えた。

練習問題は代入式を追加したりタプルとリストのための構文を追加したりして、全部やった結果657行とずいぶんブログに貼るには長くなってしまった。テストケースを書けというのも練習問題にあって、書いたんだけどさすがにそれは貼らない。

タプルとリストの構文は新たな文法として追加する。プリミティブ関数として追加してはいけないのかなと最初思ったんだけど、この言語にはまだ総称性の概念が無いのでそうしてしまうとプリミティブ関数の型を表現する方法が無いことになる。

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

; representation of types
(define-datatype type type?
  (atomic-type
    (name symbol?))
  (proc-type
    (arg-types (list-of type?))
    (result-type type?))
  (pair-type
    (type1 type?)
    (type2 type?))
  (list-type
    (content-type type?))
  )

(define int-type (atomic-type 'int))
(define bool-type (atomic-type 'bool))

(define expand-type-expression
  (lambda (texp)
    (cases type-exp texp
      (int-type-exp () int-type)
      (bool-type-exp () bool-type)
      (proc-type-exp (arg-texps result-texp)
        (proc-type
          (expand-type-expressions arg-texps)
          (expand-type-expression result-texp)))
      (pair-type-exp (texp1 texp2)
        (pair-type
          (expand-type-expression texp1)
          (expand-type-expression texp2)))
      (list-type-exp (texp)
        (list-type
          (expand-type-expression texp)))
      )))

(define expand-type-expressions
  (lambda (texps)
    (map expand-type-expression texps)))

; checking for equal types
; Exercise 4.2 explicit recursive checking (instead of using equal?)
(define check-equal-type!
  (lambda (t1 t2 exp) ; exp is used only in the error message
    (let ((type-error
            (lambda ()
              (eopl:error 'check-equal-type!
                "Types didn't match: ~s != ~s in ~%~s"
                (type-to-external-form t1)
                (type-to-external-form t2)
                exp))))
      (letrec ((C-E-T!
              (lambda (t1 t2)
                (cases type t1
                  (atomic-type (name1)
                    (cases type t2
                      (atomic-type (name2)
                        (or (eqv? name1 name2) (type-error)))
                      (else (type-error))))
                  (proc-type (arg-types1 result-type1)
                    (cases type t2
                      (proc-type (arg-types2 result-type2)
                        (for-each
                          C-E-T!
                          (cons result-type1 arg-types1)
                          (cons result-type2 arg-types2)))
                      (else (type-error))))
                  (pair-type (t1-1 t1-2)
                    (cases type t2
                      (pair-type (t2-1 t2-2)
                        (begin
                          (C-E-T! t1-1 t2-1)
                          (C-E-T! t1-2 t2-2)))
                      (else (type-error))))
                  (list-type (content-type1)
                    (cases type t2
                      (list-type (content-type2)
                        (C-E-T! content-type1 content-type2))
                      (else (type-error))))
                  ))))
        (C-E-T! t1 t2)))))

(define type-to-external-form
  (lambda (ty)
    (cases type ty
      (atomic-type (name) name)
      (proc-type (arg-types result-type)
        (append
          (arg-types-to-external-form arg-types)
          '(->)
          (list (type-to-external-form result-type))))
      (pair-type (type1 type2)
        (list 'pairof
              (type-to-external-form type1)
              (type-to-external-form type2)))
      (list-type (content-type)
        (list 'list-of
              (type-to-external-form content-type)))
      )))

(define arg-types-to-external-form
  (lambda (arg-types)
    (cond
      ((null? arg-types) '())
      ((null? (cdr arg-types)) (list (type-to-external-form (car arg-types))))
      (else (cons (type-to-external-form (car arg-types))
                  (cons '* (arg-types-to-external-form (cdr arg-types))))))))

(define type-of-program
  (lambda (pgm)
    (cases program pgm
      (a-program (exp)
        (type-of-expression exp (empty-tenv))))))

(define type-of-expression
  (lambda (exp tenv)
    (cases expression exp
      (lit-exp (number) int-type)
      (true-exp () bool-type)
      (false-exp () bool-type)
      (var-exp (id) (apply-tenv tenv id))
      (if-exp (test-exp true-exp false-exp)
        (let ((test-type (type-of-expression test-exp tenv))
              (false-type (type-of-expression false-exp tenv))
              (true-type (type-of-expression true-exp tenv)))
          (check-equal-type! test-type bool-type test-exp)
          (check-equal-type! true-type false-type exp)
          true-type))
      (proc-exp (ids texps body)
        (type-of-proc-exp texps ids body tenv))
      (primapp-exp (prim rands)
        (type-of-application
          (type-of-primitive prim)
          (types-of-expressions rands tenv)
          prim rands exp))
      (app-exp (rator rands)
        (type-of-application
          (type-of-expression rator tenv)
          (types-of-expressions rands tenv)
          rator rands exp))
      (let-exp (ids rands body)
        (type-of-let-exp ids rands body tenv))
      (letrec-exp (proc-names idss texpss result-texps bodies letrec-body)
        (type-of-letrec-exp
          result-texps proc-names texpss idss bodies letrec-body tenv))
      (varassign-exp (id rhs-exp)
        (let ((var-type (apply-tenv tenv id))
              (exp-type (type-of-expression rhs-exp tenv)))
          (check-equal-type! var-type exp-type exp)
          int-type))
      (pair-exp (exp1 exp2)
        (pair-type
          (type-of-expression exp1 tenv)
          (type-of-expression exp2 tenv)))
      (unpack-exp (id1 id2 exp body)
        (let ((exp-type (type-of-expression exp tenv)))
          (cases type exp-type
            (pair-type (type1 type2)
              (let ((tenv-for-body
                      (extend-tenv
                        (list id1 id2)
                        (list type1 type2)
                        tenv)))
                (type-of-expression body tenv-for-body)))
            (else
              (eopl:error
                'type-of-expression
                "pair expected but got ~s"
                (type-to-external-form exp-type)
                )))))
      (list-exp (exps)
        (if (= 0 (length exps))
          (eopl:error
            'type-of-expression
            "At least 1 argument required in expression ~s"
            exp)
          (let ((t (type-of-expression (car exps) tenv)))
            (begin
              (for-each
                (lambda (x) (check-equal-type!
                              (type-of-expression x tenv)
                              t
                              exp))
                (cdr exps))
              (list-type t)))))
      (cons-exp (exp1 exp2)
        (let ((type2 (type-of-expression exp2 tenv)))
          (cases type type2
            (list-type (content-type)
              (begin
                (check-equal-type!
                  (type-of-expression exp1 tenv)
                  content-type
                  exp)
                type2))
            (else
              (eopl:error
                'type-of-expression
                "~s cannnot be cons'ed onto ~s"
                exp1 exp2)))))
      (null-exp (exp)
        (cases type (type-of-expression exp tenv)
          (list-type (content-type) bool-type)
          (else
            (eopl:error
              'type-of-expression
              "~s must be list type"
              exp))))
      (emptylist-exp (texp)
        (list-type (expand-type-expression texp)))
      (car-exp (exp)
        (let ((ty (type-of-expression exp tenv)))
          (cases type ty
            (list-type (content-type) content-type)
            (else
              (eopl:error
                'type-of-expression
                "~s must be list type" exp)))))
      (cdr-exp (exp)
        (let ((ty (type-of-expression exp tenv)))
          (cases type ty
            (list-type (content-type) ty)
            (else
              (eopl:error
                'type-of-expression
                "~s must be list type" exp)))))
      )))

(define types-of-expressions
  (lambda (rands tenv)
    (map (lambda (exp) (type-of-expression exp tenv)) rands)))

(define type-of-proc-exp
  (lambda (texps ids body tenv)
    (let ((arg-types (expand-type-expressions texps)))
      (let ((result-type
              (type-of-expression body
                (extend-tenv ids arg-types tenv))))
        (proc-type arg-types result-type)))))

(define type-of-application
  (lambda (rator-type rand-types rator rands exp)
    (cases type rator-type
      (proc-type (arg-types result-type)
        (if (= (length arg-types) (length rand-types))
          (begin
            (for-each
              check-equal-type!
              rand-types arg-types rands)
            result-type)
          (eopl:error 'type-of-expression
            (string-append
              "Wrong number of arguments in expression ~s:"
              "~%expected ~s~%got ~s")
            exp
            (map type-to-external-form arg-types)
            (map type-to-external-form rand-types))))
      (else
        (eopl:error 'type-of-expression
          "Rator not a proc type:~%~s~%had rator type ~s"
          rator (type-to-external-form rator-type))))))

; Exercise 4.3 list-structure parser for types
(define list-to-type
 (lambda (l)
    (cond
      ((symbol? l) (atomic-type l))
      ((list? l)
       (let ((len (length l)))
         (and (eqv? (list-ref l (- len 2)) '->)
              (proc-type
                (args-to-type (take l (- len 2)))
                (list-to-type (last l))))))
      (else eopl:error 'list-to-type ""))))
(define args-to-type
  (lambda (l)
    (cond
      ((null? l) '())
      ((null? (cdr l))
       (list (list-to-type (car l))))
      ((eqv? '* (cadr l))
       (cons (list-to-type (car l))
             (args-to-type (cddr l))))
      (else eopl:error 'list-to-type ""))))

(define type-of-primitive
  (lambda (prim)
    (cases primitive prim
      (add-prim ()
        (list-to-type '(int * int -> int)))
      (subtract-prim ()
        (list-to-type '(int * int -> int)))
      (mult-prim ()
        (list-to-type '(int * int -> int)))
      (incr-prim ()
        (list-to-type '(int -> int)))
      (decr-prim ()
        (list-to-type '(int -> int)))
      (zero?-prim ()
        (list-to-type '(int -> bool)))
      )))

(define type-of-let-exp
  (lambda (ids rands body tenv)
    (let ((tenv-for-body
            (extend-tenv
              ids
              (types-of-expressions rands tenv)
              tenv)))
      (type-of-expression body tenv-for-body))))

(define type-of-letrec-exp
  (lambda (result-texps proc-names texpss idss bodies letrec-body tenv)
    (let ((arg-typess
            (map
              (lambda (texps)
                (expand-type-expressions texps))
              texpss))
          (result-types
            (expand-type-expressions result-texps)))
      (let ((the-proc-types
              (map proc-type arg-typess result-types)))
        (let ((tenv-for-body
                (extend-tenv proc-names the-proc-types tenv)))
          (for-each
            (lambda (ids arg-types body result-type)
              (check-equal-type!
                (type-of-expression
                  body
                  (extend-tenv ids arg-types tenv-for-body))
                result-type
                body))
            idss arg-typess bodies result-types)
          (type-of-expression letrec-body tenv-for-body))))))

; boolean
(define true-value (lambda () #t))
(define false-value (lambda () #f))
(define true-value?
  (lambda (x)
    (not (eq? #f x))))

; 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)))

; 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-recursively
  (lambda (proc-names idss bodies old-env)
    (extended-env-record
      proc-names
      (list->vector
        (map
          (lambda (x) (closure x proc-names idss bodies old-env))
          (iota (length proc-names))))
      old-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))))))

; type environment
(define empty-tenv empty-env)
(define extend-tenv extend-env)
(define apply-tenv apply-env)

; procedure
(define-datatype procval procval?
  (closure
    (pos number?)
    (proc-names (list-of symbol?))
    (idss (list-of (list-of symbol?)))
    (bodies (list-of expression?))
    (env environment?)))

(define apply-procval
  (lambda (proc args)
    (cases procval proc
      (closure (pos proc-names idss bodies env)
        (eval-expression
          (list-ref bodies pos)
          (extend-env
            (list-ref idss pos)
            args
            (extend-env-recursively
              proc-names idss bodies env)))))))

; interpreter
(define eval-program
  (lambda (pgm)
    (cases program pgm
      (a-program (body)
        (eval-expression body (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))))
      (proc-exp (ids types body)
        (closure 0 (list '_) (list ids) (list body) env))
      (app-exp (rator rands)
        (let ((proc (eval-expression rator env))
              (args (eval-rands rands env)))
          (if (procval? proc)
            (apply-procval proc args)
            (eopl:error 'eval-expression
              "Attempt to apply non-procedure ~s" proc))))
      (letrec-exp (proc-names idss typess types bodies letrec-body)
        (eval-expression
          letrec-body
          (extend-env-recursively proc-names idss bodies env)))
      (varassign-exp (id rhs-exp)
        (begin
          (setref!
            (apply-env-ref env id)
            (eval-expression rhs-exp env))
          1))
      (pair-exp (exp1 exp2)
        (cons (eval-expression exp1 env)
              (eval-expression exp2 env)))
      (unpack-exp (id1 id2 exp body)
        (let ((pair (eval-expression exp env)))
          (eval-expression
            body
            (extend-env
              (list id1 id2)
              (list (car pair) (cdr pair))
              env))))
      (list-exp (exps)
        (eval-rands exps env))
      (cons-exp (exp1 exp2)
        (cons (eval-expression exp1 env)
              (eval-expression exp2 env)))
      (null-exp (exp)
        (null? (eval-expression exp env)))
      (emptylist-exp (texp)
        '())
      (car-exp (exp)
        (car (eval-expression exp env)))
      (cdr-exp (exp)
        (cdr (eval-expression exp env)))
      (true-exp  () #t)
      (false-exp () #f)
      )))

(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)))
      (zero?-prim () (if (= (car args) 0) (true-value) (false-value)))
      )))

(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
      (expression)
      a-program)
    (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
      ("proc" "(" (separated-list identifier ":" type-exp ",") ")" expression)
      proc-exp)
    (expression
      ("(" expression (arbno expression) ")")
      app-exp)
    (expression
      ("letrec"
       (arbno
         identifier
         "(" (separated-list identifier ":" type-exp  ",") ")"
         ":" type-exp
         "=" expression)
       "in" expression)
      letrec-exp)
    (expression
      ("set" identifier "=" expression)
      varassign-exp)
    (expression
      ("pair" "(" expression "," expression ")")
      pair-exp)
    (expression
      ("unpack" identifier identifier "=" expression "in" expression)
      unpack-exp)
    (expression
      ("list" "(" (separated-list expression ",") ")")
      list-exp)
    (expression
      ("cons" "(" expression "," expression ")")
       cons-exp)
    (expression
      ("null?" "(" expression ")")
      null-exp)
    (expression
      ("emptylist" "[" type-exp "]")
      emptylist-exp)
    (expression ("car" "(" expression ")") car-exp)
    (expression ("cdr" "(" expression ")") cdr-exp)
    (expression ("true") true-exp)
    (expression ("false") false-exp)
    (primitive ("+") add-prim)
    (primitive ("-") subtract-prim)
    (primitive ("*") mult-prim)
    (primitive ("add1") incr-prim)
    (primitive ("sub1") decr-prim)
   ;(primitive ("eq?") eq?-prim)
    (primitive ("zero?") zero?-prim)
    (type-exp ("int") int-type-exp)
    (type-exp ("bool") bool-type-exp)
    (type-exp
      ("(" (separated-list type-exp "*") "->" type-exp ")")
      proc-type-exp)
    (type-exp ("(pairof" type-exp type-exp ")") pair-type-exp)
    (type-exp ("(listof" type-exp ")") list-type-exp)
    ))

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

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

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

(define type-of
  (lambda (string)
    (type-of-program (scan&parse string))))

(define type-check
  (lambda (string)
    (type-to-external-form
      (type-of-program
        (scan&parse string)))))

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

タグ：EOPL

EOPL 第3章の Exercise 3.48

"3.7 Variable Assignment" もようやく最後。

ここまでのインタプリタでは代入を Scheme のベクタの破壊的書き換えを使って実現してきました。これを Scheme の副作用に依存しない形に書き換えるのが練習問題 3.48 です。

このために store という「位置→値」の関数的なものを用意し、環境は「変数名→位置」に取って代わらせます。store は環境と同じでそのまま関数で実装しても良いでしょうが、ここでは define-datatype を使ってリスト状の構造を作りました。変数の書き換えは store を拡張することに相当し、eval 系の処理は store を追加引数にとって、戻り値として値のほかに新しい store を返すようにします。この戻り値のために answer というデータ型を定義します。

今日の解答はいつもより特に出来が悪い感じがするので公開するのがあまり気が進みません。リファクタリングできていない感が随所に漂うコードです。とりあえずやりましたということで。

続きを読む

EOPL 第3章の Exercise 3.47

練習問題 3.47 は setdynamic という式を追加して一時的な代入ができるようにする。
Perl の local とか Scala の DynamicVariable に近いかな。

続きを読む

EOPL 第3章の Exercise 3.46

練習問題 3.46 は代入が可能な処理系でフラットな環境のクロージャ実装を行う。代入無しだとただ環境を作り直すだけでよかったんだけど代入を許す言語だと代入する先が変わってしまうわけで、そこをどうにかしないといけないというところがポイント。

練習問題 3.27 でやったような実装だと、例えば、

let x = 0 in
let f = proc () set x = add1(x) in
let d = (f) in x

というコードが 1 でなく 0 になってしまう。

これを解決するために rib に入る値を最初からリファレンスにした。結構な手術になった。

続きを読む

EOPL 第3章の Exercise 3.45

練習問題 3.45 は let で導入した変数は代入不可にして letmutable　で導入した変数のみ set による代入を可能とする。Scala でいうと val と var の違いみたいな感じ。

とりあえず今のところは実行時エラーでよいと思われるので環境のレコードに extended-mutable-env-record を追加して、このレコードの場合は apply-env-ref を禁止するようなやり方で書いてみた。

gosh> (read-eval-print)
letmutable x = 1 in let d = set x = +(x,1) in x
-->2
let x = 1 in let d = set x = +(x,1) in x
-->Error reported by apply-env-ref:
x is immutable

ところでいろんな LL での定数の扱いが気になったので調べると

- Ruby: 定数に代入すると実行時に警告が出るけど代入はできてる
- PHP: 定数を2度 define しても何も言わないけど値は変わらない
- Perl (use constant): コンパイル時に警告が出るけど実行はできてる
- Perl (Readonly): 実行時にエラーになる

という感じで実にさまざま。文法もスコープもさまざま。今回の処理系の動作は Perl の Readonly が一番近いと思われる。ちなみにPython に定数はないようだ（LL 的にはこれが一番自然なような）。

続きを読む

EOPL 第3章の Exercise 3.42 と 3.43

いったん参照の扱いを練習問題 3.41 より前に戻して、データ型に配列を追加したり参照型をファーストクラスにしたり（swap 関数が書ける）した。ref 式が C でいう & にあたる。結果的には以下のような仕様になったのかな。

Arr = (Ref(Expressed Value))*
Expressed Value = Number + ProcVal + Arr + Ref(Expressed Value)
Denoted Value = Ref(Expressed Value)

続きを読む

EOPL 第3章の Exercise 3.41

前回の処理系では変数はすべて set 式によって代入が可能という作りだった。Scheme を初め多くの言語がこういう風に代入を扱っていると思う。

一方練習問題 3.41 では cell というプリミティブ式を使って生成した参照を通じてのみ代入ができるという仕組みを考える。デリファレンスと代入にはそれぞれ contents, setcell というプリミティブも用意する。要するに ML 系言語でいう ref と ! と := だ。

EOPL でつかっている説明のための等式（私はこの等式についていまだにもやもや感が消せない）だと前者が、

Expressed Value = Number + Procval
Denoted Value = Ref(Expressed Value)

で、後者が、

Expressed Value = Number + ProcVal + Ref(Expressed Value)
Denoted Value = Expressed Value

となる。

続きを読む

EOPL 第3章の Exercise 3.37 から 3.40

前回から1ヶ月も間があいてしまった。3.7節では変数への破壊的代入を取り扱えるようにする。

以前 OCaml で書いた Scheme もどき [1] でも代入をサポートしていたのだけど、それとはアプローチが違う。
[1] では環境のインターフェイスに直接代入のための操作を追加していたのに対して、ここでは環境から返ってくる値が参照になるようにして、その参照に対して deref や setref! を行う。
回りくどいようだけどインターフェイスにむやみに操作を追加するのはよくないということなんだろう。

練習問題 ～3.40 では begin を追加したり define を追加したりする。

define を追加する問題では「もし初期環境にすでに同名変数があった場合は代入、そうでなければ環境の拡張」という要件なので、これまでの環境のように見つからなかったらエラーで終了というわけにはいかなくなる。ここでは define-datatype で OCaml 風の option 型を定義してラップすることにした。

続きを読む