end of line
[scilab.git] / 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'