1. Shawn Hyam
  2. blub

Commits

shawnh  committed d667551

Tried to clean up the typechecking code a bit, and prune out some of the old crufty stuff.

  • Participants
  • Parent commits 15c6890
  • Branches default

Comments (0)

Files changed (1)

File blub_typecheck.ml

View file
       printf "Unsupported sval %a\n%!" pp_sval x;
       typevar ()
 
+type tmap = (ast, type_) PMap.t
+
 let tmap_union map1 map2 =
   PMap.foldi PMap.add map1 map2
 ;;
 
-let tcheck globals env (e:ast) : (ast, type_) PMap.t =
-  let rec tcheck (r:env) (e:ast) : (ast, type_) PMap.t =
+
+let tcheck globals env (e:ast) : tmap =
+  let rec tcheck (r:env) (e:ast) : type_ * tmap =
     (* printf "tcheck: %a\n%!" pp_ast e; *)
-    match e with
-	A_lit l -> PMap.add e (type_of_sval l) PMap.empty
+    let type_, tmap = match e with
+	A_lit l -> (type_of_sval l, PMap.empty)
       | A_ref var -> begin
 	  try
 	    let t = instantiate (PMap.find var r) in
-	    PMap.add e t PMap.empty
+	    (t, PMap.empty)
 	  with Not_found ->
 	    printf "Variable %a not found in environment\n%!" pp_var var;
 	    raise (Tcheck_failed "")
 	end
 
       | A_cnd (e1, e2, e3) ->
-	  let t2 = tcheck r e2 in
-	  let t3 = tcheck r e3 in
-	  let t1 = tcheck r e1 in
-	  let tmap = tmap_union t1 t2 in
-	  let tmap = tmap_union tmap t3 in
+	  let t2, tmap2 = tcheck r e2 in
+	  let t3, tmap3 = tcheck r e3 in
+	  let t1, tmap1 = tcheck r e1 in
+	  let tmap = tmap_union tmap1 (tmap_union tmap2 tmap3) in
 
-	  unify Bool (PMap.find e1 tmap);
-	  unify (PMap.find e2 tmap) (PMap.find e3 tmap);
-	  PMap.add e (PMap.find e2 tmap) tmap
+	  unify Bool t1;
+	  unify t2 t3;
+	  (t2, tmap)
 	    
       | A_abs (params, false, body) ->
 	  let tparams = Array.map (fun _ -> typevar ()) params in
 	  let var_ts = Array.mapi (fun i ts -> (params.(i), ts)) ts in
 	  let env = Array.fold_left (fun env (var, ts) ->
 				       PMap.add var ts env) r var_ts in
-	  let tmap = tcheck env body in
-	  let function_type = Fun (tparams, PMap.find body tmap) in
-	  PMap.add e function_type tmap
+	  let tret, tmap = tcheck env body in
+	  let function_type = Fun (tparams, tret) in
+	  (function_type, tmap)
 	    
       | A_app (fn, args) -> begin
-	  let tmap = Array.fold_right 
-	    (fun arg acc -> tmap_union (tcheck r arg) acc)
-	    args PMap.empty
-	  in
-	  let tmap = tmap_union (tcheck r fn) tmap in
-	  let fn_type = PMap.find fn tmap in
+	  let arg_typeinfo = Array.map (tcheck r) args in
+	  let fn_type, tmap = tcheck r fn in
 
-	  match fn_type with
+	  let () = match fn_type with
 	      Fun (tparams, tret) -> 
 		assert ((Array.length tparams) = (Array.length args));
 		Array.iteri 
-		  (fun i arg -> 
-		     let arg_type = PMap.find arg tmap in
+		  (fun i (arg_type, _) -> 
 		     unify tparams.(i) arg_type) 
-		  args;
-		PMap.add e tret tmap
+		  arg_typeinfo
 
 	    | t ->
 		printf "App on unexpected type: %a" pp_type t;
 		raise (Tcheck_failed "")
+	  in
+
+	  let tmap = Array.fold_right (fun (_, tmap) acc -> 
+					 tmap_union tmap acc)
+	    arg_typeinfo PMap.empty
+	  in
+	  fn_type, tmap
 	end
 
       | A_seq exprs ->
-	  let tmap = Array.fold_right 
-	    (fun expr tmap ->
-	       tmap_union (tcheck r expr) tmap)
-	    exprs PMap.empty
+	  let expr_typeinfo = Array.map (tcheck r) exprs in
+	  let tmap = Array.fold_right
+	    (fun (_, tmap) acc -> tmap_union tmap acc)
+	    expr_typeinfo PMap.empty
 	  in
-	  let last_expr = exprs.(Array.length exprs - 1) in
-	  PMap.add e (PMap.find last_expr tmap) tmap
+	  let last_expr_t, _ = expr_typeinfo.(Array.length exprs - 1) in
+	  last_expr_t, tmap
 
 	    (* very specialized support for a single let-binding of a
 	       function with one parameter *)
           let tf = Fun ( [| t1 |], t2 ) in
           let r' = PMap.add f (tf, TypeVarSet.empty) r in
           let r'' = PMap.add x (t1, TypeVarSet.empty) r' in
-          let tmap = tcheck r'' e1 in
-          let te = PMap.find e1 tmap in
+          let te, tmap = tcheck r'' e1 in
           unify te t2;
           let r = PMap.add f (schema tf r) r in
           
           (* Let part *)
-          let tmap' = tcheck r e2 in
-          let tmap = PMap.add t tf tmap in
-          PMap.add e (PMap.find e2 tmap') (tmap_union tmap tmap')
+          let t_e2, tmap' = tcheck r e2 in
+          let tmap = tmap_union tmap tmap' in
+	  t_e2, tmap
 
-(*
-      | A_let ( [| (var, (A_abs (params, false, body) as t)) |], e2, LT_letrec) ->
-	  let tparams = Array.map (fun _ -> typevar ()) params in
-	  let tret = typevar () in
-	  let tf = Fun (tparams, tret) in
-
-	  Hashtbl.add typedict t tf;
-
-	  let var_ts = Array.mapi 
-	    (fun i tp -> (params.(i), (tp, TypeVarSet.empty))) tparams in
-	  
-	  let r' = Array.fold_left 
-	    (fun env (var, ts) -> PMap.add var ts env) r var_ts
-	  in
-	  let r'' = PMap.add var (tf, TypeVarSet.empty) r' in
-	  let tbody = tcheck r'' body in
-	  unify tbody tret;
-
-	  let env = PMap.add var (schema tf r) r in
-	  tcheck env e2
-*)
 
       | A_set (var, expr) ->
-	  let tmap = tcheck r expr in
-	  PMap.add e (PMap.find expr tmap) tmap
+	  let t, tmap = tcheck r expr in
+	  t, tmap
 
       | A_let _ | A_set _ | A_callcc _ | A_abs _ ->
 	  printf "sorry, Shawn is lazy and hasn't got this stuff working again yet!!";
 	  raise (Tcheck_failed "")
-(*
-      | Let ((var, _), (Abs (params, body) as f), e2) -> (
-	  let tparams = Array.map (fun _ -> typevar ()) params in
-	  let tret = typevar () in
-	  let tf = Fun (tparams, tret) in
 
-	  Hashtbl.add typedict f tf;
-
-	  let var_ts = Array.mapi 
-	    (fun i tp -> (params.(i), (tp, TypeVarSet.empty))) tparams in
-	  
-	  let r' = Array.fold_left 
-	    (fun env (var, ts) -> PMap.add var ts env) r var_ts
-	  in
-	  let r'' = PMap.add var (tf, TypeVarSet.empty) r' in
-	  let tbody = tcheck r'' body in
-	  unify tbody tret;
-
-	  printf "HA HA HA   %s   %!" (string_of_type tf);
-	  (* NOTE the original does this to the original env r, not r'' *)
-	  let env = PMap.add var (schema tf r) r in
-	  tcheck env e2
-	)
-
-      | Let ((var, _), e1, e2) ->
-	  tcheck (vardeclcheck var e1 r) e2
-*)
-
-
-  and vardeclcheck var e r =
-    let tmap = tcheck r e in
-    let typ = PMap.find e tmap in
-    PMap.add var (schema typ r) r
+    in
+    type_, PMap.add e type_ tmap
   in
 
   (* Add the types of everything in the environment *)
     globals env
   in
 
-  tcheck env e 
+  let _, tmap = tcheck env e in
+  tmap