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