open Support.Pervasive open Support.Error open G_ast open Prim open Printf open G2str open Congruence_closure open Union_find open List exception TypeParamArgMismatch of string let trace_exp = false let rec last ls = match ls with [] -> raise (Invalid_argument "empty list") | [a] -> a | a::ls -> last ls let loaded_files = ref ([] : string list) let get_fun_reqs ft = (match ft with FunT (i, ts, (rs,sms), ps, (rt,rv,rm)) -> rs | _ -> error UNKNOWN "get_fun_reqs: expected a function type") let get_fun_info ft = (match ft with FunT (i, ts, (rs,sms), ps, (rt,rv,rm)) -> i | _ -> error UNKNOWN "get_fun_reqs: expected a function type") let get_fun_ty_params ft = (match ft with FunT (i, ts, (rs,sms), ps, (rt,rv,rm)) -> ts | _ -> error UNKNOWN "get_fun_reqs: expected a function type") (* This version does bad things for overloading. let lookup n env = (try assoc n env.local_vars with Not_found -> assoc n env.vars) *) (* The following version isn't so hot because, for example, functions pass as paremeters, are merged into the overload set instead of overshadowing. *) let lookup n env = (try (match assoc n env.local_vars with VarB (e_l,t_l,m_l,bk_l) -> (match t_l with FunT _ -> (try (match assoc n env.vars with VarB (e_g,t_g,m_g,bk_g) -> OvldB [(e_l,t_l,bk_l);(e_g,t_g,bk_g)] | OvldB ts -> OvldB ((e_l,t_l,bk_l)::ts)) with Not_found -> VarB (e_l,t_l,m_l,bk_l)) | _ -> VarB (e_l,t_l,m_l,bk_l)) | OvldB ts1 -> (try (match assoc n env.vars with VarB (e_g,t_g,m_g,bk_g) -> OvldB ((e_g,t_g,bk_g)::ts1) | OvldB ts2 -> OvldB (ts1@ts2)) with Not_found -> OvldB ts1)) with Not_found -> assoc n env.vars) (* Differentiates type variables to be either type parameters or class, struct, or union names. Also, ensure well-formedness and performs type variable renaming. Additionally, normalizes types according to same-type constraints. *) let rec typecheck_fun env (fn, (i, recur, ts, (rs,ss), ps, (rt,rv,rm), body)) = if debug then printf " type checking function %s\n" fn; (* Well-formed same-types, and extend env. *) if not (distinct ts) then error i "Duplicate type parameters."; if not (distinct (map fst ps)) then error i "Duplicate parameter names."; (match (rt,rv,rm) with (VoidT _, Lvalue, _) -> error i "May not return (void) by reference, try => instead" | _ -> ()); let (benv, nts, rs, ss) = process_generic_intro i env ts rs ss in if debug then printf " type checking function %s, finished generic intro\n" fn; (* Check for well formed types in function signature *) let ps = map (fun (n, (t,v,m)) -> (n, (well_formed_typ benv t, v, m))) ps in let rt = well_formed_typ benv rt in let ft = FunT (i, nts, (rs,ss), map snd ps, (rt,rv,rm)) in (* Extend the environment with - parameters - the function itself *) let psn = map (fun (n,_) -> uniquify_name n) ps in let psb = map2 (fun new_n (n,(t,_,m)) -> (n, VarB (Cpp_ast.VarE new_n, t, m, Defn))) psn ps in let benv = {benv with local_vars= psb @ benv.local_vars} in let new_fn = if (fn = "main") then "main" else sprintf "%s_%s" fn (typ2mangled_name ft) in let benv = if recur then let fv = Cpp_ast.VarE new_fn in env_add_ovld i benv fn (VarB (fv, ft, Constant, Defn)) else benv in (* Typecheck the function body *) if debug then (printf "Checking function %s's body with return type (%s)\n" fn (g2string_typ rt)); let (body,rts,_) = typecheck_stmt benv (get_canonical benv rt,rv,rm) body in (if debug then printf "finished checking function body\n"); (match rt with VoidT _ -> (match rts with (t,i)::rts -> error i "May not return from a function with void return type" | _ -> ()) | _ -> ()); (* Convert signature to C++ types *) let ps = map2 (fun n t -> (n, cvt_exp_typ benv t)) psn (map snd ps) in let rt = cvt_exp_typ benv (rt,rv,rm) in (new_fn, (ps, rt, ss2s body), ft) and create_dict_fwd_decl env i ts rs cn targs assocs = if trace_exp then printf "create dict fwd decl %s<%s>\n" cn (String.concat ", " (map g2string_typ targs)); let (model_rs,model_ss) = rs in let model_dict_params = make_dict_params ts i model_rs in let (cts, ats, refs, reqs, cfs, sames) = assoc cn env.concepts in (* substitute type arguments for type parameters *) if (length cts = length targs) then () else error i (sprintf "Concept %s has %d type parameters, not %d." cn (length cts) (length targs)); let sub = combine cts targs in (* what about associated types? *) let refs = map (fun (n,ts) -> (n, map (subst_typ sub) ts)) refs in let reqs = map (fun (n,ts) -> (n, map (subst_typ sub) ts)) reqs in let sames = map (fun (s,t) -> (subst_typ sub s, subst_typ sub t)) sames in let find_dict is_refine = (fun (env,dicts) (cn,targs) -> let (dict,env) = (try lookup_dictionary is_refine i cn targs env 0 with No_matching_model msg -> error i msg) in (env, dicts @ [dict])) in (* Check that all associated types are defined *) iter (fun at -> (try let _ = assoc at assocs in () with Not_found -> error i (sprintf "model %s<%s> does not define a type for %s, which is required by %s." cn (String.concat ", " (map g2string_typ targs)) at cn))) ats; (* Check for models to satisfy refs *) let (env, ref_dicts) = fold_left (find_dict true) (env,[]) refs in (* Check for models to satisfy reqs *) let (env, req_dicts) = fold_left (find_dict false) (env,[]) reqs in (* Check the same type constraints *) print_graph env.type_graph; print_reps env.type_reps; iter (fun (s,t) -> if not (equal_type env s t) then error i (sprintf "Same type requirement violated, %s != %s" (typ2str env s) (typ2str env t))) sames; let virtual_methods = map (fun (c_fn,(c_mangled_fn,c_ft,c_ft_cpp,c_pns,c_default_body)) -> make_concept_virtual_method true i env c_mangled_fn c_ft_cpp c_pns None) cfs in let fields = map (fun (n,t) -> Cpp_ast.Field (n,t)) model_dict_params in let model_cn = make_model_class_name ts cn targs (model_rs,model_ss) in let model_obj_n = make_dict_name ts cn targs in let cons = let ref_ps = (make_refine_dict_params i refs) @ (make_refine_dict_params i reqs) in let params = ref_ps @ model_dict_params in let inits = (cn, [Cpp_ast.ClassE (Stack, cn, 0, map (fun (n,_) -> Cpp_ast.VarE n) ref_ps)]) ::(map (fun (n,_) -> (n,[Cpp_ast.VarE n])) model_dict_params) in Cpp_ast.Constructor (0, params, inits, Cpp_ast.CompoundS []) in let model_class = Cpp_ast.ClassD (model_cn, [cn], cons::(virtual_methods @ fields)) in if model_rs = [] then [model_class; Cpp_ast.VarFwdD (Cpp_ast.PtrT (Cpp_ast.ClassT cn), model_obj_n)] else [model_class] and check_model_create_dict env i ts rs cn targs assocs fs = if trace_exp then printf "Checking model %s<%s>\n" cn (String.concat ", " (map g2string_typ targs)); (*printf "member funs: %s\n" (String.concat " " (map fst fs));*) let (model_rs,model_ss) = rs in let model_dict_params = make_dict_params ts i model_rs in let (cts, ats, refs, reqs, cfs, sames) = assoc cn env.concepts in (* substitute type arguments for type parameters *) if (length cts = length targs) then () else error i (sprintf "Concept %s has %d type parameters, not %d." cn (length cts) (length targs)); let sub = combine cts targs in (* what about associated types? *) let refs = map (fun (n,ts) -> (n, map (subst_typ sub) ts)) refs in let reqs = map (fun (n,ts) -> (n, map (subst_typ sub) ts)) reqs in let sames = map (fun (s,t) -> (subst_typ sub s, subst_typ sub t)) sames in let cfs = map (fun (n,(mangled_n,t,t_cpp,ps,b)) -> (n, mangled_n, (t, subst_typ sub t, t_cpp,ps,b))) cfs in let find_dict is_refine = (fun (env,dicts) (cn,targs) -> let (dict,env) = (try lookup_dictionary is_refine i cn targs env 0 with No_matching_model msg -> error i msg) in (env, dicts @ [dict])) in (* Check that all associated types are defined *) iter (fun at -> (try let _ = assoc at assocs in () with Not_found -> error i (sprintf "model %s<%s> does not define a type for %s, which is required by %s." cn (String.concat ", " (map g2string_typ targs)) at cn))) ats; (* Check for models to satisfy refs *) if trace_exp then printf "checking for refinements in %s\n" cn; let (env, ref_dicts) = fold_left (find_dict true) (env,[]) refs in (* Check for models to satisfy reqs *) if trace_exp then printf "checking for requirements in %s\n" cn; let (env, req_dicts) = fold_left (find_dict false) (env,[]) reqs in (* Check the same type constraints *) print_graph env.type_graph; print_reps env.type_reps; iter (fun (s,t) -> if not (equal_type env s t) then error i (sprintf "Same type requirement violated, %s != %s" (typ2str env s) (typ2str env t))) sames; (* make sure all the functions are defined and create member functions *) let create_dict_method class_name c_orig_ft c_ft_cpp c_mangled_fn m_mangled_fn m_ft m_ps_cpp m_rt_cpp m_body = (match (c_orig_ft, m_ft) with (FunT (_, c_ts, (c_rs,c_ss), c_ps, c_rt), FunT (_, m_ts, (m_rs,m_ss), m_ps, m_rt)) -> (match c_ft_cpp with Cpp_ast.FunT (c_ps_cpp, c_rt_cpp) -> let impl_fn = m_mangled_fn in if c_rs = [] then (* no dictionaries, nor currying *) let pn = map (fun _ -> sprintf "__%d" (make_id())) c_ps in let vps = combine pn c_ps_cpp in if debug then printf "in Model, fwd call\n"; let fwd_call = Cpp_ast.ApplyE (Cpp_ast.VarE impl_fn, map2 (fun n (c,(m_t,_,_))-> coerce_poly env i c (Cpp_ast.VarE n) (get_canonical env m_t)) pn (combine c_ps m_ps)) in let m_rt = (match m_rt with (rt,v,m) -> (get_canonical env rt, v, m)) in if debug then printf "dict method %s, converting %s --> %s\n" c_mangled_fn (g2string_exp_typ m_rt) (g2string_exp_typ c_rt); let fwd_call = coerce_poly env i m_rt fwd_call (match c_rt with (t,_,_) -> t) in let fwd = (match c_rt with (VoidT _,_,_) -> Cpp_ast.ExprS fwd_call | _ -> Cpp_ast.ReturnS (Some fwd_call)) in let virt_method = Cpp_ast.MethodFwd (c_mangled_fn, true, vps, c_rt_cpp) in let impl_method = Cpp_ast.MethodFwd (impl_fn, false, m_ps_cpp, m_rt_cpp) in let virt_method_outer = Cpp_ast.MethodD (class_name, c_mangled_fn, vps, c_rt_cpp, Cpp_ast.CompoundS [fwd]) in let impl_method_outer = Cpp_ast.MethodD (class_name, impl_fn, m_ps_cpp, m_rt_cpp, m_body) in ([virt_method; impl_method], [virt_method_outer; impl_method_outer]) else (* dictionaries, and curried *) (* create the virtual forwarding function that does the coercion *) let (cenv, c_ts, c_rs, c_ss) = process_generic_intro i env c_ts c_rs c_ss in let dict_args = map (fun (cn,targs) -> let (d,_) = lookup_dictionary false i cn targs cenv 0 in d) m_rs in let fwd_call = Cpp_ast.ApplyE (Cpp_ast.VarE impl_fn, dict_args) in let fwd = coerce_poly env i (get_canonical env m_ft, Rvalue, Constant) fwd_call c_orig_ft in let virt_method = Cpp_ast.MethodFwd (c_mangled_fn, true, make_dict_params c_ts i c_rs, Cpp_ast.FunT (c_ps_cpp, c_rt_cpp)) in let virt_method_outer = Cpp_ast.MethodD (class_name, c_mangled_fn, make_dict_params c_ts i c_rs, Cpp_ast.FunT (c_ps_cpp, c_rt_cpp), Cpp_ast.CompoundS [Cpp_ast.ReturnS (Some fwd)]) in (* create the implementation function *) let f_ds = make_dict_params m_ts i m_rs in let dict_inits = map (fun (n,t) -> (n, (Cpp_ast.VarE n, t))) (model_dict_params@f_ds) in let fe = Cpp_ast.FunE (m_ps_cpp, m_rt_cpp, dict_inits, m_body) in let impl_method = Cpp_ast.MethodFwd (impl_fn, false, f_ds, Cpp_ast.FunT (map snd m_ps_cpp, m_rt_cpp)) in let impl_method_outer = Cpp_ast.MethodD (class_name, impl_fn, f_ds, Cpp_ast.FunT (map snd m_ps_cpp, m_rt_cpp), Cpp_ast.CompoundS [Cpp_ast.ReturnS (Some fe)]) in ([virt_method; impl_method], [virt_method_outer; impl_method_outer]) | _ -> error i "expected a function type.") | _ -> error i "expected a function type.") in let model_cn = make_model_class_name ts cn targs (model_rs,model_ss) in let method_decl_def = (map (fun (c_fn,c_mangled_fn,(c_orig_ft,c_sub_ft,c_ft_cpp, c_pns,c_default_body)) -> (* the signature from the concept *) let rec find_match fs msg = (match fs with [] -> (* Attempt to find a matching function in the outer environment TODO, error in the right place *) (try (* lookup the function *) let (m_fe, (m_ft,mv,mm)) = (match lookup c_fn env with VarB (e, t, m, bk) -> (e, (t,Lvalue,m)) | OvldB ls -> (Cpp_ast.VarE c_fn, (OvldT (i,map (fun (e,t,bk) -> (e,t)) ls), Rvalue, Constant))) in (* resolve overloads *) let (m_fe, m_ft) = (match m_ft with FunT _ -> (m_fe,m_ft) | OvldT (_,ts) -> (match c_sub_ft with FunT (_, c_ts, c_w, c_ps, c_rt) -> (try let (ft,k) = resolve_overload 0 env (map snd ts) c_ps in (fst (nth ts k), ft) with Ambiguous_overload -> error i (sprintf "Could not satisfy requirement for %s, ambiguous overload" c_fn) ) | _ -> error i "expected a function") | _ -> error i (sprintf "3. Could not satisfy requirement for %s" c_fn)) in (* deduce type parameters for the function m_fe *) let m_ft = (match (c_sub_ft,m_ft) with (FunT (_, _, _, c_ps, c_rt), FunT (fi, ts, (rs,ss), ps, (rt,rv,rm))) -> let nts = map (fun t -> uniquify_name t) ts in let rename = combine ts (map (fun nt -> VarT (i, nt)) nts) in let rs = map (fun (cn,targs) -> let targs = map (subst_typ rename) targs in (cn,targs)) rs in let ss = map (fun (s,t) -> (subst_typ rename s, subst_typ rename t)) ss in let params = map (fun (t,v,m) -> (subst_typ rename t, v, m)) ps in let rt = subst_typ rename rt in (try let (sub2, _, _, _) = subtype_unify_list false nts i env [] c_ps (map (fun _ -> Cpp_ast.BoolE true) c_ps) params in let rs = map (fun (cn,targs) -> (cn, map (subst_typ sub2) targs)) rs in let ss = map (fun (s,t) -> (subst_typ sub2 s, subst_typ sub2 t)) ss in let ps = map (fun (t,v,m) -> (subst_typ sub2 t,v,m)) ps in let rt = subst_typ sub2 rt in if subtype env (rt,rv,rm) c_rt then FunT (fi, nts, (rs,ss), ps, (rt,rv,rm)) else error i (sprintf "Return type (%s) for function %s is not coercible to expected return type (%s)" (g2string_exp_typ (rt,rv,rm)) c_fn (g2string_exp_typ c_rt) ) with Unify_failure msg -> error i msg) | _ -> error i "expected a function") in (match c_ft_cpp with Cpp_ast.FunT (c_ps_cpp, c_rt_cpp) -> (match (c_orig_ft, m_ft) with (FunT (_, c_ts, (c_rs,c_ss), c_ps, c_rt), FunT (_, m_ts, (m_rs,m_ss), m_ps, m_rt)) -> let m_fe = if m_rs = [] then m_fe else let (ds,env) = (try lookup_dictionaries i m_rs env 0 with No_matching_model msg -> error i (sprintf "in ModelD, search outer env, %s" msg)) in Cpp_ast.ApplyE (m_fe, ds) in if c_rs = [] then let pn = map (fun _ -> sprintf "__%d" (make_id())) c_ps in let fwd_call = Cpp_ast.ApplyE (m_fe, map2 (fun n (c,(m_t,_,_))-> coerce_poly env i c (Cpp_ast.VarE n) m_t) pn (combine c_ps m_ps)) in let fwd = (match c_rt with (VoidT _,_,_) -> Cpp_ast.ExprS fwd_call | _ -> Cpp_ast.ReturnS (Some fwd_call)) in let virt_method = Cpp_ast.MethodFwd (c_mangled_fn, true, combine pn c_ps_cpp, c_rt_cpp) in let virt_method_def = Cpp_ast.MethodD (model_cn, c_mangled_fn, combine pn c_ps_cpp, c_rt_cpp, Cpp_ast.CompoundS [fwd]) in ([virt_method], [virt_method_def]) else let (cenv,c_ts,c_rs,c_ss) = process_generic_intro i env c_ts c_rs c_ss in let dict_args = map (fun (cn,targs) -> let (d,_) = lookup_dictionary false i cn targs cenv 0 in d) m_rs in let fwd_call = Cpp_ast.ApplyE (m_fe, dict_args) in let fwd = coerce_poly env i (m_ft, Rvalue, Constant) fwd_call c_orig_ft in let virt_method = Cpp_ast.MethodFwd (c_mangled_fn, true, make_dict_params c_ts i c_rs, Cpp_ast.FunT (c_ps_cpp, c_rt_cpp)) in let virt_method_def = Cpp_ast.MethodD (model_cn, c_mangled_fn, make_dict_params c_ts i c_rs, Cpp_ast.FunT (c_ps_cpp, c_rt_cpp), Cpp_ast.CompoundS [Cpp_ast.ReturnS (Some fwd)]) in (* create the implementation function *) let f_ds = make_dict_params m_ts i m_rs in let dict_inits = map (fun (n,t) -> (n, (Cpp_ast.VarE n, t))) (model_dict_params@f_ds) in ([virt_method], [virt_method_def]) | _ -> error i "blah") | _ -> error i "expected a C++ function") with Not_found | No_matching_overload _ -> (match c_default_body with None -> error i (sprintf "Invalid model because it did not satisfy %s's requirement for\n%s %s : %s\n%s" cn (sprintInfo (get_fun_info c_orig_ft)) c_fn (g2string_typ c_sub_ft) msg) | Some body -> (* Use the default implementation from the concept *) ([],[]))) | (m_fn,(m_mangled_fn, (m_ps_cpp, m_rt_cpp, m_body), m_ft))::fs -> (* a model-provided function *) if c_fn = m_fn then (try let _ = subtype_unify [] env [] (m_ft,Rvalue,Constant) (Cpp_ast.BoolE true) (c_sub_ft,Rvalue,Constant) in if debug then printf "satisfied function %s\n" c_fn else (); create_dict_method model_cn c_orig_ft c_ft_cpp c_mangled_fn (sprintf "%s_impl" m_mangled_fn) m_ft m_ps_cpp m_rt_cpp m_body with Unify_failure fail_msg -> let new_msg = sprintf "%s\ndid not match because %s" (sprintInfo (get_fun_info m_ft)) fail_msg in find_match fs (String.concat "\n" [msg; new_msg])) else find_match fs msg) in find_match fs "") cfs) in let method_decls = concat (map fst method_decl_def) in let method_defs = concat (map snd method_decl_def) in let fields = map (fun (n,t) -> Cpp_ast.Field (n,t)) model_dict_params in let model_obj_n = make_dict_name ts cn targs in let cons = let ref_ps = (make_refine_dict_params i refs) @ (make_refine_dict_params i reqs) in let params = ref_ps @ model_dict_params in let inits = (cn, [Cpp_ast.ClassE (Stack, cn, 0, map (fun (n,_) -> Cpp_ast.VarE n) ref_ps)]) ::(map (fun (n,_) -> (n,[Cpp_ast.VarE n])) model_dict_params) in Cpp_ast.Constructor (0, params, inits, Cpp_ast.CompoundS []) in let model_class = Cpp_ast.ClassD (model_cn, [cn], cons::(method_decls @ fields)) in if model_rs = [] then [model_class] @ method_defs @ [Cpp_ast.VarD (Cpp_ast.PtrT (Cpp_ast.ClassT cn), model_obj_n, Cpp_ast.ClassE (GCHeap, model_cn, 0, ref_dicts @ req_dicts))] else [model_class] @ method_defs (* returns Cpp_ast.exp * exp_typ *) and find_model_member i env mn cn targs dict dict_path = let (cts, ats, refs, reqs, cfs, sames) = (try assoc cn env.concepts with Not_found -> error i (sprintf "Invalid model member access, concept %s is not defined." cn)) in let subty = subst_typ (combine cts targs) in (try let (mangled_member_name,ft,ft_cpp,_,_) = assoc mn cfs in (*let dict_path = mangled_name::dict_path in*) let de = make_dict_access dict dict_path in coerce_model_member i env cn mangled_member_name ft (subty ft) de with Not_found -> let rec loop refs = (match refs with [] -> raise Not_found | (cn,targs)::rs -> let stargs = map subty targs in (try let refn = subdict_member_name cn targs in find_model_member i env mn cn stargs dict (refn::dict_path) with Not_found -> loop rs)) in loop refs) and typecheck_decls (make_defs : bool) (env : environment) (ds : decl list) : (Cpp_ast.decl list * decl list * environment) = (match ds with [] -> ([], [], env) | d::ds -> let (ds1,fwd,env) = typecheck_decl make_defs env d in let (ds2, fwds,env) = typecheck_decls make_defs env ds in (ds1@ds2, fwd::fwds, env)) and create_model_default_cons make_defs i env ct ts w = if debug then printf "Generating model DefaultConstructible<%s>\n" (g2string_typ ct); let new_on n a = let rt = (match a with Stack -> ct | Heap -> PtrT (i, ct) | GCHeap -> PtrT (i, ct)) in (n, (i, false, [], empty_where, [], (rt,Rvalue,Mutable), CompoundS (i, [ReturnS (i, Some (NewE (i, a, ct, [])))]))) in let new_on_stack = new_on "new_on_stack" Stack in let new_on_heap = new_on "new_on_heap" Heap in let new_on_gc = new_on "new_on_gc" GCHeap in let placement_new = ("new_placement", (i, false,[], empty_where, [("p", (PtrT (i,VoidT i), Rvalue, Mutable))], (PtrT (i, ct),Rvalue,Mutable), CompoundS (i, [ReturnS (i, Some (PlacementNewE (i, VarE (i, "p"), ct, [])))]))) in let new_array_on n a = (n, (i, false, [], empty_where, [("n", (IntT i, Lvalue, Constant))], (PtrT (i, ct),Rvalue,Mutable), CompoundS (i, [LetS (i, PtrT (i, ct), "a", NewArrayNoInitE (i, a, ct, VarE (i, "n"))); LetS (i, IntT i, "i", NewE (i, Stack, IntT i, [IntE (i, 0)])); WhileS (i, ApplyE (i, VarE (i, "__not_equal"), [VarE (i, "i"); VarE (i, "n")]), CompoundS (i, [ ExprS (i, ApplyE (i, PrimE (i, AssignP), [ApplyE (i, VarE (i, "__arrayelt"), [VarE (i, "a"); VarE (i, "i")]); NewE (i, Stack, ct, [])])); ExprS (i, ApplyE (i, VarE (i, "__assign"), [VarE (i, "i"); ApplyE (i, VarE (i, "__add"), [VarE (i, "i"); IntE (i, 1)])]))] )); ReturnS (i, Some (VarE (i, "a")))]))) in let new_array_on_heap = new_array_on "new_array_on_heap" Heap in let new_array_on_gc = new_array_on "new_array_on_gc" GCHeap in let dc_model = ModelD (i, false, ts, w, "DefaultConstructible", [ct], [], [new_on_stack; new_on_heap; new_on_gc; placement_new; new_array_on_heap; new_array_on_gc]) in if debug then printf "Checking model for DefaultConstructible\n"; typecheck_decl make_defs env dc_model and create_model_regular make_defs i env ct ts w = if debug then printf "Generating model Regular<%s>\n" (g2string_typ ct); let assign = ("__assign", (i, false,[], empty_where, [("x", (ct,Lvalue,Mutable)); ("y", (ct,Lvalue,Constant))], (ct,Lvalue,Mutable), CompoundS (i, [ReturnS (i, Some (ApplyE (i, VarE (i, "__assign"), [VarE (i, "x"); VarE (i, "y")])))]))) in let new_on n a = let rt = (match a with Stack -> ct | Heap -> PtrT (i, ct) | GCHeap -> PtrT (i, ct)) in (n, (i, false,[], empty_where, [("x", (ct, Lvalue, Constant))], (rt,Rvalue,Mutable), CompoundS (i, [ReturnS (i, Some (NewE (i, a, ct, [VarE (i, "x")])))]))) in let new_on_stack = new_on "new_on_stack" Stack in let new_on_heap = new_on "new_on_heap" Heap in let new_on_gc = new_on "new_on_gc" GCHeap in let placement_new = ("new_placement", (i, false,[], empty_where, [("p", (PtrT (i,VoidT i), Rvalue, Mutable)); ("x", (ct, Lvalue, Constant))], (PtrT (i, ct), Rvalue, Mutable), CompoundS (i, [ReturnS (i, Some (PlacementNewE (i, VarE (i, "p"), ct, [VarE (i, "x")])))]))) in let cleanup = ("cleanup", (i, false,[], empty_where, [("px", (PtrT (i, ct),Rvalue,Mutable))], (VoidT i, Rvalue, Mutable), CompoundS (i, [ExprS (i, ApplyE (i, PrimE (i, DeleteP), [VarE (i, "px")]))]))) in let wipeout = ("wipeout", (i, false,[], empty_where, [("px", (PtrT (i, ct),Rvalue,Mutable))], (VoidT i, Rvalue, Mutable), CompoundS (i, [ExprS (i, ApplyE (i, PrimE (i, DestroyP), [VarE (i, "px")]))]))) in let reg_model = ModelD (i, false, ts, w, "Regular", [ct], [], [assign; new_on_stack; new_on_heap; new_on_gc; placement_new; cleanup; wipeout]) in typecheck_decl make_defs env reg_model and env_add_assocs_from_refines i env refs = fold_left (fun env (cn,targs) -> let (cts, assocs, refs, reqs, cfs, sames) = assoc cn env.concepts in let qual_assocs = List.map (fun at -> (at, AssocT (i,cn, targs, at))) assocs in let env = { env with tparams = qual_assocs @ env.tparams } in let sub = combine cts targs in let refs = map (fun (cn,targs) -> (cn, map (subst_typ sub) targs)) refs in env_add_assocs_from_refines i env refs) env refs (* t has not yet gone through well_formed_typ *) and type_has_default_cons i env t = let class_has_default_cons cs = if debug then printf "class has constructors = %s\n" (String.concat "\n" (map g2string_typ cs)); exists (fun c -> match c with FunT (i,ts,w,[],rt) -> true | _ -> false) cs in (match t with AssocT _ -> (try let _ = lookup_dictionary false i "DefaultConstructible" [t] env in true with No_matching_model msg -> false) | VarT (_,n) -> (try let (_,_,_,cs) = lookup_class n env in class_has_default_cons cs with Not_found -> (try let _ = lookup_dictionary false i "DefaultConstructible" [t] env in true with No_matching_model msg -> false)) | ClassT (_,cn,targs) -> let (_,_,_,cs) = lookup_class cn env in class_has_default_cons cs | _ -> true) and type_has_copy_cons i env t = let class_has_copy_cons cn cs = exists (fun c -> match c with FunT (i,ts,w,[(ClassT (_,n,_), Lvalue, Constant)],rt) when n = cn -> true | _ -> false) cs in (match t with AssocT _ -> (try let _ = lookup_dictionary false i "Regular" [t] env in true with No_matching_model msg -> false) | VarT (_,n) -> (try let (_,_,_,cs) = lookup_class n env in class_has_copy_cons n cs with Not_found -> (try let _ = lookup_dictionary false i "Regular" [t] env in true with No_matching_model msg -> false)) | ClassT (_,cn,targs) -> let (_,_,_,cs) = lookup_class cn env in class_has_copy_cons cn cs | _ -> true) and type_has_assign i env t = let type_has_assign t = let fts = (match lookup "__assign" env with VarB (e,t,m,bk) -> [t] | OvldB ls -> map (fun (_,t,_) -> t) ls) in let argtys = [(t,Lvalue,Mutable); (t,Lvalue,Constant)] in (try let _ = resolve_overload 0 env fts argtys in true with Ambiguous_overload -> false | No_matching_overload _ -> false) in (match t with AssocT _ -> (try let _ = lookup_dictionary false i "Regular" [t] env in true with No_matching_model msg -> false) | VarT (_,n) -> (try let _ = lookup_class n env in type_has_assign (ClassT (i,n,[])) with Not_found -> (try let _ = lookup_dictionary false i "Regular" [t] env in true with No_matching_model msg -> false)) | ClassT (_,cn,targs) -> type_has_assign t | _ -> true) and make_concept_virtual_method make_fwd i env mfn ft_cpp pns body = (match ft_cpp with Cpp_ast.FunT (ps_cpp, rt_cpp) -> let body_cpp = (match body with Some body -> body | None -> Cpp_ast.PureS) in if make_fwd then Cpp_ast.MethodFwd (mfn, true, combine pns ps_cpp, rt_cpp) else Cpp_ast.Method (mfn, true, combine pns ps_cpp, rt_cpp, body_cpp) | _ -> error i "expected a function type.") and typecheck_model opn env make_defs i ts rs sms cn targs assocs fs = if trace_exp then printf "type checking model %s<%s>\n" cn (String.concat ", " (map g2string_typ targs)); if not (distinct ts) then error i "Duplicated type parameters."; (* check that the concept is defined *) (try let _ = assoc cn env.concepts in () with Not_found -> error i (sprintf "Invalid model: concept %s is not defined." cn)); let (menv,nts,rs,sms) = process_generic_intro i env ts rs sms in let menv = { menv with tparams = (map (fun (n,_) -> (n,VarT (i,n))) assocs) @ menv.tparams} in (* make sure the type arguments are well formed *) let targs = map (well_formed_typ_impl false menv) targs in if trace_exp then printf "*** checking associated types in model are well formed\n"; (* make sure the associated type definitions are well formed *) let assocs = map (fun (n,t) -> (n, well_formed_typ menv t)) assocs in let fwd = ModelFwdD (i, opn, nts, (rs,sms), cn, targs, assocs) in let menv = extend_env_with_same_types menv (map (fun (n,t) -> (VarT (i, n), t)) assocs) in if debug then printf "assocs = { %s }\n" (String.concat ", " (map (fun (n,t) -> sprintf "%s = %s" n (g2string_typ t)) assocs)); (* type check the function definitions inside the model *) let (_,nfs) = fold_left (fun (env,nfs) (fn, finfo) -> let (newfn, newfinfo, ft) = typecheck_fun env (fn,finfo) in let fv = Cpp_ast.VarE (sprintf "%s_impl" newfn) in let env = env_add_ovld i env fn (VarB (fv, ft, Constant, Defn)) in (env, nfs @ [(newfn, newfinfo, ft)])) (menv,[]) fs in let fs = combine (map fst fs) nfs in (* check that the model satisfied the concept and construct the dictionary *) let dict_name = make_dict_name nts cn targs in if debug then printf "about to call check model\n"; print_graph menv.type_graph; print_reps menv.type_reps; let decls = if make_defs then check_model_create_dict menv i nts (rs,sms) cn targs assocs fs else create_dict_fwd_decl menv i nts (rs,sms) cn targs assocs in let env = env_add_model env cn nts (rs,sms) targs assocs dict_name [] in let env = if (length rs = 0) then extend_env_with_same_types env (map (fun (n,t) -> (AssocT (i,cn,targs,n), t)) assocs) else env in let env = if opn then env_add_model_ops i env cn targs dict_name [] else env in (decls, fwd, env) and typecheck_decl (make_defs : bool) (env : environment) (d : decl) : (Cpp_ast.decl list * decl * environment) = (match d with EmptyD -> ([],EmptyD,env) | ExternScopeD (i, lang, ds) -> let benv = { env with extern = true } in let (ds, fwd_ds, benv) = typecheck_decls make_defs benv ds in let env = { benv with extern = false } in let fwd = ExternScopeD (i,lang,fwd_ds) in ([Cpp_ast.ExternScopeD (lang,ds)], fwd, env) | LetFwdD (i, t, mut, n) -> let n2 = uniquify_name n in let v = Cpp_ast.VarE n2 in let env = {env with vars=(n,VarB(v,t,mut,Defn))::env.vars} in let fwd = LetFwdD (i, t, mut, n) in ([Cpp_ast.VarFwdD (cvt_typ env t, n2)], fwd, env) | LetD (i, _, _, n, e) -> let (e,(t,_,mut)) = typecheck_exp Rvalue env e in let n2 = uniquify_name n in let fwd = LetFwdD (i, t, mut, n) in let v = Cpp_ast.VarE n2 in let env = {env with vars=(n,VarB(v,t,mut,Defn))::env.vars} in if make_defs then ([Cpp_ast.VarD (cvt_typ env t, n2, e)], fwd, env) else ([Cpp_ast.VarFwdD (cvt_typ env t, n2)], fwd, env) | FunD (i, fn, recur, ts, (rs,sms), orig_ps, orig_rt, body) -> if debug then printf "typechecking function %s\n" fn; if fn = "main" then (match orig_rt with (IntT _, Lvalue, _) -> error i "The main function must return by value, put @ after the return type" | (IntT _, Rvalue, _) -> () | (rt, _, _) -> error i (sprintf "The main function must return int, not %s\n" (g2string_typ rt))); let (newfn, (ps, rt, body), ft) = typecheck_fun env (fn, (i, recur, ts, (rs,sms), orig_ps, orig_rt, body)) in (* Special case assignment operator for class types. Need to copy dictionaries. *) let body = if fn = "__assign" then (match (orig_ps, ps, orig_rt) with ([(_, (ClassT (_, cn1, targs1), Lvalue, Mutable)); (_, (ClassT (_, cn2, targs2), Lvalue, Constant))], [(me_name, _); (other_name, _)], (ClassT (_, cn3, targs3), Lvalue, Mutable)) when cn1 = cn2 && cn1 = cn3 -> let (ts,(rs,_),_,_) = assoc cn1 env.classes in let dicts = map (fun (cn,targs) -> make_dict_name ts cn targs) rs in let inits = map (fun dn -> let lhs = Cpp_ast.MemE (Cpp_ast.VarE me_name, dn) in let rhs = Cpp_ast.MemE (Cpp_ast.VarE other_name, dn) in Cpp_ast.ExprS (Cpp_ast.ApplyE (Cpp_ast.PrimE AssignP, [lhs; rhs])) ) dicts in Cpp_ast.CompoundS (inits @ [body]) | _ -> body) else body in let fv = Cpp_ast.VarE newfn in let env = env_add_ovld i env fn (VarB (fv, ft, Constant, Defn)) in let rs = get_fun_reqs ft in let fwd = let (ts,w,pst,rt) = (match ft with FunT (_, ts, w, ps, rt) -> (ts,w,ps,rt) | _ -> error i "blah") in FunFwdD (i, fn, ts, w, combine (map fst ps) pst, rt) in if rs = [] then if make_defs then ([Cpp_ast.FunD (newfn, ps, rt, body)], fwd, env) else ([Cpp_ast.FunFwdD (newfn, ps, rt)], fwd, env) else let ds = make_dict_params (get_fun_ty_params ft) i rs in let dict_inits = map (fun (n,t) -> (n, (Cpp_ast.VarE n, t))) ds in let rt_cpp = cvt_typ env ft in let ft_cpp = Cpp_ast.FunT (map snd ds, rt_cpp) in let f = Cpp_ast.FunE (ps, rt, (newfn, (Cpp_ast.VarE newfn, ft_cpp))::dict_inits, body) in if debug then printf "finished with function decl %s\n" fn; if make_defs then ([Cpp_ast.FunD (newfn, ds, rt_cpp, Cpp_ast.CompoundS [Cpp_ast.ReturnS (Some f)])], fwd, env) else ([Cpp_ast.FunFwdD (newfn, ds, rt_cpp)], fwd, env) | FunFwdD (i, fn, ts, (rs,ss), ps, (rt,rv,rm)) -> if not (distinct ts) then error i "Duplicated type parameters."; let (benv, nts, rs, ss) = process_generic_intro i env ts rs ss in (* Check for well formed types in function signature *) let ps = map (fun (n, (t,v,m)) -> (n, (well_formed_typ benv t, v, m))) ps in let rt = well_formed_typ benv rt in let ft = FunT (i, nts, (rs,ss), map snd ps, (rt,rv,rm)) in let newfn = if (fn = "main" || env.extern) then fn else sprintf "%s_%s" fn (typ2mangled_name ft) in let fwd = FunFwdD (i, fn, nts, (rs,ss), ps, (rt,rv,rm)) in let fv = Cpp_ast.VarE newfn in let ps = map (fun (n,t) -> (n, cvt_exp_typ benv t)) ps in let rt = cvt_exp_typ benv (rt,rv,rm) in let env = env_add_ovld i env fn (VarB (fv, ft, Constant, FwdDecl)) in if rs = [] then ([Cpp_ast.FunFwdD (newfn, ps, rt)], fwd, env) else let ds = make_dict_params nts i rs in let rt_cpp = cvt_typ env ft in ([Cpp_ast.FunFwdD (newfn, ds, rt_cpp)], fwd, env) | ExternFunFwdD (i, lang, fn, ts, rs, ps, (rt,rv,rm)) -> if not (distinct ts) then error i "Duplicated type parameters."; let nts = map (fun t -> uniquify_name t) ts in (* process rs? -Jeremy *) let benv = { env with tparams = (combine_tps ts nts) @ env.tparams } in let pst = map (fun (_,(t,v,m)) -> (well_formed_typ benv t, v, m)) ps in let rt = well_formed_typ benv rt in let ft = FunT (i, ts, rs, pst, (rt,rv,rm)) in let fv = Cpp_ast.VarE fn in let env = env_add_ovld i env fn (VarB (fv, ft, Constant, FwdDecl)) in let fwd = ExternFunFwdD (i, lang, fn, nts, rs, combine (map fst ps) pst, (rt,rv,rm)) in ([Cpp_ast.ExternFunFwdD (lang, fn, combine (map fst ps) (map (cvt_exp_typ benv) pst), cvt_exp_typ benv (rt,rv,rm))], fwd, env) | PrimD (i, p, ts, ps, (rt,rv,rm)) -> if not (distinct ts) then error i "Duplicated type parameters."; let benv = { env with tparams = (combine_tps ts ts)@ env.tparams } in let pst = map (fun (_,(t,v,m)) -> (well_formed_typ benv t, v, m)) ps in let rt = well_formed_typ benv rt in let ft = FunT (i, ts, ([],[]), pst, (rt,rv,rm)) in let env = env_add_prim_ovld i env p (VarB (Cpp_ast.PrimE p, ft, Constant, Defn)) in let fwd = PrimD (i, p, ts, combine (map fst ps) pst, (rt,rv,rm)) in ([], fwd, env) | StructFwdD (i, sn, ts, w) -> if not (distinct ts) then error i "Duplicated type parameters."; let env = {env with classes= (sn,(ts,w, [],[]))::env.classes} in ([Cpp_ast.ClassFwdD sn], StructFwdD (i, sn, ts, w), env) | ClassFwdD (i, sn, ts, w) -> if not (distinct ts) then error i "Duplicated type parameters."; let env = {env with classes= (sn,(ts, w,[],[]))::env.classes} in ([Cpp_ast.ClassFwdD sn], ClassFwdD (i, sn, ts, w), env) | UnionFwdD (i, sn, ts, w) -> if not (distinct ts) then error i "Duplicated type parameters."; let env = {env with unions= (sn,(ts, w,[],[]))::env.unions} in ([Cpp_ast.ClassFwdD sn], UnionFwdD (i, sn, ts, w), env) | TypedefD (i, n, t) -> (* extend the environment with n == t *) let t = well_formed_typ env t in let env = { env with tparams = (n,VarT (i,n))::env.tparams } in let env = extend_env_with_same_types env [(VarT (i,n),t)] in ([], TypedefD (i, n, t), env) | StructD (i, sn, ts, w, ms) -> (* Construct the corresponding class in G, then call the typechecker to translate to C++. *) let (rs,sms) = w in let (menv, nts, rs, sms) = process_generic_intro i env ts rs sms in let s_typ = ClassT (i,sn, map (fun n -> VarT (i,n)) ts) in let class_typ = ClassT (i,sn, map (fun n -> VarT (i,n)) nts) in let menv = { menv with classes= (sn,(nts,(rs,sms),[],[]))::menv.classes } in let ms2 = map (fun (n,t) -> (n, well_formed_typ menv t)) ms in let fwd = StructD (i, sn, nts, (rs,sms), ms2) in let make_default = for_all (type_has_default_cons i menv) (map snd ms2) in let make_copy = for_all (type_has_copy_cons i menv) (map snd ms2) in let make_assign = for_all (type_has_assign i menv) (map snd ms2) in if debug then printf "in StructD %s, make_copy? %b\n" sn make_copy; let default_cons = if make_default then [(i, [], empty_where, [], [], CompoundS (i,[]))] else [] in let copy_cons = if make_copy then [(i, [], empty_where, [("other", (s_typ,Lvalue,Constant))], map (fun (n,t) -> (n, [MemE (i, VarE (i, "other"), n)])) ms, CompoundS (i,[]))] else [] in let init_cons = if ms = [] then (* No initialization constructor needed *) [] else [(i, [], empty_where, map (fun (n, t) -> (n, (t,Lvalue,Constant))) ms, map (fun (n,t) -> (n, [VarE (i, n)])) ms, CompoundS (i,[]))] in let dest = CompoundS (i, []) in let cs = default_cons @ copy_cons @ init_cons in let class_decl = ClassD (i, sn, ts, w, ms, cs, dest) in if debug then printf "In StructD, type checking generated class\n"; let (class_ds,_,env) = typecheck_decl make_defs env class_decl in let assign_op = FunD (i, "__assign", false, ts, w, [("me", (s_typ,Lvalue,Mutable)); ("other", (s_typ,Lvalue,Constant))], (s_typ,Lvalue,Mutable), CompoundS (i, map (fun (mn,mt) -> ExprS (i, ApplyE (i, VarE (i, "__assign"), [MemE (i, VarE (i, "me"), mn); MemE (i, VarE (i, "other"), mn)]))) ms)) in if debug then printf "In StructD %s, type checking generated assignment operator\n" sn; let (assign_ds,env) = if make_assign then let (ds,_,env) = typecheck_decl make_defs env assign_op in (ds,env) else ([], env) in if debug then printf "In StructD %s, generating default cons\n" sn; let (dc_model, env) = if make_default && make_copy then let (ds,_,env) = create_model_default_cons make_defs i env class_typ nts (rs,sms) in (ds,env) else ([],env) in if debug then printf "In StructD %s, generating regular\n" sn; let (reg_model, env) = if make_copy && make_assign then let (ds,_,env) = create_model_regular make_defs i env class_typ nts (rs,sms) in (ds,env) else ([], env) in (class_ds @ assign_ds @ dc_model @ reg_model, fwd, env) (* Class and union example: class foo where { Cmp } { foo(T x) : x(x) { } foo(foo other) : x(other.x) { } ~foo() { if (x < x) { } else { } } T x; }; becomes struct foo { foo(any_c_r x, Cmp* Cmp_T) : x(x), Cmp_T(Cmp_T) { } foo(const foo& other, Cmp* Cmp_T) : x(other.x), Cmp_T(Cmp_T) { } ~foo() { if (Cmp_T->__less(x,x)) { } else { } } any x; Cmp* Cmp_T; }; and union blah where { Cmp } { foo zow; int wob; }; becomes struct blah { enum e_blah { zow, wob }; e_blah tag; union { foo* zow; int wob; } u; blah() { } /* for allocating arrays */ /* No explicit default constructor */ blah(const blah& other, Eq* Eq_T, Cmp* Cmp_U) : tag(other.tag), Eq_T(Eq_T), Cmp_U(Cmp_U) { switch(tag) { case zow: u.zow = new foo( *other.u.zow ); break; case wob: u.wob = other.u.wob; break; }; } blah(const foo& zow_p, Eq* Eq_T, Cmp* Cmp_U) : tag(zow), Eq_T(Eq_T), Cmp_U(Cmp_U) { u.zow = new foo(zow_p, Cmp_U); } blah(const int& wob_p, Eq* Eq_T, Cmp* Cmp_U) : tag(wob), Eq_T(Eq_T), Cmp_U(Cmp_U) { u.wob = wob_p; } ~blah() { switch (tag) { case zow: delete u.zow; break; case wob: /* do nothing */ break; }; } }; *) | UnionD (i, un, ts, w, ms) -> if not (distinct ts) then error i "Duplicated type parameters."; let (rs,sms) = w in let (menv, nts, rs, sms) = process_generic_intro i env ts rs sms in let menv = { menv with unions= (un,(nts,empty_where,[],[]))::menv.unions } in (* make sure member types are well formed *) let ms = map (fun (n,t) -> (n, well_formed_typ menv t)) ms in let fwd = UnionD (i, un, nts, (rs,sms), ms) in let ct = ClassT (i,un,map (fun t -> VarT (i,t)) nts) in let cons_info = FunT (i, [], empty_where, [(ct, Lvalue, Constant)], (* Copy Constructor *) (ct, Rvalue, Mutable)) ::(map (fun (n,t) -> (* Member Initialization Constructors *) FunT (i, [], empty_where, [(t, Lvalue, Constant)], (ct, Rvalue, Mutable))) ms) in let menv = {menv with unions= (un,(nts,(rs,sms),[],cons_info))::menv.unions} in (* Generate the C++ translation *) let enum = Cpp_ast.Enum (sprintf "e_%s" un, map (fun (n,t) -> n) ms) in let tag_field = Cpp_ast.Field ("tag", Cpp_ast.ClassT (sprintf "e_%s" un)) in let union_field = Cpp_ast.Field ("u", Cpp_ast.UnionT (map (fun (n,t) -> let t = cvt_typ menv t in if Cpp_ast.pod t then (n, t) else (n, Cpp_ast.PtrT t)) ms)) in (* Can't put unions in arrays :( Not default constrible :( let default_cpp = Cpp_ast.Constructor (-1, [], [], Cpp_ast.CompoundS []) in *) let dict_params = make_dict_params nts i rs in let dict_inits = (map (fun (n,_) -> (n, [Cpp_ast.VarE n])) dict_params) in (* The Copy Constructor *) let copy_cpp = let params = [("other", Cpp_ast.RefT (Cpp_ast.ConstT (Cpp_ast.ClassT un)))] in let inits = ("tag", [Cpp_ast.MemE (Cpp_ast.VarE "other", "tag")]) ::(map (fun (n,_) -> (n, [Cpp_ast.MemE (Cpp_ast.VarE "other", n)])) dict_params) in (* TODO: put the switch statement in the body to copy the member -JGS *) Cpp_ast.Constructor (-1, params, inits, Cpp_ast.CompoundS [Cpp_ast.SwitchS (Cpp_ast.VarE "tag", Cpp_ast.CompoundS (map (fun (n,t) -> let other_mem = Cpp_ast.MemE (Cpp_ast.MemE (Cpp_ast.VarE "other", "u"), n) in let orig_other_mem = MemE (i, MemE (i, VarE (i,"other"), "u"), n) in let orig_other_deref_mem = ApplyE (i, PrimE (i,DerefP), [orig_other_mem]) in let other_deref_mem = Cpp_ast.ApplyE (Cpp_ast.PrimE DerefP, [other_mem]) in let mem = Cpp_ast.MemE (Cpp_ast.VarE "u", n) in let deref_mem = Cpp_ast.ApplyE (Cpp_ast.PrimE DerefP, [mem]) in let mem_alloc = if pod t then Cpp_ast.CompoundS [] else Cpp_ast.ExprS (Cpp_ast.ApplyE (Cpp_ast.PrimE AssignP, [mem; Cpp_ast.NewE (Heap, cvt_typ menv t, [])])) in Cpp_ast.CaseS (Cpp_ast.VarE n, Cpp_ast.CompoundS [ mem_alloc; Cpp_ast.ExprS (Cpp_ast.ApplyE (Cpp_ast.PrimE AssignP, [if pod t then mem else deref_mem; if pod t then (* other.u.wob *) other_mem else (* new foo( *other.u.zow ) *) (if debug then printf "UnionD copy_cpp, about to typecheck_new\n"; let (e,_) = typecheck_new i Rvalue menv Stack t [orig_other_deref_mem] [(other_deref_mem, (t, Lvalue, Constant))] in e)])); Cpp_ast.BreakS] )) ms))]) in if debug then printf "UnionD, finished copy_cpp\n"; (* Member initializing constructors *) let mem_cons_cpp = map2 (fun (n,t) k -> let t_cpp = cvt_typ menv t in let np = sprintf "%s_p" n in let menv = { menv with local_vars = (np, VarB (Cpp_ast.VarE np, t, Constant, Defn))::menv.local_vars } in let params = (np, Cpp_ast.RefT (Cpp_ast.ConstT t_cpp))::dict_params in let inits = dict_inits @ [("tag", [Cpp_ast.VarE n])] in let mem = Cpp_ast.MemE (Cpp_ast.VarE "u", n) in let deref_mem = Cpp_ast.ApplyE (Cpp_ast.PrimE DerefP, [mem]) in let mem_alloc = if pod t then [] else [Cpp_ast.ExprS (Cpp_ast.ApplyE (Cpp_ast.PrimE AssignP, [mem; Cpp_ast.NewE (Heap, cvt_typ menv t, [])]))] in let mem_assign = if debug then printf "UnionD mem_cons_cpp, about to type check\n"; let rhs = let (e,_) = typecheck_exp Rvalue menv (NewE (i, Stack, t, [VarE (i,np)])) in e in [Cpp_ast.ExprS (Cpp_ast.ApplyE (Cpp_ast.PrimE AssignP, [if pod t then mem else deref_mem; rhs]))] in let body = Cpp_ast.CompoundS (mem_alloc @ mem_assign) in Cpp_ast.Constructor (k + 1, params, inits, body)) ms (iota (length ms))in if debug then printf "UnionD, finished mem_cons_cpp\n"; (* Destructor *) let dest = Cpp_ast.Destructor (Cpp_ast.CompoundS [Cpp_ast.SwitchS (Cpp_ast.VarE "tag", Cpp_ast.CompoundS (map (fun (n,t) -> if pod t then Cpp_ast.CaseS (Cpp_ast.VarE n, Cpp_ast.BreakS) else Cpp_ast.CaseS (Cpp_ast.VarE n, Cpp_ast.CompoundS [Cpp_ast.ExprS (Cpp_ast.ApplyE (Cpp_ast.PrimE DeleteP, [Cpp_ast.MemE (Cpp_ast.VarE "u", n)])); Cpp_ast.BreakS])) ms))]) in (* Generate the union's C++ declaration *) let env = {env with unions= (un,(nts,(rs,sms),ms,cons_info))::env.unions} in let ct = ClassT (i, un, map (fun t -> VarT (i, t)) nts) in let union_decl = Cpp_ast.ClassD (un, [], (map (fun (n,t) -> Cpp_ast.Field (n,t)) dict_params) @ [enum; tag_field; union_field; copy_cpp] @ mem_cons_cpp @ [dest]) in (* Generate an assignment operator for the union. *) let assign_t = FunT (i, nts, (rs,sms), [(ct, Lvalue, Mutable); (ct,Lvalue,Constant)], (ct, Lvalue, Mutable)) in let assign_name = sprintf "__assign_%s" (typ2mangled_name assign_t) in let assign_v = Cpp_ast.VarE assign_name in let env = env_add_ovld i env "__assign" (VarB (assign_v, assign_t, Constant, Defn)) in let assign_decl = let params = [("me", cvt_exp_typ env (ct, Lvalue, Mutable)); ("other", cvt_exp_typ env (ct,Lvalue,Constant))] in let rt = cvt_exp_typ env (ct, Lvalue, Mutable) in (* Also copy over the dictionaries!! -JGS *) let body = Cpp_ast.CompoundS ( [Cpp_ast.SwitchS (* Delete the current value *) (Cpp_ast.MemE (Cpp_ast.VarE "me", "tag"), Cpp_ast.CompoundS (map (fun (n,t) -> if pod t then Cpp_ast.CaseS (Cpp_ast.ScopedE [un;n], Cpp_ast.BreakS) else Cpp_ast.CaseS (Cpp_ast.ScopedE [un;n], Cpp_ast.CompoundS [Cpp_ast.ExprS (Cpp_ast.ApplyE (Cpp_ast.PrimE DeleteP, [Cpp_ast.MemE (Cpp_ast.MemE (Cpp_ast.VarE "me", "u"), n)])); Cpp_ast.BreakS])) ms)); (* Copy the tag *) Cpp_ast.ExprS (Cpp_ast.ApplyE (Cpp_ast.PrimE AssignP, [Cpp_ast.MemE (Cpp_ast.VarE "me", "tag"); Cpp_ast.MemE (Cpp_ast.VarE "other", "tag")])); (* Copy over the new value *) Cpp_ast.SwitchS (Cpp_ast.MemE (Cpp_ast.VarE "me", "tag"), Cpp_ast.CompoundS (map (fun (n,t) -> let other_mem = Cpp_ast.MemE (Cpp_ast.MemE (Cpp_ast.VarE "other", "u"), n) in let other_deref_mem = Cpp_ast.ApplyE (Cpp_ast.PrimE DerefP, [other_mem]) in let mem = Cpp_ast.MemE (Cpp_ast.MemE (Cpp_ast.VarE "me", "u"), n) in let deref_mem = Cpp_ast.ApplyE (Cpp_ast.PrimE DerefP, [mem]) in let mem_alloc = if pod t then Cpp_ast.CompoundS [] else Cpp_ast.ExprS (Cpp_ast.ApplyE (Cpp_ast.PrimE AssignP, [mem; Cpp_ast.NewE (Heap, cvt_typ menv t, [])])) in Cpp_ast.CaseS (Cpp_ast.ScopedE [un;n], Cpp_ast.CompoundS [ mem_alloc; Cpp_ast.ExprS (Cpp_ast.ApplyE (Cpp_ast.PrimE AssignP, [if pod t then mem else deref_mem; if pod t then (* other.u.wob *) other_mem else (* new foo( *other.u.zow ) *) (if debug then printf "UnionD copy_cpp, about to typecheck_new\n"; let (e,_) = typecheck_new i Rvalue menv Stack t [] [(other_deref_mem, (t, Lvalue, Constant))] in e)])); Cpp_ast.BreakS] )) ms))]) in if dict_params = [] then Cpp_ast.FunD (assign_name, params, rt, body) else let dict_inits = map (fun (n,t) -> (n, (Cpp_ast.VarE n, t))) dict_params in let rt_cpp = cvt_typ env assign_t in let ft_cpp = Cpp_ast.FunT (map snd dict_params, rt_cpp) in let f = Cpp_ast.FunE (params, rt, (assign_name, (Cpp_ast.VarE assign_name, ft_cpp))::dict_inits, body) in Cpp_ast.FunD (assign_name, dict_params, rt_cpp, Cpp_ast.CompoundS [Cpp_ast.ReturnS (Some f)]) in (* Unions are not default constructible, but they are copy constructible *) let (model_regular, _,env) = create_model_regular make_defs i env ct nts (rs,sms) in ([union_decl; assign_decl] @ model_regular, fwd, env) | ClassD (i, cn, ts, (rs,sms), ms, orig_cs, dest) -> if debug then printf "class decl %s\n" cn; if not (distinct ts) then error i "Duplicated type parameters."; (try (match assoc cn env.classes with (ts,w,[],[]) -> () | _ -> error i (sprintf "There is already a class with name %s defined." cn)) with Not_found -> ()); let fwd = ClassD (i, cn, ts, (rs,sms), ms, orig_cs, dest) in let (menv, nts, rs, sms) = process_generic_intro i env ts rs sms in let menv = { menv with classes= (cn,(nts,(rs,sms),[],[]))::menv.classes } in let ms = map (fun (n,t) -> (n, well_formed_typ menv t)) ms in if debug then printf "well formed constructors?\n"; let cs = map (fun (i,ts,(rs,ss),ps,inits,body) -> let (menv,nts,rs,ss) = process_generic_intro i menv ts rs ss in let ps = map (fun (n,(t,v,m)) -> (n, (well_formed_typ menv t,v,m))) ps in (i,nts,(rs,ss),ps,inits,body)) orig_cs in if debug then printf "building cons_info\n"; let ct = ClassT (i, cn, map (fun t -> VarT (i, t)) nts) in let cons_info = map (fun (i,cts,rs,ps,_,_) -> FunT (i,cts,rs,map snd ps, (ct, Rvalue, Mutable))) cs in let menv = { menv with classes= (cn,(nts,(rs,sms),ms,cons_info))::env.classes } in let class_dict_params = make_dict_params nts i rs in let msb = map (fun (n,t) -> (n, VarB (Cpp_ast.VarE n, t, Mutable, Defn))) ms in let rec has_a_default_cons cs = (match cs with [] -> false | (i,ts,w,[],inits,body)::cs -> true | (i,ts,w,ps,inits,body)::cs -> has_a_default_cons cs) in let has_default_cons = has_a_default_cons cs in let rec has_a_copy_cons cs = (match cs with [] -> false | (i,ts,w,[(_,(ClassT (_,n,_), Lvalue, Constant))],inits,body)::cs when n = cn -> true | (i,ts,w,ps,inits,body)::cs -> has_a_copy_cons cs) in let has_copy_cons = has_a_copy_cons cs in if debug then printf "translating class decl....\n"; (* A real default constructor is needed for array allocation *) let default_cpp = if has_default_cons then (* The -1 tells cpp2str not to add the mtl::int_ to the param list *) [Cpp_ast.Constructor (-1, [], [], Cpp_ast.CompoundS [])] else [] in (* Type check and translate the user-defined constructors *) let cs_cpp = map2 (fun (i, fts,(frs,fss),ps,inits,body) k -> (* this is a lot like typecheck_fun *) (* Well-formed same-types, and extend env. *) let (menv, nfts,frs,fss) = process_generic_intro i menv fts frs fss in (* Well-formed types in the signature *) let ps = map (fun (n, (t,v,m)) -> (n, (well_formed_typ menv t, v, m))) ps in let rt = ClassT (i, cn, map (fun n -> VarT (i, n)) nts) in let ft = FunT (i, nts, (frs,fss), map snd ps, (rt,Rvalue,Mutable)) in let cons_dict_params = make_dict_params nfts i frs in let dict_params = class_dict_params @ cons_dict_params in (* Extend the environment with parameters *) let psn = map (fun (n,_) -> uniquify_name n) ps in let psb = map2 (fun new_n (n,(t,_,m)) -> (n, VarB (Cpp_ast.VarE new_n, t, m, Defn))) psn ps in let menv = {menv with local_vars= psb @ menv.local_vars} in let (is_copy_cons, other_name) = (match (frs,fss, combine psn ps) with ([], [], [(other, (_, (ct2, Lvalue, Constant)))]) when equal_type menv ct ct2 -> if debug then printf "in ClassD, copy constructor!"; (true, other) | _ -> if debug then printf "in ClassD, not a copy constructor!"; (false, "")) in (* Make sure there are no bogus initializer names *) iter (fun (n,_) -> (try let _ = assoc n ms in () with Not_found -> error i (sprintf "%s is not a member of %s" n cn))) inits; (* Type check the initializers *) let inits = map (fun (n,mt) -> (try let orig_es = assoc n inits in if debug then printf "typechecking inits\n"; let es = map (typecheck_exp Rvalue menv) orig_es in if debug then printf "done typechecking init expressions\n"; let (e,_) = typecheck_new i Rvalue menv Stack mt orig_es es in if debug then printf "done typechecking inits\n"; (n, [e]) with Not_found -> let de = NewE (i, Stack, mt, []) in let (de,_) = typecheck_exp Rvalue menv de in (n, [de])) ) ms in let inits = if is_copy_cons then (* get dictionaries from the other *) (map (fun (n,dt) -> (n, [Cpp_ast.MemE (Cpp_ast.VarE other_name, n)])) class_dict_params) @ inits else (* dictionaries are parameters *) (map (fun (n,dt) -> (n, [Cpp_ast.VarE n])) class_dict_params) @ inits in (* Type check the body *) let menv = {menv with local_vars = ("this", VarB (Cpp_ast.VarE "*this", rt, Mutable, Defn)) :: msb @ menv.local_vars} in let (body,_,_) = typecheck_stmt menv (VoidT i, Rvalue, Mutable) body in let params = map2 (fun n (_,t) -> (n, cvt_exp_typ menv t)) psn ps in let params = if is_copy_cons then params else params @ dict_params in let k = if is_copy_cons then -1 else k in Cpp_ast.Constructor (k, params, inits, ss2s body)) orig_cs (iota (length orig_cs)) in if debug then printf "in ClassD, finished translating constructors\n"; let menv = {menv with local_vars= msb @ menv.local_vars} in let (dest,_,_) = typecheck_stmt menv (VoidT i, Rvalue, Mutable) dest in let env = { env with classes= (cn,(nts,(rs,sms),ms,cons_info))::env.classes } in (* Dictionary fields come before normal data members because they have to get initialized first during construction in case they get used in the initialization of a memebr *) let class_decl = Cpp_ast.ClassD (cn, [], (map (fun (n,t) -> Cpp_ast.Field (n,t)) class_dict_params) @ (map (fun (n,t) -> Cpp_ast.Field (n, cvt_typ menv t)) ms) @ default_cpp @ cs_cpp @ [Cpp_ast.Destructor (ss2s dest)]) in ([class_decl], fwd, env) | ConceptD (i, n, ts, assocs, refs, reqs, fs, sames) -> if debug then printf "In ConceptD %s\n" n; if not (distinct ts) then error i "Duplicated type parameters."; (* check that concept not already defined *) (try let _ = assoc n env.concepts in error i (sprintf "Concept %s already defined." n) with Not_found -> ()); let make_dname = (fun ts cn targs -> subdict_member_name cn targs) in (* Similar but slightly different from process_generic_intro *) let orig_models = env.models in let menv = copy_env env in let menv = { menv with tparams = (combine_tps assocs assocs) @ menv.tparams } in let (menv,nts) = env_extend_type_params ts menv in let (menv, refs, ref_models) = collect_models_from_where make_dname true i menv nts refs in let (menv, reqs, req_models) = collect_models_from_where make_dname false i menv nts reqs in let sames = map (fun (s,t) -> (well_formed_typ menv s, well_formed_typ menv t)) sames in let menv = extend_env_with_same_types menv sames in let ms = remove_duplicate_models menv (ref_models @ req_models) in let menv = { menv with models = orig_models } in let menv = fold_left (fun env (cn,targs,dname,dpath) -> if debug then printf "refine/require %s<%s>\n" cn (String.concat ", " (map g2string_typ targs)); let env = env_add_model env cn [] empty_where targs [] dname dpath in env_add_model_ops i env cn targs dname dpath) menv ms in let menv = env_add_assocs_from_refines i menv refs in (* check that types in fs are well formed *) let fs = map (fun (fn, (ft, pns, body)) -> let mangled_fn = sprintf "%s_%s" fn (typ2mangled_name ft) in (fn, (mangled_fn, well_formed_typ menv ft, pns, body))) fs in let fwd_fs = map (fun (fn, (mangled_fn, ft, pns, body)) -> (fn, (ft, pns, body))) fs in (* add the functions to the local environment *) let menv = fold_left (fun menv (fn, (mfn, ft, _, _)) -> env_add_ovld i menv fn (VarB (Cpp_ast.VarE mfn, ft, Constant, Defn))) menv fs in (* check the default bodies *) let fs = map (fun (fn, (mangled_fn, ft, pns, body)) -> (match body with None -> (fn, (mangled_fn, ft, cvt_typ menv ft, pns, None)) | Some body -> (match ft with FunT (_, ts, (rs,sms), ps, rt) -> let ps = combine pns ps in let (_, (ps, rt, body), ft) = typecheck_fun menv (fn, (i, false, ts, (rs,sms), ps, rt, body)) in let ft_cpp = cvt_typ menv ft in (fn, (mangled_fn, ft, ft_cpp, map fst ps, Some body)) | _ -> error i "expected a function type"))) fs in (* check that types in sames are well formed *) let sames = (map (fun (s,t) -> (well_formed_typ menv s, well_formed_typ menv t)) sames) in (* generate the C++ abstract base class *) let fields = (map (fun (n,targs) -> Cpp_ast.Field (subdict_member_name n targs, Cpp_ast.PtrT (Cpp_ast.ClassT n))) refs) @ (map (fun (n,targs) -> Cpp_ast.Field (subdict_member_name n targs, Cpp_ast.PtrT (Cpp_ast.ClassT n))) reqs) in let methods = (map (fun (fn, (mfn, ft, ft_cpp, pns,body)) -> if debug then printf "operation = %s : %s\n" fn (g2string_typ ft); make_concept_virtual_method false i menv mfn ft_cpp pns body) fs) in let cons = Cpp_ast.Constructor (0, map (fun mem -> match mem with Cpp_ast.Field (n,t) -> (n, Cpp_ast.RefT (Cpp_ast.ConstT t)) | _ -> error i "blah") fields, map (fun mem -> match mem with Cpp_ast.Field (n,_) -> (n,[Cpp_ast.VarE n]) | _ -> error i "blah") fields, Cpp_ast.CompoundS []) in let dict_class = Cpp_ast.ClassD (n, [], [cons] @ methods @ fields) in (* Add the concept to the environment *) let env = { env with concepts = (n, (nts, assocs, refs, reqs, fs, sames))::env.concepts } in ([dict_class], ConceptD (i, n, nts, assocs, refs, reqs, fwd_fs, sames), env) | ModelD (i, _, ts, (rs,sms), "DefaultConstructible", [t], [], []) -> if debug then printf "in ModelD, gen DefaultConstructible, model<%s> where { %s } %s\n" (String.concat ", " ts) (String.concat ", " (map (fun (cn,targs) -> sprintf "%s<%s>" cn (String.concat ", " (map g2string_typ targs)) ) rs)) (g2string_typ t); let (menv, nts, rs, sms) = process_generic_intro i env ts rs sms in let t = well_formed_typ_impl false menv t in if debug then printf "in ModelD, gen DefaultConstructible, about to create\n"; let (ds,_,env) = create_model_default_cons make_defs i env t nts (rs,sms) in (ds, ModelD (i, false, nts, (rs,sms), "DefaultConstructible", [t], [], []), env) | ModelD (i, _, ts, (rs,sms), "Regular", [t], [], []) -> if debug then printf "in ModelD, gen Regular\n"; let (menv, nts, rs, sms) = process_generic_intro i env ts rs sms in let t = well_formed_typ_impl false menv t in if debug then printf "in ModelD, gen Regular, about to create\n"; let (ds,_,env) = create_model_regular make_defs i env t nts (rs,sms) in (ds, ModelD (i, false, nts, (rs,sms), "Regular", [t], [], []), env) | ModelD (i, opn, ts, (rs,sms), cn, targs, assocs, fs) -> typecheck_model opn env make_defs i ts rs sms cn targs assocs fs | ModelFwdD (i, opn, ts, (rs,sms), cn, targs, assocs) -> typecheck_model opn env false i ts rs sms cn targs assocs [] | IncludeD (i, fn) -> if mem fn !loaded_files then ([], IncludeD (i, fn), env) else (loaded_files := fn::!loaded_files; let f = open_out "tmp.i" in output_string f (sprintf "%%module %s\n#include <%s>\n" (Filename.chop_extension fn) fn); close_out f; let _ = Unix.system (sprintf "%s/swig -cpperraswarn -I/usr/include -I%s/Lib -g -includeall tmp.i > /dev/null 2>&1" !Parser_misc.swig_dir !Parser_misc.swig_dir) in let ids = Parser_misc.parseFile "tmp_wrap.g" in let (ids,_,env) = typecheck_decls false env ids in ([Cpp_ast.IncludeD fn], IncludeD (i, fn), env)) | UseD (i, fn) -> (* Add call to m4! -Jeremy *) if mem fn !loaded_files then ([], EmptyD, env) else (loaded_files := fn::!loaded_files; let real_fn = Parser_misc.findfile fn in let fn_sans_ext = Filename.chop_extension real_fn in let lds = Parser_misc.parseFile (sprintf "%s.fwd" fn_sans_ext) in if debug then printf "finished parsing %s\n" fn_sans_ext; let (ds,_,env) = typecheck_decls false env lds in (ds, UseD (i,fn), env)) | OvldD (i, fn, VarE (j, fn2)) -> let b = lookup fn2 env in let env = env_add_ovld i env fn b in ([], OvldD (i, fn, VarE (j, fn2)), env) | OvldD (i, fn, PrimE (j, p)) -> let b = (try assoc p env.prims with Not_found -> error i (sprintf "undefined primitive: %s" (prim2str p))) in let env = env_add_ovld i env fn b in ([], OvldD (i, fn, PrimE (j, p)), env) | OvldD (i, fn, e) -> error i "Only variables or primitives allowed in overload, not arbitrary expressions" | ImportD (i,_,_,_) -> error i "import unhandled" | ModuleD (i,_,_,_,_) -> error i "module unhandled" | PublicD i -> error i "public unhandled" | PrivateD i -> error i "private unhandled" ) and ss2s ss = (match ss with [s] -> s | _ -> Cpp_ast.CompoundS ss) and make_var_typ t_cpp tv tm = (match (tv,tm) with (Rvalue,_) -> (* Ok to copy, and solved the delete0.g bug *) t_cpp | (Lvalue,Constant) -> (match t_cpp with Cpp_ast.AnyT -> Cpp_ast.AnyConstRefT | Cpp_ast.AnyPtrT -> Cpp_ast.AnyPtrConstRefT | Cpp_ast.AnyConstPtrT -> Cpp_ast.AnyConstPtrConstRefT | _ -> Cpp_ast.RefT (Cpp_ast.ConstT t_cpp)) | (Lvalue,Mutable) -> (match t_cpp with Cpp_ast.AnyT -> Cpp_ast.AnyRefT | Cpp_ast.AnyPtrT -> Cpp_ast.AnyPtrRefT | Cpp_ast.AnyConstPtrT -> Cpp_ast.AnyConstPtrRefT | _ -> Cpp_ast.RefT t_cpp)) and typecheck_stmt (env : environment) (rt : exp_typ) (s : stmt) : (Cpp_ast.stmt list * (exp_typ * info) list (* all the return types *) * environment) = (match s with TypedefS (i, n, t) -> (* extend the environment with n == t *) let t = well_formed_typ env t in let env = { env with tparams = (n,VarT (i,n))::env.tparams } in let env = extend_env_with_same_types env [(VarT (i,n),t)] in ([], [], env) | LetS (i, _, n, e) -> let (e,(t,tv,tm)) = typecheck_exp Rvalue env e in if debug then printf "let %s : %s\n" n (g2string_typ t); let n2 = uniquify_name n in let v = Cpp_ast.VarE n2 in let t_cpp = cvt_typ env t in let t_cpp = make_var_typ t_cpp tv tm in ([Cpp_ast.VarS (t_cpp, n2, e)], [], {env with local_vars=(n,VarB(v,t,tm,Defn))::env.local_vars}) | ExprS (i, e) -> let (e,(t,_,_)) = typecheck_exp Rvalue env e in ([Cpp_ast.ExprS e], [], env) | ReturnS (i, None) -> (match rt with (VoidT _, _, _) -> ([Cpp_ast.ReturnS None], [], env) | _ -> error i (sprintf "Must return a value of tyep %s\n" (g2string_exp_typ rt))) | ReturnS (i, Some e) -> let (rtt,rvk,_) = rt in (* type check copy for return by value *) if debug then printf "type checking return expression of type %s\n" (g2string_exp_typ rt); (match rvk with Rvalue -> let newe = NewE (i, Stack, rtt, [e]) in (* This gives a horrible error message! -Jeremy *) let _ = typecheck_exp rvk env newe in () | Lvalue -> ()); let (e,t) = typecheck_exp rvk env e in (match (t,rt) with ((_, Rvalue, _), (_, Lvalue, _)) -> error i "A temporary may not be returned by reference." | _ -> ()); if debug then printf "checking return\n"; (match rtt with VoidT _ -> ([Cpp_ast.ReturnS (Some e)], [(t,i)], env) | _ -> if subtype env t rt then let (rtt,_,_) = rt in ([Cpp_ast.ReturnS (Some (coerce_poly env i t e rtt))], [(t,i)], env) else error i (sprintf "Return type (%s) does not match declared return type (%s)." (g2string_exp_typ t) (g2string_exp_typ rt))) | IfS (i, c, els, thn) -> let (c,ct) = typecheck_exp Rvalue env c in let (els,rt1,_) = typecheck_stmt env rt els in let (thn,rt2,_) = typecheck_stmt env rt thn in if subtype env ct (BoolT i, Lvalue, Constant) then ([Cpp_ast.IfS (c, ss2s els, ss2s thn)], rt1@rt2, env) else error i "Conditional expression must be convertible to bool" | WhileS (i, c, body) -> let (c,ct) = typecheck_exp Rvalue env c in let (body,rs,_) = typecheck_stmt env rt body in if subtype env ct (BoolT i, Lvalue, Constant) then ([Cpp_ast.WhileS (c, ss2s body)], rs, env) else error i "Conditional expression must be convertible to bool" | CompoundS (i, ss) -> (* let rec loop env ss = match ss with [] -> ([],[],env) | s::ss -> let (s,rs1,env) = typecheck_stmt env rt s in let (ss, rs2, env) = loop env ss in (s::ss, rs1@rs2, env) in let (ss,rs,env) = loop env ss in *) let (ss,rs,env) = fold_left (fun (ss,rs,env) s -> let (s,rs1,env) = typecheck_stmt env rt s in (ss@[s], rs@rs1,env)) ([],[],env) ss in ([Cpp_ast.CompoundS (concat ss)], rs, env) (* Example switch statement switch (get_blah()) { case zow: zow = foo(3); case wob: wob = wob * 2; }; translates to { blah& __blah = (blah&)get_blah(); switch (__blah.tag) { case blah::zow: { foo& zow = __blah.u.zow; zow = foo(3, ...); break; } case blah::wob: { int& wob = __blah.u.wob; wob = wob + 2; break; } }; } *) | SwitchS (i, c, cs) -> let (c,(ct,cv,cm)) = typecheck_exp Rvalue env c in (match ct with ClassT (_, n, targs) -> (try let (ts,(rs,sms),ms,_) = assoc n env.unions in let sub = combine ts targs in (* Check that there is a case for each member of the union *) iter (fun (m,t) -> try let _ = assoc m cs in () with Not_found -> (try let _ = assoc "default" cs in () with Not_found -> error i (sprintf "Switch is lacking a case for the %s member of the union %s." m n))) ms; let uv = uniquify_name n in let rs = ref [] in let cs = map (fun (m,s) -> let m2 = sprintf "__%s" m in let ot = assoc m ms in let t = subst_typ sub ot in let env = {env with local_vars= (m, VarB (Cpp_ast.VarE m2, t, cm, Defn))::env.local_vars } in let (ss,rs2,st) = typecheck_stmt env rt s in rs := !rs@rs2; let e = Cpp_ast.MemE (Cpp_ast.MemE (Cpp_ast.VarE uv, "u"), m) in let e = if pod ot then e else Cpp_ast.ApplyE (Cpp_ast.PrimE DerefP, [e]) in let e = coerce_poly env i (ot, Lvalue, cm) e t in Cpp_ast.CaseS (Cpp_ast.ScopedE [n;m], Cpp_ast.CompoundS ([Cpp_ast.VarS (make_var_typ (cvt_typ env t) Lvalue cm, m2, e)] @ ss @ [Cpp_ast.BreakS]))) cs in let ct_cpp = cvt_typ env ct in ([Cpp_ast.CompoundS [Cpp_ast.VarS (make_var_typ ct_cpp cv cm , uv, c); Cpp_ast.SwitchS (Cpp_ast.MemE (Cpp_ast.VarE uv, "tag"), Cpp_ast.CompoundS cs)]], !rs, env) with Not_found -> error i (sprintf "Undefined union %s." n)) | _ -> error i "Expected a union.") | _ -> error UNKNOWN "unhandled stmt") and apply_function vk env i orig_f f ft orig_args args argtys : (Cpp_ast.exp * exp_typ) = if debug then printf "apply_function %s\n" (g2string_exp orig_f); (match ft with FunT (_, ts, (rs,ss), ps, (rt,rv,rm)) -> let nts = map (fun t -> uniquify_name t) ts in let rename = combine ts (map (fun nt -> VarT (i, nt)) nts) in let rs = map (fun (cn,targs) -> let targs = map (subst_typ rename) targs in (cn,targs)) rs in let ss = map (fun (s,t) -> (subst_typ rename s, subst_typ rename t)) ss in let params = map (fun (t,v,m) -> (subst_typ rename t, v, m)) ps in let rt = subst_typ rename rt in if debug then (printf "!!!! Deducing type args\n"; printf "Parameter types are (%s)\n" (String.concat ", " (map g2string_exp_typ params)); printf "Argument types are (%s)\n" (String.concat ", " (map g2string_exp_typ argtys)) ); (try let (sub2, _, _, env) = subtype_unify_list false nts i env [] argtys (map fst args) params in if debug then (printf "Deduced type args: "; iter (fun (n,t) -> printf "%s: %s, " n (g2string_typ t)) sub2; printf "\n"); (* add dictionaries to the argument list, get same type constraints from models *) let rs = map (fun (cn,targs) -> (cn, map (subst_typ sub2) targs)) rs in let (ds,env) = (try lookup_dictionaries i rs env 0 with No_matching_model msg -> error i (sprintf "In application %s(%s),\n%s" (g2string_exp orig_f) (String.concat ", " (map g2string_exp orig_args)) msg)) in (* Check the same type constraints *) let ss = map (fun (s,t) -> (subst_typ sub2 s, subst_typ sub2 t)) ss in iter (fun (s,t) -> if not (equal_type env s t) then error i (sprintf "Same type requirement violated, %s != %s" (typ2str env s) (typ2str env t)) else ()) ss; (* check that the solution works for the non-deducible contexts (like accesses to associated types) *) let (_, args, _, _) = subtype_unify_list true nts i env [] argtys (map fst args) params in (* check that sub2 has a solution for each variable *) let targs = map (fun t -> (try assoc t sub2 with Not_found -> (match get_canonical env (VarT (i,t)) with VarT (_,s) -> error i (sprintf "Could not deduce type parameter %s, canonical %s" t s) | AssocT _ -> error i (sprintf "Could not deduce type parameter %s" t) | t -> t))) nts in (* need to check that sub2 only has substitutions for the right variables -JGS *) iter (fun (n,t) -> if (mem n nts) then () else error i (sprintf "Type variable %s can not match type %s." n (g2string_typ t))) sub2; let f = if (ds = []) then f else (if debug then printf "applying dictionary arguments\n"; Cpp_ast.ApplyE (f, ds)) in let app = Cpp_ast.ApplyE (f, args) in if debug then printf "srt: %s\n" (g2string_typ (subst_typ sub2 rt)); let srt = get_canonical env (subst_typ sub2 rt) in if debug then printf "rt: %s --> srt: %s\n" (g2string_typ rt) (g2string_typ srt) ; print_graph env.type_graph; print_reps env.type_reps; let app = (match f with Cpp_ast.PrimE _ -> app | _ -> coerce_poly env i (rt,rv,rm) app srt) in if debug then printf "finished apply_function %s\n" (g2string_exp orig_f); (app, (srt, rv, rm)) with Unify_failure m -> error i (sprintf "In application %s(%s), argument/parameter mismatch.\n%s\n%s\n%s" (g2string_exp orig_f) (String.concat ", " (map g2string_exp orig_args)) (sprintf "Parameter types are (%s)" (String.concat ", " (map g2string_exp_typ params))) (sprintf "Argument types are (%s)" (String.concat ", " (map g2string_exp_typ argtys))) m)) | _ -> error i "apply_function: expected a function type.") (* Type check a union creation expression. *) and process_union env vk i a cn targs mn arg : (Cpp_ast.exp * exp_typ) = let (arg,argt) = typecheck_exp vk env arg in let (ts,(rs,sms),mts,_) = (try assoc cn env.unions with Not_found -> error i (sprintf "Union %s is not defined." cn)) in let (t,k) = (try assoc mn (map2 (fun (n,t) k -> (n,(t,k))) mts (iota (length mts))) with Not_found -> error i (sprintf "Member %s is not in the union %s" mn cn)) in let targs = map (well_formed_typ env) targs in let sub = combine ts targs in let nt = subst_typ sub t in if (subtype env argt (nt,Lvalue,Constant)) then let rt = (match a with Stack -> ClassT (i,cn,targs) | Heap -> PtrT (i, ClassT (i,cn,targs)) | GCHeap -> PtrT (i, ClassT (i,cn,targs))) in if debug then printf "creating object of union %s\n" cn; let rs = map (fun (cn,targs) -> (cn, map (subst_typ sub) targs)) rs in let (ds,env) = (try lookup_dictionaries i rs env 0 with No_matching_model msg -> error i msg) in (Cpp_ast.ClassE (a, cn, k + 1, (* add one since the copy constructor is in position zero *) (coerce_poly env i argt arg t)::ds), (rt, Rvalue, Mutable)) else let (argt,_,_) = argt in error i (sprintf "Union argument type (%s) does not match type (%s) of member %s" (g2string_typ argt) (g2string_typ nt) mn) and combine_returns i env rs = (match rs with [] -> (VoidT i, Rvalue, Mutable) | r::rs -> let rec loop ((r1,v1,m1),i) rs = (match rs with [] -> (r1,v1,m1) | ((r2,v2,m2),j)::rs -> if equal_type env r1 r2 && v1 = v2 && m1 = m2 then loop ((r1,v1,m1), i) rs else errf (fun() -> print_string "Error: return types not equal "; printInfo i; print_string " and "; printInfo j; print_newline())) in loop r rs) and translate_sizeof i t vk env = (match t with VarT _ | AssocT _ | PtrT (_, VarT _) | PtrT (_, AssocT _) -> (* polymorphic, go through SizeOf concept *) let f = ModelMemE (i, "SizeOf", [t], "size_of") in let e = ApplyE (i, f, []) in let (e,_) = typecheck_exp vk env e in e | _ -> Cpp_ast.SizeofE (cvt_typ env t)) and typecheck_new i vk env a t orig_args args = (match t with VarT _ | AssocT _ | PtrT (_, VarT _) | PtrT (_, AssocT _) -> (* polymorphic, go through DefaultConstructible or Regular concept *) if length args = 0 then let mem = (match a with Stack -> "new_on_stack" | Heap -> "new_on_heap" | GCHeap -> "new_on_gc") in let f = ModelMemE (i, "DefaultConstructible", [t], mem) in let e = ApplyE (i, f, []) in typecheck_exp vk env e else if length args = 1 then let mem = (match a with Stack -> "new_on_stack" | Heap -> "new_on_heap" | GCHeap -> "new_on_gc") in let orig_f = ModelMemE (i, "Regular", [t], mem) in let (f,(ft,_,_)) = typecheck_exp vk env orig_f in typecheck_apply vk env i orig_f f ft orig_args args else error i "wrong number of arguments in call to new" | ClassT (i, cn, targs) -> (* already did this let targs = map (well_formed_typ env) targs in*) let (ts,(class_rs,sms),_,cs) = (try lookup_class cn env with Not_found -> error i (sprintf "Class %s is not defined" cn)) in let sub = combine ts targs in if debug then (printf "constructors = \n"; iter (fun t -> printf "%s\n" (g2string_typ t)) cs); let cs = map (subst_typ sub) cs in if debug then (printf "constructors after subst = \n"; iter (fun t -> printf "%s\n" (g2string_typ t)) cs); let class_rs = map (fun (cn,targs) -> (cn, map (subst_typ sub) targs)) class_rs in let (class_ds,_) = (try lookup_dictionaries i class_rs env 0 with No_matching_model msg -> error i msg ) in let (ft, k) = (try resolve_overload 0 env cs (map snd args) with Ambiguous_overload -> error i (sprintf "Ambiguous constructors for %s(%s)." cn (String.concat ", " (map (fun (e,(t,_,_)) -> g2string_typ t) args))) | No_matching_overload msg -> error i (sprintf "No matching constructor for %s(%s).\n%s" cn (String.concat ", " (map (fun (e,(t,_,_)) -> g2string_typ t) args)) msg)) in if debug then printf "resolved to constructor %s %d = %s\n" cn k (g2string_typ ft); (match ft with FunT (_, ts, (rs,ss), ps, _) -> let (sub, _, _, _) = subtype_unify_list false ts i env [] (map snd args) (map fst args) ps in let rs = map (fun (cn,targs) -> (cn, map (subst_typ sub) targs)) rs in (try let (cons_ds,env) = lookup_dictionaries i rs env 0 in let _ = subtype_unify_list true ts i env [] (map snd args) (map fst args) ps in let rt = (match a with Stack -> ClassT (i,cn,targs) | Heap -> PtrT (i, ClassT (i,cn,targs)) | GCHeap -> PtrT (i, ClassT (i,cn,targs))) in if debug then printf "class type = %s\n" (g2string_typ t); let copy_cons = (match (rs,ss,ps) with ([], [], [(t2, Lvalue, Constant)]) when equal_type env t (subst_typ sub t2) -> if debug then printf "its a copy constructor\n"; true | _ -> if debug then printf "not a copy constructor\n"; false) in let ds = if copy_cons then [] else class_ds @ cons_ds in let k = if copy_cons then -1 else k in (Cpp_ast.ClassE (a, cn, k, (map fst args) @ ds), (rt, Rvalue, Mutable)) with No_matching_model msg -> error i msg) | _ -> error i "expected function type") | _ -> if debug then printf "about to type check primitive new\n" else (); let orig_f = InstE (i, PrimE (i, NewP a), [t]) in let (f,(ft,_,_)) = typecheck_exp vk env orig_f in if debug then printf "prim new = %s\n" (g2string_typ ft); let (_, rt) = typecheck_apply vk env i orig_f f ft orig_args args in (Cpp_ast.NewE (a, cvt_typ env t, map fst args), rt)) and typecheck_placement_new i vk env orig_p (p : Cpp_ast.exp * G_ast.exp_typ) t orig_args args = (match t with VarT _ | AssocT _ | PtrT (_, VarT _) | PtrT (_, AssocT _) -> (* polymorphic, go through DefaultConstructible or Regular *) if length args = 0 then let mem = "new_placement" in let f = ModelMemE (i, "DefaultConstructible", [t], mem) in let e = ApplyE (i, f, [orig_p]) in typecheck_exp vk env e else if length args = 1 then let mem = "new_placement" in let orig_f = ModelMemE (i, "Regular", [t], mem) in let (f,(ft,_,_)) = typecheck_exp vk env orig_f in typecheck_apply vk env i orig_f f ft (orig_p::orig_args) (p::args) else error i "wrong number of arguments in call to new" | ClassT (i, cn, targs) -> (* already did this let targs = map (well_formed_typ env) targs in*) let (ts,(class_rs,sms),_,cs) = (try lookup_class cn env with Not_found -> error i (sprintf "Class %s is not defined" cn)) in let sub = combine ts targs in if debug then (printf "constructors = \n"; iter (fun t -> printf "%s\n" (g2string_typ t)) cs); let cs = map (subst_typ sub) cs in if debug then (printf "constructors after subst = \n"; iter (fun t -> printf "%s\n" (g2string_typ t)) cs); let class_rs = map (fun (cn,targs) -> (cn, map (subst_typ sub) targs)) class_rs in let (class_ds,_) = (try lookup_dictionaries i class_rs env 0 with No_matching_model msg -> error i msg ) in let (ft, k) = (try resolve_overload 0 env cs (map snd args) with Ambiguous_overload -> error i (sprintf "Ambiguous constructors for %s(%s)." cn (String.concat ", " (map (fun (e,(t,_,_)) -> g2string_typ t) args))) | No_matching_overload msg -> error i (sprintf "No matching constructor for %s(%s).\n%s" cn (String.concat ", " (map (fun (e,(t,_,_)) -> g2string_typ t) args)) msg)) in if debug then printf "resolved to constructor %s %d = %s\n" cn k (g2string_typ ft); (match ft with FunT (_, ts, (rs,ss), ps, _) -> let (sub, _, _, _) = subtype_unify_list false ts i env [] (map snd args) (map fst args) ps in let rs = map (fun (cn,targs) -> (cn, map (subst_typ sub) targs)) rs in (try let (cons_ds,env) = lookup_dictionaries i rs env 0 in let _ = subtype_unify_list true ts i env [] (map snd args) (map fst args) ps in let rt = PtrT (i, ClassT (i,cn,targs)) in if debug then printf "class type = %s\n" (g2string_typ t); let copy_cons = (match (rs,ss,ps) with ([], [], [(t2, Lvalue, Constant)]) when equal_type env t (subst_typ sub t2) -> if debug then printf "its a copy constructor\n"; true | _ -> if debug then printf "not a copy constructor\n"; false) in let ds = if copy_cons then [] else class_ds @ cons_ds in let k = if copy_cons then -1 else k in (Cpp_ast.PlacementClassE (fst p, cn, k, (map fst args) @ ds), (rt, Rvalue, Mutable)) with No_matching_model msg -> error i msg) | _ -> error i "expected function type") | _ -> if debug then printf "about to type check primitive new\n" else (); let orig_f = InstE (i, PrimE (i, PlacementNewP), [t]) in let (f,(ft,_,_)) = typecheck_exp vk env orig_f in if debug then printf "prim placement new = %s\n" (g2string_typ ft); let (_, rt) = typecheck_apply vk env i orig_f f ft (orig_p::orig_args) (p::args) in (Cpp_ast.PlacementNewE (fst p, cvt_typ env t, map fst args), rt)) and typecheck_apply vk env i (orig_f : G_ast.exp) (f : Cpp_ast.exp) ft orig_args args = let argtys = map snd args in (match ft with FunT (_, ts, (rs,ss), params, rt) -> apply_function vk env i orig_f f ft orig_args args argtys | OvldT (_,ts) -> (try let (ft,k) = resolve_overload 0 env (map snd ts) argtys in if debug then printf "with args (%s), resolved overload = %s\n" (String.concat ", " (map g2string_exp_typ argtys)) (typ2str env ft); apply_function vk env i orig_f (fst (nth ts k)) (snd (nth ts k)) orig_args args argtys with Ambiguous_overload -> error i (sprintf "Ambiguous overloads for %s with argument types (%s):\n\n%s\n" (g2string_exp orig_f) (String.concat ", " (map (fun (t,_,_) -> g2string_typ t) argtys)) (String.concat "\n\n" (map (fun t -> g2string_typ t) (map snd ts)))) | No_matching_overload msg -> error i (sprintf "No matching overload for %s with argument types (%s).\n\n%s\n" (g2string_exp orig_f) (String.concat ", " (map (fun (t,_,_) -> g2string_typ (get_canonical env t)) argtys)) msg)) | _ -> error i "Attempt to apply a non-function.") (* Need to apply dictionaries Under construction *) and inst_fun i env e t targs = (match t with FunT (j, ts, (rs,ss), ps, (rt,rv,rm)) -> if (length ts = length targs) then let sub = combine ts targs in let rs = map (fun (cn,targs) -> (cn, map (subst_typ sub) targs)) rs in let (ds,_) = lookup_dictionaries i rs env 0 in let f = if (ds = []) then e else Cpp_ast.ApplyE (e, ds) in let new_ft = FunT (j, [], empty_where, map (fun (t,v,m) -> (subst_typ sub t, v, m)) ps, (subst_typ sub rt, rv, rm)) in (coerce_poly env i (t,Rvalue,Constant) f new_ft, (new_ft, Rvalue, Constant)) else raise (TypeParamArgMismatch "Number of type arguments does not match number of type parameters.") | _ -> error i "inst_fun: expected a function type") and typecheck_exp (vk : value_kind) (env : environment) (e : exp) : (Cpp_ast.exp (* the expression translated to C++ *) * exp_typ) (* the type of the expression (in G) *) = let (ec,t) = typecheck_exp_real vk env e in if trace_exp then (printf "typecheck_exp %s : %s\n" (g2string_exp e) (g2string_exp_typ t); flush stdout); (ec,t) and typecheck_exp_real (vk : value_kind) (env : environment) (e : exp) : (Cpp_ast.exp (* the expression translated to C++ *) * exp_typ) (* the type of the expression (in G) *) = match e with NullE i -> (Cpp_ast.NullE, (NullT i, Rvalue, Mutable)) | ThisE i -> (try match (lookup "this" env) with VarB (e,t,m,bk) -> (e, (t, Lvalue, m)) | OvldB ls -> error i "in typecheck_exp, ThisE" with Not_found -> (*printf "%s %s" (String.concat " " (map fst env.vars)) (String.concat " " (map fst env.local_vars));*) error i (sprintf "May not use this outside of a constructor")) | IntE (i, n) -> (Cpp_ast.IntE n, (IntT i, Rvalue, Mutable)) | FloatE (i, n) -> (Cpp_ast.FloatE n, (FloatT i, Rvalue, Mutable)) | DoubleE (i, n) -> (Cpp_ast.DoubleE n, (DoubleT i, Rvalue, Mutable)) | BoolE (i, n) -> (Cpp_ast.BoolE n, (BoolT i, Rvalue, Mutable)) | StringE (i, n) -> (Cpp_ast.StringE n, (PtrT (i, CharT i), Rvalue, Constant)) | CharE (i, n) -> (Cpp_ast.CharE n, (CharT i, Rvalue, Mutable)) | VarE (i, n) -> if debug then printf "type_check: VarE %s\n" n; (try match (lookup n env) with VarB (e,t,m,bk) -> (e, (t, Lvalue, m)) | OvldB ls -> (Cpp_ast.VarE n, (OvldT (i,map (fun (e,t,bk) -> (e,t)) ls), Rvalue, Constant)) with Not_found -> (*printf "%s %s" (String.concat " " (map fst env.vars)) (String.concat " " (map fst env.local_vars));*) error i (sprintf "Variable undefined: %s" n)) | FunE (i, ts, ps, _, inits, body) -> let pst = map (fun (_,(t,v,m)) -> (well_formed_typ env t,v,m)) ps in let psn = map (fun (n,_) -> uniquify_name n) ps in let ps2 = (combine psn pst) in let psb = map2 (fun n (nn,(t,v,m)) -> (n, VarB (Cpp_ast.VarE nn, t, m, Defn))) (map fst ps) ps2 in let inits = map (fun (n, (e,_)) -> let orig_e = e in let (e,t) = typecheck_exp vk env e in let (tt,_,_) = t in let _ = typecheck_new i Rvalue env Stack tt [orig_e] [(e,t)] in (n, (e,t))) inits in let initsb = map (fun (n,(e,(t,v,m))) -> (n, VarB (Cpp_ast.VarE n, t, m, Defn))) inits in let benv = {env with local_vars= psb @ initsb; vars = env.vars; (* copy over the global vars *) models = [] } in let ps = combine psn (map (cvt_exp_typ benv) pst) in let (body, rs, _) = typecheck_stmt benv (VoidT i, Rvalue, Mutable) body in if debug then (printf "return types =\n"; iter (fun (t,i) -> printf "%s\n" (g2string_exp_typ t)) rs); let rt = combine_returns i env rs in let inits = map (fun (n,(e,(t,_,_))) -> (n, (e, cvt_typ benv t))) inits in if debug then printf "Lambda return type = %s\n" (g2string_exp_typ rt); (Cpp_ast.FunE (ps, cvt_exp_typ benv rt, inits, ss2s body), (FunT (i, ts, empty_where, pst, rt), Rvalue, Constant)) | ModelMemE (i, cn, targs, mn) -> let targs = map (well_formed_typ env) targs in let (dict,_) = (try lookup_dictionary false i cn targs env 0 with No_matching_model msg -> error i msg) in if debug then printf "model member finished dict lookup\n"; (try find_model_member i env mn cn targs dict [] with Not_found -> error i (sprintf "Could not find member %s in concept %s" mn cn)) | MemE (i, e, m) -> let (e,(t,evk,em)) = typecheck_exp vk env e in (match t with ClassT (_,cn,targs) -> (try let (ts,_,ms,cs) = assoc cn env.classes in if (length ts) != (length targs) then error i "In MemE: number of type arguments does not match number of type parameters" else (try let omt = assoc m ms in let sub = combine ts targs in let mt = subst_typ sub omt in let me = Cpp_ast.MemE (e, m) in (coerce_poly env i (omt,evk,em) me mt, (mt, Lvalue, em)) (* see poly_struct2.g line 11: f1.x = 20 (match vk with Lvalue -> (me, (mt, Lvalue, em)) | Rvalue -> if true then (coerce_poly env i omt me mt, (mt, Rvalue, em)) else (match omt with PtrT (_, VarT (_, _)) -> (me, (omt, Rvalue, em)) | _ -> (coerce_poly env i omt me mt, (mt, Rvalue, em))) ) *) with Not_found -> error i (sprintf "There is no %s member in class %s." m cn)) with Not_found -> error i (sprintf "Member access: there is no class %s." cn)) | t -> error i (sprintf "The member access (dot) operator may only be applied to classes, not %s." (g2string_typ t))) | PrimE (i, p) -> (try match assoc p env.prims with VarB (e,t,m,bk) -> (Cpp_ast.PrimE p, (t, Lvalue, m)) | OvldB ls -> (Cpp_ast.PrimE p, (OvldT (i,map (fun (e,t,bk) -> (e,t)) ls), Rvalue, Constant)) with Not_found -> error i (sprintf "undefined primitive: %s" (prim2str p))) (* some special cases *) (* I think this is dead code. See DestroyE. -Jeremy Nope, it is not dead code, used in reverse_iterator.g. -Jeremy *) | ApplyE (i, PrimE (_, DestroyP), [e]) -> let (e,(t,v,m)) = typecheck_exp vk env e in (match t with PtrT (_, tt) -> (Cpp_ast.DestroyE (cvt_typ env tt, e), (VoidT i, Rvalue, Mutable)) | _ -> error i (sprintf "destroy may only be applied to a pointer, not %s" (g2string_typ t))) | ApplyE (i, PrimE (_, SizeofP), [e]) -> let (e,(t,v,m)) = typecheck_exp vk env e in (translate_sizeof i t vk env, (IntT i, Rvalue, Mutable)) | SizeofE (i, t) -> let t = get_canonical env (well_formed_typ env t) in (translate_sizeof i t vk env, (IntT i, Rvalue, Mutable)) | ApplyE (i, InstE (_, PrimE (_, CastP), [ct]), [e]) -> let ct = well_formed_typ env ct in let (e,(t,v,m)) = typecheck_exp vk env e in (Cpp_ast.CastE (cvt_typ env ct, e), (ct, v, m)) | ApplyE (i, VarE (_, "__assign"), [lhs; rhs]) -> let orig_args = [lhs; rhs] in let (lhs,lhst) = typecheck_exp vk env lhs in let (rhs,rhst) = typecheck_exp vk env rhs in let (lt,lv,lm) = lhst in let (rt,_,_) = rhst in (* Special case for function objects *) (match (lt,lv,lm) with (FunT _, Lvalue, Mutable) -> if equal_type env lt rt then (Cpp_ast.ApplyE (Cpp_ast.PrimE AssignP, [lhs; rhs]), lhst) else error i (sprintf "Type of right hand side (%s) of assignment does not match left hand side (%s)" (g2string_typ rt) (g2string_typ lt)) | (FunT _, _, Constant) -> error i "Left hand side of assignment is constant. It must be mutable." | (FunT _, Rvalue, _) -> error i "Left hand side of assignment is a temporary. It must be an l-value." | _ -> let orig_f = VarE (i, "__assign") in let (f,(ft,_,_)) = typecheck_exp vk env orig_f in typecheck_apply vk env i orig_f f ft orig_args [(lhs,lhst); (rhs,rhst)]) | ApplyE (i, orig_f, orig_args) -> let args = map (typecheck_exp vk env) orig_args in let (f,(ft,_,_)) = typecheck_exp vk env orig_f in let ret = typecheck_apply vk env i orig_f f ft orig_args args in if debug then printf "finish ApplyE: %s\n" (g2string_exp e); ret | SeqE (i, args) -> if args = [] then error i "empty expression sequence"; let args = map (typecheck_exp vk env) args in (Cpp_ast.SeqE (map fst args), snd (last args)) | InstE (i, e, targs) -> if debug then printf "*** explicitly instantiating!\n" else (); let targs = map (well_formed_typ env) targs in let (e,(t,_,_)) = typecheck_exp vk env e in (match t with FunT _ -> (try inst_fun i env e t targs with No_matching_model msg -> error i msg | TypeParamArgMismatch msg -> error i msg) | OvldT (i,ets) -> let ets = filter_map (fun (e,t) -> match t with FunT (i, ts, (rs,ss), ps, (rt,rv,rm)) -> if length targs = length ts then (try let (e,(t,_,_)) = inst_fun i env e t targs in Some (e,t) with No_matching_model msg -> None | TypeParamArgMismatch msg -> None) else None | _ -> error i "expected function type inside overload") ets in (e, (OvldT (i, ets), Rvalue, Constant)) | _ -> error i (sprintf "Only polymorphic functions may be explicitly instantiated, not %s." (typ2str env t))) | NewE (i, a, t, orig_args) -> let t = get_canonical env (well_formed_typ env t) and args = map (typecheck_exp vk env) orig_args in if debug then printf "NewE t = %s\n" (g2string_typ t); typecheck_new i vk env a t orig_args args | PlacementNewE (i, orig_p, t, orig_args) -> let t = get_canonical env (well_formed_typ env t) and p = typecheck_exp vk env orig_p and args = map (typecheck_exp vk env) orig_args in typecheck_placement_new i vk env orig_p p t orig_args args | NewArrayE (i, a, t, orig_n) -> let t = get_canonical env (well_formed_typ env t) and n = typecheck_exp vk env orig_n in (match t with VarT _ | AssocT _ | ClassT _ -> let mem = (match a with Stack -> "new_array_on_stack" | Heap -> "new_array_on_heap" | GCHeap -> "new_array_on_gc") in let orig_f = ModelMemE (i, "DefaultConstructible", [t], mem) in let (f,(ft,_,_)) = typecheck_exp vk env orig_f in typecheck_apply vk env i orig_f f ft [orig_n] [n] | _ -> let orig_f = InstE (i, PrimE (i, NewArrayP a), [t]) in let (f,(ft,_,_)) = typecheck_exp vk env orig_f in let (_, rt) = typecheck_apply vk env i orig_f f ft [orig_n] [n] in (Cpp_ast.NewArrayE (a, cvt_typ env t, fst n), rt)) | NewArrayNoInitE (i, a, t, orig_n) -> let t = get_canonical env (well_formed_typ env t) and n = typecheck_exp vk env orig_n in let orig_f = InstE (i, PrimE (i, NewArrayP a), [t]) in let (f,(ft,_,_)) = typecheck_exp vk env orig_f in let (_, rt) = typecheck_apply vk env i orig_f f ft [orig_n] [n] in (Cpp_ast.NewArrayE (a, cvt_typ env t, fst n), rt) | DeleteE (i, orig_e) -> let (e,(t,v,m)) = typecheck_exp vk env orig_e in (match t with PtrT (_, pt) -> (match pt with VarT _ | AssocT _ -> let orig_f = ModelMemE (i, "Regular", [pt], "cleanup") in let (f,(ft,_,_)) = typecheck_exp vk env orig_f in typecheck_apply vk env i orig_f f ft [orig_e] [(e,(t,v,m))] | _ -> (Cpp_ast.ApplyE (Cpp_ast.PrimE DeleteP, [e]), (VoidT i, Rvalue, Mutable))) | _ -> error i (sprintf "May only delete pointers, not %s" (g2string_typ t))) | DestroyE (i, orig_e) -> let (e,(t,v,m)) = typecheck_exp vk env orig_e in (match t with PtrT (_, pt) -> (match pt with VarT _ | AssocT _ -> let orig_f = ModelMemE (i, "Regular", [pt], "wipeout") in let (f,(ft,_,_)) = typecheck_exp vk env orig_f in typecheck_apply vk env i orig_f f ft [orig_e] [(e,(t,v,m))] | ConstT _ -> error i "May not destroy const pointer" | _ -> (Cpp_ast.DestroyE (cvt_typ env pt, e), (VoidT i, Rvalue, Mutable))) | _ -> error i (sprintf "May only delete pointers, not %s" (g2string_typ t))) | StructE (i, a, cn, targs, args) -> (try let (ts,(rs,sms),mts,_) = assoc cn env.classes in if (length targs != length ts) then error i (sprintf "Struct %s has %d parameters, not %d" cn (length ts) (length targs)) else let args = map (fun (m,_) -> (try assoc m args with Not_found -> error i (sprintf "Member %s is not in struct %s" m cn))) mts in let e = NewE (i, a, ClassT (i, cn, targs), args) in typecheck_exp vk env e with Not_found -> (try let _ = assoc cn env.unions in let arg = (nth args 0) in process_union env vk i a cn targs (fst arg) (snd arg) with Not_found -> error i (sprintf "Type %s is not defined." cn))) | IfE (i, c, els, thn) -> let (c,(ct,_,_)) = typecheck_exp vk env c in let (els,elst) = typecheck_exp vk env els in let (thn,thnt) = typecheck_exp vk env thn in (match ct with BoolT _ -> (* This differs a little bit from C/C++ *) if (subtype env elst thnt) then let t = cvt_exp_typ env thnt in (Cpp_ast.IfE (c, Cpp_ast.CastE (t, els), thn), elst) else if (subtype env thnt elst) then let t = cvt_exp_typ env elst in (Cpp_ast.IfE (c, els, Cpp_ast.CastE (t, thn)), thnt) else error i "The two branches of the conditional expression must have the same type or one must be coercible to the other." | _ -> error i "The condition must have type bool")