2 * Translator from Modelica 2.x to flat Modelica
4 * Copyright (C) 2005 - 2007 Imagine S.A.
5 * For more information or commercial use please contact us at www.amesim.com
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.
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.
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.
30 dynamic_scope: dynamic_scope option;
31 element_nature: element_nature
38 named_elements: (string * element_type Lazy.t) list
57 | ComponentElement of component_type
58 | ClassElement of class_specifier Lazy.t
59 | ComponentTypeElement of component_type
60 | PredefinedTypeElement of predefined_type
65 variability: variability Lazy.t;
66 causality: causality Lazy.t;
67 base_class: class_specifier Lazy.t;
70 and variability = Continuous | Discrete | Parameter | Constant
72 and causality = Acausal | Input | Output
75 | PredefinedType of predefined_type
76 | ClassType of class_type
77 | ComponentType of component_type
78 | ArrayType of dimension * class_specifier
79 | TupleType of class_specifier list
84 attributes: (string * bool) list
92 | EnumerationType of string list
95 | ConstantDimension of int32
99 type type_comparison =
106 (* Useful functions *)
108 let evaluate x = Lazy.force x
110 (* type calculations *)
112 let min_variability var var' = match var, var' with
113 | Constant, _ | _, Constant -> Constant
114 | Parameter, _ | _, Parameter -> Parameter
115 | Discrete, _ | _, Discrete -> Discrete
116 | Continuous, Continuous -> Continuous
118 and max_variability var var' = match var, var' with
119 | Continuous, _ | _, Continuous -> Continuous
120 | Discrete, _ | _, Discrete -> Discrete
121 | Parameter, _ | _, Parameter -> Parameter
122 | Constant, Constant -> Constant
124 let higher_variability var var' =
125 (max_variability var var') = var
127 and lower_variability var var' =
128 (max_variability var var') = var'
130 let add_dimensions dims cl_spec =
131 let add_dimension dim cl_spec = ArrayType (dim, cl_spec) in
132 List.fold_right add_dimension dims cl_spec
136 let empty_tuple_class_type = TupleType []
138 let boolean_class_type =
139 PredefinedType { base_type = BooleanType; attributes = ["start", false] }
141 and integer_class_type =
143 { base_type = IntegerType; attributes = ["start", false; "nominal", false] }
145 and real_class_type =
147 { base_type = RealType; attributes = ["start", false; "nominal", false] }
149 and string_class_type =
150 PredefinedType { base_type = StringType; attributes = ["start", false] }
152 and enumeration_class_type enum_lits =
154 { base_type = EnumerationType enum_lits; attributes = ["start", false] }
156 let boolean_component_type var =
159 variability = lazy var;
160 causality = lazy Acausal;
161 base_class = lazy boolean_class_type;
164 let integer_component_type var =
165 { (boolean_component_type var) with
166 base_class = lazy integer_class_type
169 let real_component_type var =
170 { (boolean_component_type var) with
171 base_class = lazy real_class_type
174 let string_component_type var =
175 { (boolean_component_type var) with
176 base_class = lazy string_class_type
179 let enumeration_component_type var enum_lits =
181 (boolean_component_type var) with
182 base_class = lazy (enumeration_class_type enum_lits)
185 let integer_array_component_type var dims =
186 let cl_spec = integer_class_type in
189 variability = lazy var;
190 causality = lazy Acausal;
191 base_class = lazy (add_dimensions dims cl_spec)
194 let empty_tuple_type var =
196 { (boolean_component_type var) with
197 base_class = lazy (empty_tuple_class_type)
200 let boolean_type var = ComponentElement (boolean_component_type var)
202 let integer_type var = ComponentElement (integer_component_type var)
204 let integer_array_type var dim =
208 PredefinedType { base_type = IntegerType; attributes = [] }) in
212 variability = lazy var;
213 causality = lazy Acausal;
214 base_class = lazy cl_spec
216 ComponentElement cpnt_type
218 let real_type var = ComponentElement (real_component_type var)
220 let string_type var =
221 ComponentElement (string_component_type var)
223 let enumeration_type var enum_lits =
224 ComponentElement (enumeration_component_type var enum_lits)
226 let function_type inputs outputs =
227 let named_elements inout args =
228 let element_type cpnt_type =
233 dynamic_scope = None;
235 ComponentElement { cpnt_type with causality = lazy inout }
237 let named_element (id, cpnt_type) = id, lazy (element_type cpnt_type) in
238 List.map named_element args in
242 kind = lazy Function;
244 named_elements Input inputs @ named_elements Output outputs
246 ClassElement (lazy (ClassType cl_type))
248 let reversed_element_dimensions elt_type =
249 let rec reversed_dimensions dims = function
250 | ArrayType (dim, cl_spec) -> reversed_dimensions (dim :: dims) cl_spec
251 | PredefinedType _ | ClassType _ | ComponentType _ | TupleType _ -> dims in
253 | ComponentElement cpnt_type ->
254 let cl_spec = evaluate cpnt_type.base_class in
255 reversed_dimensions [] cl_spec
256 | ClassElement _ | ComponentTypeElement _ | PredefinedTypeElement _ -> []
258 let scalar_component_type cpnt_type =
259 let rec scalar_class_specifier cl_spec = match cl_spec with
260 | ArrayType (_, cl_spec) -> scalar_class_specifier cl_spec
264 base_class = lazy (scalar_class_specifier (evaluate cpnt_type.base_class))
268 (* General type comparisons *)
270 let rec compare_class_types ct ct' =
271 match Lazy.force ct.kind, Lazy.force ct'.kind with
272 | Class, Class -> compare_classes ct ct'
273 | Model, Model -> compare_models ct ct'
274 | Block, Block -> compare_blocks ct ct'
275 | Record, Record -> compare_records ct ct'
276 | ExpandableConnector, ExpandableConnector ->
277 compare_expandable_connectors ct ct'
278 | Connector, Connector -> compare_connectors ct ct'
279 | Package, Package -> compare_packages ct ct'
280 | Function, Function -> compare_functions ct ct'
283 and compare_classes ct ct' =
284 let rec compare_classes' type_cmp named_elts named_elts' =
285 match named_elts' with
287 | (s', _) :: _ when not (List.mem_assoc s' named_elts) -> NotRelated
288 | (s', elt_type') :: named_elts' ->
292 (Lazy.force (List.assoc s' named_elts))
293 (Lazy.force elt_type') in
294 match type_cmp, type_cmp' with
295 | SameType, (SameType | Subtype) ->
296 compare_classes' type_cmp' named_elts named_elts'
297 | Subtype, (SameType | Subtype) ->
298 compare_classes' Subtype named_elts named_elts'
301 let named_elts = ct.named_elements
302 and named_elts' = ct'.named_elements in
303 let l = List.length named_elts
304 and l' = List.length named_elts' in
305 if l < l' then invert (compare_classes' Subtype named_elts' named_elts)
306 else if l = l' then compare_classes' SameType named_elts named_elts'
307 else compare_classes' Subtype named_elts named_elts'
309 and invert = function
310 | NotRelated -> NotRelated
311 | Subtype -> Supertype
312 | Supertype -> Subtype
313 | SameType -> SameType
315 and compare_models ct ct' = compare_classes ct ct'
317 and compare_blocks ct ct' = compare_classes ct ct'
319 and compare_records ct ct' = compare_classes ct ct'
321 and compare_expandable_connectors ct ct' = compare_classes ct ct'
323 and compare_connectors ct ct' = compare_classes ct ct'
325 and compare_packages ct ct' = compare_classes ct ct'
327 and compare_functions ct ct' = compare_classes ct ct'
329 and compare_elements elt_type elt_type' =
331 elt_type.protected = elt_type'.protected &&
332 elt_type.final = elt_type'.final &&
333 elt_type.replaceable = elt_type'.replaceable &&
334 elt_type.dynamic_scope = elt_type'.dynamic_scope
335 then compare_element_natures elt_type.element_nature elt_type'.element_nature
338 and compare_element_natures elt_nature elt_nature' = match elt_nature, elt_nature' with
339 | ComponentElement cpntt, ComponentElement cpntt' -> compare_component_types cpntt cpntt'
340 | ClassElement cs, ClassElement cs' -> compare_specifiers (Lazy.force cs) (Lazy.force cs')
341 | ComponentTypeElement cpntt, ComponentTypeElement cpntt' -> compare_component_types cpntt cpntt'
342 | PredefinedTypeElement pt, PredefinedTypeElement pt' -> compare_predefined_types pt pt'
343 | (ComponentElement _ | ClassElement _ | ComponentTypeElement _ | PredefinedTypeElement _),
344 (ComponentElement _ | ClassElement _ | ComponentTypeElement _ | PredefinedTypeElement _) ->
347 and compare_component_types cpntt cpntt' =
349 Lazy.force cpntt.flow = Lazy.force cpntt'.flow &&
350 Lazy.force cpntt.variability = Lazy.force cpntt'.variability &&
351 Lazy.force cpntt.causality = Lazy.force cpntt'.causality
353 compare_specifiers (Lazy.force cpntt.base_class) (Lazy.force cpntt'.base_class)
356 and compare_specifiers cs cs' = match cs, cs' with
357 | PredefinedType pt, PredefinedType pt' -> compare_predefined_types pt pt'
358 | ClassType ct, ClassType ct' -> compare_class_types ct ct'
359 | ComponentType cpntt, ComponentType cpntt' -> compare_component_types cpntt cpntt'
360 | ArrayType (dim, cs), ArrayType (dim', cs')
361 when compare_dimensions dim dim' ->
362 compare_specifiers cs cs'
363 | TupleType css, TupleType css' -> compare_tuple_types css css'
364 | (PredefinedType _ | ClassType _ | ComponentType _ | ArrayType _ | TupleType _),
365 (PredefinedType _ | ClassType _ | ComponentType _ | ArrayType _ | TupleType _) ->
368 and compare_dimensions dim dim' = match dim, dim' with
369 | ConstantDimension i, ConstantDimension i' when i <> i' -> false
372 and compare_tuple_types css css' =
373 if List.for_all2 (fun cs cs' -> compare_specifiers cs cs' = SameType) css css' then
377 and compare_predefined_types pt pt' = match pt.base_type, pt'.base_type with
378 | BooleanType, BooleanType -> SameType
379 | IntegerType, IntegerType -> SameType
380 | RealType, RealType -> SameType
381 | RealType, IntegerType -> Supertype
382 | IntegerType, RealType -> Subtype
383 | StringType, StringType -> SameType
384 | EnumerationType enum_elts, EnumerationType enum_elts'
385 when enum_elts = enum_elts' -> SameType
388 (* Printing utilities *)
390 let fprint_tabs oc offset =
391 for i = 1 to offset do Printf.fprintf oc "\t" done
393 let rec fprint_class_type oc id cl_type =
394 if cl_type.partial then Printf.fprintf oc "partial ";
395 fprint_kind oc (Lazy.force cl_type.kind);
396 Printf.fprintf oc "%s\n" id;
397 fprint_named_elements oc 1 cl_type.named_elements;
398 Printf.fprintf oc "end %s;\n" id
400 and fprint_kind oc = function
401 | Class -> Printf.fprintf oc "class "
402 | Model -> Printf.fprintf oc "model "
403 | Block -> Printf.fprintf oc "block "
404 | Record -> Printf.fprintf oc "record "
405 | ExpandableConnector -> Printf.fprintf oc "expandable connector "
406 | Connector -> Printf.fprintf oc "connector "
407 | Package -> Printf.fprintf oc "package "
408 | Function -> Printf.fprintf oc "function "
410 and fprint_named_elements oc offset named_elts =
412 (function (s, elt_type) -> fprint_named_element oc offset (s, Lazy.force elt_type))
415 and fprint_named_element oc offset (id, elt_type) =
416 fprint_tabs oc offset;
417 if elt_type.protected then Printf.fprintf oc "protected ";
418 if elt_type.final then Printf.fprintf oc "final ";
419 if elt_type.replaceable then Printf.fprintf oc "replaceable ";
420 fprint_dynamic_scope oc elt_type.dynamic_scope;
421 fprint_element_nature oc offset id elt_type.element_nature
423 and fprint_dynamic_scope oc = function
425 | Some Inner -> Printf.fprintf oc "inner "
426 | Some Outer -> Printf.fprintf oc "outer "
427 | Some InnerOuter -> Printf.fprintf oc "inner outer "
429 and fprint_element_nature oc offset id = function
430 | ComponentElement cpnt_type -> fprint_component_type oc offset id cpnt_type
431 | ClassElement cl_spec -> fprint_class_specifier oc offset id (Lazy.force cl_spec)
432 | ComponentTypeElement cpnt_type -> fprint_component_type_type oc offset id cpnt_type
433 | PredefinedTypeElement predef_type -> fprint_predefined_type_type oc id predef_type
435 and fprint_class_specifier oc offset id = function
436 | PredefinedType _ -> assert false
437 | ClassType cl_type -> fprint_class_type_specifier oc offset id cl_type
438 | ComponentType _ -> assert false
439 | ArrayType (_, cs) -> fprint_class_specifier oc offset id cs
440 | TupleType _ -> assert false
442 and fprint_class_type_specifier oc offset id cl_type =
443 if cl_type.partial then Printf.fprintf oc "partial ";
444 fprint_kind oc (Lazy.force cl_type.kind);
445 Printf.fprintf oc "%s\n" id;
446 fprint_named_elements oc (offset + 1) cl_type.named_elements;
447 fprint_tabs oc offset;
448 Printf.fprintf oc "end %s;\n" id
450 and fprint_component_type_type oc offset id cpnt_type =
451 Printf.fprintf oc "type %s = " id;
452 fprint_component_type oc offset "" cpnt_type;
453 Printf.fprintf oc ";\n"
455 and fprint_predefined_type_type oc id predef_type =
456 Printf.fprintf oc "type %s = " id;
457 fprint_predefined_type oc predef_type;
458 Printf.fprintf oc ";\n"
460 and fprint_component_type oc offset id cpnt_type =
461 if Lazy.force cpnt_type.flow then Printf.fprintf oc "flow ";
462 fprint_variability oc (Lazy.force cpnt_type.variability);
463 fprint_causality oc (Lazy.force cpnt_type.causality);
464 fprint_class_specifier_type oc offset (Lazy.force cpnt_type.base_class);
465 fprint_dimensions oc (Lazy.force cpnt_type.base_class);
466 Printf.fprintf oc " %s;\n" id
468 and fprint_variability oc = function
470 | Discrete -> Printf.fprintf oc "discrete "
471 | Parameter -> Printf.fprintf oc "parameter "
472 | Constant -> Printf.fprintf oc "constant "
474 and fprint_causality oc = function
476 | Input -> Printf.fprintf oc "input "
477 | Output -> Printf.fprintf oc "output "
479 and fprint_class_specifier_type oc offset = function
480 | PredefinedType predef_type -> fprint_predefined_type oc predef_type
481 | ClassType cl_type -> fprint_class_type_specifier_type oc offset cl_type
482 | ComponentType cpnt_type -> fprint_component_type_specifier_type oc offset cpnt_type
483 | ArrayType (_, cs) -> fprint_class_specifier_type oc offset cs
484 | TupleType _ -> assert false
486 and fprint_predefined_type oc predef_type = match predef_type.base_type with
487 | BooleanType -> Printf.fprintf oc "Boolean"
488 | IntegerType -> Printf.fprintf oc "Integer"
489 | RealType -> Printf.fprintf oc "Real"
490 | StringType -> Printf.fprintf oc "String"
491 | EnumerationType enum_elts -> fprint_enumeration_type oc enum_elts
493 and fprint_enumeration_type oc ss =
494 let rec fprint_enumeration_type' = function
496 | [s] -> Printf.fprintf oc "%s" s
497 | s :: ss -> Printf.fprintf oc "%s, " s; fprint_enumeration_type' ss in
498 Printf.fprintf oc "enumeration(";
499 fprint_enumeration_type' ss;
500 Printf.fprintf oc ")"
502 and fprint_class_type_specifier_type oc offset cl_type =
503 if cl_type.partial then Printf.fprintf oc "partial ";
504 fprint_kind oc (Lazy.force cl_type.kind);
505 Printf.fprintf oc "_\n";
506 fprint_named_elements oc (offset + 1) cl_type.named_elements;
507 fprint_tabs oc offset;
508 Printf.fprintf oc "end _"
510 and fprint_component_type_specifier_type oc offset cpnt_type =
511 Printf.fprintf oc "(";
512 if Lazy.force cpnt_type.flow then Printf.fprintf oc "flow ";
513 fprint_variability oc (Lazy.force cpnt_type.variability);
514 fprint_causality oc (Lazy.force cpnt_type.causality);
515 fprint_class_specifier_type oc offset (Lazy.force cpnt_type.base_class);
516 fprint_dimensions oc (Lazy.force cpnt_type.base_class);
517 Printf.fprintf oc ")"
519 and fprint_dimensions oc cs =
520 let fprint_dimension = function
521 | ConstantDimension d -> Printf.fprintf oc "%ld" d
522 | ParameterDimension -> Printf.fprintf oc "p"
523 | DiscreteDimension -> Printf.fprintf oc ":" in
524 let rec fprint_dimensions' dim = function
525 | PredefinedType _ | ClassType _ | ComponentType _ | TupleType _ ->
527 | ArrayType (dim', cs') ->
528 fprint_dimension dim;
529 Printf.fprintf oc ", ";
530 fprint_dimensions' dim' cs' in
532 | PredefinedType _ | ClassType _ | ComponentType _ | TupleType _ -> ()
533 | ArrayType (dim, cs) ->
534 Printf.fprintf oc "["; fprint_dimensions' dim cs; Printf.fprintf oc "]"
536 (* String conversion utilities *)
538 let rec string_of_kind kind = match kind with
542 | Record -> "record "
543 | ExpandableConnector -> "expandable connector "
544 | Connector -> "connector "
545 | Package -> "package "
546 | Function -> "function "
548 and string_of_dynamic_scope dyn_scope = match dyn_scope with
550 | Some Inner -> "inner "
551 | Some Outer -> "outer "
552 | Some InnerOuter -> "inner outer "
554 and string_of_class_specifier cl_spec =
555 let string_of_dimension dim = match dim with
556 | ConstantDimension d -> Int32.to_string d
557 | ParameterDimension -> "p"
558 | DiscreteDimension -> ":" in
559 let string_of_dimensions dims =
560 let rec string_of_dimensions' dims = match dims with
562 | [dim] -> string_of_dimension dim
564 (string_of_dimension dim) ^ ", " ^ (string_of_dimensions' dims) in
567 | _ -> "[" ^ (string_of_dimensions' dims) ^ "]" in
568 let rec string_of_class_specifier' dims cl_spec = match cl_spec with
569 | PredefinedType predef_type ->
570 (string_of_predefined_type predef_type) ^
571 (string_of_dimensions dims)
572 | ClassType cl_type ->
573 (string_of_class_type cl_type) ^
574 (string_of_dimensions dims)
575 | ComponentType cpnt_type ->
576 (string_of_component_type cpnt_type) ^
577 (string_of_dimensions dims)
578 | ArrayType (dim, cs) ->
579 string_of_class_specifier' (dim :: dims) cs
580 | TupleType cl_specs ->
581 "(" ^ (string_of_tuple_type cl_specs) ^ ")" ^
582 (string_of_dimensions dims) in
583 string_of_class_specifier' [] cl_spec
585 and string_of_tuple_type cl_specs = match cl_specs with
587 | [cl_spec] -> string_of_class_specifier cl_spec
588 | cl_spec :: cl_specs ->
589 (string_of_class_specifier cl_spec) ^ ", " ^
590 (string_of_tuple_type cl_specs)
592 and string_of_class_type cl_type =
593 string_of_kind (Lazy.force cl_type.kind)
595 and string_of_component_type cpnt_type =
596 string_of_class_specifier (Lazy.force cpnt_type.base_class)
598 and string_of_variability var = match var with
599 | Continuous -> "continuous"
600 | Discrete -> "discrete"
601 | Parameter -> "parameter"
602 | Constant -> "constant"
604 and string_of_causality c = match c with
609 and string_of_predefined_type predef_type =
610 string_of_base_type predef_type.base_type
612 and string_of_base_type base_type = match base_type with
613 | BooleanType -> "Boolean"
614 | IntegerType -> "Integer"
616 | StringType -> "String"
617 | EnumerationType enum_elts -> string_of_enumeration_type enum_elts
619 and string_of_enumeration_type ss =
620 let rec string_of_enumeration_type' ss = match ss with
623 | s :: ss -> s ^ ", " ^ (string_of_enumeration_type' ss) in
624 "enumeration(" ^ (string_of_enumeration_type' ss) ^ ")"
626 and string_of_element_nature = function
627 | ComponentElement _ -> "_ComponentElement"
628 | ClassElement _ -> "_ClassElement"
629 | ComponentTypeElement _ -> "_ComponentTypeElement"
630 | PredefinedTypeElement _ -> "_PredefinedTypeElement"