scilab/modules/scicos/src/translator/translation/codeGeneration.ml

   1 (*
   2  *  Translator from Modelica 2.x to flat Modelica
   3  *
   4  *  Copyright (C) 2005 - 2007 Imagine S.A.
   5  *  For more information or commercial use please contact us at www.amesim.com
   6  *
   7  *  This program is free software; you can redistribute it and/or
   8  *  modify it under the terms of the GNU General Public License
   9  *  as published by the Free Software Foundation; either version 2
  10  *  of the License, or (at your option) any later version.
  11  *
  12  *  This program is distributed in the hope that it will be useful,
  13  *  but WITHOUT ANY WARRANTY; without even the implied warranty of
  14  *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15  *  GNU General Public License for more details.
  16  *
  17  *  You should have received a copy of the GNU General Public License
  18  *  along with this program; if not, write to the Free Software
  19  *  Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA.
  20  *
  21  *)
  22
  23 (** The main functions are:
  24 {ul
  25 {- [ generate_code ]: main function
  26   {ul
  27   {- [ collect_function_definitions ]: Collect function definitions }
  28   {- [ generate_component_description ]: Generate component descriptions
  29     {ul
  30     {- [ collect_component_elements ]: Returns a [ flat_instance ] containing all variables and equations
  31       {ul
  32         {- [ expand_equations ]: Generation of connect equations }
  33         {- [ introduce_derivative_variables ]: Introduce derivative variables}
  34       }
  35     }
  36     {- [ generate_dynamic_description ]: Generate the dynamic Model description
  37       {ul
  38         {- [ generate_flatten_instance ]: Dynamic model description as flat Modelica }
  39         {- [ generate_flatten_XML ]: if the "-xml" option is activated }
  40       }
  41     }
  42     {- [ generate_function_definitions ]: Generate function definitions in a file named filename_functions.mo }
  43     {- [ generate_initial_description ]: Generate initialization description in a file named filename_init.xml,
  44       and abstract relations in a file named filename_relations.xml.
  45       {ul
  46         {- [ generate_flatten_XML ]: Generates an XML description of initialization problem }
  47         {- [ generate_relations ]: Generates an XML description of abstract relations and other informations }
  48       }
  49     }
  50     }
  51   }
  52   }
  53 }
  54 }*)
  55
  56 open ErrorDico (* To have access to GenericError *)
  57
  58 type flat_instance =
  59   {
  60     variables: Instantiation.component_description list;
  61     dynamic_equations: Instantiation.equation_desc list;
  62     initial_equations: Instantiation.equation_desc list;
  63     abstract_relations: abstract_relation list
  64   }
  65
  66 and function_description =
  67   {
  68     inputs: (string * Types.class_specifier) list;
  69     outputs: (string * Types.class_specifier) list
  70   }
  71
  72 and abstract_relation =
  73   | Rel of Instantiation.component_description list
  74
  75 and 'a tree = Leaf of (string * 'a) | Node of string * 'a tree list
  76
  77 and element =
  78   {
  79     kind: element_kind;
  80     id: string;
  81     comment: string;
  82     initial_value: Instantiation.expression option;
  83 (*    nominal_value: Instantiation.expression option;
  84 *)
  85     output: bool;
  86     fixed: bool option
  87   }
  88
  89 and element_kind =
  90   | Input
  91   | Parameter
  92   | Variable
  93   | DiscreteVariable
  94
  95 type stats =
  96   {
  97     nb_ipars: int;
  98     nb_rpars: int;
  99     nb_spars: int;
 100     nb_dvars: int;
 101     nb_cvars: int;
 102     nb_inps: int;
 103     nb_outps: int
 104   }
 105
 106
 107 (* Utilities *)
 108
 109 let evaluate t = Lazy.force t
 110
 111 (* Remove enclosing parenthesis *)
 112 let unbraced s =
 113   let n = String.length s in
 114   try
 115     match s.[0], s.[n - 1] with
 116     | '(', ')' -> String.sub s 1 (n - 2)
 117     | _ -> s
 118   with
 119   | _ -> s
 120
 121 (* function used to hide XML special characters *)
 122 let hide_spc s =
 123   let encoded_s = ref "" in
 124   let hide_special_character c = match c with
 125     | '<' -> encoded_s := !encoded_s ^ "&lt;"
 126     | '>' -> encoded_s := !encoded_s ^ "&gt;"
 127     | '&' -> encoded_s := !encoded_s ^ "&amp;"
 128     | '\'' -> encoded_s := !encoded_s ^ "&apos;"
 129     | '\"' -> encoded_s := !encoded_s ^ "&quot;"
 130     | _ -> encoded_s := !encoded_s ^ (String.make 1 c) in
 131   String.iter hide_special_character s;
 132   !encoded_s
 133
 134
 135 (* Code generation functions *)
 136
 137 let rec generate_code xml init filename inst_defs =
 138   let fun_defs =
 139     List.fold_left collect_function_definitions [] inst_defs in
 140   let add_instance_element acc (id, elt_desc) =
 141     match evaluate elt_desc.Instantiation.element_nature with
 142     | Instantiation.Class _ -> acc
 143     | Instantiation.Component cpnt_desc -> (id, cpnt_desc) :: acc in
 144   match List.fold_left add_instance_element [] inst_defs with
 145   | [] -> ()
 146   | [ id, cpnt_desc ] ->
 147       generate_component_description xml init filename fun_defs id cpnt_desc
 148   | _ -> assert false
 149
 150 and collect_function_definitions fun_defs (id, elt_desc) =
 151   match evaluate elt_desc.Instantiation.element_nature with
 152   | Instantiation.Class cl_def ->
 153       let ctx =
 154         {
 155           path = cl_def.Instantiation.class_path;
 156           location = cl_def.Instantiation.class_location;
 157           instance_nature = Instantiation.ClassElement
 158         } in
 159       let cl_spec = cl_def.Instantiation.class_type in
 160       fun_defs @
 161       collect_function_definitions_in_class_specifier ctx cl_spec
 162   | Instantiation.Component cpnt_desc ->
 163       let ctx =
 164         {
 165           path = cpnt_desc.Instantiation.component_path;
 166           location = cpnt_desc.Instantiation.component_location;
 167           instance_nature =
 168             Instantiation.ComponentElement cpnt_desc.Instantiation.class_name
 169         } in
 170       fun_defs @
 171       collect_function_definitions_in_component ctx cpnt_desc
 172
 173 and collect_function_definitions_in_class_specifier ctx = function
 174   | Types.PredefinedType _ | Types.ComponentType _ | Types.ArrayType _ |
 175     Types.TupleType _ -> []
 176   | Types.ClassType cl_type ->
 177       collect_function_definition_in_class_type ctx cl_type
 178
 179 and collect_function_definition_in_class_type ctx cl_type =
 180   let fun_defs = collect_inner_functions ctx cl_type in
 181   collect_function ctx fun_defs cl_type
 182
 183 and collect_inner_functions ctx cl_type =
 184   match evaluate cl_type.Types.kind with
 185     | Types.Class | Types.Model | Types.Block | Types.Package |
 186       Types.Function ->
 187         let named_elts = cl_type.Types.named_elements in
 188         List.fold_left
 189           (collect_function_definitions_in_type ctx)
 190           []
 191           named_elts
 192     | Types.Record | Types.ExpandableConnector | Types.Connector -> []
 193
 194 and collect_function_definitions_in_type ctx fun_defs (id, elt_type) =
 195   let elt_type' = evaluate elt_type in
 196   match elt_type'.Types.dynamic_scope, elt_type'.Types.element_nature with
 197     | None, Types.ClassElement cl_spec ->
 198         let ctx' =
 199           {
 200             ctx with
 201             path = ctx.path @ [Instantiation.Name id]
 202           } in
 203         let cl_spec' = evaluate cl_spec in
 204         let fun_defs' =
 205           collect_function_definitions_in_class_specifier ctx' cl_spec' in
 206         fun_defs' @ fun_defs
 207     | Some _, _ |
 208       None,
 209       (Types.ComponentElement _ | Types.ComponentTypeElement _ |
 210        Types.PredefinedTypeElement _) -> fun_defs
 211
 212 and collect_function ctx fun_defs cl_type =
 213   match evaluate cl_type.Types.kind with
 214     | Types.Function ->
 215         let named_elts = cl_type.Types.named_elements in
 216         function_description_of_named_elements ctx named_elts :: fun_defs
 217     | Types.Class | Types.Model | Types.Block | Types.Record |
 218       Types.ExpandableConnector | Types.Connector| Types.Package -> fun_defs
 219
 220 and function_description_of_named_elements ctx named_elts =
 221   let collect_input_or_output (id, elt_type) fun_desc =
 222     let collect_input_or_output' cpnt_type =
 223       match evaluate cpnt_type.Types.causality with
 224         | Types.Input ->
 225             let cl_spec = evaluate cpnt_type.Types.base_class in
 226             { fun_desc with inputs = (id, cl_spec) :: fun_desc.inputs }
 227         | Types.Output ->
 228             let cl_spec = evaluate cpnt_type.Types.base_class in
 229             { fun_desc with outputs = (id, cl_spec) :: fun_desc.outputs }
 230         | Types.Acausal -> fun_desc in
 231     let elt_type' = evaluate elt_type in
 232     match elt_type'.Types.element_nature with
 233       | Types.ComponentElement cpnt_type ->
 234           collect_input_or_output' cpnt_type
 235       | Types.ClassElement _ | Types.ComponentTypeElement _ |
 236         Types.PredefinedTypeElement _ -> fun_desc in
 237   let fun_desc = { inputs = []; outputs = [] } in
 238   ctx,
 239   List.fold_right collect_input_or_output named_elts fun_desc
 240
 241 and collect_function_definitions_in_component ctx cpnt_desc =
 242   match evaluate cpnt_desc.Instantiation.component_nature with
 243     | Instantiation.DynamicArray cpnt_desc ->
 244         let ctx' =
 245           { ctx with path = ctx.path @ [Instantiation.Index 0] } in
 246         collect_function_definitions_in_component ctx' cpnt_desc
 247     | Instantiation.Instance inst ->
 248         let elts = evaluate inst.Instantiation.elements in
 249         let named_elts = elts.Instantiation.named_elements in
 250         List.fold_left collect_function_definitions [] named_elts
 251     | Instantiation.PredefinedTypeInstance _ -> []
 252     | Instantiation.StaticArray [||] -> []
 253     | Instantiation.StaticArray cpnt_descs ->
 254         let ctx' =
 255           { ctx with path = ctx.path @ [Instantiation.Index 0] } in
 256         collect_function_definitions_in_component ctx' cpnt_descs.(0)
 257
 258 and generate_function_definition oc acc (ctx, fun_desc) =
 259   let ext_name = Printf.sprintf "%s" (last_id ctx.path)
 260   and name = string_of_path ctx.path in
 261   match List.mem ext_name acc with
 262   | true -> acc
 263   | false ->
 264       Printf.fprintf oc "function %s \"%s\"\n" ext_name name;
 265       List.iter (generate_function_inout ctx oc "input") fun_desc.inputs;
 266       List.iter (generate_function_inout ctx oc "output") fun_desc.outputs;
 267       Printf.fprintf oc "external;\nend %s;\n" ext_name;
 268       ext_name :: acc
 269
 270 and generate_function_inout ctx oc inout (id, cl_spec) =
 271   let generate_dimensions ndims =
 272     let rec generate_dimensions' ndims =
 273       match ndims with
 274       | 0 -> assert false
 275       | 1 -> Printf.fprintf oc ":"
 276       | _ -> Printf.fprintf oc ":, "; generate_dimensions' (ndims - 1) in
 277     match ndims with
 278     | 0 -> ()
 279     | _ ->
 280       Printf.fprintf oc "[";
 281       generate_dimensions' ndims;
 282       Printf.fprintf oc "]" in
 283   let rec generate_function_inout' cl_spec ndims = match cl_spec with
 284     | Types.PredefinedType { Types.base_type = Types.RealType } ->
 285         Printf.fprintf oc "\t%s Real" inout;
 286         generate_dimensions ndims;
 287         Printf.fprintf oc " %s;\n" id
 288     | Types.PredefinedType { Types.base_type = Types.IntegerType }
 289       when ndims = 0 && inout = "input" ->
 290         Printf.fprintf oc "\t%s Integer %s;\n" inout id
 291     | Types.PredefinedType { Types.base_type = Types.StringType }
 292       when ndims = 0 && inout = "input" ->
 293         Printf.fprintf oc "\t%s String %s;\n" inout id
 294     | Types.ArrayType (_, cl_spec) when inout = "input" ->
 295         generate_function_inout' cl_spec (ndims + 1)
 296     | _ ->
 297         raise (GenericError
 298           { err_msg =
 299               ["_NotYetImplemented"; "_NonSupportedTypeOfFuncInOut"; id];
 300             err_info = [];
 301             err_ctx = ctx }) in
 302   generate_function_inout' cl_spec 0
 303
 304 and generate_component_description xml init filename fun_defs id cpnt_desc =
 305   let chop_extension s = try Filename.chop_extension s with _ -> s in
 306   let filename = match filename with
 307     | None -> id
 308     | Some s -> chop_extension s in
 309   let ctx =
 310       {
 311         path = cpnt_desc.Instantiation.component_path;
 312         location = cpnt_desc.Instantiation.component_location;
 313         instance_nature =
 314           Instantiation.ComponentElement cpnt_desc.Instantiation.class_name
 315       }
 316   and flat_inst = collect_component_elements cpnt_desc in
 317   generate_dynamic_description ctx xml filename fun_defs id flat_inst;
 318   generate_function_definitions ctx filename fun_defs;
 319   if init then
 320     generate_initial_description ctx filename fun_defs id flat_inst
 321
 322 and generate_dynamic_description ctx xml filename fun_defs id flat_inst =
 323   let vars = flat_inst.variables
 324   and equs = flat_inst.dynamic_equations
 325   and ext = if xml then ".xml" else ".mo" in
 326   let oc = open_out (filename ^ ext) in
 327   try
 328     if xml then
 329       generate_flatten_XML ctx fun_defs oc id vars equs
 330     else
 331     generate_flatten_instance ctx fun_defs oc id vars equs;
 332     close_out oc;
 333   with exn -> close_out oc; raise exn
 334
 335 and generate_initial_description ctx filename fun_defs id flat_inst =
 336   let oc = open_out (filename ^ "_init.xml") in
 337   try
 338     let varss = List.map (function Rel r -> r) flat_inst.abstract_relations in
 339     let vars =
 340       List.fold_left add_component flat_inst.variables (List.flatten varss)
 341     and equs = flat_inst.initial_equations in
 342     generate_flatten_XML ctx fun_defs oc id vars equs;
 343     generate_relations filename vars flat_inst.abstract_relations;
 344     close_out oc;
 345   with exn -> close_out oc; raise exn
 346
 347 and generate_function_definitions ctx filename fun_defs =
 348   let generate_function_definitions' oc =
 349     try
 350       let _ = List.fold_left (generate_function_definition oc) [] fun_defs in
 351       close_out oc
 352     with exn -> close_out oc; raise exn in
 353   match fun_defs with
 354   | [] -> ()
 355   | _ ->
 356     let oc = open_out (filename ^ "_functions.mo") in
 357     generate_function_definitions' oc
 358
 359 and collect_component_elements cpnt_desc =
 360   let ctx =
 361     {path = cpnt_desc.Instantiation.component_path;
 362      location = cpnt_desc.Instantiation.component_location;
 363      instance_nature =
 364        Instantiation.ComponentElement cpnt_desc.Instantiation.class_name} in
 365   match evaluate cpnt_desc.Instantiation.component_nature with
 366     | Instantiation.DynamicArray _ ->
 367         raise (GenericError
 368           { err_msg = ["_NotYetImplemented"; "_DynamicArrayType"];
 369             err_info = [];
 370             err_ctx = ctx })
 371     | Instantiation.Instance inst -> collect_instance_elements ctx inst
 372     | Instantiation.PredefinedTypeInstance _
 373       when is_fixed_parameter cpnt_desc ->
 374         {
 375           variables = [];
 376           dynamic_equations = [];
 377           initial_equations = [];
 378           abstract_relations = []
 379         }
 380     | Instantiation.PredefinedTypeInstance _ ->
 381                           let decl_equs = collect_declaration_equation cpnt_desc in
 382         {
 383           variables = [ cpnt_desc ];
 384           dynamic_equations = decl_equs;
 385           initial_equations = decl_equs;
 386           abstract_relations = []
 387         }
 388     | Instantiation.StaticArray cpnt_descs ->
 389         collect_array_elements cpnt_descs
 390
 391 and collect_instance_elements ctx inst =
 392   let elts = evaluate inst.Instantiation.elements in
 393   let named_elts = elts.Instantiation.named_elements
 394   and unnamed_elts = elts.Instantiation.unnamed_elements in
 395   let flat_inst = collect_instance_named_elements named_elts
 396   and dyn_equs, init_equs =
 397     List.fold_left (collect_equations ctx) ([], []) unnamed_elts in
 398   let init_equs, rels =
 399     List.fold_left
 400       (introduce_derivative_variables ctx)
 401       ([], [])
 402       (dyn_equs @ init_equs) in
 403   { flat_inst with
 404     dynamic_equations = flat_inst.dynamic_equations @ dyn_equs;
 405     initial_equations = flat_inst.initial_equations @ init_equs;
 406     abstract_relations = flat_inst.abstract_relations @ rels
 407   }
 408
 409 and collect_instance_named_elements named_elts =
 410   let collect_instance_named_elements' flat_inst (_, elt_desc) =
 411     let elt_nat = evaluate elt_desc.Instantiation.element_nature in
 412     match elt_nat with
 413       | Instantiation.Class _ -> flat_inst
 414       | Instantiation.Component cpnt_desc ->
 415           let flat_inst' = collect_component_elements cpnt_desc in
 416           {
 417             variables = flat_inst.variables @ flat_inst'.variables;
 418             dynamic_equations =
 419               flat_inst.dynamic_equations @ flat_inst'.dynamic_equations;
 420             initial_equations =
 421               flat_inst.initial_equations @ flat_inst'.initial_equations;
 422             abstract_relations =
 423               flat_inst.abstract_relations @ flat_inst'.abstract_relations
 424           } in
 425   let flat_inst =
 426     {
 427       variables = [];
 428       dynamic_equations = [];
 429       initial_equations = [];
 430       abstract_relations = []
 431     } in
 432   List.fold_left collect_instance_named_elements' flat_inst named_elts
 433
 434 and introduce_derivative_variables ctx (init_equs, rels) equ =
 435   let rec introduce_derivative_variables' expr = match expr with
 436     | Instantiation.BinaryOperation (oper_kind, expr1, expr2) ->
 437         let expr1, cpnt_descs1 = introduce_derivative_variables' expr1
 438         and expr2, cpnt_descs2 = introduce_derivative_variables' expr2 in
 439         Instantiation.BinaryOperation (oper_kind, expr1, expr2),
 440         cpnt_descs1 @ cpnt_descs2
 441     | Instantiation.FunctionCall
 442         (Instantiation.PredefinedIdentifier "der",
 443          [ Instantiation.ComponentReference cpnt_desc ]) ->
 444         let cpnt_desc' = component_derivative cpnt_desc in
 445         Instantiation.ComponentReference cpnt_desc',
 446         [ cpnt_desc' ]
 447     | Instantiation.FunctionCall
 448         (Instantiation.PredefinedIdentifier "der", _) ->
 449         raise (GenericError
 450           { err_msg = ["_NotYetImplemented"; "_UnsupportedDerOperArg"];
 451             err_info = [];
 452             err_ctx = ctx }) (*error*)
 453     | Instantiation.If (alts, default) ->
 454         let f (cond, expr) =
 455           let cond, cpnt_descs1 = introduce_derivative_variables' cond
 456           and expr, cpnt_descs2 = introduce_derivative_variables' expr in
 457           (cond, expr), cpnt_descs1 @ cpnt_descs2 in
 458         let alts, cpnt_descss = List.split (List.map f alts) in
 459         let default, cpnt_descs' = introduce_derivative_variables' default in
 460         Instantiation.If (alts, default),
 461         (List.flatten cpnt_descss) @ cpnt_descs'
 462     | Instantiation.IndexedAccess (expr, exprs) ->
 463         let expr, cpnt_descs = introduce_derivative_variables' expr in
 464         Instantiation.IndexedAccess (expr, exprs),
 465         cpnt_descs
 466     | Instantiation.NoEvent expr ->
 467         let expr, cpnt_descs = introduce_derivative_variables' expr in
 468         Instantiation.NoEvent expr,
 469         cpnt_descs
 470     | Instantiation.UnaryOperation (oper_kind, expr) ->
 471         let expr, cpnt_descs = introduce_derivative_variables' expr in
 472         Instantiation.UnaryOperation (oper_kind, expr),
 473         cpnt_descs
 474     | Instantiation.VectorReduction (exprs, expr) ->
 475         let expr, cpnt_descs = introduce_derivative_variables' expr in
 476         Instantiation.VectorReduction (exprs, expr),
 477         cpnt_descs
 478     | Instantiation.Record record_elts ->
 479         let f (id, expr) =
 480           let expr, cpnt_descs = introduce_derivative_variables' expr in
 481           (id, expr), cpnt_descs in
 482         let record_elts, cpnt_descs = List.split (List.map f record_elts) in
 483         Instantiation.Record record_elts,
 484         List.flatten cpnt_descs
 485     | Instantiation.Tuple exprs ->
 486         let exprs' = List.map introduce_derivative_variables' exprs in
 487         let exprs', cpnt_descs' = List.split exprs' in
 488         Instantiation.Tuple exprs',
 489         List.flatten cpnt_descs'
 490     | Instantiation.Vector exprs ->
 491         let exprs' = Array.map introduce_derivative_variables' exprs in
 492         let exprs', cpnt_descs' = List.split (Array.to_list exprs') in
 493         Instantiation.Vector (Array.of_list exprs'),
 494         List.flatten cpnt_descs'
 495     | Instantiation.FunctionCall (expr, exprs) ->
 496         let exprs' = List.map introduce_derivative_variables' exprs in
 497         let exprs', cpnt_descs' = List.split exprs' in
 498         Instantiation.FunctionCall (expr, exprs'),
 499         List.flatten cpnt_descs'
 500     | Instantiation.ComponentReference cpnt_desc -> expr, [ cpnt_desc ]
 501     | _ -> expr, [] in
 502   match equ with
 503   | Instantiation.Equal (expr1, expr2) ->
 504       let expr1, cpnt_descs1 = introduce_derivative_variables' expr1
 505       and expr2, cpnt_descs2 = introduce_derivative_variables' expr2 in
 506       let cpnt_descs =
 507         List.fold_left add_component [] (cpnt_descs1 @ cpnt_descs2) in
 508       (Instantiation.Equal (expr1, expr2)) :: init_equs,
 509       (Rel cpnt_descs) :: rels
 510   | Instantiation.ConnectFlows _ | Instantiation.ConditionalEquationE _ |
 511     Instantiation.WhenClauseE _ -> init_equs, rels
 512
 513 and collect_equations ctx (dyn_equs, init_equs) unnamed_elt =
 514   match unnamed_elt with
 515   | Instantiation.EquationClause (NameResolve.Permanent, equs) ->
 516       dyn_equs @ (expand_equations ctx (evaluate equs)), init_equs
 517   | Instantiation.EquationClause (NameResolve.Initial, equs) ->
 518       dyn_equs, init_equs @ (expand_equations ctx (evaluate equs))
 519   | Instantiation.AlgorithmClause _ ->
 520       raise (GenericError
 521         { err_msg = ["_NotYetImplemented"; "_AlgorithmClause"];
 522           err_info = [];
 523           err_ctx = ctx }) (*error*)
 524
 525 and expand_equations ctx equs =
 526   let expand_equation equ = equ.Instantiation.nature in
 527   let add_connection (expr, sign) (expr', sign') cnect_sets =
 528     let contains_at_least_one_node_to_connect cnect_set =
 529       List.mem_assoc expr cnect_set || List.mem_assoc expr' cnect_set in
 530     let cnect_sets, cnect_sets' =
 531       List.partition contains_at_least_one_node_to_connect cnect_sets in
 532     match cnect_sets with
 533       | [] -> [(expr, sign); (expr', sign')] :: cnect_sets'
 534       | [cnect_set; cnect_set'] -> (cnect_set @ cnect_set') :: cnect_sets'
 535       | [cnect_set] when List.mem_assoc expr cnect_set ->
 536           ((expr', sign') :: cnect_set) :: cnect_sets'
 537       | [cnect_set] -> ((expr, sign) :: cnect_set) :: cnect_sets'
 538       | _ :: _ :: _ :: _ -> assert false in
 539   let expand_connection cnect_sets = function
 540     | Instantiation.ConnectFlows (sign, expr, sign', expr') ->
 541         add_connection (expr, sign) (expr', sign') cnect_sets
 542     | Instantiation.Equal _ | Instantiation.ConditionalEquationE _ |
 543       Instantiation.WhenClauseE _ -> cnect_sets in
 544   let generate_flow_equation cnect_set =
 545     let to_expression (expr, sign) = match sign with
 546       | NameResolve.Positive -> expr
 547       | NameResolve.Negative ->
 548           Instantiation.UnaryOperation (Instantiation.UnaryMinus, expr) in
 549     let add_expressions expr expr' =
 550       Instantiation.BinaryOperation (Instantiation.Plus, expr, expr') in
 551     let exprs = List.map to_expression cnect_set in
 552     let lhs = List.fold_left add_expressions (Instantiation.Real 0.) exprs in
 553     Instantiation.Equal (lhs, Instantiation.Real 0.) in
 554   let collect_equation equs equ = match equ with
 555     | Instantiation.ConnectFlows _ -> equs
 556     | Instantiation.Equal _ | Instantiation.ConditionalEquationE _ |
 557       Instantiation.WhenClauseE _ -> equ :: equs in
 558   let equ_descs = List.flatten (List.map expand_equation equs) in
 559   let cnect_sets = List.fold_left expand_connection [] equ_descs
 560   and equs = List.fold_left collect_equation [] equ_descs in
 561   let equs' = List.map generate_flow_equation cnect_sets in
 562   equs @ equs'
 563
 564 and collect_array_elements cpnt_descs =
 565   let rec collect_array_elements' flat_inst i =
 566     if i = Array.length cpnt_descs then flat_inst
 567     else
 568       let flat_inst' = collect_component_elements cpnt_descs.(i) in
 569       let flat_inst =
 570         {
 571           variables = flat_inst.variables @ flat_inst'.variables;
 572           dynamic_equations =
 573             flat_inst.dynamic_equations @ flat_inst'.dynamic_equations;
 574           initial_equations =
 575             flat_inst.initial_equations @ flat_inst'.initial_equations;
 576           abstract_relations =
 577             flat_inst.abstract_relations @ flat_inst'.abstract_relations
 578         } in
 579       collect_array_elements' flat_inst (i + 1) in
 580   let flat_inst =
 581     {
 582       variables = [];
 583       dynamic_equations = [];
 584       initial_equations = [];
 585       abstract_relations = []
 586     } in
 587   collect_array_elements' flat_inst 0
 588
 589 and collect_declaration_equation cpnt_desc =
 590   let var = cpnt_desc.Instantiation.variability
 591   and equ = cpnt_desc.Instantiation.declaration_equation in
 592   match var, equ with
 593   | (Types.Continuous | Types.Discrete), Some expr ->
 594       let expr' = Instantiation.ComponentReference cpnt_desc in
 595       [ Instantiation.Equal (expr', evaluate expr) ]
 596   | _ -> []
 597
 598 and generate_flatten_instance ctx fun_defs oc id vars equs =
 599   Printf.fprintf oc "class %s\n" id;
 600   List.iter (generate_variable_declaration ctx oc) vars;
 601   Printf.fprintf oc "equation\n";
 602   generate_equation_descriptions ctx fun_defs oc equs;
 603   Printf.fprintf oc "end %s;\n" id
 604
 605 and generate_variable_declaration ctx oc cpnt_desc =
 606   Printf.fprintf oc "\t";
 607   generate_variable_variability oc cpnt_desc;
 608   generate_variable_causality oc cpnt_desc;
 609   generate_variable_type ctx oc cpnt_desc;
 610   generate_variable_name oc cpnt_desc;
 611   generate_variable_start_value ctx oc cpnt_desc;
 612   generate_initialization ctx oc cpnt_desc;
 613   generate_comment oc cpnt_desc;
 614   Printf.fprintf oc ";\n"
 615
 616 and generate_variable_variability oc cpnt_desc =
 617   match cpnt_desc.Instantiation.variability with
 618     | Types.Constant -> Printf.fprintf oc "constant "
 619     | Types.Parameter -> Printf.fprintf oc "parameter "
 620     | Types.Discrete -> Printf.fprintf oc "discrete "
 621     | Types.Continuous -> ()
 622
 623 and generate_variable_causality oc cpnt_desc =
 624   let inout = cpnt_desc.Instantiation.causality in
 625   match inout with
 626     | Types.Input -> Printf.fprintf oc "input "
 627     | Types.Output -> Printf.fprintf oc "output "
 628     | Types.Acausal -> ()
 629
 630 and generate_variable_type ctx oc cpnt_desc =
 631   let generate_variable_type' predef =
 632     let var = cpnt_desc.Instantiation.variability in
 633     match predef.Instantiation.predefined_type, var with
 634       | Instantiation.IntegerType, Types.Parameter  ->
 635           Printf.fprintf oc "Integer "
 636       | Instantiation.IntegerType, _  ->
 637           raise (GenericError
 638             { err_msg = ["_NotYetImplemented"; "_IntegerType"];
 639               err_info = [];
 640               err_ctx = ctx }) (*error*)
 641       | Instantiation.RealType, _ -> Printf.fprintf oc "Real "
 642       | Instantiation.BooleanType, _ ->
 643           raise (GenericError
 644             { err_msg = ["_NotYetImplemented"; "_BooleanType"];
 645               err_info = [];
 646               err_ctx = ctx }) (*error*)
 647       | Instantiation.StringType, Types.Parameter ->
 648           Printf.fprintf oc "String "
 649       | Instantiation.StringType, _ ->
 650           raise (GenericError
 651             { err_msg = ["_NotYetImplemented"; "_StringType"];
 652               err_info = [];
 653               err_ctx = ctx }) (*error*)
 654       | Instantiation.EnumerationType, _ ->
 655           raise (GenericError
 656             { err_msg = ["_NotYetImplemented"; "_EnumType"];
 657               err_info = [];
 658               err_ctx = ctx }) (*error*) in
 659   let var_type = evaluate cpnt_desc.Instantiation.component_nature in
 660   match var_type with
 661     | Instantiation.PredefinedTypeInstance predef ->
 662         generate_variable_type' predef
 663     | Instantiation.DynamicArray _ ->
 664         raise (GenericError
 665           { err_msg = ["_NotYetImplemented"; "_DynamicArrayType"];
 666             err_info = [];
 667             err_ctx = ctx }) (*error*)
 668     | Instantiation.Instance _ ->
 669         raise (GenericError
 670           { err_msg = ["_NotYetImplemented"; "_InstanceType"];
 671             err_info = [];
 672             err_ctx = ctx }) (*error*)
 673     | Instantiation.StaticArray _ ->
 674         raise (GenericError
 675           { err_msg = ["_NotYetImplemented"; "_StaticArrayType"];
 676             err_info = [];
 677             err_ctx = ctx }) (*error*)
 678
 679 and generate_variable_name oc cpnt_desc =
 680   let name = ident_of_path cpnt_desc.Instantiation.component_path in
 681   Printf.fprintf oc "%s" name
 682
 683 and generate_variable_start_value ctx oc cpnt_desc =
 684   let generate_start_value attrs =
 685     try
 686       let expr = evaluate (List.assoc "start" attrs) in
 687       Printf.fprintf oc "(start=%s)"
 688         (string_of_expression ctx [] expr)
 689     with Not_found -> () in
 690   let generate_variable_start_value' predef =
 691     let attrs = predef.Instantiation.attributes in
 692     generate_start_value attrs in
 693   let var_type = evaluate cpnt_desc.Instantiation.component_nature in
 694   match var_type with
 695     | Instantiation.PredefinedTypeInstance predef ->
 696         generate_variable_start_value' predef
 697     | Instantiation.DynamicArray _ ->
 698         raise (GenericError
 699           { err_msg = ["_NotYetImplemented"; "_DynamicArrayType"];
 700             err_info = [];
 701             err_ctx = ctx }) (*error*)
 702     | Instantiation.Instance _ ->
 703         raise (GenericError
 704           { err_msg = ["_NotYetImplemented"; "_InstanceType"];
 705             err_info = [];
 706             err_ctx = ctx }) (*error*)
 707     | Instantiation.StaticArray _ ->
 708         raise (GenericError
 709           { err_msg = ["_NotYetImplemented"; "_StaticArrayType"];
 710             err_info = [];
 711             err_ctx = ctx }) (*error*)
 712
 713 and string_of_path = function
 714   | [] -> assert false
 715   | [Instantiation.Name id] -> id
 716   | [Instantiation.Index i] -> Printf.sprintf "[%d]" (i + 1)
 717   | Instantiation.Name id :: path ->
 718       Printf.sprintf "%s.%s" id (string_of_path path)
 719   | Instantiation.Index i :: path ->
 720       Printf.sprintf "[%d].%s" (i + 1) (string_of_path path)
 721
 722 and ident_of_path path =
 723   let rec ident_of_path' path =
 724     match path with
 725     | [] -> assert false
 726     | [Instantiation.Name id] -> unquoted id
 727     | [Instantiation.Index i] -> Printf.sprintf "[%d]" (i + 1)
 728     | Instantiation.Name id :: path ->
 729         Printf.sprintf "%s.%s" (unquoted id) (ident_of_path' path)
 730     | Instantiation.Index i :: path ->
 731         Printf.sprintf "[%d].%s" (i + 1) (ident_of_path' path) in
 732   match path with
 733   | [] -> assert false
 734   | [Instantiation.Name id] -> assert false
 735   | [Instantiation.Index i] -> assert false
 736   | Instantiation.Name id :: path ->
 737       Printf.sprintf "`%s`" (ident_of_path' path)
 738   | Instantiation.Index i :: path -> assert false
 739
 740 and unquoted id =
 741   let n = String.length id in
 742   try
 743     match id.[0] with
 744     | '`' | '\'' -> String.sub id 1 (n - 2)
 745     | _ -> id
 746   with
 747   | _ -> id
 748
 749 and generate_initialization ctx oc cpnt_desc =
 750   let var = cpnt_desc.Instantiation.variability
 751   and equ = cpnt_desc.Instantiation.declaration_equation in
 752   match var, equ with
 753   | Types.Parameter, Some expr ->
 754       Printf.fprintf oc " = %s"
 755         (string_of_expression ctx [] (evaluate expr))
 756   | _ -> ()
 757
 758 and generate_comment oc cpnt_desc =
 759   Printf.fprintf oc " \"%s\"" cpnt_desc.Instantiation.comment
 760
 761 and generate_equation_descriptions ctx fun_defs oc equ_descs =
 762   List.iter (generate_equation_description ctx fun_defs oc) equ_descs
 763
 764 and generate_equation_description ctx fun_defs oc equ_desc =
 765   match equ_desc with
 766   | Instantiation.Equal (expr, expr') ->
 767       Printf.fprintf oc "%s" (string_of_equal ctx fun_defs expr expr')
 768   | Instantiation.ConditionalEquationE _ -> assert false
 769   | Instantiation.ConnectFlows _ -> assert false
 770   | Instantiation.WhenClauseE alts ->
 771       generate_when_clause ctx fun_defs oc alts
 772
 773 and string_of_equal ctx fun_defs expr expr' = match expr with
 774   | Instantiation.Tuple [] ->
 775       Printf.sprintf "\t%s;\n"
 776         (string_of_expression ctx fun_defs expr')
 777   | _ ->
 778       Printf.sprintf "\t%s = %s;\n"
 779         (string_of_expression ctx fun_defs expr)
 780         (string_of_expression ctx fun_defs expr')
 781
 782 and generate_when_clause ctx fun_defs oc alts = match alts with
 783   | [] -> ()
 784   | [ (expr, equs) ] ->
 785       Printf.fprintf oc "when %s then\n"
 786         (string_of_expression ctx fun_defs expr);
 787       List.iter (generate_when_equation ctx fun_defs oc) equs;
 788       Printf.fprintf oc "end when;\n"
 789   | (expr, equs) :: alts ->
 790       Printf.fprintf oc "when %s then\n"
 791         (string_of_expression ctx fun_defs expr);
 792       List.iter (generate_when_equation ctx fun_defs oc) equs;
 793       Printf.fprintf oc "else";
 794       generate_when_clause ctx fun_defs oc alts
 795
 796 and generate_when_equation ctx fun_defs oc equ =
 797   let equ' = equ.Instantiation.nature in
 798   generate_equation_descriptions ctx fun_defs oc equ'
 799
 800 and string_of_expression ctx fun_defs = function
 801   | Instantiation.BinaryOperation (bin_op, expr, expr') ->
 802       string_of_binary_operation ctx fun_defs bin_op expr expr'
 803   | Instantiation.ClassReference cl_def ->
 804       string_of_class_reference fun_defs cl_def
 805   | Instantiation.ComponentReference cpnt_desc ->
 806       ident_of_path cpnt_desc.Instantiation.component_path
 807   | Instantiation.EnumerationElement _ ->
 808       raise (GenericError
 809         { err_msg = [ "_NotYetImplemented";
 810                       "_ExprOfType";
 811                       "enumeration" ];
 812           err_info = [];
 813           err_ctx = ctx }) (*error*)
 814   | Instantiation.False ->
 815       raise (GenericError
 816         { err_msg = ["_NotYetImplemented"; "_Expr"; "false"];
 817           err_info = [];
 818           err_ctx = ctx }) (*error*)
 819   | Instantiation.FieldAccess _ ->
 820       raise (GenericError
 821         { err_msg = ["_NotYetImplemented"; "_FieldAccessExpr"];
 822           err_info = [];
 823           err_ctx = ctx }) (*error*)
 824   | Instantiation.FunctionCall (expr, exprs) ->
 825       string_of_function_call ctx fun_defs expr exprs
 826   | Instantiation.If (alts, expr) ->
 827       string_of_if ctx fun_defs alts expr
 828   | Instantiation.IndexedAccess _ ->
 829       raise (GenericError
 830         { err_msg = ["_NotYetImplemented"; "_IndexedAccessExpr"];
 831           err_info = [];
 832           err_ctx = ctx }) (*error*)
 833   | Instantiation.Integer i when Int32.to_int i >= 0 ->
 834       Printf.sprintf "%ld" i
 835   | Instantiation.Integer i ->
 836       let expr = Instantiation.Integer (Int32.neg i)
 837       and un_op = Instantiation.UnaryMinus in
 838       string_of_unary_operation ctx fun_defs un_op expr
 839   | Instantiation.LoopVariable _ ->
 840       raise (GenericError
 841         { err_msg = ["_NotYetImplemented"; "_LoopVar"];
 842           err_info = [];
 843           err_ctx = ctx }) (*error*)
 844   | Instantiation.NoEvent expr -> string_of_no_event ctx fun_defs expr
 845   | Instantiation.PredefinedIdentifier id -> Printf.sprintf "%s" id
 846   | Instantiation.Range _ ->
 847       raise (GenericError
 848         { err_msg = ["_NotYetImplemented"; "_RangeExpr"];
 849           err_info = [];
 850           err_ctx = ctx }) (*error*)
 851   | Instantiation.Real f ->
 852       Printf.sprintf "%s" (string_of_float f)
 853   | Instantiation.Record _ ->
 854       raise (GenericError
 855         { err_msg = ["_NotYetImplemented"; "_ExprOfType"; "record"];
 856           err_info = [];
 857           err_ctx = ctx }) (*error*)
 858   | Instantiation.String s -> Printf.sprintf "\"%s\"" s
 859   | Instantiation.True ->
 860       raise (GenericError
 861         { err_msg = ["_NotYetImplemented"; "_Expr"; "true"];
 862           err_info = [];
 863           err_ctx = ctx }) (*error*)
 864   | Instantiation.Tuple _ ->
 865       raise (GenericError
 866         { err_msg = ["_NotYetImplemented"; "_TupleExpr"];
 867           err_info = [];
 868           err_ctx = ctx }) (*error*)
 869   | Instantiation.UnaryOperation (un_op, expr) ->
 870       string_of_unary_operation ctx fun_defs un_op expr
 871   | Instantiation.Vector exprs ->
 872       string_of_vector ctx fun_defs exprs
 873   | Instantiation.VectorReduction _ ->
 874       raise (GenericError
 875         { err_msg = ["_NotYetImplemented"; "_VectorReduct"];
 876           err_info = [];
 877           err_ctx = ctx }) (*error*)
 878
 879 and string_of_binary_operation ctx fun_defs bin_op expr expr' =
 880   let string_of_binary_operation_kind = function
 881     | Instantiation.And -> "and"
 882     | Instantiation.Divide -> "/"
 883     | Instantiation.EqualEqual -> "=="
 884     | Instantiation.GreaterEqual -> ">="
 885     | Instantiation.Greater -> ">"
 886     | Instantiation.LessEqual -> "<="
 887     | Instantiation.Less -> "<"
 888     | Instantiation.Times -> "*"
 889     | Instantiation.NotEqual -> "<>"
 890     | Instantiation.Or -> "or"
 891     | Instantiation.Plus -> "+"
 892     | Instantiation.Power -> "^"
 893     | Instantiation.Minus -> "-" in
 894   Printf.sprintf "(%s %s %s)"
 895     (string_of_expression ctx fun_defs expr)
 896     (string_of_binary_operation_kind bin_op)
 897     (string_of_expression ctx fun_defs expr')
 898
 899 and string_of_class_reference fun_defs cl_def =
 900   let rec last = function
 901     | [] -> assert false
 902     | [Instantiation.Name id] -> id
 903     | [Instantiation.Index _] -> assert false
 904     | _ :: path -> last path in
 905   let ctx =
 906     {
 907       path = cl_def.Instantiation.class_path;
 908       location = cl_def.Instantiation.class_location;
 909       instance_nature = Instantiation.ClassElement
 910     } in
 911   let string_of_external_call ext_call =
 912     match ext_call.NameResolve.nature with
 913     | NameResolve.PrimitiveCall "builtin" |
 914       NameResolve.PrimitiveCall "C" -> last ctx.path
 915     | NameResolve.PrimitiveCall lang ->
 916         raise (GenericError
 917           { err_msg = ["_NotYetImplemented";
 918                        "_ExternalCallToLanguage";
 919                        lang];
 920             err_info = [];
 921             err_ctx = ctx }) (*error*)
 922     | NameResolve.ExternalProcedureCall _ ->
 923         raise (GenericError
 924           { err_msg = ["_NotYetImplemented";
 925                        "_ExternalProcedureCall"];
 926             err_info = [];
 927             err_ctx = ctx }) (*error*) in
 928   let string_of_long_description long_desc =
 929     match evaluate long_desc.NameResolve.external_call with
 930     | None ->
 931         raise (GenericError
 932           { err_msg = ["_NotYetImplemented";
 933                        "_NonExternalCallClassRef"];
 934             err_info = [];
 935             err_ctx = ctx }) (*error*)
 936     | Some ext_call -> string_of_external_call ext_call in
 937   match cl_def.Instantiation.description with
 938   | Instantiation.ClassDescription (_, cl_desc) ->
 939       string_of_long_description cl_desc.Instantiation.long_description
 940   | Instantiation.PredefinedType _ ->
 941       raise (GenericError
 942         { err_msg = ["_NotYetImplemented";
 943                      "_PredefinedTypeClassRef"];
 944           err_info = [];
 945           err_ctx = ctx }) (*error*)
 946
 947 and string_of_function_call ctx fun_defs expr exprs =
 948   Printf.sprintf "%s(%s)"
 949     (string_of_expression ctx fun_defs expr)
 950     (string_of_expressions ctx fun_defs exprs)
 951
 952 and string_of_expressions ctx fun_defs exprs =
 953   String.concat ", " (List.map (string_of_expression ctx fun_defs) exprs)
 954
 955 and string_of_if ctx fun_defs alts expr =
 956   let rec string_of_alternatives = function
 957     | [] -> Printf.sprintf " %s" (string_of_expression ctx fun_defs expr)
 958     | (expr, expr') :: alts ->
 959         Printf.sprintf "(if %s then %s else%s)"
 960           (string_of_expression ctx fun_defs expr)
 961           (string_of_expression ctx fun_defs expr')
 962           (string_of_alternatives alts) in
 963   string_of_alternatives alts
 964
 965 and string_of_no_event ctx fun_defs expr =
 966   Printf.sprintf "noEvent(%s)"
 967     (string_of_expression ctx fun_defs expr)
 968
 969 and string_of_unary_operation ctx fun_defs un_op expr =
 970   let string_of_unary_operation_kind = function
 971     | Instantiation.Not -> "not"
 972     | Instantiation.UnaryMinus -> "-" in
 973   Printf.sprintf "(%s %s)"
 974     (string_of_unary_operation_kind un_op)
 975     (string_of_expression ctx fun_defs expr)
 976
 977 and string_of_vector ctx fun_defs exprs =
 978   let exprs' = Array.to_list exprs in
 979   Printf.sprintf "{ %s }"
 980     (string_of_expressions ctx fun_defs exprs')
 981
 982 and last_id path =
 983   let rec last_id' id path = match path with
 984     | [] -> id
 985     | (Instantiation.Name id) :: path -> last_id' id path
 986     | (Instantiation.Index _) :: path -> last_id' id path in
 987   last_id' "" path
 988
 989 and string_of_float f =
 990   let add_parenthesis s =
 991     if String.contains s '-' then Printf.sprintf "(%s)" s else s in
 992   match Printf.sprintf "%.16g" f with
 993   | s when (String.contains s '.') || (String.contains s 'e') ->
 994       add_parenthesis s
 995   | s -> add_parenthesis (Printf.sprintf "%s." s)
 996
 997 and component_derivative cpnt_desc =
 998   let derivative_path path =
 999     let rec derivative_path' path =
1000       match path with
1001       | [] -> assert false
1002       | (Instantiation.Name s) :: path ->
1003           (Instantiation.Name ("__der_" ^ s)) :: path
1004       | (Instantiation.Index i) :: path ->
1005           (Instantiation.Index i) :: (derivative_path' path) in
1006     List.rev (derivative_path' (List.rev path)) in
1007   let path = cpnt_desc.Instantiation.component_path in
1008   let id = unquoted (ident_of_path path) in
1009   let component_derivative_nature cpnt_desc =
1010     match evaluate cpnt_desc.Instantiation.component_nature with
1011     | Instantiation.PredefinedTypeInstance predef_type_inst ->
1012         let attribs = [ "start", lazy (Instantiation.Real 0.) ] in
1013         Instantiation.PredefinedTypeInstance
1014           { predef_type_inst with Instantiation.attributes = attribs }
1015     | cpnt_nat -> cpnt_nat in
1016   {
1017     cpnt_desc with
1018     Instantiation.component_path = derivative_path path;
1019     Instantiation.component_nature =
1020       lazy (component_derivative_nature cpnt_desc);
1021     Instantiation.declaration_equation = None;
1022     Instantiation.comment = "Time derivative of " ^ id
1023   }
1024
1025 and add_component cpnt_descs cpnt_desc =
1026   let equal_components cpnt_desc cpnt_desc' =
1027     cpnt_desc.Instantiation.component_path =
1028       cpnt_desc'.Instantiation.component_path in
1029   match List.exists (equal_components cpnt_desc) cpnt_descs with
1030   | false -> cpnt_desc :: cpnt_descs
1031   | true -> cpnt_descs
1032
1033 and is_fixed_parameter cpnt_desc =
1034   match cpnt_desc.Instantiation.variability with
1035   | Types.Constant -> true
1036   | Types.Parameter -> is_fixed cpnt_desc
1037   | _ -> false
1038
1039 and is_fixed cpnt_desc =
1040   let var = cpnt_desc.Instantiation.variability
1041   and cpnt_nat = evaluate cpnt_desc.Instantiation.component_nature in
1042   let bool_of_fixed predef =
1043     match evaluate (List.assoc "fixed" predef.Instantiation.attributes) with
1044           | Instantiation.False -> false
1045     | _ -> true in
1046   match var, cpnt_nat with
1047   | Types.Constant, _ -> true
1048   | _, Instantiation.PredefinedTypeInstance predef
1049     when List.mem_assoc "fixed" predef.Instantiation.attributes ->
1050       bool_of_fixed predef
1051   | Types.Parameter, _ -> true
1052   | _ -> false
1053
1054 and defined_attribute cpnt_desc attrib_name =
1055   match evaluate cpnt_desc.Instantiation.component_nature with
1056   | Instantiation.PredefinedTypeInstance predef ->
1057       List.mem_assoc "fixed" predef.Instantiation.attributes
1058   | _ -> false
1059
1060 and generate_relations filename vars rels =
1061   let add_indentifier_stats stats cpnt_desc =
1062     match
1063       cpnt_desc.Instantiation.variability,
1064       cpnt_desc.Instantiation.causality,
1065       Lazy.force cpnt_desc.Instantiation.component_nature
1066     with
1067     | Types.Parameter, _,
1068       Instantiation.PredefinedTypeInstance
1069         { Instantiation.predefined_type = Instantiation.IntegerType } ->
1070         { stats with nb_ipars = stats.nb_ipars + 1 }
1071     | Types.Parameter, _,
1072       Instantiation.PredefinedTypeInstance
1073         { Instantiation.predefined_type = Instantiation.RealType } ->
1074         { stats with nb_rpars = stats.nb_rpars + 1 }
1075     | Types.Parameter, _,
1076       Instantiation.PredefinedTypeInstance
1077         { Instantiation.predefined_type = Instantiation.StringType } ->
1078         { stats with nb_spars = stats.nb_spars + 1 }
1079     | Types.Discrete, _, _ -> { stats with nb_dvars = stats.nb_dvars + 1 }
1080     | Types.Continuous, Types.Input, _ ->
1081         { stats with nb_inps = stats.nb_inps + 1 }
1082     | Types.Continuous, Types.Output, _ ->
1083         { stats with
1084           nb_cvars = stats.nb_cvars + 1;
1085           nb_outps = stats.nb_outps + 1
1086         }
1087     | Types.Continuous, Types.Acausal, _ ->
1088         { stats with nb_cvars = stats.nb_cvars + 1 }
1089     | _ -> stats in
1090   let variable_id cpnt_desc =
1091     let name = ident_of_path cpnt_desc.Instantiation.component_path in
1092     hide_spc (unquoted name) in
1093   let generate_identifier oc tabs cpnt_desc =
1094     let rec generate_tabs tabs =
1095       if tabs > 0 then begin
1096         Printf.fprintf oc "\t"; generate_tabs (tabs - 1)
1097       end in
1098     match
1099       cpnt_desc.Instantiation.variability,
1100       cpnt_desc.Instantiation.causality
1101     with
1102     | Types.Parameter, _ ->
1103         let id = variable_id cpnt_desc in
1104         generate_tabs tabs;
1105         Printf.fprintf oc "<parameter>%s</parameter>\n" id
1106     | Types.Constant, _ -> ()
1107     | _, (Types.Acausal | Types.Output) ->
1108         let id = variable_id cpnt_desc in
1109         generate_tabs tabs;
1110         Printf.fprintf oc "<implicit_variable>%s</implicit_variable>\n" id
1111     | _, Types.Input ->
1112         let id = variable_id cpnt_desc in
1113         generate_tabs tabs;
1114         Printf.fprintf oc "<input>%s</input>\n" id in
1115   let generate_relation oc rel =
1116     match rel with
1117     | Rel cpnt_descs ->
1118         Printf.fprintf oc "\t\t<implicit_relation>\n";
1119         List.iter (generate_identifier oc 3) cpnt_descs;
1120         Printf.fprintf oc "\t\t</implicit_relation>\n" in
1121   let generate_output oc cpnt_desc =
1122     match
1123       cpnt_desc.Instantiation.variability,
1124       cpnt_desc.Instantiation.causality
1125     with
1126     | (Types.Parameter | Types.Constant), _ |
1127       _, (Types.Acausal | Types.Input) -> ()
1128     | _, Types.Output ->
1129         let id = variable_id cpnt_desc in
1130         Printf.fprintf oc
1131           "\t\t<output>\n\
1132           \t\t\t<name>%s</name>\n\
1133           \t\t\t<dependencies>\n\
1134           \t\t\t\t<variable>%s</variable>\n\
1135           \t\t\t</dependencies>\n\
1136           \t\t</output>\n"
1137           id
1138           id in
1139   let oc' = open_out (filename ^ "_relations.xml") in
1140   Printf.fprintf oc' "<model>\n";
1141   let stats =
1142     List.fold_left
1143       add_indentifier_stats
1144       {
1145         nb_ipars = 0;
1146         nb_rpars = 0;
1147         nb_spars = 0;
1148         nb_dvars = 0;
1149         nb_cvars = 0;
1150         nb_inps = 0;
1151         nb_outps = 0
1152       }
1153       vars in
1154   Printf.fprintf oc'
1155     "\t<model_info>\n\
1156     \t\t<number_of_integer_parameters>%d</number_of_integer_parameters>\n\
1157     \t\t<number_of_real_parameters>%d</number_of_real_parameters>\n\
1158     \t\t<number_of_string_parameters>%d</number_of_string_parameters>\n\
1159     \t\t<number_of_discrete_variables>%d</number_of_discrete_variables>\n\
1160     \t\t<number_of_continuous_variables>%d</number_of_continuous_variables>\n\
1161     \t\t<number_of_continuous_unknowns>%d</number_of_continuous_unknowns>\n\
1162     \t\t<number_of_inputs>%d</number_of_inputs>\n\
1163     \t\t<number_of_outputs>%d</number_of_outputs>\n\
1164     \t</model_info>\n"
1165     stats.nb_ipars
1166     stats.nb_rpars
1167     stats.nb_spars
1168     stats.nb_dvars
1169     stats.nb_cvars
1170     stats.nb_cvars
1171     stats.nb_inps
1172     stats.nb_outps;
1173   Printf.fprintf oc' "\t<identifiers>\n";
1174   List.iter (generate_identifier oc' 2) vars;
1175   Printf.fprintf oc' "\t</identifiers>\n";
1176   Printf.fprintf oc' "\t<implicit_relations>\n";
1177   List.iter (generate_relation oc') rels;
1178   Printf.fprintf oc' "\t</implicit_relations>\n";
1179   Printf.fprintf oc' "\t<outputs>\n";
1180   List.iter (generate_output oc') vars;
1181   Printf.fprintf oc' "\t</outputs>\n";
1182   Printf.fprintf oc' "</model>\n";
1183   close_out oc'
1184
1185 and generate_flatten_XML ctx fun_defs oc id vars equs =
1186   let print_when_clause equ =
1187     let string_of_equation equ =
1188       let string_of_equation' equ_desc = match equ_desc with
1189     | Instantiation.Equal (expr, expr') ->
1190             hide_spc (string_of_equal ctx fun_defs expr expr')
1191     | _ -> assert false in
1192       String.concat
1193         " "
1194         (List.map string_of_equation' equ.Instantiation.nature) in
1195     let rec string_of_when_clause alts = match alts with
1196       | [] -> ""
1197       | [ (expr, equs) ] ->
1198           Printf.sprintf "when %s then\n %s end when;\n"
1199             (string_of_expression ctx fun_defs expr)
1200             (String.concat " " (List.map string_of_equation equs))
1201       | (expr, equs) :: alts ->
1202           Printf.sprintf "when %s then\n %s else %s"
1203             (string_of_expression ctx fun_defs expr)
1204             (String.concat " " (List.map string_of_equation equs))
1205             (string_of_when_clause alts) in
1206     match equ with
1207     | Instantiation.WhenClauseE alts ->
1208     Printf.fprintf oc "<when_clause value=\"%s\"/>\n"
1209       (string_of_when_clause alts)
1210     | _ -> ()
1211   and print_equation equ = match equ with
1212     | Instantiation.Equal (expr, expr') ->
1213     Printf.fprintf oc "<equation value=\"%s\"/>\n"
1214           (hide_spc (string_of_equal ctx fun_defs expr expr'))
1215     | _ -> () in
1216   let print_equations equs =
1217     Printf.fprintf oc "<equations>\n";
1218     List.iter print_equation equs;
1219     Printf.fprintf oc "</equations>\n"
1220   and print_when_clauses equs =
1221     Printf.fprintf oc "  <when_clauses>\n";
1222     List.iter print_when_clause equs;
1223     Printf.fprintf oc "  </when_clauses>\n" in
1224   Printf.fprintf oc "<model>\n";
1225   Printf.fprintf oc "<name>%s</name>\n" (hide_spc id);
1226   print_tree ctx fun_defs oc (build_tree vars);
1227   print_equations equs;
1228   print_when_clauses equs;
1229   Printf.fprintf oc "</model>\n"
1230
1231 and build_tree vars =
1232   let is_output caus = match caus with
1233     | Types.Output  -> true
1234     | _ -> false
1235   and variable_kind caus var = match caus, var with
1236     | Types.Input, _ -> Input
1237     | _, Types.Parameter -> Parameter
1238     | _, Types.Discrete -> DiscreteVariable
1239     | _ -> Variable
1240   and attribute_value name attrs =
1241       try
1242         Some (evaluate (List.assoc name attrs))
1243       with Not_found -> None in
1244   let variable_initial_value cpnt_desc =
1245     let cpnt_nat = evaluate cpnt_desc.Instantiation.component_nature
1246     and var = cpnt_desc.Instantiation.variability
1247     and equ = cpnt_desc.Instantiation.declaration_equation in
1248     match cpnt_nat, var, equ with
1249     | Instantiation.PredefinedTypeInstance _, Types.Parameter, Some expr ->
1250         Some (evaluate expr)
1251     | Instantiation.PredefinedTypeInstance predef,
1252       (Types.Continuous | Types.Discrete),
1253       _ ->
1254         let attrs = predef.Instantiation.attributes in
1255         attribute_value "start" attrs
1256     | _ -> None
1257   and variable_nominal_value cpnt_desc =
1258     match evaluate cpnt_desc.Instantiation.component_nature with
1259     | Instantiation.PredefinedTypeInstance predef ->
1260         let attrs = predef.Instantiation.attributes in
1261         attribute_value "nominal" attrs
1262     | _ -> None
1263   and fixed cpnt_desc =
1264     match defined_attribute cpnt_desc "fixed" with
1265     | false -> None
1266     | true -> Some (is_fixed cpnt_desc) in
1267   let terminal_element cpnt_desc =
1268     let caus = cpnt_desc.Instantiation.causality
1269     and var = cpnt_desc.Instantiation.variability in
1270     let id =
1271       unquoted (ident_of_path cpnt_desc.Instantiation.component_path) in
1272     {
1273       kind = variable_kind caus var;
1274       id = id;
1275       comment = cpnt_desc.Instantiation.comment;
1276       initial_value = variable_initial_value cpnt_desc;
1277 (*      nominal_value = variable_nominal_value cpnt_desc;
1278 *)
1279       output = is_output caus;
1280       fixed = fixed cpnt_desc
1281     } in
1282   let t_elts = List.map terminal_element vars in
1283   List.fold_left
1284     (fun ts t_elt -> insert (split t_elt.id) t_elt ts)
1285     []
1286     t_elts
1287
1288 and print_tree ctx fun_defs oc ts =
1289   let string_of_kind = function
1290     | Input -> "input"
1291     | Parameter -> "fixed_parameter"
1292     | Variable -> "variable"
1293     | DiscreteVariable -> "discrete_variable" in
1294   let string_of_initial_value elt = match elt.initial_value with
1295     | None -> ""
1296     | Some expr -> string_of_expression ctx fun_defs expr in
1297 (*  let string_of_nominal_value elt = match elt.nominal_value with
1298     | None -> ""
1299     | Some expr -> string_of_expression ctx fun_defs expr in *)
1300   let string_of_fixed elt = match elt.fixed with
1301     | None -> ""
1302     | Some true -> "true"
1303     | Some false -> "false" in
1304   let rec print_tree_element = function
1305     | Node (s, ts) ->
1306         Printf.fprintf oc "<struct>\n";
1307         Printf.fprintf oc "<name>%s</name>\n" (hide_spc s);
1308         Printf.fprintf oc "<subnodes>\n";
1309         List.iter print_tree_element ts;
1310         Printf.fprintf oc "</subnodes>\n";
1311         Printf.fprintf oc "</struct>\n"
1312     | Leaf (s, elt) ->
1313         Printf.fprintf oc "<terminal>\n";
1314         Printf.fprintf oc "<name>%s</name>\n" (hide_spc s);
1315         Printf.fprintf oc "<kind>%s</kind>\n" (string_of_kind elt.kind);
1316         Printf.fprintf oc "<id>%s</id>\n" (hide_spc elt.id);
1317         Printf.fprintf oc "<fixed value=\"%s\"/>\n" (string_of_fixed elt);
1318         Printf.fprintf oc "<initial_value value=\"%s\"/>\n"
1319           (hide_spc (unbraced (string_of_initial_value elt)));
1320 (*        Printf.fprintf oc "<nominal_value value=\"%s\"/>\n"
1321           (hide_spc (unbraced (string_of_nominal_value elt)));
1322 *)
1323         Printf.fprintf oc "<comment value=\"%s\"/>\n" (hide_spc elt.comment);
1324         if elt.output then
1325           Printf.fprintf oc "<output/>\n";
1326         if elt.kind <> Parameter && elt.initial_value <> None then
1327           Printf.fprintf oc "<selected value=\"y\" />\n";
1328         Printf.fprintf oc "</terminal>\n"
1329   in
1330   Printf.fprintf oc "  <elements>\n";
1331   List.iter print_tree_element ts;
1332   Printf.fprintf oc "  </elements>\n"
1333
1334 and insert path x ts =
1335   let rec insert' s path' = function
1336     | [] -> [Node (s, insert path' x [])]
1337     | Node (s', ts'') :: ts' when s = s' -> Node (s', insert path' x ts'') :: ts'
1338     | t' :: ts' -> t' :: insert' s path' ts' in
1339   match path with
1340   | [s] -> ts @ [Leaf (s, x)] (*the order of elements is important in Scicos*)
1341   | s :: path' -> insert' s path' ts
1342   | [] -> assert false
1343
1344 and cut_on_dot s =
1345   let rec cut_on_dot' i =
1346     if i = String.length s then s, None
1347       else if s.[i] = '.' then String.sub s 0 i, Some (String.sub s (i + 1) (String.length s - i - 1))
1348       else cut_on_dot' (i + 1)
1349   in cut_on_dot' 0
1350
1351 and split name =
1352   let s, name_opt = cut_on_dot name in
1353   match name_opt with
1354     | None -> [s]
1355     | Some name' -> s :: split name'