end of line
[scilab.git] / scilab / modules / scicos / src / translator / compilation / types.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
24
25 type element_type =
26   {
27     protected: bool;
28     final: bool;
29     replaceable: bool;
30     dynamic_scope: dynamic_scope option;
31     element_nature: element_nature
32   }
33
34 and class_type =
35   {
36     partial: bool;
37     kind: kind Lazy.t;
38     named_elements: (string * element_type Lazy.t) list
39   }
40
41 and kind =
42   | Class
43   | Model
44   | Block
45   | Record
46   | ExpandableConnector
47   | Connector
48   | Package
49   | Function
50
51 and dynamic_scope =
52   | Inner
53   | Outer
54   | InnerOuter
55
56 and element_nature =
57   | ComponentElement of component_type
58   | ClassElement of class_specifier Lazy.t
59   | ComponentTypeElement of component_type
60   | PredefinedTypeElement of predefined_type
61
62 and component_type =
63   {
64     flow: bool Lazy.t;
65     variability: variability Lazy.t;
66     causality: causality Lazy.t;
67     base_class: class_specifier Lazy.t;
68   }
69
70 and variability = Continuous | Discrete | Parameter | Constant
71
72 and causality = Acausal | Input | Output
73
74 and class_specifier =
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
80
81 and predefined_type =
82   {
83     base_type: base_type;
84     attributes: (string * bool) list
85  }
86
87 and base_type =
88   | BooleanType
89   | IntegerType
90   | RealType
91   | StringType
92   | EnumerationType of string list
93
94 and dimension =
95   | ConstantDimension of int32
96   | ParameterDimension
97   | DiscreteDimension
98
99 type type_comparison =
100   | NotRelated
101   | Subtype
102   | Supertype
103   | SameType
104
105
106 (* Useful functions *)
107
108 let evaluate x = Lazy.force x
109
110 (* type calculations *)
111
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
117
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
123
124 let higher_variability var var' =
125   (max_variability var var') = var
126
127 and lower_variability var var' =
128   (max_variability var var') = var'
129
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
133
134 (* Utilities *)
135
136 let empty_tuple_class_type = TupleType []
137
138 let boolean_class_type =
139   PredefinedType { base_type = BooleanType; attributes = ["start", false] }
140
141 and integer_class_type =
142   PredefinedType
143     { base_type = IntegerType; attributes = ["start", false; "nominal", false] }
144
145 and real_class_type =
146   PredefinedType
147     { base_type = RealType; attributes = ["start", false; "nominal", false] }
148
149 and string_class_type =
150   PredefinedType { base_type = StringType; attributes = ["start", false] }
151
152 and enumeration_class_type enum_lits =
153   PredefinedType
154     { base_type = EnumerationType enum_lits; attributes = ["start", false] }
155
156 let boolean_component_type var =
157   {
158     flow = lazy false;
159     variability = lazy var;
160     causality = lazy Acausal;
161     base_class = lazy boolean_class_type;
162   }
163
164 let integer_component_type var =
165   { (boolean_component_type var) with
166     base_class = lazy integer_class_type
167   }
168
169 let real_component_type var =
170   { (boolean_component_type var) with
171     base_class = lazy real_class_type
172   }
173
174 let string_component_type var =
175   { (boolean_component_type var) with
176     base_class = lazy string_class_type
177   }
178
179 let enumeration_component_type var enum_lits =
180   { 
181     (boolean_component_type var) with
182     base_class = lazy (enumeration_class_type enum_lits)
183   }
184
185 let integer_array_component_type var dims =
186   let cl_spec = integer_class_type in
187   {
188     flow = lazy false;
189     variability = lazy var;
190     causality = lazy Acausal;
191     base_class = lazy (add_dimensions dims cl_spec)
192   }
193
194 let empty_tuple_type var =
195   ComponentElement
196     { (boolean_component_type var) with
197       base_class = lazy (empty_tuple_class_type)
198     }
199
200 let boolean_type var = ComponentElement (boolean_component_type var)
201
202 let integer_type var = ComponentElement (integer_component_type var)
203
204 let integer_array_type var dim =
205   let cl_spec =
206     ArrayType
207       (dim,
208        PredefinedType { base_type = IntegerType; attributes = [] }) in
209   let cpnt_type =
210     {
211       flow = lazy false;
212       variability = lazy var;
213       causality = lazy Acausal;
214       base_class = lazy cl_spec
215     } in
216   ComponentElement cpnt_type
217
218 let real_type var = ComponentElement (real_component_type var)
219
220 let string_type var =
221   ComponentElement (string_component_type var)
222
223 let enumeration_type var enum_lits =
224   ComponentElement (enumeration_component_type var enum_lits)
225
226 let function_type inputs outputs =
227   let named_elements inout args =
228     let element_type cpnt_type =
229       {
230         protected = false;
231         final = true;
232         replaceable = false;
233         dynamic_scope = None;
234         element_nature =
235           ComponentElement { cpnt_type with causality = lazy inout }
236       } in
237     let named_element (id, cpnt_type) = id, lazy (element_type cpnt_type) in
238     List.map named_element args in
239   let cl_type =
240     {
241       partial = false;
242       kind = lazy Function;
243       named_elements =
244         named_elements Input inputs @ named_elements Output outputs
245     } in
246   ClassElement (lazy (ClassType cl_type))
247
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
252   match elt_type with
253     | ComponentElement cpnt_type ->
254         let cl_spec = evaluate cpnt_type.base_class in
255         reversed_dimensions [] cl_spec
256     | ClassElement _ | ComponentTypeElement _ | PredefinedTypeElement _ -> []
257
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
261     | _ -> cl_spec in
262   {
263     cpnt_type with
264     base_class = lazy (scalar_class_specifier (evaluate cpnt_type.base_class))
265   }
266
267
268 (* General type comparisons *)
269
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'
281   | _ -> NotRelated
282
283 and compare_classes ct ct' =
284   let rec compare_classes' type_cmp named_elts named_elts' =
285     match named_elts' with
286     | [] -> type_cmp
287     | (s', _) :: _ when not (List.mem_assoc s' named_elts) -> NotRelated
288     | (s', elt_type') :: named_elts' ->
289         begin
290           let type_cmp' =
291             compare_elements
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'
299             | _ -> NotRelated
300         end in
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'
308
309 and invert = function
310   | NotRelated -> NotRelated
311   | Subtype -> Supertype
312   | Supertype -> Subtype
313   | SameType -> SameType
314
315 and compare_models ct ct' = compare_classes ct ct'
316
317 and compare_blocks ct ct' = compare_classes ct ct'
318
319 and compare_records ct ct' = compare_classes ct ct'
320
321 and compare_expandable_connectors ct ct' = compare_classes ct ct'
322
323 and compare_connectors ct ct' = compare_classes ct ct'
324
325 and compare_packages ct ct' = compare_classes ct ct'
326
327 and compare_functions ct ct' = compare_classes ct ct'
328
329 and compare_elements elt_type elt_type' =
330   if
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
336   else NotRelated
337
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 _) ->
345       NotRelated
346
347 and compare_component_types cpntt cpntt' =
348   (*if
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
352   then*)
353     compare_specifiers (Lazy.force cpntt.base_class) (Lazy.force cpntt'.base_class)
354   (*else NotRelated*)
355
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 _) ->
366       NotRelated
367
368 and compare_dimensions dim dim' = match dim, dim' with
369   | ConstantDimension i, ConstantDimension i' when i <> i' -> false
370   | _ -> true
371
372 and compare_tuple_types css css' =
373   if List.for_all2 (fun cs cs' -> compare_specifiers cs cs' = SameType) css css' then
374     SameType
375   else NotRelated
376
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
386   | _ -> NotRelated
387
388 (* Printing utilities *)
389
390 let fprint_tabs oc offset =
391   for i = 1 to offset do Printf.fprintf oc "\t" done
392
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
399
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 "
409
410 and fprint_named_elements oc offset named_elts =
411   List.iter
412     (function (s, elt_type) -> fprint_named_element oc offset (s, Lazy.force elt_type))
413     named_elts
414
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
422
423 and fprint_dynamic_scope oc = function
424   | None -> ()
425   | Some Inner -> Printf.fprintf oc "inner "
426   | Some Outer -> Printf.fprintf oc "outer "
427   | Some InnerOuter -> Printf.fprintf oc "inner outer "
428
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
434
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
441
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
449
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"
454
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"
459
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
467
468 and fprint_variability oc = function
469   | Continuous -> ()
470   | Discrete -> Printf.fprintf oc "discrete "
471   | Parameter -> Printf.fprintf oc "parameter "
472   | Constant -> Printf.fprintf oc "constant "
473
474 and fprint_causality oc = function
475   | Acausal -> ()
476   | Input -> Printf.fprintf oc "input "
477   | Output -> Printf.fprintf oc "output "
478
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
485
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
492
493 and fprint_enumeration_type oc ss =
494   let rec fprint_enumeration_type' = function
495     | [] -> ()
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 ")"
501
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 _"
509
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 ")"
518
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 _ ->
526         fprint_dimension dim
527     | ArrayType (dim', cs') ->
528         fprint_dimension dim;
529         Printf.fprintf oc ", ";
530         fprint_dimensions' dim' cs' in
531   match cs with
532     | PredefinedType _ | ClassType _ | ComponentType _ | TupleType _ -> ()
533     | ArrayType (dim, cs) ->
534         Printf.fprintf oc "["; fprint_dimensions' dim cs; Printf.fprintf oc "]"
535
536 (* String conversion utilities *)
537
538 let rec string_of_kind kind = match kind with
539   | Class -> "class "
540   | Model -> "model "
541   | Block -> "block "
542   | Record -> "record "
543   | ExpandableConnector -> "expandable connector "
544   | Connector -> "connector "
545   | Package -> "package "
546   | Function -> "function "
547
548 and string_of_dynamic_scope dyn_scope = match dyn_scope with
549   | None -> ""
550   | Some Inner -> "inner "
551   | Some Outer -> "outer "
552   | Some InnerOuter -> "inner outer "
553
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
561       | [] -> ""
562       | [dim] -> string_of_dimension dim
563       | dim :: dims ->
564           (string_of_dimension dim) ^ ", " ^ (string_of_dimensions' dims) in
565     match dims with
566       | [] -> ""
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
584
585 and string_of_tuple_type cl_specs = match cl_specs with
586   | [] -> ""
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)
591
592 and string_of_class_type cl_type =
593   string_of_kind (Lazy.force cl_type.kind)
594
595 and string_of_component_type cpnt_type =
596   string_of_class_specifier (Lazy.force cpnt_type.base_class)
597
598 and string_of_variability var = match var with
599   | Continuous -> "continuous"
600   | Discrete -> "discrete"
601   | Parameter -> "parameter"
602   | Constant -> "constant"
603
604 and string_of_causality c = match c with
605   | Acausal -> ""
606   | Input -> "input"
607   | Output -> "output"
608
609 and string_of_predefined_type predef_type =
610   string_of_base_type predef_type.base_type
611
612 and string_of_base_type base_type = match base_type with
613   | BooleanType -> "Boolean"
614   | IntegerType -> "Integer"
615   | RealType -> "Real"
616   | StringType -> "String"
617   | EnumerationType enum_elts -> string_of_enumeration_type enum_elts
618
619 and string_of_enumeration_type ss =
620   let rec string_of_enumeration_type' ss = match ss with
621     | [] -> ""
622     | [s] -> s
623     | s :: ss -> s ^ ", " ^ (string_of_enumeration_type' ss) in
624   "enumeration(" ^ (string_of_enumeration_type' ss) ^ ")"
625
626 and string_of_element_nature = function
627   | ComponentElement _ -> "_ComponentElement"
628   | ClassElement _ -> "_ClassElement"
629   | ComponentTypeElement _ -> "_ComponentTypeElement"
630   | PredefinedTypeElement _ -> "_PredefinedTypeElement"