evalType.ml

(** Time-stamp: <modified the 30/05/2008 (at 17:46) by Erwan Jahier> *)
 
  
open Predef
open PredefSemantics
open SyntaxTree
open SyntaxTreeCore
open CompiledData
open Printf
open Lxm
open Errors

let finish_me msg = print_string ("\n\tXXX evalType.ml:"^msg^" ->  finish me!\n")
let rec (f : id_solver -> val_exp_eff -> type_eff list) =
  fun id_solver ve ->
    match ve with
      | CallByPosEff ({it=posop; src=lxm}, OperEff args) -> (
	  try eval_by_pos_type id_solver posop lxm args
	  with EvalType_error msg -> 
	    raise (Compile_error(lxm, "type error: "^msg))
	) 
      | CallByNameEff ({it=nmop; src=lxm}, nmargs ) ->
	  try eval_by_name_type id_solver nmop lxm nmargs
	  with EvalConst_error msg ->
	    raise (Compile_error(lxm, "\n*** can't eval constant: "^msg))
	      
and (eval_by_pos_type :
       id_solver -> by_pos_op_eff -> Lxm.t -> val_exp_eff list -> type_eff list) =
  fun id_solver posop lxm args ->
    match posop with
      | Predef_eff (op,sargs) -> 
	  PredefSemantics.type_eval op lxm sargs (List.map (f id_solver) args)

      | CALL_eff node_exp_eff -> 
	  let lto = snd (List.split node_exp_eff.it.outlist_eff) in
	    (try List.map type_eff_ext_to_type_eff lto
	    with Polymorphic | Overloaded -> assert false)

      | IDENT_eff id  -> (
	  (* [id] migth be a constant, but also a variable *)
	  try [type_of_const_eff (id_solver.id2const id lxm)]
	  with _ -> [(id_solver.id2var id lxm).var_type_eff]
	)
      | WITH_eff -> (
	  match args with
	      [a0;a1;a2] -> (
		match (f id_solver a0) with
		  | [Bool_type_eff] ->
		      let teff1 = f id_solver a1
		      and teff2 = f id_solver a2 in
			if teff1 = teff2 then teff1 else
			  type_error [] "type mismatch in with statements"
		  | x -> type_error x "bool"
	      )
	    | _ ->
		raise (EvalType_error(sprintf "arity error: 3 expected instead of %d" 
					 (List.length args)))
	)
      | TUPLE_eff -> List.flatten (List.map (f id_solver) args)

      | CONCAT_eff -> (
	  match List.map (f id_solver) args with
	    | [[Array_type_eff (teff0, size0)]; [Array_type_eff (teff1, size1)]] -> (
		if teff0 = teff1 then 
		  [Array_type_eff (teff0, size0+size1)]	
		else
		  raise(EvalType_error(
			  sprintf "type combination error, can't concat %s with %s"
			    (CompiledDataDump.string_of_type_eff teff0)
			    (CompiledDataDump.string_of_type_eff teff1)))
	      )
	    | [_;_] ->
		raise(EvalType_error("type combination error, array type expected"))
	    | _ -> 
		raise(EvalType_error(sprintf "arity error: 2 expected instead of %d" 
				       (List.length args)))
	)

      | STRUCT_ACCESS_eff fid -> (
	  let type_args_eff = List.flatten (List.map (f id_solver) args) in
	    match type_args_eff with 
	       | [Struct_type_eff (name, fl)] -> (
		   try 
		     [fst (List.assoc fid fl)]
		   with Not_found -> 
		     raise (EvalType_error
			      (Printf.sprintf "%s is not a field of struct %s" 
				 (Ident.to_string fid) 
				 (CompiledDataDump.string_of_type_eff(List.hd type_args_eff))))
		 )
	       | [x] -> type_error [x] "struct type"
	       | x -> arity_error x "1"
	    )
      | ARRAY_ACCES_eff  (_, teff) -> [teff]

      | ARRAY_SLICE_eff  (sieff,teff) -> 
	    [Array_type_eff(teff, sieff.se_width)]

      | HAT_eff(size,teff) -> [Array_type_eff(teff,size)]
      | ARRAY_eff ->
	  (* check that args are of the same type *)
	  let type_args_eff = (List.map (f id_solver) args) in
	  let teff_elt =
	    List.fold_left
	      (fun acc teff ->
		 match acc with
		   | [] -> teff
		   | [sacc] -> if acc = teff then acc else
		       raise(EvalType_error(
			       "all array elements should be of the same type"))
		   | _ -> assert false
	      )
	      []
	      type_args_eff
	  in
	    assert (List.length teff_elt = 1);
	    [Array_type_eff(List.hd teff_elt, List.length args)]


      | WHEN_eff -> (
	  let type_args_eff = List.map (f id_solver) args in
	    match type_args_eff with
	      | [teff; clk_t] -> teff
	      | _ -> raise(EvalType_error("arity error (2 args expected)"))
	)
      | ARROW_eff
      | FBY_eff -> (
	  let type_args_eff = List.map (f id_solver) args in
	    match type_args_eff with
	      | [init; teff] -> if init = teff then teff else 
		  raise(EvalType_error("type mismatch. "))
	      | _ -> raise(EvalType_error("arity error (2 args expected)"))
	)
      | CURRENT_eff 
      | PRE_eff -> (
	  let type_args_eff = List.map (f id_solver) args in
	    match type_args_eff with
	      | [teff] -> teff
	      | _ -> raise(EvalType_error("arity error (1 arg expected)"))
	)
      | MERGE_eff _ -> finish_me "merge"; assert false



and (eval_by_name_type : id_solver -> by_name_op_eff -> Lxm.t -> 
      (Ident.t Lxm.srcflagged * val_exp_eff) list -> type_eff list) =
  fun id_solver namop lxm namargs -> 
    match namop with
      | STRUCT_anonymous_eff -> 
	  (* ??? comment faire ici pour recuperer son type ???
	     il faut que je recherche  l'aide des noms de champs
	     le type structure qui va bien !

	     - creer une table [liste des noms de champs -> ident de type structure] ?
	     - rajouter dans la table a sa creation une entree dont le nom
	     est compos du nom des champs ?
	     *)
	  finish_me "anonymous struct not yet supported"; 
	  assert false
(* 	  failwith "Finish me: anonymous struct not yet supported" *)

      | STRUCT_eff opid -> [id_solver.id2type opid lxm]