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.
23 (** Resolution of types for Modelica elements from the abstract syntax tree.
24 The main functions are:
26 {- [ resolve_toplevel ]: Main function. Resolve a list of top level syntax element}
27 {- [ resolve_variable_definition ]: Resolution of a variable definition}
28 {- [ resolve_class_definition ]: Resolution of a class definition}
29 {- [ resolve_modification ]: Resolution of modifications}
30 {- [ resolve_expression ]: Resolution of syntax expressions
32 {- [ resolve_binary_operation ]: Resolve binary operation expression }
33 {- [ resolve_unuary_operation ]: Resolve unary operation }
34 {- [ resolve_identifier ]: scoping algorithm and resolution of identifiers}
35 {- [ apply_binary_coercions, apply_rhs_coercions ]: Adding of Real to Integer implicit coercions}
36 {- [ resolve_function_call ]: Resolution of a function call expression }
37 {- [ resolve_field_access ]: Resolve field access }
38 {- [ resolve_if ]: Resolve [ if ] expression }
39 {- [ resolve_indexed_access ]: Resolve indexed access }
40 {- [ resolve_vector ]: Resolve vector expression }
41 {- [ resolve_range ]: resolve range expression }
44 {- [ resolve_equation ]: Resolution of an equation
46 {- [ resolve_equal ]: Resolution of a simple equation of the form [ expr1 = expr2 ] }
47 {- [ resolve_conditional_equation_e ]: Resolution of conditional equations }
48 {- [ resolve_for_clause_e ]: Resolution of for equations }
49 {- [ resolve_connect_clause ]: resolution of connect equations }
50 {- [ resolve_when_clause_e ]: resolution of when equations}
51 {- [ equations ]: resolution of array, record and for equations
57 (* The type [ node ] is used to attach syntax information to resolved elements *)
64 (* Type of resolved elements *)
66 and element_description =
68 element_type: Types.element_type Lazy.t;
70 element_nature: element_nature;
71 element_location: Parser.location
75 | Component of component_description
76 | Class of class_definition
77 | ComponentType of component_type_description
78 | PredefinedType of Types.predefined_type
80 and component_description =
82 component_type: Types.component_type Lazy.t;
83 type_specifier: expression Lazy.t;
84 dimensions: dimension list Lazy.t;
85 modification: modification option Lazy.t;
91 | Expression of expression
93 and class_definition =
95 class_type: Types.class_specifier Lazy.t;
96 enclosing_class: class_definition option;
98 description: class_description Lazy.t;
101 and class_description =
102 | LongDescription of long_description
103 | ShortDescription of modified_class
105 and long_description =
107 class_annotations: (annotation list) Lazy.t;
108 imports: import_description list;
109 extensions: (visibility * modified_class) list;
110 named_elements: named_element list;
111 unnamed_elements: equation_or_algorithm_clause list Lazy.t;
112 external_call: external_call option Lazy.t
116 | InverseFunction of inverse_function Lazy.t
117 | UnknownAnnotation of (Parser.location Syntax.class_modification) Lazy.t
119 and inverse_function =
121 function_class: expression;
122 arguments: (string * string) list
125 and import_description = unit
127 and visibility = Public | Protected
129 and named_element = string * element_description
133 modified_class_type: Types.class_type Lazy.t;
134 base_class: expression Lazy.t;
135 class_modification: class_modification Lazy.t
138 and component_type_description =
140 described_type: Types.component_type Lazy.t;
141 base_type: expression Lazy.t;
142 type_dimensions: dimension list Lazy.t;
143 type_modification: class_modification Lazy.t
146 and external_call = (external_call_desc, Parser.location Syntax.externalll) node
148 and external_call_desc =
149 | PrimitiveCall of string
150 | ExternalProcedureCall of language *
151 expression option (* rhs *) * string * expression list
153 and language = C | FORTRAN
156 | Modification of class_modification * expression Lazy.t option
157 | Assignment of expression Lazy.t
158 | Equality of expression Lazy.t
160 and class_modification = modification_argument list
162 and modification_argument =
167 action: modification_action option
170 and modification_action =
171 | ElementModification of modification
172 | ElementRedeclaration of element_description
174 (* Type of equations and algorithms *)
176 and equation_or_algorithm_clause =
177 | EquationClause of validity * equation list
178 | AlgorithmClause of validity * algorithm list
180 and validity = Initial | Permanent
182 and equation = (equation_desc, Parser.location Syntax.equation option) node
185 | Equal of expression * expression
186 | ConditionalEquationE of (expression * equation list) list * equation list
187 | ForClauseE of expression list (* ranges *) * equation list
188 | ConnectFlows of sign * expression * sign * expression
189 | WhenClauseE of (expression * equation list) list
191 and sign = Positive | Negative
193 and algorithm = (algorithm_desc, Parser.location Syntax.algorithm option) node
196 | Assign of expression * expression
197 | FunctionCallA of expression * expression list
198 | MultipleAssign of expression list * expression * expression list
201 | ConditionalEquationA of (expression * algorithm list) list *
203 | ForClauseA of expression list (* ranges *) * algorithm list
204 | WhileClause of expression * algorithm list
205 | WhenClauseA of (expression * algorithm list) list
207 (* Type of expressions *)
209 and expression = (expression_desc, expression_information) node
211 (* Type of a resolved expression:
212 - [ syntax ]: expression syntax (this information is optional, some expressions
213 are dynamicaly created during typing analysis)
214 - [ type_description ]: expression type *)
215 and expression_information =
217 syntax: Parser.location Syntax.expression option;
218 type_description: Types.element_nature
221 and expression_desc =
222 | BinaryOperation of binary_operator_kind * expression * expression
223 | DynamicIdentifier of int (** number of nested classes to skip *) *
224 string (** name to be searched for at instanciation time *)
226 | FieldAccess of expression * string
227 | FunctionArgument of int (** the position of the argument in the call *)
228 | FunctionCall of expression (** function *) *
229 expression list (** arguments *) *
230 expression (** the expression involving the function call *)
231 (** creation of a dynamic function context *)
232 | FunctionInvocation of expression list
233 (** invocation of the current function in context *)
234 | If of (expression (** condition *) * expression) list *
235 expression (** default *)
236 | IndexedAccess of expression * expression list (* subscripts *)
238 | LocalIdentifier of int (** number of nested classes to skip *) *
239 string (** key in the dictionary of the defining class *)
240 | LoopVariable of int (** number of nested for loops to skip *)
241 | NoEvent of expression
242 | PredefinedIdentifier of string (** predefined identifier *)
243 | Range of expression * expression * expression
246 | ToplevelIdentifier of string (** key in the toplevel dictionary *)
248 | Tuple of expression list
249 | UnaryOperation of unary_operator_kind * expression
250 | Vector of expression list
251 | VectorReduction of expression list (** nested ranges *) * expression
252 | Coercion of coercion_kind * expression
255 | RealOfInteger (** Implicit conversion of Integer to Real *)
257 and unary_operator_kind =
262 and binary_operator_kind =
277 (* Context types. Contexts are used to resolve identifiers in expressions *)
281 toplevel: (string * element_description) list Lazy.t;
282 context_nature: context_nature;
283 location: Parser.location
288 | ClassContext of class_definition
289 | SubscriptContext of
290 context * expression (* evaluating to an array *) *
291 int32 (* dimension index *) * Types.dimension
292 | ForContext of context * string * Types.element_nature
294 (* Type Errors detected during compilation *)
296 type error_description =
298 err_msg: string list;
299 err_info: (string * string) list;
303 exception CompilError of error_description
307 let evaluate x = Lazy.force x
309 let resolve_elements add_element elts other_elts =
310 let resolve_other_elements other_elt acc = match other_elt.Syntax.nature with
311 | Syntax.Public elts -> List.fold_right (add_element Public) elts acc
312 | Syntax.Protected elts -> List.fold_right (add_element Protected) elts acc
313 | Syntax.EquationClause _ | Syntax.AlgorithmClause _ -> acc in
317 (List.fold_right resolve_other_elements other_elts [])
319 let resolved_expression syntax nat elt_nat =
322 info = { syntax = syntax; type_description = elt_nat }
327 and elt_nat = Types.integer_type Types.Constant in
328 resolved_expression None nat elt_nat
331 (* Name resolution functions *)
333 let rec resolve_toplevel dic nodes =
334 let add_element ctx acc (id, elt_desc) =
335 match List.mem_assoc id acc with
337 let ctx = { ctx with location = elt_desc.element_location } in
339 {err_msg = ["_DuplicateDeclarationOfElement"; id];
341 err_ctx = ctx}) (*error*)
342 | false -> acc @ [ (id, elt_desc) ] in
346 lazy (List.fold_left (add_element ctx) dic (evaluate elt_descs));
347 context_nature = ToplevelContext;
352 Parser.filename = Parser.CommandLine
355 and elt_descs = lazy (resolve_toplevel_nodes ctx nodes) in
356 evaluate ctx.toplevel
358 and resolve_toplevel_nodes ctx nodes =
359 let rec resolve_toplevel_nodes' nodes' =
363 (resolve_toplevel_statements ctx node) @
364 (resolve_toplevel_nodes' nodes') in
365 let collect_toplevel_defs (cl_defs, nodes) node =
366 match node.Syntax.nature with
367 | Syntax.ClassDefinitions cl_defs' -> cl_defs' @ cl_defs, nodes
368 | _ -> cl_defs, [node] @ nodes in
369 let cl_defs, nodes = List.fold_left collect_toplevel_defs ([], []) nodes in
370 let node = {Syntax.nature = Syntax.ClassDefinitions cl_defs;
371 Syntax.info = ctx.location} in
372 (resolve_toplevel_statements ctx node) @
373 resolve_toplevel_nodes' nodes
375 and resolve_toplevel_statements ctx node = match node.Syntax.nature with
376 | Syntax.ClassDefinitions cl_defs -> resolve_class_definitions ctx cl_defs
377 | Syntax.Expression expr -> raise (CompilError
378 {err_msg = ["_NotYetImplemented"; "_TopLevelExpr"];
380 err_ctx = {ctx with location = expr.Syntax.info}})
381 | Syntax.VariablesDefinitions (expr, subs, cpnt_decls) ->
382 resole_variables_definitions ctx expr subs cpnt_decls
383 | Syntax.Command algo -> raise (CompilError
384 {err_msg = ["_NotYetImplemented"; "_TopLevelAlgorithm"];
386 err_ctx = {ctx with location = algo.Syntax.info}})
387 | Syntax.Within path -> raise (CompilError
388 {err_msg = ["_NotYetImplemented"; "_WithinClause"];
389 err_info = [("_Expr", Syntax.string_of_toplevel_element node)];
390 err_ctx = {ctx with location = node.Syntax.info}})
391 | Syntax.Import imprt -> raise (CompilError
392 {err_msg = ["_NotYetImplemented"; "_ImportClause"];
393 err_info = [("_Expr", Syntax.string_of_toplevel_element node)];
394 err_ctx = {ctx with location = imprt.Syntax.info}})
396 and resole_variables_definitions ctx expr subs cpnt_decls =
397 let type_spec = lazy (resolve_expression ctx expr)
398 and dims = lazy (resolve_dimensions ctx subs) in
399 List.map (resolve_variable_definition ctx type_spec dims expr) cpnt_decls
401 and resolve_variable_definition ctx type_spec dims expr cpnt_decl =
402 let type_pref = false, None, Types.Acausal in
403 let id, elt_nat, elt_loc =
404 resolve_component_declaration ctx type_pref type_spec dims expr cpnt_decl in
408 lazy (element_type ctx false None None None elt_desc);
410 element_nature = elt_nat;
411 element_location = elt_loc
415 and resolve_class_definitions ctx cl_defs =
416 List.map (resolve_class_definition ctx) cl_defs
418 and resolve_class_definition ctx cl_def = match cl_def.Syntax.nature with
419 | Syntax.ClassDefinition (final, def) ->
420 let loc = (match def.Syntax.nature with
421 | Syntax.Definition (_, _, _, cl_spec) -> cl_spec.Syntax.info) in
424 element_type = lazy (element_type ctx false final None None elt_desc);
426 element_nature = resolve_definition ctx def;
427 element_location = loc
429 let s = class_definition_name def in
432 and class_definition_name def = match def.Syntax.nature with
433 | Syntax.Definition (_, _, _, cl_spec) -> class_specifier_name cl_spec
435 and class_specifier_name cl_spec = match cl_spec.Syntax.nature with
436 | Syntax.LongSpecifier (id, _, _) |
437 Syntax.ShortSpecifier (id, _, _, _, _, _) |
438 Syntax.EnumerationSpecifier (id, _, _) |
439 Syntax.ExtensionSpecifier (id, _, _, _) -> id
441 and resolve_definition ctx def =
442 let ctx = {ctx with location = def.Syntax.info} in
443 match def.Syntax.nature with
444 | Syntax.Definition (encap, part, kind, cl_spec) ->
445 resolve_specification ctx encap part kind cl_spec
447 and resolve_specification ctx encap part kind cl_spec =
448 let encap' = bool_of_encapsulated encap in
451 resolve_class_specification ctx encap' part Types.Class cl_spec
453 resolve_class_specification ctx encap' part Types.Model cl_spec
455 resolve_class_specification ctx encap' part Types.Block cl_spec
457 resolve_class_specification ctx encap' part Types.Record cl_spec
458 | Syntax.ExpandableConnector ->
459 resolve_class_specification
463 Types.ExpandableConnector
465 | Syntax.Connector ->
466 resolve_class_specification ctx encap' part Types.Connector cl_spec
467 | Syntax.Type when encap' ->
469 {err_msg = ["_EncapsulatedCannotBeAppliedTo"; "_TypeDef"];
471 err_ctx = ctx}) (*error*)
472 | Syntax.Type -> resolve_type_specification ctx cl_spec
474 resolve_class_specification ctx encap' part Types.Package cl_spec
476 resolve_class_specification ctx encap' part Types.Function cl_spec
478 and resolve_type_specification ctx cl_spec =
479 let ctx = {ctx with location = cl_spec.Syntax.info} in
480 match cl_spec.Syntax.nature with
481 | Syntax.LongSpecifier _ ->
483 {err_msg = ["_InvalidTypeDef"];
485 err_ctx = ctx}) (*error*)
486 | Syntax.ExtensionSpecifier _ ->
488 {err_msg = ["_InvalidTypeDef"];
490 err_ctx = ctx}) (*error*)
491 | Syntax.ShortSpecifier (_, base_pref, cl_spec, subs, cl_modif, _) ->
493 resolve_type_composition ctx base_pref cl_spec subs cl_modif in
494 ComponentType cpnt_type
495 | Syntax.EnumerationSpecifier (idt, enum_comp, _) ->
496 let enum_type = resolve_enumeration_composition ctx enum_comp in
497 PredefinedType enum_type
499 and resolve_type_composition ctx base_pref cl_spec subs cl_modif =
500 let base_pref' = type_prefix base_pref
501 and base_type = lazy (resolve_expression ctx cl_spec)
502 and dims = lazy (resolve_dimensions ctx subs) in
503 let cpnt_type = lazy (component_type ctx base_pref' base_type dims) in
504 let cl_modif' = lazy (resolve_type_modification ctx cpnt_type cl_modif) in
506 described_type = lazy (modified_described_type ctx cpnt_type cl_modif');
507 base_type = base_type;
508 type_dimensions = dims;
509 type_modification = cl_modif'
512 and resolve_enumeration_composition ctx enum_comp =
513 let resolve_enumeration_literal enum_lit ids =
514 match enum_lit.Syntax.nature with
515 | Syntax.EnumerationLiteral (id, _) when List.mem id ids ->
517 {err_msg = ["_EnumTypeDefWithDuplicLit"; id];
519 err_ctx = {ctx with location = enum_lit.Syntax.info}}) (*error*)
520 | Syntax.EnumerationLiteral (id, _) -> id :: ids in
521 match enum_comp.Syntax.nature with
522 | Syntax.EnumList (Some enum_lits) ->
523 let elts = List.fold_right resolve_enumeration_literal enum_lits [] in
525 Types.base_type = Types.EnumerationType elts;
526 attributes = ["start", false]
528 | Syntax.EnumList None ->
530 {err_msg = ["_UnspecifiedEnumLits"];
532 err_ctx = {ctx with location = enum_comp.Syntax.info}}) (*error*)
533 | Syntax.EnumColon ->
535 {err_msg = ["_UnspecifiedEnumLits"];
537 err_ctx = {ctx with location = enum_comp.Syntax.info}}) (*error*)
539 and resolve_class_specification ctx encap part kind cl_spec =
540 let ctx = {ctx with location = cl_spec.Syntax.info} in
541 let resolve_specifier encap' cl_def =
542 let ctx' = {ctx with context_nature = ClassContext cl_def} in
543 resolve_class_specifier ctx ctx' encap cl_spec in
546 class_type = lazy (class_specifier_type ctx part kind cl_def cl_spec);
547 enclosing_class = enclosing_class ctx;
548 encapsulated = encap;
549 description = lazy (resolve_specifier encap cl_def)
553 and enclosing_class ctx = match ctx.context_nature with
554 | ToplevelContext -> None
555 | ClassContext cl_def -> Some cl_def
556 | SubscriptContext (ctx, _, _, _) |
557 ForContext (ctx, _, _) -> enclosing_class ctx
559 and bool_of_encapsulated = function
561 | Some Syntax.Encapsulated -> true
563 and resolve_class_specifier ctx ctx' encap cl_spec =
564 let ctx = {ctx with location = cl_spec.Syntax.info}
565 and ctx' = {ctx' with location = cl_spec.Syntax.info} in
566 match cl_spec.Syntax.nature with
567 | Syntax.LongSpecifier (_, _, comp) ->
568 LongDescription (resolve_composition ctx ctx' comp)
569 | Syntax.ShortSpecifier _ when encap ->
571 {err_msg = ["_EncapsulatedCannotBeAppliedTo"; "_ShortClassDef"];
573 err_ctx = ctx}) (*error*)
574 | Syntax.ShortSpecifier (_, base_pref, cl_spec, subs, cl_modif, _) ->
576 resolve_short_specifier ctx base_pref cl_spec subs cl_modif in
577 ShortDescription short_desc
578 | Syntax.ExtensionSpecifier _ when encap ->
580 {err_msg = ["_EncapsulatedCannotBeAppliedTo"; "_ClassDefByExtension"];
582 err_ctx = ctx}) (*error*)
583 | Syntax.ExtensionSpecifier (id , cl_modif, _, comp) ->
585 resolve_extension_composition ctx ctx' id cl_modif comp in
586 LongDescription long_desc
587 | Syntax.EnumerationSpecifier _ ->
589 {err_msg = ["_InvalidUseOfEnumKeyword"];
591 err_ctx = ctx}) (*error*)
593 and resolve_short_specifier ctx base_pref cl_spec subs cl_modif =
594 let ctx = {ctx with location = cl_spec.Syntax.info} in
595 match base_pref.Syntax.nature, subs with
596 | Syntax.TypePrefix (None, None, None), None ->
597 resolve_modified_class ctx ctx cl_spec cl_modif
598 | (Syntax.TypePrefix (Some _, _, _) | Syntax.TypePrefix (_, Some _, _) |
599 Syntax.TypePrefix (_, _, Some _)), _ ->
601 {err_msg = ["_UseOfTypePrefixInShortClassDef"];
603 [("_TypePrefix", Syntax.string_of_base_prefix base_pref)];
604 err_ctx = {ctx with location = base_pref.Syntax.info}}) (*error*)
605 | Syntax.TypePrefix (None, None, None), Some subs ->
607 {err_msg = ["_UseOfSubsInShortClassDef"];
609 err_ctx = {ctx with location = subs.Syntax.info}}) (*error*)
611 and resolve_extension_composition ctx ctx' id cl_modif comp =
613 {err_msg = ["_NotYetImplemented"; "_ClassExtendsDef"];
617 and resolve_composition ctx ctx' comp = match comp.Syntax.nature with
618 | Syntax.Composition (elts, other_elts, extern) ->
620 class_annotations = lazy (resolve_class_annotations ctx' elts other_elts);
621 imports = resolve_imports ctx' elts other_elts;
622 extensions = resolve_extensions ctx ctx' elts other_elts;
623 named_elements = resolve_named_elements ctx' elts other_elts;
624 unnamed_elements = lazy (resolve_unnamed_elements ctx' other_elts);
625 external_call = lazy (resolve_external_call ctx' extern)
628 and resolve_external_call ctx extern =
629 let resolve_external_call' extern' = match extern'.Syntax.nature with
630 | Syntax.External (Some id, None, _, _) ->
631 { nature = PrimitiveCall id; info = extern' }
632 | Syntax.External (Some lang, Some extern_call, _, _) ->
634 {err_msg = ["_NotYetImplemented"; "_ExternalProcedureCall"];
637 {ctx with location = extern'.Syntax.info}}) (*error*)
638 | Syntax.External (None, _, _, _) ->
639 { nature = PrimitiveCall "C"; info = extern' } in
641 {err_msg = ["_UnspecifiedExtCallLang"];
644 {ctx with location = extern'.Syntax.info}}) (*error*) in*)
647 | Some extern' -> Some (resolve_external_call' extern')
649 and resolve_class_annotations ctx elts other_elts =
650 let add_class_annotation vis elt anns = match vis, elt.Syntax.nature with
651 | _, Syntax.ClassAnnotation ann ->
652 begin match resolve_class_annotation ctx ann with
654 | anns' -> anns' @ anns
656 | _, (Syntax.ImportClause _ | Syntax.ExtendsClause _ |
657 Syntax.ElementDefinition _) -> anns in
658 resolve_elements add_class_annotation elts other_elts
660 and resolve_imports ctx elts other_elts =
661 let add_import vis elt imps = match vis, elt.Syntax.nature with
662 | _, Syntax.ImportClause (imp_clause, _) ->
663 resolve_import_clause ctx imp_clause :: imps
664 | _, (Syntax.ClassAnnotation _ | Syntax.ExtendsClause _ |
665 Syntax.ElementDefinition _) -> imps in
666 resolve_elements add_import elts other_elts
668 and resolve_extensions ctx ctx' elts other_elts =
669 let add_extension vis elt exts = match vis, elt.Syntax.nature with
670 | Public, Syntax.ExtendsClause (ext_clause, _) ->
671 (Public, resolve_extends_clause ctx ctx' ext_clause) :: exts
672 | Protected, Syntax.ExtendsClause (ext_clause, _) ->
673 (Protected, resolve_extends_clause ctx ctx' ext_clause) :: exts
674 | _, (Syntax.ClassAnnotation _ | Syntax.ImportClause _ |
675 Syntax.ElementDefinition _) -> exts in
676 resolve_elements add_extension elts other_elts
678 and resolve_named_elements ctx elts other_elts =
679 let add_named_element (id, elt_desc) elts =
680 match List.mem_assoc id elts with
683 {err_msg = ["_DuplicateDeclarationOfElement"; id];
685 err_ctx = ctx}) (*error*)
686 | false -> (id, elt_desc) :: elts in
687 let add_named_elements vis elt elts = match vis, elt.Syntax.nature with
689 Syntax.ElementDefinition (redecl, final, dyn_scope, elt_def, _) ->
691 resolve_element_definition ctx false redecl final dyn_scope elt_def in
692 List.fold_right add_named_element elts' elts
694 Syntax.ElementDefinition (redecl, final, dyn_scope, elt_def, _) ->
696 resolve_element_definition ctx true redecl final dyn_scope elt_def in
697 List.fold_right add_named_element elts' elts
698 | _, (Syntax.ClassAnnotation _ | Syntax.ImportClause _ |
699 Syntax.ExtendsClause _) -> elts in
700 resolve_elements add_named_elements elts other_elts
702 and resolve_class_annotation ctx ann =
703 let rec resolve_class_annotation' cl_modif =
704 let add_annotation_information arg acc = match arg.Syntax.nature with
705 | Syntax.ElementModification (
708 { Syntax.nature = Syntax.Identifier "Imagine" },
712 Syntax.Modification (
715 Syntax.ClassModification
719 Syntax.ElementModification (
723 Syntax.nature = Syntax.Identifier "AMESim"
728 Syntax.Modification (cl_modif, None)
736 []) -> add_amesim_annotations ctx cl_modif acc
737 | Syntax.ElementModification _ | Syntax.ElementRedeclaration _ ->
738 (UnknownAnnotation (lazy cl_modif)) :: acc in
739 match cl_modif.Syntax.nature with
740 | Syntax.ClassModification args ->
741 List.fold_right add_annotation_information args [] in
742 match ann.Syntax.nature with
743 | Syntax.Annotation cl_modif -> resolve_class_annotation' cl_modif
745 and add_amesim_annotations ctx cl_modif acc =
746 let add_inverse_declarations cl_modif =
747 let add_inverse_declaration arg acc =
748 let add_inverse_declaration' expr modif =
749 match expr.Syntax.nature, modif.Syntax.nature with
750 | Syntax.IndexedAccess (
751 { Syntax.nature = Syntax.Identifier "inverse" }, _),
755 Syntax.FunctionCall (expr, Some fun_args)
756 } -> (resolve_inverse_declaration ctx expr fun_args) :: acc
759 {err_msg = ["_InvalidAnnOfInvFunc"; "_InvalidModifExpr"];
762 {ctx with location = expr.Syntax.info}}) (*error*) in
763 match arg.Syntax.nature with
764 | Syntax.ElementModification (Some _, _, _, _, _) ->
766 {err_msg = ["_InvalidAnnOfInvFunc"; "_UseOfEachKeywordNotAllowed"];
768 err_ctx = {ctx with location = arg.Syntax.info}}) (*error*)
769 | Syntax.ElementModification (None, Some _, _, _, _) ->
771 {err_msg = ["_InvalidAnnOfInvFunc"; "_UseOfFinalKeywordNotAllowed"];
773 err_ctx = {ctx with location = arg.Syntax.info}}) (*error*)
774 | Syntax.ElementModification (None, None, _, None, _) ->
776 {err_msg = ["_InvalidAnnOfInvFunc"; "_UnspecifiedModification"];
778 err_ctx = {ctx with location = arg.Syntax.info}}) (*error*)
779 | Syntax.ElementModification (None, None, expr, Some modif, _) ->
780 add_inverse_declaration' expr modif
781 | Syntax.ElementRedeclaration _ ->
783 {err_msg = ["_InvalidAnnOfInvFunc"; "_RedeclarationNotAllowed"];
785 err_ctx = {ctx with location = arg.Syntax.info}}) (*error*) in
786 match cl_modif.Syntax.nature with
787 | Syntax.ClassModification args ->
788 List.fold_right add_inverse_declaration args acc in
789 match cl_modif.Syntax.nature with
790 | Syntax.ClassModification
794 Syntax.ElementModification (
798 Syntax.nature = Syntax.Identifier "InverseFunctions"
803 Syntax.Modification (cl_modif, None)
807 ] -> add_inverse_declarations cl_modif
808 | Syntax.ClassModification _ -> acc
810 and resolve_inverse_declaration ctx expr fun_args =
811 let inverse_function_arguments expr' fun_args =
812 let map_function_arguments named_args =
813 let map_function_argument arg =
814 match arg.Syntax.nature with
815 | Syntax.NamedArgument (id, expr)
816 when List.mem_assoc id named_args ->
817 let expr' = resolve_expression ctx expr in
818 begin match expr'.nature with
819 | LocalIdentifier (0, id') -> id, id'
822 {err_msg = ["_InvalidAnnOfInvFunc";
823 "_InvalidFuncArgModif"];
827 location = expr.Syntax.info}}) (*error*)
829 | Syntax.NamedArgument (id, expr) ->
831 {err_msg = ["_InvalidAnnOfInvFunc";
832 "_UnknownArgName"; id];
835 {ctx with location = arg.Syntax.info}}) (*error*)
836 | Syntax.Argument _ ->
838 {err_msg = ["_InvalidAnnOfInvFunc";
839 "_CannotUseUnnamedFuncArg"];
842 {ctx with location = arg.Syntax.info}}) (*error*) in
843 match fun_args.Syntax.nature with
844 | Syntax.ArgumentList args -> List.map map_function_argument args
845 | Syntax.Reduction _ ->
847 {err_msg = ["_InvalidAnnOfInvFunc";
848 "_FuncArgReductionNotAllowed"];
851 {ctx with location = fun_args.Syntax.info}}) (*error*) in
852 let inverse_function_arguments' cl_type =
853 match cl_type.Types.partial, evaluate cl_type.Types.kind with
856 {err_msg = ["_InvalidAnnOfInvFunc";
857 "_UseOfPartialClassElement"];
858 err_info = [("_ElementFound",
859 Syntax.string_of_expression expr)];
861 {ctx with location = expr.Syntax.info}}) (*error*)
862 | false, Types.Function ->
863 map_function_arguments cl_type.Types.named_elements
866 {err_msg = ["_InvalidAnnOfInvFunc";
867 "_InvalidTypeOfFuncCallExpr"];
868 err_info = [("_ExpectedType", "_Function");
869 ("_TypeFound", Types.string_of_kind kind)];
871 {ctx with location = expr.Syntax.info}}) (*error*) in
872 let elt_nat = expr'.info.type_description in
874 | Types.ClassElement cl_spec ->
875 let cl_spec = evaluate cl_spec in
876 begin match cl_spec with
877 | Types.ClassType cl_type ->
878 inverse_function_arguments' cl_type
881 {err_msg = ["_InvalidAnnOfInvFunc";
882 "_InvalidTypeOfFuncCallExpr"];
884 [("_ExpectedType", "_ClassType");
886 Types.string_of_class_specifier cl_spec)];
888 {ctx with location = expr.Syntax.info}}) (*error*)
890 | Types.ComponentTypeElement _ ->
892 {err_msg = ["_InvalidAnnOfInvFunc";
893 "_InvalidTypeOfFuncCallExpr"];
894 err_info = [("_ExpectedType", "_ClassElement");
895 ("_TypeFound", "_ComponentTypeElement")];
897 {ctx with location = expr.Syntax.info}}) (*error*)
898 | Types.PredefinedTypeElement _ ->
900 {err_msg = ["_InvalidAnnOfInvFunc";
901 "_InvalidTypeOfFuncCallExpr"];
902 err_info = [("_ExpectedType", "_ClassElement");
903 ("_TypeFound", "_PredefinedTypeElement")];
905 {ctx with location = expr.Syntax.info}}) (*error*)
906 | Types.ComponentElement _ ->
908 {err_msg = ["_InvalidAnnOfInvFunc";
909 "_InvalidTypeOfFuncCallExpr"];
910 err_info = [("_ExpectedType", "_ClassElement");
911 ("_TypeFound", "_ComponentElement")];
913 {ctx with location = expr.Syntax.info}}) (*error*) in
914 let expr' = resolve_expression ctx expr in
915 match expr'.nature with
916 | ToplevelIdentifier _ | LocalIdentifier _ ->
920 function_class = expr';
921 arguments = inverse_function_arguments expr' fun_args
925 {err_msg = ["_InvalidAnnOfInvFunc"; "_InvalidFuncCallExpr"];
928 {ctx with location = expr.Syntax.info}}) (*error*)
930 (*and resolve_inverse_function_annotation ctx ann =
931 let rec resolve_class_annotation' cl_modif =
932 let resolve_inverse_declaration expr fun_args =
933 let inverse_function_arguments expr' fun_args =
934 let map_function_arguments named_args =
935 let map_function_argument arg =
936 match arg.Syntax.nature with
937 | Syntax.NamedArgument (id, expr)
938 when List.mem_assoc id named_args ->
939 let expr' = resolve_expression ctx expr in
940 begin match expr'.nature with
941 | LocalIdentifier (0, id') -> id, id'
944 {err_msg = ["_InvalidAnnOfInvFunc";
945 "_InvalidFuncArgModif"];
949 location = expr.Syntax.info}}) (*error*)
951 | Syntax.NamedArgument (id, expr) ->
953 {err_msg = ["_InvalidAnnOfInvFunc";
954 "_UnknownArgName"; id];
957 {ctx with location = arg.Syntax.info}}) (*error*)
958 | Syntax.Argument _ ->
960 {err_msg = ["_InvalidAnnOfInvFunc";
961 "_CannotUseUnnamedFuncArg"];
964 {ctx with location = arg.Syntax.info}}) (*error*) in
965 match fun_args.Syntax.nature with
966 | Syntax.ArgumentList args -> List.map map_function_argument args
967 | Syntax.Reduction _ ->
969 {err_msg = ["_InvalidAnnOfInvFunc";
970 "_FuncArgReductionNotAllowed"];
973 {ctx with location = fun_args.Syntax.info}}) (*error*) in
974 let inverse_function_arguments' cl_type =
975 match cl_type.Types.partial, evaluate cl_type.Types.kind with
978 {err_msg = ["_InvalidAnnOfInvFunc";
979 "_UseOfPartialClassElement"];
980 err_info = [("_ElementFound",
981 Syntax.string_of_expression expr)];
983 {ctx with location = expr.Syntax.info}}) (*error*)
984 | false, Types.Function ->
985 map_function_arguments cl_type.Types.named_elements
988 {err_msg = ["_InvalidAnnOfInvFunc";
989 "_InvalidTypeOfFuncCallExpr"];
990 err_info = [("_ExpectedType", "_Function");
991 ("_TypeFound", Types.string_of_kind kind)];
993 {ctx with location = expr.Syntax.info}}) (*error*) in
994 let elt_nat = expr'.info.type_description in
996 | Types.ClassElement cl_spec ->
997 let cl_spec = evaluate cl_spec in
998 begin match cl_spec with
999 | Types.ClassType cl_type ->
1000 inverse_function_arguments' cl_type
1003 {err_msg = ["_InvalidAnnOfInvFunc";
1004 "_InvalidTypeOfFuncCallExpr"];
1006 [("_ExpectedType", "_ClassType");
1008 Types.string_of_class_specifier cl_spec)];
1010 {ctx with location = expr.Syntax.info}}) (*error*)
1012 | Types.ComponentTypeElement _ ->
1014 {err_msg = ["_InvalidAnnOfInvFunc";
1015 "_InvalidTypeOfFuncCallExpr"];
1016 err_info = [("_ExpectedType", "_ClassElement");
1017 ("_TypeFound", "_ComponentTypeElement")];
1019 {ctx with location = expr.Syntax.info}}) (*error*)
1020 | Types.PredefinedTypeElement _ ->
1022 {err_msg = ["_InvalidAnnOfInvFunc";
1023 "_InvalidTypeOfFuncCallExpr"];
1024 err_info = [("_ExpectedType", "_ClassElement");
1025 ("_TypeFound", "_PredefinedTypeElement")];
1027 {ctx with location = expr.Syntax.info}}) (*error*)
1028 | Types.ComponentElement _ ->
1030 {err_msg = ["_InvalidAnnOfInvFunc";
1031 "_InvalidTypeOfFuncCallExpr"];
1032 err_info = [("_ExpectedType", "_ClassElement");
1033 ("_TypeFound", "_ComponentElement")];
1035 {ctx with location = expr.Syntax.info}}) (*error*) in
1036 let expr' = resolve_expression ctx expr in
1037 match expr'.nature with
1038 | ToplevelIdentifier _ | LocalIdentifier _ ->
1040 function_class = expr';
1042 inverse_function_arguments expr' fun_args
1046 {err_msg = ["_InvalidAnnOfInvFunc"; "_InvalidFuncCallExpr"];
1049 {ctx with location = expr.Syntax.info}}) (*error*) in
1050 let add_inverse_declaration arg acc =
1051 let add_inverse_declaration' expr modif =
1052 match expr.Syntax.nature, modif.Syntax.nature with
1053 | Syntax.IndexedAccess (
1054 { Syntax.nature = Syntax.Identifier "inverse" }, _),
1058 Syntax.FunctionCall (expr, Some fun_args)
1059 } -> lazy (resolve_inverse_declaration expr fun_args) :: acc
1062 {err_msg = ["_InvalidAnnOfInvFunc"; "_InvalidModifExpr"];
1065 {ctx with location = expr.Syntax.info}}) (*error*) in
1066 match arg.Syntax.nature with
1067 | Syntax.ElementModification (Some _, _, _, _, _) ->
1069 {err_msg = ["_InvalidAnnOfInvFunc"; "_UseOfEachKeywordNotAllowed"];
1071 err_ctx = {ctx with location = arg.Syntax.info}}) (*error*)
1072 | Syntax.ElementModification (None, Some _, _, _, _) ->
1074 {err_msg = ["_InvalidAnnOfInvFunc"; "_UseOfFinalKeywordNotAllowed"];
1076 err_ctx = {ctx with location = arg.Syntax.info}}) (*error*)
1077 | Syntax.ElementModification (None, None, _, None, _) ->
1079 {err_msg = ["_InvalidAnnOfInvFunc"; "_UnspecifiedModification"];
1081 err_ctx = {ctx with location = arg.Syntax.info}}) (*error*)
1082 | Syntax.ElementModification (None, None, expr, Some modif, _) ->
1083 add_inverse_declaration' expr modif
1084 | Syntax.ElementRedeclaration _ ->
1086 {err_msg = ["_InvalidAnnOfInvFunc"; "_RedeclarationNotAllowed"];
1088 err_ctx = {ctx with location = arg.Syntax.info}}) (*error*) in
1089 let add_inverse_declarations cl_modif acc =
1090 let add_inverse_declarations' cl_modif =
1091 match cl_modif.Syntax.nature with
1092 | Syntax.ClassModification args ->
1093 List.fold_right add_inverse_declaration args acc in
1094 match cl_modif.Syntax.nature with
1095 | Syntax.ClassModification
1099 Syntax.ElementModification (
1103 Syntax.nature = Syntax.Identifier "InverseFunctions"
1108 Syntax.Modification (cl_modif, None)
1112 ] -> add_inverse_declarations' cl_modif
1113 | Syntax.ClassModification _ -> acc in
1114 let add_annotation_information arg acc = match arg.Syntax.nature with
1115 | Syntax.ElementModification (
1118 { Syntax.nature = Syntax.Identifier "Imagine" },
1122 Syntax.Modification (
1125 Syntax.ClassModification
1129 Syntax.ElementModification (
1133 Syntax.nature = Syntax.Identifier "AMESim"
1138 Syntax.Modification (cl_modif, None)
1146 []) -> add_inverse_declarations cl_modif acc
1147 | Syntax.ElementModification _ | Syntax.ElementRedeclaration _ -> acc in
1148 match cl_modif.Syntax.nature with
1149 | Syntax.ClassModification args ->
1150 List.fold_right add_annotation_information args [] in
1151 match ann.Syntax.nature with
1152 | Syntax.Annotation cl_modif -> resolve_class_annotation' cl_modif*)
1154 and resolve_import_clause ctx imp_clause =
1155 let ctx = {ctx with location = imp_clause.Syntax.info} in
1157 {err_msg = ["_NotYetImplemented"; "_ImportClause"];
1158 err_info = [("_Expr", Syntax.string_of_import imp_clause)];
1161 and resolve_extends_clause ctx ctx' ext_clause =
1162 match ext_clause.Syntax.nature with
1163 | Syntax.Extends (cl_spec, cl_modif, _) ->
1164 resolve_extension ctx ctx' cl_spec cl_modif
1166 and resolve_extension ctx ctx' cl_spec cl_modif =
1167 let ctx' = {ctx' with location = cl_spec.Syntax.info} in
1168 let base_class = lazy (resolve_extension_expression ctx cl_spec) in
1169 let cl_spec' = lazy (base_class_type ctx' cl_spec base_class) in
1171 lazy (resolve_class_modification_option ctx' cl_spec' cl_modif) in
1173 modified_class_type = lazy (modified_class_type ctx' cl_spec' cl_modif');
1174 base_class = base_class;
1175 class_modification = cl_modif'
1178 and resolve_extension_expression ctx cl_spec =
1179 let rec modify_resolved_expression expr = match expr.nature with
1180 | LocalIdentifier (level, id) ->
1181 { expr with nature = LocalIdentifier (level + 1, id) }
1182 | FieldAccess (expr', id) ->
1184 nature = FieldAccess (modify_resolved_expression expr', id)
1186 | IndexedAccess (expr', exprs') ->
1187 let exprs' = List.map modify_resolved_expression exprs' in
1189 nature = IndexedAccess (modify_resolved_expression expr', exprs')
1191 | ToplevelIdentifier _ -> expr
1194 {err_msg = ["_InvalidExtensionDef"];
1196 err_ctx = ctx}) (*error*) in
1197 match ctx.context_nature with
1198 | ToplevelContext | ClassContext _ ->
1199 let base_class = resolve_expression ctx cl_spec in
1200 modify_resolved_expression base_class
1201 | SubscriptContext _ | ForContext _ ->
1203 {err_msg = ["_InvalidExtensionDef"];
1205 err_ctx = ctx}) (*error*)
1207 and resolve_modified_class ctx ctx' cl_spec cl_modif =
1208 let ctx' = {ctx' with location = cl_spec.Syntax.info} in
1209 let base_class = lazy (resolve_expression ctx cl_spec) in
1210 let cl_spec' = lazy (base_class_type ctx' cl_spec base_class) in
1212 lazy (resolve_class_modification_option ctx' cl_spec' cl_modif) in
1214 modified_class_type = lazy (modified_class_type ctx' cl_spec' cl_modif');
1215 base_class = base_class;
1216 class_modification = cl_modif'
1219 and resolve_element_definition ctx protect redecl final dyn_scope elt_def =
1220 let repl = replaceable_attribute elt_def in
1221 let element_description (id, elt_nat, elt_loc) =
1225 lazy (element_type ctx protect final repl dyn_scope elt_desc);
1226 redeclare = bool_of_redeclare redecl;
1227 element_nature = elt_nat;
1228 element_location = elt_loc
1231 List.map element_description (declared_elements ctx elt_def)
1233 and replaceable_attribute elt_def = match elt_def.Syntax.nature with
1234 | Syntax.ClassDefinitionElement (repl, _, _) |
1235 Syntax.ComponentClauseElement (repl, _, _) -> repl
1237 and bool_of_redeclare = function
1239 | Some Syntax.Redeclare -> true
1241 and resolve_type_constraint ctx elt_def = match elt_def.Syntax.nature with
1242 | Syntax.ClassDefinitionElement (_, _, []) |
1243 Syntax.ComponentClauseElement (_, _, []) -> None
1244 | Syntax.ClassDefinitionElement (_, _, _ :: _) |
1245 Syntax.ComponentClauseElement (_, _, _ :: _) -> assert false
1247 and declared_elements ctx elt_def = match elt_def.Syntax.nature with
1248 | Syntax.ClassDefinitionElement (_, def, _) ->
1249 let s = class_definition_name def
1250 and elt_nat = resolve_definition ctx def
1251 and loc = match def.Syntax.nature with
1252 | Syntax.Definition (encap, part, kind, cl_spec) ->
1253 cl_spec.Syntax.info in
1255 | Syntax.ComponentClauseElement (_, cpnt_cl, _) ->
1256 resolve_component_clause ctx cpnt_cl
1258 and resolve_component_clause ctx cpnt_cl = match cpnt_cl.Syntax.nature with
1259 | Syntax.ComponentClause (type_pref, type_spec, subs, cpnt_decls) ->
1260 let type_pref' = type_prefix type_pref
1261 and type_spec' = lazy (resolve_expression ctx type_spec)
1262 and dims = lazy (resolve_dimensions ctx subs) in
1264 (resolve_component_declaration ctx type_pref' type_spec' dims type_spec)
1267 and type_prefix type_pref =
1268 let bool_of_flow = function
1270 | Some Syntax.Flow -> true
1271 and variability_of_variability = function
1273 | Some Syntax.Constant -> Some Types.Constant
1274 | Some Syntax.Parameter -> Some Types.Parameter
1275 | Some Syntax.Discrete -> Some Types.Discrete
1276 and causality_of_inout = function
1277 | None -> Types.Acausal
1278 | Some Syntax.Input -> Types.Input
1279 | Some Syntax.Output -> Types.Output in
1280 match type_pref.Syntax.nature with
1281 | Syntax.TypePrefix (flow, var, inout) ->
1283 variability_of_variability var,
1284 causality_of_inout inout
1286 and resolve_component_declaration
1287 ctx type_pref type_spec' dims type_spec cpnt_decl =
1288 let build_comment_string cmt = match cmt.Syntax.nature with
1289 | Syntax.Comment (ss, _) -> List.fold_right ( ^ ) ss "" in
1290 match cpnt_decl.Syntax.nature with
1291 | Syntax.ComponentDeclaration (decl, cmt) ->
1292 let cmt' = build_comment_string cmt in
1293 resolve_declaration ctx type_pref type_spec' dims decl cmt' type_spec
1295 and resolve_declaration ctx type_pref type_spec' dims decl cmt type_spec =
1296 let ctx = {ctx with location = decl.Syntax.info} in
1297 match decl.Syntax.nature with
1298 | Syntax.Declaration (id, subs, modif) ->
1299 let dims = lazy ((resolve_dimensions ctx subs) @ (evaluate dims)) in
1300 let cpnt_type = lazy (component_type ctx type_pref type_spec' dims) in
1302 lazy (resolve_component_modification ctx cpnt_type modif) in
1306 lazy (modified_component_type ctx (evaluate cpnt_type) modif');
1307 type_specifier = type_spec';
1309 modification = modif';
1312 (id, Component cpnt_desc, decl.Syntax.info)
1314 and resolve_dimensions ctx subs =
1315 let resolve_dimension sub = match sub.Syntax.nature with
1316 | Syntax.Colon -> Colon
1317 | Syntax.Subscript expr ->
1318 Expression (resolve_subscript_expression ctx expr) in
1319 let resolve_dimensions' = function
1321 | Some { Syntax.nature = Syntax.Subscripts subs_elts } ->
1322 List.map resolve_dimension subs_elts in
1323 resolve_dimensions' subs
1325 and base_class_type ctx cl_spec base_class =
1326 match (evaluate base_class).info.type_description with
1327 | Types.ClassElement cl_spec -> evaluate cl_spec
1328 | Types.ComponentTypeElement _ ->
1330 {err_msg = ["_CannotInheritFrom"; "_ComponentTypeElement"];
1332 [("_ElemFound", Syntax.string_of_expression cl_spec)];
1333 err_ctx = {ctx with location = cl_spec.Syntax.info}}) (*error*)
1334 | Types.PredefinedTypeElement _ ->
1336 {err_msg = ["_CannotInheritFrom"; "_PredefinedTypeElement"];
1338 [("_ElemFound", Syntax.string_of_expression cl_spec)];
1339 err_ctx = {ctx with location = cl_spec.Syntax.info}}) (*error*)
1340 | Types.ComponentElement _ ->
1342 {err_msg = ["_CannotInheritFrom"; "_ComponentElement"];
1344 err_ctx = {ctx with location = cl_spec.Syntax.info}}) (*error*)
1346 and component_type ctx (flow, var, inout) base_type dims =
1347 let base_type = evaluate base_type in
1348 let lower_variability var var' = match var, var' with
1349 | Some Types.Constant,
1350 (Types.Constant | Types.Parameter | Types.Discrete | Types.Continuous) ->
1352 | Some Types.Parameter,
1353 (Types.Parameter | Types.Discrete | Types.Continuous) -> Types.Parameter
1354 | Some Types.Discrete, (Types.Discrete | Types.Continuous) -> Types.Discrete
1355 | Some Types.Continuous, Types.Continuous -> Types.Continuous
1357 | Some var, (Types.Constant | Types.Parameter | Types.Discrete) ->
1359 {err_msg = ["_VariablityConflictsInCompDef"];
1361 [("_TypePrefix", Types.string_of_variability var);
1362 ("_TypeSpecifierVariability", Types.string_of_variability var')];
1363 err_ctx = ctx}) (*error*)
1364 and propagate_causality inout inout' = match inout, inout' with
1365 | Types.Acausal, (Types.Acausal | Types.Input | Types.Output) -> inout'
1366 | (Types.Input | Types.Output), Types.Acausal -> inout
1367 | Types.Input, Types.Input | Types.Output, Types.Output -> inout
1368 | Types.Input, Types.Output | Types.Output, Types.Input ->
1370 {err_msg = ["_CausalityConflictsInCompDef"];
1371 err_info = [("_TypePrefix", Types.string_of_causality inout);
1372 ("_TypeSpecifierCausality",
1373 Types.string_of_causality inout')];
1374 err_ctx = ctx}) (*error*) in
1375 let predefined_type_variability predef = match predef with
1376 | { Types.base_type = Types.RealType } -> Types.Continuous
1377 | _ -> Types.Discrete in
1378 let rec class_specifier_variability cl_spec = match cl_spec with
1379 | Types.PredefinedType predef -> predefined_type_variability predef
1380 | Types.ClassType cl_type -> Types.Continuous
1381 | Types.ComponentType cpnt_type -> evaluate cpnt_type.Types.variability
1382 | Types.ArrayType (dim, cl_spec) -> class_specifier_variability cl_spec
1383 | Types.TupleType cl_specs -> assert false in
1384 match base_type.info.type_description with
1385 | Types.ComponentElement _ ->
1387 {err_msg = ["class"; "_ElemExpected"];
1388 err_info = [("TypeFound", "_ComponentElement")];
1389 err_ctx = ctx}) (*error*)
1390 | Types.ClassElement cl_spec ->
1391 let cl_spec = evaluate cl_spec in
1392 let var' = class_specifier_variability cl_spec in
1393 let var' = lazy (lower_variability var var')
1394 and base_class = lazy (add_dimensions dims cl_spec) in
1395 component_element (lazy flow) var' (lazy inout) base_class
1396 | Types.ComponentTypeElement cpnt_type ->
1397 let flow' = lazy (flow || evaluate cpnt_type.Types.flow)
1399 lazy (lower_variability var (evaluate cpnt_type.Types.variability))
1401 lazy (propagate_causality inout (evaluate cpnt_type.Types.causality))
1403 lazy (add_dimensions dims (Types.ComponentType cpnt_type)) in
1404 component_element flow' var' inout' base_class
1405 | Types.PredefinedTypeElement predef ->
1406 let var' = predefined_type_variability predef in
1407 let var' = lazy (lower_variability var var')
1409 lazy (add_dimensions dims (Types.PredefinedType predef)) in
1410 component_element (lazy flow) var' (lazy inout) base_class
1412 and add_dimensions dims cl_spec =
1413 let add_dimension dim cl_spec = match dim with
1414 | Expression { nature = Integer i } ->
1415 Types.ArrayType (Types.ConstantDimension i, cl_spec)
1416 | Expression _ -> Types.ArrayType (Types.ParameterDimension, cl_spec)
1417 | Colon -> Types.ArrayType (Types.DiscreteDimension, cl_spec) in
1418 List.fold_right add_dimension (evaluate dims) cl_spec
1420 and modified_described_type ctx cpnt_type cl_modif =
1421 let cpnt_type' = evaluate cpnt_type in
1422 let cl_spec = cpnt_type'.Types.base_class in
1425 lazy (modify_class_specifier ctx (evaluate cl_modif) cl_spec)
1428 and modified_class_type ctx cl_spec cl_modif =
1429 let cl_spec' = modify_class_specifier ctx (evaluate cl_modif) cl_spec in
1431 | Types.ClassType cl_type -> cl_type
1432 | Types.PredefinedType _ | Types.ComponentType _ | Types.ArrayType _ |
1433 Types.TupleType _ ->
1435 {err_msg = ["class"; "_ElemExpected"];
1436 err_info = [("TypeFound",
1437 Types.string_of_class_specifier cl_spec')];
1438 err_ctx = ctx}) (*error*)
1440 and modified_component_type ctx cpnt_type modif =
1441 let modified_component_type' = function
1442 | Modification (cl_modif, _) -> modify_component_type ctx cl_modif cpnt_type
1443 | Assignment _ | Equality _ -> cpnt_type in
1444 match evaluate modif with
1446 | Some modif' -> modified_component_type' modif'
1448 (* We can abstract dimensions away since they have been already checked at *)
1449 (* modification resolution time. *)
1450 and modify_class_specifier ctx cl_modif cl_spec =
1451 let rec modify_class_specifier' cl_spec' = match cl_spec' with
1452 | Types.PredefinedType predef ->
1453 Types.PredefinedType (modify_predefined_type ctx cl_modif predef)
1454 | Types.ClassType cl_type ->
1455 Types.ClassType (modify_class_type ctx cl_modif cl_type)
1456 | Types.ComponentType cpnt_type ->
1457 Types.ComponentType (modify_component_type ctx cl_modif cpnt_type)
1458 | Types.ArrayType (dim, cl_spec) ->
1459 Types.ArrayType (dim, modify_class_specifier' cl_spec)
1460 | Types.TupleType _ ->
1462 {err_msg = ["_InvalidTypeOfClassSpec"];
1463 err_info = [("_TypeFound",
1464 Types.string_of_class_specifier cl_spec')];
1465 err_ctx = ctx}) (*error*) in
1466 modify_class_specifier' (evaluate cl_spec)
1468 and modify_predefined_type ctx cl_modif predef =
1471 modify_predefined_attributes ctx cl_modif predef.Types.attributes
1474 and modify_predefined_attributes ctx cl_modif attrs =
1475 let apply_modifications ((id, final) as attr) = function
1477 | [_] when final -> assert false (*error*)
1478 | [final', (Assignment _ | Equality _)] -> id, final'
1479 | _ :: _ -> assert false (*error*) in
1480 let modify_attribute ((id, _) as attr) =
1481 let modifs, elt_descs = partition_modifications cl_modif id in
1482 match modifs, elt_descs with
1484 | _ :: _, [] -> apply_modifications attr modifs
1488 {err_msg = ["_RedeclarePredefTypeAttrib"; id];
1490 err_ctx = ctx}) (*error*) in
1491 List.map modify_attribute attrs
1493 and modify_class_type ctx cl_modif cl_type =
1494 let modify_named_element (id, elt_type) =
1495 id, lazy (modify_element ctx cl_modif id (evaluate elt_type)) in
1497 Types.named_elements =
1498 List.map modify_named_element cl_type.Types.named_elements
1501 and modify_element ctx cl_modif id elt_type =
1502 let modifs, elt_descs = partition_modifications cl_modif id in
1503 match modifs, elt_descs with
1504 | [], [] -> elt_type
1505 | _ :: _, [] -> apply_element_modifications ctx modifs elt_type id
1506 | [], [elt_desc] -> apply_element_redeclaration ctx elt_desc elt_type
1507 | [], _ :: _ :: _ ->
1509 {err_msg = ["_InvalidElemModifDef"];
1511 err_ctx = ctx}) (*error*)
1514 {err_msg = ["_InvalidElemModifDef"];
1516 err_ctx = ctx}) (*error*)
1518 and partition_modifications cl_modif id =
1519 let add_element_modification modif_arg modifs = match modif_arg.action with
1520 | Some (ElementModification modif) -> (modif_arg.final, modif) :: modifs
1521 | None | Some (ElementRedeclaration _) -> modifs
1522 and add_element_redeclaration modif_arg elt_descs =
1523 match modif_arg.action with
1524 | None | Some (ElementModification _) -> elt_descs
1525 | Some (ElementRedeclaration elt_desc) ->
1526 (modif_arg.final, elt_desc) :: elt_descs in
1527 let is_current_element_modification modif_arg = modif_arg.target = id in
1528 let cl_modif' = List.filter is_current_element_modification cl_modif in
1529 let modifs = List.fold_right add_element_modification cl_modif' []
1530 and elt_descs = List.fold_right add_element_redeclaration cl_modif' [] in
1533 and apply_element_redeclaration ctx elt_desc elt_type =
1535 {err_msg = ["_NotYetImplemented"; "_ElementRedeclaration"];
1539 and apply_element_modifications ctx modifs elt_type id =
1540 let add_modification_arguments (final, modif) cl_modifs = match modif with
1541 | Modification (cl_modif, _) -> (final, cl_modif) :: cl_modifs
1542 | Assignment _ | Equality _ -> cl_modifs
1543 and add_value_modification (final, modif) val_modifs = match modif with
1544 | Modification (_, Some _) | Assignment _ | Equality _ ->
1546 | Modification (_, None) -> val_modifs in
1547 let cl_modifs = List.fold_right add_modification_arguments modifs []
1548 and val_modifs = List.fold_right add_value_modification modifs [] in
1549 let elt_type' = modify_element_type ctx cl_modifs elt_type id in
1550 modify_element_value ctx val_modifs elt_type' id
1552 and modify_element_type ctx cl_modifs elt_type id =
1553 let propagate_final_attribute final modif_arg cl_modif =
1554 { modif_arg with final = final } :: cl_modif in
1555 let merge_modifications (final, cl_modif) cl_modif' =
1556 List.fold_right (propagate_final_attribute final) cl_modif cl_modif' in
1557 let cl_modif = List.fold_right merge_modifications cl_modifs [] in
1559 Types.element_nature = modify_element_nature ctx cl_modif elt_type id
1562 and modify_element_nature ctx cl_modif elt_type id =
1563 match elt_type.Types.element_nature with
1564 | _ when elt_type.Types.final ->
1566 {err_msg = ["_FinalElemModifNotAllowed"; id];
1568 err_ctx = ctx}) (*error*)
1569 | Types.ComponentElement cpnt_type ->
1570 Types.ComponentElement (modify_component_type ctx cl_modif cpnt_type)
1571 | Types.ClassElement cl_spec ->
1572 let cl_spec' = lazy (modify_class_specifier ctx cl_modif cl_spec) in
1573 Types.ClassElement cl_spec'
1574 | Types.ComponentTypeElement cpnt_type ->
1575 let cpnt_type' = modify_component_type ctx cl_modif cpnt_type in
1576 Types.ComponentTypeElement cpnt_type'
1577 | Types.PredefinedTypeElement predef ->
1578 Types.PredefinedTypeElement (modify_predefined_type ctx cl_modif predef)
1580 and modify_element_value ctx val_modifs elt_type id =
1581 match val_modifs with
1583 | [_] when elt_type.Types.final ->
1585 {err_msg = ["_FinalElemModifNotAllowed"; id];
1587 err_ctx = ctx}) (*error*)
1588 | [final] -> { elt_type with Types.final = final }
1591 {err_msg = ["_DuplicatedModifOfElem"; id];
1593 err_ctx = ctx}) (*error*)
1595 and modify_component_type ctx cl_modif cpnt_type =
1598 lazy (modify_class_specifier ctx cl_modif cpnt_type.Types.base_class)
1601 and resolve_type_modification ctx cpnt_type cl_modif =
1602 let cl_spec = (evaluate cpnt_type).Types.base_class in
1603 resolve_class_modification_option ctx cl_spec cl_modif
1605 and resolve_component_modification ctx cpnt_type = function
1608 let elt_nat = Types.ComponentElement (evaluate cpnt_type) in
1609 Some (resolve_modification ctx elt_nat modif')
1611 and resolve_class_modification_option ctx cl_spec = function
1613 | Some cl_modif -> resolve_class_modification ctx cl_spec cl_modif
1615 and resolve_modification ctx elt_nat modif =
1616 let ctx = {ctx with location = modif.Syntax.info} in
1617 match elt_nat, modif.Syntax.nature with
1618 | Types.ComponentElement cpnt_type, Syntax.Modification (cl_modif, expr) |
1619 Types.ComponentTypeElement cpnt_type,
1620 Syntax.Modification (cl_modif, (None as expr)) ->
1621 resolve_component_type_modification ctx cpnt_type cl_modif expr
1622 | Types.ComponentTypeElement _, Syntax.Modification (_, Some _) ->
1624 {err_msg = ["_InvalidClassElemModif"];
1626 err_ctx = ctx}) (*error*)
1627 | Types.ClassElement cl_spec, Syntax.Modification (cl_modif, None) ->
1628 let cl_modif' = resolve_class_modification ctx cl_spec cl_modif in
1629 Modification (cl_modif', None)
1630 | Types.ClassElement _, Syntax.Modification (_, Some _) ->
1632 {err_msg = ["_InvalidClassElemModif"];
1634 err_ctx = ctx}) (*error*)
1635 | (Types.PredefinedTypeElement _),
1636 (Syntax.Modification _ | Syntax.Eq _ | Syntax.ColEq _) ->
1638 {err_msg = ["_InvalidClassElemModif"];
1640 err_ctx = ctx}) (*error*)
1641 | Types.ComponentElement cpnt_type, Syntax.Eq expr ->
1642 let expr' = lazy (resolve_modification_equation ctx cpnt_type expr) in
1644 | Types.ComponentElement cpnt_type, Syntax.ColEq expr ->
1645 let expr' = lazy (resolve_modification_algorithm ctx cpnt_type expr) in
1647 | (Types.ClassElement _ | Types.ComponentTypeElement _),
1648 (Syntax.Eq _ | Syntax.ColEq _) ->
1650 {err_msg = ["_InvalidClassElemModif"];
1652 err_ctx = ctx}) (*error*)
1654 and resolve_component_type_modification ctx cpnt_type cl_modif expr =
1655 let ctx = {ctx with location = cl_modif.Syntax.info} in
1656 let cl_spec = cpnt_type.Types.base_class in
1657 let cl_modif' = resolve_class_modification ctx cl_spec cl_modif in
1658 let cpnt_type' = modify_component_type ctx cl_modif' cpnt_type in
1659 let expr' = resolve_value_modification_option ctx cpnt_type' expr in
1660 Modification (cl_modif', expr')
1662 and resolve_value_modification_option ctx cpnt_type = function
1664 | Some expr -> Some (lazy (resolve_modification_equation ctx cpnt_type expr))
1666 and resolve_modification_equation ctx cpnt_type expr =
1667 let ctx = {ctx with location = expr.Syntax.info} in
1668 let resolve_modification_equation' cpnt_type' expr' =
1669 let var = evaluate cpnt_type.Types.variability
1670 and var' = evaluate cpnt_type'.Types.variability in
1671 match Types.compare_component_types cpnt_type cpnt_type' with
1673 when Types.higher_variability var var' -> expr'
1675 let var = Types.string_of_variability var
1676 and var' = Types.string_of_variability var' in
1678 {err_msg = ["_VariabilityConflicts"];
1679 err_info = [("_ExprKind", "A = B");
1680 ("_VariabilityOfA", var);
1681 ("_VariabilityOfB", var')];
1682 err_ctx = ctx}) (*error*)
1684 let type_A = Types.string_of_component_type cpnt_type
1685 and type_B = Types.string_of_component_type cpnt_type' in
1687 {err_msg = [ "_EquTermsNotOfTheSameType"];
1688 err_info = [("_ExprKind", "A = B");
1689 ("_TypeOfA", type_A);
1690 ("_TypeOfB", type_B)];
1691 err_ctx = ctx}) (*error*) in
1692 let expr' = resolve_expression ctx expr in
1693 let expr' = apply_rhs_coercions cpnt_type expr' in
1694 match expr'.info.type_description with
1695 | Types.ComponentElement cpnt_type' ->
1696 resolve_modification_equation' cpnt_type' expr'
1697 | Types.ClassElement _ | Types.ComponentTypeElement _ |
1698 Types.PredefinedTypeElement _ ->
1700 {err_msg = ["_ClassElemFoundInExpr"];
1702 err_ctx = ctx}) (*error*)
1704 and resolve_modification_algorithm ctx cpnt_type expr =
1705 let ctx = {ctx with location = expr.Syntax.info} in
1706 let resolve_modification_algorithm' cpnt_type' expr' =
1707 let var = evaluate cpnt_type.Types.variability
1708 and var' = evaluate cpnt_type'.Types.variability in
1709 match Types.compare_component_types cpnt_type cpnt_type' with
1711 when Types.higher_variability var var' -> expr'
1713 let var = Types.string_of_variability var
1714 and var' = Types.string_of_variability var' in
1716 {err_msg = ["_VariabilityConflicts"];
1717 err_info = [("_ExprKind", "A := B");
1718 ("_VariabilityOfA", var);
1719 ("_VariabilityOfB", var')];
1720 err_ctx = ctx}) (*error*)
1722 let type_A = Types.string_of_component_type cpnt_type
1723 and type_B = Types.string_of_component_type cpnt_type' in
1725 {err_msg = [ "_TypeConflictsInAssign"];
1726 err_info = [("_ExprKind", "A := B");
1727 ("_TypeOfA", type_A);
1728 ("_TypeOfB", type_B)];
1729 err_ctx = ctx}) (*error*) in
1730 let expr' = resolve_expression ctx expr in
1731 let expr' = apply_rhs_coercions cpnt_type expr' in
1732 match expr'.info.type_description with
1733 | Types.ComponentElement cpnt_type' ->
1734 resolve_modification_algorithm' cpnt_type' expr'
1735 | Types.ClassElement _ | Types.ComponentTypeElement _ |
1736 Types.PredefinedTypeElement _ ->
1738 {err_msg = ["_ClassElemFoundInExpr"];
1740 err_ctx = ctx}) (*error*)
1742 and resolve_class_modification ctx cl_spec cl_modif =
1743 match cl_modif.Syntax.nature with
1744 | Syntax.ClassModification args ->
1745 List.map (resolve_modification_argument ctx cl_spec) args
1747 and resolve_modification_argument ctx cl_spec arg =
1748 let ctx = {ctx with location = arg.Syntax.info} in
1749 let apply_each each =
1750 let rec drop_dimensions cl_spec = match cl_spec with
1751 | Types.ArrayType (_, cl_spec') -> drop_dimensions cl_spec'
1752 | Types.PredefinedType _ | Types.ClassType _ | Types.ComponentType _ |
1753 Types.TupleType _ -> cl_spec in
1754 let cl_spec' = evaluate cl_spec in
1756 | Types.ArrayType _ when each -> drop_dimensions cl_spec'
1757 | Types.PredefinedType _
1759 | Types.ComponentType _
1760 | Types.TupleType _ when each ->
1762 {err_msg = ["_EachAppliedToNonArrayElem"];
1764 err_ctx = ctx}) (*error*)
1765 | Types.ArrayType _ | Types.PredefinedType _ | Types.ClassType _ |
1766 Types.ComponentType _ | Types.TupleType _ -> cl_spec' in
1767 match arg.Syntax.nature with
1768 | Syntax.ElementModification (each, final, expr, modif, _) ->
1769 let each' = bool_of_each each
1770 and final' = bool_of_final final in
1771 let cl_spec' = apply_each each' in
1772 resolve_element_modification ctx cl_spec' each' final' expr modif
1773 | Syntax.ElementRedeclaration (each, final, elt_def) ->
1774 let each' = bool_of_each each
1775 and final' = bool_of_final final in
1776 let cl_spec' = apply_each each' in
1777 resolve_element_redeclaration ctx cl_spec' each' final' elt_def
1779 and bool_of_each = function
1781 | Some Syntax.Each -> true
1783 and bool_of_final = function
1785 | Some Syntax.Final -> true
1787 and resolve_element_modification ctx cl_spec each final expr modif =
1788 let ctx = {ctx with location = expr.Syntax.info} in
1789 let rec path_of_expression path expr = match expr.Syntax.nature with
1790 | Syntax.Identifier id ->
1791 modification_arguments_of_path cl_spec each final id (List.rev path)
1792 | Syntax.FieldAccess (expr, id) -> path_of_expression (id :: path) expr
1795 {err_msg = ["_InvalidExprInElemModif"];
1797 err_ctx = ctx}) (*error*)
1798 and modification_arguments_of_path cl_spec each final id path =
1800 and var = Types.Continuous
1801 and inout = Types.Acausal in
1802 let elt_nat = element_field_type_nature ctx flow var inout cl_spec id in
1807 action = resolve_modification_action ctx modif elt_nat path
1809 and resolve_modification_action ctx modif elt_nat = function
1810 | [] -> resolve_modification_option ctx elt_nat modif
1813 {err_msg = ["_NotYetImplemented"; "_FieldAccessInElemModifExpr"];
1816 and resolve_modification_option ctx elt_nat = function
1819 Some (ElementModification (resolve_modification ctx elt_nat modif)) in
1820 path_of_expression [] expr
1822 and resolve_element_redeclaration ctx cl_spec each final elt_def =
1823 let ctx = {ctx with location = elt_def.Syntax.info} in
1825 {err_msg = ["_NotYetImplemented"; "_ElementRedeclaration"];
1829 and resolve_unnamed_elements ctx other_elts =
1831 let class_context' cl_spec = match cl_spec with
1832 | Types.ClassType cl_type ->
1833 Some (evaluate cl_type.Types.kind)
1835 match ctx.context_nature with
1836 | ClassContext cl_def ->
1837 class_context' (evaluate cl_def.class_type)
1839 let add_equation_or_algorithm_clause other_elt acc =
1840 match other_elt.Syntax.nature, class_kind with
1841 | (Syntax.EquationClause _), Some kind
1842 when List.mem kind [Types.Function; Types.Record; Types.Connector] ->
1844 {err_msg = ["_EquNotAllowedInTheDefOf"; Types.string_of_kind kind];
1846 err_ctx = ctx}) (*error*)
1847 | Syntax.EquationClause (init, equ_defs), _ ->
1848 let init' = bool_of_initial init
1849 and equ_defs' = resolve_equation_definitions ctx equ_defs in
1850 EquationClause (init', equ_defs') :: acc
1851 | Syntax.AlgorithmClause (init, algo_defs), _ ->
1852 let init' = bool_of_initial init
1853 and algo_defs' = resolve_algorithm_definitions ctx algo_defs in
1854 AlgorithmClause (init', algo_defs') :: acc
1855 | (Syntax.Public _ | Syntax.Protected _), _ -> acc in
1856 List.fold_right add_equation_or_algorithm_clause other_elts []
1858 and bool_of_initial = function
1860 | Some Syntax.Initial -> Initial
1862 and resolve_equation_definitions ctx equ_defs =
1863 let resolve_equation_definition equ_def = match equ_def.Syntax.nature with
1864 | Syntax.Equation (equ, _, _) -> resolve_equation ctx equ in
1865 List.flatten (List.map resolve_equation_definition equ_defs)
1867 and resolve_algorithm_definitions ctx algo_defs =
1868 let resolve_algorithm_definition algo_def = match algo_def.Syntax.nature with
1869 | Syntax.Algorithm (algo, _, _) -> resolve_algorithm ctx algo in
1870 List.map resolve_algorithm_definition algo_defs
1872 and resolve_equation ctx equ =
1873 let ctx = {ctx with location = equ.Syntax.info} in
1874 match equ.Syntax.nature with
1875 | Syntax.Equal (expr, expr') -> resolve_equal ctx equ expr expr'
1876 | Syntax.ConditionalEquationE (alts, default) ->
1877 resolve_conditional_equation_e ctx equ alts default
1878 | Syntax.ForClauseE (for_inds, equs) ->
1879 resolve_for_clause_e ctx equ for_inds equs
1880 | Syntax.ConnectClause (expr, expr') ->
1881 resolve_connect_clause ctx equ expr expr'
1882 | Syntax.WhenClauseE alts ->
1883 resolve_when_clause_e ctx equ alts
1884 | Syntax.FunctionCallE (expr, fun_args) ->
1885 resolve_functional_call_e ctx equ expr fun_args
1887 and resolve_equal ctx equ expres expres' =
1888 let resolve_equal' cpnt_type expr cpnt_type' expr' =
1889 let resolved_equation syn expr expr' =
1891 nature = Equal (expr, expr');
1894 let var = evaluate cpnt_type.Types.variability
1895 and var' = evaluate cpnt_type'.Types.variability in
1896 match var, var' with
1897 | Types.Continuous, _ | _, Types.Continuous ->
1898 equations ctx equ resolved_equation cpnt_type expr cpnt_type' expr'
1899 | Types.Discrete, _ | _, Types.Discrete
1900 when expression_of_variable expres ->
1901 equations ctx equ resolved_equation cpnt_type expr cpnt_type' expr'
1902 | Types.Discrete, _ | _, Types.Discrete ->
1904 {err_msg = ["_LHSOfDiscreteEquMustBeAVar"];
1906 err_ctx = {ctx with location = expres.Syntax.info}}) (*error*)
1908 equations ctx equ resolved_equation cpnt_type expr cpnt_type' expr' in
1909 let expr = resolve_expression ctx expres
1910 and expr' = resolve_expression ctx expres' in
1911 let exprs = apply_binary_coercions [ expr; expr' ] in
1912 let expr = List.nth exprs 0
1913 and expr' = List.nth exprs 1 in
1914 let elt_nat = expr.info.type_description
1915 and elt_nat' = expr'.info.type_description in
1916 match elt_nat, elt_nat' with
1917 | Types.ComponentElement cpnt_type, Types.ComponentElement cpnt_type' ->
1918 resolve_equal' cpnt_type expr cpnt_type' expr'
1919 | (Types.ClassElement _ | Types.ComponentTypeElement _ |
1920 Types.PredefinedTypeElement _), _ ->
1921 let ctx = {ctx with location = expres.Syntax.info} in
1923 {err_msg = ["_ClassElemFoundInExpr"];
1925 err_ctx = ctx}) (*error*)
1926 | _, (Types.ClassElement _ | Types.ComponentTypeElement _ |
1927 Types.PredefinedTypeElement _) ->
1928 let ctx = {ctx with location = expres'.Syntax.info} in
1930 {err_msg = ["_ClassElemFoundInExpr"];
1932 err_ctx = ctx}) (*error*)
1934 and resolve_conditional_equation_e ctx equ alts default =
1935 let resolve_alternative (expr, equs) =
1936 let ctx = {ctx with location = expr.Syntax.info} in
1937 let expr' = resolve_expression ctx expr in
1938 let resolve_alternative' cpnt_type =
1939 let cl_spec = evaluate cpnt_type.Types.base_class in
1941 | Types.PredefinedType { Types.base_type = Types.BooleanType } ->
1942 let equs' = List.flatten (List.map (resolve_equation ctx) equs) in
1944 | Types.PredefinedType _ | Types.ClassType _ | Types.ComponentType _ |
1945 Types.ArrayType _ | Types.TupleType _ ->
1947 {err_msg = ["_NonBooleanIfCondExpr"];
1949 [("_ExprKind", "...if A then...");
1950 ("_TypeOfA", Types.string_of_class_specifier cl_spec)];
1951 err_ctx = ctx}) (*error*) in
1952 match expr'.info.type_description with
1953 | Types.ComponentElement cpnt_type -> resolve_alternative' cpnt_type
1954 | Types.ClassElement _ | Types.ComponentTypeElement _ |
1955 Types.PredefinedTypeElement _ ->
1957 {err_msg = ["_ClassElemFoundInExpr"];
1959 err_ctx = ctx}) (*error*) in
1960 let alts' = List.map resolve_alternative alts in
1961 let default' = match default with
1963 | Some equs -> List.flatten (List.map (resolve_equation ctx) equs) in
1965 nature = ConditionalEquationE (alts', default');
1969 and resolve_for_clause_e ctx equ for_inds equs =
1970 let range_element_type expr range =
1971 let ctx = {ctx with location = expr.Syntax.info} in
1972 let sub_dimension cl_spec = match cl_spec with
1973 | Types.ArrayType (dim, cl_spec) -> cl_spec
1974 | Types.PredefinedType _ | Types.ClassType _ |
1975 Types.ComponentType _ | Types.TupleType _ ->
1977 {err_msg = ["_InvalidTypeInRangeExpr"];
1979 [("_ExpectedType", "Integer");
1980 ("_TypeFound", Types.string_of_class_specifier cl_spec)];
1981 err_ctx = ctx}) (*error*) in
1982 match range.info.type_description with
1983 | Types.ComponentElement cpnt_type ->
1984 let cl_spec = evaluate cpnt_type.Types.base_class in
1987 Types.base_class = lazy (sub_dimension cl_spec)
1989 Types.ComponentElement cpnt_type'
1990 | Types.ClassElement _ | Types.ComponentTypeElement _ |
1991 Types.PredefinedTypeElement _ ->
1993 {err_msg = ["_ClassElemFoundInExpr"];
1995 err_ctx = ctx}) (*error*) in
1996 let rec resolve_for_clause_e' acc ctx = function
1998 let equs' = List.flatten (List.map (resolve_equation ctx) equs) in
2000 nature = ForClauseE (List.rev acc, equs');
2005 {err_msg = ["_NotYetImplemented"; "_ImplicitIterRange"];
2008 | (id, Some expr) :: for_inds ->
2009 let range = resolve_expression ctx expr in
2010 let elt_nat = range_element_type expr range in
2013 context_nature = ForContext (ctx, id, elt_nat)
2015 resolve_for_clause_e' (range :: acc) ctx' for_inds in
2016 resolve_for_clause_e' [] ctx for_inds
2018 and resolve_connect_clause ctx equ expres expres' =
2019 let expr = resolve_expression ctx expres
2020 and expr' = resolve_expression ctx expres' in
2021 let resolve_connect_clause' cpnt_typ cpnt_typ' =
2022 let rec class_type_of_class_specifier cl_spec = match cl_spec with
2023 | Types.ClassType cl_type -> cl_type
2024 | Types.ComponentType cpnt_type ->
2025 let cl_spec = evaluate cpnt_type.Types.base_class in
2026 class_type_of_class_specifier cl_spec
2027 | Types.ArrayType (_, cl_spec) -> class_type_of_class_specifier cl_spec
2028 | Types.PredefinedType _ | Types.TupleType _ ->
2030 {err_msg = ["_InvalidTypeOfArgInConnectStat"];
2032 [("_ExprKind", "connect(A, B)");
2033 ("_TypeOfA", Types.string_of_component_type cpnt_typ);
2034 ("_TypeOfB", Types.string_of_component_type cpnt_typ')];
2035 err_ctx = ctx}) (*error*) in
2036 let connector_sign expr =
2037 let is_connector_type expr =
2038 let is_connector_type' cpnt_type =
2039 let cl_spec = evaluate cpnt_type.Types.base_class in
2040 let cl_type = class_type_of_class_specifier cl_spec in
2041 match evaluate cl_type.Types.kind with
2042 | Types.Connector | Types.ExpandableConnector -> true
2043 | Types.Class | Types.Model | Types.Block -> false
2047 ["record"; "_InstanceUsedInConnection"];
2049 err_ctx = ctx}) (*error*)
2053 ["package"; "_InstanceUsedInConnection"];
2055 err_ctx = ctx}) (*error*)
2059 ["function"; "_InstanceUsedInConnection"];
2061 err_ctx = ctx}) (*error*) in
2062 match expr.info.type_description with
2063 | Types.ComponentElement cpnt_type ->
2064 is_connector_type' cpnt_type
2067 {err_msg = ["_ClassElemFoundInExpr"];
2069 err_ctx = ctx}) (*error*) in
2070 let is_connectable expr =
2071 let is_connectable' cpnt_type =
2072 let cl_spec = evaluate cpnt_type.Types.base_class in
2073 let cl_type = class_type_of_class_specifier cl_spec in
2074 match evaluate cl_type.Types.kind with
2075 | Types.Class | Types.Model | Types.Block -> true
2076 | Types.Connector | Types.ExpandableConnector -> false
2080 ["record"; "_InstanceUsedInConnection"];
2082 err_ctx = ctx}) (*error*)
2086 ["package"; "_InstanceUsedInConnection"];
2088 err_ctx = ctx}) (*error*)
2092 ["function"; "_InstanceUsedInConnection"];
2094 err_ctx = ctx}) (*error*) in
2095 match expr.info.type_description with
2096 | Types.ComponentElement cpnt_type ->
2097 is_connectable' cpnt_type
2100 {err_msg = ["_ClassElemFoundInExpr"];
2102 err_ctx = ctx}) (*error*) in
2103 let rec connector_sign' expr = match expr.nature with
2104 | LocalIdentifier (0, _) when is_connector_type expr -> Some Negative
2105 | LocalIdentifier (0, _) when is_connectable expr -> Some Positive
2106 | (FieldAccess (expr', _) | IndexedAccess (expr', _))
2107 when is_connector_type expr -> connector_sign' expr'
2108 | (FieldAccess (expr', _) | IndexedAccess (expr', _))
2109 when is_connectable expr' -> connector_sign' expr'
2112 {err_msg = ["_InvalidTypeOfArgInConnectStat"];
2114 [("_ExprKind", "connect(A, B)");
2115 ("_TypeOfA", Types.string_of_component_type cpnt_typ);
2116 ("_TypeOfB", Types.string_of_component_type cpnt_typ')];
2117 err_ctx = ctx}) (*error*) in
2118 match expr.nature with
2119 | _ when not (is_connector_type expr) ->
2121 {err_msg = ["_InvalidTypeOfArgInConnectStat"];
2123 [("_ExprKind", "connect(A, B)");
2124 ("_TypeOfA", Types.string_of_component_type cpnt_typ);
2125 ("_TypeOfB", Types.string_of_component_type cpnt_typ')];
2126 err_ctx = ctx}) (*error*)
2127 | LocalIdentifier (0, _) -> Some Negative
2128 | _ -> connector_sign' expr in
2129 let connect sign cpnt_type sign' cpnt_type' =
2130 let resolved_equation syn expr expr' =
2131 let elt_nat = expr.info.type_description
2132 and elt_nat' = expr'.info.type_description in
2133 let flow, _, _ = type_prefixes_of_element_nature elt_nat
2134 and flow', _, _ = type_prefixes_of_element_nature elt_nat' in
2135 match flow, flow' with
2138 nature = Equal (expr, expr');
2143 nature = ConnectFlows (sign, expr, sign', expr');
2148 {err_msg = ["_CannotConnectFlowAndNonFlowComp"];
2150 [("_ExprKind", "connect(A, B)");
2151 ("_TypeOfA", "non-flow connector");
2152 ("_TypeOfB", "flow connector")];
2153 err_ctx = ctx}) (*error*)
2156 {err_msg = ["_CannotConnectFlowAndNonFlowComp"];
2158 [("_ExprKind", "connect(A, B)");
2159 ("_TypeOfA", "flow connector");
2160 ("_TypeOfB", "non-flow connector")];
2161 err_ctx = ctx}) (*error*) in
2162 equations ctx equ resolved_equation cpnt_type expr cpnt_type' expr' in
2163 match connector_sign expr, connector_sign expr' with
2164 | Some sign, Some sign' -> connect sign cpnt_typ sign' cpnt_typ'
2165 | None, Some _ -> assert false
2166 | Some _, None -> assert false
2167 | None, None -> assert false in
2168 let elt_nat = expr.info.type_description
2169 and elt_nat' = expr'.info.type_description in
2170 match elt_nat, elt_nat' with
2171 | Types.ComponentElement cpnt_typ, Types.ComponentElement cpnt_typ' ->
2172 resolve_connect_clause' cpnt_typ cpnt_typ'
2175 {err_msg = ["_InvalidTypeOfArgInConnectStat"];
2177 [("_ExprKind", "connect(A, B)");
2178 ("_TypeOfA", Types.string_of_element_nature elt_nat);
2179 ("_TypeOfB", Types.string_of_element_nature elt_nat')];
2180 err_ctx = ctx}) (*error*)
2182 and resolve_when_clause_e ctx equ alts =
2183 let resolve_alternative (expr, equs) =
2184 let expr' = resolve_expression ctx expr in
2185 let rec check_equation equ =
2186 let check_equal expr expr' =
2187 match expr.Syntax.nature, expr'.Syntax.nature with
2188 | _, _ when expression_of_variable expr -> true
2189 | Syntax.Tuple exprs, Syntax.FunctionCall _
2190 when List.for_all expression_of_variable exprs -> true
2191 | _, _ -> raise (CompilError
2192 {err_msg = ["_InvalidWhenEquation"];
2194 err_ctx = {ctx with location = expr.Syntax.info}}) (*error*) in
2195 let check_alternative (expr, equs) =
2196 List.for_all check_equation equs in
2197 let check_function_call_e expr fun_args =
2198 match expr.Syntax.nature with
2199 | Syntax.Identifier "assert" |
2200 Syntax.Identifier "terminate" |
2201 Syntax.Identifier "reinit" -> true
2204 {err_msg = ["_InvalidWhenEquation"];
2206 err_ctx = {ctx with location = expr.Syntax.info}}) in
2207 match equ.Syntax.nature with
2208 | Syntax.Equal (expr, expr') -> check_equal expr expr'
2209 | Syntax.ConditionalEquationE (alts, None) ->
2210 List.for_all check_alternative alts
2211 | Syntax.ConditionalEquationE (alts, Some equs) ->
2212 (List.for_all check_alternative alts) &&
2213 (List.for_all check_equation equs)
2214 | Syntax.ForClauseE (for_inds, equs) ->
2215 List.for_all check_equation equs
2216 | Syntax.ConnectClause (expr, expr') ->
2218 {err_msg = ["_InvalidWhenEquation"];
2220 err_ctx = {ctx with location = equ.Syntax.info}}) (*error*)
2221 | Syntax.WhenClauseE alts ->
2223 {err_msg = ["_WhenClausesCannotBeNested"];
2225 err_ctx = {ctx with location = equ.Syntax.info}}) (*error*)
2226 | Syntax.FunctionCallE (expr, fun_args) ->
2227 check_function_call_e expr fun_args in
2228 let resolve_alternative' cpnt_type =
2229 let cl_spec = evaluate cpnt_type.Types.base_class in
2231 | Types.ArrayType (Types.DiscreteDimension, _) ->
2233 {err_msg = ["_InvalidTypeOfWhenCond"];
2235 [("_ExprKind", "...when A then...");
2236 ("_TypeOfA", Types.string_of_class_specifier cl_spec)];
2237 err_ctx = {ctx with location = expr.Syntax.info}}) (*error*)
2238 | Types.PredefinedType { Types.base_type = Types.BooleanType } |
2240 (_, Types.PredefinedType { Types.base_type = Types.BooleanType })
2241 when List.for_all check_equation equs ->
2242 let equs' = List.flatten (List.map (resolve_equation ctx) equs) in
2244 | Types.PredefinedType _ | Types.ClassType _ | Types.ComponentType _ |
2245 Types.ArrayType _ | Types.TupleType _ ->
2247 {err_msg = ["_InvalidTypeOfWhenCond"];
2249 [("_ExprKind", "...when A then...");
2250 ("_TypeOfA", Types.string_of_class_specifier cl_spec)];
2251 err_ctx = {ctx with location = expr.Syntax.info}}) (*error*) in
2252 match expr'.info.type_description with
2253 | Types.ComponentElement cpnt_type
2254 when (evaluate cpnt_type.Types.variability) <> Types.Continuous ->
2255 resolve_alternative' cpnt_type
2256 | Types.ComponentElement cpnt_type ->
2258 {err_msg = ["_WhenConditionMustBeDiscrete"];
2260 err_ctx = {ctx with location = expr.Syntax.info}}) (*error*)
2261 | Types.ClassElement _ | Types.ComponentTypeElement _ |
2262 Types.PredefinedTypeElement _ ->
2264 {err_msg = ["_ClassElemFoundInExpr"];
2266 err_ctx = {ctx with location = expr.Syntax.info}}) (*error*) in
2267 let alts' = List.map resolve_alternative alts in
2269 nature = WhenClauseE alts';
2273 and resolve_functional_call_e ctx equ expr fun_args =
2274 let ctx = {ctx with location = equ.Syntax.info} in
2277 and elt_nat = Types.empty_tuple_type Types.Constant in
2278 resolved_expression None nat elt_nat in
2279 let fun_call = resolve_function_call ctx None expr fun_args in
2280 let resolve_functional_call_e cpnt_type =
2281 let cl_spec = evaluate cpnt_type.Types.base_class in
2283 | Types.TupleType [] ->
2285 nature = Equal (res, fun_call);
2290 {err_msg = ["_NonEmptyFuncCallUsedAsAnEqu"];
2292 [("_TypeOfFuncValue", Types.string_of_class_specifier cl_spec)];
2293 err_ctx = ctx}) (*error*) in
2294 match fun_call.info.type_description with
2295 | Types.ComponentElement cpnt_type -> resolve_functional_call_e cpnt_type
2296 | Types.ClassElement _ | Types.ComponentTypeElement _ |
2297 Types.PredefinedTypeElement _ ->
2299 {err_msg = ["_ClassElemFoundInExpr"];
2301 err_ctx = ctx}) (*error*)
2303 and equations ctx equ resolved_equation cpnt_type expr cpnt_type' expr' =
2304 let equivalent_types predef predef' =
2305 match Types.compare_predefined_types predef predef',
2306 Types.compare_predefined_types predef' predef with
2307 | _, Types.NotRelated | Types.NotRelated, _ -> false
2309 let rec equations' i subs cl_spec expr cl_spec' expr' =
2310 match cl_spec, cl_spec' with
2311 | Types.PredefinedType predef, Types.PredefinedType predef'
2312 when equivalent_types predef predef' ->
2313 [equation subs expr expr']
2314 | Types.ComponentType cpnt_type, Types.ComponentType cpnt_type' ->
2316 {err_msg = ["_NotYetImplemented"; "_ComponentTypeEqu"];
2319 | Types.ClassType cl_type, Types.ClassType cl_type' ->
2320 record_equations subs cl_type expr cl_type' expr'
2321 | Types.ArrayType (dim, cl_spec), Types.ArrayType (dim', cl_spec') ->
2322 [for_equation i subs dim cl_spec expr dim' cl_spec' expr']
2323 | Types.TupleType cl_specs, Types.TupleType cl_specs' ->
2325 nature = Equal (expr, expr');
2328 | (Types.PredefinedType _ | Types.ComponentType _ | Types.ArrayType _ |
2329 Types.TupleType _ | Types.ClassType _),
2330 (Types.PredefinedType _ | Types.ComponentType _ | Types.ArrayType _ |
2331 Types.TupleType _ | Types.ClassType _) ->
2333 {err_msg = ["_EquTermsNotOfTheSameType"];
2335 [("_ExprKind", "A = B");
2336 ("_TypeOfA", Types.string_of_class_specifier cl_spec);
2337 ("_TypeOfB", Types.string_of_class_specifier cl_spec')];
2338 err_ctx = {ctx with location = equ.Syntax.info}}) (*error*)
2339 and for_equation i subs dim cl_spec expr dim' cl_spec' expr' =
2340 match dim, dim' with
2341 | Types.ConstantDimension n, Types.ConstantDimension n' when n <> n' ->
2342 let type_A = Types.string_of_component_type cpnt_type
2343 and type_B = Types.string_of_component_type cpnt_type' in
2345 {err_msg = ["_ArrayDimMismatchInEqu"];
2346 err_info = [("_ExprKind", "A = B");
2347 ("_TypeOfA", type_A);
2348 ("_TypeOfB", type_B)];
2349 err_ctx = ctx}) (*error*)
2350 | (Types.ConstantDimension _ | Types.ParameterDimension),
2351 (Types.ConstantDimension _ | Types.ParameterDimension) ->
2352 let range = resolve_colon ctx expr (Int32.of_int i) dim in
2354 let nat = LoopVariable (i - 1)
2355 and elt_nat = Types.integer_type Types.Constant in
2356 resolved_expression None nat elt_nat :: subs in
2357 let equs = equations' (i + 1) subs cl_spec expr cl_spec' expr' in
2359 nature = ForClauseE ([range], equs);
2362 | (Types.ConstantDimension _ | Types.ParameterDimension |
2363 Types.DiscreteDimension),
2364 (Types.ConstantDimension _ | Types.ParameterDimension |
2365 Types.DiscreteDimension) ->
2366 let type_A = Types.string_of_component_type cpnt_type
2367 and type_B = Types.string_of_component_type cpnt_type' in
2369 {err_msg = ["_ArrayDimMismatchInEqu"];
2370 err_info = [("_ExprKind", "A = B");
2371 ("_TypeOfA", type_A);
2372 ("_TypeOfB", type_B)];
2373 err_ctx = ctx}) (*error*)
2374 and record_equations subs cl_type expr cl_type' expr' =
2375 let named_elts = cl_type.Types.named_elements
2376 and named_elts' = cl_type'.Types.named_elements in
2377 let record_equations' expr expr' =
2378 let class_spec_of_element_type elt_type =
2379 let elt_type' = evaluate elt_type in
2380 element_nature_class ctx elt_type'.Types.element_nature in
2381 let record_equation (id, elt_type) =
2384 List.assoc id named_elts'
2387 {err_msg = ["_EquTermsNotOfTheSameType"];
2389 [("_ExprKind", "A = B");
2390 ("_TypeOfA", Types.string_of_component_type cpnt_type);
2391 ("_TypeOfB", Types.string_of_component_type cpnt_type')];
2392 err_ctx = {ctx with location = equ.Syntax.info}}) (*error*) in
2393 let cl_spec = class_spec_of_element_type elt_type
2394 and cl_spec' = class_spec_of_element_type elt_type' in
2396 let nat = FieldAccess (expr, id)
2397 and flow, var, inout =
2398 type_prefixes_of_element_nature expr.info.type_description
2399 and cl_spec = element_nature_class ctx expr.info.type_description in
2401 element_field_type_nature ctx flow var inout cl_spec id in
2402 resolved_expression None nat elt_nat
2404 let nat = FieldAccess (expr', id)
2405 and flow, var, inout =
2406 type_prefixes_of_element_nature expr'.info.type_description
2407 and cl_spec = element_nature_class ctx expr'.info.type_description in
2409 element_field_type_nature ctx flow var inout cl_spec id in
2410 resolved_expression None nat elt_nat in
2411 equations' 1 [] cl_spec expr cl_spec' expr' in
2412 List.flatten (List.map record_equation named_elts) in
2414 | [] -> record_equations' expr expr'
2417 let elt_nat = expr.info.type_description in
2418 let nat = IndexedAccess (expr, subs)
2419 and elt_nat' = scalar_element_nature elt_nat in
2420 resolved_expression None nat elt_nat'
2422 let elt_nat = expr'.info.type_description in
2423 let nat = IndexedAccess (expr', subs)
2424 and elt_nat' = scalar_element_nature elt_nat in
2425 resolved_expression None nat elt_nat' in
2426 record_equations' expr expr'
2427 and equation subs expr expr' = match subs with
2428 | [] -> resolved_equation (Some equ) expr expr'
2431 let elt_nat = expr.info.type_description in
2432 let nat = IndexedAccess (expr, subs)
2433 and elt_nat' = scalar_element_nature elt_nat in
2434 resolved_expression None nat elt_nat'
2436 let elt_nat = expr'.info.type_description in
2437 let nat = IndexedAccess (expr', subs)
2438 and elt_nat' = scalar_element_nature elt_nat in
2439 resolved_expression None nat elt_nat' in
2440 resolved_equation None expr expr' in
2441 let cl_spec = evaluate cpnt_type.Types.base_class
2442 and cl_spec' = evaluate cpnt_type'.Types.base_class in
2443 equations' 1 [] cl_spec expr cl_spec' expr'
2445 and resolve_algorithm ctx algo =
2446 let ctx = {ctx with location = algo.Syntax.info} in
2447 match algo.Syntax.nature with
2449 Syntax.FunctionCallA _ |
2450 Syntax.MultipleAssign _ |
2453 Syntax.ConditionalEquationA _ |
2454 Syntax.ForClauseA _ |
2455 Syntax.WhileClause _ |
2456 Syntax.WhenClauseA _ ->
2458 {err_msg = ["_NotYetImplemented"; "_AlgoClause"];
2462 and resolve_expression ctx expr =
2463 let ctx = {ctx with location = expr.Syntax.info} in
2464 match expr.Syntax.nature with
2465 | Syntax.BinaryOperation (kind, arg1, arg2) ->
2466 resolve_binary_operation ctx expr kind arg1 arg2
2467 | Syntax.End -> resolve_end ctx expr
2468 | Syntax.False -> resolve_false ctx expr
2469 | Syntax.FieldAccess (expr', id) -> resolve_field_access ctx expr expr' id
2470 | Syntax.FunctionCall (expr', fun_args) ->
2471 resolve_function_call ctx (Some expr) expr' fun_args
2472 | Syntax.Identifier id -> resolve_identifier ctx expr id
2473 | Syntax.If (alts, expr') -> resolve_if ctx expr alts expr'
2474 | Syntax.IndexedAccess (expr', subs) ->
2475 resolve_indexed_access ctx expr expr' subs
2476 | Syntax.Integer s -> resolve_integer ctx expr s
2477 | Syntax.MatrixConstruction exprss ->
2478 resolve_matrix_construction ctx expr exprss
2479 | Syntax.NoEvent expr' ->
2480 resolve_no_event ctx expr expr'
2481 | Syntax.Range (start, step, stop) ->
2482 resolve_range ctx expr start step stop
2483 | Syntax.Real s -> resolve_real ctx expr s
2484 | Syntax.String s -> resolve_string ctx expr s
2485 | Syntax.True -> resolve_true ctx expr
2486 | Syntax.Tuple exprs -> resolve_tuple ctx expr exprs
2487 | Syntax.UnaryOperation (kind, arg) ->
2488 resolve_unuary_operation ctx expr kind arg
2489 | Syntax.Vector vec_elts -> resolve_vector ctx expr vec_elts
2491 and resolve_binary_operation ctx expr kind arg1 arg2 =
2492 let arg1' = resolve_expression ctx arg1
2493 and arg2' = resolve_expression ctx arg2 in
2494 let args' = apply_binary_coercions [ arg1'; arg2' ] in
2495 let arg1' = List.nth args' 0
2496 and arg2' = List.nth args' 1 in
2497 match kind.Syntax.nature with
2498 | Syntax.Plus -> resolve_addition ctx expr arg1' arg2'
2499 | Syntax.And -> resolve_and ctx expr arg1' arg2'
2500 | Syntax.Divide -> resolve_division ctx expr arg1' arg2'
2501 | Syntax.EqualEqual -> raise (CompilError
2502 {err_msg = ["_NotYetImplemented"; "_BinaryOperEQUEQU"];
2505 | Syntax.GreaterEqual ->
2506 resolve_comparison ctx expr GreaterEqual arg1' arg2'
2507 | Syntax.Greater -> resolve_comparison ctx expr Greater arg1' arg2'
2508 | Syntax.LessEqual -> resolve_comparison ctx expr LessEqual arg1' arg2'
2509 | Syntax.Less -> resolve_comparison ctx expr Less arg1' arg2'
2510 | Syntax.Times -> resolve_multiplication ctx expr arg1' arg2'
2511 | Syntax.NotEqual -> raise (CompilError
2512 {err_msg = ["_NotYetImplemented"; "_BinaryOperDIFF"];
2515 | Syntax.Or -> resolve_or ctx expr arg1' arg2'
2516 | Syntax.Power -> resolve_power ctx expr arg1' arg2'
2517 | Syntax.Minus -> resolve_subtraction ctx expr arg1' arg2'
2519 and resolve_end ctx expr =
2520 let ctx = {ctx with location = expr.Syntax.info} in
2521 match ctx.context_nature with
2522 | SubscriptContext (_, _, _, Types.ConstantDimension n) ->
2524 and elt_nat = Types.integer_type Types.Constant in
2525 resolved_expression (Some expr) nat elt_nat
2526 | SubscriptContext (_, expr', n, Types.ParameterDimension) ->
2527 size_function_call ctx (Some expr) expr' n
2528 | SubscriptContext (_, expr', n, Types.DiscreteDimension) ->
2529 size_function_call ctx (Some expr) expr' n
2530 | ForContext (ctx', _, _) -> resolve_end ctx' expr
2531 | ToplevelContext | ClassContext _ ->
2533 {err_msg = ["_InvalidKeyWordEndInExpr"];
2535 err_ctx = ctx}) (*error*)
2537 and resolve_false ctx expr =
2538 resolved_expression (Some expr) False (Types.boolean_type Types.Constant)
2540 and resolve_field_access ctx expr expr' id =
2541 let expr' = resolve_expression ctx expr' in
2542 let resolve_field_access' expr' id =
2543 let nat = FieldAccess (expr', id)
2544 and flow, var, inout =
2545 type_prefixes_of_element_nature expr'.info.type_description
2546 and cl_spec = element_nature_class ctx expr'.info.type_description in
2547 let elt_nat = element_field_type_nature ctx flow var inout cl_spec id in
2548 resolved_expression (Some expr) nat elt_nat in
2549 let is_package cl_spec = match evaluate cl_spec with
2550 | Types.ClassType cl_type
2551 when evaluate cl_type.Types.kind = Types.Package -> true
2553 match expr'.info.type_description with
2554 | Types.ComponentElement _ ->
2555 resolve_field_access' expr' id
2556 | Types.ClassElement cl_spec when is_package cl_spec ->
2557 resolve_field_access' expr' id
2560 {err_msg = ["component or package"; "_ElemExpected"];
2562 err_ctx = { ctx with location = expr.Syntax.info }}) (*error*)
2564 and type_prefixes_of_element_nature = function
2565 | Types.ComponentElement cpnt_type ->
2566 evaluate cpnt_type.Types.flow,
2567 evaluate cpnt_type.Types.variability,
2568 evaluate cpnt_type.Types.causality
2569 | Types.ClassElement _ | Types.ComponentTypeElement _ |
2570 Types.PredefinedTypeElement _ ->
2571 false, Types.Constant, Types.Acausal
2573 and resolve_function_call ctx syn expr fun_args =
2574 let ctx = {ctx with location = expr.Syntax.info} in
2575 let expr' = resolve_expression ctx expr in
2576 let resolve_function_arguments named_elts =
2577 let reversed_additional_dimensions input_types args =
2578 let additional_named_element_dimensions id arg =
2579 let rec subtract_dimensions fun_dims arg_dims =
2580 match fun_dims, arg_dims with
2584 {err_msg = ["_ArgDimMismatch"];
2586 err_ctx = ctx}) (*error*)
2587 | Types.ConstantDimension i :: _, Types.ConstantDimension i' :: _
2590 {err_msg = ["_ArgDimMismatch"];
2592 err_ctx = ctx}) (*error*)
2593 | _ :: fun_dims, _ :: arg_dims ->
2594 subtract_dimensions fun_dims arg_dims in
2595 let elt_type = List.assoc id input_types in
2596 let elt_type' = evaluate elt_type in
2598 Types.reversed_element_dimensions elt_type'.Types.element_nature
2600 Types.reversed_element_dimensions arg.info.type_description in
2601 subtract_dimensions fun_dims arg_dims in
2602 let rec reversed_additional_dimensions' ids dims args =
2605 | (id, arg) :: args ->
2606 let dims' = additional_named_element_dimensions id arg in
2607 update_additional_dimensions ids dims id dims' args
2608 and update_additional_dimensions ids dims id dims' args =
2609 match dims, dims' with
2610 | _, [] -> reversed_additional_dimensions' ids dims args
2612 let ids' = id :: ids in
2613 reversed_additional_dimensions' ids' dims' args
2614 | _ :: _, _ :: _ when dims <> dims' ->
2616 {err_msg = ["_ArgDimMismatchInVectCall"];
2618 err_ctx = ctx}) (*error*)
2620 let ids' = id :: ids in
2621 reversed_additional_dimensions' ids' dims args in
2622 reversed_additional_dimensions' [] [] args in
2623 let function_call ids rev_dims input_types output_types args =
2624 let ndims = List.length rev_dims in
2625 let rec expressions_of_named_arguments pos input_types =
2626 let expression_of_default_argument id elt_type =
2627 let elt_type' = evaluate elt_type in
2629 let nat = FunctionArgument 0
2630 and elt_nat = expr'.info.type_description in
2631 resolved_expression None nat elt_nat in
2632 let nat = FieldAccess (func, id)
2633 and elt_nat = elt_type'.Types.element_nature in
2634 resolved_expression None nat elt_nat
2635 and expression_of_named_argument pos id elt_type =
2636 let rec loop_variables = function
2639 let nat = LoopVariable (ndims - 1)
2640 and elt_nat = (Types.integer_type Types.Constant) in
2641 let loop_var = resolved_expression None nat elt_nat in
2642 loop_var :: loop_variables (ndims - 1) in
2643 let elt_type' = evaluate elt_type in
2644 let elt_nat = elt_type'.Types.element_nature in
2645 let nat = match List.mem id ids with
2646 | false -> FunctionArgument pos
2648 let arg = List.assoc id args in
2649 let nat = FunctionArgument pos
2650 and elt_nat = arg.info.type_description in
2651 let expr = resolved_expression None nat elt_nat in
2652 IndexedAccess (expr, loop_variables ndims) in
2653 resolved_expression None nat elt_nat in
2654 match input_types with
2656 | (id, elt_type) :: input_types when not (List.mem_assoc id args) ->
2657 let arg = expression_of_default_argument id elt_type in
2658 arg :: expressions_of_named_arguments pos input_types
2659 | (id, elt_type) :: input_types ->
2660 let arg = expression_of_named_argument pos id elt_type in
2661 arg :: expressions_of_named_arguments (pos + 1) input_types in
2662 let ranges arg rev_dims =
2663 let rec ranges' acc n rev_dims =
2664 let range_of_dimension dim =
2666 let nat = Range (one, one, stop)
2667 and elt_nat = Types.integer_array_type Types.Constant dim in
2668 resolved_expression None nat elt_nat in
2670 | Types.ConstantDimension i ->
2673 and elt_nat = (Types.integer_type Types.Constant) in
2674 resolved_expression None nat elt_nat in
2676 | Types.ParameterDimension ->
2677 let stop = size_function_call ctx None arg n in
2679 | Types.DiscreteDimension ->
2680 let stop = size_function_call ctx None arg n in
2684 | dim :: rev_dims ->
2685 let range = range_of_dimension dim in
2686 ranges' (range :: acc) (Int32.succ n) rev_dims in
2687 ranges' [] 1l rev_dims in
2688 let rec sorted_arguments_of_named_arguments = function
2690 | (id, _) :: input_types when not (List.mem_assoc id args) ->
2691 sorted_arguments_of_named_arguments input_types
2692 | (id, _) :: input_types ->
2693 let arg = List.assoc id args in
2694 arg :: sorted_arguments_of_named_arguments input_types in
2695 let wrap_function_invocation cpnt_type =
2696 let add_dimensions cpnt_type =
2697 let rec add_dimensions cl_spec = function
2699 | dim :: rev_dims ->
2700 let cl_spec' = Types.ArrayType (dim, cl_spec) in
2701 add_dimensions cl_spec' rev_dims in
2702 let base_class = cpnt_type.Types.base_class in
2705 lazy (add_dimensions (evaluate base_class) rev_dims)
2707 let wrap_function_invocation' cpnt_type rev_dims =
2709 let exprs = expressions_of_named_arguments 1 input_types in
2710 FunctionInvocation exprs
2711 and elt_nat = Types.ComponentElement cpnt_type in
2714 resolved_expression syn nat elt_nat
2716 let cpnt_type' = add_dimensions cpnt_type in
2719 let arg = List.assoc id args in
2721 and expr = resolved_expression None nat elt_nat in
2722 VectorReduction (ranges, expr)
2723 and elt_nat = Types.ComponentElement cpnt_type' in
2724 resolved_expression None nat elt_nat in
2725 wrap_function_invocation' cpnt_type rev_dims in
2726 let component_type_of_output_types output_types =
2727 let component_type_of_output_type cpnt_type (_, elt_type) =
2728 let add_class_specifier cl_spec cl_spec' =
2729 match cl_spec, cl_spec' with
2730 | Types.TupleType [], _ -> cl_spec'
2731 | (Types.TupleType cl_specs), _ ->
2732 Types.TupleType (cl_spec' :: cl_specs)
2733 | _, _ -> Types.TupleType [cl_spec'; cl_spec] in
2734 let var = evaluate cpnt_type.Types.variability
2735 and cl_spec = evaluate cpnt_type.Types.base_class in
2736 let elt_type' = evaluate elt_type in
2737 match elt_type'.Types.element_nature with
2738 | Types.ComponentElement cpnt_type' ->
2739 let var' = evaluate cpnt_type'.Types.variability
2740 and cl_spec' = evaluate cpnt_type'.Types.base_class in
2742 Types.flow = lazy false;
2743 Types.variability = lazy (Types.max_variability var var');
2744 Types.causality = lazy Types.Acausal;
2745 Types.base_class = lazy (add_class_specifier cl_spec cl_spec')
2747 | Types.ClassElement _ | Types.ComponentTypeElement _ |
2748 Types.PredefinedTypeElement _ ->
2750 {err_msg = ["_ClassElemFoundInExpr"];
2752 err_ctx = ctx}) (*error*) in
2755 Types.flow = lazy false;
2756 Types.variability = lazy Types.Constant;
2757 Types.causality = lazy Types.Acausal;
2758 Types.base_class = lazy (Types.TupleType [])
2760 List.fold_left component_type_of_output_type cpnt_type output_types in
2761 let args' = sorted_arguments_of_named_arguments input_types
2762 and cpnt_type = component_type_of_output_types output_types in
2763 let func_invoc = wrap_function_invocation cpnt_type in
2764 let nat = FunctionCall (expr', args', func_invoc)
2765 and elt_nat = func_invoc.info.type_description in
2766 resolved_expression syn nat elt_nat in
2767 let resolve_function_arguments' fun_args =
2768 match fun_args.Syntax.nature with
2769 | Syntax.Reduction _ ->
2771 {err_msg = ["_NotYetImplemented"; "_FuncArgumentReduction"];
2774 | Syntax.ArgumentList args ->
2775 let input_types, output_types, named_args =
2776 resolve_function_argument_list ctx expr' named_elts args in
2778 reversed_additional_dimensions input_types named_args in
2779 function_call ids rev_dims input_types output_types named_args in
2782 let fun_args = { Syntax.nature = Syntax.ArgumentList [];
2783 Syntax.info = ctx.location } in
2784 resolve_function_arguments' fun_args
2785 | Some fun_args -> resolve_function_arguments' fun_args in
2786 let resolve_class_function_call cl_type =
2787 match evaluate cl_type.Types.kind with
2789 resolve_function_arguments cl_type.Types.named_elements
2790 | Types.Class | Types.Model | Types.Block | Types.Record |
2791 Types.ExpandableConnector | Types.Connector | Types.Package ->
2793 {err_msg = ["function"; "_ElemExpected"];
2795 err_ctx = ctx}) (*error*) in
2796 let resolve_function_call' cl_spec =
2797 match evaluate cl_spec with
2798 | Types.ClassType cl_type ->
2799 resolve_class_function_call cl_type
2802 {err_msg = ["function"; "_ElemExpected"];
2804 err_ctx = ctx}) (*error*) in
2805 match expr'.info.type_description with
2806 | Types.ClassElement cl_spec -> resolve_function_call' cl_spec
2807 | Types.ComponentElement cpnt_type ->
2808 let cl_spec = cpnt_type.Types.base_class in
2809 resolve_function_call' cl_spec
2810 | Types.ComponentTypeElement _ | Types.PredefinedTypeElement _ ->
2812 {err_msg = ["function"; "_ElemExpected"];
2814 err_ctx = ctx}) (*error*)
2816 and resolve_function_argument_list ctx expr' named_elts args =
2817 let rec class_kind ctx =
2818 let class_context' cl_spec = match cl_spec with
2819 | Types.ClassType cl_type ->
2820 Some (evaluate cl_type.Types.kind)
2822 match ctx.context_nature with
2823 | ClassContext cl_def ->
2824 class_context' (evaluate cl_def.class_type)
2825 | SubscriptContext (ctx, _, _, _) | ForContext (ctx, _, _) ->
2828 let add_function_inout_argument ((id, elt_type) as named_elt) inouts =
2829 let add_function_inout_argument' cpnt_type =
2830 match inouts, evaluate cpnt_type.Types.causality with
2831 | (ins, outs), Types.Input -> named_elt :: ins, outs
2832 | (ins, outs), Types.Output -> ins, named_elt :: outs
2833 | _, Types.Acausal -> inouts in
2834 let elt_type' = evaluate elt_type in
2835 match elt_type'.Types.element_nature with
2836 | Types.ComponentElement cpnt_type when not elt_type'.Types.protected ->
2837 add_function_inout_argument' cpnt_type
2839 let add_argument id arg arg' elt_type acc =
2840 let matchable_types cpnt_type cpnt_type' =
2841 let cl_spec = evaluate cpnt_type.Types.base_class
2842 and cl_spec' = evaluate cpnt_type'.Types.base_class in
2843 let rec matchable_types' cl_spec cl_spec' = match cl_spec, cl_spec' with
2844 | Types.ArrayType (dim, cl_spec), _ ->
2845 matchable_types' cl_spec cl_spec'
2846 | _, Types.ArrayType (dim', cl_spec') ->
2847 matchable_types' cl_spec cl_spec'
2849 let type_compare = Types.compare_specifiers cl_spec cl_spec' in
2850 (type_compare = Types.SameType) ||
2851 (type_compare = Types.Supertype) in
2852 matchable_types' cl_spec cl_spec' in
2853 let matchable_variabilities cpnt_type cpnt_type' =
2854 let var = evaluate cpnt_type.Types.variability
2855 and var' = evaluate cpnt_type'.Types.variability in
2856 Types.higher_variability var var' in
2857 let elt_type = evaluate elt_type in
2858 let cpnt_type = match elt_type.Types.element_nature with
2859 | Types.ComponentElement cpnt_type -> cpnt_type
2860 | _ -> assert false in
2861 let arg' = apply_rhs_coercions cpnt_type arg' in
2862 match arg'.info.type_description with
2863 | Types.ComponentElement cpnt_type'
2864 when not (matchable_types cpnt_type cpnt_type') ->
2866 {err_msg = ["_ArgTypeMismatch"];
2868 [("_ExpectedType", Types.string_of_component_type cpnt_type);
2869 ("_TypeFound", Types.string_of_component_type cpnt_type')];
2870 err_ctx = {ctx with location = arg.Syntax.info}}) (*error*)
2871 | Types.ComponentElement cpnt_type'
2872 when not (matchable_variabilities cpnt_type cpnt_type') ->
2873 let var = evaluate cpnt_type.Types.variability
2874 and var' = evaluate cpnt_type'.Types.variability in
2875 let var = Types.string_of_variability var
2876 and var' = Types.string_of_variability var' in
2878 {err_msg = ["_ArgVariabilityMismatch"];
2879 err_info = [("_ExpectedVariability", var);
2880 ("_VariabilityFound", var')];
2881 err_ctx = {ctx with location = arg.Syntax.info}}) (*error*)
2882 | Types.ComponentElement cpnt_type' -> (id, arg') :: acc
2883 | _ -> raise (CompilError
2884 {err_msg = ["_ClassElemFoundInExpr"];
2886 err_ctx = {ctx with location = arg.Syntax.info}}) (*error*) in
2887 let named_arguments_of_arguments input_types args =
2888 let rec add_positional_arguments acc input_types args =
2889 match input_types, args with
2893 {err_msg = ["_TooManyArgsInFuncCall"];
2895 err_ctx = ctx}) (*error*)
2898 {err_msg = ["_TooFewArgsInFuncCall"];
2900 err_ctx = ctx}) (*error*)
2901 | (id, elt_type) :: input_types,
2902 { Syntax.nature = Syntax.Argument arg } :: args ->
2903 let arg' = resolve_expression ctx arg in
2904 let acc = add_argument id arg arg' elt_type acc in
2905 add_positional_arguments acc input_types args
2906 | _, { Syntax.nature = Syntax.NamedArgument _ } :: _ ->
2907 add_named_arguments acc input_types args
2908 and add_named_arguments acc input_types args =
2909 match input_types, args with
2913 {err_msg = ["_TooManyArgsInFuncCall"];
2915 err_ctx = ctx}) (*error*)
2918 {err_msg = ["_TooFewArgsInFuncCall"];
2920 err_ctx = ctx}) (*error*)
2921 | _, { Syntax.nature = Syntax.Argument _ } :: _ ->
2923 {err_msg = ["_MixedPositAndNamedFuncArgPass"];
2925 err_ctx = ctx}) (*error*)
2926 | _, { Syntax.nature = Syntax.NamedArgument (id, _) } :: _
2927 when List.mem_assoc id acc ->
2929 {err_msg = ["_FuncCallWithDuplicateArg"; id];
2931 err_ctx = ctx}) (*error*)
2932 | _, { Syntax.nature = Syntax.NamedArgument (id, _) } :: _
2933 when not (List.mem_assoc id input_types) ->
2935 {err_msg = ["_NonInputFuncArgElem"; id];
2937 err_ctx = ctx}) (*error*)
2938 | _, { Syntax.nature = Syntax.NamedArgument (id, arg) } :: args ->
2939 let arg' = resolve_expression ctx arg
2940 and elt_type = List.assoc id input_types in
2941 let acc = add_argument id arg arg' elt_type acc in
2942 add_named_arguments acc input_types args in
2943 add_positional_arguments [] input_types args in
2944 let resolve_built_in_function_argument arg = match arg with
2945 | { Syntax.nature = Syntax.Argument arg } ->
2946 arg, (resolve_expression ctx arg)
2947 | { Syntax.nature = Syntax.NamedArgument _; Syntax.info = info } ->
2949 {err_msg = ["_CannotUseNamedArgWithBuiltInOper"];
2951 err_ctx = {ctx with location = info}}) (*error*) in
2952 let rec built_in_function_named_arguments acc input_types args' =
2953 match input_types, args' with
2957 {err_msg = ["_TooManyArgsInFuncCall"];
2959 err_ctx = ctx}) (*error*)
2962 {err_msg = ["_TooFewArgsInFuncCall"];
2964 err_ctx = ctx}) (*error*)
2965 | (id, elt_type) :: input_types, (arg, arg') :: args' ->
2966 let acc = add_argument id arg arg' elt_type acc in
2967 built_in_function_named_arguments acc input_types args' in
2968 let built_in_function_inout_types ctx id (in_types, out_types) args' =
2969 let argument_component_type (arg, arg') =
2970 match arg'.info.type_description with
2971 | Types.ComponentElement cpnt_type ->
2973 | _ -> raise (CompilError
2974 {err_msg = ["_ClassElemFoundInExpr"];
2976 err_ctx = {ctx with location = arg.Syntax.info}}) (*error*) in
2977 let scalar_base_class_specifier (arg, arg') =
2978 let rec scalar_base_class_specifier' cl_spec = match cl_spec with
2979 | Types.ArrayType (dim, cl_spec) -> scalar_base_class_specifier' cl_spec
2981 let cpnt_type = argument_component_type (arg, arg') in
2982 let cl_spec = evaluate cpnt_type.Types.base_class in
2983 scalar_base_class_specifier' cl_spec in
2984 let argument_base_type bt (arg, arg') =
2985 let cl_spec = scalar_base_class_specifier (arg, arg') in
2987 | Types.PredefinedType predef when predef.Types.base_type = bt -> true
2989 let argument_base_types bt args =
2990 List.for_all (argument_base_type bt) args in
2991 let argument_variability var (arg, arg') =
2992 let cpnt_type = argument_component_type (arg, arg') in
2993 let var' = evaluate cpnt_type.Types.variability in
2995 let neg f = function x -> not (f x) in
2997 let cpnt_type = component_type_of_expression ctx arg' in
2998 let rec ndims' cl_spec =
3000 | Types.ArrayType (dim, cl_spec) -> ndims' cl_spec + 1
3002 ndims' (evaluate cpnt_type.Types.base_class) in
3003 let numeric_base_type arg' =
3004 let cl_spec = scalar_class_specifier ctx arg' in
3005 (Types.compare_specifiers Types.integer_class_type cl_spec =
3007 (Types.compare_specifiers Types.real_class_type cl_spec =
3009 let rec argument_types i args = match args with
3011 | (arg, arg') :: args ->
3012 let cpnt_type = component_type_of_expression ctx arg'
3013 and name = Printf.sprintf "@%d" i in
3014 (name, cpnt_type) :: (argument_types (i + 1) args) in
3015 let element_types input_types output_types =
3016 let element_type inout (id, cpnt_type) =
3020 Types.protected = false;
3022 Types.replaceable = false;
3023 Types.dynamic_scope = None;
3024 Types.element_nature =
3025 Types.ComponentElement
3026 { cpnt_type with Types.causality = lazy inout }
3028 (List.map (element_type Types.Input) input_types),
3029 (List.map (element_type Types.Output) output_types) in
3030 match id, args' with
3031 | ("der" | "initial" | "terminal" | "sample" | "pre" | "edge" | "change" |
3032 "reinit" | "delay"), _ when (class_kind ctx) = Some Types.Function ->
3034 {err_msg = [id; "_OperCannotBeUsedWithinFuncDef"];
3036 err_ctx = ctx}) (*error*)
3037 | ("pre" | "edge" | "change"), [arg, arg'] | "reinit", [(arg, arg'); _]
3038 when not (expression_of_variable arg) ->
3040 {err_msg = [id; "_OperArgMustBeAVar"];
3042 err_ctx = {ctx with location = arg.Syntax.info}}) (*error*)
3043 | ("ceil" | "floor" | "integer" | "der"), [arg, arg'] |
3044 "reinit", [(arg, arg'); _] |
3045 "smooth", [_; (arg, arg')]
3046 when not (argument_base_type Types.RealType (arg, arg')) ->
3047 let cl_spec = scalar_base_class_specifier (arg, arg') in
3049 {err_msg = ["_ArgTypeMismatch"];
3051 [("_ExpectedType", "Real");
3052 ("_TypeFound", Types.string_of_class_specifier cl_spec)];
3053 err_ctx = {ctx with location = arg.Syntax.info}}) (*error*)
3055 when not (List.for_all (argument_base_type Types.RealType) args') ->
3057 List.find (neg (argument_base_type Types.RealType)) args' in
3058 let cl_spec = scalar_base_class_specifier (arg, arg') in
3060 {err_msg = ["_ArgTypeMismatch"];
3062 [("_ExpectedType", "Real");
3063 ("_TypeFound", Types.string_of_class_specifier cl_spec)];
3064 err_ctx = {ctx with location = arg.Syntax.info}}) (*error*)
3065 | "der", [arg, arg']
3066 when not (argument_variability Types.Continuous (arg, arg')) ->
3067 let cpnt_type = argument_component_type (arg, arg') in
3068 let var = evaluate cpnt_type.Types.variability in
3069 let var = Types.string_of_variability var in
3071 {err_msg = ["_ArgVariabilityMismatch"];
3072 err_info = [("_ExpectedVariability", "Continuous");
3073 ("_VariabilityFound", var)];
3074 err_ctx = {ctx with location = arg.Syntax.info}}) (*error*)
3075 | "delay", _ when List.length args' = 3 ->
3077 [("@1", Types.real_component_type Types.Continuous);
3078 ("@2", Types.real_component_type Types.Continuous);
3079 ("@3", Types.real_component_type Types.Parameter)]
3081 ["@4", Types.real_component_type Types.Continuous] in
3082 element_types input_types output_types
3083 | "abs", [arg, arg']
3084 when argument_base_type Types.IntegerType (arg, arg') ->
3085 let input_types = ["@1", Types.integer_component_type Types.Discrete]
3087 ["@2", Types.integer_component_type Types.Discrete] in
3088 element_types input_types output_types
3089 | ("ones" | "zeros"), _
3090 when not (argument_base_types Types.IntegerType args') ->
3092 List.find (neg (argument_base_type Types.IntegerType)) args' in
3094 {err_msg = ["_ArgTypeMismatch"];
3096 err_ctx = {ctx with location = arg.Syntax.info}}) (*error*)
3097 | "fill", _ :: args'
3098 when not (argument_base_types Types.IntegerType args') ->
3100 List.find (neg (argument_base_type Types.IntegerType)) args' in
3102 {err_msg = ["_ArgTypeMismatch"];
3104 err_ctx = {ctx with location = arg.Syntax.info}}) (*error*)
3105 | ("sum" | "product" | "max" | "min" | "scalar"), [arg, arg']
3106 when ndims arg' = 0 ->
3108 {err_msg = ["_ArgTypeMismatch"];
3110 err_ctx = {ctx with location = arg.Syntax.info}}) (*error*)
3111 | "diagonal", [arg, arg']
3112 when ndims arg' <> 1 ->
3114 {err_msg = ["_ArgTypeMismatch"];
3116 err_ctx = {ctx with location = arg.Syntax.info}}) (*error*)
3117 | ("scalar"), [arg, arg'] ->
3118 let cpnt_type = component_type_of_expression ctx arg' in
3119 let input_types = ["@1", cpnt_type]
3121 ["@2", Types.scalar_component_type cpnt_type ] in
3122 element_types input_types output_types
3123 | ("sum" | "product" | "max" | "min" | "diagonal"), [arg, arg']
3124 when not (numeric_base_type arg') ->
3126 {err_msg = ["_ArgTypeMismatch"];
3128 err_ctx = {ctx with location = arg.Syntax.info}}) (*error*)
3129 | ("sum" | "product" | "max" | "min"), [arg, arg'] ->
3130 let cpnt_type = component_type_of_expression ctx arg' in
3131 let input_types = ["@1", cpnt_type]
3133 ["@2", Types.scalar_component_type cpnt_type ] in
3134 element_types input_types output_types
3135 | ("ones" | "zeros"), _ :: _ ->
3136 let input_types = argument_types 1 args'
3138 let n = List.length args'
3140 List.map (function _ -> Types.ParameterDimension) args' in
3143 Types.flow = lazy false;
3144 variability = lazy Types.Parameter;
3145 Types.causality = lazy Types.Acausal;
3147 lazy(Types.add_dimensions dims Types.integer_class_type)
3149 [ Printf.sprintf "@%d" (n + 1), cpnt_type ] in
3150 element_types input_types output_types
3151 | "fill", (arg, arg') :: (_ :: _ as args) ->
3152 let input_types = argument_types 1 args'
3154 let n = List.length args
3156 List.map (function _ -> Types.ParameterDimension) args in
3157 let cpnt_type = component_type_of_expression ctx arg' in
3159 (Types.add_dimensions
3161 (evaluate cpnt_type.Types.base_class)) in
3163 Printf.sprintf "@%d" (n + 1),
3164 { cpnt_type with Types.base_class = lcl_spec }
3166 element_types input_types output_types
3167 | "diagonal", [ arg, arg' ] ->
3168 let cpnt_type = component_type_of_expression ctx arg' in
3169 let input_types = [ "@1", cpnt_type ]
3171 let dims = [ Types.ParameterDimension ] in
3173 (Types.add_dimensions
3175 (evaluate cpnt_type.Types.base_class)) in
3176 [ "@2", { cpnt_type with Types.base_class = lcl_spec } ] in
3177 element_types input_types output_types
3178 | ("div" | "mod" | "rem" | "max" | "min"), _
3179 when List.for_all (argument_base_type Types.IntegerType) args' ->
3182 "@1", Types.integer_component_type Types.Discrete;
3183 "@2", Types.integer_component_type Types.Discrete
3186 ["@3", Types.integer_component_type Types.Discrete] in
3187 element_types input_types output_types
3188 | ("pre" | "change"), [arg, arg'] ->
3189 let cpnt_type = argument_component_type (arg, arg') in
3191 ["@1", { cpnt_type with Types.variability = lazy Types.Continuous }]
3193 ["@2", { cpnt_type with Types.variability = lazy Types.Discrete }] in
3194 element_types input_types output_types
3195 | _, _ -> in_types, out_types in
3196 match expr'.nature with
3197 | PredefinedIdentifier id ->
3198 let args' = List.map resolve_built_in_function_argument args in
3199 let input_types, output_types =
3201 List.fold_right add_function_inout_argument named_elts ([], []) in
3202 built_in_function_inout_types ctx id inout_types args' in
3204 built_in_function_named_arguments [] input_types args' in
3205 input_types, output_types, named_args
3207 let input_types, output_types =
3208 List.fold_right add_function_inout_argument named_elts ([], []) in
3209 let named_args = named_arguments_of_arguments input_types args in
3210 input_types, output_types, named_args
3212 and resolve_identifier ctx expr id =
3213 let rec resolve_predefined_identifier ctx expr id = match id with
3215 let nat = PredefinedIdentifier "Boolean"
3216 and elt_nat = Types.ClassElement (lazy (Types.boolean_class_type)) in
3217 resolved_expression (Some expr) nat elt_nat
3219 let nat = PredefinedIdentifier "Integer"
3220 and elt_nat = Types.ClassElement (lazy (Types.integer_class_type)) in
3221 resolved_expression (Some expr) nat elt_nat
3223 let nat = PredefinedIdentifier "Real"
3224 and elt_nat = Types.ClassElement (lazy (Types.real_class_type)) in
3225 resolved_expression (Some expr) nat elt_nat
3227 let nat = PredefinedIdentifier "String"
3228 and elt_nat = Types.ClassElement (lazy (Types.string_class_type)) in
3229 resolved_expression (Some expr) nat elt_nat
3231 let nat = PredefinedIdentifier "reinit"
3234 ["@1", Types.real_component_type Types.Continuous;
3235 "@2", Types.real_component_type Types.Continuous]
3237 Types.function_type inputs outputs in
3238 resolved_expression (Some expr) nat elt_nat
3240 let nat = PredefinedIdentifier "time"
3241 and elt_nat = Types.real_type Types.Continuous in
3242 resolved_expression (Some expr) nat elt_nat
3243 | "pre" | "change" ->
3244 let nat = PredefinedIdentifier "pre"
3246 let inputs = ["@1", Types.real_component_type Types.Continuous]
3247 and outputs = ["@2", Types.real_component_type Types.Discrete] in
3248 Types.function_type inputs outputs in
3249 resolved_expression (Some expr) nat elt_nat
3251 let nat = PredefinedIdentifier "edge"
3253 let inputs = ["@1", Types.boolean_component_type Types.Discrete]
3254 and outputs = ["@2", Types.boolean_component_type Types.Discrete] in
3255 Types.function_type inputs outputs in
3256 resolved_expression (Some expr) nat elt_nat
3258 let nat = PredefinedIdentifier "initial"
3262 Types.function_type inputs outputs in
3263 resolved_expression (Some expr) nat elt_nat
3265 let nat = PredefinedIdentifier "terminal"
3269 Types.function_type inputs outputs in
3270 resolved_expression (Some expr) nat elt_nat
3272 let nat = PredefinedIdentifier "sample"
3274 let inputs = [("@1", Types.real_component_type Types.Parameter);
3275 ("@2", Types.real_component_type Types.Parameter)]
3276 and outputs = ["@3", Types.boolean_component_type Types.Parameter] in
3277 Types.function_type inputs outputs in
3278 resolved_expression (Some expr) nat elt_nat
3280 let nat = PredefinedIdentifier "delay"
3282 let inputs = [("@1", Types.real_component_type Types.Continuous);
3283 ("@2", Types.real_component_type Types.Parameter)]
3284 and outputs = ["@3", Types.real_component_type Types.Continuous] in
3285 Types.function_type inputs outputs in
3286 resolved_expression (Some expr) nat elt_nat
3288 let nat = PredefinedIdentifier "assert"
3290 let inputs = [("@1", Types.boolean_component_type Types.Discrete);
3291 ("@2", Types.string_component_type Types.Discrete)]
3293 Types.function_type inputs outputs in
3294 resolved_expression (Some expr) nat elt_nat
3296 let nat = PredefinedIdentifier "terminate"
3298 let inputs = [("@1", Types.string_component_type Types.Discrete)]
3300 Types.function_type inputs outputs in
3301 resolved_expression (Some expr) nat elt_nat
3302 | "abs" | "cos" | "sin" | "tan" | "exp" | "log" | "sqrt" |
3303 "asin" | "acos" | "atan" | "sinh" | "cosh" | "tanh" | "asinh" |
3304 "acosh" | "atanh" | "log10" | "ceil" | "floor" | "der" ->
3305 let nat = PredefinedIdentifier id
3307 let inputs = ["@1", Types.real_component_type Types.Continuous]
3308 and outputs = ["@2", Types.real_component_type Types.Continuous] in
3309 Types.function_type inputs outputs in
3310 resolved_expression (Some expr) nat elt_nat
3311 | "sign" | "integer" | "ones" | "zeros" ->
3312 let nat = PredefinedIdentifier id
3314 let inputs = ["@1", Types.real_component_type Types.Continuous]
3315 and outputs = ["@2", Types.integer_component_type Types.Discrete] in
3316 Types.function_type inputs outputs in
3317 resolved_expression (Some expr) nat elt_nat
3318 | "max" | "min" | "div" | "mod" | "rem" | "fill" ->
3319 let nat = PredefinedIdentifier id
3323 "@1", Types.real_component_type Types.Continuous;
3324 "@2", Types.real_component_type Types.Continuous
3326 and outputs = ["@3", Types.real_component_type Types.Continuous] in
3327 Types.function_type inputs outputs in
3328 resolved_expression (Some expr) nat elt_nat
3330 let nat = PredefinedIdentifier id
3334 "@1", Types.integer_component_type Types.Discrete;
3335 "@2", Types.real_component_type Types.Continuous
3337 and outputs = ["@3", Types.real_component_type Types.Continuous] in
3338 Types.function_type inputs outputs in
3339 resolved_expression (Some expr) nat elt_nat
3341 let nat = PredefinedIdentifier id
3343 let inputs = [ "@1", Types.integer_component_type Types.Parameter ]
3346 [Types.ParameterDimension; Types.ParameterDimension] in
3349 Types.integer_array_component_type Types.Parameter dims
3351 Types.function_type inputs outputs in
3352 resolved_expression (Some expr) nat elt_nat
3354 let nat = PredefinedIdentifier id
3357 let dim = [ Types.ParameterDimension ] in
3358 [ "@1", Types.integer_array_component_type Types.Parameter dim ]
3361 [Types.ParameterDimension; Types.ParameterDimension] in
3364 Types.integer_array_component_type Types.Parameter dims
3366 Types.function_type inputs outputs in
3367 resolved_expression (Some expr) nat elt_nat
3368 | "sum" | "product" | "scalar" ->
3369 let nat = PredefinedIdentifier id
3372 let dim = [ Types.DiscreteDimension ] in
3373 [ "@1", Types.integer_array_component_type Types.Discrete dim ]
3374 and outputs = ["@2", Types.integer_component_type Types.Discrete] in
3375 Types.function_type inputs outputs in
3376 resolved_expression (Some expr) nat elt_nat
3377 | _ -> raise (CompilError
3378 {err_msg = ["_UnknownIdentifier"; id];
3381 and search_in_toplevel dic =
3383 let elt_desc = List.assoc id (evaluate dic) in
3384 let elt_type = evaluate elt_desc.element_type in
3385 match elt_type.Types.dynamic_scope with
3386 | None | Some Types.Inner ->
3387 let nat = ToplevelIdentifier id in
3388 resolved_expression (Some expr) nat elt_type.Types.element_nature
3389 | Some Types.Outer | Some Types.InnerOuter ->
3391 {err_msg = ["_NoInnerDeclForOuterElem"; id];
3393 err_ctx = ctx}) (*error*)
3394 with Not_found -> resolve_predefined_identifier ctx expr id
3395 and search_in_class level cl_def = match evaluate cl_def.class_type with
3396 | Types.ClassType cl_type -> search_in_class_type level cl_def cl_type
3397 | Types.PredefinedType _ | Types.ComponentType _ | Types.ArrayType _ |
3398 Types.TupleType _ ->
3400 {err_msg = ["_NoInnerDeclForOuterElem"; id];
3402 err_ctx = ctx}) (*error*)
3403 and search_in_class_type level cl_def cl_type =
3405 let elt_type = evaluate (List.assoc id cl_type.Types.named_elements) in
3406 match elt_type.Types.dynamic_scope with
3407 | None | Some Types.Inner ->
3408 let nat = LocalIdentifier (level, id) in
3409 resolved_expression (Some expr) nat elt_type.Types.element_nature
3410 | Some Types.Outer | Some Types.InnerOuter ->
3411 let nat = DynamicIdentifier (level, id) in
3412 resolved_expression (Some expr) nat elt_type.Types.element_nature
3413 with Not_found -> search_in_parent level cl_def
3414 and search_in_parent level cl_def = match cl_def.enclosing_class with
3415 | _ when cl_def.encapsulated -> search_in_toplevel ctx.toplevel
3416 | Some cl_def -> search_in_class (level + 1) cl_def
3417 | None -> search_in_toplevel ctx.toplevel
3418 and search_in_for_loop_variables level ctx = match ctx.context_nature with
3419 | ToplevelContext -> search_in_toplevel ctx.toplevel
3420 | ClassContext cl_def -> search_in_class 0 cl_def
3421 | SubscriptContext (ctx', _, _, _) ->
3422 search_in_for_loop_variables level ctx'
3423 | ForContext (_, id', elt_nat) when id' = id ->
3424 let nat = LoopVariable level in
3425 resolved_expression (Some expr) nat elt_nat
3426 | ForContext (ctx', _, _) ->
3427 search_in_for_loop_variables (level + 1) ctx' in
3428 search_in_for_loop_variables 0 ctx
3430 (*and resolve_if ctx expr alts expr' =
3431 let expres' = resolve_expression ctx expr' in
3432 let elt_nat' = expres'.info.type_description in
3433 let rec resolve_alternative (cond, expr) =
3434 resolve_condition cond,
3435 resolve_alternative_expression expr
3436 and resolve_condition cond =
3437 let ctx = {ctx with location = cond.Syntax.info} in
3438 let cond' = resolve_expression ctx cond in
3439 let condition cpnt_type =
3440 let cl_spec = evaluate cpnt_type.Types.base_class in
3442 | Types.PredefinedType { Types.base_type = Types.BooleanType } -> cond'
3443 | Types.PredefinedType _ | Types.ClassType _ | Types.ComponentType _ |
3444 Types.ArrayType _ | Types.TupleType _ ->
3446 {err_msg = ["_NonBooleanIfCondExpr"];
3448 [("_ExprKind", "...if A then...");
3449 ("_TypeOfA", Types.string_of_class_specifier cl_spec)];
3450 err_ctx = ctx}) (*error*) in
3451 match cond'.info.type_description with
3452 | Types.ComponentElement cpnt_type -> condition cpnt_type
3453 | _ -> raise (CompilError
3454 {err_msg = ["_ClassElemFoundInExpr"];
3456 err_ctx = {ctx with location = cond.Syntax.info}}) (*error*)
3457 and resolve_alternative_expression expr =
3458 let ctx = {ctx with location = expr.Syntax.info} in
3459 let expres = resolve_expression ctx expr in
3460 let elt_nat = expres.info.type_description in
3461 let display_error elt_nat elt_nat' = match elt_nat, elt_nat' with
3462 | Types.ComponentElement cpnt_type, Types.ComponentElement cpnt_type' ->
3464 {err_msg = ["_TypeConflictsInIfAlternExprs"];
3466 [("_TypeOfThenBranche",
3467 Types.string_of_component_type cpnt_type);
3468 ("_TypeOfElseBranche",
3469 Types.string_of_component_type cpnt_type')];
3470 err_ctx = ctx}) (*error*)
3471 | Types.ComponentElement cpnt_type, _ ->
3473 {err_msg = ["_ClassElemFoundInExpr"];
3475 [("_TypeOfThenBranche",
3476 Types.string_of_component_type cpnt_type);
3477 ("_TypeOfElseBranche", "_ClassElement")];
3478 err_ctx = ctx}) (*error*)
3479 | _, Types.ComponentElement cpnt_type' ->
3481 {err_msg = ["_ClassElemFoundInExpr"];
3483 [("_TypeOfThenBranche", "_ClassElement");
3484 ("_TypeOfElseBranche",
3485 Types.string_of_component_type cpnt_type')];
3486 err_ctx = ctx}) (*error*)
3489 {err_msg = ["_ClassElemFoundInExpr"];
3491 [("_TypeOfThenBranche", "_ClassElement");
3492 ("_TypeOfElseBranche", "_ClassElement")];
3493 err_ctx = ctx}) (*error*) in
3494 match Types.compare_element_natures elt_nat elt_nat' with
3495 | Types.NotRelated -> display_error elt_nat elt_nat'
3497 let alts = List.map resolve_alternative alts in
3498 let nat = If (alts, expres') in
3499 resolved_expression (Some expr) nat elt_nat'*)
3501 and resolve_if ctx expr alts expr' =
3502 let resolve_data_expression ctx expr =
3503 let expr' = resolve_expression ctx expr in
3504 match expr'.info.type_description with
3505 | Types.ComponentElement cpnt_type -> expr'
3508 {err_msg = ["_ClassElemFoundInExpr"];
3510 err_ctx = {ctx with location = expr.Syntax.info}}) (*error*) in
3511 let resolve_condition cond =
3512 let ctx = {ctx with location = cond.Syntax.info} in
3513 let cond' = resolve_data_expression ctx cond in
3514 let condition cpnt_type =
3515 match evaluate cpnt_type.Types.base_class with
3516 | Types.PredefinedType { Types.base_type = Types.BooleanType } -> cond'
3519 {err_msg = ["_NonBooleanIfCondExpr"];
3521 [("_ExprKind", "...if A then...");
3522 ("_TypeOfA", Types.string_of_class_specifier cl_spec)];
3523 err_ctx = ctx}) (*error*) in
3524 match cond'.info.type_description with
3525 | Types.ComponentElement cpnt_type -> condition cpnt_type
3528 {err_msg = ["_DataElemExpected"];
3530 err_ctx = ctx}) (*error*) in
3531 let resolve_alternatives (alts, expr') (cond, expr) =
3532 let ctx = {ctx with location = expr.Syntax.info} in
3533 let cond' = resolve_condition cond
3534 and expr = resolve_data_expression ctx expr in
3535 let exprs = apply_binary_coercions [ expr'; expr] in
3536 let expr' = List.nth exprs 0
3537 and expr = List.nth exprs 1 in
3538 let elt_nat = expr.info.type_description
3539 and elt_nat' = expr'.info.type_description in
3540 match Types.compare_element_natures elt_nat elt_nat' with
3542 (alts @ [cond', expr]), expr'
3545 {err_msg = ["_TypeConflictsInIfAlternExprs"];
3547 [("_TypeOfThenBranche",
3548 Types.string_of_element_nature elt_nat);
3549 ("_TypeOfElseBranche",
3550 Types.string_of_element_nature elt_nat')];
3551 err_ctx = ctx}) (*error*) in
3552 let expr' = resolve_data_expression ctx expr' in
3553 let alts, expr' = List.fold_left resolve_alternatives ([], expr') alts in
3554 let nat = If (alts, expr') in
3555 resolved_expression (Some expr) nat expr'.info.type_description
3557 and resolve_indexed_access ctx expr expr' subs =
3558 let expres' = resolve_expression ctx expr' in
3559 let rec resolve_component_indexed_access cl_spec subs =
3560 match cl_spec, subs with
3561 | (Types.PredefinedType _ | Types.ClassType _ | Types.ComponentType _ |
3562 Types.ArrayType _ | Types.TupleType _), [] -> cl_spec
3563 | (Types.PredefinedType _ | Types.ClassType _ | Types.ComponentType _ |
3564 Types.TupleType _), _ :: _ ->
3566 {err_msg = ["_CannotSubscriptANonArrayTypeElem"];
3568 [("_ExpectedType", "_ArrayType");
3569 ("_TypeFound", Types.string_of_class_specifier cl_spec)];
3570 err_ctx = ctx}) (*error*)
3571 | Types.ArrayType (_, cl_spec'), sub :: subs' ->
3572 let cl_spec' = resolve_component_indexed_access cl_spec' subs' in
3573 subarray_access sub cl_spec'
3574 and subarray_access sub cl_spec =
3575 let subarray_access' = function
3576 | Types.PredefinedType { Types.base_type = Types.IntegerType } -> cl_spec
3578 (dim, Types.PredefinedType { Types.base_type = Types.IntegerType }) ->
3579 Types.ArrayType (dim, cl_spec)
3580 | Types.PredefinedType _ | Types.ClassType _ | Types.ComponentType _ |
3581 Types.ArrayType _ | Types.TupleType _ -> assert false (*error*) in
3582 match sub.info.type_description with
3583 | Types.ComponentElement cpnt_type ->
3584 let cl_spec' = evaluate cpnt_type.Types.base_class in
3585 subarray_access' cl_spec'
3586 | Types.ClassElement _ | Types.ComponentTypeElement _ |
3587 Types.PredefinedTypeElement _ -> assert false (*error*) in
3588 match expres'.info.type_description with
3589 | Types.ComponentElement cpnt_type ->
3590 let cl_spec = evaluate cpnt_type.Types.base_class in
3591 let subs' = resolve_subscripts ctx expres' cl_spec subs in
3595 lazy (resolve_component_indexed_access cl_spec subs')
3600 type_description = Types.ComponentElement cpnt_type'
3602 { nature = IndexedAccess (expres', subs'); info = info }
3603 | Types.ClassElement _ | Types.ComponentTypeElement _ |
3604 Types.PredefinedTypeElement _ ->
3606 {err_msg = ["_ClassElemFoundInExpr"];
3608 err_ctx = ctx}) (*error*)
3610 and resolve_integer ctx expr s =
3613 Integer (Int32.of_string s)
3617 {err_msg = ["_InvalidInteger"; s];
3620 resolved_expression (Some expr) nat (Types.integer_type Types.Constant)
3622 and resolve_matrix_construction ctx expr exprss =
3624 {err_msg = ["_NotYetImplemented"; "_MatrixExpr"];
3628 and resolve_no_event ctx expr expr' =
3629 let expr' = resolve_expression ctx expr' in
3630 match expr'.info.type_description with
3631 | Types.ComponentElement cpnt_type ->
3632 let nat = NoEvent expr'
3633 and flow = lazy (evaluate cpnt_type.Types.flow)
3634 and var = lazy Types.Continuous
3635 and inout = cpnt_type.Types.causality
3636 and cl_spec = cpnt_type.Types.base_class in
3638 component_element flow var inout cl_spec in
3639 let elt_nat = Types.ComponentElement cpnt_type in
3640 resolved_expression (Some expr) nat elt_nat
3643 {err_msg = ["_ClassElemFoundInExpr"];
3645 err_ctx = ctx}) (*error*)
3647 and resolve_range ctx expr start step stop =
3648 let integer_range var start' step' stop' =
3649 let integer_range' =
3650 match start'.nature, step'.nature, stop'.nature with
3651 | _, _, _ when Types.higher_variability var Types.Discrete ->
3652 let var = Types.string_of_variability var in
3654 {err_msg = ["_InvalidVarOfRangeExpr"];
3655 err_info = [("_Expr", Syntax.string_of_range start step stop);
3656 ("_ExpectedVariability", "parameter");
3657 ("_VariabilityFound", var)];
3659 | Integer i, Integer p, Integer j when p = Int32.zero ->
3661 {err_msg = ["_RangeStepValueCannotBeNull"];
3662 err_info = [("_Expr", Syntax.string_of_range start step stop)];
3664 | Integer i, Integer p, Integer j ->
3665 let dim = Int32.div (Int32.succ (Int32.sub j i)) p in
3666 Types.integer_array_type var (Types.ConstantDimension dim)
3667 | (Integer _ | DynamicIdentifier _ | LocalIdentifier _ |
3668 LoopVariable _ | PredefinedIdentifier _ | ToplevelIdentifier _),
3669 (Integer _ | DynamicIdentifier _ | LocalIdentifier _ |
3670 LoopVariable _ | PredefinedIdentifier _ | ToplevelIdentifier _),
3671 (Integer _ | DynamicIdentifier _ | LocalIdentifier _ |
3672 LoopVariable _ | PredefinedIdentifier _ | ToplevelIdentifier _) ->
3673 Types.integer_array_type var Types.ParameterDimension
3676 {err_msg = ["_NotYetImplemented"; "_NonIntegerRangeExpr"];
3677 err_info = [("_Expr", Syntax.string_of_range start step stop)];
3679 let nat = Range (start', step', stop') in
3680 let elt_nat = integer_range' in
3681 resolved_expression (Some expr) nat elt_nat in
3682 let start' = resolve_expression ctx start
3683 and step' = match step with
3685 | Some expr -> resolve_expression ctx expr
3686 and stop' = resolve_expression ctx stop in
3687 let resolve_range' var start_cl_spec step_cl_spec stop_cl_spec =
3688 match start_cl_spec, step_cl_spec, stop_cl_spec with
3689 | Types.PredefinedType { Types.base_type = Types.IntegerType },
3690 Types.PredefinedType { Types.base_type = Types.IntegerType },
3691 Types.PredefinedType { Types.base_type = Types.IntegerType } ->
3692 integer_range var start' step' stop'
3693 (*| Types.PredefinedType { Types.base_type = Types.IntegerType },
3694 Types.PredefinedType { Types.base_type = Types.IntegerType },
3696 | _ -> raise (CompilError
3697 {err_msg = ["_NotYetImplemented"; "_NonIntegerRangeExpr"];
3698 err_info = [("_Expr", Syntax.string_of_range start step stop)];
3700 let start_elt_nat = start'.info.type_description
3701 and step_elt_nat = step'.info.type_description
3702 and stop_elt_nat = stop'.info.type_description in
3703 match start_elt_nat, step_elt_nat, stop_elt_nat with
3704 | Types.ComponentElement start_cpnt_type,
3705 Types.ComponentElement step_cpnt_type,
3706 Types.ComponentElement stop_cpnt_type ->
3707 let start_cl_spec = evaluate start_cpnt_type.Types.base_class
3708 and step_cl_spec = evaluate step_cpnt_type.Types.base_class
3709 and stop_cl_spec = evaluate stop_cpnt_type.Types.base_class
3710 and start_var = evaluate start_cpnt_type.Types.variability
3711 and step_var = evaluate step_cpnt_type.Types.variability
3712 and stop_var = evaluate stop_cpnt_type.Types.variability in
3714 let var' = Types.max_variability step_var stop_var in
3715 Types.max_variability start_var var' in
3716 resolve_range' var start_cl_spec step_cl_spec stop_cl_spec
3717 | _ -> raise (CompilError
3718 {err_msg = ["_InvalidTypeInRangeExpr"];
3719 err_info = [("_Expr", Syntax.string_of_range start step stop)];
3720 err_ctx = ctx}) (*error*)
3722 and resolve_real ctx expr s =
3723 let nat = Real (float_of_string s) in
3724 resolved_expression (Some expr) nat (Types.real_type Types.Constant)
3726 and resolve_string ctx expr s =
3727 resolved_expression (Some expr) (String s) (Types.string_type Types.Constant)
3729 and resolve_true ctx expr =
3730 resolved_expression (Some expr) True (Types.boolean_type Types.Constant)
3732 and resolve_tuple ctx expr exprs =
3733 let max_element_variability var expr expr' =
3734 match expr'.info.type_description with
3735 | Types.ComponentElement cpnt_type ->
3736 let var' = evaluate cpnt_type.Types.variability in
3737 Types.max_variability var var'
3738 | Types.ClassElement _ | Types.ComponentTypeElement _ |
3739 Types.PredefinedTypeElement _ ->
3741 {err_msg = ["_ClassElemFoundInExpr"];
3743 err_ctx = ctx}) (*error*)
3744 and class_specifier expr expr' =
3745 match expr'.info.type_description with
3746 | Types.ComponentElement cpnt_type -> evaluate cpnt_type.Types.base_class
3747 | Types.ClassElement _ | Types.ComponentTypeElement _ |
3748 Types.PredefinedTypeElement _ ->
3750 {err_msg = ["_ClassElemFoundInExpr"];
3752 err_ctx = ctx}) (*error*) in
3753 let exprs' = List.map (resolve_expression ctx) exprs in
3754 let flow = lazy false
3756 lazy (List.fold_left2 max_element_variability Types.Constant exprs exprs')
3757 and inout = lazy Types.Acausal
3758 and cl_spec = lazy (Types.TupleType (List.map2 class_specifier exprs exprs')) in
3760 nature = Tuple exprs';
3765 Types.ComponentElement (component_element flow var inout cl_spec)
3769 and resolve_unuary_operation ctx expr kind arg =
3770 let arg' = resolve_expression ctx arg in
3771 match kind.Syntax.nature with
3772 | Syntax.UnaryMinus -> resolve_unary_minus ctx expr arg'
3773 | Syntax.Not -> resolve_not ctx expr arg'
3774 | Syntax.UnaryPlus ->
3776 {err_msg = ["_NotYetImplemented"; "_UnaryOperPLUS"];
3780 and resolve_vector ctx expr vec_elts = match vec_elts.Syntax.nature with
3781 | Syntax.VectorReduction (expr', for_inds) ->
3782 resolve_vector_reduction ctx expr expr' for_inds
3783 | Syntax.VectorElements exprs -> resolve_vector_elements ctx expr exprs
3785 and resolve_vector_reduction ctx expr expr' for_inds =
3786 let vector_reduction_type acc expr expr' =
3787 let add_dimension elt_nat cl_spec =
3788 let add_dimension' cl_spec' = match cl_spec' with
3789 | Types.ArrayType (dim, _) -> Types.ArrayType (dim, cl_spec)
3790 | Types.PredefinedType _ | Types.ClassType _ |
3791 Types.ComponentType _ | Types.TupleType _ ->
3793 {err_msg = ["_InvalidTypeInRangeExpr"];
3795 [("_ExpectedType", "_ArrayType");
3797 Types.string_of_class_specifier cl_spec')];
3798 err_ctx = ctx}) (*error*) in
3800 | Types.ComponentElement cpnt_type ->
3801 let cl_spec' = evaluate cpnt_type.Types.base_class in
3802 add_dimension' cl_spec'
3803 | Types.ClassElement _ | Types.ComponentTypeElement _ |
3804 Types.PredefinedTypeElement _ ->
3806 {err_msg = ["_ClassElemFoundInExpr"];
3808 err_ctx = ctx}) (*error*) in
3809 let rec vector_reduction_type' acc cl_spec = match acc with
3812 let elt_nat = range.info.type_description in
3813 let cl_spec' = add_dimension elt_nat cl_spec in
3814 vector_reduction_type' acc cl_spec' in
3815 match expr'.info.type_description with
3816 | Types.ComponentElement cpnt_type ->
3817 let cl_spec = evaluate cpnt_type.Types.base_class in
3820 Types.base_class = lazy (vector_reduction_type' acc cl_spec)
3822 Types.ComponentElement cpnt_type'
3823 | Types.ClassElement _ | Types.ComponentTypeElement _ |
3824 Types.PredefinedTypeElement _ ->
3826 {err_msg = ["_ClassElemFoundInExpr"];
3828 err_ctx = ctx}) (*error*)
3829 and range_element_type range range' =
3830 let sub_dimension cl_spec = match cl_spec with
3831 | Types.ArrayType (dim, cl_spec) -> cl_spec
3832 | Types.PredefinedType _ | Types.ClassType _ |
3833 Types.ComponentType _ | Types.TupleType _ ->
3835 {err_msg = ["_InvalidTypeInRangeExpr"];
3837 [("_ExpectedType", "_ArrayType");
3838 ("_TypeFound", Types.string_of_class_specifier cl_spec)];
3839 err_ctx = ctx}) (*error*) in
3840 match range'.info.type_description with
3841 | Types.ComponentElement cpnt_type ->
3842 let cl_spec = evaluate cpnt_type.Types.base_class in
3845 Types.base_class = lazy (sub_dimension cl_spec)
3847 Types.ComponentElement cpnt_type'
3848 | Types.ClassElement _ | Types.ComponentTypeElement _ |
3849 Types.PredefinedTypeElement _ ->
3851 {err_msg = ["_ClassElemFoundInExpr"];
3853 err_ctx = ctx}) (*error*) in
3854 let rec resolve_vector_reduction' acc ctx = function
3856 let expres' = resolve_expression ctx expr' in
3857 let nat = VectorReduction (List.rev acc, expres')
3858 and elt_nat = vector_reduction_type acc expr' expres' in
3859 resolved_expression (Some expr) nat elt_nat
3862 {err_msg = ["_NotYetImplemented"; "_ImplicitIterRange"];
3863 err_info = [("_Expr", Syntax.string_of_for_inds for_inds)];
3865 | (id, Some range) :: for_inds ->
3866 let range' = resolve_expression ctx range in
3867 let elt_nat = range_element_type range range' in
3870 context_nature = ForContext (ctx, id, elt_nat)
3872 resolve_vector_reduction' (range' :: acc) ctx' for_inds in
3873 resolve_vector_reduction' [] ctx for_inds
3875 and resolve_vector_elements ctx expr exprs =
3876 let max_variability var cpnt_type =
3877 let var' = evaluate cpnt_type.Types.variability in
3878 Types.max_variability var var' in
3879 let type_of_elements cpnt_types =
3880 let rec type_of_elements' cl_spec = function
3882 | cpnt_type :: cpnt_types ->
3883 let cl_spec' = evaluate cpnt_type.Types.base_class in
3884 type_of_elements' (update cl_spec cl_spec') cpnt_types
3885 and update cl_spec cl_spec' =
3886 match Types.compare_specifiers cl_spec cl_spec' with
3887 | Types.SameType | Types.Supertype -> cl_spec
3888 | Types.Subtype -> cl_spec'
3891 {err_msg = ["_TypeConflictsInVectorExpr"];
3893 [("_MismatchingTypes",
3894 Types.string_of_class_specifier cl_spec ^ ", " ^
3895 Types.string_of_class_specifier cl_spec')];
3897 match cpnt_types with
3898 | [] -> assert false (*error*)
3899 | cpnt_type :: cpnt_types ->
3900 let cl_spec' = evaluate cpnt_type.Types.base_class in
3901 type_of_elements' cl_spec' cpnt_types in
3902 let exprs' = List.map (resolve_expression ctx) exprs in
3903 let exprs' = apply_binary_coercions exprs' in
3904 let cpnt_types = List.map (component_type_of_expression ctx) exprs' in
3905 let var = lazy (List.fold_left max_variability Types.Constant cpnt_types) in
3906 let cl_spec = type_of_elements cpnt_types in
3907 let dim = Types.ConstantDimension (Int32.of_int (List.length exprs')) in
3908 let cl_spec' = lazy (Types.ArrayType (dim, cl_spec)) in
3911 Types.flow = lazy false;
3913 causality = lazy Types.Acausal;
3914 base_class = cl_spec'
3916 let nat = Vector exprs'
3917 and elt_nat = Types.ComponentElement cpnt_type in
3918 resolved_expression (Some expr) nat elt_nat
3920 and resolve_and ctx expr arg arg' =
3921 let resolve_and' cpnt_type cpnt_type' =
3922 let rec and_type cl_spec cl_spec' = match cl_spec, cl_spec' with
3923 | Types.PredefinedType { Types.base_type = Types.BooleanType },
3924 Types.PredefinedType { Types.base_type = Types.BooleanType } ->
3925 Types.PredefinedType
3926 { Types.base_type = Types.BooleanType; attributes = [] }
3927 | Types.PredefinedType { Types.base_type = Types.BooleanType },
3928 (Types.PredefinedType _ | Types.ClassType _ | Types.ComponentType _ |
3929 Types.ArrayType _ | Types.TupleType _) ->
3931 {err_msg = ["and"; "_OperAppliedToNonBoolExpr"];
3933 [("_ExpectedType", "Boolean");
3934 ("_TypeFound", Types.string_of_class_specifier cl_spec')];
3935 err_ctx = ctx}) (*error*)
3936 | (Types.PredefinedType _ | Types.ClassType _ | Types.ComponentType _ |
3937 Types.ArrayType _ | Types.TupleType _),
3938 (Types.PredefinedType _ | Types.ClassType _ | Types.ComponentType _ |
3939 Types.ArrayType _ | Types.TupleType _) ->
3941 {err_msg = ["and"; "_OperAppliedToNonBoolExpr"];
3943 [("_ExpectedType", "Boolean");
3944 ("_TypeFound", Types.string_of_class_specifier cl_spec)];
3945 err_ctx = ctx}) (*error*) in
3948 let var = evaluate cpnt_type.Types.variability
3949 and var' = evaluate cpnt_type'.Types.variability in
3950 Types.max_variability var var')
3951 and inout = Types.Acausal
3954 let cl_spec = evaluate cpnt_type.Types.base_class
3955 and cl_spec' = evaluate cpnt_type'.Types.base_class in
3956 and_type cl_spec cl_spec') in
3957 let nat = BinaryOperation (And, arg, arg') in
3960 component_element (lazy false) var (lazy inout) cl_spec in
3961 Types.ComponentElement cpnt_type in
3962 resolved_expression (Some expr) nat elt_nat in
3963 match arg.info.type_description, arg'.info.type_description with
3964 | Types.ComponentElement cpnt_type, Types.ComponentElement cpnt_type' ->
3965 resolve_and' cpnt_type cpnt_type'
3966 | Types.ComponentElement _,
3967 (Types.ClassElement _ | Types.ComponentTypeElement _ |
3968 Types.PredefinedTypeElement _) ->
3970 {err_msg = ["_ClassElemFoundInExpr"];
3972 err_ctx = ctx}) (*error*)
3973 | (Types.ClassElement _ | Types.ComponentTypeElement _ |
3974 Types.PredefinedTypeElement _),
3975 (Types.ComponentElement _ | Types.ClassElement _ |
3976 Types.ComponentTypeElement _ | Types.PredefinedTypeElement _) ->
3978 {err_msg = ["_ClassElemFoundInExpr"];
3980 err_ctx = ctx}) (*error*)
3982 and resolve_or ctx expr arg arg' =
3983 let resolve_or' cpnt_type cpnt_type' =
3984 let rec or_type cl_spec cl_spec' = match cl_spec, cl_spec' with
3985 | Types.PredefinedType { Types.base_type = Types.BooleanType },
3986 Types.PredefinedType { Types.base_type = Types.BooleanType } ->
3987 Types.PredefinedType
3988 { Types.base_type = Types.BooleanType; attributes = [] }
3989 | Types.PredefinedType { Types.base_type = Types.BooleanType },
3990 (Types.PredefinedType _ | Types.ClassType _ | Types.ComponentType _ |
3991 Types.ArrayType _ | Types.TupleType _) ->
3993 {err_msg = ["or"; "_OperAppliedToNonBoolExpr"];
3995 [("_ExpectedType", "Boolean");
3996 ("_TypeFound", Types.string_of_class_specifier cl_spec')];
3997 err_ctx = ctx}) (*error*)
3998 | (Types.PredefinedType _ | Types.ClassType _ | Types.ComponentType _ |
3999 Types.ArrayType _ | Types.TupleType _),
4000 (Types.PredefinedType _ | Types.ClassType _ | Types.ComponentType _ |
4001 Types.ArrayType _ | Types.TupleType _) ->
4003 {err_msg = ["or"; "_OperAppliedToNonBoolExpr"];
4005 [("_ExpectedType", "Boolean");
4006 ("_TypeFound", Types.string_of_class_specifier cl_spec)];
4007 err_ctx = ctx}) (*error*) in
4009 lazy (let var = evaluate cpnt_type.Types.variability
4010 and var' = evaluate cpnt_type'.Types.variability in
4011 Types.max_variability var var')
4012 and inout = Types.Acausal
4014 lazy (let cl_spec = evaluate cpnt_type.Types.base_class
4015 and cl_spec' = evaluate cpnt_type'.Types.base_class in
4016 or_type cl_spec cl_spec') in
4017 let nat = BinaryOperation (Or, arg, arg') in
4020 component_element (lazy false) var (lazy inout) cl_spec in
4021 Types.ComponentElement cpnt_type in
4022 resolved_expression (Some expr) nat elt_nat in
4023 match arg.info.type_description, arg'.info.type_description with
4024 | Types.ComponentElement cpnt_type, Types.ComponentElement cpnt_type' ->
4025 resolve_or' cpnt_type cpnt_type'
4026 | (Types.ComponentElement _ | Types.ClassElement _ |
4027 Types.ComponentTypeElement _ | Types.PredefinedTypeElement _),
4028 (Types.ComponentElement _ | Types.ClassElement _ |
4029 Types.ComponentTypeElement _ | Types.PredefinedTypeElement _) ->
4031 {err_msg = ["_ClassElemFoundInExpr"];
4033 err_ctx = ctx}) (*error*)
4035 and resolve_addition ctx expr arg arg' =
4036 let resolve_addition' cpnt_type cpnt_type' =
4037 let rec addition_type cl_spec cl_spec' = match cl_spec, cl_spec' with
4038 | Types.ArrayType (Types.ConstantDimension n, _),
4039 Types.ArrayType (Types.ConstantDimension n', _) when n <> n' ->
4041 {err_msg = ["_ArrayDimMustAgreeToPerform"; "_Addition"];
4043 [("_ExprKind", "A + B");
4044 ("_TypeOfA", Types.string_of_class_specifier cl_spec);
4045 ("_TypeOfB", Types.string_of_class_specifier cl_spec')];
4046 err_ctx = ctx}) (*error*)
4047 | Types.ArrayType (Types.ConstantDimension _, cl_spec),
4048 Types.ArrayType (dim, cl_spec') |
4049 Types.ArrayType (dim, cl_spec),
4050 Types.ArrayType (Types.ConstantDimension _, cl_spec') ->
4051 Types.ArrayType (dim, addition_type cl_spec cl_spec')
4052 | Types.ArrayType (Types.ParameterDimension, cl_spec),
4053 Types.ArrayType (dim, cl_spec') |
4054 Types.ArrayType (dim, cl_spec),
4055 Types.ArrayType (Types.ParameterDimension, cl_spec') ->
4056 Types.ArrayType (dim, addition_type cl_spec cl_spec')
4057 | Types.ArrayType (Types.DiscreteDimension, cl_spec),
4058 Types.ArrayType (Types.DiscreteDimension, cl_spec') ->
4060 (Types.DiscreteDimension, addition_type cl_spec cl_spec')
4061 | Types.PredefinedType { Types.base_type = Types.IntegerType },
4062 Types.PredefinedType { Types.base_type = Types.IntegerType } ->
4063 Types.PredefinedType
4064 { Types.base_type = Types.IntegerType; attributes = [] }
4065 | Types.PredefinedType
4066 { Types.base_type = Types.RealType | Types.IntegerType },
4067 Types.PredefinedType
4068 { Types.base_type = Types.RealType | Types.IntegerType } ->
4069 Types.PredefinedType
4070 { Types.base_type = Types.RealType; attributes = [] }
4071 | Types.PredefinedType _, Types.ArrayType _
4072 | Types.ArrayType _, Types.PredefinedType _ ->
4074 {err_msg = ["+"; "_OperBetweenScalarAndArray"];
4076 [("_ExprKind", "A + B");
4077 ("_TypeOfA", Types.string_of_class_specifier cl_spec);
4078 ("_TypeOfB", Types.string_of_class_specifier cl_spec')];
4079 err_ctx = ctx}) (*error*)
4082 {err_msg = ["+"; "_OperAppliedToNonNumericExpr"];
4084 [("_ExprKind", "A + B");
4085 ("_TypeOfA", Types.string_of_class_specifier cl_spec);
4086 ("_TypeOfB", Types.string_of_class_specifier cl_spec')];
4087 err_ctx = ctx}) (*error*) in
4089 lazy (let var = evaluate cpnt_type.Types.variability
4090 and var' = evaluate cpnt_type'.Types.variability in
4091 Types.max_variability var var')
4092 and inout = Types.Acausal
4094 lazy (let cl_spec = evaluate cpnt_type.Types.base_class
4095 and cl_spec' = evaluate cpnt_type'.Types.base_class in
4096 addition_type cl_spec cl_spec') in
4097 let nat = BinaryOperation (Plus, arg, arg') in
4100 component_element (lazy false) var (lazy inout) cl_spec in
4101 Types.ComponentElement cpnt_type in
4102 resolved_expression (Some expr) nat elt_nat in
4103 match arg.info.type_description, arg'.info.type_description with
4104 | Types.ComponentElement cpnt_type, Types.ComponentElement cpnt_type' ->
4105 resolve_addition' cpnt_type cpnt_type'
4106 | (Types.ComponentElement _ | Types.ClassElement _ |
4107 Types.ComponentTypeElement _ | Types.PredefinedTypeElement _),
4108 (Types.ComponentElement _ | Types.ClassElement _ |
4109 Types.ComponentTypeElement _ | Types.PredefinedTypeElement _) ->
4111 {err_msg = ["_ClassElemFoundInExpr"];
4113 err_ctx = ctx}) (*error*)
4115 and resolve_comparison ctx expr kind arg arg' =
4116 let resolve_comparison' cpnt_type cpnt_type' =
4117 let rec comparison_type cl_spec cl_spec' = match cl_spec, cl_spec' with
4118 | Types.PredefinedType
4119 { Types.base_type = Types.IntegerType | Types.RealType },
4120 Types.PredefinedType
4121 { Types.base_type = Types.IntegerType | Types.RealType } ->
4122 Types.PredefinedType
4123 { Types.base_type = Types.BooleanType; attributes = [] }
4124 | (Types.PredefinedType _ | Types.ClassType _ | Types.ComponentType _ |
4125 Types.ArrayType _ | Types.TupleType _),
4126 (Types.PredefinedType _ | Types.ClassType _ | Types.ComponentType _ |
4127 Types.ArrayType _ | Types.TupleType _) ->
4129 {err_msg = ["_TypeInconsistWithComparOper"];
4131 [("_ExprKind", "A" ^ (string_of_bin_oper_kind kind) ^ "B");
4132 ("_TypeOfA", Types.string_of_class_specifier cl_spec);
4133 ("_TypeOfB", Types.string_of_class_specifier cl_spec')];
4134 err_ctx = ctx}) (*error*) in
4136 let var = evaluate cpnt_type.Types.variability
4137 and var' = evaluate cpnt_type'.Types.variability in
4138 Types.max_variability var var'*)
4139 let var = Types.Discrete
4140 and inout = Types.Acausal
4142 lazy (let cl_spec = evaluate cpnt_type.Types.base_class
4143 and cl_spec' = evaluate cpnt_type'.Types.base_class in
4144 comparison_type cl_spec cl_spec') in
4145 let nat = BinaryOperation (kind, arg, arg') in
4148 component_element (lazy false) (lazy var) (lazy inout) cl_spec in
4149 Types.ComponentElement cpnt_type in
4150 resolved_expression (Some expr) nat elt_nat in
4151 match arg.info.type_description, arg'.info.type_description with
4152 | Types.ComponentElement cpnt_type, Types.ComponentElement cpnt_type' ->
4153 resolve_comparison' cpnt_type cpnt_type'
4154 | (Types.ComponentElement _ | Types.ClassElement _ |
4155 Types.ComponentTypeElement _ | Types.PredefinedTypeElement _),
4156 (Types.ComponentElement _ | Types.ClassElement _ |
4157 Types.ComponentTypeElement _ | Types.PredefinedTypeElement _) ->
4159 {err_msg = ["_ClassElemFoundInExpr"];
4161 err_ctx = ctx}) (*error*)
4163 and resolve_division ctx expr arg arg' =
4164 let resolve_division' cpnt_type cpnt_type' =
4165 let rec division_type cl_spec cl_spec' = match cl_spec, cl_spec' with
4166 | Types.ArrayType (dim, cl_spec),
4167 Types.PredefinedType
4168 { Types.base_type = Types.IntegerType | Types.RealType } ->
4169 Types.ArrayType (dim, division_type cl_spec cl_spec')
4170 | Types.PredefinedType
4171 { Types.base_type = Types.RealType | Types.IntegerType },
4172 Types.PredefinedType
4173 { Types.base_type = Types.RealType | Types.IntegerType } ->
4174 Types.PredefinedType
4175 { Types.base_type = Types.RealType; attributes = [] }
4176 | (Types.PredefinedType _ | Types.ClassType _ | Types.ComponentType _ |
4177 Types.ArrayType _ | Types.TupleType _),
4178 (Types.PredefinedType _ | Types.ClassType _ | Types.ComponentType _ |
4179 Types.ArrayType _ | Types.TupleType _) ->
4181 {err_msg = ["_TypeInconsistentWithDivOper"];
4183 [("_ExprKind", "A / B");
4184 ("_TypeOfA", Types.string_of_class_specifier cl_spec);
4185 ("_TypeOfB", Types.string_of_class_specifier cl_spec')];
4186 err_ctx = ctx}) (*error*) in
4188 lazy (let var = evaluate cpnt_type.Types.variability
4189 and var' = evaluate cpnt_type'.Types.variability in
4190 Types.max_variability var var')
4191 and inout = Types.Acausal
4193 lazy (let cl_spec = evaluate cpnt_type.Types.base_class
4194 and cl_spec' = evaluate cpnt_type'.Types.base_class in
4195 division_type cl_spec cl_spec') in
4196 let nat = BinaryOperation (Divide, arg, arg') in
4199 component_element (lazy false) var (lazy inout) cl_spec in
4200 Types.ComponentElement cpnt_type in
4201 resolved_expression (Some expr) nat elt_nat in
4202 match arg.info.type_description, arg'.info.type_description with
4203 | Types.ComponentElement cpnt_type, Types.ComponentElement cpnt_type' ->
4204 resolve_division' cpnt_type cpnt_type'
4205 | (Types.ComponentElement _ | Types.ClassElement _ |
4206 Types.ComponentTypeElement _ | Types.PredefinedTypeElement _),
4207 (Types.ComponentElement _ | Types.ClassElement _ |
4208 Types.ComponentTypeElement _ | Types.PredefinedTypeElement _) ->
4210 {err_msg = ["_ClassElemFoundInExpr"];
4212 err_ctx = ctx}) (*error*)
4214 and resolve_multiplication ctx expr arg arg' =
4215 let resolve_multiplication' cpnt_type cpnt_type' =
4216 let rec multiplication_type cl_spec cl_spec' = match cl_spec, cl_spec' with
4217 | Types.ArrayType (_, Types.ArrayType (Types.ConstantDimension n, _)),
4218 Types.ArrayType (Types.ConstantDimension n', Types.ArrayType _)
4221 {err_msg = ["_ArrayDimsNonCompatibleWithMult"];
4223 [("_ExprKind", "A * B");
4224 ("_TypeOfA", Types.string_of_component_type cpnt_type);
4225 ("_TypeOfB", Types.string_of_component_type cpnt_type')];
4226 err_ctx = ctx}) (*error*)
4228 (dim, Types.ArrayType
4229 (_, Types.PredefinedType
4230 { Types.base_type = Types.IntegerType })),
4233 (dim', Types.PredefinedType
4234 { Types.base_type = Types.IntegerType })) ->
4236 (dim, Types.ArrayType
4237 (dim', Types.PredefinedType
4238 { Types.base_type = Types.IntegerType; attributes = [] }))
4240 (dim, Types.ArrayType
4241 (_, Types.PredefinedType
4242 { Types.base_type = Types.IntegerType | Types.RealType })),
4245 (dim', Types.PredefinedType
4246 { Types.base_type = Types.IntegerType | Types.RealType })) ->
4248 (dim, Types.ArrayType
4249 (dim', Types.PredefinedType
4250 { Types.base_type = Types.RealType; attributes = [] }))
4251 | Types.ArrayType (_, Types.ArrayType (Types.ConstantDimension n, _)),
4252 Types.ArrayType (Types.ConstantDimension n', _)
4255 {err_msg = ["_ArrayDimsNonCompatibleWithMult"];
4257 [("_ExprKind", "A * B");
4258 ("_TypeOfA", Types.string_of_class_specifier cl_spec);
4259 ("_TypeOfB", Types.string_of_class_specifier cl_spec')];
4260 err_ctx = ctx}) (*error*)
4262 (dim, Types.ArrayType
4263 (_, Types.PredefinedType
4264 { Types.base_type = Types.IntegerType })),
4266 (_, Types.PredefinedType
4267 { Types.base_type = Types.IntegerType }) ->
4269 (dim, Types.PredefinedType
4270 { Types.base_type = Types.IntegerType; attributes = [] })
4272 (dim, Types.ArrayType
4273 (_, Types.PredefinedType
4274 { Types.base_type = Types.IntegerType | Types.RealType })),
4276 (_, Types.PredefinedType
4277 { Types.base_type = Types.IntegerType | Types.RealType }) ->
4279 (dim, Types.PredefinedType
4280 { Types.base_type = Types.RealType; attributes = [] })
4281 | Types.ArrayType (Types.ConstantDimension n, _),
4282 Types.ArrayType (Types.ConstantDimension n', Types.ArrayType _)
4285 {err_msg = ["_ArrayDimsNonCompatibleWithMult"];
4287 [("_ExprKind", "A * B");
4288 ("_TypeOfA", Types.string_of_class_specifier cl_spec);
4289 ("_TypeOfB", Types.string_of_class_specifier cl_spec')];
4290 err_ctx = ctx}) (*error*)
4292 (_, Types.PredefinedType
4293 { Types.base_type = Types.IntegerType }),
4296 (dim, Types.PredefinedType
4297 { Types.base_type = Types.IntegerType })) ->
4299 (dim, Types.PredefinedType
4300 { Types.base_type = Types.IntegerType; attributes = [] })
4302 (_, Types.PredefinedType
4303 { Types.base_type = Types.IntegerType | Types.RealType }),
4306 (dim, Types.PredefinedType
4307 { Types.base_type = Types.IntegerType | Types.RealType })) ->
4309 (dim, Types.PredefinedType
4310 { Types.base_type = Types.RealType; attributes = [] })
4311 | Types.ArrayType (Types.ConstantDimension n, _),
4312 Types.ArrayType (Types.ConstantDimension n', _)
4315 {err_msg = ["_ArrayDimsNonCompatibleWithMult"];
4317 [("_ExprKind", "A * B");
4318 ("_TypeOfA", Types.string_of_class_specifier cl_spec);
4319 ("_TypeOfB", Types.string_of_class_specifier cl_spec')];
4320 err_ctx = ctx}) (*error*)
4322 (_, Types.PredefinedType
4323 { Types.base_type = Types.IntegerType }),
4325 (_, Types.PredefinedType
4326 { Types.base_type = Types.IntegerType }) ->
4327 Types.PredefinedType
4328 { Types.base_type = Types.IntegerType; attributes = [] }
4330 (_, Types.PredefinedType
4331 { Types.base_type = Types.IntegerType | Types.RealType }),
4333 (_, Types.PredefinedType
4334 { Types.base_type = Types.IntegerType | Types.RealType }) ->
4335 Types.PredefinedType
4336 { Types.base_type = Types.RealType; attributes = [] }
4337 | Types.PredefinedType
4338 { Types.base_type = Types.IntegerType | Types.RealType },
4339 Types.ArrayType (dim, cl_spec') ->
4340 Types.ArrayType (dim, multiplication_type cl_spec cl_spec')
4341 | Types.ArrayType (dim, cl_spec),
4342 Types.PredefinedType
4343 { Types.base_type = Types.IntegerType | Types.RealType } ->
4344 Types.ArrayType (dim, multiplication_type cl_spec cl_spec')
4345 | Types.PredefinedType { Types.base_type = Types.IntegerType },
4346 Types.PredefinedType { Types.base_type = Types.IntegerType } ->
4347 Types.PredefinedType
4348 { Types.base_type = Types.IntegerType; attributes = [] }
4349 | Types.PredefinedType
4350 { Types.base_type = Types.RealType | Types.IntegerType },
4351 Types.PredefinedType
4352 { Types.base_type = Types.RealType | Types.IntegerType } ->
4353 Types.PredefinedType
4354 { Types.base_type = Types.RealType; attributes = [] }
4355 | (Types.PredefinedType _ | Types.ClassType _ | Types.ComponentType _ |
4356 Types.ArrayType _ | Types.TupleType _),
4357 (Types.PredefinedType _ | Types.ClassType _ | Types.ComponentType _ |
4358 Types.ArrayType _ | Types.TupleType _) ->
4360 {err_msg = ["*"; "_OperAppliedToNonNumericExpr"];
4362 [("_ExprKind", "A * B");
4363 ("_TypeOfA", Types.string_of_class_specifier cl_spec);
4364 ("_TypeOfB", Types.string_of_class_specifier cl_spec')];
4365 err_ctx = ctx}) (*error*) in
4367 lazy (let var = evaluate cpnt_type.Types.variability
4368 and var' = evaluate cpnt_type'.Types.variability in
4369 Types.max_variability var var')
4370 and inout = Types.Acausal
4372 lazy (let cl_spec = evaluate cpnt_type.Types.base_class
4373 and cl_spec' = evaluate cpnt_type'.Types.base_class in
4374 multiplication_type cl_spec cl_spec') in
4375 let nat = BinaryOperation (Times, arg, arg') in
4378 component_element (lazy false) var (lazy inout) cl_spec in
4379 Types.ComponentElement cpnt_type in
4380 resolved_expression (Some expr) nat elt_nat in
4381 match arg.info.type_description, arg'.info.type_description with
4382 | Types.ComponentElement cpnt_type, Types.ComponentElement cpnt_type' ->
4383 resolve_multiplication' cpnt_type cpnt_type'
4384 | (Types.ComponentElement _ | Types.ClassElement _ |
4385 Types.ComponentTypeElement _ | Types.PredefinedTypeElement _),
4386 (Types.ComponentElement _ | Types.ClassElement _ |
4387 Types.ComponentTypeElement _ | Types.PredefinedTypeElement _) ->
4389 {err_msg = ["_ClassElemFoundInExpr"];
4391 err_ctx = ctx}) (*error*)
4393 and resolve_power ctx expr arg arg' =
4394 let resolve_power' cpnt_type cpnt_type' =
4395 let rec power_type cl_spec cl_spec' = match cl_spec, cl_spec' with
4397 (Types.ConstantDimension n, Types.ArrayType
4398 (Types.ConstantDimension n', _)),
4399 Types.PredefinedType { Types.base_type = Types.IntegerType }
4402 {err_msg = ["_PowerOperOnNonSquareArray"];
4404 [("_ExprKind", "A ^ B");
4405 ("_TypeOfA", Types.string_of_class_specifier cl_spec);
4406 ("_TypeOfB", Types.string_of_class_specifier cl_spec')];
4407 err_ctx = ctx}) (*error*)
4409 (dim, Types.ArrayType
4410 (dim', Types.PredefinedType
4411 { Types.base_type = Types.IntegerType })),
4412 Types.PredefinedType { Types.base_type = Types.IntegerType } ->
4414 (dim, Types.ArrayType
4415 (dim', Types.PredefinedType
4416 { Types.base_type = Types.RealType; attributes = [] }))
4418 (dim, Types.ArrayType
4419 (dim', Types.PredefinedType { Types.base_type = Types.RealType })),
4420 Types.PredefinedType { Types.base_type = Types.IntegerType } ->
4422 (dim, Types.ArrayType
4423 (dim', Types.PredefinedType
4424 { Types.base_type = Types.RealType; attributes = [] }))
4425 | Types.PredefinedType { Types.base_type = Types.IntegerType },
4426 Types.PredefinedType { Types.base_type = Types.IntegerType } ->
4427 Types.PredefinedType
4428 { Types.base_type = Types.RealType; attributes = [] }
4429 | Types.PredefinedType
4430 { Types.base_type = Types.RealType | Types.IntegerType },
4431 Types.PredefinedType
4432 { Types.base_type = Types.RealType | Types.IntegerType } ->
4433 Types.PredefinedType
4434 { Types.base_type = Types.RealType; attributes = [] }
4435 | (Types.PredefinedType _ | Types.ClassType _ | Types.ComponentType _ |
4436 Types.ArrayType _ | Types.TupleType _),
4437 (Types.PredefinedType _ | Types.ClassType _ | Types.ComponentType _ |
4438 Types.ArrayType _ | Types.TupleType _) ->
4440 {err_msg = ["^"; "_OperAppliedToNonNumericExpr"];
4442 [("_ExprKind", "A ^ B");
4443 ("_TypeOfA", Types.string_of_class_specifier cl_spec);
4444 ("_TypeOfB", Types.string_of_class_specifier cl_spec')];
4445 err_ctx = ctx}) (*error*) in
4447 lazy (let var = evaluate cpnt_type.Types.variability
4448 and var' = evaluate cpnt_type'.Types.variability in
4449 Types.max_variability var var')
4450 and inout = Types.Acausal
4452 lazy (let cl_spec = evaluate cpnt_type.Types.base_class
4453 and cl_spec' = evaluate cpnt_type'.Types.base_class in
4454 power_type cl_spec cl_spec') in
4455 let nat = BinaryOperation (Power, arg, arg') in
4458 component_element (lazy false) var (lazy inout) cl_spec in
4459 Types.ComponentElement cpnt_type in
4460 resolved_expression (Some expr) nat elt_nat in
4461 match arg.info.type_description, arg'.info.type_description with
4462 | Types.ComponentElement cpnt_type, Types.ComponentElement cpnt_type' ->
4463 resolve_power' cpnt_type cpnt_type'
4464 | (Types.ComponentElement _ | Types.ClassElement _ |
4465 Types.ComponentTypeElement _ | Types.PredefinedTypeElement _),
4466 (Types.ComponentElement _ | Types.ClassElement _ |
4467 Types.ComponentTypeElement _ | Types.PredefinedTypeElement _) ->
4469 {err_msg = ["_ClassElemFoundInExpr"];
4471 err_ctx = ctx}) (*error*)
4473 and resolve_subtraction ctx expr arg arg' =
4474 let resolve_subtraction' cpnt_type cpnt_type' =
4475 let rec subtraction_type cl_spec cl_spec' = match cl_spec, cl_spec' with
4476 | Types.ArrayType (Types.ConstantDimension n, _),
4477 Types.ArrayType (Types.ConstantDimension n', _) when n <> n' ->
4479 {err_msg = ["_ArrayDimMustAgreeToPerform"; "_Subtraction"];
4481 [("_ExprKind", "A - B");
4482 ("_TypeOfA", Types.string_of_class_specifier cl_spec);
4483 ("_TypeOfB", Types.string_of_class_specifier cl_spec')];
4484 err_ctx = ctx}) (*error*)
4485 | Types.ArrayType (Types.ConstantDimension _, cl_spec),
4486 Types.ArrayType (dim, cl_spec') |
4487 Types.ArrayType (dim, cl_spec),
4488 Types.ArrayType (Types.ConstantDimension _, cl_spec') ->
4489 Types.ArrayType (dim, subtraction_type cl_spec cl_spec')
4490 | Types.ArrayType (Types.ParameterDimension, cl_spec),
4491 Types.ArrayType (dim, cl_spec') |
4492 Types.ArrayType (dim, cl_spec),
4493 Types.ArrayType (Types.ParameterDimension, cl_spec') ->
4494 Types.ArrayType (dim, subtraction_type cl_spec cl_spec')
4495 | Types.ArrayType (Types.DiscreteDimension, cl_spec),
4496 Types.ArrayType (Types.DiscreteDimension, cl_spec') ->
4498 (Types.DiscreteDimension, subtraction_type cl_spec cl_spec')
4499 | Types.PredefinedType { Types.base_type = Types.IntegerType },
4500 Types.PredefinedType { Types.base_type = Types.IntegerType } ->
4501 Types.PredefinedType
4502 { Types.base_type = Types.IntegerType; attributes = [] }
4503 | Types.PredefinedType
4504 { Types.base_type = Types.RealType | Types.IntegerType },
4505 Types.PredefinedType
4506 { Types.base_type = Types.RealType | Types.IntegerType } ->
4507 Types.PredefinedType
4508 { Types.base_type = Types.RealType; attributes = [] }
4509 | (Types.PredefinedType _ | Types.ClassType _ | Types.ComponentType _ |
4510 Types.ArrayType _ | Types.TupleType _),
4511 (Types.PredefinedType _ | Types.ClassType _ | Types.ComponentType _ |
4512 Types.ArrayType _ | Types.TupleType _) ->
4514 {err_msg = ["-"; "_OperAppliedToNonNumericExpr"];
4516 [("_ExprKind", "A - B");
4517 ("_TypeOfA", Types.string_of_class_specifier cl_spec);
4518 ("_TypeOfB", Types.string_of_class_specifier cl_spec')];
4519 err_ctx = ctx}) (*error*) in
4521 lazy (let var = evaluate cpnt_type.Types.variability
4522 and var' = evaluate cpnt_type'.Types.variability in
4523 Types.max_variability var var')
4524 and inout = Types.Acausal
4526 lazy (let cl_spec = evaluate cpnt_type.Types.base_class
4527 and cl_spec' = evaluate cpnt_type'.Types.base_class in
4528 subtraction_type cl_spec cl_spec') in
4529 let nat = BinaryOperation (Minus, arg, arg') in
4532 component_element (lazy false) var (lazy inout) cl_spec in
4533 Types.ComponentElement cpnt_type in
4534 resolved_expression (Some expr) nat elt_nat in
4535 match arg.info.type_description, arg'.info.type_description with
4536 | Types.ComponentElement cpnt_type, Types.ComponentElement cpnt_type' ->
4537 resolve_subtraction' cpnt_type cpnt_type'
4538 | (Types.ComponentElement _ | Types.ClassElement _ |
4539 Types.ComponentTypeElement _ | Types.PredefinedTypeElement _),
4540 (Types.ComponentElement _ | Types.ClassElement _ |
4541 Types.ComponentTypeElement _ | Types.PredefinedTypeElement _) ->
4543 {err_msg = ["_ClassElemFoundInExpr"];
4545 err_ctx = ctx}) (*error*)
4547 and resolve_unary_minus ctx expr arg =
4548 let resolve_unary_minus' cpnt_type =
4549 let rec unary_minus_type cl_spec = match cl_spec with
4550 | Types.ArrayType (dim, cl_spec) ->
4551 Types.ArrayType (dim, unary_minus_type cl_spec)
4552 | Types.PredefinedType
4553 { Types.base_type = Types.RealType | Types.IntegerType } -> cl_spec
4554 | (Types.PredefinedType _ | Types.ClassType _ | Types.ComponentType _ |
4555 Types.TupleType _) ->
4557 {err_msg = ["-"; "_OperAppliedToNonNumericExpr"];
4559 [("_ExprKind", "- A");
4560 ("_TypeOfA", Types.string_of_class_specifier cl_spec)];
4561 err_ctx = ctx}) (*error*) in
4562 let var = cpnt_type.Types.variability
4563 and inout = Types.Acausal
4565 lazy (let cl_spec = evaluate cpnt_type.Types.base_class in
4566 unary_minus_type cl_spec) in
4567 let nat = UnaryOperation (UnaryMinus, arg) in
4570 component_element (lazy false) var (lazy inout) cl_spec in
4571 Types.ComponentElement cpnt_type in
4572 resolved_expression (Some expr) nat elt_nat in
4573 match arg.info.type_description with
4574 | Types.ComponentElement cpnt_type -> resolve_unary_minus' cpnt_type
4575 | Types.ClassElement _ |
4576 Types.ComponentTypeElement _ | Types.PredefinedTypeElement _ ->
4578 {err_msg = ["_ClassElemFoundInExpr"];
4580 err_ctx = ctx}) (*error*)
4582 and resolve_not ctx expr arg =
4583 let resolve_not' cpnt_type =
4584 let rec not_type cl_spec = match cl_spec with
4585 | Types.PredefinedType { Types.base_type = Types.BooleanType } -> cl_spec
4586 | (Types.PredefinedType _ | Types.ArrayType _ | Types.ClassType _ |
4587 Types.ComponentType _ | Types.TupleType _) ->
4589 {err_msg = ["not"; "_OperAppliedToNonBoolExpr"];
4591 [("_ExprKind", "not A");
4592 ("_TypeOfA", Types.string_of_class_specifier cl_spec)];
4593 err_ctx = ctx}) (*error*) in
4594 let var = cpnt_type.Types.variability
4595 and inout = Types.Acausal
4597 lazy (let cl_spec = evaluate cpnt_type.Types.base_class in
4598 not_type cl_spec) in
4599 let nat = UnaryOperation (Not, arg) in
4602 component_element (lazy false) var (lazy inout) cl_spec in
4603 Types.ComponentElement cpnt_type in
4604 resolved_expression (Some expr) nat elt_nat in
4605 match arg.info.type_description with
4606 | Types.ComponentElement cpnt_type -> resolve_not' cpnt_type
4607 | Types.ClassElement _ |
4608 Types.ComponentTypeElement _ | Types.PredefinedTypeElement _ ->
4610 {err_msg = ["_ClassElemFoundInExpr"];
4612 err_ctx = ctx}) (*error*)
4614 and component_element flow var inout cl_spec =
4619 base_class = cl_spec
4622 and element_nature_class ctx = function
4623 | Types.ClassElement cl_spec -> evaluate cl_spec
4624 | Types.ComponentElement cpnt_type -> evaluate cpnt_type.Types.base_class
4625 | Types.PredefinedTypeElement predef -> Types.PredefinedType predef
4626 | Types.ComponentTypeElement _ -> assert false (*error*)
4628 and element_field_type_nature ctx flow var inout cl_spec id =
4629 let add_dimension dim = function
4630 | Types.ComponentElement cpnt_type ->
4634 lazy (Types.ArrayType (dim, evaluate cpnt_type.Types.base_class))
4636 Types.ComponentElement cpnt_type'
4637 | Types.ClassElement _
4638 | Types.ComponentTypeElement _
4639 | Types.PredefinedTypeElement _ ->
4641 {err_msg = ["_InvalidClassElemModif"];
4643 err_ctx = ctx}) (*error*) in
4644 let find_predefined_local_identifier predef id =
4645 match predef.Types.base_type with
4646 | Types.BooleanType when id = "start" -> Types.boolean_type Types.Parameter
4647 | Types.IntegerType when id = "start" ->
4648 Types.integer_type Types.Parameter
4649 | Types.RealType when id = "start" ->
4650 Types.real_type Types.Parameter
4651 | Types.StringType when id = "start" -> Types.string_type Types.Parameter
4652 | Types.EnumerationType enum_lits when id = "start" ->
4653 Types.enumeration_type Types.Parameter enum_lits
4654 | _ when id = "fixed" -> Types.boolean_type Types.Constant
4655 | Types.IntegerType when id = "nominal" ->
4656 Types.integer_type Types.Constant
4657 | Types.RealType when id = "nominal" ->
4658 Types.real_type Types.Constant
4661 {err_msg = ["_NotYetImplemented"; "_PredefinedTypeAttribModif"; id];
4664 and find_class_local_identifier flow var inout cl_type id =
4665 let apply_prefixes elt_nat = match elt_nat with
4666 | Types.ComponentElement cpnt_type ->
4667 let flow' = lazy (flow || evaluate cpnt_type.Types.flow) in
4668 Types.ComponentElement { cpnt_type with Types.flow = flow' }
4669 | Types.ClassElement _ | Types.ComponentTypeElement _ |
4670 Types.PredefinedTypeElement _ -> elt_nat in
4673 evaluate (List.assoc id cl_type.Types.named_elements) in
4674 match elt_type.Types.dynamic_scope with
4675 | None | Some Types.Inner | Some Types.InnerOuter
4676 when not elt_type.Types.protected ->
4677 apply_prefixes elt_type.Types.element_nature
4678 | None | Some Types.Inner | Some Types.InnerOuter ->
4680 {err_msg = ["_CannotAccessProtectElem"; id];
4682 err_ctx = ctx}) (*error*)
4683 | Some Types.Outer ->
4685 {err_msg = ["_CannotAccessOuterElem"; id];
4687 err_ctx = ctx}) (*error*)
4690 {err_msg = ["_UnknownIdentifier"; id];
4692 err_ctx = ctx }) (*error*) in
4693 let rec find_local_identifier flow var inout = function
4694 | Types.PredefinedType predef_type ->
4695 find_predefined_local_identifier predef_type id
4696 | Types.ClassType cl_type ->
4697 find_class_local_identifier flow var inout cl_type id
4698 | Types.ComponentType cpnt_type ->
4699 let flow = flow || evaluate cpnt_type.Types.flow
4701 Types.max_variability var (evaluate cpnt_type.Types.variability)
4702 and inout = evaluate cpnt_type.Types.causality
4703 and base_class = evaluate cpnt_type.Types.base_class in
4704 find_local_identifier flow var inout base_class
4705 | Types.ArrayType (dim, cl_spec) ->
4706 add_dimension dim (find_local_identifier flow var inout cl_spec)
4707 | Types.TupleType _ -> assert false (*error*) in
4708 find_local_identifier flow var inout cl_spec
4710 and scalar_element_nature elt_nat =
4711 let rec scalar_element_nature' cl_spec = match cl_spec with
4712 | Types.PredefinedType _ | Types.ClassType _ | Types.ComponentType _ |
4713 Types.TupleType _ -> cl_spec
4714 | Types.ArrayType (_, cl_spec) -> scalar_element_nature' cl_spec in
4716 | Types.ComponentElement cpnt_type ->
4718 lazy (scalar_element_nature' (evaluate cpnt_type.Types.base_class)) in
4719 Types.ComponentElement { cpnt_type with Types.base_class = base_class' }
4720 | Types.ClassElement _ | Types.ComponentTypeElement _ |
4721 Types.PredefinedTypeElement _ -> elt_nat
4723 and resolve_lhs_expression ctx expr =
4725 {err_msg = ["_NotYetImplemented";
4726 "_ExternalCallWithLeftHandSideExpr"];
4730 and resolve_subscripts ctx expr cl_spec subs =
4731 let rec resolve_subscripts' n cl_spec subs = match cl_spec, subs with
4733 | Types.ArrayType (dim, cl_spec'), sub :: subs' ->
4734 let sub' = resolve_subscript ctx expr n dim sub in
4735 sub' :: resolve_subscripts' (Int32.add n 1l) cl_spec' subs'
4736 | (Types.PredefinedType _ | Types.ClassType _ | Types.ComponentType _ |
4737 Types.TupleType _), _ :: _ ->
4739 {err_msg = ["_CannotSubscriptANonArrayTypeElem"];
4741 [("_ExpectedType", "_ArrayType");
4742 ("_TypeFound", Types.string_of_class_specifier cl_spec)];
4743 err_ctx = ctx}) (*error*) in
4744 match subs.Syntax.nature with
4745 | Syntax.Subscripts subs' -> resolve_subscripts' 1l cl_spec subs'
4747 and resolve_subscript ctx expr n dim sub = match sub.Syntax.nature with
4748 | Syntax.Colon -> resolve_colon ctx expr n dim
4749 | Syntax.Subscript expr' ->
4752 context_nature = SubscriptContext (ctx, expr, n, dim);
4753 location = expr'.Syntax.info } in
4754 resolve_subscript_expression ctx' expr'
4756 and resolve_colon ctx expr n dim =
4757 let range var stop =
4758 let nat = Range (one, one, stop)
4759 and elt_nat = Types.integer_array_type var dim in
4760 resolved_expression None nat elt_nat in
4762 | Types.ConstantDimension n ->
4765 and elt_nat = Types.integer_type Types.Constant in
4766 resolved_expression None nat elt_nat in
4767 range Types.Constant stop
4768 | Types.ParameterDimension ->
4769 let stop = size_function_call ctx None expr n in
4770 range Types.Parameter stop
4771 | Types.DiscreteDimension ->
4772 let stop = size_function_call ctx None expr n in
4773 range Types.Discrete stop
4775 and resolve_subscript_expression ctx expr =
4776 let expr' = resolve_expression ctx expr in
4777 let resolve_subscript_expression' cpnt_type =
4778 let cl_spec = evaluate cpnt_type.Types.base_class in
4780 | Types.PredefinedType { Types.base_type = Types.IntegerType } |
4782 (_, Types.PredefinedType { Types.base_type = Types.IntegerType }) ->
4784 | Types.PredefinedType _ | Types.ClassType _ | Types.ComponentType _ |
4785 Types.ArrayType _ | Types.TupleType _ ->
4787 {err_msg = ["_NonIntegerArraySubscript"];
4789 [("_ExpectedType", "Integer");
4790 ("_TypeFound", Types.string_of_class_specifier cl_spec)];
4791 err_ctx = ctx}) (*error*) in
4792 match expr'.info.type_description with
4793 | Types.ComponentElement cpnt_type ->
4794 resolve_subscript_expression' cpnt_type
4795 | Types.ClassElement _ | Types.ComponentTypeElement _ |
4796 Types.PredefinedTypeElement _ ->
4798 {err_msg = ["_ClassElemFoundInExpr"];
4800 err_ctx = ctx}) (*error*)
4802 and size_function_call ctx syn arg n =
4803 let size_function_call' cpnt_type =
4806 Types.base_class = lazy (Types.integer_class_type)
4809 let nat = PredefinedIdentifier "size"
4813 ("@2", Types.integer_component_type Types.Constant)]
4814 ["@3", cpnt_type'] in
4815 resolved_expression None nat elt_nat in
4816 let elt_nat = Types.ComponentElement cpnt_type' in
4819 and elt_nat = Types.integer_type Types.Constant in
4820 resolved_expression None nat elt_nat
4824 let nat = FunctionArgument 1
4825 and elt_nat = arg.info.type_description in
4826 resolved_expression None nat elt_nat
4828 let nat = FunctionArgument 2
4829 and elt_nat = Types.integer_type Types.Constant in
4830 resolved_expression None nat elt_nat in
4832 let nat = FunctionInvocation args in
4833 resolved_expression None nat elt_nat in
4834 let nat = FunctionCall (size, [arg; num], expr) in
4835 resolved_expression syn nat elt_nat in
4836 match arg.info.type_description with
4837 | Types.ComponentElement cpnt_type -> size_function_call' cpnt_type
4838 | Types.ClassElement _ | Types.ComponentTypeElement _ |
4839 Types.PredefinedTypeElement _ ->
4841 {err_msg = ["_ClassElemFoundInExpr"];
4843 err_ctx = ctx}) (*error*)
4845 and element_type ctx protect final repl dyn_scope elt_desc =
4847 Types.protected = protect;
4848 final = bool_of_final final;
4849 replaceable = bool_of_replaceable repl;
4850 dynamic_scope = dynamic_scope_of_dynamic_scope dyn_scope;
4851 element_nature = element_nature_type ctx elt_desc
4854 and bool_of_replaceable = function
4856 | Some Syntax.Replaceable -> true
4858 and dynamic_scope_of_dynamic_scope = function
4860 | Some Syntax.Inner -> Some Types.Inner
4861 | Some Syntax.Outer -> Some Types.Outer
4862 | Some Syntax.InnerOuter -> Some Types.InnerOuter
4864 and element_nature_type ctx elt_desc =
4865 let elt_nat = match elt_desc.element_nature with
4866 | Component cpnt_desc -> Types.ComponentElement (evaluate cpnt_desc.component_type)
4867 | Class cl_def -> Types.ClassElement cl_def.class_type
4868 | ComponentType cpnt_type_desc ->
4869 Types.ComponentTypeElement (evaluate cpnt_type_desc.described_type)
4870 | PredefinedType predef -> Types.PredefinedTypeElement predef in
4873 and class_specifier_type ctx part kind cl_def cl_spec =
4874 let class_kind kind cl_type =
4875 let check_class () =
4876 if has_inouts cl_type then
4878 {err_msg = ["_CannotUseCausPrefixInGenClass";
4879 class_specifier_name cl_spec];
4881 err_ctx = ctx}) (*error*)
4883 and check_model () = kind
4884 and check_block () =
4886 {err_msg = ["_NotYetImplemented"; "_BlockElem"];
4889 and check_record () = kind
4890 and check_expandable_connector () =
4892 {err_msg = ["_NotYetImplemented"; "_ExpandableConnector"];
4895 and check_connector () = kind
4896 and check_package () = kind
4897 and check_function () = kind in
4899 | Types.Class -> check_class ()
4900 | Types.Model -> check_model ()
4901 | Types.Block -> check_block ()
4902 | Types.Record -> check_record ()
4903 | Types.ExpandableConnector -> check_expandable_connector ()
4904 | Types.Connector -> check_connector ()
4905 | Types.Package -> check_package ()
4906 | Types.Function -> check_function () in
4909 Types.partial = bool_of_partial part;
4910 kind = lazy (class_kind kind cl_type);
4911 named_elements = class_type_elements ctx kind cl_def
4913 Types.ClassType cl_type
4915 and bool_of_partial = function
4917 | Some Syntax.Partial -> true
4919 and class_type_elements ctx kind cl_def = match evaluate cl_def.description with
4920 | LongDescription long_desc -> long_description_type_elements ctx kind long_desc
4921 | ShortDescription short_desc -> short_description_type_elements ctx kind short_desc
4923 and short_description_type_elements ctx kind short_desc =
4924 let cl_type = evaluate short_desc.modified_class_type in
4925 let kind' = evaluate cl_type.Types.kind in
4926 match kind, kind' with
4927 | Types.Class, Types.Class |
4928 Types.Model, Types.Model |
4929 Types.Block, Types.Block |
4930 Types.Record, Types.Record |
4931 Types.ExpandableConnector, Types.ExpandableConnector |
4932 Types.Connector, Types.Connector |
4933 Types.Package, Types.Package |
4934 Types.Function, Types.Function -> cl_type.Types.named_elements
4935 | (Types.Class | Types.Model | Types.Block | Types.Record |
4936 Types.ExpandableConnector | Types.Connector | Types.Package | Types.Function),
4937 (Types.Class | Types.Model | Types.Block | Types.Record |
4938 Types.ExpandableConnector | Types.Connector | Types.Package | Types.Function) ->
4940 {err_msg = ["_InheritFromDiffClassKindsNotAllowed"];
4942 err_ctx = ctx}) (*error*)
4944 and long_description_type_elements ctx kind long_desc =
4945 let type_element (id, elt_desc) = id, elt_desc.element_type in
4946 let local_elts = List.map type_element long_desc.named_elements in
4947 let add_extensions kinds exts =
4948 let add_named_element protected named_elt named_elts =
4949 let element_type elt_type =
4950 let elt_type' = evaluate elt_type in
4951 { elt_type' with Types.protected =
4952 elt_type'.Types.protected || protected } in
4953 match named_elt with
4954 | id, _ when List.mem_assoc id named_elts ->
4956 {err_msg = [id; "_AlreadyDeclaredInParentClass"];
4958 err_ctx = ctx}) (*error*)
4959 | id, elt_type -> (id, lazy (element_type elt_type)) :: named_elts in
4960 let add_extension_contribution (visibility, modif_cl) named_elts =
4961 let protected = bool_of_visibility visibility
4962 and cl_type = evaluate modif_cl.modified_class_type in
4963 let named_elts' = cl_type.Types.named_elements in
4964 if List.mem (evaluate cl_type.Types.kind) kinds then
4965 List.fold_right (add_named_element protected) named_elts' named_elts
4968 {err_msg = ["_InheritFromDiffClassKindsNotAllowed"];
4970 err_ctx = ctx}) (*error*) in
4971 List.fold_right add_extension_contribution exts local_elts in
4972 match kind, long_desc.extensions with
4973 | Types.Function, [] -> local_elts
4974 | Types.Function, _ :: _ ->
4976 {err_msg = ["_InheritFromFunctionNotAllowed"];
4978 err_ctx = ctx}) (*error*)
4979 | (Types.Class | Types.Model | Types.Block | Types.Record | Types.Connector | Types.Package),
4980 exts -> add_extensions [kind] exts
4981 | Types.ExpandableConnector, exts ->
4982 add_extensions [kind; Types.Connector] exts
4984 and bool_of_visibility = function
4988 and has_inouts cl_type =
4989 let is_inout_component cpnt_type =
4990 match evaluate cpnt_type.Types.causality with
4991 | Types.Input | Types.Output -> true
4992 | Types.Acausal -> false in
4993 let is_inout = function
4994 | Types.ComponentElement cpnt_type -> is_inout_component cpnt_type
4995 | Types.ClassElement _ | Types.ComponentTypeElement _ |
4996 Types.PredefinedTypeElement _ -> false
4997 and element_nature (_, elt_type) = (evaluate elt_type).Types.element_nature in
4999 (function named_elt -> is_inout (element_nature named_elt))
5000 cl_type.Types.named_elements
5002 and component_type_of_expression ctx expr =
5003 match expr.info.type_description with
5004 | Types.ComponentElement cpnt_type -> cpnt_type
5005 | Types.ClassElement _ | Types.ComponentTypeElement _ |
5006 Types.PredefinedTypeElement _ ->
5008 {err_msg = ["_ClassElemFoundInExpr"];
5010 err_ctx = ctx}) (*error*)
5012 and scalar_class_specifier ctx expr =
5013 let rec scalar_class_specifier' cl_spec = match cl_spec with
5014 | Types.ArrayType (dim, cl_spec) ->
5015 scalar_class_specifier' cl_spec
5017 let cpnt_type = component_type_of_expression ctx expr in
5018 let cl_spec = evaluate cpnt_type.Types.base_class in
5019 scalar_class_specifier' cl_spec
5021 and expression_of_variable expr =
5022 let vector_variables vec_elts = match vec_elts.Syntax.nature with
5023 | Syntax.VectorReduction _ -> false
5024 | Syntax.VectorElements exprs ->
5025 List.for_all expression_of_variable exprs in
5026 match expr.Syntax.nature with
5027 | Syntax.Identifier _ -> true
5028 | Syntax.FieldAccess (expr', _) -> expression_of_variable expr'
5029 | Syntax.IndexedAccess (expr', subs) ->
5030 expression_of_variable expr'
5031 | Syntax.MatrixConstruction exprss ->
5032 List.for_all (List.for_all expression_of_variable) exprss
5033 | Syntax.Tuple exprs ->
5034 List.for_all expression_of_variable exprs
5035 | Syntax.Vector vec_elts -> vector_variables vec_elts
5038 and string_of_bin_oper_kind kind = match kind with
5041 | EqualEqual -> " == "
5042 | GreaterEqual -> " >= "
5044 | LessEqual -> " <= "
5047 | NotEqual -> " <> "
5053 and string_of_un_oper_kind kind = match kind with
5055 | UnaryMinus -> "- "
5058 and apply_binary_coercions exprs =
5059 let base_type expr =
5060 let rec base_type' cl_spec = match cl_spec with
5061 | Types.ArrayType (_, cl_spec) -> base_type' cl_spec
5062 | Types.PredefinedType pt -> Some pt.Types.base_type
5064 match expr.info.type_description with
5065 | Types.ComponentElement cpnt_type ->
5066 let cl_spec = evaluate cpnt_type.Types.base_class in
5069 and real_type bt = match bt with
5070 | Some Types.RealType -> true
5072 and integer_type bt = match bt with
5073 | Some Types.IntegerType -> true
5075 match List.map base_type exprs with
5076 | [] | [ _ ] -> exprs
5077 | bts when (List.exists real_type bts) &&
5078 (List.exists integer_type bts) ->
5079 let cpnt_type = Types.real_component_type Types.Continuous in
5080 List.map (apply_rhs_coercions cpnt_type) exprs
5083 and apply_rhs_coercions cpnt_type expr =
5084 let apply_real_of_integer cpnt_type cpnt_type' =
5085 let rec apply_real_of_integer' cl_spec cl_spec' =
5086 match cl_spec, cl_spec' with
5087 | Types.ArrayType (dim, cl_spec), _ ->
5088 apply_real_of_integer' cl_spec cl_spec'
5089 | _, Types.ArrayType (dim', cl_spec') ->
5090 let coer, cl_spec' = apply_real_of_integer' cl_spec cl_spec' in
5091 coer, Types.ArrayType (dim', cl_spec')
5092 | Types.PredefinedType { Types.base_type = Types.RealType },
5093 Types.PredefinedType { Types.base_type = Types.IntegerType } ->
5094 Some RealOfInteger, Types.real_class_type
5095 | _, _ -> None, cl_spec' in
5096 let cl_spec = evaluate cpnt_type.Types.base_class
5097 and cl_spec' = evaluate cpnt_type'.Types.base_class in
5098 match apply_real_of_integer' cl_spec cl_spec' with
5099 | Some RealOfInteger, cl_spec' ->
5103 Types.base_class = lazy cl_spec'
5105 and nat' = Coercion (RealOfInteger, expr) in
5106 let elt_nat' = Types.ComponentElement cpnt_type' in
5107 resolved_expression expr.info.syntax nat' elt_nat'
5109 match expr.info.type_description with
5110 | Types.ComponentElement cpnt_type' ->
5111 apply_real_of_integer cpnt_type cpnt_type'
5115 and string_of_expression expr = match expr.nature with
5116 | BinaryOperation (bin_oper_kind, expr, expr') ->
5117 Printf.sprintf "BinaryOperation(_, %s, %s)"
5118 (string_of_expression expr)
5119 (string_of_expression expr')
5120 | DynamicIdentifier (i, s) -> "DynamicIdentifier"
5122 | FieldAccess (expr, s) -> "FieldAccess"
5123 | FunctionArgument i -> "FunctionArgument"
5124 | FunctionCall (expr, exprs, expr') ->
5125 Printf.sprintf "FunctionCall(%s, {%s}, %s)"
5126 (string_of_expression expr)
5127 (String.concat "," (List.map string_of_expression exprs))
5128 (string_of_expression expr')
5129 | FunctionInvocation exprs -> "FunctionInvocation"
5130 | If (alts, expr) -> "If"
5131 | IndexedAccess (expr, exprs) -> "IndexedAccess"
5133 Printf.sprintf "Integer(%d)" (Int32.to_int i)
5134 | LocalIdentifier (i, s) ->
5135 Printf.sprintf "LocalIdentifier(%d, %s)" i s
5136 | LoopVariable i -> "LoopVariable"
5137 | NoEvent expr -> "NoEvent"
5138 | PredefinedIdentifier s ->
5139 Printf.sprintf "PredefinedIdentifier(%s)" s
5140 | Range (start, step, stop) ->
5141 Printf.sprintf "Range(%s, %s, %s)"
5142 (string_of_expression start)
5143 (string_of_expression step)
5144 (string_of_expression stop)
5146 | String s -> "String"
5147 | ToplevelIdentifier s -> "ToplevelIdentifier"
5149 | Tuple exprs -> "Tuple"
5150 | UnaryOperation (un_oper_kind, expr) -> "UnaryOperation"
5151 | Vector exprs -> "Vector"
5152 | VectorReduction (exprs, expr) -> "VectorReduction"
5153 | Coercion _ -> "Coercion"