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-dynamic-scope

sub f() {
    print "$a\n";
}

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

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

h()

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 は以下のように定義できます。

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 コマンドを使っても良いです。

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 です。

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 の説明が終わったので型を定義しなおします。

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 には特に見どころはないと思います。

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 になるようにする

あたりでしょうか。

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 を作りましょう。

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 をテストしてみると良いと思います。

main.ml

let () =
  let sexps = Parser.program Lexer.token (Lexing.from_channel stdin) in
  List.iter Sexp.display sexps

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

shell

$ echo '(hello (world) !)' | ./a.out
(hello (world) !)

便利関数

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

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

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

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 を作りましょう。

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 しておきましょう。

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

試してみましょう。

sh

$ echo "(display 10)" | ./a.out
10.

いい感じですね。

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

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 も作りましょう。

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

sh

$ echo "(display (+ 10 (* 2 3)))" | ./a.out
16.

Core を作る

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

assert

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

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 してから例外を投げます。

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

test.l

(assert t)
(assert (= 0 0))
(assert (= () (not t)))
(assert (not (not t)))
(assert (= (+ 1 2) 3))
(display "OK")

sh

$ ./a.out < test.l
OK

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

quote

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

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

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

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

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 を返します。

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

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

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

test.l

(assert (= 'a (if t 'a 'b)))
(assert (= 'b (if () 'a 'b)))
(assert (= 'a (if t 'a)))
(assert (= () (if () 'a)))

setq

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

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

test.l

(setq a 10)
(assert (= a 10))

defun

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

sexp.ml

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

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

test.l

(defun succ (n) (+ n 1))
(assert (= (succ 1) 2))

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

test.l

(defun fact (n)
  (if (= n 1)
      1
      (* n (fact (- n 1)))))
(assert (= (fact 5) 120))

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

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) を返してるだけです。

sexp.ml

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

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

test.l

(assert (= '(3 4 5)
           (map (lambda (n) (+ n 2))
                '(1 2 3))))

let

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

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

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

test.l

(setq a 10)
(let ((a 20))
  (assert (= a 20)))
(assert (= a 10))

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

test.l

(assert (= '(4 5 6)
           (let ((k 3))
             (map (lambda (n) (+ n k))
                  '(1 2 3)))))

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

まとめ

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

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

ところで

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

; 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 を足す関数として動いてくれます。

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

; 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 という名前の変数を使っているからです。動的スコープの言語で自由変数を使おうとすると、見えないところで使われている変数名が何かまで把握しておかなければなりません。恐ろしいですね。

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