Permalink
Browse files

6-3. 変数の型付けを含む型検査 [2010/09/26 追加, 2010/09/29修正]

  • Loading branch information...
1 parent cb5ca6e commit e915a581e73a42e078353da83a671342089732b7 @tomykaira committed Mar 19, 2012
Showing with 21 additions and 13 deletions.
  1. +5 −4 eval.ml
  2. +1 −0 syntax.ml
  3. +15 −9 test.ml
View
@@ -72,20 +72,21 @@ let rec eval e env =
| _ -> failwith "list value expected")
| _ -> failwith "unknown expression"
-let rec tcheck e = match e with
+let rec tcheck tenv e = match e with
| IntLit _ -> TInt
| BoolLit _ -> TBool
+| Var x -> lookup x tenv
| If (pred, then_e, else_e) ->
- (match (tcheck pred, tcheck then_e, tcheck else_e) with
+ (match (tcheck tenv pred, tcheck tenv then_e, tcheck tenv else_e) with
| TBool, then_t, else_t ->
if then_t = else_t then then_t else failwith "type error in IF"
| _ -> failwith "type error in If")
| Plus (e1, e2) ->
- (match (tcheck e1, tcheck e2) with
+ (match (tcheck tenv e1, tcheck tenv e2) with
| (TInt, TInt) -> TInt
| _ -> failwith "type error in Plus")
| Eq (e1, e2) ->
- if tcheck e1 = tcheck e2 then TBool else failwith "type error in Eq"
+ if tcheck tenv e1 = tcheck tenv e2 then TBool else failwith "type error in Eq"
| _ -> failwith "unknown expression"
let new_eval e = eval e emptyenv
View
@@ -42,3 +42,4 @@ and
(* 「型」をあらわす型の定義 *)
type ty = TInt | TBool
+type tyenv = (string * ty) list
View
24 test.ml
@@ -17,8 +17,8 @@ let _ptv title str v =
let _pte title str exp =
_t ("pretty print exp - " ^ title) str (Pretty_printer.string_of_exp exp) id
-let _tt title exp_type exp =
- _t ("Type check - " ^ title) exp_type (tcheck exp) Pretty_printer.string_of_type
+let _tt title exp_type exp tenv =
+ _t ("Type check - " ^ title) exp_type (tcheck tenv exp) Pretty_printer.string_of_type
let _ =
((_te "四則演算" (IntVal(4*1*10+5)) (Plus (Times (Times(IntLit 4, IntLit 1), IntLit 10), IntLit 5)));
@@ -101,13 +101,19 @@ let _ = (
)
let _ = (
- (_tt "int" TInt (IntLit 10));
- (_tt "bool" TBool (BoolLit true));
- (_tt "plus" TInt (Plus (IntLit 10, IntLit 20)));
- (_tt "if - int" TInt (If (BoolLit true, IntLit 10, IntLit 20)));
- (_tt "if - bool" TBool (If (BoolLit true, BoolLit true, BoolLit false)));
- (_tt "eq - int" TBool (Eq (IntLit 10, IntLit 3)));
- (_tt "eq - bool" TBool (Eq (BoolLit true, BoolLit false)));
+ (_tt "int" TInt (IntLit 10) []);
+ (_tt "bool" TBool (BoolLit true) []);
+ (_tt "plus" TInt (Plus (IntLit 10, IntLit 20)) []);
+ (_tt "if - int" TInt (If (BoolLit true, IntLit 10, IntLit 20)) []);
+ (_tt "if - bool" TBool (If (BoolLit true, BoolLit true, BoolLit false)) []);
+ (_tt "eq - int" TBool (Eq (IntLit 10, IntLit 3)) []);
+ (_tt "eq - bool" TBool (Eq (BoolLit true, BoolLit false)) []);
+ let e1 = If(BoolLit(true), Var("x"), IntLit(100)) in
+ ((_tt "var" TInt e1 [("x",TInt);("y",TInt)])
+ (* (_tt "var" TBool e1 [("x",TBool);("y",TInt)]); : TBool と TIntで型エラー *)
+ (* (_tt "var" TInt e1 [("z",TInt);("y",TInt)])) : x が未定義でエラー *)
+ );
+ (* (_tt "var" If(Var("x"), Var("x"), IntLit(100)) [("x",TBool)]) : どんな環境でもエラー *)
)
let _ = eval (LetRec ("f", "x", If(Eq(Var "x", IntLit 0), IntLit 1,

0 comments on commit e915a58

Please sign in to comment.