OCamlで動的スコープなLispを作る

# はじめに

本記事はOCamlで遊んだ記です。

構文木を直接解釈する方式で動的スコープな変数をもつ Lisp インタプリタっぽいものを作ります。このやり方だと非常に簡単に自作言語ができるので、趣味の自作言語の第一歩としてどうでしょう、という感じの記事です。

ソースコードはこちらにあります。空白行含めて331行です。
https://github.com/usm-takl/dynamic-scoping-lisp-in-ocaml

# 動的スコープとは

動的スコープというのは、雑に言うと「関数内で定義されてない変数を参照するとき、変数の定義を関数呼び出しの深い方から浅い方に向かって探すやり方」です。関数gでローカル変数aを定義して、gの中から関数fを呼び出すと、f内ではgのローカル変数が見えます。perl 5のlocal変数や、emacs lispの変数がこういう動きをします。例を載せておきます。

```perl:perl-dynamic-scope
sub f() {
    print "$a\n";
}

sub g() {
    local $a = 10;
    f();
}

sub h() {
    local $a = 20;
    g(); # 10 が表示される
    f(); # 20 が表示される
}

h()
```

```clojure:emacs-lisp-dynamic-scope
(defun f ()
  (print a))

(defun g ()
  (let ((a 10))
    (f)))

(let ((a 20))
  (g) ; 10が表示される
  (f) ; 20が表示される
  )
```

動的スコープを使ったプログラムはバグりやすいので最近のプログラミング言語ではあまり採用されません。が、わりといい感じに動きますし、大体の用途では十分ですし、なにより

　**実装が簡単**

というとても良い性質を持っています。バグりやすいですけど、趣味のプログラミング言語作成なら今でも十分アリだと思います。では作っていきましょう。

# 動的スコープの実装方針

動的スコープですが、次のような感じで実装できます。

* ソースコード中に現れるすべての変数っぽいものを全てグローバル変数とする
* 変数はスタックを持つ
* 変数が定義されたとき、値をスタックにpushする
* 変数のスコープから抜けるとき、スタックをpopする
* 変数に値が書き込まれたとき、古い値を pop してから新しい値を push する

この変数っぽいものの役割を持つのが symbol です(Lisp方言によってsymbolの扱いは大分違うのでそこは注意してください)。symbol は以下のように定義できます。

```ocaml:sexp.ml
(* Lisp の値を表す型です。とりあえず Nil, T, Symbol だけ作ります。 *)
type t =
  | Nil
  | T
  | Symbol of symbol
and symbol = {
     symbol_name : string; (* 変数名というか、そんな感じのやつ *)
     mutable symbol_values : t list (* これをスタックとして使う *)
}

let push symbol value =
  match symbol with
  | Symbol s -> s.symbol_values <- value :: s.symbol_values
  | _ -> raise (Error "push")

let pop symbol =
  match symbol with
  | Symbol s -> s.symbol_values <- List.tl s.symbol_values
  | _ -> raise (Error "pop")

 let setq symbol value =
  match symbol with
  | Symbol s -> s.symbol_values <- value :: List.tl s.symbol_values
  | _ -> raise (Error "setq")
```

list をスタックとして使う、よくあるやつです。

ちょっと触ってみましょう。私はちょっとした動作確認に emacs から utop を使ったりします。utopは OCaml の repl の賢いやつです。設定が面倒であれば `ocaml` コマンドを使っても良いです。

```text:utop
utop[0]> #load "sexp.cmo";;
utop[1]> let s = Sexp.Symbol { symbol_name = "s"; symbol_values = [Nil] };;
val s : Sexp.t =
  Sexp.Symbol {Sexp.symbol_name = "s"; symbol_values = [Sexp.Nil]}
utop[2]> s;;
- : Sexp.t =
Sexp.Symbol {Sexp.symbol_name = "s"; symbol_values = [Sexp.Nil]}
utop[3]> Sexp.setq s T;;
- : unit = ()
utop[4]> s;;
- : Sexp.t =
Sexp.Symbol {Sexp.symbol_name = "s"; symbol_values = [Sexp.T]}
utop[5]> Sexp.push s True;;
- : unit = ()
utop[6]> s;;
- : Sexp.t =
Sexp.Symbol {Sexp.symbol_name = "s"; symbol_values = [Sexp.T; Sexp.T]}
utop[7]> Sexp.pop s;;
- : unit = ()
utop[8]> s;;
- : Sexp.t =
Sexp.Symbol {Sexp.symbol_name = "s"; symbol_values = [Sexp.T]}
```

だいたい良さそうですね。

もうひとつ、 `intern` という関数を作ります。`intern` は文字列から symbol を作る関数なのですが、同じ文字列に対しては必ず同一の symbol を返します。ソースコード中の全ての Symbol を `intern` 経由で作成することにより、同じ名前の変数(symbol)がすべて同じ記憶領域を指すようにできます。

実装的には単なる `Hashtbl.t` です。

```ocaml:sexp.ml
let obarray = Hashtbl.create 256

let intern symbol_name =
  if Hashtbl.mem obarray symbol_name then
    Hashtbl.find obarray symbol_name
  else
    let symbol = Symbol {symbol_name; symbol_values = [Nil]} in
    Hashtbl.add obarray symbol_name symbol;
    symbol
```

使用例はこんな感じです。二回目の `Sexp.intern` が返した symbol には最初から `Sexp.T` が入ってますね。

```
utop[0]> #load "sexp.cmo";;
utop[1]> let a = Sexp.intern "a";;
val a : Sexp.t =
  Sexp.Symbol {Sexp.symbol_name = "a"; symbol_values = [Sexp.Nil]}
utop[2]> Sexp.setq a T;;
- : unit = ()
utop[3]> let a = Sexp.intern "a";;
val a : Sexp.t =
  Sexp.Symbol {Sexp.symbol_name = "a"; symbol_values = [Sexp.T]}
```

# 値の定義

Symbol の説明が終わったので型を定義しなおします。

```ocaml:sexp.ml
type t =
  | Nil
  | T
  | Symbol of symbol
  | String of string
  | Number of float
  | Cons of t * t
  | Subr of (t -> t)
  | Core of (t -> t)
  | Procedure of t * t (* params, body *)
and symbol = { symbol_name : string; mutable symbol_values : t list }
```

雑な説明を表にしておきます。

| Sexp.t | 説明 |
|----|----|
| `Nil` | リストの末端を表す値かつ偽です。Schemeは`()`は真ですが、今回は偽ということにします。Common Lisp では `nil` は Symbol ですが、今回は Symbol でない値ということにします。 |
| `T` | 真を表すための値です。`Nil` 以外はすべて真なので要らないといえば要らない値です。Common Lisp では `t` は Symbol ですが、今回は Symbol でない値ということにします。定数の　Symbol を実装するのが面倒なんです。 |
| `Symbol` | 変数かつ変数名です。 |
| `String` | 文字列です。 |
| `Number` | 数です。OCaml の float を使います。手抜きのために数はこれだけにします。 |
| `Cons` | いわゆる cons cell です。 |
| `Subr` | サブルーチン。いわゆる組み込み関数です。 `+`, `-`, `=` などが `Subr` になります。 |
| `Core` | 組み込みオペレータです。`Subr`との違いは引数が評価されて渡されるか、評価されずに渡されるかです。`if` や `let` などが `Core` になります。`Core` があれば `Subr` は要らないのですが、概念的になんとなく分けておきたいです。 |
| `Procedure` | ユーザー定義の手続きです。その実態は引数リストと本体のペアです。 |

# 字句解析+構文解析

データ型を定義できましたので字句解析+構文解析をします。S式なので手書きしてもいいのですが、手抜きをして Menhir と ocamllex でさくっと作ります。

`parser.mly` には特に見どころはないと思います。

```ocaml:parser.mly
%token <Sexp.t> DATUM
%token LPAREN RPAREN DOT QUOTE EOF
%type <Sexp.t list> program
%start program

%%

program:
| sexp* EOF { $1 }

sexp:
| DATUM { $1 }
| LPAREN list_body1 { $2 }
| QUOTE sexp { Sexp.Cons(Sexp.intern "quote", Sexp.Cons($2, Sexp.Nil)) }

list_body1:
| RPAREN { Sexp.Nil }
| sexp list_body2 { Sexp.Cons($1, $2) }

list_body2:
| DOT sexp RPAREN { $2 }
| RPAREN { Sexp.Nil }
| sexp list_body2 { Sexp.Cons($1, $2) }
```

`lexer.mll` の見どころは `symbol_char+` の部分の

* データはすべて`DATUM`トークンとして lexer で処理してしまっている
* `t` を特別扱いしている
* `Sexp.intern` で同じ名前の symbol は全て同じ symbol になるようにする

あたりでしょうか。

```ocaml:lexer.mll
let space = ['\t' '\n' '\r' ' ']
let symbol_char =
  ['!' '$' '%' '&' '*' '+' '-' '.' '/' '0'-'9' '<' '=' '>' '?'
   '@' 'A'-'Z' '^' '_' 'a'-'z' '~']

rule token = parse
| space+ { token lexbuf }
| symbol_char+ as lexeme {
    match float_of_string_opt lexeme with
    | Some f ->
        Parser.DATUM(Sexp.Number(f))
    | None when lexeme = "t" ->
        Parser.DATUM(Sexp.T)
    | None when lexeme = "." ->
        Parser.DOT
    | None ->
        Parser.DATUM(Sexp.intern(lexeme))
  }
| "#|" { block_comment lexbuf; token lexbuf }
| ";" { line_comment lexbuf; token lexbuf }
| '\'' { Parser.QUOTE }
| '(' { Parser.LPAREN }
| ')' { Parser.RPAREN }
| eof { Parser.EOF }
| '"' (([^'"''\\'] | '\\'['\x00'-'\xff'])+ as lexeme) '"' {
    Parser.DATUM(Sexp.String(Scanf.unescaped lexeme))
  }

and line_comment = parse
| ('\n' | eof) { () }
| _ { line_comment lexbuf }

and block_comment = parse
| "|#" { () }
| "#|" { block_comment lexbuf; block_comment lexbuf }
| eof { () }
| _ { block_comment lexbuf }
```

ちなみに Common Lisp や emacs lisp とは異なり `nil` は特別扱いしていません。この辺はお好みでどうぞ。

# pretty printer を作る

動作確認用に pritty printer を作りましょう。

```ocaml
let rec display = function
  | Nil ->
     print_string "()"
  | T ->
     print_string "t"
  | Symbol { symbol_name } ->
     print_string symbol_name
  | String s ->
     print_string s
  | Number f ->
     print_float f
  | Cons(car, cdr) ->
     print_string "(";
     display car;
     print_list cdr
  | Subr _ ->
     print_string "#<subr>"
  | Core _ ->
     print_string "#<core>"
  | Procedure _ ->
     print_string "#<procedure>"
and print_list = function
  | Nil ->
     print_char ')'
  | Cons(car, cdr) ->
     print_char ' ';
     display car;
     print_list cdr
  | cdr ->
     print_string " . ";
     display cdr;
     print_char ')'
```

print_list が少しトリッキーかもしれませんが、ほぼ素直な printer になっているかと思います。

次のような main.ml を用意して、 reader と printer をテストしてみると良いと思います。

```ocaml:main.ml
let () =
  let sexps = Parser.program Lexer.token (Lexing.from_channel stdin) in
  List.iter Sexp.display sexps
```

だいたい次のような感じになるかと思います。

```text:shell
$ echo '(hello (world) !)' | ./a.out
(hello (world) !)
```

# 便利関数

構文解析ができるようになったので便利関数を定義しましょう。とりあえず `car`, `cdr`, `cadr`, `cddr`, `caddr`, `map`, `iter`, `iter2` あたりをつくります。

```ocaml:sexp.ml
let car = function
  | Nil -> Nil
  | Cons(car, cdr) -> car
  | _ -> raise (Error "car")

let cdr = function
  | Nil -> Nil
  | Cons(car, cdr) -> cdr
  | _ -> raise (Error "cdr")

let cadr list = car (cdr list)

let cddr list = cdr (cdr list)

let caddr list = car (cddr list)

let rec map fn = function
  | Nil -> Nil
  | Cons(car, cdr) -> Cons(fn car, map fn cdr)
  | _ -> raise (Error "map")

let rec iter fn = function
  | Nil -> ()
  | Cons(car, cdr) -> fn car; iter fn cdr
  | _ -> raise (Error "iter")

let rec iter2 fn l1 l2 =
  match l1, l2 with
  | Nil, Nil -> ()
  | Cons(car1, cdr1), Cons(car2, cdr2) -> fn car1 car2; iter2 fn cdr1 cdr2
  | _ -> raise (Error "iter2")
```

関数型言語の練習レベルかと思います。

# eval

みんな大好き `eval` です。若干ネストが深くてアレですがまぁいいや。ほとんどは見ればわかるかと思います。

少し複雑なのはのは `Procedure` の呼び出しでしょうか。それでも大したことはしていません。次のような感じです。

1. `args`(実引数)を評価して `Procedure` の仮引数リスト(`params`)に含まれるシンボルに `push`
2. `body` を評価
3. `Procedure` の仮引数リスト(`params`)に含まれるシンボルを `pop`

これで手続きに引数を渡すことができてしまいます。動的スコープな変数と構文木を直接解釈する方式のインタプリタなら、スタックフレームがどうとか考える必要がないんです。

```ocaml:sexp.ml
let rec eval expr =
  match expr with
  | Nil -> expr
  | T -> expr
  | Symbol {symbol_values} -> List.hd symbol_values
  | String _ -> expr
  | Number _ -> expr
  | Procedure _ -> expr
  | Subr _ -> expr
  | Core _ -> expr
  | Cons(op, args) ->
     match eval op with
     | Procedure(params, body) ->
        iter2 (fun p a -> push p (eval a)) params args;
        let ret = progn body in
        iter pop params;
        ret
     | Subr fn -> fn (map eval args)
     | Core fn -> fn args
     | _ -> raise (Error "not an operator")
and progn = function
  | Nil -> Nil
  | Cons(car, Nil) -> eval car
  | Cons(car, cdr) -> ignore @@ eval car; progn cdr
  | _ -> raise (Error "progn")
```

読み込んだコードを `eval` に流し込むような `main.ml` を作りましょう。

```ocaml:main.ml
let () =
  let sexps = Parser.program Lexer.token (Lexing.from_channel stdin) in
  List.iter (fun sexp -> ignore @@ Sexp.eval sexp) sexps
```

あとは `Core`, `Subr` を充実させていけば Lisp インタプリタができます。

# `Subr` を作る

組み込み手続き `Subr` を作っていきます。

動作確認に使いたい `display` から作りましょう。
`eval` を読んで頂くとわかると思いますが「先頭要素を評価すると `Subr fn` になるリスト」を評価すると「引数を全部評価したリストを作って `fn` に適用」します。ということは OCaml の関数を `Subr` でくるんでやれば組み込み手続きが作れますね。ついでに適当に `intern` した symbol に `setq` しておきましょう。

```OCaml:sexp.ml
let subr_display =
  Subr (function
      | Cons(arg, Nil) -> display arg; Nil
      | _ -> raise (Error "subr_display: wrong number of arguments"))
;;
setq (intern "display") subr_display
```

試してみましょう。

```shell-session:sh
$ echo "(display 10)" | ./a.out
10.
```

いい感じですね。

残りの組み込み手続きを紹介していくのは長くなるだけですので、ふたつだけ紹介します。

```ocaml:sexp.ml
let subr_add =
  Subr(function
      | Cons(Number a, Cons(Number b, Nil)) -> Number(a +. b)
      | _ -> raise (Error "add: invalid arguments"))
let subr_equal =
  Subr(function
      | Cons(car, Cons(cadr, Nil)) -> if car = cadr then T else Nil
      | _ -> raise (Error "subr_equal: wrong number of arguments"))
;;
setq (intern "+") subr_add;
setq (intern "=") subr_equal
```

`+` は多くの lisp と異なり、引数は厳密に2個でなければなりません。これはもちろん手抜きのためです。

`=` も多くの lisp と異なりどんな型の値でも比較できます。
これも手抜きなのですが、「OCaml の `=` が大体何でも比較できるからこうしちゃえ」という動機もあります。

こんなノリで `-`, `*`, `/`, `car`, `cdr`, `cons`, `not` も作りましょう。

ちょっとした電卓ぐらいならもうできますね。

```shell-session:sh
$ echo "(display (+ 10 (* 2 3)))" | ./a.out
16.
```

# `Core` を作る

ここから組み込みオペレータの `Core` を作っていきます。

## `assert`

まずは動作確認用に便利な `assert` を作りましょう。
こんな感じです。

```ocaml:sexp.ml
let core_assert =
  Core(function
      | Cons(expr, Nil) ->
         if eval expr = T then
           Nil
         else (
           display expr;
           raise (Error "assertion failed")
         )
      | _ ->
         raise (Error "malformed assert expression"))
;;
setq (intern "assert") core_assert
```

`Core` は `Subr` とは異なり、引数を評価せずに OCaml の関数に渡します。
`assert` は引数を評価し、その値が `T` であったら何もせず、それ以外なら引数を `display` してから例外を投げます。

こんなスクリプトを作って実行してみましょう。

```scheme:test.l
(assert t)
(assert (= 0 0))
(assert (= () (not t)))
(assert (not (not t)))
(assert (= (+ 1 2) 3))
(display "OK")
```

```shell-session:sh
$ ./a.out < test.l
OK
```

テストに使えて便利な気がします。

## `quote`

次は `quote` です。「引数を評価せずに返す」やつです。

```ocaml
let core_quote =
  Core(function
      | Cons(car, Nil) -> car
      | _ -> raise (Error "malformed quote expression"))
;;
setq (intern "quote") core_quote
```

ほぼ自明な実装かと思います。

そしてこんなテストを追加して実行すると。

```scheme:test.l
(assert (= 'a (car '(a b))))
(assert (= '(b) (cdr '(a b))))
(assert (= '(a b c) '(a b c)))
(assert (= (cons 'a 'b) '(a . b)))
```

"OK"が出たらOKです。

## `if`

次、条件分岐の`if`です。

`if` は次のように動きます。

* 第一引数を評価して結果が nil 以外第二引数を `eval` して返します。
* 第一引数を評価した結果が nil 以外で第三引数があれば、第三引数を `eval` して返します。
* 第一引数を評価した結果が nil 以外で第三引数がなければ、`Nil` を返します。

コードそのまんまで実装できますね。

```ocaml:sexp.ml
let core_if =
  Core(fun args ->
      if eval (car args) <> Nil then
        eval (cadr args)
      else if cddr args <> Nil then
        eval (caddr args)
      else
        Nil)
;;
setq (intern "if") core_if
```

テストも書いておきましょう。

```lisp:test.l
(assert (= 'a (if t 'a 'b)))
(assert (= 'b (if () 'a 'b)))
(assert (= 'a (if t 'a)))
(assert (= () (if () 'a)))
```

## `setq`

`setq` です。シンボルに値をセットします。自明ですね。

```ocaml:sexp.ml
let core_setq =
  Core(function
      | Cons(symbol, Cons (value, Nil)) ->
         setq symbol (eval value); Nil
      | _ ->raise (Error "malformed setq expression"))
;;
setq (intern "setq") core_if
```

```lisp:test.l
(setq a 10)
(assert (= a 10))
```

## `defun`

いよいよ関数定義の `defun` です。
関数定義は難しそうですが、 symbol に `Procedure(params, body)` を `setq` するだけです。

```ocaml:sexp.ml
let core_defun =
  Core(function
      | Cons(symbol, Cons (params, body)) ->
         setq symbol @@ Procedure(params, body); Nil
      | _ -> raise (Error "malformed defun expression"))
```

早速`succ`関数とか作ってみましょう。

```lisp:test.l
(defun succ (n) (+ n 1))
(assert (= (succ 1) 2))
```

もちろん再帰だってできます。おなじみの階乗関数です。

```lisp:test.l
(defun fact (n)
  (if (= n 1)
      1
      (* n (fact (- n 1)))))
(assert (= (fact 5) 120))
```

定義した関数を値として使うこともできます(Common Lisp と異なり`#'`は不要)。
`map`なんかも実装できてます。

```scheme:test.l
(defun map (proc lst)
  (if lst
      (cons (proc (car lst))
            (map proc (cdr lst)))))
(assert (= '(2 3 4) (map succ '(1 2 3))))
```

なんかもう、ひととおりできそうな気分ですね。

## `lambda`

Lisp といえば `lambda` です。
`defun` が理解できればもう何の問題もなく実装できると思いますがこんなんです。
単に `Procedure(params, body)` を返してるだけです。

```ocaml:sexp.ml
let core_lambda =
  Core(function
      | Cons(params, body) -> Procedure(params, body)
      | _ -> raise (Error "malformed lambda expression"))
;;
setq (intern "lambda") core_lambda;
```

さっきの `map` で使ってみましょう。

```lisp:test.l
(assert (= '(3 4 5)
           (map (lambda (n) (+ n 2))
                '(1 2 3))))
```

## `let`

ローカル変数定義の `let` です。

Lisp の `let` がいやらしい形をしているので少しプログラムが長くなっていますが、やっているのは関数呼び出しと同じく、「スコープに入るときにシンボルに新しい値を `push`」「スコープから出るときにシンボルの値を `pop`」だけです。ちなみに実装の手抜きのために `let` というよりは `let*` 相当になっています。

```OCaml:sexp.ml
let core_let =
  let init1 = function
    | Cons(car, Cons(cadr, Nil)) ->
       push car (eval cadr)
    | Cons(car, Nil) ->
       ()
    | _ -> raise (Error "malformed let expression")
  in
  let rec init = function
    | Nil -> ()
    | Cons(car, cdr) -> init1 car; init cdr
    | _ -> raise (Error "malformed let expression")
  in
  let rec fini = function
    | Nil -> ()
    | Cons(Cons(var, _), cdr) -> pop var; fini cdr
    | _ -> raise (Error "malformed let expression")
  in
  Core(function
      | Cons(car, cdr) ->
         init car;
         let tmp = progn cdr in
         fini car;
         tmp
      | _ -> raise (Error "malformed quote expression"))
```

```lisp:test.l
(setq a 10)
(let ((a 20))
  (assert (= a 20)))
(assert (= a 10))
```

ここまで実装できていると自由変数の扱いもわりと上手く行ってしまいます。

```lisp:test.l
(assert (= '(4 5 6)
           (let ((k 3))
             (map (lambda (n) (+ n k))
                  '(1 2 3)))))
```

`lambda` の内側で `lambda` の外側のローカル変数を参照できています。今回の実装では全ての変数は実質グローバル変数なので当然ですね。

# まとめ

この辺でプログラミング言語の実装を名乗っていいぐらいの機能はできてるんじゃないでしょうか？`progn`と`while`ぐらいは欲しいかもしれませんが、すぐ作れそうな感じではあります。趣味なのでこれでいいことにしましょう。

というわけで、動的スコープ+構文木を直接するインタプリタを作りました。非常に簡単に実装できます。趣味の自作言語の第一歩としてどうでしょう？

# ところで

ところで動的スコープの残念な点ですが、次のコードの実行は失敗します。

```lisp
; This will fail.
(setq f (let ((k 3)) (lambda (n) (+ n k))))
(map f '(1 2 3))
```

`let` を抜けた時点でローカル変数 `k` の値が消えてしまうので、`lambda` の中で `k` を参照したときに例外が raise されてしまいます。不便ですね。Scheme や Common Lisp などのレキシカルスコープを採用した言語では `f` は 3 を足す関数として動いてくれます。

ついでに、次のコードも興味深いと思います。

```lisp
; success
(assert (= '(4 5 6)
           (let ((k 3))
             (map (lambda (n) (+ n k))
                  '(1 2 3)))))
; fail
(assert (= '(4 5 6)
           (let ((lst 3))
             (map (lambda (n) (+ n lst))
                  '(1 2 3)))))
```

一個目の `assert` は成功しますが、二個目の `assert` では `+` の実行時に例外が raise されます。一個目と二個目の違いは `let` で作成するローカル変数の名前だけです。

何故こんなことが起こるかというと、`map` が内部で `lst` という名前の変数を使っているからです。動的スコープの言語で自由変数を使おうとすると、見えないところで使われている変数名が何かまで把握しておかなければなりません。恐ろしいですね。

この辺が動的スコープが廃れてしまった理由です。