今回は電卓プログラムを改造して、簡単な関数型のプログラミング言語を作りましょう。具体的には、匿名関数 (クロージャ) と局所変数を定義する let 式を追加します。クロージャをサポートすると、効率を度外視すれば簡単なデータ構造、たとえば「連結リスト」を作ることもできます。
最初に、匿名関数と let 式の構文を示します。
fn(仮引数, ...) 式1, 式2, ... end let [rec] 変数1 = 初期化式1, 変数2 = 初期化式2, ... in 式1, 式2, ... end
匿名関数 (fn式) は fn で定義します。let は let ... in の間に定義された変数を局所変数として扱います。let rec は初期化式のなかで定義する変数自身の名前を使うことができます。let rec と fn式 を使って、局所関数の再帰呼び出しも行うことができます。どちらの構文も最後は end になります。また、関数の本体、if 式の then 節、else 節、while 式の本体、let 式の本体では、複数の式をカンマで区切って指定できるように拡張します。つまり、暗黙のうちに begin 式で囲まれていると考えてください。式の値は begin 式と同様に、最後に評価した式の値とします。
文法は次のようになります。
[EBNF]
文 = 関数定義 | 式.
関数定義 = "def", 関数, "(", [仮引数リスト], ")", 式, { ",", 式 }, "end".
式 = 代入式 | 式１.
代入式 = 変数, "=", 式.
式１ = 式２, { ("and" | "or"), 式２}.
式２ = 式３, ("==" | "!=" | "<" | "<=" | ">" | ">="), 式３.
式３ = 項, { ("+" | "-"), 項 }.
項 = 因子, { ("*" | "/"), 因子 }.
因子 = 数値 | ("+" | "-" | "not"), 因子 | "(", 式, ")" | 変数 | fn式 |
変数, "(", [引数リスト], ")" | fn式, "(", [引数リスト], ")" |
if式 | begin式 | while式 | let式.
if式 = "if", 式, "then", 式, { ",", 式 }, ["else", 式, { ",", 式 }], "end".
begin式 = "begin", 式, { ",", 式 }, "end".
while式 = "while", 式, "do", 式, { ",", 式 }, "end".
let式 = "let", ["rec"], 代入式, { ",", 代入式 }, "in", 式, { ",", 式 }, "end".
fn式 = "fn", "(", [仮引数リスト], ")", 式, { ",", 式 }, "end".
変数 = 識別子
仮引数リスト = 変数, { ",", 変数 }.
引数リスト = 式, { ",", 式 }.
[注意] 数値と識別子の定義は省略
関数本体は変数に格納します。今回は変数名のあとに左カッコがある場合、それを関数呼び出しと判断します。実行時に変数を評価して、その値が「関数」でなければエラーを送出します。また、匿名関数 (fn式) の場合も、end の後ろに左カッコがあると、それを関数として呼び出します。
それではプログラムを作りましょう。最初に、構文解析で構築する式の定義を修正します。次のリストを見てください。
リスト : 式の定義
datatype value = Nil (* 空を表す値 *)
| Integer of IntInf.int (* 整数 *)
| Float of real (* 実数 *)
| Func of func (* 関数 *)
and func = F1 of value -> value
| F2 of (value * value) -> value
| CLO of string list * expr * (string * value ref) list
and expr = Val of value (* 値 *)
| Var of string (* 変数 *)
| Op1 of operator * expr (* 単項演算子 *)
| Op2 of operator * expr * expr (* 二項演算子 *)
| Ops of operator * expr * expr (* 短絡演算子 *)
| Sel of expr * expr * expr (* if expr then expr else expr end *)
| Whl of expr * expr (* while expr do expr end *)
| Bgn of expr list (* begin expr, ... end *)
| Clo of string list * expr (* fn (仮引数) body end *)
| Let of string list * expr list * expr (* let *)
| Rec of string list * expr list * expr (* let rec *)
| App of expr * expr list (* 関数の適用 *)
値 value に Nil と Func of func を追加します。Nil は値がないことを表すデータです。let rec の実装とクロージャで連結リストを実装するときに使います。func は UF を削除してクロージャを表す CLO を追加します。仮引数リストは expr list から string list に変更します。
CLO の (string * value ref) list は、クロージャを生成したときの「環境」を格納するために使います。value に「関数」が加わったので、expr の定義で Num を Val に変更します。あとは、クロージャを生成する Clo と、let 式を処理する Let, Rec を追加します。string list が仮引数リストを表し、expr list が初期化式を表します。
トークンを表す token には FN (fn), LET (let), REC (rec), IN (in) を追加します。修正は簡単なので説明は割愛します。詳細はプログラムリストをお読みください。
次は構文解析の処理を修正します。
リスト : 構文解析の処理
and factor s =
case !tokenBuff of
Lpar => (
・・・ 省略 ・・・
)
| Value(n) => (get_token s; Val(n))
| Quit => raise Calc_exit
| IF => (get_token s; make_sel s)
| WHL => (get_token s; make_while s)
| BGN => (get_token s; make_begin s)
| FN => (get_token s; make_clo s)
| LET => (get_token s; make_let s)
| Oper(NOT) => (get_token s; Op1(NOT, factor s))
| Oper(Sub) => (get_token s; Op1(Sub, factor s))
| Oper(Add) => (get_token s; Op1(Add, factor s))
| Ident(name) => (
get_token s;
case !tokenBuff of
Lpar => App(Var(name), get_argument s)
| _ => Var(name)
)
| _ => raise Syntax_error("unexpected token")
トークンが Value(n) ならば Val(n) を返します。FN ならば関数 make_clo で fn 式の処理を行います。LET ならば関数 make_let で let 式と let rec 式の処理を行います。
Ident(name) の場合、name が変数名になります。そのあとに、左カッコ (Lpar) が続くのでれば、関数呼び出しなので App を生成して返します。このとき、変数の値を求めるため、App の第 1 引数には Var(name) をセットすることに注意してください。
これで局所変数にセットされた関数でも呼び出すことができます。Lpar でなければ変数の値を求める Var(name) を返します。
次は fn 式を処理する関数 make_clo を作ります。
リスト : fn 式の処理
and make_clo s =
let
val args = get_parameter s
val body = make_begin s
in
case !tokenBuff of
Lpar => App(Clo(args, body), get_argument s)
| _ => Clo(args, body)
end
最初に仮引数リストを get_parameter で求めて変数 args にセットします。次に、begin 式を生成する make_begin を呼び出し、カンマで区切られた式を取り出して、変数 body にセットします。
このあと、トークンが Lpar であれば、fn 式を実行するため App を生成して返します。このとき、第 1 引数に Clo(args, body) をセットします。これで実行時にクロージャが生成され、そのクロージャを App で実行することになります。トークンが Lpar でない場合は Clo(args, body) を返すだけです。
次は let 式を処理する関数 make_let を作ります。
リスト : let 式の処理
and make_let s =
let
fun iter(a, b) =
case !tokenBuff of
IN => (get_token s; (a, b, make_begin s))
| Comma => (get_token s; iter(a, b))
| _ => let val e1 = expression s in
case e1 of
Op2(Assign, Var(x), e2) => iter(x::a, e2::b)
| _ => raise Syntax_error("invalid let form")
end
in
case !tokenBuff of
REC => (get_token s; Rec(iter([], [])))
| _ => Let(iter([], []))
end
実際の処理は局所関数 iter で行います。累積変数 a のリストに仮引数を、b のリストに初期化式をセットします。トークンが IN の場合、本体部分を make_begin で取り出して、a, b と一緒にタプルに格納して返します。Comma の場合は iter を再帰呼び出しして次の代入式を取り出します。
それ以外の場合は代入式と考えて、expression で式を取り出します。それが変数の代入式 Op2(Assign, Var(x), e2) であれば、x を a に、 e2 を b に追加して iter を再帰呼び出しします。代入式と一致しない場合はエラーを送出します。
最初に iter を呼び出すとき、トークンをチェックします。REC の場合、get_token で次のトークンを取り出してから iter を呼び出し、その結果を Rec に格納して返します。そうでなければ、iter を呼び出して結果を Let に格納して返します。
次は式を評価する関数 eval_expr を修正します。
リスト : 式の評価
fun eval_expr(Val(n), _) = n
・・・ 省略 ・・・
| eval_expr(App(expr, args), env) = (
case eval_expr(expr, env) of
Func f =>
let
val vs = map (fn e => eval_expr(e, env)) args
in
case f of
F1 f1 => f1(hd vs)
| F2 f2 => f2(hd vs, hd (tl vs))
| CLO(parm, body, clo) =>
eval_expr(body, add_binding(parm, vs, clo))
end
| _ => raise Calc_run_error("Not function")
)
・・・ 省略 ・・・
| eval_expr(Clo(args, expr), env) = Func(CLO(args, expr, env))
| eval_expr(Let(parm, args, body), env) =
eval_expr(body,
ListPair.foldl (fn(n, e, a) => (n, ref (eval_expr(e, env)))::a)
env
(parm, args))
| eval_expr(Rec(parm, args, body), env) =
let
val new_env = foldl (fn(x, a) => (x, ref Nil)::a) env parm
in
ListPair.app (fn(p, e) =>
case get_var(p, new_env) of
NONE => raise Calc_run_error("let rec error")
| SOME (_, v) => v := eval_expr(e, new_env))
(parm, args);
eval_expr(body, new_env)
end
Val(n) はそのまま n を返します。App は最初に expr を eval_expr で評価します。これで変数に格納されている値を求めることができます。また、クロージャを生成する Clo であれば、その場でクロージャが生成されて CLO が返されます。返り値が関数でなければエラーを送出します。
組み込み関数 F1, F2 の処理は今までと同じです。CLO の場合、クロージャ内に格納された環境 clo があるので、そこに新しい変数束縛を add_binding で追加して、本体 body を eval_expr で評価します。これでクロージャ内に保存された環境にアクセスすることができます。Clo は環境 env を取り出してクロージャ CLO にセットして返すだけです。
Let の処理は簡単です。ListPair.foldl で変数を束縛して環境 env に追加し、その環境で本体 body を eval_expr で評価します。foldl に渡す匿名関数の引数 n が変数名、e が式、a が累積変数 (環境) になります。式 e は env のもとで評価することに注意してください。
Rec の処理はちょっとだけ複雑になります。最初に変数を Nil で初期化し、それを env に追加して新しい環境 new_env を作ります。そして、ListPair.app で式を評価して変数の値を書き換えます。匿名関数の引数 p が変数名、e が評価する式です。eval_expr で式 e を評価するとき、環境は new_env を渡すことに注意してください。これで式を評価するとき、定義する変数名があっても大丈夫です。最後に、本体 body を new_env のもとで評価します。
次は toplevel で関数を定義する処理を修正します。
リスト : 関数定義の修正
fun toplevel s = (
get_token s;
case !tokenBuff of
DEF => (
get_token s;
case !tokenBuff of
Ident(name) => (
get_token s;
let
val a = get_parameter s
val b = get_comma_list(s, [])
in
case !tokenBuff of
END => (update(name, Func(CLO(a, Bgn(b), [])));
print (name ^ "\n"))
| _ => raise Syntax_error("end expected")
end
)
| _ => raise Syntax_error("ivalid def form")
)
・・・ 省略 ・・・
仮引数を get_paramater で、本体を get_command_list で取得します。トークンが END であることを確認したら、クロージャ CLO を生成して、update で大域変数の環境 global_env に追加します。def で関数を定義するとき、局所変数は定義されていない、つまり大域的な環境しかないので、クロージャに格納する環境は空リスト [ ] になります。
最後にプログラムファイルをロードする処理を作ります。次のリストを見てください。
リスト : ファイルのロード
fun load_library(filename) =
let
val a = openIn(filename)
in
(while true do toplevel(a)) handle
Option => ()
| Syntax_error(mes) => print("ERROR: " ^ mes ^ "\n")
| Calc_run_error(mes) => print("ERROR: " ^ mes ^ "\n")
| Div => print("ERROR: divide by zero\n")
| err => raise err;
closeIn(a)
end
fun calc(filename) = (
if filename <> "" then load_library(filename) else ();
while true do (
print "Calc> ";
flushOut(stdOut);
toplevel(stdIn) handle
Syntax_error(mes) => print("ERROR: " ^ mes ^ "\n")
| Calc_run_error(mes) => print("ERROR: " ^ mes ^ "\n")
| Div => print("ERROR: divide by zero\n")
| err => raise err;
inputLine(stdIn)
)
)
関数 calc に引数 filename を追加します。filename が空文字列でなければ、関数 load_file を呼び出して、指定されたファイルをロードします。load_file は filename で指定されたファイルをオープンし、ファイルの終了を検出するまで toplevel を呼び出してプログラムを読み込みます。
実際は、ファイルの終了を検出すると、入力関数で NONE が返されて、関数 valOf でエラー Option が送出されます。これを handle で捕捉しています。Syntax_error, Calc_run_error, DIV 以外のエラーは raise で再送出します。最後に、closeIn で入力ファイルをクローズします。
あとの修正は簡単なので説明は割愛します。詳細はプログラムリストをお読みください。
それでは実際に試してみましょう。
Calc> a = 10; 10 Calc> b = 20; 20 Calc> a; 10 Calc> b; 20 Calc> let a = 100, b = 200 in a + b end; 300 Calc> a; 10 Calc> b; 20
let は正しく動作していますね。次は匿名関数を試してみましょう。
Calc> fn(a, b) a + b end; <Function> Calc> fn(a, b) a + b end(10, 20); 30 Calc> let add = fn(a, b) a + b end in add(100, 200) end; 300 Calc> let rec fact = fn(x) if x == 0 then 1 else x * fact(x - 1) end end in fact(10) end; 3628800
fn 式で関数 (クロージャ) が生成され、それを直接呼び出すことができます。また、let 式の局所変数に匿名関数で生成したクロージャをセットすることで、局所関数として呼び出すこともできます。局所関数で再帰呼び出ししたい場合は let rec を使います。
最後にクロージャらしい機能を使ってみましょう。
Calc> def makeAdder(x) fn(y) x + y end end makeAdder Calc> add10 = makeAdder(10); <Function> Calc> add10(20); 30 Calc> add10(200); 210 Calc> add100 = makeAdder(100); <Function> Calc> add100(200); 300 Calc> add100(1000); 1100
makeAdder は x を足し算する関数を生成して返します。makeAdder(10) の返り値を add10 にセットすると、add10 は引数に 10 を加算する関数になります。また、makeAdder(100) は引数に 100 を加算する関数を返します。どちらも正常に動作していますね。
最後に末尾再帰最適化について考えてみましょう。SML/NJ は末尾再帰最適化を行うので、ある条件で eval_expr が末尾再帰していれば、電卓プログラムも末尾再帰最適化が行われます。
実をいうと、電卓プログラムは最初から末尾再帰最適化が行われているのです。なお、ここでいう末尾再帰最適化は処理速度のことではなく、次に示すような関数呼び出しにおいて、スタックを消費せずに実行できることです。
Calc> def foo() foo() end foo Calc> foo(); => 無限ループになる
末尾再帰最適化が行われる場合、foo を評価すると無限ループになります。実際、電卓プログラムで foo を評価すると無限ループになります。
末尾再帰の末尾とは最後に行われる処理のことで、一般に末尾で関数を呼び出すことを「末尾呼び出し」といいます。関数を呼び出す場合、返ってきた後に行う処理のために、必要な情報を保存しておかなければいけません。ところが、末尾呼び出しはそのあと実行する処理がないので、情報を保存しておく必要がありません。このため、末尾再帰は繰り返しに変換することができるのです。
簡単な例として、Common Lisp で階乗を計算する関数 fact を作りましょう。
リスト : 末尾再帰を繰り返しに変換する
(defun fact (x a)
(if (= x 0)
a
(fact (- x 1) (* a x))))
(defun facti (x a)
(tagbody
loop
(if (= x 0)
(return-from facti a))
(setf a (* a x)
x (- x 1))
(go loop)))
fact は末尾再帰になっています。これを繰り返しに変換すると facti のようになります。引数 x と a の値を保存する必要が無いので、値を書き換えてから先頭の処理へジャンプします。
tagbody はジャンプ命令 go を使うための特殊形式 (シンタックス形式) です。SML/NJ に tagbody と go はありませんが、末尾再帰は最適化が行われるため効率的に処理することができます。
電卓プログラムで式を評価するとき、末尾呼び出しが行われる場所は、関数本体、if 式の then 節や else 節、let 式の本体がありますが、これらは begin 式にコンパイルされています。
関数本体の評価、if 式、let 式は最後に begin 式を eval_expr で評価しているので末尾再帰になっています。したがって、begin 式の処理が末尾再帰になっていれば、電卓プログラムも末尾再帰になります。次のリストを見てください。
リスト : 末尾呼び出しの処理
| eval_expr(Bgn(xs), env) =
let
fun iter [] = raise Calc_run_error("ivalid begin form")
| iter [x] = eval_expr(x, env)
| iter (x::xs) = (eval_expr(x, env); iter(xs))
in
iter(xs)
end
最後の式を評価するときの eval_expr は末尾呼び出しになっているので、eval_expr は末尾再帰になります。このように eval_expr を末尾再帰でプログラムすると、電卓プログラムで式を評価するときに末尾再帰最適化が行われます。
簡単な例を示しましょう。1 から x までの合計値を求めるプログラムを作ります。次のリストを見てください。
リスト : 1 から x までの合計値を求める
def sum(x)
if x == 0 then
0
else
x + sum(x - 1)
end
end
def sum1(x, a)
if x == 0 then
a
else
sum1(x - 1, a + x)
end
end
関数 sum は末尾再帰になっていないので、大きな値を計算するとメモリを大量に消費します。関数 sum1 は末尾再帰になっているので、大きな値でもメモリを消費せずに計算することができます。実行結果は次のようになります。
Calc> sum(1000000); 500000500000 Calc> sum1(1000000, 0); 500000500000
Windows 10, Intel Core i5-6200U 2.30GHz, SML/NJ ver 110.98 で実行した場合、どちらの関数でも値を求めることができました。実行時間は sum が約 8.5 秒、sum1 が約 0.42 秒になりました。SML/NJ 上で動作する簡単な電卓プログラムですが、末尾再帰最適化の効果はとても大きいようです。
相互再帰とは、関数 foo が関数 bar を呼び出し、bar でも foo を呼び出すというように、お互いに再帰呼び出しを行っていることをいいます。簡単な例を示しましょう。次のリストを見てください。
リスト : 相互再帰
def foo(n)
if n == 0 then
1
else
bar(n - 1)
end
end
def bar(n)
if n == 0 then
0
else
foo(n - 1)
end
end
このプログラムは関数 foo と bar が相互再帰しています。foo と bar が何をしているのか、実際に動かしてみましょう。
Calc> foo(10); 1 Calc> bar(10); 0 Calc> foo(15); 0 Calc> bar(15); 1
結果を見ればおわかりのように、foo は n が偶数のときに真を返し、bar は n が奇数のときに真を返します。なお、このプログラムはあくまでも相互再帰の例題であり、実用的なプログラムではありません。
電卓プログラムの末尾最適化はこのような相互再帰でも機能します。bar(1000000) を実行したところ、メモリを大量に消費することなく約 0.3 秒で実行することができます。末尾最適化の効果は十分に出ていると思います。
今回はここまでです。次回はクロージャを使って「連結リスト」を作ってみましょう。
(*
* calc.sml : 電卓プログラム
*
* Copyright (C) 2012-2021 Makoto Hiroi
*
* (1) 四則演算の実装
* (2) 変数と組み込み関数の追加
* (3) ユーザー定義関数の追加
* (4) 論理演算子, 比較演算子, if の追加
* (5) begin, while の追加
* (6) 関数を値とし、匿名関数 (クロージャ) と let を追加
*
*)
open TextIO
(* 例外 *)
exception Calc_exit
exception Syntax_error of string
exception Calc_run_error of string
(* 演算子の定義 *)
datatype operator = Add | Sub | Mul | Quo | Mod | Assign
| NOT | AND | OR
| EQ | NE | LT | GT | LE | GE
(* 式の定義 *)
datatype value = Nil (* 空を表す値 *)
| Integer of IntInf.int (* 整数 *)
| Float of real (* 実数 *)
| Func of func (* 関数 *)
and func = F1 of value -> value
| F2 of (value * value) -> value
| CLO of string list * expr * (string * value ref) list
and expr = Val of value (* 値 *)
| Var of string (* 変数 *)
| Op1 of operator * expr (* 単項演算子 *)
| Op2 of operator * expr * expr (* 二項演算子 *)
| Ops of operator * expr * expr (* 短絡演算子 *)
| Sel of expr * expr * expr (* if expr then expr else expr end *)
| Whl of expr * expr (* while expr do expr end *)
| Bgn of expr list (* begin expr, ... end *)
| Clo of string list * expr (* fn (仮引数) body end *)
| Let of string list * expr list * expr
| Rec of string list * expr list * expr
| App of expr * expr list (* 関数の適用 *)
(* トークンの定義 *)
datatype token = Value of value (* 値 *)
| Ident of string (* 識別子 *)
| Oper of operator (* 演算子 *)
| Lpar | Rpar (* (, ) *)
| Semic (* ; *)
| Comma (* , *)
| DEF (* def *)
| END (* end *)
| IF (* if *)
| THEN (* then *)
| ELSE (* else *)
| WHL (* while *)
| DO (* do *)
| BGN (* begin *)
| FN (* fn *)
| LET (* let *)
| IN (* in *)
| REC (* rec *)
| Quit (* 終了 *)
| Others (* その他 *)
(* value を real に変換 *)
fun toReal(Float(v)) = v
| toReal(Integer(v)) = Real.fromLargeInt(v)
| toReal(_) = raise Calc_run_error("Not Number")
(* 関数を呼び出す *)
fun call_real_func1 f v = Float(f(toReal v))
fun call_real_func2 f (v, w) = Float(f(toReal v, toReal w))
(* 値の表示 *)
fun print_value x =
case x of
Nil => Nil
| Integer(n) => (print(IntInf.toString(n)); Nil)
| Float(n) => (print(Real.toString(n)); Nil)
| Func(_) => (print "<Function>"; Nil)
(* 文字の表示 *)
fun print_char(n as Integer(x)) = (
output1(stdOut, chr(IntInf.toInt(x))); Nil
)
| print_char(_) = raise Calc_run_error("Not Integer")
(* 型チェック *)
val True = Integer(1)
val False = Integer(0)
fun isNil(Nil) = True
| isNil(_) = False
fun isInteger(Integer(_)) = True
| isInteger(_) = False
fun isFloat(Float(_)) = True
| isFloat(_) = False
fun isFunction(Func(_)) = True
| isFunction(_) = False
(* 大域変数 *)
val global_env = ref [("sqrt", ref (Func(F1(call_real_func1 Math.sqrt)))),
("sin", ref (Func(F1(call_real_func1 Math.sin)))),
("cos", ref (Func(F1(call_real_func1 Math.cos)))),
("tan", ref (Func(F1(call_real_func1 Math.tan)))),
("asin", ref (Func(F1(call_real_func1 Math.asin)))),
("acos", ref (Func(F1(call_real_func1 Math.acos)))),
("atan", ref (Func(F1(call_real_func1 Math.atan)))),
("atan2", ref (Func(F2(call_real_func2 Math.atan2)))),
("exp", ref (Func(F1(call_real_func1 Math.exp)))),
("pow", ref (Func(F2(call_real_func2 Math.pow)))),
("ln", ref (Func(F1(call_real_func1 Math.ln)))),
("log10", ref (Func(F1(call_real_func1 Math.log10)))),
("sinh", ref (Func(F1(call_real_func1 Math.sinh)))),
("cosh", ref (Func(F1(call_real_func1 Math.cosh)))),
("tanh", ref (Func(F1(call_real_func1 Math.tanh)))),
("print", ref (Func(F1 print_value))),
("printc", ref (Func(F1 print_char))),
("isNil", ref (Func(F1 isNil))),
("isInteger", ref (Func(F1 isInteger))),
("isFloat", ref (Func(F1 isFloat))),
("isFunction", ref (Func(F1 isFunction))),
("nil", ref Nil)]
(* 探索 *)
fun lookup name =
let
fun iter [] = NONE
| iter ((x as (n, _))::xs) =
if n = name then SOME x else iter xs
in
iter(!global_env)
end
(* 追加 *)
fun update(name, value) =
global_env := (name, ref value)::(!global_env)
(* 切り出したトークンを格納するバッファ *)
val tokenBuff = ref Others
(* 整数の切り出し *)
fun get_number s =
let
val buff = ref []
fun get_numeric() =
let val c = valOf(lookahead s) in
if Char.isDigit(c) then (
buff := valOf(input1 s) :: (!buff);
get_numeric()
) else ()
end
fun check_float(c) =
case c of
#"." => true
| #"e" => true
| #"E" => true
| _ => false
in
get_numeric(); (* 整数部の取得 *)
if check_float(valOf(lookahead s)) then (
if valOf(lookahead s) = #"." then (
(* 小数部の取得 *)
buff := valOf(input1 s) :: (!buff);
get_numeric()
) else ();
if Char.toUpper(valOf(lookahead s)) = #"E" then (
(* 指数形式 *)
buff := valOf(input1 s) :: (!buff);
let val c = valOf(lookahead s) in
if c = #"+" orelse c = #"-" then
buff := (valOf(input1 s)) :: (!buff)
else ()
end;
get_numeric()
) else ();
tokenBuff := Value(Float(valOf(Real.fromString(implode(rev (!buff))))))
) else
tokenBuff := Value(Integer(valOf(IntInf.fromString(implode(rev (!buff))))))
end
(* 識別子の切り出し *)
fun get_ident s =
let fun iter a =
if Char.isAlphaNum(valOf(lookahead s)) then
iter ((valOf(input1 s)) :: a)
else Ident(implode(rev a))
in
iter []
end
(* トークンの切り出し *)
fun get_token s =
let val c = valOf(lookahead s) in
if Char.isSpace(c) then (input1 s; get_token s)
else if Char.isDigit(c) then get_number s
else if Char.isAlpha(c) then
let val (id as Ident(name)) = get_ident s in
tokenBuff := (
case name of
"quit" => Quit
| "def" => DEF
| "end" => END
| "not" => Oper(NOT)
| "and" => Oper(AND)
| "or" => Oper(OR)
| "if" => IF
| "then" => THEN
| "else" => ELSE
| "while" => WHL
| "do" => DO
| "begin" => BGN
| "fn" => FN
| "let" => LET
| "in" => IN
| "rec" => REC
| _ => id
)
end
else (
input1 s; (* s から c を取り除く *)
tokenBuff := (case c of
#"+" => Oper(Add)
| #"-" => Oper(Sub)
| #"*" => Oper(Mul)
| #"/" => Oper(Quo)
| #"%" => Oper(Mod)
| #"=" => (case valOf(lookahead s) of
#"=" => (input1 s; Oper(EQ))
| _ => Oper(Assign))
| #"!" => (case valOf(lookahead s) of
#"=" => (input1 s; Oper(NE))
| _ => Oper(NOT))
| #"<" => (case valOf(lookahead s) of
#"=" => (input1 s; Oper(LE))
| _ => Oper(LT))
| #">" => (case valOf(lookahead s) of
#"=" => (input1 s; Oper(GE))
| _ => Oper(GT))
| #"(" => Lpar
| #")" => Rpar
| #";" => Semic
| #"," => Comma
| _ => Others
)
)
end
(* 構文木の組み立て *)
fun expression s =
let
fun iter v =
case !tokenBuff of
Oper(Assign) => (
case v of
Var(_) => (get_token s; Op2(Assign, v, expression s))
| _ => raise Syntax_error("invalid assign form")
)
| _ => v
in
iter(expr1 s)
end
(* 論理演算子 and, or の処理 *)
and expr1 s =
let
fun iter v =
case !tokenBuff of
Oper(AND) => (get_token s; iter(Ops(AND, v, expr2 s)))
| Oper(OR) => (get_token s; iter(Ops(OR, v, expr2 s)))
| _ => v
in
iter(expr2 s)
end
(* 比較演算子の処理 *)
and expr2 s =
let
fun iter v =
case !tokenBuff of
Oper(EQ) => (get_token s; iter(Op2(EQ, v, expr3 s)))
| Oper(NE) => (get_token s; iter(Op2(NE, v, expr3 s)))
| Oper(LT) => (get_token s; iter(Op2(LT, v, expr3 s)))
| Oper(GT) => (get_token s; iter(Op2(GT, v, expr3 s)))
| Oper(LE) => (get_token s; iter(Op2(LE, v, expr3 s)))
| Oper(GE) => (get_token s; iter(Op2(GE, v, expr3 s)))
| _ => v
in
iter(expr3 s)
end
and expr3 s =
let
fun iter v =
case !tokenBuff of
Oper(Add) => (get_token s; iter(Op2(Add, v, term s)))
| Oper(Sub) => (get_token s; iter(Op2(Sub, v, term s)))
| _ => v
in
iter (term s)
end
and term s =
let
fun iter v =
case !tokenBuff of
Oper(Mul) => (get_token s; iter(Op2(Mul, v, factor s)))
| Oper(Quo) => (get_token s; iter(Op2(Quo, v, factor s)))
| Oper(Mod) => (get_token s; iter(Op2(Mod, v, factor s)))
| _ => v
in
iter (factor s)
end
and factor s =
case !tokenBuff of
Lpar => (
get_token s;
let
val v = expression s
in
case !tokenBuff of
Rpar => (get_token s; v)
| _ => raise Syntax_error("')' expected")
end
)
| Value(n) => (get_token s; Val(n))
| Quit => raise Calc_exit
| IF => (get_token s; make_sel s)
| WHL => (get_token s; make_while s)
| BGN => (get_token s; make_begin s)
| FN => (get_token s; make_clo s)
| LET => (get_token s; make_let s)
| Oper(NOT) => (get_token s; Op1(NOT, factor s))
| Oper(Sub) => (get_token s; Op1(Sub, factor s))
| Oper(Add) => (get_token s; Op1(Add, factor s))
| Ident(name) => (
get_token s;
case !tokenBuff of
Lpar => App(Var(name), get_argument s)
| _ => Var(name)
)
| _ => raise Syntax_error("unexpected token")
(* カンマで区切られた式を取得 *)
and get_comma_list(s, a) =
let val v = expression s in
case !tokenBuff of
Comma => (get_token s; get_comma_list(s, v::a))
| _ => rev(v::a)
end
(* 引数の取得 *)
and get_argument s =
case !tokenBuff of
Lpar => (get_token s;
case !tokenBuff of
Rpar => (get_token s; [])
| _ => let val args = get_comma_list(s, []) in
case !tokenBuff of
Rpar => (get_token s; args)
| _ => raise Syntax_error("unexpected token")
end)
| _ => raise Syntax_error("'(' expected")
(* 仮引数の取得 *)
and get_parameter s =
let val parm = get_argument s in
map (fn x => case x of
Var(name) => name
| _ => raise Syntax_error("bad parameter"))
parm
end
(* if *)
and make_sel s =
let val test_form = expression s in
case !tokenBuff of
THEN => (
get_token s;
let val then_form = get_comma_list(s, []) in
case !tokenBuff of
ELSE => (
get_token s;
let val else_form = get_comma_list(s, []) in
case !tokenBuff of
END => (get_token s;
Sel(test_form, Bgn(then_form), Bgn(else_form)))
| _ => raise Syntax_error("end expected")
end
)
| END => (get_token s;
Sel(test_form, Bgn(then_form), Val(False)))
| _ => raise Syntax_error("else or end expected")
end
)
| _ => raise Syntax_error("then expected")
end
(* while *)
and make_while s =
let val test_form = expression s in
case !tokenBuff of
DO => (get_token s; Whl(test_form, make_begin s))
| _ => raise Syntax_error("do expected")
end
(* begin *)
and make_begin s =
let
val body = get_comma_list(s, [])
in
case !tokenBuff of
END => (get_token s; Bgn(body))
| _ => raise Syntax_error("end expected")
end
(* closure *)
and make_clo s =
let
val args = get_parameter s
val body = make_begin s
in
case !tokenBuff of
Lpar => App(Clo(args, body), get_argument s)
| _ => Clo(args, body)
end
and make_let s =
let
fun iter(a, b) =
case !tokenBuff of
IN => (get_token s; (a, b, make_begin s))
| Comma => (get_token s; iter(a, b))
| _ => let val e1 = expression s in
case e1 of
Op2(Assign, Var(x), e2) => iter(x::a, e2::b)
| _ => raise Syntax_error("invalid let form")
end
in
case !tokenBuff of
REC => (get_token s; Rec(iter([], [])))
| _ => Let(iter([], []))
end
(* 変数束縛 *)
fun add_binding([], _, a) = a
| add_binding(_, [], _) = raise Calc_run_error("not enough argument")
| add_binding(name::ps, x::xs, a) = add_binding(ps, xs, (name, ref x)::a)
(* 変数を求める *)
fun get_var(name, []) = lookup(name)
| get_var(name, (x as (n, _))::xs) =
if name = n then SOME x else get_var(name, xs)
(* 真偽のチェック *)
fun isTrue(Float(v)) = Real.!=(v, 0.0)
| isTrue(Integer(v)) = v <> 0
| isTrue(Nil) = false
| isTrue(_) = true
(* 演算子の評価 *)
fun eval_op(op1, op2, v, w) =
case (v, w) of
(Integer(n), Integer(m)) => Integer(op1(n, m))
| (Integer(n), Float(m)) => Float(op2(Real.fromLargeInt(n), m))
| (Float(n), Integer(m)) => Float(op2(n, Real.fromLargeInt(m)))
| (Float(n), Float(m)) => Float(op2(n, m))
| (_, _) => raise Calc_run_error("Not Number")
fun eval_op_int(op1, v, w) =
case (v, w) of
(Integer(n), Integer(m)) => Integer(op1(n, m))
| (_, _) => raise Calc_run_error("Not Integer")
(* 比較演算子の評価 *)
fun eval_comp(op1, op2, v, w) =
case (v, w) of
(Integer(n), Integer(m)) =>
if op1(n, m) then True else False
| (Integer(n), Float(m)) =>
if op2(Real.fromLargeInt(n), m) then True else False
| (Float(n), Integer(m)) =>
if op2(n, Real.fromLargeInt(m)) then True else False
| (Float(n), Float(m)) =>
if op2(n, m) then True else False
| (_, _) => raise Calc_run_error("Not Number")
(* 式の評価 *)
fun eval_expr(Val(n), _) = n
| eval_expr(Var(name), env) = (
case get_var(name, env) of
NONE => raise Calc_run_error("Unbound variable: " ^ name)
| SOME (_, ref v) => v
)
| eval_expr(Op2(Assign, expr1, expr2), env) =
let
val w = eval_expr(expr2, env)
in
case expr1 of
Var(name) => (case get_var(name, env) of
NONE => (update(name, w); w)
| SOME (_, v) => (v := w; w) )
| _ => raise Calc_run_error("Illegal assign form")
end
| eval_expr(Op2(op2, expr1, expr2), env) =
let
val v = eval_expr(expr1, env)
val w = eval_expr(expr2, env)
in
case op2 of
Add => eval_op(op +, op +, v, w)
| Sub => eval_op(op -, op -, v, w)
| Mul => eval_op(op *, op *, v, w)
| Quo => eval_op(op div, op /, v, w)
| Mod => eval_op_int(op mod, v, w)
| EQ => eval_comp(op =, Real.==, v, w)
| NE => eval_comp(op <>, Real.!=, v, w)
| LT => eval_comp(op <, op <, v, w)
| GT => eval_comp(op >, op >, v, w)
| LE => eval_comp(op <=, op <=, v, w)
| GE => eval_comp(op >=, op >=, v, w)
| _ => raise Calc_run_error("Illegal operator")
end
| eval_expr(Op1(op1, expr1), env) =
let
val v = eval_expr(expr1, env)
in
case (op1, v) of
(Add, _) => v
| (Sub, Integer(n)) => Integer(~n)
| (Sub, Float(n)) => Float(~n)
| (NOT, _) => if isTrue(v) then False else True
| _ => raise Calc_run_error("Illegal expression")
end
| eval_expr(Ops(ops, expr1, expr2), env) =
let val v = eval_expr(expr1, env) in
case ops of
AND => if isTrue(v) then eval_expr(expr2, env) else v
| OR => if isTrue(v) then v else eval_expr(expr2, env)
| _ => raise Calc_run_error("Illegal operator")
end
| eval_expr(Sel(expr_c, expr_t, expr_e), env) =
if isTrue(eval_expr(expr_c, env))
then eval_expr(expr_t, env) else eval_expr(expr_e, env)
| eval_expr(App(expr, args), env) = (
case eval_expr(expr, env) of
Func f =>
let
val vs = map (fn e => eval_expr(e, env)) args
in
case f of
F1 f1 => f1(hd vs)
| F2 f2 => f2(hd vs, hd (tl vs))
| CLO(parm, body, clo) =>
eval_expr(body, add_binding(parm, vs, clo))
end
| _ => raise Calc_run_error("Not function")
)
| eval_expr(Whl(expr_c, expr_b), env) = (
while isTrue(eval_expr(expr_c, env)) do eval_expr(expr_b, env);
False
)
| eval_expr(Bgn(xs), env) =
let
fun iter [] = raise Calc_run_error("ivalid begin form")
| iter [x] = eval_expr(x, env)
| iter (x::xs) = (eval_expr(x, env); iter(xs))
in
iter(xs)
end
| eval_expr(Clo(args, expr), env) = Func(CLO(args, expr, env))
| eval_expr(Let(parm, args, body), env) =
eval_expr(body,
ListPair.foldl (fn(n, e, a) => (n, ref (eval_expr(e, env)))::a)
env
(parm, args))
| eval_expr(Rec(parm, args, body), env) =
let
val new_env = foldl (fn(x, a) => (x, ref Nil)::a) env parm
in
ListPair.app (fn(p, e) =>
case get_var(p, new_env) of
NONE => raise Calc_run_error("let rec error")
| SOME (_, v) => v := eval_expr(e, new_env))
(parm, args);
eval_expr(body, new_env)
end
(* 実行 *)
fun toplevel s = (
get_token s;
case !tokenBuff of
DEF => (
get_token s;
case !tokenBuff of
Ident(name) => (
get_token s;
let
val a = get_parameter s
val b = get_comma_list(s, [])
in
case !tokenBuff of
END => (update(name, Func(CLO(a, Bgn(b), [])));
print (name ^ "\n"))
| _ => raise Syntax_error("end expected")
end
)
| _ => raise Syntax_error("ivalid def form")
)
| _ => let val result = expression s in
case !tokenBuff of
Semic => ()
| Quit => raise Calc_exit
| _ => raise Syntax_error("unexpected token");
print_value(eval_expr(result, []));
print "\n"
end
)
(* ファイルのロード *)
fun load_library(filename) =
let
val a = openIn(filename)
in
(while true do toplevel(a)) handle
Option => ()
| Syntax_error(mes) => print("ERROR: " ^ mes ^ "\n")
| Calc_run_error(mes) => print("ERROR: " ^ mes ^ "\n")
| Div => print("ERROR: divide by zero\n")
| err => raise err;
closeIn(a)
end
fun calc(filename) = (
if filename <> "" then load_library(filename) else ();
while true do (
print "Calc> ";
flushOut(stdOut);
toplevel(stdIn) handle
Syntax_error(mes) => print("ERROR: " ^ mes ^ "\n")
| Calc_run_error(mes) => print("ERROR: " ^ mes ^ "\n")
| Div => print("ERROR: divide by zero\n")
| err => raise err;
inputLine(stdIn)
)
)