前回はクロージャを使って「連結リスト」を実装しました。今回は関数型電卓プログラムに新しいデータ型として「連結リスト」を追加してみましょう。
最初に連結リストを表すデータ型を定義します。次のリストを見てください。
リスト : データ型の定義
datatype value = Nil (* 空を表す値 *)
| Integer of IntInf.int (* 整数 *)
| Float of real (* 実数 *)
| Func of func (* 関数 *)
| Pair of value ref * value ref (* 連結リスト *)
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 *)
| Lst of expr list (* リストの生成 *)
| App of expr * expr list (* 関数の適用 *)
value に Pair of value ref * value ref を追加します。最初の要素が CAR 部を、次の要素が CDR 部を表します。car, cdr, cons, setCar, setCdr は関数として定義します。それから、連結リストを生成する構文としてリスト生成式を定義します。リスト生成式の構文は次のようになります。
list(引数1, ..., 引数n)
list は複数の引数を評価して、その結果を連結リストに格納して返します。Lisp / Scheme の関数 list と同じ働きをします。電卓プログラムの関数には可変個引数の機能がないので、構文で list を用意しました。トークンを表す token に LIST を追加し、expr には連結リストを生成する Lst of expr list を追加します。
次は連結リストを表示するため関数 print_value を修正します。
リスト : 値の表示
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)
| Pair(_) => (print "("; print_pair(x); print ")"; Nil)
and print_pair(Pair(ref x, ref y)) = (
case x of
Nil => (print "()"; Nil)
| _ => print_value x;
case y of
Nil => Nil
| Pair(_, _) => (print " "; print_pair y)
| _ => (print " . "; print_value y)
)
| print_pair x = print_value x
連結リストの表示は、前回と同じく Lisp / Scheme の表記法に従います。print_value の引数 x が Pair の場合、"(" を表示して関数 print_pair を呼び出して連結リストを表示し、最後に ")" で囲みます。
print_pair は CAR 部の値 x が Nil ならば "()" を表示し、そうでなければ print_value で x を表示します。CDR 部の y が Nil ならば Nil を返します。Pair ならば空白を表示して print_pair を再帰呼び出しします。これで次の要素を表示することができます。それ以外の場合、連結リストは Nil 以外のデータで終端されているので、" . " を表示してから print_value で y を表示します。
次は連結リストの基本関数を定義します。
リスト : 連結リストの操作関数
fun isPair(Pair(_, _)) = True
| isPair(_) = 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")
(* 大域変数 *)
val global_env = ref [("sqrt", ref (Func(F1(call_real_func1 Math.sqrt)))),
・・・ 省略 ・・・
("isPair", ref (Func(F1 isPair))),
("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))),
("nil", ref Nil)]
関数 isPair は引数が Pair であれば真 (1) を返します。関数 car は Pair の第 1 要素を、関数 cdr は第 2 要素を返します。cons は Pair を生成して返します。setCar は Pair の第 1 要素の値を z に書き換えます。setCdr は第 2 要素の値を z に書き換えます。
次は連結リストを生成するリスト生成式の処理を追加します。構文解析は次のようになります。
リスト : リスト生成式の追加
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)
| LIST => (get_token s; make_list 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))
・・・ 省略 ・・・
and make_list s =
case !tokenBuff of
Lpar => (get_token s;
let
val args = get_comma_list(s, [])
in
case !tokenBuff of
Rpar => (get_token s; Lst(args))
| _ => raise Syntax_error("')' expected")
end)
| _ => raise Syntax_error("'(' expected")
関数 factor でトークンが LIST であればリストを生成する関数 make_list を呼び出します。make_list の処理は簡単で、list の後のカッコ内の式を get_comma_list で取り出し、それを Lst に格納して返すだけです。
連結リストを生成する Lst の処理も簡単です。関数 eval_expr に Lst の処理を追加します。
リスト : 連結リストの生成
| eval_expr(Lst(args), env) =
let
fun iter [] = Nil
| iter(x::xs) = Pair(ref (eval_expr(x, env)), ref (iter(xs)))
in
iter args
end
局所関数 iter で args から式を取り出して eval_expr で評価し、その結果を Pair に格納して返します。
あとの修正は簡単なので説明は割愛します。詳細は プログラムリスト１ をお読みください。
それでは簡単な実行例を示します。
Calc> a = cons(1, 2); (1 . 2) Calc> isPair(a); 1 Calc> car(a); 1 Calc> cdr(a); 2 Calc> setCar(a, 10); 10 Calc> a; (10 . 2) Calc> setCdr(a, 20); 20 Calc> a; (10 . 20) Calc> b = list(1, 2, 3, 4, 5); (1 2 3 4 5)
基本関数と list は正常に動作していますね。
前回作成した連結リストライブラリは、car, cdr, cons, setCar, setCdr, printlist の定義を削除し、pair の定義を isPari に、printlist を print に書き換えるだけで、そのまま利用することができます。詳細は プログラムリスト２ をお読みください。
簡単な実行例を示します。
Calc> a = iota(1, 8); (1 2 3 4 5 6 7 8) Calc> b = iota(11, 18); (11 12 13 14 15 16 17 18) Calc> c = zip(a, b); ((1 . 11) (2 . 12) (3 . 13) (4 . 14) (5 . 15) (6 . 16) (7 . 17) (8 . 18)) Calc> flatten(c); (1 11 2 12 3 13 4 14 5 15 6 16 7 17 8 18) Calc> map(car, c); (1 2 3 4 5 6 7 8) Calc> map(cdr, c); (11 12 13 14 15 16 17 18) Calc> append(a, b); (1 2 3 4 5 6 7 8 11 12 13 14 15 16 17 18) Calc> d = list(5, 6, 4, 7, 3, 8, 2, 9, 1); (5 6 4 7 3 8 2 9 1) Calc> mergeSort(d, 9, fn(x, y) x < y end); (1 2 3 4 5 6 7 8 9) Calc> mergeSort(d, 9, fn(x, y) x > y end); (9 8 7 6 5 4 3 2 1) Calc> permutation(3, list(1,2,3)); (1 2 3) (1 3 2) (2 1 3) (2 3 1) (3 1 2) (3 2 1) 0 Calc> nreverse(a); (8 7 6 5 4 3 2 1) Calc> a; (1)
正常に動作していますね。興味のある方はいろいろ試してみてください。
今回はここまでです。次回は関数型電卓プログラムに新しいデータ型「ベクタ (vector)」を追加してみましょう。
(*
* calc.sml : 電卓プログラム
*
* Copyright (C) 2012-2021 Makoto Hiroi
*
* (1) 四則演算の実装
* (2) 変数と組み込み関数の追加
* (3) ユーザー定義関数の追加
* (4) 論理演算子, 比較演算子, if の追加
* (5) begin, while の追加
* (6) 関数を値とし、匿名関数 (クロージャ) と let を追加
* (7) 空リスト Nil と型述語 (isNil, isInteger, isFloat, isFunction) の追加
* (8) 連結リストの実装
*
*)
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 (* 関数 *)
| Pair of value ref * value ref (* 連結リスト *)
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
| Lst of expr list (* リストの生成 *)
| 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 *)
| LIST (* list *)
| 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)
| Pair(_) => (print "("; print_pair(x); print ")"; Nil)
and print_pair(Pair(ref x, ref y)) = (
case x of
Nil => (print "()"; Nil)
| _ => print_value x;
case y of
Nil => Nil
| Pair(_, _) => (print " "; print_pair y)
| _ => (print " . "; print_value y)
)
| print_pair 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 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")
(* 大域変数 *)
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))),
("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))),
("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))),
("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
| "list" => LIST
| _ => 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)
| LIST => (get_token s; make_list 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
and make_list s =
case !tokenBuff of
Lpar => (get_token s;
let
val args = get_comma_list(s, [])
in
case !tokenBuff of
Rpar => (get_token s; Lst(args))
| _ => raise Syntax_error("')' expected")
end)
| _ => raise Syntax_error("'(' expected")
(* 変数束縛 *)
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
| eval_expr(Lst(args), env) =
let
fun iter [] = Nil
| iter(x::xs) = Pair(ref (eval_expr(x, env)), ref (iter(xs)))
in
iter args
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)
)
)
リスト : 連結リストライブラリ
def pair(xs) isPair(xs) end
def null(xs) isNil(xs) end
def nth(xs, n)
if null(xs) then
nil
else
if n == 0 then
car(xs)
else
nth(cdr(xs), n - 1)
end
end
end
def length(xs)
let rec
iter = fn(xs, n)
if null(xs) then
n
else
iter(cdr(xs), n + 1)
end
end
in
iter(xs, 0)
end
end
def reverse(xs)
let rec
iter = fn(ys, a)
if null(ys) then
a
else
iter(cdr(ys), cons(car(ys), a))
end
end
in
iter(xs, nil)
end
end
def member(x, ls)
if null(ls) then
nil
else
if car(ls) == x then
ls
else
member(x, cdr(ls))
end
end
end
def append(xs, ys)
if null(xs) then
ys
else
cons(car(xs), append(cdr(xs), ys))
end
end
def remove(x, ls)
if null(ls) then
nil
else
if x == car(ls) then
remove(x, cdr(ls))
else
cons(car(ls), remove(x, cdr(ls)))
end
end
end
def map(f, xs)
if null(xs) then
nil
else
cons(f(car(xs)), map(f, cdr(xs)))
end
end
def filter(f, xs)
if null(xs) then
nil
else
if f(car(xs)) then
cons(car(xs), filter(f, cdr(xs)))
else
filter(f, cdr(xs))
end
end
end
def foldl(f, a, xs)
if null(xs) then
a
else
foldl(f, f(car(xs), a), cdr(xs))
end
end
def foldr(f, a, xs)
if null(xs) then
a
else
f(car(xs), foldr(f, a, cdr(xs)))
end
end
def foreach(f, ls)
if pair(ls) then
f(car(ls)),
foreach(f, cdr(ls))
end
end
def zip(xs, ys)
if null(xs) or null(ys) then
nil
else
cons(cons(car(xs), car(ys)), zip(cdr(xs), cdr(ys)))
end
end
def flatten(ls)
if null(ls) then
nil
else
if pair(ls) then
append(flatten(car(ls)), flatten(cdr(ls)))
else
cons(ls, nil)
end
end
end
def take(xs, n)
if n == 0 or null(xs) then
nil
else
cons(car(xs), take(cdr(xs), n - 1))
end
end
def drop(xs, n)
if n == 0 or null(xs) then
xs
else
drop(cdr(xs), n - 1)
end
end
def makelist(n, x)
let rec
iter = fn(n, a)
if n == 0 then
a
else
iter(n - 1, cons(x, a))
end
end
in
iter(n, nil)
end
end
def iota(n, m)
let rec
iter = fn(m, a)
if m < n then
a
else
iter(m - 1, cons(m, a))
end
end
in
iter(m, nil)
end
end
def tabulate(f, n, m)
let rec
iter = fn(m, a)
if m < n then
a
else
iter(m - 1, cons(f(m), a))
end
end
in
iter(m, nil)
end
end
def equal(xs, ys)
if pair(xs) and pair(ys) then
if equal(car(xs), car(ys)) then
equal(cdr(xs), cdr(ys))
else
0
end
else
if (isInteger(xs) and isInteger(ys)) or
(isFloat(xs) and isFloat(ys)) then
xs == ys
else
null(xs) and null(ys)
end
end
end
def permutation(n, xs)
let rec
perm = fn(m, ys, a)
if m == n then
printlist(reverse(a)), putc(10)
else
foreach(fn(x)
if not(member(x, a)) then
perm(m + 1, remove(x, ys), cons(x, a))
end
end,
ys)
end
end
in
perm(0, xs, nil)
end
end
def merge(xs, ys, pred)
if null(xs) or null(ys) then
if null(xs) then ys else xs end
else
if pred(car(xs), car(ys)) then
cons(car(xs), merge(cdr(xs), ys, pred))
else
cons(car(ys), merge(xs, cdr(ys), pred))
end
end
end
def mergeSort(xs, n, pred)
if n == 1 then
cons(car(xs), nil)
else
let
m = n / 2
in
merge(mergeSort(xs, m, pred),
mergeSort(drop(xs, m), n - m, pred),
pred)
end
end
end
def listSet(xs, n, v)
if null(xs) then
nil
else
if n == 0 then
setCar(xs, v)
else
listSet(cdr(xs), n - 1, v)
end
end
end
def nreverse(xs)
let rec
iter = fn(xs, a)
if null(xs) then
a
else
let ys = cdr(xs) in
setCdr(xs, a),
iter(ys, xs)
end
end
end
in
iter(xs, nil)
end
end