CristalCaveGem » LustreC

(********************************************************************)

(*                                                                  *)

(*  The LustreC compiler toolset   /  The LustreC Development Team  *)

(*  Copyright 2012 -    --   ONERA - CNRS - INPT                    *)

(*                                                                  *)

(*  LustreC is free software, distributed WITHOUT ANY WARRANTY      *)

(*  under the terms of the GNU Lesser General Public License        *)

(*  version 2.1.                                                    *)

(*                                                                  *)

(********************************************************************)

open Utils

  try

    Options_management.name_dependency (local, dep) ext 

  with Not_found ->

    (* Error.pp_error loc (fun fmt -> Format.fprintf fmt "Unknown library %s" dep); *)

 if Hashtbl.mem hashtbl name

let check_symbol loc msg hashtbl name =

 if not (Hashtbl.mem hashtbl name)

(*Format.eprintf "add_imported_node %s %a (owner=%s)@." name Printers.pp_imported_node (imported_node_of_top value) value.top_decl_owner;*)

  try

    let itf' = value'.top_decl_itf in

    let owner = value.top_decl_owner in

    let itf = value.top_decl_itf in

    match value'.top_decl_desc, value.top_decl_desc with

  with

let add_node name value =

(*Format.eprintf "add_node %s %a (owner=%s)@." name Printers.pp_imported_node (get_node_interface (node_of_top value)) value.top_decl_owner;*)

  try

    let itf' = value'.top_decl_itf in

    let owner = value.top_decl_owner in

    let itf = value.top_decl_itf in

    match value'.top_decl_desc, value.top_decl_desc with

    | ImportedNode _, Node _          when owner = owner' && itf' && (not itf) -> ()

  with

let add_tag loc name typ =

  if Hashtbl.mem tag_table name then

let add_field loc name typ =

  if Hashtbl.mem field_table name then

let import_typedef name tydef =

  let loc = tydef.top_decl_loc in

  let rec import ty =

    match ty with

    | Tydec_enum tl   ->

       List.iter (fun tag -> add_tag loc tag tydef) tl

    | Tydec_struct fl -> 

       List.iter (fun (field, ty) -> add_field loc field tydef; import ty) fl

    | Tydec_clock ty      -> import ty

    | Tydec_const c       ->

       if not (Hashtbl.mem type_table (Tydec_const c))

    | Tydec_array (c, ty) -> import ty

    | _                   -> ()

  in import ((typedef_of_top tydef).tydef_desc)

let add_type itf name value =

    let value' = Hashtbl.find type_table (Tydec_const name) in

    let owner' = value'.top_decl_owner in

    let itf' = value'.top_decl_itf in

    let owner = value.top_decl_owner in

    let itf = value.top_decl_itf in

    match value'.top_decl_desc, value.top_decl_desc with

    | TypeDef ty', TypeDef ty when coretype_equal ty'.tydef_desc ty.tydef_desc && owner' = owner && itf' && (not itf) -> ()

  with Not_found -> (import_typedef name value; Hashtbl.add type_table (Tydec_const name) value)

let check_type loc name =

 if not (Hashtbl.mem type_table (Tydec_const name))

let add_const itf name value =

  try

    let value' = Hashtbl.find consts_table name in

    let owner' = value'.top_decl_owner in

    let itf' = value'.top_decl_itf in

    let owner = value.top_decl_owner in

    let itf = value.top_decl_itf in

    match value'.top_decl_desc, value.top_decl_desc with

    | Const c', Const c when c.const_value = c'.const_value && owner' = owner && itf' && (not itf) -> ()

  with Not_found -> Hashtbl.add consts_table name value

 *   let basename = Options_management.name_dependency (local, dep) in

 *   let extension = ".lusic" in 

 *   try

 *     let lusic = Lusic.read_lusic basename extension in

 *     Lusic.check_obsolete lusic basename;

 *     lusic

 *   with

 *   | Sys_error msg ->

 *       raise (Error (loc, Error.Unknown_library basename))

 *     

 * let import_dependency loc (local, dep) =

 *   try

 *     import_dependency_aux loc (local, dep)

 *   with

 *   | Corelang.Error (_, err) as exc -> (

 *     Format.eprintf "Import error: %a%a@."

 *       Error.pp_error_msg err

 *       Location.pp_loc loc;

 *     raise exc

 *   ) *)

  match decl.top_decl_desc with

  | Open (local, dep) -> (

    let loc = decl.top_decl_loc in

    let extension = ".lusic" in 

      let lusic = Lusic.read_lusic basename extension in

      Lusic.check_obsolete lusic basename;

      lusic

    with

  (Env.add_value ty_env const_decl.const_id const_decl.const_type,

   Env.add_value ck_env const_decl.const_id (Clocks.new_var true))

  List.fold_right get_envs_from_const const_decls (ty_env, ck_env)

let rec get_envs_from_top_decl (ty_env, ck_env) top_decl =

  match top_decl.top_decl_desc with

  | Node nd          -> (Env.add_value ty_env nd.node_id nd.node_type,

			 Env.add_value ck_env nd.node_id nd.node_clock)

  | ImportedNode ind -> (Env.add_value ty_env ind.nodei_id ind.nodei_type,

			 Env.add_value ck_env ind.nodei_id ind.nodei_clock)

  | Const c          -> get_envs_from_const c (ty_env, ck_env)

  | TypeDef _        -> List.fold_left get_envs_from_top_decl (ty_env, ck_env) (consts_of_enum_type top_decl)

(* get type and clock environments from a header *)

let get_envs_from_top_decls header =

  List.fold_left get_envs_from_top_decl (Env.initial, Env.initial) header

  let is_stateful topdecl =

  match topdecl.top_decl_desc with

  | Node nd -> (match nd.node_stateless with Some b -> not b | None -> not nd.node_dec_stateless)

  | ImportedNode nd -> not nd.nodei_stateless 

  | _ -> false

    List.fold_left (fun ((accu_prog, accu_dep, typ_env, clk_env) as accu) decl ->

        (* Precompute the updated envs, will not be used in the Open case *)

        let typ_env', clk_env' = get_envs_from_top_decl (typ_env, clk_env) decl in

        match decl.top_decl_desc with

        | Open (local, dep) -> (

          (* loading the dep *)

          try

            let basename = name_dependency decl.top_decl_loc (local, dep) ".lusic" in

            if List.exists

                 (fun dep -> basename = name_dependency decl.top_decl_loc  (dep.local, dep.name) ".lusic")

                 accu_dep

            then

              (* Library already imported. Just skip *)

              accu

            else (

              Log.report ~level:1 (fun fmt -> Format.fprintf fmt "@ .. Library %s@ " basename);

              let lusic = get_lusic decl in

              (* Recursive call with accumulator on lusic *)

              let (accu_prog, accu_dep, typ_env, clk_env) =

                load_rec ~is_header:true accu lusic.Lusic.contents in

              (* Building the dep *)

              let is_stateful = List.exists is_stateful lusic.Lusic.contents in

              let new_dep = { local = local;

                              name = dep;

                              content = lusic.Lusic.contents;

                              is_stateful = is_stateful } in

              (* Returning the prog while keeping the Open, the deps with the new

            )

          with

          | Not_found ->

             let loc = decl.top_decl_loc in

             Error.pp_error loc (fun fmt -> Format.fprintf fmt "Unknown library %s" dep);

        | Include name ->

           let basename = name_dependency decl.top_decl_loc (true, name) "" in

           if Filename.check_suffix basename ".lus" then

             let include_src = Compiler_common.parse basename ".lus" in

             let (accu_prog, accu_dep, typ_env, clk_env) =

               load_rec ~is_header:false accu include_src

             in

             decl::accu_prog, accu_dep, typ_env, clk_env

           else

        | Node nd ->

           if is_header then

           else (

             (* Registering node *)

             add_node nd.node_id decl;

             (* Updating the type/clock env *)

             decl::accu_prog, accu_dep, typ_env', clk_env'                   

           )

        | ImportedNode ind ->

           if is_header then (

             add_imported_node ind.nodei_id decl;

             decl::accu_prog, accu_dep, typ_env', clk_env'                   

           )

           else

                                       " declared in a regular Lustre file")))  

        | Const c -> (

          add_const is_header c.const_id decl;

          decl::accu_prog, accu_dep, typ_env', clk_env' 

        )

        | TypeDef tdef -> (

          add_type is_header tdef.tydef_id decl;

          decl::accu_prog, accu_dep, typ_env', clk_env'

        )

      ) accu program

(* Iterates through lusi definitions and records them in the hashtbl. Open instructions are evaluated and update these hashtbl as well. node_table/type/table/consts_table *)

      load_rec ~is_header

        ([], (* accumulator for program elements *)

         [], (* accumulator for dependencies *)

         Env.initial, (* empty type env *)

         Env.initial  (* empty clock env *)

        ) program

    in

    List.rev prog, List.rev deps, (typ_env, clk_env)

     *   Error.pp_error_msg err

     *   Location.pp_loc loc; *)

    Format.eprintf "Import error: %a@."

  );;