evalConst.ml

(** Time-stamp: <modified the 29/08/2008 (at 10:21) by Erwan Jahier> *)


open Printf 
open Lxm
open Errors
open SyntaxTree
open Eff
open SyntaxTreeCore
open Predef
open PredefEvalConst
open PredefEvalType

(*----------------------------------------------------
EvalArray_error :
        - leve par les fonctions ddies aux tableaux
----------------------------------------------------*)
exception EvalArray_error of string

(*----------------------------------------------------
EvalConst_error :
  - leve localement dans les sous-fonctions,
  - capte dans EvalConst.f et tranforme en Compile_error.
----------------------------------------------------*)

let finish_me msg = print_string ("\n\tXXX evalConst.ml:"^msg^" ->  finish me!\n")
      
let not_evaluable_construct str =
  raise (EvalConst_error(
           Printf.sprintf "The construct %s is not allowed in static expression" 
             str))

(*----------------------------------------------------
Utilitaire :
extraire une tranche de tableau

N.B. first_ix  last_ix step et width sont supposs 
venir de eva et donc tre corrects

N.B. Puisque correct, last_ix est inutile, mais bon ...
-----------------------------------------------------*)
let (make_slice_const : 
       Eff.const array -> Eff.type_ -> Eff.slice_info -> Eff.const list) =
  fun ctab ctype slice ->
    let get_res (ix : int) = Array.get ctab (slice.se_first + ix*slice.se_step) in
      [Array_const_eff (Array.init slice.se_width get_res, ctype)]


(** Utilitaire : fabriquer si possible une constante tableau *)
let (make_array_const : Eff.const list array -> Eff.const) =
  fun ops -> 
    let expected_type = ref None in
    let treat_arg (op : Eff.const list) =
      match op with
        | [x] -> (
            (* non tuple *)
            let xtyp = Eff.type_of_const x in
              match (!expected_type) with
                | None -> expected_type := Some xtyp; x
                | Some t -> (
                    if (t = xtyp) then x else 
                      raise (EvalConst_error(
                               "type error in array, "^
                                 (LicDump.string_of_type_eff xtyp)^
                                 " mixed with " ^ LicDump.string_of_type_eff t
                             ))
                  )
          )
        | _  ->  (* tuple *)
            raise (EvalConst_error("array of tuple not allowed"))
    in 
    let res = Array.map treat_arg ops in
      match (!expected_type) with
        | None -> raise (EvalConst_error("empty array"))
        | Some t -> Array_const_eff(res, t)



(** Utilitaire : fabriquer si possible une constante structure 

N.B. Par construction on sait que nops n'a pas de doublons
*)
let make_struct_const 
    (teff : Eff.type_)
    (arg_tab : (Ident.t, Lxm.t * Eff.const) Hashtbl.t) =
  (
    (* on verifie qu'on a bien un type struct *)
    match teff with
        Struct_type_eff (tnm, flst) -> (
          (* on construit la liste dans le BON ordre *)
          let make_eff_field ((fn: Ident.t),((ft:Eff.type_),(fv:Eff.const option))) = (
            try (
              (* on prend en priorit dans arg_tab *)
              match (Hashtbl.find arg_tab fn) with
                  (lxm, v) -> (
                    (* effet de bord : on vire la valeur de arg_tab *)
                    Hashtbl.remove arg_tab fn ;
                    let vt = Eff.type_of_const v in
                      if (vt = ft) then (fn, v) (*ok*)
                      else raise (Compile_error(
                                    lxm , 
                                    sprintf
                                      "\n*** type error in struct %s, %s instead of %s"
                                      (Ident.string_of_long tnm)
                                      (LicDump.string_of_type_eff vt)
                                      (LicDump.string_of_type_eff ft) 
                                  )) 
                  )
            ) with Not_found -> (
              (* sinon la valeur par dfaut *)
              match fv with
                  Some v -> (fn, v) (* ok : v correcte par construction *)
                | None -> 
                    raise (EvalConst_error(
                             sprintf
                               "bad struct expression, no value given for field %s" 
                                             (Ident.to_string fn)
                           ))
            )
          ) in
            (* on mappe flst pour avoir la liste dans le bon ordre *)
          let eff_fields = List.map make_eff_field flst in
            (* si arg_tab n'est pas vide, erreur sur le premier *) 
          let raise_error (id : Ident.t) ((lxm : Lxm.t), (veff : Eff.const)) 
              = raise(Compile_error(
                        lxm, 
                        sprintf
                          "\n*** %s is not a field of struct %s" 
                          (Ident.to_string id) 
                          (LicDump.string_of_type_eff(teff))
                      )) 
          in 
            Hashtbl.iter raise_error arg_tab ;
            (* ok : tout s'est bien pass ! *)
            Struct_const_eff (eff_fields, teff)
        ) 
      | _ -> raise (EvalConst_error(
                          sprintf
                            "struct type expected instead of %s" 
                            (LicDump.string_of_type_eff teff)
                        ))
  )


let l2ll l = if l = [] then [] else [l]

(*----------------------------------------------------
        Evaluation rcursive des expressions constantes
------------------------------------------------------
f :
        - entres :  Eff.id_solver et val_exp
        - sortie :        Eff.const list
        - Effet de bord : Compile_error 
Rle :
        -> rsoud les rfrences aux idents
        -> gre les appels rcursifs (valuation des arguments) 
----------------------------------------------------*)
let rec f
    (env : Eff.id_solver) 
    (vexp : val_exp)
    = (
      (*-----------------------------------
        fonction rcursive principale
        -> capte les nv
        -> rcupre les EvalConst_error 
        -----------------------------------*)
      let rec rec_eval_const (vexp : SyntaxTreeCore.val_exp) = (
        match vexp with
          | SyntaxTreeCore.CallByPos ({it=posop; src=lxm}, Oper args) -> (
              try eval_by_pos_const posop lxm args
              with
                | EvalType_error msg -> 
                    raise (Compile_error(lxm, "type error: "^msg))
                | EvalConst_error msg ->
                    raise (Compile_error(lxm, "\n*** can't eval constant: "^msg))
            )
          | SyntaxTreeCore.CallByName ({it=nmop; src=lxm}, nmargs ) -> (
              try eval_by_name_const nmop lxm nmargs
              with EvalConst_error msg ->
                raise (Compile_error(lxm, "\n*** can't eval constant: "^msg))
            )
      )
        (*-----------------------------------
          fonction rcursive secondaire
          eval. exp classique (by pos)
          N.B. On distingue les oprations 
          classiques (avec extention tableau
          implicie) des autres. Ici, on traite
          toutes les oprations non classiques. 
          -----------------------------------*)
      and eval_by_pos_const
          (posop : by_pos_op)   (* l'operateur *)
          (lxm : Lxm.t)      (* source de l'oprateur *)
          (args : val_exp list) (* arguments *)
          = (
            match (posop) with 
                (* capte les idents de constantes *)
                IDENT_n  id  -> (
                  (* 2007-07 on interdit les externes *)
                  match (env.id2const id lxm) with
                    | Extern_const_eff(_,_, Some const_eff) -> [const_eff]
                    | Extern_const_eff(_,_,None) -> 
                        raise (EvalConst_error(
                                 sprintf "\n*** cannot access this abstract constant value"))
                    | x -> [ x ]
                )
                  (* oprateur lazzy *)
              | WITH_n(a0,a1,a2) -> (
                  match (rec_eval_const a0) with
                      [ Bool_const_eff true] -> rec_eval_const a1
                    | [ Bool_const_eff false] -> rec_eval_const a2
                    | x -> type_error_const x "bool"
                )
                  (* mettre  plat la liste des args *)
              | TUPLE_n -> ( List.flatten (List.map rec_eval_const args))
                  (* les tableaux de tuples sont interdits *)
              | HAT_n -> (
                  match args with
                    | [cexp; szexp] -> (
                        try
                          let sz = eval_array_size env szexp in
                            match rec_eval_const cexp with
                              | [cst] ->
                                  let atab = Array.make sz cst in       
                                    [ Array_const_eff (atab, Eff.type_of_const cst) ]
                              | x -> 
                                  raise (EvalConst_error("array of tuple not allowed"))
                        with 
                            EvalArray_error msg -> raise(EvalConst_error msg)
                      ) 
                    | _ -> raise(EvalConst_error
                                   (sprintf "arity error: 2 expected instead of %d" 
                                      (List.length args)))
                )
              | CONCAT_n -> (
                  let ops = (List.map rec_eval_const args) in
                    match ops with
                      | [[Array_const_eff (v0, t0)];
                         [Array_const_eff (v1, t1)]] -> (
                          if(t0 = t1) then 
                            [Array_const_eff (Array.append v0 v1, t0)]  
                          else 
                            raise(EvalConst_error(
                                    sprintf 
                                      "\n*** type combination error, can't concat %s with %s"
                                      (LicDump.string_of_type_eff(t0)) 
                                      (LicDump.string_of_type_eff(t1)) 
                                  ))
                        )
                      | [_;_] -> 
                          raise(EvalConst_error(
                                  "type combination error, array type expected"))
                      | _ -> raise(EvalConst_error
                                     (sprintf "arity error: 2 expected instead of %d" 
                                        (List.length ops)))
                )
              | ARRAY_n -> (
                  let ops = (List.map rec_eval_const args) in
                    [make_array_const (Array.of_list ops)]
                )
              | ARRAY_ACCES_n ix -> (
                  let effargs = List.flatten (List.map rec_eval_const args) in
                    match effargs with
                      | [Array_const_eff (elts, typelts)] -> (
                          try
                            let sz = Array.length elts in
                            let effix = eval_array_index env ix sz lxm in
                              [Array.get elts effix ]
                          with EvalArray_error msg -> raise(EvalConst_error msg)
                        )
                      |  _  -> type_error_const effargs "some array"
                )
              | ARRAY_SLICE_n sl -> (
                  let (elts, typelts) =
                    match List.flatten (List.map rec_eval_const args) with
                      | [Array_const_eff (l, t)] -> (l, t) 
                      | x -> type_error_const x "some array"
                  in
                    (* on en dduit la taille du tableau *) 
                  let sz = Array.length elts in
                    (* value la slice *)
                    try
                      let sliceff = eval_array_slice env sl sz lxm in
                        make_slice_const elts typelts sliceff
                    with
                        EvalArray_error msg -> raise(EvalConst_error msg)
                ) 

              | STRUCT_ACCESS_n fid -> 
                  let ceff_list = List.flatten (List.map rec_eval_const args) in
                    (match ceff_list with 
                       | [Struct_const_eff (flst, typ)] -> (
                           try [(List.assoc fid flst)]
                           with Not_found -> 
                             raise (EvalConst_error
                                      (Printf.sprintf "%s is not a field of struct %s" 
                                         (Ident.to_string fid) 
                                         (LicDump.string_of_type_eff(typ))))
                         )
                       | [x] -> type_error_const [x] "struct type"
                       | x -> arity_error_const x "1"
                    )

              | CALL_n _ -> not_evaluable_construct "node call"
              | MERGE_n _ -> not_evaluable_construct "merge"
              | WHEN_n -> not_evaluable_construct "when"
              | FBY_n -> not_evaluable_construct "fby"
              | ARROW_n -> not_evaluable_construct "->"
              | CURRENT_n -> not_evaluable_construct "current"
              | PRE_n -> not_evaluable_construct "pre"

              | Predef_n(op,sargs)
                -> 
                  if sargs = [] then
                    let effargs =  (List.map rec_eval_const args) in
                      PredefEvalConst.f op lxm [] effargs
                  else
                    (* Well, it migth be possible after all... TODO *)
                    not_evaluable_construct (op2string op)
                    
                      
          ) (* FIN DE : eval_by_pos_const *)
        (*-------------------------------------*)
        (* Fonction rcursive secondaire       *)
        (*-------------------------------------*)
        (* -> Eval. d'une expression spciale  *)
        (* "par nom"                           *)
        (*-------------------------------------*)
      and eval_by_name_const
          (namop : by_name_op)   (* l'operateur *)
          (lxm : Lxm.t)      (* source de l'oprateur *)
          (namargs : (Ident.t srcflagged * val_exp) list) (* arguments *)
          = (
            match namop with
              | STRUCT_anonymous_n -> 
                  finish_me "anonymous struct"; 
                  assert false
                    
              | STRUCT_n opid -> (
                  (* effet de bord : on tabule les param effectif *)
                  let arg_tab = Hashtbl.create 50 in 
                  let treat_one_arg ((pid:Ident.t srcflagged), (pexp:val_exp)) =
                    if 
                      (Hashtbl.mem arg_tab pid.it) 
                    then
                      raise(EvalConst_error(
                              sprintf
                                "multiple definition of param %s in %s call"
                                (Ident.to_string pid.it)
                                (Ident.string_of_idref opid)))
                    else 
                      let v = rec_eval_const pexp in
                        match v with
                          | [x] -> Hashtbl.add arg_tab pid.it (pid.src, x)
                          | _ -> 
                              raise(
                                EvalConst_error(
                                  sprintf
                                    "unexpected tuple value for param %s in %s call"
                                    (Ident.to_string pid.it)
                                    (Ident.string_of_idref opid)
                                ))
                  in 
                    List.iter treat_one_arg namargs ;
                    (* pour l'instant, on ne traite que les constructions de struct *)
                    try let teff = env.id2type opid lxm in
                      [make_struct_const teff arg_tab]
                    with _ -> 
                      raise(EvalConst_error(
                              sprintf "struct type expected instead of %s"
                                (Ident.string_of_idref opid)))
                )
          ) (* FIN DE : eval_by_name_const *)
        (*-------------------------------------*)
        (* Corps de la fonction principale      *)
        (*-------------------------------------*)
      in 
        rec_eval_const vexp 
    ) (* fin de f *)

(*---------------------------------------------------------------------
  eval_array_size
  -----------------------------------------------------------------------
  Rle : calcule une taille de tableau 

  Entres: 

  Sorties :
  int (strictement positif)

  Effets de bord :
  EvalArray_error "bad array size, type int expected but get <t>" si t pas int
  EvalArray_error "bad array size <n>" si n <= 0
  ----------------------------------------------------------------------*)
and (eval_array_size: Eff.id_solver -> val_exp -> int) =
  fun id_solver szexp -> 
    match (f id_solver szexp) with
      | [Int_const_eff sz] -> 
          if (sz > 0) then sz else
            raise(EvalArray_error(sprintf "bad array size %d" sz))
      | [x] -> 
          raise(EvalArray_error(sprintf  "bad array size, int expected but get %s"
                        (LicDump.string_of_type_eff(Eff.type_of_const x)))) 
      | _ -> 
          raise(EvalArray_error(sprintf "bad array size, int expected, not a tuple"))
            
(*---------------------------------------------------------------------
  eval_array_index
  -----------------------------------------------------------------------
  Rle :

  Entres :
  id_solver, val_exp, taille du tableau

  Sorties :
  int (entre 0 et taille du tableau -1
  
  Effets de bord :
  EvalArray_error msg si pas bon
  ----------------------------------------------------------------------*)
and eval_array_index
    (env : Eff.id_solver)
    (ixexp : val_exp)
    (sz : int)
    (lxm : Lxm.t)
    = 
  try 
    (
      match (f env ixexp) with
        | [Int_const_eff i] 
        | [Extern_const_eff(_,_, Some (Int_const_eff i))] -> check_int i sz
        | [Extern_const_eff(id,_,None)] ->
            raise(EvalArray_error("The extern const " ^ (Ident.string_of_long id) ^ 
                                    " is abstract"))
        | [Extern_const_eff(_,_, Some x)] 
        | [x] -> raise(EvalArray_error(sprintf 
                        "bad array index, int expected but get %s"
                        (LicDump.string_of_type_eff(Eff.type_of_const x)))
                      ) 
        | _ -> raise(EvalArray_error(
                       sprintf "bad array index, int expected but get a tuple"))

    )
  with 
      EvalArray_error msg -> 
        raise (Compile_error(lxm, "\n*** can't eval constant: "^msg))
          
 and check_int i sz =
    if ((i >= 0) && (i < sz)) then i
    else raise(EvalArray_error(
                 sprintf "array index %d out of bounds 0..%d" i (sz-1)))

(*---------------------------------------------------------------------
  eval_array_slice
  -----------------------------------------------------------------------
  Rle :

  Entres :
  Eff.id_solver, slice_info, size du tableau,
  lxm (source de l'opration slice pour warning)
  Eff.Sor :
  slice_info_eff, i.e.
  (fisrt,last,step,width) tels que step <> 0 et
  - si step > 0 alors 0<=first<=last<=sz
  - si step < 0 alors 0<=last<=first<=sz
  - 1<=width<=sz 
  Effets de bord :
  EvalArray_error msg si pas bon
  ----------------------------------------------------------------------*)
and eval_array_slice (env : Eff.id_solver) (sl : slice_info) (sz : int) (lxm : Lxm.t) =
  try
    let first_ix = eval_array_index env sl.si_first sz lxm in 
    let last_ix = eval_array_index env sl.si_last sz lxm in
    let step =
      match sl.si_step with
        | Some stepexp -> (
            match (f env stepexp) with
              | [Int_const_eff s] ->  s (* ok *)                    
              | [x] -> raise(EvalArray_error(
                      sprintf  "bad array step, int expected but get %s"
                        (LicDump.string_of_type_eff (Eff.type_of_const x)))) 
              | _ -> raise(EvalArray_error(
                             sprintf "bad array step, int expected but get a tuple"))
          )
        | None -> if (first_ix <= last_ix) then 1 else -1
    in
      if
        (step = 0) 
        || ((step > 0) && (first_ix > last_ix))
        || ((step < 0) && (first_ix < last_ix))
      then
        let msg = sprintf "bad array slice [%d..%d] step %d" first_ix last_ix step in
          raise (EvalArray_error msg)
      else
        (* index relatif du dernier *)
        let last_rel = abs (last_ix-first_ix) in
        let abs_step = abs step in
          (* le dernier est-il pris dans la tranche ? *)
          if ((last_rel mod abs_step) <> 0) then
            warning lxm (sprintf "last index out of slice [%d..%d step %d]" 
                           first_ix last_ix step);
          let width = 1 + last_rel/abs_step in
            (* on force le dernier a tre dans la tranche *)
          let real_last_ix = first_ix + (width-1) * step in
            (* (first_ix,last_ix,step,width) *)
            {
              se_first = first_ix;
              se_last = real_last_ix;
              se_step = step;
              se_width = width
            }
  with 
      EvalArray_error msg -> 
        raise (Compile_error(lxm, "\n*** can't eval constant: "^msg))