Skip to content

Commit

Permalink
move expression-AST converter to type.ml
Browse files Browse the repository at this point in the history
  • Loading branch information
@Simn
Simn committed Jun 25, 2015
1 parent c03db23 commit 51409af
Show file tree
Hide file tree
Showing 2 changed files with 132 additions and 135 deletions.
136 changes: 2 additions & 134 deletions interp.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -209,8 +209,6 @@ let enc_hash_ref = ref (fun h -> assert false)
let enc_array_ref = ref (fun l -> assert false)
let dec_array_ref = ref (fun v -> assert false)
let enc_string_ref = ref (fun s -> assert false)
let make_ast_ref = ref (fun _ -> assert false)
let make_complex_type_ref = ref (fun _ -> assert false)
let encode_tvar_ref = ref (fun _ -> assert false)
let decode_path_ref = ref (fun _ -> assert false)
let decode_import_ref = ref (fun _ -> assert false)
Expand All @@ -228,9 +226,7 @@ let encode_texpr (e:Type.texpr) : value = (!encode_texpr_ref) e
let decode_texpr (v:value) : Type.texpr = (!decode_texpr_ref) v
let encode_clref (c:tclass) : value = (!encode_clref_ref) c
let enc_hash (h:('a,'b) Hashtbl.t) : value = (!enc_hash_ref) h
let make_ast (e:texpr) : Ast.expr = (!make_ast_ref) e
let enc_string (s:string) : value = (!enc_string_ref) s
let make_complex_type (t:Type.t) : Ast.complex_type = (!make_complex_type_ref) t
let encode_tvar (v:tvar) : value = (!encode_tvar_ref) v
let decode_path (v:value) : Ast.type_path = (!decode_path_ref) v
let encode_import (i:Ast.import) : value = (!encode_import_ref) i
Expand Down Expand Up @@ -2398,7 +2394,7 @@ let macro_lib =
VString (Digest.to_hex (Digest.string (Marshal.to_string v [Marshal.Closures])))
);
"to_complex", Fun1 (fun v ->
try encode_complex_type (make_complex_type (decode_type v))
try encode_complex_type (TExprToExpr.convert_type (decode_type v))
with Exit -> VNull
);
"unify", Fun2 (fun t1 t2 ->
Expand Down Expand Up @@ -2634,7 +2630,7 @@ let macro_lib =
);
"get_typed_expr", Fun1 (fun e ->
let e = decode_texpr e in
encode_expr (make_ast e)
encode_expr (TExprToExpr.convert_expr e)
);
"store_typed_expr", Fun1 (fun e ->
let e = try decode_texpr e with Invalid_expr -> error() in
Expand Down Expand Up @@ -4971,137 +4967,9 @@ let rec make_const e =
(* ---------------------------------------------------------------------- *)
(* TEXPR-TO-AST-EXPR *)

open Ast

let tpath p mp pl =
if snd mp = snd p then
CTPath {
tpackage = fst p;
tname = snd p;
tparams = List.map (fun t -> TPType t) pl;
tsub = None;
}
else CTPath {
tpackage = fst mp;
tname = snd mp;
tparams = List.map (fun t -> TPType t) pl;
tsub = Some (snd p);
}

let rec make_type = function
| TMono r ->
(match !r with
| None -> raise Exit
| Some t -> make_type t)
| TEnum (e,pl) ->
tpath e.e_path e.e_module.m_path (List.map make_type pl)
| TInst({cl_kind = KTypeParameter _} as c,pl) ->
tpath ([],snd c.cl_path) ([],snd c.cl_path) (List.map make_type pl)
| TInst (c,pl) ->
tpath c.cl_path c.cl_module.m_path (List.map make_type pl)
| TType (t,pl) as tf ->
(* recurse on type-type *)
if (snd t.t_path).[0] = '#' then make_type (follow tf) else tpath t.t_path t.t_module.m_path (List.map make_type pl)
| TAbstract (a,pl) ->
tpath a.a_path a.a_module.m_path (List.map make_type pl)
| TFun (args,ret) ->
CTFunction (List.map (fun (_,_,t) -> make_type t) args, make_type ret)
| TAnon a ->
begin match !(a.a_status) with
| Statics c -> tpath ([],"Class") ([],"Class") [tpath c.cl_path c.cl_path []]
| EnumStatics e -> tpath ([],"Enum") ([],"Enum") [tpath e.e_path e.e_path []]
| _ ->
CTAnonymous (PMap.foldi (fun _ f acc ->
{
cff_name = f.cf_name;
cff_kind = FVar (mk_ot f.cf_type,None);
cff_pos = f.cf_pos;
cff_doc = f.cf_doc;
cff_meta = f.cf_meta;
cff_access = [];
} :: acc
) a.a_fields [])
end
| (TDynamic t2) as t ->
tpath ([],"Dynamic") ([],"Dynamic") (if t == t_dynamic then [] else [make_type t2])
| TLazy f ->
make_type ((!f)())

and mk_ot t =
match follow t with
| TMono _ -> None
| _ -> (try Some (make_type t) with Exit -> None)

let rec make_ast e =
let full_type_path t =
let mp,p = match t with
| TClassDecl c -> c.cl_module.m_path,c.cl_path
| TEnumDecl en -> en.e_module.m_path,en.e_path
| TAbstractDecl a -> a.a_module.m_path,a.a_path
| TTypeDecl t -> t.t_module.m_path,t.t_path
in
if snd mp = snd p then p else (fst mp) @ [snd mp],snd p
in
let mk_path = expr_of_type_path in
let mk_ident = function
| "`trace" -> Ident "trace"
| n -> Ident n
in
let eopt = function None -> None | Some e -> Some (make_ast e) in
((match e.eexpr with
| TConst c ->
EConst (tconst_to_const c)
| TLocal v -> EConst (mk_ident v.v_name)
| TArray (e1,e2) -> EArray (make_ast e1,make_ast e2)
| TBinop (op,e1,e2) -> EBinop (op, make_ast e1, make_ast e2)
| TField (e,f) -> EField (make_ast e, Type.field_name f)
| TTypeExpr t -> fst (mk_path (full_type_path t) e.epos)
| TParenthesis e -> EParenthesis (make_ast e)
| TObjectDecl fl -> EObjectDecl (List.map (fun (f,e) -> f, make_ast e) fl)
| TArrayDecl el -> EArrayDecl (List.map make_ast el)
| TCall (e,el) -> ECall (make_ast e,List.map make_ast el)
| TNew (c,pl,el) -> ENew ((match (try make_type (TInst (c,pl)) with Exit -> make_type (TInst (c,[]))) with CTPath p -> p | _ -> assert false),List.map make_ast el)
| TUnop (op,p,e) -> EUnop (op,p,make_ast e)
| TFunction f ->
let arg (v,c) = v.v_name, false, mk_ot v.v_type, (match c with None -> None | Some c -> Some (EConst (tconst_to_const c),e.epos)) in
EFunction (None,{ f_params = []; f_args = List.map arg f.tf_args; f_type = mk_ot f.tf_type; f_expr = Some (make_ast f.tf_expr) })
| TVar (v,eo) ->
EVars ([v.v_name, mk_ot v.v_type, eopt eo])
| TBlock el -> EBlock (List.map make_ast el)
| TFor (v,it,e) ->
let ein = (EIn ((EConst (Ident v.v_name),it.epos),make_ast it),it.epos) in
EFor (ein,make_ast e)
| TIf (e,e1,e2) -> EIf (make_ast e,make_ast e1,eopt e2)
| TWhile (e1,e2,flag) -> EWhile (make_ast e1, make_ast e2, flag)
| TSwitch (e,cases,def) ->
let cases = List.map (fun (vl,e) ->
List.map make_ast vl,None,(match e.eexpr with TBlock [] -> None | _ -> Some (make_ast e))
) cases in
let def = match eopt def with None -> None | Some (EBlock [],_) -> Some None | e -> Some e in
ESwitch (make_ast e,cases,def)
| TEnumParameter _ ->
(* these are considered complex, so the AST is handled in TMeta(Meta.Ast) *)
assert false
| TTry (e,catches) -> ETry (make_ast e,List.map (fun (v,e) -> v.v_name, (try make_type v.v_type with Exit -> assert false), make_ast e) catches)
| TReturn e -> EReturn (eopt e)
| TBreak -> EBreak
| TContinue -> EContinue
| TThrow e -> EThrow (make_ast e)
| TCast (e,t) ->
let t = (match t with
| None -> None
| Some t ->
let t = (match t with TClassDecl c -> TInst (c,[]) | TEnumDecl e -> TEnum (e,[]) | TTypeDecl t -> TType (t,[]) | TAbstractDecl a -> TAbstract (a,[])) in
Some (try make_type t with Exit -> assert false)
) in
ECast (make_ast e,t)
| TMeta ((Meta.Ast,[e1,_],_),_) -> e1
| TMeta (m,e) -> EMeta(m,make_ast e))
,e.epos)

;;
make_ast_ref := make_ast;
make_complex_type_ref := make_type;
encode_complex_type_ref := encode_ctype;
enc_array_ref := enc_array;
dec_array_ref := dec_array;
Expand Down
131 changes: 130 additions & 1 deletion type.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -2129,5 +2129,134 @@ let map_expr_type f ft fv e =
| TMeta (m,e1) ->
{e with eexpr = TMeta(m, f e1); etype = ft e.etype }

module TExprToExpr = struct
let tpath p mp pl =
if snd mp = snd p then
CTPath {
tpackage = fst p;
tname = snd p;
tparams = List.map (fun t -> TPType t) pl;
tsub = None;
}
else CTPath {
tpackage = fst mp;
tname = snd mp;
tparams = List.map (fun t -> TPType t) pl;
tsub = Some (snd p);
}

let rec convert_type = function
| TMono r ->
(match !r with
| None -> raise Exit
| Some t -> convert_type t)
| TEnum (e,pl) ->
tpath e.e_path e.e_module.m_path (List.map convert_type pl)
| TInst({cl_kind = KTypeParameter _} as c,pl) ->
tpath ([],snd c.cl_path) ([],snd c.cl_path) (List.map convert_type pl)
| TInst (c,pl) ->
tpath c.cl_path c.cl_module.m_path (List.map convert_type pl)
| TType (t,pl) as tf ->
(* recurse on type-type *)
if (snd t.t_path).[0] = '#' then convert_type (follow tf) else tpath t.t_path t.t_module.m_path (List.map convert_type pl)
| TAbstract (a,pl) ->
tpath a.a_path a.a_module.m_path (List.map convert_type pl)
| TFun (args,ret) ->
CTFunction (List.map (fun (_,_,t) -> convert_type t) args, convert_type ret)
| TAnon a ->
begin match !(a.a_status) with
| Statics c -> tpath ([],"Class") ([],"Class") [tpath c.cl_path c.cl_path []]
| EnumStatics e -> tpath ([],"Enum") ([],"Enum") [tpath e.e_path e.e_path []]
| _ ->
CTAnonymous (PMap.foldi (fun _ f acc ->
{
cff_name = f.cf_name;
cff_kind = FVar (mk_ot f.cf_type,None);
cff_pos = f.cf_pos;
cff_doc = f.cf_doc;
cff_meta = f.cf_meta;
cff_access = [];
} :: acc
) a.a_fields [])
end
| (TDynamic t2) as t ->
tpath ([],"Dynamic") ([],"Dynamic") (if t == t_dynamic then [] else [convert_type t2])
| TLazy f ->
convert_type ((!f)())

and mk_ot t =
match follow t with
| TMono _ -> None
| _ -> (try Some (convert_type t) with Exit -> None)

let rec convert_expr e =
let full_type_path t =
let mp,p = match t with
| TClassDecl c -> c.cl_module.m_path,c.cl_path
| TEnumDecl en -> en.e_module.m_path,en.e_path
| TAbstractDecl a -> a.a_module.m_path,a.a_path
| TTypeDecl t -> t.t_module.m_path,t.t_path
in
if snd mp = snd p then p else (fst mp) @ [snd mp],snd p
in
let mk_path = expr_of_type_path in
let mk_ident = function
| "`trace" -> Ident "trace"
| n -> Ident n
in
let eopt = function None -> None | Some e -> Some (convert_expr e) in
((match e.eexpr with
| TConst c ->
EConst (tconst_to_const c)
| TLocal v -> EConst (mk_ident v.v_name)
| TArray (e1,e2) -> EArray (convert_expr e1,convert_expr e2)
| TBinop (op,e1,e2) -> EBinop (op, convert_expr e1, convert_expr e2)
| TField (e,f) -> EField (convert_expr e, field_name f)
| TTypeExpr t -> fst (mk_path (full_type_path t) e.epos)
| TParenthesis e -> EParenthesis (convert_expr e)
| TObjectDecl fl -> EObjectDecl (List.map (fun (f,e) -> f, convert_expr e) fl)
| TArrayDecl el -> EArrayDecl (List.map convert_expr el)
| TCall (e,el) -> ECall (convert_expr e,List.map convert_expr el)
| TNew (c,pl,el) -> ENew ((match (try convert_type (TInst (c,pl)) with Exit -> convert_type (TInst (c,[]))) with CTPath p -> p | _ -> assert false),List.map convert_expr el)
| TUnop (op,p,e) -> EUnop (op,p,convert_expr e)
| TFunction f ->
let arg (v,c) = v.v_name, false, mk_ot v.v_type, (match c with None -> None | Some c -> Some (EConst (tconst_to_const c),e.epos)) in
EFunction (None,{ f_params = []; f_args = List.map arg f.tf_args; f_type = mk_ot f.tf_type; f_expr = Some (convert_expr f.tf_expr) })
| TVar (v,eo) ->
EVars ([v.v_name, mk_ot v.v_type, eopt eo])
| TBlock el -> EBlock (List.map convert_expr el)
| TFor (v,it,e) ->
let ein = (EIn ((EConst (Ident v.v_name),it.epos),convert_expr it),it.epos) in
EFor (ein,convert_expr e)
| TIf (e,e1,e2) -> EIf (convert_expr e,convert_expr e1,eopt e2)
| TWhile (e1,e2,flag) -> EWhile (convert_expr e1, convert_expr e2, flag)
| TSwitch (e,cases,def) ->
let cases = List.map (fun (vl,e) ->
List.map convert_expr vl,None,(match e.eexpr with TBlock [] -> None | _ -> Some (convert_expr e))
) cases in
let def = match eopt def with None -> None | Some (EBlock [],_) -> Some None | e -> Some e in
ESwitch (convert_expr e,cases,def)
| TEnumParameter _ ->
(* these are considered complex, so the AST is handled in TMeta(Meta.Ast) *)
assert false
| TTry (e,catches) -> ETry (convert_expr e,List.map (fun (v,e) -> v.v_name, (try convert_type v.v_type with Exit -> assert false), convert_expr e) catches)
| TReturn e -> EReturn (eopt e)
| TBreak -> EBreak
| TContinue -> EContinue
| TThrow e -> EThrow (convert_expr e)
| TCast (e,t) ->
let t = (match t with
| None -> None
| Some t ->
let t = (match t with TClassDecl c -> TInst (c,[]) | TEnumDecl e -> TEnum (e,[]) | TTypeDecl t -> TType (t,[]) | TAbstractDecl a -> TAbstract (a,[])) in
Some (try convert_type t with Exit -> assert false)
) in
ECast (convert_expr e,t)
| TMeta ((Meta.Ast,[e1,_],_),_) -> e1
| TMeta (m,e) -> EMeta(m,convert_expr e))
,e.epos)

end

let print_if b e =
if b then print_endline (s_expr_pretty "" (s_type (print_context())) e)
if b then print_endline (s_expr_pretty "" (s_type (print_context())) e)

0 comments on commit 51409af

Please sign in to comment.