今まで作成した関数型電卓プログラムは、変数にアクセスするとき局所的な環境 env と大域的な環境 global_env を線形探索していました。プログラムの実行時に探索を行うと、実行時間はどうしても遅くなってしまいます。コンパイル時に局所変数と大域変数を区別してアクセス方法を工夫すると、実行時間はもう少し速くなると思われます。
そこで今回は変数のアクセス方法を改良して、電卓プログラムの高速化に挑戦してみましょう。そのほかに、文字列型データや新しい関数を追加します。
大域変数と局所変数を区別する場合、コンパイル時にも局所変数の環境を生成する必要があります。局所変数の環境に同じ名前があれば、それは局所変数であることがわかります。なければ大域変数と判断することができます。そして、局所変数は名前ではなく環境の位置で表し、大域変数は global_env に格納されているタプルで表すことにします。変数名で探索する必要がなくなるので、変数のアクセスは確実に速くなると思われます。
局所変数の環境は次のように二重のリストを使って表します。
コンパイル時 : [[name, ...], [name, ...], ..., [name, ,,,]] 実行時 : [[var, ... ], [var, ... ], ..., [var, ... ]]
中のリストを「フレーム」と呼ぶことにします。フレームは関数呼び出しの引数や let 式など、局所変数を定義するときに生成され、局所変数の環境に追加されます。コンパイル時には変数名を格納し、実行時には変数の値 (value ref) を格納します。コンパイルする時は環境から変数名を検索し、フレーム番号とフレーム内の位置を求めます。実行時はこの 2 つの整数値を使って環境に格納されている値にアクセスすればいいわけです。
大域変数の場合、コンパイル時に変数名 name を環境 global_env から探索し、見つけた場合はタプル (name, ref value) を渡すようにコンパイルするだけです。そうすると、値を求める命令はタプルの値 value を取り出すだけ、値の更新は value を書き換えるだけで実現できます。
変数 name が見つからない場合、タプル (name, ref Undef) を生成して環境に追加することにします。Undef は未束縛の変数であることを表す値として使います。Undef のチェックは大域変数の値を求める処理で行えばいいでしょう。もちろん、コンパイル時にエラーチェックしてもかまいませんが、今回は簡単な方法を選びました。
次は文法を修正します。実は、変数のアクセス方法を修正すると、「再帰降下法」のままでは let rec の文法を修正しないと実装が困難になるのです。今までは実行時に変数を探索していたので、let rec は let と同じ文法でも動作していました。ところが、今回はコンパイル時に局所変数を環境の位置に変換するため、初期化式をコンパイルする前に、let rec で定義されているすべての局所変数をフレームに格納して環境に追加しておかないと、局所関数で再帰呼び出しや相互再帰ができなくなるのです。
たとえば、let rec var1 = expr1, var2 = expr2 in ... end をコンパイルする場合、expr1 をコンパイルする前に、var2 を求めるためトークンの先読みが必要になります。再帰降下法でこの処理を実現するのは難しいので、let rec の文法を次のように修正します。
let rec 変数1, 変数2, ... = 初期化式1, 初期化式2, ... in 式, ... end
定義する局所変数をカンマで区切って定義し、= のあとに初期化式をカンマで区切って定義します。これで、初期化式をコンパイルする前に定義する局所変数をすべて求めることができるので、再帰降下法のままで let rec を簡単に実装することができます。
それから、次の式を関数呼び出しとして扱うように文法を修正します。
(式)(引数, ...)
カッコの後ろにカッコが続く場合、前のカッコ内の式の評価結果が「関数」であれば、その関数に引数を渡して呼び出します。リストや配列に格納されている関数を呼び出すときに便利です。
それではプログラムを作りましょう。最初にデータ型を定義します。
リスト : データ型の定義
datatype value = Nil (* 空を表す値 *)
| Undef (* 未束縛 *)
| Integer of IntInf.int (* 整数 *)
| Float of real (* 実数 *)
| Func of func (* 関数 *)
| Pair of value ref * value ref (* 連結リスト *)
| Vec of value array (* ベクタ *)
| Str of string (* 文字列 *)
and func = F1 of value -> value
| F2 of (value * value) -> value
| CLO of int * expr * value ref list list
| CT of value -> value
and expr = Val of value (* 値 *)
| Gvar of string * value ref (* 大域変数 *)
| Lvar of int * int (* 局所変数 *)
| 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 int * expr (* closure の生成 *)
| Let of expr list * expr (* let *)
| Rec of expr list * expr (* let rec *)
| Lst of expr list (* リストの生成 *)
| Crv of expr list (* ベクタの生成 *)
| Ref of expr * expr list (* ベクタのアクセス *)
| App of expr * expr list (* 関数の適用 *)
| Cct of expr (* 継続 *)
値を表す value に Undef と Str of string を追加します。Undef は変数が未束縛であることを表すために使います。Str of string は文字列を表すデータ型です。func の CLO は int * expr * value ref list list に変更します。最初の int は引数の個数を表します。次の expr が関数本体です。最後のリストはクロージャが保持する局所変数の環境です。
expr は変数を表す Var を削除して、大域変数を表す Gvar of string * value ref と局所変数を表す Lvar of int * int を追加します。let, let rec を表す Let と Rec は expr list * expr に変更します。局所変数は環境の位置に変換されているので、局所変数の名前を格納するリストは不要になります。
次は字句解析で文字列を切り出す処理を作成します。文字列は " で囲んで表すことにします。また、文字列の中ではエスケープ記号 \ を使うことができるようにします。プログラムは次のようになります。
リスト : 文字列の切り出し
fun get_string s =
let fun iter a =
if valOf(lookahead s) = #"\"" then (
input1 s;
tokenBuff := Value(Str(implode(rev a)))
) else
let val c = valOf(input1 s) in
if c = #"\\" then
case valOf(input1 s) of
#"n" => iter(#"\n" :: a)
| #"t" => iter(#"\t" :: a)
| x => iter(x :: a)
else iter(c :: a)
end
in
iter []
end
(* トークンの切り出し *)
fun get_token s =
let val c = valOf(lookahead s) in
if Char.isSpace(c) then (
if c = #"\n" then countLine := !countLine + 1 else ();
input1 s;
get_token s
)
else if Char.isDigit(c) then get_number s
else if Char.isAlpha(c) then
・・・ 省略 ・・・
else if c = #"#" then (
countLine := !countLine + 1;
inputLine s;
get_token s
)
else if c = #"\"" then (input1 s; get_string s)
else (
・・・ 省略 ・・・
)
end
関数 get_string は " で囲まれた文字を取り出し、文字列型の値として返します。実際の処理は局所関数 iter で行います。文字 " が出現するまで文字を読み出して累積変数 a に格納します。この中でエスケープ記号 #"\\" を見つけたら、次の文字をチェックします。今回は \n と \t のみ対応することにします。#"n" ならば改行を表す #"\n" に、#"t" ならばタブを表す #"\t" に変換します。それ以外の文字はそのまま a に追加します。これで文字列の中に " や \ を含めることができます。
関数 get_token は文字列の処理だけではなく、エラー表示で行数を表示するための処理と、コメント行の処理を追加しています。改行文字 #"\n" を読み込んだら coutLine を +1 します。コメントは # から行末までとします。文字 #"#" を見つけたら関数 inputLine で行末まで読み飛ばします。文字 #"\"" を見つけたら文字列を切り出す関数 get_string を呼び出します。
次は構文解析の処理を修正します。
リスト : 構文解析の修正
fun expression(s, env) =
let
fun iter v =
case !tokenBuff of
Oper(Assign) => (
case v of
(Gvar(_) | Lvar(_) | Ref(_)) =>
(get_token s; Op2(Assign, v, expression(s, env)))
| _ => raise Syntax_error("invalid assign form")
)
| _ => v
in
iter(expr1(s, env))
end
まず大きな修正として構文解析を行う関数に局所変数の環境を表す引数 env を追加します。関数 expression の場合、引数に env を追加するとともに、左辺値が Gvar, Lvar, Ref ならば代入処理を行う構文木を生成します。
リスト : 構文解析の修正 (2)
and factor(s, env) =
case !tokenBuff of
Lpar => (
get_token s;
let
val v = expression(s, env)
in
case !tokenBuff of
Rpar => (get_token s;
case !tokenBuff of
Lpar => App(v, get_argument(s, env))
| _ => v)
| _ => raise Syntax_error("')' expected")
end
)
・・・ 省略 ・・・
| Ident(name) => (
get_token s;
let
val var = search_variable(name, env)
in
case !tokenBuff of
Lpar => App(var, get_argument(s, env))
| Lbra => Ref(var, get_index(s, env))
| _ => var
end
)
| _ => raise Syntax_error("unexpected token")
関数 factor では、カッコ内の式を評価したあと、左カッコ Lpar が続く場合は関数を呼び出す構文木 App を生成します。トークンが Ident(name) の場合、関数 search_variable で局所変数と大域変数から名前が name の変数を探します。そのあとに左カッコ Lpar が続く場合は関数呼び出し、左角カッコ Lbra が続く場合はベクタのアクセス、それ以外の場合は変数のアクセスになります。
次は関数 search_variable を作ります。
リスト : 変数の探索
fun search_variable(name, env) =
let
fun iter1(_, []) = NONE
| iter1(i, x::xs) =
if name = x then SOME i else iter1(i + 1, xs)
fun iter2(_, []) = Gvar(lookup name)
| iter2(j, x::xs) =
case iter1(0, x) of
NONE => iter2(j + 1, xs)
| SOME i => Lvar(j, i)
in
iter2(0, env)
end
局所関数 iter1 でフレーム内の変数の位置を、iter2 でフレーム番号を求めます。環境 env から name を見つけた場合は Lvar(j, i) を返します。先頭要素 j がフレーム番号、i がフレーム内の位置です。見つからない場合は関数 lookup で大域変数から name を探します。
関数 lookup は次のようになります。
リスト : 大域変数の探索
fun lookup name =
let
fun iter [] =
let
val cell = (name, ref Undef)
in
global_env := cell :: (!global_env);
cell
end
| iter ((x as (n, _))::xs) =
if n = name then x else iter xs
in
iter(!global_env)
end
局所関数 iter で大域変数の環境 global_env を探索します。name を見つけた場合はタプルをそのまま返します。見つからない場合は新しいタプル cell を生成して、global_env に追加してから返します。このとき、値は Undef に初期化することに注意してください。
次はクロージャを生成する関数 make_clo を修正します。
リスト : クロージャの生成
and make_clo(s, env) =
let
val args = get_parameter s
val num = length args
val body = make_begin(s, args::env)
in
case !tokenBuff of
Lpar => App(Clo(num, body), get_argument(s, env))
| _ => Clo(num, body)
end
まず最初に関数 get_parameter で引数を取り出して変数 args にセットし、その個数を length でカウントして変数 num にセットします。そして、関数本体を make_begin でコンパイルします。このとき、局所変数の環境 env に args を追加することに注意してください。なお、get_argument で引数を評価するとき、環境は env のままになります。
次は let, let rec の処理を作ります。
リスト : let, let rec の処理
and make_let(s, env) =
let
fun iter0(a, b) =
case !tokenBuff of
IN => (get_token s; (rev b, make_begin(s, (rev a)::env)))
| Comma => (get_token s; iter0(a, b))
| Ident(name) => (get_token s;
case !tokenBuff of
Oper(Assign) =>
(get_token s; iter0(name::a, (expression(s, env))::b))
| _ => raise Syntax_error("invalid let form"))
| _ => raise Syntax_error("invalid let form")
fun get_var a =
case !tokenBuff of
Oper(Assign) => (get_token s; rev a)
| Ident(name) => (get_token s; get_var (name::a))
| Comma => (get_token s; get_var(a))
| _ => raise Syntax_error("invalid let form")
fun iter(vars, env1) =
let
val vals = get_comma_list(s, [], env1)
in
case !tokenBuff of
IN => (get_token s;
if length(vars) = length(vals)
then (vals, make_begin(s, env1))
else raise Syntax_error("invalid let form"))
| _ => raise Syntax_error("in expected")
end
in
case !tokenBuff of
REC => (get_token s;
let
val vars = get_var []
in
Rec(iter(vars, vars::env))
end)
| _ => Let(iter0([], []))
end
let の処理は局所関数 iter0 で行います。今までは expression を呼び出して代入式を求めていましたが、これでは局所変数名を求めることができません。get_token を呼び出して構文解析を行います。
まず、Ident(name) で変数名を取得したあと、次のトークンが Oper(Assign) であることを確認します。それから、expression で初期化式を取得します。取り出した変数名と式は累積変数 a, b に格納します。トークンが IN の場合、本体を make_begin で取得して Let を返します。このとき、環境 env に rev a を追加することをお忘れなく。
let rec の処理は局所関数 get_var と iter で行います。最初に、get_var でカンマで区切られている局所変数を求め、変数名を累積変数 a に追加します。トークンが Oper(Assign) の場合は rev a を返します。iter に渡す環境は env に get_var の返り値を追加したものになります。iter は最初に get_comma_list でカンマで区切られた式を求めます。次に、トークンが IN であることを確認したら、変数の個数と式の個数をチェックします。個数が合わない場合はエラーを送出します。あとは、make_begin で本体を取得して Rec を返すだけです。
あとの修正は簡単なので説明は割愛します。詳細は プログラムリスト をお読みください。
次は式を評価する関数 eval_expr を修正します。
リスト : eval_expr の修正
fun eval_expr(Val(n), _, cont) = cont n
| eval_expr(Gvar(name, ref v), _, cont) = (
case v of
Undef => raise Calc_run_error("Unbound variable " ^ name)
| _ => cont v
)
| eval_expr(Lvar(j, i), env, cont) =
cont(!(List.nth(List.nth(env, j), i)))
| eval_expr(Op2(Assign, expr1, expr2), env, cont) =
eval_expr(
expr2,
env,
fn w => case expr1 of
Gvar(_, v) => (v := w; cont w)
| Lvar(j, i) => (List.nth(List.nth(env, j), i) := w;
cont w)
| Ref(expr, args) =>
eval_expr(
expr,
env,
fn v => eval_index(
args,
env,
fn a => (update_vector(v, a, w); cont w)))
| _ => raise Calc_run_error("Illegal assign form") )
・・・ 省略 ・・・
式が Gvar(name, ref v) の場合、v が Undef であればエラーを送出し、そうでなければ v を返します。Lvar(j, i) の場合は env の j 番目のフレームの i 番目の要素を返します。Assign の場合は代入処理を行います。Gvar(_, v) の場合は v の値を書き換えます。Lvar(j, i) の場合は env の j 番目のフレームの i 番目の要素の値を書き換えます。
次は let rec の処理を修正します。
リスト : let rec の評価
| eval_expr(Rec(args, body), env, cont) =
let
fun iter([], [], env) = eval_expr(body, env, cont)
| iter(e::es, x::xs, env) =
eval_expr(e,
env,
fn v => (x := v; iter(es, xs, env)) )
| iter(_, _, _) = raise Calc_run_error("invalid let rec form")
fun make_frame([], a) = a
| make_frame(_::xs, a) = make_frame(xs, (ref Undef)::a)
val xs = make_frame(args, [])
in
iter(args, xs, xs::env)
end
局所関数 make_frame で値が Undef のフレーム xs を生成します。そして、局所関数 iter で初期化式を順番に評価し、フレームの値をその返り値で書き換えます。このとき、環境は xs::evn になります。最後に本体 body を eval_expr で評価します。
あとの修正は簡単なので説明は割愛します。詳細は プログラムリスト をお読みください。
最後に文字列の操作関数を追加します。
| 関数名 | 機能 |
|---|---|
| isString(s) | s が文字列ならば真を返す |
| strlen(s) | 文字列 s の長さを返す |
| strref(s, n) | 文字列 s の n 番目の文字を返す |
| strcat(s1, s2) | 文字列 s1, s2 を連結した新しい文字列を返す |
| ord(c) | 文字 c を整数値に変換する |
| chr(n) | 整数値 n を文字に変換する |
| strcmp(s1, s2) | 文字列を比較する (返り値は -1, 0, 1) |
文字は長さ 1 の文字列で表します。プログラムは次のようになります。
リスト : 文字列の操作関数
(* データ型のチェック : isString *)
fun isString(Str(_)) = True
| isString(_) = False
(* 文字列の長さ : strlen *)
fun string_length(Str(s)) =
Integer(IntInf.fromInt(String.size(s)))
| string_length(_) = raise Calc_run_error("Not String")
(* n 番目の文字を求める ; strref *)
fun string_ref(Str(s), Integer(n)) =
Str(String.str(String.sub(s, IntInf.toInt(n))))
| string_ref(_, _) = raise Calc_run_error("Not (String, Integer)")
(* 文字列の連結 : strcat *)
fun string_append(Str(s1), Str(s2)) = Str(s1 ^ s2)
| string_append(_, _) = raise Calc_run_error("Not (String, String)")
(* 文字を整数値に変換 : ord *)
fun string_to_integer(Str(s)) = (
case Char.fromString(s) of
NONE => raise Calc_run_error("Not Char")
| SOME c => Integer(IntInf.fromInt(ord(c))) )
| string_to_integer(_) = raise Calc_run_error("Not String")
(* 整数値を文字に変換 : chr *)
fun integer_to_string(Integer(n)) =
Str(str(chr(IntInf.toInt(n))))
| integer_to_string(_) = raise Calc_run_error("Not Integer")
(* 文字列の比較 : strcmp *)
fun string_compare(Str(s1), Str(s2)) =
Integer(case String.compare(s1, s2) of
LESS => ~1 | EQUAL => 0 | GREATER => 1)
| string_compare(_, _) = raise Calc_run_error("Not String")
基本的には SML/NJ のライブラリ関数を呼び出すだけです。
あとは、ファイルをロードする関数 load を追加しますが、とくに難しいところはないと思います。説明は割愛しますので、詳細は プログラムリスト をお読みください。
それでは、簡単な実行例を示します。最初に大域変数と局所変数のアクセスをチェックします。
Calc> a;
ERROR: Unbound variable a
Calc> a = 10;
10
Calc> b;
ERROR: Unbound variable b
Calc> b = 20;
20
Calc> b;
20
Calc> let a = 100, b = 200 in print(a), print(", "), print(b) end;
100, 200
Calc> a;
10
Calc> b;
20
Calc> def add(a, b) a + b end
add
Calc> add;
<Function>
Calc> add(1000, 2000);
3000
Calc> a;
10
Calc> b;
20
Calc> let a = 1 in
let a = 2 in
let a = 3 in
print(a), print("\n") end,
print(a), print("\n") end,
print(a), print("\n") end;
3
2
1
Calc> def makeAdder(x) fn(y) x + y end end
makeAdder
Calc> a10 = makeAdder(10);
<Function>
Calc> a10(100);
110
Calc> a5 = makeAdder(5);
<Function>
Calc> a5(10);
15
大域変数の未束縛チェック、関数呼び出しや let による局所変数の定義、let の入れ子、クロージャは正常に動作しています。
次は let rec で再帰呼び出しを試してみましょう。
Calc> let rec fact = fn(n)
if n == 0 then 1 else n * fact(n - 1) end end
in fact(10) end;
3628800
Calc> let rec foo, bar =
fn(n) if n == 0 then 1 else bar(n - 1) end end,
fn(n) if n == 0 then 0 else foo(n - 1) end end
in print(foo(100)), print(", "), print(bar(100)) end;
1, 0
Calc> f = cons(fn(a, b) a + b end, fn(a, b) a - b end);
(<Function> . <Function>)
Calc> (car(f))(10, 20);
30
Calc> (cdr(f))(10, 20);
~10
再帰呼び出し、相互再帰ともに正常に動作しています。(式)(引数, ...) による関数呼び出しも大丈夫ですね。
次は文字列関数を試してみましょう。
Calc> isString("hello");
1
Calc> isString(10);
0
Calc> strlen("hello");
5
Calc> strcat("hello", " world");
hello world
Calc> strref("hello", 0);
h
Calc> strref("hello", 4);
o
Calc> strcmp("abc", "aba");
1
Calc> strcmp("abc", "abc");
0
Calc> strcmp("abc", "abd");
~1
Calc> a = "hello";
hello
Calc> let k = strlen(a), i = 0 in
while i < k do print(ord(strref(a, i))), print("\n"), i = i + 1 end end;
104
101
108
108
111
0
Calc> chr(104);
h
Calc> chr(101);
e
Calc> chr(108);
l
Calc> chr(111);
o
正常に動作しているようです。興味のある方はいろいろ試してみてください。
最後に、整数の合計値を求める関数 sum0, sum1. sum2 とたらいまわし関数を使って実行時間を計測します。プログラムを再掲します。
リスト : 1 から x までの合計値を求める
def sum0(n)
if n == 0 then 0 else n + sum0(n - 1) end
end
def sum1(n, a)
if n == 0 then a else sum1(n - 1, a + n) end
end
def sum2(n)
let
a = 0
in
while n > 0 do
a = a + n,
n = n - 1
end,
a
end
end
リスト : たらいまわし関数
def tak(x, y, z)
if x <= y then
z
else
tak(tak(x - 1, y, z), tak(y - 1, z, x), tak(z - 1, x, y))
end
end
def tarai(x, y, z)
if x <= y then
y
else
tarai(tarai(x - 1, y, z), tarai(y - 1, z, x), tarai(z - 1, x, y))
end
end
結果は次のようになりました。
表 : 実行結果 (単位 : 秒)
: calc : fcalc
------------------+------+-------
sum0(1000000) : 9.87 : 1.98
sum1(10000000, 0) : 4.80 : 0.42
sum2(10000000) : 4.48 : 0.44
tak(18, 9, 0) : 7.42 : 5.41
tarai(12, 6, 0) : 5.97 : 4.39
実行環境 : Windows 10, Intel Core i5-6200U 2.30GHz, SML/NJ ver 110.98
calc が前回までに作成した電卓プログラム、fcalc が今回作成した電卓プログラムです。どのテストでも実行時間は fcalc のほうが速くなりました。変数のアクセス方法を改良した効果は十分に出ていると思います。興味のある方はいろいろ試してみてください。
(*
* fcalc.sml : 関数型電卓プログラム
*
* Copyright (C) 2012-2021 Makoto Hiroi
*
*)
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 (* 空を表す値 *)
| Undef (* 未定義 *)
| Integer of IntInf.int (* 整数 *)
| Float of real (* 実数 *)
| Func of func (* 関数 *)
| Pair of value ref * value ref (* 連結リスト *)
| Vec of value array (* ベクタ *)
| Str of string (* 文字列 *)
and func = F1 of value -> value
| F2 of (value * value) -> value
| CLO of int * expr * value ref list list
| CT of value -> value
and expr = Val of value (* 値 *)
| Gvar of string * value ref (* 大域変数 *)
| Lvar of int * int (* 局所変数 *)
| 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 int * expr (* closure の生成 *)
| Let of expr list * expr (* let *)
| Rec of expr list * expr (* let rec *)
| Lst of expr list (* リストの生成 *)
| Crv of expr list (* ベクタの生成 *)
| Ref of expr * expr list (* ベクタのアクセス *)
| App of expr * expr list (* 関数の適用 *)
| Cct of expr (* 継続 *)
(* トークンの定義 *)
datatype token = Value of value (* 値 *)
| Ident of string (* 識別子 *)
| Oper of operator (* 演算子 *)
| Lpar | Rpar (* (, ) *)
| Lbra | Rbra (* [, ] *)
| 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 *)
| LIST (* list *)
| CALLCC (* callcc *)
| 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 => (print "()"; Nil)
| Undef => (print "<Undef>"; Nil)
| Integer(n) => (print(IntInf.toString(n)); Nil)
| Float(n) => (print(Real.toString(n)); Nil)
| Func(_) => (print "<Function>"; Nil)
| Pair(_) => (print "("; print_pair(x); print ")"; Nil)
| Vec(_) => (print "["; print_vector(x); print "]"; Nil)
| Str(s) => (print s; Nil)
and print_pair(Pair(ref x, ref y)) = (
print_value x;
case y of
Nil => Nil
| Pair(_, _) => (print " "; print_pair y)
| _ => (print " . "; print_value y)
)
| print_pair x = print_value x
and print_vector(Vec(v)) =
let
val i = ref 0
val k = Array.length(v)
in
while !i < k - 1 do (
print_value(Array.sub(v, !i));
print ", ";
i := !i + 1
);
print_value(Array.sub(v, !i));
Nil
end
| print_vector x = print_value x
(* 文字の表示 *)
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
fun isPair(Pair(_, _)) = True
| isPair(_) = False
fun isVector(Vec(_)) = True
| isVector(_) = False
fun isString(Str(_)) = True
| isString(_) = False
(* 連結リストの基本関数 *)
fun car(Pair(ref x, _)) = x
| car(_) = raise Calc_run_error("Not Pair")
fun cdr(Pair(_, ref y)) = y
| cdr(_) = raise Calc_run_error("Not Pair")
fun cons(x, y) = Pair(ref x, ref y)
fun setCar(Pair(x, _), z) = (x := z; z)
| setCar(_, _) = raise Calc_run_error("Not Pair")
fun setCdr(Pair(_, y), z) = (y := z; z)
| setCdr(_, _) = raise Calc_run_error("Not Pair")
(* ベクタの生成 *)
fun make_vector(Integer(size), v) =
Vec(Array.array(IntInf.toInt(size), v))
| make_vector(_, _) = raise Calc_run_error("Not Integer")
(* ベクタの大きさ *)
fun vector_length(Vec(v)) =
Integer(IntInf.fromInt(Array.length(v)))
| vector_length(_) = raise Calc_run_error("Not Vector")
(* 文字列の基本関数 *)
fun string_length(Str(s)) =
Integer(IntInf.fromInt(String.size(s)))
| string_length(_) = raise Calc_run_error("Not String")
fun string_ref(Str(s), Integer(n)) =
Str(String.str(String.sub(s, IntInf.toInt(n))))
| string_ref(_, _) = raise Calc_run_error("Not (String, Integer)")
fun string_append(Str(s1), Str(s2)) = Str(s1 ^ s2)
| string_append(_, _) = raise Calc_run_error("Not (String, String)")
fun string_to_integer(Str(s)) = (
case Char.fromString(s) of
NONE => raise Calc_run_error("Not Char")
| SOME c => Integer(IntInf.fromInt(ord(c))) )
| string_to_integer(_) = raise Calc_run_error("Not String")
fun integer_to_string(Integer(n)) =
Str(str(chr(IntInf.toInt(n))))
| integer_to_string(_) = raise Calc_run_error("Not Integer")
fun string_compare(Str(s1), Str(s2)) =
Integer(case String.compare(s1, s2) of
LESS => ~1 | EQUAL => 0 | GREATER => 1)
| string_compare(_, _) = raise Calc_run_error("Not String")
(* 大域変数 *)
val global_env : (string * value ref) list ref = ref []
(* 探索 *)
fun lookup name =
let
fun iter [] =
let
val cell = (name, ref Undef)
in
global_env := cell :: (!global_env);
cell
end
| iter ((x as (n, _))::xs) =
if n = name then x else iter xs
in
iter(!global_env)
end
(* 切り出したトークンを格納するバッファ *)
val tokenBuff = ref Others
(* 行数をカウントする *)
val countLine = ref 0
(* 整数の切り出し *)
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 =
let val c = valOf(lookahead s) in
if Char.isAlphaNum(c) orelse c = #"_" then
iter ((valOf(input1 s)) :: a)
else Ident(implode(rev a))
end
in
iter []
end
(* 文字列の切り出し *)
fun get_string s =
let fun iter a =
if valOf(lookahead s) = #"\"" then (
input1 s;
tokenBuff := Value(Str(implode(rev a)))
) else
let val c = valOf(input1 s) in
if c = #"\\" then
case valOf(input1 s) of
#"\\" => iter(#"\\" :: a)
| #"n" => iter(#"\n" :: a)
| #"t" => iter(#"\t" :: a)
| x => iter(x :: a)
else iter(c :: a)
end
in
iter []
end
(* トークンの切り出し *)
fun get_token s =
let val c = valOf(lookahead s) in
if Char.isSpace(c) then (
if c = #"\n" then countLine := !countLine + 1 else ();
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
| "list" => LIST
| "callcc" => CALLCC
| _ => id
)
end
else if c = #"#" then (
countLine := !countLine + 1;
inputLine s;
get_token s
)
else if c = #"\"" then (input1 s; get_string s)
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
| #"[" => Lbra
| #"]" => Rbra
| #";" => Semic
| #"," => Comma
| _ => Others
)
)
end
(* 変数の探索 *)
fun search_variable(name, env) =
let
fun iter1(_, []) = NONE
| iter1(i, x::xs) =
if name = x then SOME i else iter1(i + 1, xs)
fun iter2(_, []) = Gvar(lookup name)
| iter2(j, x::xs) =
case iter1(0, x) of
NONE => iter2(j + 1, xs)
| SOME i => Lvar(j, i)
in
iter2(0, env)
end
(* 仮引数の取得 *)
fun get_parameter s =
let
fun iter a =
case !tokenBuff of
Ident(name) => (get_token s; iter (name::a))
| Comma => (get_token s; iter a)
| _ => rev a
in
case !tokenBuff of
Lpar => (get_token s;
case !tokenBuff of
Rpar => (get_token s; [])
| _ => let val parm = iter [] in
case !tokenBuff of
Rpar => (get_token s; parm)
| _ => raise Syntax_error("unexpected token")
end)
| _ => raise Syntax_error("'(' expected")
end
(* 本体の生成 *)
fun make_body([]) = Val(Nil)
| make_body([x]) = x
| make_body(xs) = Bgn(xs)
(* 構文木の組み立て *)
fun expression(s, env) =
let
fun iter v =
case !tokenBuff of
Oper(Assign) => (
case v of
(Gvar(_) | Lvar(_) | Ref(_)) =>
(get_token s; Op2(Assign, v, expression(s, env)))
| _ => raise Syntax_error("invalid assign form")
)
| _ => v
in
iter(expr1(s, env))
end
(* 論理演算子 and, or の処理 *)
and expr1(s, env) =
let
fun iter v =
case !tokenBuff of
Oper(AND) => (get_token s; iter(Ops(AND, v, expr2(s, env))))
| Oper(OR) => (get_token s; iter(Ops(OR, v, expr2(s, env))))
| _ => v
in
iter(expr2(s, env))
end
(* 比較演算子の処理 *)
and expr2(s, env) =
let
fun iter v =
case !tokenBuff of
Oper(EQ) => (get_token s; iter(Op2(EQ, v, expr3(s, env))))
| Oper(NE) => (get_token s; iter(Op2(NE, v, expr3(s, env))))
| Oper(LT) => (get_token s; iter(Op2(LT, v, expr3(s, env))))
| Oper(GT) => (get_token s; iter(Op2(GT, v, expr3(s, env))))
| Oper(LE) => (get_token s; iter(Op2(LE, v, expr3(s, env))))
| Oper(GE) => (get_token s; iter(Op2(GE, v, expr3(s, env))))
| _ => v
in
iter(expr3(s, env))
end
and expr3(s, env) =
let
fun iter v =
case !tokenBuff of
Oper(Add) => (get_token s; iter(Op2(Add, v, term(s, env))))
| Oper(Sub) => (get_token s; iter(Op2(Sub, v, term(s, env))))
| _ => v
in
iter (term(s, env))
end
and term(s, env) =
let
fun iter v =
case !tokenBuff of
Oper(Mul) => (get_token s; iter(Op2(Mul, v, factor(s, env))))
| Oper(Quo) => (get_token s; iter(Op2(Quo, v, factor(s, env))))
| Oper(Mod) => (get_token s; iter(Op2(Mod, v, factor(s, env))))
| _ => v
in
iter (factor(s, env))
end
and factor(s, env) =
case !tokenBuff of
Lpar => (
get_token s;
let
val v = expression(s, env)
in
case !tokenBuff of
Rpar => (get_token s;
case !tokenBuff of
Lpar => App(v, get_argument(s, env))
| _ => v)
| _ => raise Syntax_error("')' expected")
end
)
| Lbra => (
get_token s;
let val args = get_comma_list(s, [], env) in
case !tokenBuff of
Rbra => (get_token s; Crv(args))
| _ => raise Syntax_error("']' expected")
end
)
| Value(n) => (get_token s; Val(n))
| Quit => raise Calc_exit
| IF => (get_token s; make_sel(s, env))
| WHL => (get_token s; make_while(s, env))
| BGN => (get_token s; make_begin(s, env))
| FN => (get_token s; make_clo(s, env))
| LET => (get_token s; make_let(s, env))
| LIST => (get_token s; make_list(s, env))
| CALLCC => (get_token s; make_ct(s, env))
| Oper(NOT) => (get_token s; Op1(NOT, factor(s, env)))
| Oper(Sub) => (get_token s; Op1(Sub, factor(s, env)))
| Oper(Add) => (get_token s; Op1(Add, factor(s, env)))
| Ident(name) => (
get_token s;
let
val var = search_variable(name, env)
in
case !tokenBuff of
Lpar => App(var, get_argument(s, env))
| Lbra => Ref(var, get_index(s, env))
| _ => var
end
)
| _ => raise Syntax_error("unexpected token")
(* カンマで区切られた式を取得 *)
and get_comma_list(s, a, env) =
let val v = expression(s, env) in
case !tokenBuff of
Comma => (get_token s; get_comma_list(s, v::a, env))
| _ => rev(v::a)
end
(* 引数の取得 *)
and get_argument(s, env) =
case !tokenBuff of
Lpar => (get_token s;
case !tokenBuff of
Rpar => (get_token s; [])
| _ => let val args = get_comma_list(s, [], env) in
case !tokenBuff of
Rpar => (get_token s; args)
| _ => raise Syntax_error("unexpected token")
end)
| _ => raise Syntax_error("'(' expected")
(* if *)
and make_sel(s, env) =
let val test_form = expression(s, env) in
case !tokenBuff of
THEN => (
get_token s;
let val then_form = get_comma_list(s, [], env) in
case !tokenBuff of
ELSE => (
get_token s;
let val else_form = get_comma_list(s, [], env) in
case !tokenBuff of
END => (get_token s;
Sel(test_form, make_body(then_form), make_body(else_form)))
| _ => raise Syntax_error("end expected")
end
)
| END => (get_token s;
Sel(test_form, make_body(then_form), Val(False)))
| _ => raise Syntax_error("else or end expected")
end
)
| _ => raise Syntax_error("then expected")
end
(* while *)
and make_while(s, env) =
let val test_form = expression(s, env) in
case !tokenBuff of
DO => (get_token s; Whl(test_form, make_begin(s, env)))
| _ => raise Syntax_error("do expected")
end
(* begin *)
and make_begin(s, env) =
let
val body = get_comma_list(s, [], env)
in
case !tokenBuff of
END => (get_token s; make_body(body))
| _ => raise Syntax_error("end expected")
end
(* closure *)
and make_clo(s, env) =
let
val args = get_parameter s
val num = length args
val body = make_begin(s, args::env)
in
case !tokenBuff of
Lpar => App(Clo(num, body), get_argument(s, env))
| _ => Clo(num, body)
end
and make_let(s, env) =
let
fun iter0(a, b) =
case !tokenBuff of
IN => (get_token s; (rev b, make_begin(s, (rev a)::env)))
| Comma => (get_token s; iter0(a, b))
| Ident(name) => (get_token s;
case !tokenBuff of
Oper(Assign) =>
(get_token s; iter0(name::a, (expression(s, env))::b))
| _ => raise Syntax_error("invalid let form"))
| _ => raise Syntax_error("invalid let form")
fun get_var a =
case !tokenBuff of
Oper(Assign) => (get_token s; rev a)
| Ident(name) => (get_token s; get_var (name::a))
| Comma => (get_token s; get_var(a))
| _ => raise Syntax_error("invalid let form")
fun iter(vars, env1) =
let
val vals = get_comma_list(s, [], env1)
in
case !tokenBuff of
IN => (get_token s;
if length(vars) = length(vals)
then (vals, make_begin(s, env1))
else raise Syntax_error("invalid let form"))
| _ => raise Syntax_error("in expected")
end
in
case !tokenBuff of
REC => (get_token s;
let
val vars = get_var []
in
Rec(iter(vars, vars::env))
end)
| _ => Let(iter0([], []))
end
and make_list(s, env) =
case !tokenBuff of
Lpar => (get_token s;
let
val args = get_comma_list(s, [], env)
in
case !tokenBuff of
Rpar => (get_token s; Lst(args))
| _ => raise Syntax_error("')' expected")
end)
| _ => raise Syntax_error("'(' expected")
(* ベクタの添字を取得する *)
and get_index(s, env) =
let
fun iter a =
let
val v = expression(s, env)
in
case !tokenBuff of
Rbra => (get_token s;
case !tokenBuff of
Lbra => (get_token s; iter(v::a))
| _ => rev(v::a))
| _ => raise Syntax_error("']' expected")
end
in
get_token s;
iter([])
end
(* 継続の生成 *)
and make_ct(s, env) =
case !tokenBuff of
Lpar => (get_token s;
let
val v = expression(s, env)
in
case !tokenBuff of
Rpar => (get_token s; Cct(v))
| _ => raise Syntax_error("')' expected")
end)
| _ => raise Syntax_error("'(' expected")
(* 引数の個数をチェック *)
fun check_args_num(args, n) =
if length(args) < n
then raise Calc_run_error("Not enough argument")
else ()
(* 真偽のチェック *)
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 update_vector(Vec(v), [x], w) = (Array.update(v, x, w); w)
| update_vector(Vec(v), x::xs, w) = update_vector(Array.sub(v, x), xs, w)
| update_vector(_, _, _) = raise Calc_run_error("Not Vector")
(* ベクタの値を取得 *)
fun get_vector(Vec(v), [x]) = Array.sub(v, x)
| get_vector(Vec(v), x::xs) = get_vector(Array.sub(v, x), xs)
| get_vector(_, _) = raise Calc_run_error("Not Vector")
(* 式の評価 *)
fun eval_expr(Val(n), _, cont) = cont n
| eval_expr(Gvar(name, ref v), _, cont) = (
case v of
Undef => raise Calc_run_error("Unbound variable " ^ name)
| _ => cont v
)
| eval_expr(Lvar(j, i), env, cont) =
cont(!(List.nth(List.nth(env, j), i)))
| eval_expr(Ref(expr, args), env, cont) =
eval_expr(
expr,
env,
fn v => eval_index(args,
env,
fn a => cont(get_vector(v, a))))
| eval_expr(Op2(Assign, expr1, expr2), env, cont) =
eval_expr(
expr2,
env,
fn w => case expr1 of
Gvar(_, v) => (v := w; cont w)
| Lvar(j, i) => (List.nth(List.nth(env, j), i) := w;
cont w)
| Ref(expr, args) =>
eval_expr(
expr,
env,
fn v => eval_index(
args,
env,
fn a => (update_vector(v, a, w); cont w)))
| _ => raise Calc_run_error("Illegal assign form") )
| eval_expr(Op2(op2, expr1, expr2), env, cont) =
eval_expr(
expr1,
env,
fn v => eval_expr(
expr2,
env,
fn w => case op2 of
Add => cont(eval_op(op +, op +, v, w))
| Sub => cont(eval_op(op -, op -, v, w))
| Mul => cont(eval_op(op *, op *, v, w))
| Quo => cont(eval_op(op div, op /, v, w))
| Mod => cont(eval_op_int(op mod, v, w))
| EQ => cont(eval_comp(op =, Real.==, v, w))
| NE => cont(eval_comp(op <>, Real.!=, v, w))
| LT => cont(eval_comp(op <, op <, v, w))
| GT => cont(eval_comp(op >, op >, v, w))
| LE => cont(eval_comp(op <=, op <=, v, w))
| GE => cont(eval_comp(op >=, op >=, v, w))
| _ => raise Calc_run_error("Illegal operator") ))
| eval_expr(Op1(op1, expr1), env, cont) =
eval_expr(
expr1,
env,
fn v => case (op1, v) of
(Add, _) => cont v
| (Sub, Integer(n)) => cont(Integer(~n))
| (Sub, Float(n)) => cont(Float(~n))
| (NOT, _) => cont(if isTrue(v) then False else True)
| _ => raise Calc_run_error("Illegal expression") )
| eval_expr(Ops(ops, expr1, expr2), env, cont) =
eval_expr(
expr1,
env,
fn v => case ops of
AND => if isTrue(v)
then eval_expr(expr2, env, cont)
else cont v
| OR => if isTrue(v)
then cont v
else eval_expr(expr2, env, cont)
| _ => raise Calc_run_error("Illegal operator") )
| eval_expr(Sel(expr_c, expr_t, expr_e), env, cont) =
eval_expr(
expr_c,
env,
fn v => if isTrue(v)
then eval_expr(expr_t, env, cont)
else eval_expr(expr_e, env, cont) )
| eval_expr(App(expr, args), env, cont) =
let
fun iter([], _, k) = k []
| iter(x::xs, env, k) =
eval_expr(x,
env,
fn v => iter(xs, env, fn w => k ((ref v)::w)))
in
iter(args,
env,
fn vs => eval_expr(
expr,
env,
fn v => case v of
Func(F1 f1) => (check_args_num(vs, 1);
cont(f1(!(hd vs))))
| Func(F2 f2) => (check_args_num(vs, 2);
cont(f2(!(hd vs), !(hd (tl vs)))))
| Func(CLO(n, body, clo)) =>
(check_args_num(vs, n);
eval_expr(body, vs::clo, cont))
| Func(CT k) => (check_args_num(vs, 1);
k(!(hd vs)))
| _ => raise Calc_run_error("Not function") ))
end
| eval_expr(Cct(expr), env, cont) =
eval_expr(expr,
env,
fn f => case f of
Func(CLO(_, body, clo)) =>
eval_expr(body, [ref (Func(CT cont))]::clo, cont)
| _ => raise Calc_run_error("Not Closure") )
| eval_expr(Whl(expr_c, expr_b), env, cont) =
let
fun iter () =
eval_expr(expr_c,
env,
fn v => if isTrue(v)
then eval_expr(expr_b, env, fn _ => iter ())
else cont False)
in
iter ()
end
| eval_expr(Bgn(xs), env, cont) =
let
fun iter [] = raise Calc_run_error("ivalid begin form")
| iter [x] = eval_expr(x, env, cont)
| iter (x::xs) = eval_expr(x, env, fn _ => iter(xs))
in
iter(xs)
end
| eval_expr(Clo(n, expr), env, cont) = cont(Func(CLO(n, expr, env)))
| eval_expr(Let(args, body), env, cont) =
let
fun iter([], _, k) = k []
| iter(x::xs, env, k) =
eval_expr(x,
env,
fn v => iter(xs, env, fn w => k ((ref v)::w)))
in
iter(args,
env,
fn vs => eval_expr(body, vs::env, cont))
end
| eval_expr(Rec(args, body), env, cont) =
let
fun iter([], [], env) = eval_expr(body, env, cont)
| iter(e::es, x::xs, env) =
eval_expr(e,
env,
fn v => (x := v; iter(es, xs, env)) )
| iter(_, _, _) = raise Calc_run_error("invalid let rec form")
fun make_frame([], a) = a
| make_frame(_::xs, a) = make_frame(xs, (ref Undef)::a)
val xs = make_frame(args, [])
in
iter(args, xs, xs::env)
end
| eval_expr(Lst(args), env, cont) =
let
fun iter([], k) = k Nil
| iter(x::xs, k) =
eval_expr(x,
env,
fn v => iter(xs, fn w => k (Pair(ref v, ref w))))
in
iter(args, fn v => cont v)
end
| eval_expr(Crv(args), env, cont) =
let
fun toVector(_, [], v) = v
| toVector(i, x::xs, v) =
(Array.update(v, i - 1, x); toVector(i - 1, xs, v))
fun iter(i, [], a) =
cont(Vec(toVector(i, a, Array.array(i, Nil))))
| iter(i, x::xs, a) =
eval_expr(x, env, fn w => iter(i + 1, xs, w::a))
in
iter(0, args, [])
end
(* 添字の評価 *)
and eval_index(args, env, cont) =
let
fun iter([], k) = k []
| iter(x::xs, k) =
eval_expr(
x,
env,
fn w => iter(xs, fn v => case w of
Integer(n) => k(IntInf.toInt(n)::v)
| _ => raise Calc_run_error("Index is not Integer")))
in
iter(args, fn v => cont v)
end
(* 実行 *)
fun toplevel(s, flag) = (
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, [], [a])
val (_, v) = lookup name
in
case !tokenBuff of
END => (v := Func(CLO(length(a), make_body(b), []));
if flag then print (name ^ "\n") else ())
| _ => 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");
let
val v = eval_expr(result, [], fn x => x)
in
if flag then (
case v of
Nil => Nil
| _ => print_value(v);
print "\n")
else ()
end
end
)
fun print_token() =
case !tokenBuff of
Value(v) => (print_value(v); ())
| Ident(name) => print name
| Oper(_) => print "Oper"
| Lpar => print "("
| Rpar => print ")"
| Lbra => print "["
| Rbra => print "]"
| Semic => print ";"
| Comma => print ","
| DEF => print "def"
| END => print "end"
| IF => print "if"
| THEN => print "then"
| ELSE => print "else"
| WHL => print "while"
| DO => print "do"
| BGN => print "begin"
| FN => print "fn"
| LET => print "let"
| IN => print "in"
| REC => print "rec"
| LIST => print "list"
| CALLCC => print "callcc"
| Quit => print "quit"
| Others => print "others"
fun print_error(s, name, mes) = (
print("ERROR: " ^ mes ^ "\n");
print name;
print(", line: " ^ Int.toString(!countLine));
print(", token: ");
print_token();
print(", char: ");
print(Char.toString(valOf(lookahead s)));
print("\n")
)
(* ファイルのロード *)
fun load_library(filename) =
let
val a = openIn(filename)
in
countLine := 1;
(while true do toplevel(a, false)) handle
Option => ()
| Syntax_error(mes) => print_error(a, filename, mes)
| Calc_run_error(mes) => print("ERROR: " ^ mes ^ "\n")
| Div => print "ERROR: Divied by zero\n"
| Subscript => print "ERROR: subscript out of bounds\n"
| err => raise err;
closeIn(a)
end
(* ファイルのロード *)
fun load_file(Str(filename)) = (load_library(filename); Nil)
| load_file(_) = raise Calc_run_error("Not String")
(* 大域変数の初期化 *)
fun init_global () =
global_env := [("nil", ref Nil),
("print", ref (Func(F1 print_value))),
("putc", 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))),
("isPair", ref (Func(F1 isPair))),
("isVector", ref (Func(F1 isVector))),
("isString", ref (Func(F1 isString))),
("car", ref (Func(F1 car))),
("cdr", ref (Func(F1 cdr))),
("cons", ref (Func(F2 cons))),
("setCar", ref (Func(F2 setCar))),
("setCdr", ref (Func(F2 setCdr))),
("makeVector", ref (Func(F2 make_vector))),
("len", ref (Func(F1 vector_length))),
("strlen", ref (Func(F1 string_length))),
("strref", ref (Func(F2 string_ref))),
("strcat", ref (Func(F2 string_append))),
("strcmp", ref (Func(F2 string_compare))),
("ord", ref (Func(F1 string_to_integer))),
("chr", ref (Func(F1 integer_to_string))),
("load", ref (Func(F1 load_file))),
("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))))]
fun calc() = (
init_global();
while true do (
countLine := 1;
print "Calc> ";
flushOut(stdOut);
toplevel(stdIn, true) handle
Syntax_error(mes) => print_error(stdIn, "stdin", mes)
| Calc_run_error(mes) => print("ERROR: " ^ mes ^ "\n")
| Div => print "ERROR: divide by zero\n"
| Subscript => print "ERROR: subscript out of bounds\n"
| err => raise err;
inputLine(stdIn)
)
)