今回は電卓プログラムに論理演算子、比較演算子、条件分岐の機能を追加してみましょう。
論理演算子と比較演算子を使う場合、真偽値を表すデータが必要になります。電卓プログラムのデータは数値しかないので、整数の 0 または実数の 0.0 を偽、それ以外を真と定義することにしましょう。論理演算子と比較演算子は、結果が真であれば整数値 1 を、偽であれば整数値 0 を返すことにします。
電卓プログラムで使用する論理演算子と比較演算子を表に示します。
| 操作 | 意味 | トークン |
|---|---|---|
| not x, ! x | x の否定（真偽の反転） | NOT |
| x and y | x が真かつ y が真ならば真 | AND |
| x or y | x が真まはた y が真ならば真 | OR |
| 演算子 | 意味 | トークン |
|---|---|---|
| == | 等しい | EQ |
| != | 等しくない | NE |
| < | より小さい | LT |
| > | より大きい | GT |
| <= | より小さいか等しい | LE |
| >= | より大きいか等しい | GE |
論理演算子は not (!), and, or で、not は単項演算子になります。比較演算子は ==, !=, <, >, <=, >= の 6 種類で、Ｃ言語の比較演算子と同じです。演算子の優先順位ですが、Ｃ言語のように細かく分けることはしないで、次のように設定することにしました。
優先順位 (高) 単項演算子 (+, -, not) 乗法演算子 (*, /) 加法演算子 (+, -) 比較演算子 (==, !=, <, >, <=, >=) 論理演算子 (and, or) 代入演算子 (=) 優先順位 (低)
条件分岐は「文」として定義することもできますが、今回は簡単な電卓プログラムなので「if 式」として組み込むことにします。if 式の構文を示します。
if 条件式 then 式a else 式b end if 条件式 then 式a end
if は条件式が真であれば式a を実行し、その結果が if 式の値になります。条件式が偽であれば 式b を実行して、その結果が if 式の値になります。else 節が省略されていて、かつ条件式が偽の場合、if 式は整数 0 を返すことにしましょう。
文法を EBNF で表すと次のようになります。
[EBNF]
文 = 関数定義 | 式.
関数定義 = "def", 関数, "(", [仮引数リスト], ")", 式, "end".
式 = 代入式 | 式１.
代入式 = 変数, "=", 式.
式１ = 式２, { ("and" | "or"), 式２}.
式２ = 式３, ("==" | "!=" | "<" | "<=" | ">" | ">="), 式３.
式３ = 項, { ("+" | "-"), 項 }.
項 = 因子, { ("*" | "/"), 因子 }.
因子 = 数値 | ("+" | "-" | "not"), 因子 | "(", 式, ")" | 変数 | 関数, "(", [引数リスト], ")" | if式.
if式 = "if", 式, "then", 式, ["else", 式], "end".
変数 = 識別子
関数 = 識別子
仮引数リスト = 変数, { ",", 変数 }.
引数リスト = 式, { ",", 式 }.
[注意] 数値と識別子の定義は省略
論理演算子と比較演算子の処理は、文法をそのままプログラムするだけなので簡単です。if 式も構文木に変換すると簡単にプログラムすることができます。データ型の定義は次のようになります。
リスト : データ型の定義
(* 演算子の定義 *)
datatype operator = Add | Sub | Mul | Quo | Assign
| NOT | AND | OR
| EQ | NE | LT | GT | LE | GE
(* トークンの定義 *)
datatype token = Number of value (* 数 *)
| Ident of string (* 識別子 *)
| Oper of operator (* 演算子 *)
| Lpar | Rpar (* (, ) *)
| Semic (* ; *)
| Comma (* , *)
| DEF (* def *)
| END (* end *)
| IF (* if *)
| THEN (* then *)
| ELSE (* else *)
| Quit (* 終了 *)
| Others (* その他 *)
(* 式の定義 *)
datatype func = F1 of value -> value
| F2 of (value * value) -> value
| UF of expr list option ref * expr option ref
and expr = Num 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 *)
| App of func * expr list (* 関数の適用 *)
operator に論理演算子 (NOT, AND, OR) と比較演算子 (EQ, NE, LT, GT, LE, GE) を追加します。token には if 文を表す IF, THEN, ELSE を追加します。 expr には and, or を表す Ops of expr * expr と、if を表す Sel of expr * expr * expr を追加します。and と or を「短絡演算子」として機能させるため、専用の構文木 Ops を用意しました。Sel の先頭要素がテストフォームで、第 2 要素が then 節、第 3 要素が else 節を表します。なお、ユーザ関数 UF の定義も変更していますが、これはあとで詳しく説明します。
それではプログラムを作りましょう。まず最初に、関数 get_token を修正します。
リスト : トークンの切り出し
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
| _ => id
)
end
else (
input1(s); (* s から c を取り除く *)
tokenBuff := (case c of
#"+" => Oper(Add)
| #"-" => Oper(Sub)
| #"*" => Oper(Mul)
| #"/" => Oper(Quo)
| #"=" => (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
val get_token = fn : instream -> unit
識別子の処理で、name の値が if, then, else, not, and, or であれば、おのおののトークンを tokenBuff にセットします。記号が = で、次の記号も = の場合は tokenBuff に Oper(EQ) をセットします。記号が ! の場合、次の記号が = であれば tokenBuff に Oper(NE) をセットし、そうでなければ Oper(NOT) をセットします。あとは同様に、<, <= と >, >= の処理を行います。
次は構文解析の処理を修正します。論理演算子の処理は次のようになります。
リスト : 論理演算子の処理
(* 構文木の組み立て *)
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
val expression = fn : instream -> expr val expr1 = fn : instream -> expr
式を評価する expression から関数 expr1 を呼び出します。expr1 は and と or の処理を行います。最初に関数 expr2 を呼び出して、その返り値を局所関数 iter の引数 v に渡します。iter では、tokenBuff の値が AND, OR の場合、Ops を生成して iter を再帰呼び出しします。
次は比較演算子の処理を作ります。
リスト : 比較演算子の処理
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
val expr2 = fn : instream -> expr val expr3 = fn : instream -> expr
関数 expr2 は比較演算子の処理を行います。最初に、expr3 を呼び出して、その返り値を局所関数 iter の引数 v に渡します。iter は tokenBuff の値が比較演算子であれば、Op2 を生成して iter を再帰呼び出しします。
次は factor に not と if の処理を追加します。
リスト : 因子の処理
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
)
| Number(n) => (get_token(s); Num(n))
| Quit => raise Calc_exit
| IF => (get_token(s); make_sel(s))
| Oper(NOT) => (get_token(s); Op1(NOT, factor(s)))
・・・ 省略 ・・・
if の処理は関数 make_sel で行います。NOT は Op1 を生成して返すだけです。
次は if 式を組み立てる関数 make_sel を作ります。
リスト : if の処理
and make_sel(s) =
let val test_form = expression(s) in
case !tokenBuff of
THEN => (
get_token(s);
let val then_form = expression(s) in
case !tokenBuff of
ELSE => (
get_token(s);
let val else_form = expression(s) in
case !tokenBuff of
END => (get_token(s);
Sel(test_form, then_form, else_form))
| _ => raise Syntax_error("end expected")
end
)
| END => (get_token(s);
Sel(test_form, then_form, Num(Integer(0))))
| _ => raise Syntax_error("else or end expected")
end
)
| _ => raise Syntax_error("then expected")
end
val make_sel = fn : instream -> expr
最初に expression を呼び出して、テストフォームを読み込みます。次に、トークンが THEN であることを確認し、 expression で then 節を読み込みます。トークンが ELSE の場合、同様に else 節を読み込みます。トークンが END であることを確認したら Sel を生成して返します。END でない場合はエラーを送出します。else 節がない場合は else 節の代わりに Num(integer(0)) を Sel に格納して返します。
次は式の評価を行う関数 eval_expr を修正します。
リスト : 式の評価
fun isTrue(Float(v)) = Real.!=(v, 0.0)
| isTrue(Integer(v)) = v <> 0
fun eval_comp(op1, op2, v, w) =
let val vt = Integer(1)
val vf = Integer(0) in
case (v, w) of
(Integer(n), Integer(m)) => if op1(n, m) then vt else vf
| (Integer(n), Float(m)) => if op2(Real.fromLargeInt(n), m) then vt else vf
| (Float(n), Integer(m)) => if op2(n, Real.fromLargeInt(m)) then vt else vf
| (Float(n), Float(m)) => if op2(n, m) then vt else vf
end
fun eval_expr(Num(n), _) = n
・・・ 省略 ・・・
| 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)
| 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)
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 Integer(0) else Integer(1)
| _ => 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)
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)
・・・ 省略 ・・・
val isTrue = fn : value -> bool val eval_comp = fn : (IntInf.int * IntInf.int -> bool) * (real * real -> bool) * value * value -> value val eval_expr = fn : expr -> value
関数 isTrue は値 v が 0 または 0.0 でなければ true を返します。比較演算子の処理は関数 eval_comp で行います。第 1 引数が整数同士の比較、第 2 引数が実数同士の比較を行う関数です。SML/NJ の場合、演算子 = と <> で実数を比較することはできません。かわりに Real.== と Real.!= を使います。
NOT の処理は簡単です。expr1 を評価した値 v を isTrue でチェックし、真であれば Integer(0) を、偽であれば Integer(1) を返します。短絡演算子の処理 Ops も簡単です。最初に expr1 を eval_expr で評価して、結果を変数 v にセットします。 次に、isTrue で v が真かチェックします。AND の場合、v が真であれば expr2 を評価し、その結果を返します。偽であれば expr2 を評価せずに v を返します。OR の場合、v が真であれば expr2 を評価しないで v を返します。偽の場合は expr2 を評価してその結果を返します。
if 文の処理 Sel も簡単です。最初にテストフォーム expr_c を eval_expr で評価し、その返り値を isTrue でチェックします。真であれば then 節 (expr_t) を、偽であれば else 節 (expr_e) を eval_expr で評価するだけです。
さて、電卓プログラムで if 式が使えるようになると、関数の再帰呼び出しが可能になります。ところが、前回作成したプログラムでは、関数の再帰呼び出しに対応していません。たとえば、階乗を求める関数は次のようになります。
リスト : 階乗の計算
def fact(n)
if n == 0 then 1 else n * fact(n - 1) end
end
電卓プログラムは func_table に登録されている識別子を関数と判断します。def 文 は式を構文木に変換する expression を実行したあとに fact を func_table に登録するので、expression を実行する段階では、fact を関数ではなく変数として認識してしまいます。これでは関数の再帰呼び出しができません。そこで、expression を実行する前に、func_table に関数を登録し、expression を評価したあと値を書き換えることにします。このため、UF の定義を expr list option ref * expr option ref に変更します。
関数 toplevel の修正は次のようになります。
リスト : 関数定義の修正
fun toplevel() = (
print "Calc> ";
flushOut(stdOut);
get_token(stdIn);
case !tokenBuff of
DEF => (
get_token(stdIn);
case !tokenBuff of
Ident(name) => (
get_token(stdIn);
let
val (cell as UF(a, b)) = UF(ref NONE, ref NONE)
in
func_table := (name, cell) :: (!func_table);
a := SOME (get_parameter(stdIn));
b := SOME (expression(stdIn));
case !tokenBuff of
END => print (name ^ "\n")
| _ => raise Syntax_error("end expected")
end
)
| _ => raise Syntax_error("ivalid def form")
)
・・・ 省略 ・・・
)
UF(ref NONE, ref NONE) を生成し、それを name といっしょにタプルに格納して func_table にセットします。次に、get_parameter で仮引数を取得して UF にセットし、それから expression で本体を取得して UF にセットします。あとは関数 factor と eval_expr で、UF を操作するとき option ref からデータを取り出すように修正するだけです。
それでは簡単な実行例を示します。
Calc> not 0; 1 Calc> not 0.0; 1 Calc> not 1; 0 Calc> not 1.1; 0 Calc> ! 0; 1 Calc> ! 1; 0 Calc> 0 and 0; 0 Calc> 1 and 0; 0 Calc> 1 and 2; 2 Calc> 0 or 0; 0 Calc> 2 or 0; 2 Calc> 0 or 3; 3 Calc> 2 == 2; 1 Calc> 2 != 2; 0 Calc> 1 < 2; 1 Calc> 1 <= 2; 1 Calc> 2 <= 2; 1 Calc> 1 > 2; 0 Calc> 1 >= 2; 0 Calc> 2 >= 2; 1
論理演算子と比較演算子は正常に動作しているようです。次は論理演算子と比較演算子を組み合わせてみましょう。
Calc> not 1 or not 0; 1 Calc> not 1 or not 1; 0 Calc> not 0 or not 1; 1 Calc> not 0 and not 0; 1 Calc> not 0 and not 1; 0 Calc> 1 < 2 and 2 < 3; 1 Calc> 1 > 2 and 2 < 3; 0 Calc> 1 < 2 and 2 > 3; 0 Calc> 1 < 2 or 2 < 3; 1 Calc> 1 > 2 or 2 < 3; 1 Calc> 1 > 2 or 2 > 3; 0
これも正常に動作しているようです。次は if 式を試してみましょう。
Calc> if 1 < 2 then 10 else -10 end; 10 Calc> if 1 > 2 then 10 else -10 end; ~10 Calc> if 1 > 2 then 10 end; 0 Calc> def abs(n) if n > 0 then n else - n end end abs Calc> abs(10); 10 Calc> abs(-10); 10 Calc> abs(11 - 10); 1 Calc> abs(10 - 11); 1
正常に動作していますね。条件分岐があると、再帰呼び出しで繰り返しを実現することができます。階乗を求める関数 fact とフィボナッチ数列を求める関数 fibo は次のようになります。
Calc> def fact(n) if n == 0 then 1 else n * fact(n - 1) end end fact Calc> fact(9); 362880 Calc> fact(10); 3628800 Calc> fact(20); 2432902008176640000 Calc> def fibo(n) if n == 0 or n == 1 then n else fibo(n - 1) + fibo(n - 2) end end fibo Calc> fibo(6); 8 Calc> fibo(7); 13 Calc> fibo(8); 21 Calc> fibo(9); 34 Calc> fibo(10); 55 Calc> fibo(11); 89
関数 fibo は二重再帰ですが、累積変数を使って末尾再帰に変換することができます。
Calc> def fiboi(n, a, b) if n == 0 then a else fiboi(n - 1, b, a + b) end end fiboi Calc> fiboi(6, 0, 1); 8 Calc> fiboi(11, 0, 1); 89 Calc> fiboi(30, 0, 1); 832040 Calc> fiboi(40, 0, 1); 102334155
電卓プログラムは末尾再帰最適化を行わないので繰り返しに変換することはできませんが、二重再帰よりも高速にフィボナッチ数列を求めることができます。
今回はここまでです。次回は複数の式を順番に実行する begin 式と、式を繰り返し実行する while 式を追加してみましょう。
(*
* calc.sml : 電卓プログラム
*
* Copyright (C) 2012-2021 Makoto Hiroi
*
* (1) 四則演算の実装
* (2) 変数と組み込み関数の追加
* (3) ユーザー定義関数の追加
* (4) 論理演算子, 比較演算子, if の追加
*
*)
open TextIO
(* 例外 *)
exception Calc_exit
exception Syntax_error of string
exception Calc_run_error of string
(* 値の定義 *)
datatype value = Integer of IntInf.int | Float of real
(* 演算子の定義 *)
datatype operator = Add | Sub | Mul | Quo | Assign
| NOT | AND | OR
| EQ | NE | LT | GT | LE | GE
(* トークンの定義 *)
datatype token = Number of value (* 数 *)
| Ident of string (* 識別子 *)
| Oper of operator (* 演算子 *)
| Lpar | Rpar (* (, ) *)
| Semic (* ; *)
| Comma (* , *)
| DEF (* def *)
| END (* end *)
| IF (* if *)
| THEN (* then *)
| ELSE (* else *)
| Quit (* 終了 *)
| Others (* その他 *)
(* 式の定義 *)
datatype func = F1 of value -> value
| F2 of (value * value) -> value
| UF of expr list option ref * expr option ref
and expr = Num 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 *)
| App of func * expr list (* 関数の適用 *)
(* グローバル変数を格納する配列 *)
val global_env : (string * value ref) list ref = ref []
(* 探索 *)
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)
(* value を real に変換 *)
fun toReal(Float(v)) = v
| toReal(Integer(v)) = Real.fromLargeInt(v)
(* Math モジュールの関数を呼び出す *)
fun call_real_func1 f v = Float(f(toReal v))
fun call_real_func2 f (v, w) = Float(f(toReal v, toReal w))
(* 関数を格納する配列 *)
val func_table= ref [("sqrt", F1 (call_real_func1 Math.sqrt)),
("sin", F1 (call_real_func1 Math.sin)),
("cos", F1 (call_real_func1 Math.cos)),
("tan", F1 (call_real_func1 Math.tan)),
("asin", F1 (call_real_func1 Math.asin)),
("acos", F1 (call_real_func1 Math.acos)),
("atan", F1 (call_real_func1 Math.atan)),
("atan2", F2 (call_real_func2 Math.atan2)),
("exp", F1 (call_real_func1 Math.exp)),
("pow", F2 (call_real_func2 Math.pow)),
("ln", F1 (call_real_func1 Math.ln)),
("log10", F1 (call_real_func1 Math.log10)),
("sinh", F1 (call_real_func1 Math.sinh)),
("cosh", F1 (call_real_func1 Math.cosh)),
("tanh", F1 (call_real_func1 Math.tanh))]
(* 関数の探索 *)
fun lookup_function(name) =
let
fun iter([]) = NONE
| iter((n, f)::xs) =
if n = name then SOME f else iter(xs)
in
iter(!func_table)
end
(* 切り出したトークンを格納するバッファ *)
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 := Number(Float(valOf(Real.fromString(implode(rev (!buff))))))
) else
tokenBuff := Number(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
| _ => id
)
end
else (
input1(s); (* s から c を取り除く *)
tokenBuff := (case c of
#"+" => Oper(Add)
| #"-" => Oper(Sub)
| #"*" => Oper(Mul)
| #"/" => Oper(Quo)
| #"=" => (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))))
| _ => 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
)
| Number(n) => (get_token(s); Num(n))
| Quit => raise Calc_exit
| IF => (get_token(s); make_sel(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 lookup_function(name) of
NONE => Var(name)
| SOME f => let val args = get_argument(s) in
case f of
F1 _ => if length(args) < 1
then raise Syntax_error("not enough args")
else ()
| F2 _ => if length(args) < 2
then raise Syntax_error("not enough args")
else ()
| UF(ref (SOME ps), _) =>
if length(args) < length(ps)
then raise Syntax_error("not enough args")
else ();
App(f, args)
end
)
| _ => 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
app (fn x => case x of
Var(_) => ()
| _ => raise Syntax_error("bad parameter"))
parm;
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 = expression(s) in
case !tokenBuff of
ELSE => (
get_token(s);
let val else_form = expression(s) in
case !tokenBuff of
END => (get_token(s);
Sel(test_form, then_form, else_form))
| _ => raise Syntax_error("end expected")
end
)
| END => (get_token(s);
Sel(test_form, then_form, Num(Integer(0))))
| _ => raise Syntax_error("else or end expected")
end
)
| _ => raise Syntax_error("then expected")
end
(* 変数束縛 *)
fun add_binding([], _, a) = a
| add_binding(_, [], _) = raise Calc_run_error("not enough argument")
| add_binding(Var(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
(* 演算子の評価 *)
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))
(* 比較演算子の評価 *)
fun eval_comp(op1, op2, v, w) =
let val vt = Integer(1)
val vf = Integer(0) in
case (v, w) of
(Integer(n), Integer(m)) => if op1(n, m) then vt else vf
| (Integer(n), Float(m)) => if op2(Real.fromLargeInt(n), m) then vt else vf
| (Float(n), Integer(m)) => if op2(n, Real.fromLargeInt(m)) then vt else vf
| (Float(n), Float(m)) => if op2(n, m) then vt else vf
end
(* 式の評価 *)
fun eval_expr(Num(n), _) = n
| eval_expr(Var(name), env) = (
case get_var(name, env) of
NONE => raise Calc_run_error("unbound variable")
| 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)
| 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)
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 Integer(0) else Integer(1)
| _ => 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)
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(f, args), env) =
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))
| UF(ref (SOME parm), ref (SOME body)) =>
eval_expr(body, add_binding(parm, vs, []))
end
(* 実行 *)
fun toplevel() = (
print "Calc> ";
flushOut(stdOut);
get_token(stdIn);
case !tokenBuff of
DEF => (
get_token(stdIn);
case !tokenBuff of
Ident(name) => (
get_token(stdIn);
let
val (cell as UF(a, b)) = UF(ref NONE, ref NONE)
in
func_table := (name, cell) :: (!func_table);
a := SOME (get_parameter(stdIn));
b := SOME (expression(stdIn));
case !tokenBuff of
END => print (name ^ "\n")
| _ => raise Syntax_error("end expected")
end
)
| _ => raise Syntax_error("ivalid def form")
)
| _ => let val result = expression(stdIn) in
case !tokenBuff of
Semic => ()
| Quit => raise Calc_exit
| _ => raise Syntax_error("unexpected token");
case eval_expr(result, []) of
Integer(n) => print(IntInf.toString(n) ^ "\n")
| Float(n) => print(Real.toString(n) ^ "\n")
end
)
fun calc() =
while true do
toplevel() handle
Syntax_error(mes) => (inputLine(stdIn); print("ERROR: " ^ mes ^ "\n"))
| Calc_run_error(mes) => (inputLine(stdIn); print("ERROR: " ^ mes ^ "\n"))
| Div => (inputLine(stdIn); print("ERROR: divide by zero\n"))
| err => raise err