-(*\r
- * Translator from Modelica 2.x to flat Modelica\r
- *\r
- * Copyright (C) 2005 - 2007 Imagine S.A.\r
- * For more information or commercial use please contact us at www.amesim.com\r
- *\r
- * This program is free software; you can redistribute it and/or\r
- * modify it under the terms of the GNU General Public License\r
- * as published by the Free Software Foundation; either version 2\r
- * of the License, or (at your option) any later version.\r
- *\r
- * This program is distributed in the hope that it will be useful,\r
- * but WITHOUT ANY WARRANTY; without even the implied warranty of\r
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\r
- * GNU General Public License for more details.\r
- *\r
- * You should have received a copy of the GNU General Public License\r
- * along with this program; if not, write to the Free Software\r
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.\r
- *\r
- *)\r
-\r
-(** Resolution of types for Modelica elements from the abstract syntax tree.\r
-The main functions are:\r
-{ul\r
-{- [ resolve_toplevel ]: Main function. Resolve a list of top level syntax element}\r
-{- [ resolve_variable_definition ]: Resolution of a variable definition}\r
-{- [ resolve_class_definition ]: Resolution of a class definition}\r
-{- [ resolve_modification ]: Resolution of modifications}\r
-{- [ resolve_expression ]: Resolution of syntax expressions\r
- {ul\r
- {- [ resolve_binary_operation ]: Resolve binary operation expression }\r
- {- [ resolve_unuary_operation ]: Resolve unary operation }\r
- {- [ resolve_identifier ]: scoping algorithm and resolution of identifiers}\r
- {- [ apply_binary_coercions, apply_rhs_coercions ]: Adding of Real to Integer implicit coercions}\r
- {- [ resolve_function_call ]: Resolution of a function call expression }\r
- {- [ resolve_field_access ]: Resolve field access }\r
- {- [ resolve_if ]: Resolve [ if ] expression }\r
- {- [ resolve_indexed_access ]: Resolve indexed access }\r
- {- [ resolve_vector ]: Resolve vector expression }\r
- {- [ resolve_range ]: resolve range expression }\r
- }\r
-}\r
-{- [ resolve_equation ]: Resolution of an equation\r
- {ul\r
- {- [ resolve_equal ]: Resolution of a simple equation of the form [ expr1 = expr2 ] }\r
- {- [ resolve_conditional_equation_e ]: Resolution of conditional equations }\r
- {- [ resolve_for_clause_e ]: Resolution of for equations }\r
- {- [ resolve_connect_clause ]: resolution of connect equations }\r
- {- [ resolve_when_clause_e ]: resolution of when equations}\r
- {- [ equations ]: resolution of array, record and for equations\r
- }\r
-}\r
-}\r
-*)\r
-\r
-(* The type [ node ] is used to attach syntax information to resolved elements *)\r
-type ('a, 'b) node =\r
- {\r
- nature: 'a;\r
- info: 'b\r
- }\r
-\r
-(* Type of resolved elements *)\r
-\r
-and element_description =\r
- {\r
- element_type: Types.element_type Lazy.t;\r
- redeclare: bool;\r
- element_nature: element_nature;\r
- element_location: Parser.location\r
- }\r
-\r
-and element_nature =\r
- | Component of component_description\r
- | Class of class_definition\r
- | ComponentType of component_type_description\r
- | PredefinedType of Types.predefined_type\r
-\r
-and component_description =\r
- {\r
- component_type: Types.component_type Lazy.t;\r
- type_specifier: expression Lazy.t;\r
- dimensions: dimension list Lazy.t;\r
- modification: modification option Lazy.t;\r
- comment: string\r
- }\r
-\r
-and dimension =\r
- | Colon\r
- | Expression of expression\r
-\r
-and class_definition =\r
- {\r
- class_type: Types.class_specifier Lazy.t;\r
- enclosing_class: class_definition option;\r
- encapsulated: bool;\r
- description: class_description Lazy.t;\r
- }\r
-\r
-and class_description =\r
- | LongDescription of long_description\r
- | ShortDescription of modified_class\r
-\r
-and long_description =\r
- {\r
- class_annotations: (annotation list) Lazy.t;\r
- imports: import_description list;\r
- extensions: (visibility * modified_class) list;\r
- named_elements: named_element list;\r
- unnamed_elements: equation_or_algorithm_clause list Lazy.t;\r
- external_call: external_call option Lazy.t\r
- }\r
-\r
-and annotation =\r
- | InverseFunction of inverse_function Lazy.t\r
- | UnknownAnnotation of (Parser.location Syntax.class_modification) Lazy.t\r
-\r
-and inverse_function =\r
- {\r
- function_class: expression;\r
- arguments: (string * string) list\r
- }\r
-\r
-and import_description = unit\r
-\r
-and visibility = Public | Protected\r
-\r
-and named_element = string * element_description\r
-\r
-and modified_class =\r
- {\r
- modified_class_type: Types.class_type Lazy.t;\r
- base_class: expression Lazy.t;\r
- class_modification: class_modification Lazy.t\r
- }\r
-\r
-and component_type_description =\r
- {\r
- described_type: Types.component_type Lazy.t;\r
- base_type: expression Lazy.t;\r
- type_dimensions: dimension list Lazy.t;\r
- type_modification: class_modification Lazy.t\r
- }\r
-\r
-and external_call = (external_call_desc, Parser.location Syntax.externalll) node\r
-\r
-and external_call_desc =\r
- | PrimitiveCall of string\r
- | ExternalProcedureCall of language *\r
- expression option (* rhs *) * string * expression list\r
-\r
-and language = C | FORTRAN\r
-\r
-and modification =\r
- | Modification of class_modification * expression Lazy.t option\r
- | Assignment of expression Lazy.t\r
- | Equality of expression Lazy.t\r
-\r
-and class_modification = modification_argument list\r
-\r
-and modification_argument =\r
- {\r
- each: bool;\r
- final: bool;\r
- target: string;\r
- action: modification_action option\r
- }\r
-\r
-and modification_action =\r
- | ElementModification of modification\r
- | ElementRedeclaration of element_description\r
-\r
-(* Type of equations and algorithms *)\r
-\r
-and equation_or_algorithm_clause =\r
- | EquationClause of validity * equation list\r
- | AlgorithmClause of validity * algorithm list\r
-\r
-and validity = Initial | Permanent\r
-\r
-and equation = (equation_desc, Parser.location Syntax.equation option) node\r
-\r
-and equation_desc =\r
- | Equal of expression * expression\r
- | ConditionalEquationE of (expression * equation list) list * equation list\r
- | ForClauseE of expression list (* ranges *) * equation list\r
- | ConnectFlows of sign * expression * sign * expression\r
- | WhenClauseE of (expression * equation list) list\r
-\r
-and sign = Positive | Negative\r
-\r
-and algorithm = (algorithm_desc, Parser.location Syntax.algorithm option) node\r
-\r
-and algorithm_desc =\r
- | Assign of expression * expression\r
- | FunctionCallA of expression * expression list\r
- | MultipleAssign of expression list * expression * expression list\r
- | Break\r
- | Return\r
- | ConditionalEquationA of (expression * algorithm list) list *\r
- algorithm list\r
- | ForClauseA of expression list (* ranges *) * algorithm list\r
- | WhileClause of expression * algorithm list\r
- | WhenClauseA of (expression * algorithm list) list\r
-\r
-(* Type of expressions *)\r
-\r
-and expression = (expression_desc, expression_information) node\r
-\r
-(* Type of a resolved expression:\r
-- [ syntax ]: expression syntax (this information is optional, some expressions\r
- are dynamicaly created during typing analysis)\r
-- [ type_description ]: expression type *)\r
-and expression_information =\r
- {\r
- syntax: Parser.location Syntax.expression option;\r
- type_description: Types.element_nature\r
- }\r
-\r
-and expression_desc =\r
- | BinaryOperation of binary_operator_kind * expression * expression\r
- | DynamicIdentifier of int (** number of nested classes to skip *) *\r
- string (** name to be searched for at instanciation time *)\r
- | False\r
- | FieldAccess of expression * string\r
- | FunctionArgument of int (** the position of the argument in the call *)\r
- | FunctionCall of expression (** function *) *\r
- expression list (** arguments *) *\r
- expression (** the expression involving the function call *)\r
- (** creation of a dynamic function context *)\r
- | FunctionInvocation of expression list\r
- (** invocation of the current function in context *)\r
- | If of (expression (** condition *) * expression) list *\r
- expression (** default *)\r
- | IndexedAccess of expression * expression list (* subscripts *)\r
- | Integer of int32\r
- | LocalIdentifier of int (** number of nested classes to skip *) *\r
- string (** key in the dictionary of the defining class *)\r
- | LoopVariable of int (** number of nested for loops to skip *)\r
- | NoEvent of expression\r
- | PredefinedIdentifier of string (** predefined identifier *)\r
- | Range of expression * expression * expression\r
- | Real of float\r
- | String of string\r
- | ToplevelIdentifier of string (** key in the toplevel dictionary *)\r
- | True\r
- | Tuple of expression list\r
- | UnaryOperation of unary_operator_kind * expression\r
- | Vector of expression list\r
- | VectorReduction of expression list (** nested ranges *) * expression\r
- | Coercion of coercion_kind * expression\r
-\r
-and coercion_kind =\r
- | RealOfInteger (** Implicit conversion of Integer to Real *)\r
-\r
-and unary_operator_kind =\r
- | Not\r
- | UnaryMinus\r
- | UnaryPlus\r
-\r
-and binary_operator_kind =\r
- | And\r
- | Divide\r
- | EqualEqual\r
- | GreaterEqual\r
- | Greater\r
- | LessEqual\r
- | Less\r
- | Times\r
- | NotEqual\r
- | Or\r
- | Plus\r
- | Power\r
- | Minus\r
-\r
-(* Context types. Contexts are used to resolve identifiers in expressions *)\r
-\r
-type context =\r
- {\r
- toplevel: (string * element_description) list Lazy.t;\r
- context_nature: context_nature;\r
- location: Parser.location\r
- }\r
-\r
-and context_nature =\r
- | ToplevelContext\r
- | ClassContext of class_definition\r
- | SubscriptContext of\r
- context * expression (* evaluating to an array *) *\r
- int32 (* dimension index *) * Types.dimension\r
- | ForContext of context * string * Types.element_nature\r
-\r
-(* Type Errors detected during compilation *)\r
-\r
-type error_description =\r
- {\r
- err_msg: string list;\r
- err_info: (string * string) list;\r
- err_ctx: context\r
- }\r
-\r
-exception CompilError of error_description\r
-\r
-(* Utilities *)\r
-\r
-let evaluate x = Lazy.force x\r
-\r
-let resolve_elements add_element elts other_elts =\r
- let resolve_other_elements other_elt acc = match other_elt.Syntax.nature with\r
- | Syntax.Public elts -> List.fold_right (add_element Public) elts acc\r
- | Syntax.Protected elts -> List.fold_right (add_element Protected) elts acc\r
- | Syntax.EquationClause _ | Syntax.AlgorithmClause _ -> acc in\r
- List.fold_right\r
- (add_element Public)\r
- elts\r
- (List.fold_right resolve_other_elements other_elts [])\r
-\r
-let resolved_expression syntax nat elt_nat =\r
- {\r
- nature = nat;\r
- info = { syntax = syntax; type_description = elt_nat }\r
- }\r
-\r
-let one =\r
- let nat = Integer 1l\r
- and elt_nat = Types.integer_type Types.Constant in\r
- resolved_expression None nat elt_nat\r
-\r
-\r
-(* Name resolution functions *)\r
-\r
-let rec resolve_toplevel dic nodes =\r
- let add_element ctx acc (id, elt_desc) =\r
- match List.mem_assoc id acc with\r
- | true ->\r
- let ctx = { ctx with location = elt_desc.element_location } in\r
- raise (CompilError\r
- {err_msg = ["_DuplicateDeclarationOfElement"; id];\r
- err_info = [];\r
- err_ctx = ctx}) (*error*)\r
- | false -> acc @ [ (id, elt_desc) ] in\r
- let rec ctx =\r
- {\r
- toplevel =\r
- lazy (List.fold_left (add_element ctx) dic (evaluate elt_descs));\r
- context_nature = ToplevelContext;\r
- location =\r
- {\r
- Parser.start = 0;\r
- Parser.enddd = 0;\r
- Parser.filename = Parser.CommandLine\r
- }\r
- }\r
- and elt_descs = lazy (resolve_toplevel_nodes ctx nodes) in\r
- evaluate ctx.toplevel\r
-\r
-and resolve_toplevel_nodes ctx nodes =\r
- let rec resolve_toplevel_nodes' nodes' =\r
- match nodes' with\r
- | [] -> []\r
- | node :: nodes' ->\r
- (resolve_toplevel_statements ctx node) @\r
- (resolve_toplevel_nodes' nodes') in\r
- let collect_toplevel_defs (cl_defs, nodes) node =\r
- match node.Syntax.nature with\r
- | Syntax.ClassDefinitions cl_defs' -> cl_defs' @ cl_defs, nodes\r
- | _ -> cl_defs, [node] @ nodes in\r
- let cl_defs, nodes = List.fold_left collect_toplevel_defs ([], []) nodes in\r
- let node = {Syntax.nature = Syntax.ClassDefinitions cl_defs;\r
- Syntax.info = ctx.location} in\r
- (resolve_toplevel_statements ctx node) @\r
- resolve_toplevel_nodes' nodes\r
-\r
-and resolve_toplevel_statements ctx node = match node.Syntax.nature with\r
- | Syntax.ClassDefinitions cl_defs -> resolve_class_definitions ctx cl_defs\r
- | Syntax.Expression expr -> raise (CompilError\r
- {err_msg = ["_NotYetImplemented"; "_TopLevelExpr"];\r
- err_info = [];\r
- err_ctx = {ctx with location = expr.Syntax.info}})\r
- | Syntax.VariablesDefinitions (expr, subs, cpnt_decls) ->\r
- resole_variables_definitions ctx expr subs cpnt_decls\r
- | Syntax.Command algo -> raise (CompilError\r
- {err_msg = ["_NotYetImplemented"; "_TopLevelAlgorithm"];\r
- err_info = [];\r
- err_ctx = {ctx with location = algo.Syntax.info}})\r
- | Syntax.Within path -> raise (CompilError\r
- {err_msg = ["_NotYetImplemented"; "_WithinClause"];\r
- err_info = [("_Expr", Syntax.string_of_toplevel_element node)];\r
- err_ctx = {ctx with location = node.Syntax.info}})\r
- | Syntax.Import imprt -> raise (CompilError\r
- {err_msg = ["_NotYetImplemented"; "_ImportClause"];\r
- err_info = [("_Expr", Syntax.string_of_toplevel_element node)];\r
- err_ctx = {ctx with location = imprt.Syntax.info}})\r
-\r
-and resole_variables_definitions ctx expr subs cpnt_decls =\r
- let type_spec = lazy (resolve_expression ctx expr)\r
- and dims = lazy (resolve_dimensions ctx subs) in\r
- List.map (resolve_variable_definition ctx type_spec dims expr) cpnt_decls\r
-\r
-and resolve_variable_definition ctx type_spec dims expr cpnt_decl =\r
- let type_pref = false, None, Types.Acausal in\r
- let id, elt_nat, elt_loc =\r
- resolve_component_declaration ctx type_pref type_spec dims expr cpnt_decl in\r
- let rec elt_desc =\r
- {\r
- element_type =\r
- lazy (element_type ctx false None None None elt_desc);\r
- redeclare = false;\r
- element_nature = elt_nat;\r
- element_location = elt_loc\r
- } in\r
- id, elt_desc\r
-\r
-and resolve_class_definitions ctx cl_defs =\r
- List.map (resolve_class_definition ctx) cl_defs\r
-\r
-and resolve_class_definition ctx cl_def = match cl_def.Syntax.nature with\r
- | Syntax.ClassDefinition (final, def) ->\r
- let loc = (match def.Syntax.nature with\r
- | Syntax.Definition (_, _, _, cl_spec) -> cl_spec.Syntax.info) in\r
- let rec elt_desc =\r
- {\r
- element_type = lazy (element_type ctx false final None None elt_desc);\r
- redeclare = false;\r
- element_nature = resolve_definition ctx def;\r
- element_location = loc\r
- } in\r
- let s = class_definition_name def in\r
- s, elt_desc\r
-\r
-and class_definition_name def = match def.Syntax.nature with\r
- | Syntax.Definition (_, _, _, cl_spec) -> class_specifier_name cl_spec\r
-\r
-and class_specifier_name cl_spec = match cl_spec.Syntax.nature with\r
- | Syntax.LongSpecifier (id, _, _) |\r
- Syntax.ShortSpecifier (id, _, _, _, _, _) |\r
- Syntax.EnumerationSpecifier (id, _, _) |\r
- Syntax.ExtensionSpecifier (id, _, _, _) -> id\r
-\r
-and resolve_definition ctx def =\r
- let ctx = {ctx with location = def.Syntax.info} in \r
- match def.Syntax.nature with\r
- | Syntax.Definition (encap, part, kind, cl_spec) ->\r
- resolve_specification ctx encap part kind cl_spec\r
-\r
-and resolve_specification ctx encap part kind cl_spec =\r
- let encap' = bool_of_encapsulated encap in\r
- match kind with\r
- | Syntax.Class ->\r
- resolve_class_specification ctx encap' part Types.Class cl_spec\r
- | Syntax.Model ->\r
- resolve_class_specification ctx encap' part Types.Model cl_spec\r
- | Syntax.Block ->\r
- resolve_class_specification ctx encap' part Types.Block cl_spec\r
- | Syntax.Record ->\r
- resolve_class_specification ctx encap' part Types.Record cl_spec\r
- | Syntax.ExpandableConnector ->\r
- resolve_class_specification\r
- ctx\r
- encap'\r
- part\r
- Types.ExpandableConnector\r
- cl_spec\r
- | Syntax.Connector ->\r
- resolve_class_specification ctx encap' part Types.Connector cl_spec\r
- | Syntax.Type when encap' ->\r
- raise (CompilError\r
- {err_msg = ["_EncapsulatedCannotBeAppliedTo"; "_TypeDef"];\r
- err_info = [];\r
- err_ctx = ctx}) (*error*)\r
- | Syntax.Type -> resolve_type_specification ctx cl_spec\r
- | Syntax.Package ->\r
- resolve_class_specification ctx encap' part Types.Package cl_spec\r
- | Syntax.Function ->\r
- resolve_class_specification ctx encap' part Types.Function cl_spec\r
-\r
-and resolve_type_specification ctx cl_spec =\r
- let ctx = {ctx with location = cl_spec.Syntax.info} in\r
- match cl_spec.Syntax.nature with\r
- | Syntax.LongSpecifier _ ->\r
- raise (CompilError\r
- {err_msg = ["_InvalidTypeDef"];\r
- err_info = [];\r
- err_ctx = ctx}) (*error*)\r
- | Syntax.ExtensionSpecifier _ ->\r
- raise (CompilError\r
- {err_msg = ["_InvalidTypeDef"];\r
- err_info = [];\r
- err_ctx = ctx}) (*error*)\r
- | Syntax.ShortSpecifier (_, base_pref, cl_spec, subs, cl_modif, _) ->\r
- let cpnt_type =\r
- resolve_type_composition ctx base_pref cl_spec subs cl_modif in\r
- ComponentType cpnt_type\r
- | Syntax.EnumerationSpecifier (idt, enum_comp, _) ->\r
- let enum_type = resolve_enumeration_composition ctx enum_comp in\r
- PredefinedType enum_type\r
-\r
-and resolve_type_composition ctx base_pref cl_spec subs cl_modif =\r
- let base_pref' = type_prefix base_pref\r
- and base_type = lazy (resolve_expression ctx cl_spec)\r
- and dims = lazy (resolve_dimensions ctx subs) in\r
- let cpnt_type = lazy (component_type ctx base_pref' base_type dims) in\r
- let cl_modif' = lazy (resolve_type_modification ctx cpnt_type cl_modif) in\r
- {\r
- described_type = lazy (modified_described_type ctx cpnt_type cl_modif');\r
- base_type = base_type;\r
- type_dimensions = dims;\r
- type_modification = cl_modif'\r
- }\r
-\r
-and resolve_enumeration_composition ctx enum_comp =\r
- let resolve_enumeration_literal enum_lit ids =\r
- match enum_lit.Syntax.nature with\r
- | Syntax.EnumerationLiteral (id, _) when List.mem id ids ->\r
- raise (CompilError\r
- {err_msg = ["_EnumTypeDefWithDuplicLit"; id];\r
- err_info = [];\r
- err_ctx = {ctx with location = enum_lit.Syntax.info}}) (*error*)\r
- | Syntax.EnumerationLiteral (id, _) -> id :: ids in\r
- match enum_comp.Syntax.nature with\r
- | Syntax.EnumList (Some enum_lits) ->\r
- let elts = List.fold_right resolve_enumeration_literal enum_lits [] in\r
- {\r
- Types.base_type = Types.EnumerationType elts;\r
- attributes = ["start", false]\r
- }\r
- | Syntax.EnumList None ->\r
- raise (CompilError\r
- {err_msg = ["_UnspecifiedEnumLits"];\r
- err_info = [];\r
- err_ctx = {ctx with location = enum_comp.Syntax.info}}) (*error*)\r
- | Syntax.EnumColon ->\r
- raise (CompilError\r
- {err_msg = ["_UnspecifiedEnumLits"];\r
- err_info = [];\r
- err_ctx = {ctx with location = enum_comp.Syntax.info}}) (*error*)\r
-\r
-and resolve_class_specification ctx encap part kind cl_spec =\r
- let ctx = {ctx with location = cl_spec.Syntax.info} in\r
- let resolve_specifier encap' cl_def =\r
- let ctx' = {ctx with context_nature = ClassContext cl_def} in\r
- resolve_class_specifier ctx ctx' encap cl_spec in\r
- let rec cl_def =\r
- {\r
- class_type = lazy (class_specifier_type ctx part kind cl_def cl_spec);\r
- enclosing_class = enclosing_class ctx;\r
- encapsulated = encap;\r
- description = lazy (resolve_specifier encap cl_def)\r
- } in\r
- Class cl_def\r
-\r
-and enclosing_class ctx = match ctx.context_nature with\r
- | ToplevelContext -> None\r
- | ClassContext cl_def -> Some cl_def\r
- | SubscriptContext (ctx, _, _, _) |\r
- ForContext (ctx, _, _) -> enclosing_class ctx\r
-\r
-and bool_of_encapsulated = function\r
- | None -> false\r
- | Some Syntax.Encapsulated -> true\r
-\r
-and resolve_class_specifier ctx ctx' encap cl_spec =\r
- let ctx = {ctx with location = cl_spec.Syntax.info}\r
- and ctx' = {ctx' with location = cl_spec.Syntax.info} in\r
- match cl_spec.Syntax.nature with\r
- | Syntax.LongSpecifier (_, _, comp) ->\r
- LongDescription (resolve_composition ctx ctx' comp)\r
- | Syntax.ShortSpecifier _ when encap ->\r
- raise (CompilError\r
- {err_msg = ["_EncapsulatedCannotBeAppliedTo"; "_ShortClassDef"];\r
- err_info = [];\r
- err_ctx = ctx}) (*error*)\r
- | Syntax.ShortSpecifier (_, base_pref, cl_spec, subs, cl_modif, _) ->\r
- let short_desc =\r
- resolve_short_specifier ctx base_pref cl_spec subs cl_modif in\r
- ShortDescription short_desc\r
- | Syntax.ExtensionSpecifier _ when encap ->\r
- raise (CompilError\r
- {err_msg = ["_EncapsulatedCannotBeAppliedTo"; "_ClassDefByExtension"];\r
- err_info = [];\r
- err_ctx = ctx}) (*error*)\r
- | Syntax.ExtensionSpecifier (id , cl_modif, _, comp) ->\r
- let long_desc =\r
- resolve_extension_composition ctx ctx' id cl_modif comp in\r
- LongDescription long_desc\r
- | Syntax.EnumerationSpecifier _ ->\r
- raise (CompilError\r
- {err_msg = ["_InvalidUseOfEnumKeyword"];\r
- err_info = [];\r
- err_ctx = ctx}) (*error*)\r
-\r
-and resolve_short_specifier ctx base_pref cl_spec subs cl_modif =\r
- let ctx = {ctx with location = cl_spec.Syntax.info} in\r
- match base_pref.Syntax.nature, subs with\r
- | Syntax.TypePrefix (None, None, None), None ->\r
- resolve_modified_class ctx ctx cl_spec cl_modif\r
- | (Syntax.TypePrefix (Some _, _, _) | Syntax.TypePrefix (_, Some _, _) |\r
- Syntax.TypePrefix (_, _, Some _)), _ ->\r
- raise (CompilError\r
- {err_msg = ["_UseOfTypePrefixInShortClassDef"];\r
- err_info =\r
- [("_TypePrefix", Syntax.string_of_base_prefix base_pref)];\r
- err_ctx = {ctx with location = base_pref.Syntax.info}}) (*error*)\r
- | Syntax.TypePrefix (None, None, None), Some subs ->\r
- raise (CompilError\r
- {err_msg = ["_UseOfSubsInShortClassDef"];\r
- err_info = [];\r
- err_ctx = {ctx with location = subs.Syntax.info}}) (*error*)\r
-\r
-and resolve_extension_composition ctx ctx' id cl_modif comp =\r
- raise (CompilError\r
- {err_msg = ["_NotYetImplemented"; "_ClassExtendsDef"];\r
- err_info = [];\r
- err_ctx = ctx})\r
-\r
-and resolve_composition ctx ctx' comp = match comp.Syntax.nature with\r
- | Syntax.Composition (elts, other_elts, extern) ->\r
- {\r
- class_annotations = lazy (resolve_class_annotations ctx' elts other_elts);\r
- imports = resolve_imports ctx' elts other_elts;\r
- extensions = resolve_extensions ctx ctx' elts other_elts;\r
- named_elements = resolve_named_elements ctx' elts other_elts;\r
- unnamed_elements = lazy (resolve_unnamed_elements ctx' other_elts);\r
- external_call = lazy (resolve_external_call ctx' extern)\r
- }\r
-\r
-and resolve_external_call ctx extern =\r
- let resolve_external_call' extern' = match extern'.Syntax.nature with\r
- | Syntax.External (Some id, None, _, _) ->\r
- { nature = PrimitiveCall id; info = extern' }\r
- | Syntax.External (Some lang, Some extern_call, _, _) ->\r
- raise (CompilError\r
- {err_msg = ["_NotYetImplemented"; "_ExternalProcedureCall"];\r
- err_info = [];\r
- err_ctx =\r
- {ctx with location = extern'.Syntax.info}}) (*error*)\r
- | Syntax.External (None, _, _, _) ->\r
- { nature = PrimitiveCall "C"; info = extern' } in\r
- (*raise (CompilError\r
- {err_msg = ["_UnspecifiedExtCallLang"];\r
- err_info = [];\r
- err_ctx =\r
- {ctx with location = extern'.Syntax.info}}) (*error*) in*)\r
- match extern with\r
- | None -> None\r
- | Some extern' -> Some (resolve_external_call' extern')\r
-\r
-and resolve_class_annotations ctx elts other_elts =\r
- let add_class_annotation vis elt anns = match vis, elt.Syntax.nature with\r
- | _, Syntax.ClassAnnotation ann ->\r
- begin match resolve_class_annotation ctx ann with\r
- | [] -> anns\r
- | anns' -> anns' @ anns\r
- end\r
- | _, (Syntax.ImportClause _ | Syntax.ExtendsClause _ |\r
- Syntax.ElementDefinition _) -> anns in\r
- resolve_elements add_class_annotation elts other_elts\r
-\r
-and resolve_imports ctx elts other_elts =\r
- let add_import vis elt imps = match vis, elt.Syntax.nature with\r
- | _, Syntax.ImportClause (imp_clause, _) ->\r
- resolve_import_clause ctx imp_clause :: imps\r
- | _, (Syntax.ClassAnnotation _ | Syntax.ExtendsClause _ |\r
- Syntax.ElementDefinition _) -> imps in\r
- resolve_elements add_import elts other_elts\r
-\r
-and resolve_extensions ctx ctx' elts other_elts =\r
- let add_extension vis elt exts = match vis, elt.Syntax.nature with\r
- | Public, Syntax.ExtendsClause (ext_clause, _) ->\r
- (Public, resolve_extends_clause ctx ctx' ext_clause) :: exts\r
- | Protected, Syntax.ExtendsClause (ext_clause, _) ->\r
- (Protected, resolve_extends_clause ctx ctx' ext_clause) :: exts\r
- | _, (Syntax.ClassAnnotation _ | Syntax.ImportClause _ |\r
- Syntax.ElementDefinition _) -> exts in\r
- resolve_elements add_extension elts other_elts\r
-\r
-and resolve_named_elements ctx elts other_elts =\r
- let add_named_element (id, elt_desc) elts =\r
- match List.mem_assoc id elts with\r
- | true ->\r
- raise (CompilError\r
- {err_msg = ["_DuplicateDeclarationOfElement"; id];\r
- err_info = [];\r
- err_ctx = ctx}) (*error*)\r
- | false -> (id, elt_desc) :: elts in\r
- let add_named_elements vis elt elts = match vis, elt.Syntax.nature with\r
- | Public,\r
- Syntax.ElementDefinition (redecl, final, dyn_scope, elt_def, _) ->\r
- let elts' =\r
- resolve_element_definition ctx false redecl final dyn_scope elt_def in\r
- List.fold_right add_named_element elts' elts\r
- | Protected,\r
- Syntax.ElementDefinition (redecl, final, dyn_scope, elt_def, _) ->\r
- let elts' =\r
- resolve_element_definition ctx true redecl final dyn_scope elt_def in\r
- List.fold_right add_named_element elts' elts\r
- | _, (Syntax.ClassAnnotation _ | Syntax.ImportClause _ |\r
- Syntax.ExtendsClause _) -> elts in\r
- resolve_elements add_named_elements elts other_elts\r
-\r
-and resolve_class_annotation ctx ann =\r
- let rec resolve_class_annotation' cl_modif =\r
- let add_annotation_information arg acc = match arg.Syntax.nature with\r
- | Syntax.ElementModification (\r
- None,\r
- None,\r
- { Syntax.nature = Syntax.Identifier "Imagine" },\r
- Some\r
- {\r
- Syntax.nature =\r
- Syntax.Modification (\r
- {\r
- Syntax.nature =\r
- Syntax.ClassModification\r
- [\r
- {\r
- Syntax.nature =\r
- Syntax.ElementModification (\r
- None,\r
- None,\r
- {\r
- Syntax.nature = Syntax.Identifier "AMESim"\r
- },\r
- Some\r
- {\r
- Syntax.nature =\r
- Syntax.Modification (cl_modif, None)\r
- },\r
- [])\r
- }\r
- ]\r
- },\r
- None)\r
- },\r
- []) -> add_amesim_annotations ctx cl_modif acc\r
- | Syntax.ElementModification _ | Syntax.ElementRedeclaration _ ->\r
- (UnknownAnnotation (lazy cl_modif)) :: acc in\r
- match cl_modif.Syntax.nature with\r
- | Syntax.ClassModification args ->\r
- List.fold_right add_annotation_information args [] in\r
- match ann.Syntax.nature with\r
- | Syntax.Annotation cl_modif -> resolve_class_annotation' cl_modif\r
-\r
-and add_amesim_annotations ctx cl_modif acc =\r
- let add_inverse_declarations cl_modif =\r
- let add_inverse_declaration arg acc =\r
- let add_inverse_declaration' expr modif =\r
- match expr.Syntax.nature, modif.Syntax.nature with\r
- | Syntax.IndexedAccess (\r
- { Syntax.nature = Syntax.Identifier "inverse" }, _),\r
- Syntax.Eq\r
- {\r
- Syntax.nature =\r
- Syntax.FunctionCall (expr, Some fun_args)\r
- } -> (resolve_inverse_declaration ctx expr fun_args) :: acc\r
- | _ ->\r
- raise (CompilError\r
- {err_msg = ["_InvalidAnnOfInvFunc"; "_InvalidModifExpr"];\r
- err_info = [];\r
- err_ctx =\r
- {ctx with location = expr.Syntax.info}}) (*error*) in\r
- match arg.Syntax.nature with\r
- | Syntax.ElementModification (Some _, _, _, _, _) ->\r
- raise (CompilError\r
- {err_msg = ["_InvalidAnnOfInvFunc"; "_UseOfEachKeywordNotAllowed"];\r
- err_info = [];\r
- err_ctx = {ctx with location = arg.Syntax.info}}) (*error*)\r
- | Syntax.ElementModification (None, Some _, _, _, _) ->\r
- raise (CompilError\r
- {err_msg = ["_InvalidAnnOfInvFunc"; "_UseOfFinalKeywordNotAllowed"];\r
- err_info = [];\r
- err_ctx = {ctx with location = arg.Syntax.info}}) (*error*)\r
- | Syntax.ElementModification (None, None, _, None, _) ->\r
- raise (CompilError\r
- {err_msg = ["_InvalidAnnOfInvFunc"; "_UnspecifiedModification"];\r
- err_info = [];\r
- err_ctx = {ctx with location = arg.Syntax.info}}) (*error*)\r
- | Syntax.ElementModification (None, None, expr, Some modif, _) ->\r
- add_inverse_declaration' expr modif\r
- | Syntax.ElementRedeclaration _ ->\r
- raise (CompilError\r
- {err_msg = ["_InvalidAnnOfInvFunc"; "_RedeclarationNotAllowed"];\r
- err_info = [];\r
- err_ctx = {ctx with location = arg.Syntax.info}}) (*error*) in\r
- match cl_modif.Syntax.nature with\r
- | Syntax.ClassModification args ->\r
- List.fold_right add_inverse_declaration args acc in\r
- match cl_modif.Syntax.nature with\r
- | Syntax.ClassModification\r
- [\r
- {\r
- Syntax.nature =\r
- Syntax.ElementModification (\r
- None,\r
- None,\r
- {\r
- Syntax.nature = Syntax.Identifier "InverseFunctions"\r
- },\r
- Some\r
- {\r
- Syntax.nature =\r
- Syntax.Modification (cl_modif, None)\r
- },\r
- [])\r
- }\r
- ] -> add_inverse_declarations cl_modif\r
- | Syntax.ClassModification _ -> acc\r
-\r
-and resolve_inverse_declaration ctx expr fun_args =\r
- let inverse_function_arguments expr' fun_args =\r
- let map_function_arguments named_args =\r
- let map_function_argument arg =\r
- match arg.Syntax.nature with\r
- | Syntax.NamedArgument (id, expr)\r
- when List.mem_assoc id named_args ->\r
- let expr' = resolve_expression ctx expr in\r
- begin match expr'.nature with\r
- | LocalIdentifier (0, id') -> id, id'\r
- | _ ->\r
- raise (CompilError\r
- {err_msg = ["_InvalidAnnOfInvFunc";\r
- "_InvalidFuncArgModif"];\r
- err_info = [];\r
- err_ctx =\r
- {ctx with\r
- location = expr.Syntax.info}}) (*error*)\r
- end\r
- | Syntax.NamedArgument (id, expr) ->\r
- raise (CompilError\r
- {err_msg = ["_InvalidAnnOfInvFunc";\r
- "_UnknownArgName"; id];\r
- err_info = [];\r
- err_ctx =\r
- {ctx with location = arg.Syntax.info}}) (*error*)\r
- | Syntax.Argument _ ->\r
- raise (CompilError\r
- {err_msg = ["_InvalidAnnOfInvFunc";\r
- "_CannotUseUnnamedFuncArg"];\r
- err_info = [];\r
- err_ctx =\r
- {ctx with location = arg.Syntax.info}}) (*error*) in\r
- match fun_args.Syntax.nature with\r
- | Syntax.ArgumentList args -> List.map map_function_argument args\r
- | Syntax.Reduction _ ->\r
- raise (CompilError\r
- {err_msg = ["_InvalidAnnOfInvFunc";\r
- "_FuncArgReductionNotAllowed"];\r
- err_info = [];\r
- err_ctx =\r
- {ctx with location = fun_args.Syntax.info}}) (*error*) in\r
- let inverse_function_arguments' cl_type =\r
- match cl_type.Types.partial, evaluate cl_type.Types.kind with\r
- | true, _ ->\r
- raise (CompilError\r
- {err_msg = ["_InvalidAnnOfInvFunc";\r
- "_UseOfPartialClassElement"];\r
- err_info = [("_ElementFound",\r
- Syntax.string_of_expression expr)];\r
- err_ctx =\r
- {ctx with location = expr.Syntax.info}}) (*error*)\r
- | false, Types.Function ->\r
- map_function_arguments cl_type.Types.named_elements\r
- | _, kind ->\r
- raise (CompilError\r
- {err_msg = ["_InvalidAnnOfInvFunc";\r
- "_InvalidTypeOfFuncCallExpr"];\r
- err_info = [("_ExpectedType", "_Function");\r
- ("_TypeFound", Types.string_of_kind kind)];\r
- err_ctx =\r
- {ctx with location = expr.Syntax.info}}) (*error*) in\r
- let elt_nat = expr'.info.type_description in\r
- match elt_nat with\r
- | Types.ClassElement cl_spec ->\r
- let cl_spec = evaluate cl_spec in\r
- begin match cl_spec with\r
- | Types.ClassType cl_type ->\r
- inverse_function_arguments' cl_type\r
- | _ ->\r
- raise (CompilError\r
- {err_msg = ["_InvalidAnnOfInvFunc";\r
- "_InvalidTypeOfFuncCallExpr"];\r
- err_info =\r
- [("_ExpectedType", "_ClassType");\r
- ("_TypeFound",\r
- Types.string_of_class_specifier cl_spec)];\r
- err_ctx =\r
- {ctx with location = expr.Syntax.info}}) (*error*)\r
- end\r
- | Types.ComponentTypeElement _ ->\r
- raise (CompilError\r
- {err_msg = ["_InvalidAnnOfInvFunc";\r
- "_InvalidTypeOfFuncCallExpr"];\r
- err_info = [("_ExpectedType", "_ClassElement");\r
- ("_TypeFound", "_ComponentTypeElement")];\r
- err_ctx =\r
- {ctx with location = expr.Syntax.info}}) (*error*)\r
- | Types.PredefinedTypeElement _ ->\r
- raise (CompilError\r
- {err_msg = ["_InvalidAnnOfInvFunc";\r
- "_InvalidTypeOfFuncCallExpr"];\r
- err_info = [("_ExpectedType", "_ClassElement");\r
- ("_TypeFound", "_PredefinedTypeElement")];\r
- err_ctx =\r
- {ctx with location = expr.Syntax.info}}) (*error*)\r
- | Types.ComponentElement _ ->\r
- raise (CompilError\r
- {err_msg = ["_InvalidAnnOfInvFunc";\r
- "_InvalidTypeOfFuncCallExpr"];\r
- err_info = [("_ExpectedType", "_ClassElement");\r
- ("_TypeFound", "_ComponentElement")];\r
- err_ctx =\r
- {ctx with location = expr.Syntax.info}}) (*error*) in\r
- let expr' = resolve_expression ctx expr in\r
- match expr'.nature with\r
- | ToplevelIdentifier _ | LocalIdentifier _ ->\r
- InverseFunction\r
- (lazy\r
- {\r
- function_class = expr';\r
- arguments = inverse_function_arguments expr' fun_args\r
- })\r
- | _ ->\r
- raise (CompilError\r
- {err_msg = ["_InvalidAnnOfInvFunc"; "_InvalidFuncCallExpr"];\r
- err_info = [];\r
- err_ctx =\r
- {ctx with location = expr.Syntax.info}}) (*error*)\r
-\r
-(*and resolve_inverse_function_annotation ctx ann =\r
- let rec resolve_class_annotation' cl_modif =\r
- let resolve_inverse_declaration expr fun_args =\r
- let inverse_function_arguments expr' fun_args =\r
- let map_function_arguments named_args =\r
- let map_function_argument arg =\r
- match arg.Syntax.nature with\r
- | Syntax.NamedArgument (id, expr)\r
- when List.mem_assoc id named_args ->\r
- let expr' = resolve_expression ctx expr in\r
- begin match expr'.nature with\r
- | LocalIdentifier (0, id') -> id, id'\r
- | _ ->\r
- raise (CompilError\r
- {err_msg = ["_InvalidAnnOfInvFunc";\r
- "_InvalidFuncArgModif"];\r
- err_info = [];\r
- err_ctx =\r
- {ctx with\r
- location = expr.Syntax.info}}) (*error*)\r
- end\r
- | Syntax.NamedArgument (id, expr) ->\r
- raise (CompilError\r
- {err_msg = ["_InvalidAnnOfInvFunc";\r
- "_UnknownArgName"; id];\r
- err_info = [];\r
- err_ctx =\r
- {ctx with location = arg.Syntax.info}}) (*error*)\r
- | Syntax.Argument _ ->\r
- raise (CompilError\r
- {err_msg = ["_InvalidAnnOfInvFunc";\r
- "_CannotUseUnnamedFuncArg"];\r
- err_info = [];\r
- err_ctx =\r
- {ctx with location = arg.Syntax.info}}) (*error*) in\r
- match fun_args.Syntax.nature with\r
- | Syntax.ArgumentList args -> List.map map_function_argument args\r
- | Syntax.Reduction _ ->\r
- raise (CompilError\r
- {err_msg = ["_InvalidAnnOfInvFunc";\r
- "_FuncArgReductionNotAllowed"];\r
- err_info = [];\r
- err_ctx =\r
- {ctx with location = fun_args.Syntax.info}}) (*error*) in\r
- let inverse_function_arguments' cl_type =\r
- match cl_type.Types.partial, evaluate cl_type.Types.kind with\r
- | true, _ ->\r
- raise (CompilError\r
- {err_msg = ["_InvalidAnnOfInvFunc";\r
- "_UseOfPartialClassElement"];\r
- err_info = [("_ElementFound",\r
- Syntax.string_of_expression expr)];\r
- err_ctx =\r
- {ctx with location = expr.Syntax.info}}) (*error*)\r
- | false, Types.Function ->\r
- map_function_arguments cl_type.Types.named_elements\r
- | _, kind ->\r
- raise (CompilError\r
- {err_msg = ["_InvalidAnnOfInvFunc";\r
- "_InvalidTypeOfFuncCallExpr"];\r
- err_info = [("_ExpectedType", "_Function");\r
- ("_TypeFound", Types.string_of_kind kind)];\r
- err_ctx =\r
- {ctx with location = expr.Syntax.info}}) (*error*) in\r
- let elt_nat = expr'.info.type_description in\r
- match elt_nat with\r
- | Types.ClassElement cl_spec ->\r
- let cl_spec = evaluate cl_spec in\r
- begin match cl_spec with\r
- | Types.ClassType cl_type ->\r
- inverse_function_arguments' cl_type\r
- | _ ->\r
- raise (CompilError\r
- {err_msg = ["_InvalidAnnOfInvFunc";\r
- "_InvalidTypeOfFuncCallExpr"];\r
- err_info =\r
- [("_ExpectedType", "_ClassType");\r
- ("_TypeFound",\r
- Types.string_of_class_specifier cl_spec)];\r
- err_ctx =\r
- {ctx with location = expr.Syntax.info}}) (*error*)\r
- end\r
- | Types.ComponentTypeElement _ ->\r
- raise (CompilError\r
- {err_msg = ["_InvalidAnnOfInvFunc";\r
- "_InvalidTypeOfFuncCallExpr"];\r
- err_info = [("_ExpectedType", "_ClassElement");\r
- ("_TypeFound", "_ComponentTypeElement")];\r
- err_ctx =\r
- {ctx with location = expr.Syntax.info}}) (*error*)\r
- | Types.PredefinedTypeElement _ ->\r
- raise (CompilError\r
- {err_msg = ["_InvalidAnnOfInvFunc";\r
- "_InvalidTypeOfFuncCallExpr"];\r
- err_info = [("_ExpectedType", "_ClassElement");\r
- ("_TypeFound", "_PredefinedTypeElement")];\r
- err_ctx =\r
- {ctx with location = expr.Syntax.info}}) (*error*)\r
- | Types.ComponentElement _ ->\r
- raise (CompilError\r
- {err_msg = ["_InvalidAnnOfInvFunc";\r
- "_InvalidTypeOfFuncCallExpr"];\r
- err_info = [("_ExpectedType", "_ClassElement");\r
- ("_TypeFound", "_ComponentElement")];\r
- err_ctx =\r
- {ctx with location = expr.Syntax.info}}) (*error*) in\r
- let expr' = resolve_expression ctx expr in\r
- match expr'.nature with\r
- | ToplevelIdentifier _ | LocalIdentifier _ ->\r
- {\r
- function_class = expr';\r
- arguments =\r
- inverse_function_arguments expr' fun_args\r
- }\r
- | _ ->\r
- raise (CompilError\r
- {err_msg = ["_InvalidAnnOfInvFunc"; "_InvalidFuncCallExpr"];\r
- err_info = [];\r
- err_ctx =\r
- {ctx with location = expr.Syntax.info}}) (*error*) in\r
- let add_inverse_declaration arg acc =\r
- let add_inverse_declaration' expr modif =\r
- match expr.Syntax.nature, modif.Syntax.nature with\r
- | Syntax.IndexedAccess (\r
- { Syntax.nature = Syntax.Identifier "inverse" }, _),\r
- Syntax.Eq\r
- {\r
- Syntax.nature =\r
- Syntax.FunctionCall (expr, Some fun_args)\r
- } -> lazy (resolve_inverse_declaration expr fun_args) :: acc\r
- | _ ->\r
- raise (CompilError\r
- {err_msg = ["_InvalidAnnOfInvFunc"; "_InvalidModifExpr"];\r
- err_info = [];\r
- err_ctx =\r
- {ctx with location = expr.Syntax.info}}) (*error*) in\r
- match arg.Syntax.nature with\r
- | Syntax.ElementModification (Some _, _, _, _, _) ->\r
- raise (CompilError\r
- {err_msg = ["_InvalidAnnOfInvFunc"; "_UseOfEachKeywordNotAllowed"];\r
- err_info = [];\r
- err_ctx = {ctx with location = arg.Syntax.info}}) (*error*)\r
- | Syntax.ElementModification (None, Some _, _, _, _) ->\r
- raise (CompilError\r
- {err_msg = ["_InvalidAnnOfInvFunc"; "_UseOfFinalKeywordNotAllowed"];\r
- err_info = [];\r
- err_ctx = {ctx with location = arg.Syntax.info}}) (*error*)\r
- | Syntax.ElementModification (None, None, _, None, _) ->\r
- raise (CompilError\r
- {err_msg = ["_InvalidAnnOfInvFunc"; "_UnspecifiedModification"];\r
- err_info = [];\r
- err_ctx = {ctx with location = arg.Syntax.info}}) (*error*)\r
- | Syntax.ElementModification (None, None, expr, Some modif, _) ->\r
- add_inverse_declaration' expr modif\r
- | Syntax.ElementRedeclaration _ ->\r
- raise (CompilError\r
- {err_msg = ["_InvalidAnnOfInvFunc"; "_RedeclarationNotAllowed"];\r
- err_info = [];\r
- err_ctx = {ctx with location = arg.Syntax.info}}) (*error*) in\r
- let add_inverse_declarations cl_modif acc =\r
- let add_inverse_declarations' cl_modif = \r
- match cl_modif.Syntax.nature with\r
- | Syntax.ClassModification args ->\r
- List.fold_right add_inverse_declaration args acc in\r
- match cl_modif.Syntax.nature with\r
- | Syntax.ClassModification\r
- [\r
- {\r
- Syntax.nature =\r
- Syntax.ElementModification (\r
- None,\r
- None,\r
- {\r
- Syntax.nature = Syntax.Identifier "InverseFunctions"\r
- },\r
- Some\r
- {\r
- Syntax.nature =\r
- Syntax.Modification (cl_modif, None)\r
- },\r
- [])\r
- }\r
- ] -> add_inverse_declarations' cl_modif\r
- | Syntax.ClassModification _ -> acc in\r
- let add_annotation_information arg acc = match arg.Syntax.nature with\r
- | Syntax.ElementModification (\r
- None,\r
- None,\r
- { Syntax.nature = Syntax.Identifier "Imagine" },\r
- Some\r
- {\r
- Syntax.nature =\r
- Syntax.Modification (\r
- {\r
- Syntax.nature =\r
- Syntax.ClassModification\r
- [\r
- {\r
- Syntax.nature =\r
- Syntax.ElementModification (\r
- None,\r
- None,\r
- {\r
- Syntax.nature = Syntax.Identifier "AMESim"\r
- },\r
- Some\r
- {\r
- Syntax.nature =\r
- Syntax.Modification (cl_modif, None)\r
- },\r
- [])\r
- }\r
- ]\r
- },\r
- None)\r
- },\r
- []) -> add_inverse_declarations cl_modif acc\r
- | Syntax.ElementModification _ | Syntax.ElementRedeclaration _ -> acc in\r
- match cl_modif.Syntax.nature with\r
- | Syntax.ClassModification args ->\r
- List.fold_right add_annotation_information args [] in\r
- match ann.Syntax.nature with\r
- | Syntax.Annotation cl_modif -> resolve_class_annotation' cl_modif*)\r
-\r
-and resolve_import_clause ctx imp_clause =\r
- let ctx = {ctx with location = imp_clause.Syntax.info} in\r
- raise (CompilError\r
- {err_msg = ["_NotYetImplemented"; "_ImportClause"];\r
- err_info = [("_Expr", Syntax.string_of_import imp_clause)];\r
- err_ctx = ctx})\r
-\r
-and resolve_extends_clause ctx ctx' ext_clause =\r
- match ext_clause.Syntax.nature with\r
- | Syntax.Extends (cl_spec, cl_modif, _) ->\r
- resolve_extension ctx ctx' cl_spec cl_modif\r
-\r
-and resolve_extension ctx ctx' cl_spec cl_modif =\r
- let ctx' = {ctx' with location = cl_spec.Syntax.info} in\r
- let base_class = lazy (resolve_extension_expression ctx cl_spec) in\r
- let cl_spec' = lazy (base_class_type ctx' cl_spec base_class) in\r
- let cl_modif' =\r
- lazy (resolve_class_modification_option ctx' cl_spec' cl_modif) in\r
- {\r
- modified_class_type = lazy (modified_class_type ctx' cl_spec' cl_modif');\r
- base_class = base_class;\r
- class_modification = cl_modif'\r
- }\r
-\r
-and resolve_extension_expression ctx cl_spec =\r
- let rec modify_resolved_expression expr = match expr.nature with\r
- | LocalIdentifier (level, id) ->\r
- { expr with nature = LocalIdentifier (level + 1, id) }\r
- | FieldAccess (expr', id) ->\r
- { expr with\r
- nature = FieldAccess (modify_resolved_expression expr', id)\r
- }\r
- | IndexedAccess (expr', exprs') ->\r
- let exprs' = List.map modify_resolved_expression exprs' in\r
- { expr with\r
- nature = IndexedAccess (modify_resolved_expression expr', exprs')\r
- }\r
- | ToplevelIdentifier _ -> expr\r
- | _ ->\r
- raise (CompilError\r
- {err_msg = ["_InvalidExtensionDef"];\r
- err_info = [];\r
- err_ctx = ctx}) (*error*) in\r
- match ctx.context_nature with\r
- | ToplevelContext | ClassContext _ ->\r
- let base_class = resolve_expression ctx cl_spec in\r
- modify_resolved_expression base_class\r
- | SubscriptContext _ | ForContext _ ->\r
- raise (CompilError\r
- {err_msg = ["_InvalidExtensionDef"];\r
- err_info = [];\r
- err_ctx = ctx}) (*error*)\r
-\r
-and resolve_modified_class ctx ctx' cl_spec cl_modif =\r
- let ctx' = {ctx' with location = cl_spec.Syntax.info} in\r
- let base_class = lazy (resolve_expression ctx cl_spec) in\r
- let cl_spec' = lazy (base_class_type ctx' cl_spec base_class) in\r
- let cl_modif' =\r
- lazy (resolve_class_modification_option ctx' cl_spec' cl_modif) in\r
- {\r
- modified_class_type = lazy (modified_class_type ctx' cl_spec' cl_modif');\r
- base_class = base_class;\r
- class_modification = cl_modif'\r
- }\r
-\r
-and resolve_element_definition ctx protect redecl final dyn_scope elt_def =\r
- let repl = replaceable_attribute elt_def in\r
- let element_description (id, elt_nat, elt_loc) =\r
- let rec elt_desc =\r
- {\r
- element_type =\r
- lazy (element_type ctx protect final repl dyn_scope elt_desc);\r
- redeclare = bool_of_redeclare redecl;\r
- element_nature = elt_nat;\r
- element_location = elt_loc\r
- } in\r
- id, elt_desc in\r
- List.map element_description (declared_elements ctx elt_def)\r
-\r
-and replaceable_attribute elt_def = match elt_def.Syntax.nature with\r
- | Syntax.ClassDefinitionElement (repl, _, _) |\r
- Syntax.ComponentClauseElement (repl, _, _) -> repl\r
-\r
-and bool_of_redeclare = function\r
- | None -> false\r
- | Some Syntax.Redeclare -> true\r
-\r
-and resolve_type_constraint ctx elt_def = match elt_def.Syntax.nature with\r
- | Syntax.ClassDefinitionElement (_, _, []) |\r
- Syntax.ComponentClauseElement (_, _, []) -> None\r
- | Syntax.ClassDefinitionElement (_, _, _ :: _) |\r
- Syntax.ComponentClauseElement (_, _, _ :: _) -> assert false\r
-\r
-and declared_elements ctx elt_def = match elt_def.Syntax.nature with\r
- | Syntax.ClassDefinitionElement (_, def, _) ->\r
- let s = class_definition_name def\r
- and elt_nat = resolve_definition ctx def\r
- and loc = match def.Syntax.nature with\r
- | Syntax.Definition (encap, part, kind, cl_spec) ->\r
- cl_spec.Syntax.info in\r
- [s, elt_nat, loc]\r
- | Syntax.ComponentClauseElement (_, cpnt_cl, _) ->\r
- resolve_component_clause ctx cpnt_cl\r
-\r
-and resolve_component_clause ctx cpnt_cl = match cpnt_cl.Syntax.nature with\r
- | Syntax.ComponentClause (type_pref, type_spec, subs, cpnt_decls) ->\r
- let type_pref' = type_prefix type_pref\r
- and type_spec' = lazy (resolve_expression ctx type_spec)\r
- and dims = lazy (resolve_dimensions ctx subs) in\r
- List.map\r
- (resolve_component_declaration ctx type_pref' type_spec' dims type_spec)\r
- cpnt_decls\r
-\r
-and type_prefix type_pref =\r
- let bool_of_flow = function\r
- | None -> false\r
- | Some Syntax.Flow -> true\r
- and variability_of_variability = function\r
- | None -> None\r
- | Some Syntax.Constant -> Some Types.Constant\r
- | Some Syntax.Parameter -> Some Types.Parameter\r
- | Some Syntax.Discrete -> Some Types.Discrete\r
- and causality_of_inout = function\r
- | None -> Types.Acausal\r
- | Some Syntax.Input -> Types.Input\r
- | Some Syntax.Output -> Types.Output in\r
- match type_pref.Syntax.nature with\r
- | Syntax.TypePrefix (flow, var, inout) ->\r
- bool_of_flow flow,\r
- variability_of_variability var,\r
- causality_of_inout inout\r
-\r
-and resolve_component_declaration\r
- ctx type_pref type_spec' dims type_spec cpnt_decl =\r
- let build_comment_string cmt = match cmt.Syntax.nature with\r
- | Syntax.Comment (ss, _) -> List.fold_right ( ^ ) ss "" in\r
- match cpnt_decl.Syntax.nature with\r
- | Syntax.ComponentDeclaration (decl, cmt) ->\r
- let cmt' = build_comment_string cmt in\r
- resolve_declaration ctx type_pref type_spec' dims decl cmt' type_spec\r
-\r
-and resolve_declaration ctx type_pref type_spec' dims decl cmt type_spec =\r
- let ctx = {ctx with location = decl.Syntax.info} in\r
- match decl.Syntax.nature with\r
- | Syntax.Declaration (id, subs, modif) ->\r
- let dims = lazy ((resolve_dimensions ctx subs) @ (evaluate dims)) in\r
- let cpnt_type = lazy (component_type ctx type_pref type_spec' dims) in\r
- let modif' =\r
- lazy (resolve_component_modification ctx cpnt_type modif) in\r
- let cpnt_desc =\r
- {\r
- component_type =\r
- lazy (modified_component_type ctx (evaluate cpnt_type) modif');\r
- type_specifier = type_spec';\r
- dimensions = dims;\r
- modification = modif';\r
- comment = cmt;\r
- } in\r
- (id, Component cpnt_desc, decl.Syntax.info)\r
-\r
-and resolve_dimensions ctx subs =\r
- let resolve_dimension sub = match sub.Syntax.nature with\r
- | Syntax.Colon -> Colon\r
- | Syntax.Subscript expr ->\r
- Expression (resolve_subscript_expression ctx expr) in\r
- let resolve_dimensions' = function\r
- | None -> []\r
- | Some { Syntax.nature = Syntax.Subscripts subs_elts } ->\r
- List.map resolve_dimension subs_elts in\r
- resolve_dimensions' subs\r
-\r
-and base_class_type ctx cl_spec base_class =\r
- match (evaluate base_class).info.type_description with\r
- | Types.ClassElement cl_spec -> evaluate cl_spec\r
- | Types.ComponentTypeElement _ ->\r
- raise (CompilError\r
- {err_msg = ["_CannotInheritFrom"; "_ComponentTypeElement"];\r
- err_info =\r
- [("_ElemFound", Syntax.string_of_expression cl_spec)];\r
- err_ctx = {ctx with location = cl_spec.Syntax.info}}) (*error*)\r
- | Types.PredefinedTypeElement _ ->\r
- raise (CompilError\r
- {err_msg = ["_CannotInheritFrom"; "_PredefinedTypeElement"];\r
- err_info =\r
- [("_ElemFound", Syntax.string_of_expression cl_spec)];\r
- err_ctx = {ctx with location = cl_spec.Syntax.info}}) (*error*)\r
- | Types.ComponentElement _ ->\r
- raise (CompilError\r
- {err_msg = ["_CannotInheritFrom"; "_ComponentElement"];\r
- err_info = [];\r
- err_ctx = {ctx with location = cl_spec.Syntax.info}}) (*error*)\r
-\r
-and component_type ctx (flow, var, inout) base_type dims =\r
- let base_type = evaluate base_type in\r
- let lower_variability var var' = match var, var' with\r
- | Some Types.Constant,\r
- (Types.Constant | Types.Parameter | Types.Discrete | Types.Continuous) ->\r
- Types.Constant\r
- | Some Types.Parameter,\r
- (Types.Parameter | Types.Discrete | Types.Continuous) -> Types.Parameter\r
- | Some Types.Discrete, (Types.Discrete | Types.Continuous) -> Types.Discrete\r
- | Some Types.Continuous, Types.Continuous -> Types.Continuous\r
- | None, _ -> var'\r
- | Some var, (Types.Constant | Types.Parameter | Types.Discrete) ->\r
- raise (CompilError\r
- {err_msg = ["_VariablityConflictsInCompDef"];\r
- err_info =\r
- [("_TypePrefix", Types.string_of_variability var);\r
- ("_TypeSpecifierVariability", Types.string_of_variability var')];\r
- err_ctx = ctx}) (*error*)\r
- and propagate_causality inout inout' = match inout, inout' with\r
- | Types.Acausal, (Types.Acausal | Types.Input | Types.Output) -> inout'\r
- | (Types.Input | Types.Output), Types.Acausal -> inout\r
- | Types.Input, Types.Input | Types.Output, Types.Output -> inout\r
- | Types.Input, Types.Output | Types.Output, Types.Input ->\r
- raise (CompilError\r
- {err_msg = ["_CausalityConflictsInCompDef"];\r
- err_info = [("_TypePrefix", Types.string_of_causality inout);\r
- ("_TypeSpecifierCausality",\r
- Types.string_of_causality inout')];\r
- err_ctx = ctx}) (*error*) in\r
- let predefined_type_variability predef = match predef with\r
- | { Types.base_type = Types.RealType } -> Types.Continuous\r
- | _ -> Types.Discrete in\r
- let rec class_specifier_variability cl_spec = match cl_spec with\r
- | Types.PredefinedType predef -> predefined_type_variability predef\r
- | Types.ClassType cl_type -> Types.Continuous\r
- | Types.ComponentType cpnt_type -> evaluate cpnt_type.Types.variability\r
- | Types.ArrayType (dim, cl_spec) -> class_specifier_variability cl_spec\r
- | Types.TupleType cl_specs -> assert false in\r
- match base_type.info.type_description with\r
- | Types.ComponentElement _ ->\r
- raise (CompilError\r
- {err_msg = ["class"; "_ElemExpected"];\r
- err_info = [("TypeFound", "_ComponentElement")];\r
- err_ctx = ctx}) (*error*)\r
- | Types.ClassElement cl_spec ->\r
- let cl_spec = evaluate cl_spec in\r
- let var' = class_specifier_variability cl_spec in\r
- let var' = lazy (lower_variability var var')\r
- and base_class = lazy (add_dimensions dims cl_spec) in\r
- component_element (lazy flow) var' (lazy inout) base_class\r
- | Types.ComponentTypeElement cpnt_type ->\r
- let flow' = lazy (flow || evaluate cpnt_type.Types.flow)\r
- and var' =\r
- lazy (lower_variability var (evaluate cpnt_type.Types.variability))\r
- and inout' =\r
- lazy (propagate_causality inout (evaluate cpnt_type.Types.causality))\r
- and base_class =\r
- lazy (add_dimensions dims (Types.ComponentType cpnt_type)) in\r
- component_element flow' var' inout' base_class\r
- | Types.PredefinedTypeElement predef ->\r
- let var' = predefined_type_variability predef in\r
- let var' = lazy (lower_variability var var')\r
- and base_class =\r
- lazy (add_dimensions dims (Types.PredefinedType predef)) in\r
- component_element (lazy flow) var' (lazy inout) base_class\r
-\r
-and add_dimensions dims cl_spec =\r
- let add_dimension dim cl_spec = match dim with\r
- | Expression { nature = Integer i } ->\r
- Types.ArrayType (Types.ConstantDimension i, cl_spec)\r
- | Expression _ -> Types.ArrayType (Types.ParameterDimension, cl_spec)\r
- | Colon -> Types.ArrayType (Types.DiscreteDimension, cl_spec) in\r
- List.fold_right add_dimension (evaluate dims) cl_spec\r
-\r
-and modified_described_type ctx cpnt_type cl_modif =\r
- let cpnt_type' = evaluate cpnt_type in\r
- let cl_spec = cpnt_type'.Types.base_class in\r
- { cpnt_type' with\r
- Types.base_class =\r
- lazy (modify_class_specifier ctx (evaluate cl_modif) cl_spec)\r
- }\r
-\r
-and modified_class_type ctx cl_spec cl_modif =\r
- let cl_spec' = modify_class_specifier ctx (evaluate cl_modif) cl_spec in\r
- match cl_spec' with\r
- | Types.ClassType cl_type -> cl_type\r
- | Types.PredefinedType _ | Types.ComponentType _ | Types.ArrayType _ |\r
- Types.TupleType _ ->\r
- raise (CompilError\r
- {err_msg = ["class"; "_ElemExpected"];\r
- err_info = [("TypeFound",\r
- Types.string_of_class_specifier cl_spec')];\r
- err_ctx = ctx}) (*error*)\r
-\r
-and modified_component_type ctx cpnt_type modif =\r
- let modified_component_type' = function\r
- | Modification (cl_modif, _) -> modify_component_type ctx cl_modif cpnt_type\r
- | Assignment _ | Equality _ -> cpnt_type in\r
- match evaluate modif with\r
- | None -> cpnt_type\r
- | Some modif' -> modified_component_type' modif'\r
-\r
-(* We can abstract dimensions away since they have been already checked at *)\r
-(* modification resolution time. *)\r
-and modify_class_specifier ctx cl_modif cl_spec =\r
- let rec modify_class_specifier' cl_spec' = match cl_spec' with\r
- | Types.PredefinedType predef ->\r
- Types.PredefinedType (modify_predefined_type ctx cl_modif predef)\r
- | Types.ClassType cl_type ->\r
- Types.ClassType (modify_class_type ctx cl_modif cl_type)\r
- | Types.ComponentType cpnt_type ->\r
- Types.ComponentType (modify_component_type ctx cl_modif cpnt_type)\r
- | Types.ArrayType (dim, cl_spec) ->\r
- Types.ArrayType (dim, modify_class_specifier' cl_spec)\r
- | Types.TupleType _ ->\r
- raise (CompilError\r
- {err_msg = ["_InvalidTypeOfClassSpec"];\r
- err_info = [("_TypeFound",\r
- Types.string_of_class_specifier cl_spec')];\r
- err_ctx = ctx}) (*error*) in\r
- modify_class_specifier' (evaluate cl_spec)\r
-\r
-and modify_predefined_type ctx cl_modif predef =\r
- { predef with\r
- Types.attributes =\r
- modify_predefined_attributes ctx cl_modif predef.Types.attributes\r
- }\r
-\r
-and modify_predefined_attributes ctx cl_modif attrs =\r
- let apply_modifications ((id, final) as attr) = function\r
- | [] -> attr\r
- | [_] when final -> assert false (*error*)\r
- | [final', (Assignment _ | Equality _)] -> id, final'\r
- | _ :: _ -> assert false (*error*) in\r
- let modify_attribute ((id, _) as attr) =\r
- let modifs, elt_descs = partition_modifications cl_modif id in\r
- match modifs, elt_descs with\r
- | [], [] -> attr\r
- | _ :: _, [] -> apply_modifications attr modifs\r
- | [], _ :: _\r
- | _ :: _, _ :: _ ->\r
- raise (CompilError\r
- {err_msg = ["_RedeclarePredefTypeAttrib"; id];\r
- err_info = [];\r
- err_ctx = ctx}) (*error*) in\r
- List.map modify_attribute attrs\r
-\r
-and modify_class_type ctx cl_modif cl_type =\r
- let modify_named_element (id, elt_type) =\r
- id, lazy (modify_element ctx cl_modif id (evaluate elt_type)) in\r
- { cl_type with\r
- Types.named_elements =\r
- List.map modify_named_element cl_type.Types.named_elements\r
- }\r
-\r
-and modify_element ctx cl_modif id elt_type =\r
- let modifs, elt_descs = partition_modifications cl_modif id in\r
- match modifs, elt_descs with\r
- | [], [] -> elt_type\r
- | _ :: _, [] -> apply_element_modifications ctx modifs elt_type id\r
- | [], [elt_desc] -> apply_element_redeclaration ctx elt_desc elt_type\r
- | [], _ :: _ :: _ ->\r
- raise (CompilError\r
- {err_msg = ["_InvalidElemModifDef"];\r
- err_info = [];\r
- err_ctx = ctx}) (*error*)\r
- | _ :: _, _ :: _ ->\r
- raise (CompilError\r
- {err_msg = ["_InvalidElemModifDef"];\r
- err_info = [];\r
- err_ctx = ctx}) (*error*)\r
-\r
-and partition_modifications cl_modif id =\r
- let add_element_modification modif_arg modifs = match modif_arg.action with\r
- | Some (ElementModification modif) -> (modif_arg.final, modif) :: modifs\r
- | None | Some (ElementRedeclaration _) -> modifs\r
- and add_element_redeclaration modif_arg elt_descs =\r
- match modif_arg.action with\r
- | None | Some (ElementModification _) -> elt_descs\r
- | Some (ElementRedeclaration elt_desc) ->\r
- (modif_arg.final, elt_desc) :: elt_descs in\r
- let is_current_element_modification modif_arg = modif_arg.target = id in\r
- let cl_modif' = List.filter is_current_element_modification cl_modif in\r
- let modifs = List.fold_right add_element_modification cl_modif' []\r
- and elt_descs = List.fold_right add_element_redeclaration cl_modif' [] in\r
- modifs, elt_descs\r
-\r
-and apply_element_redeclaration ctx elt_desc elt_type =\r
- raise (CompilError\r
- {err_msg = ["_NotYetImplemented"; "_ElementRedeclaration"];\r
- err_info = [];\r
- err_ctx = ctx})\r
-\r
-and apply_element_modifications ctx modifs elt_type id =\r
- let add_modification_arguments (final, modif) cl_modifs = match modif with\r
- | Modification (cl_modif, _) -> (final, cl_modif) :: cl_modifs\r
- | Assignment _ | Equality _ -> cl_modifs\r
- and add_value_modification (final, modif) val_modifs = match modif with\r
- | Modification (_, Some _) | Assignment _ | Equality _ ->\r
- final :: val_modifs\r
- | Modification (_, None) -> val_modifs in\r
- let cl_modifs = List.fold_right add_modification_arguments modifs []\r
- and val_modifs = List.fold_right add_value_modification modifs [] in\r
- let elt_type' = modify_element_type ctx cl_modifs elt_type id in\r
- modify_element_value ctx val_modifs elt_type' id\r
-\r
-and modify_element_type ctx cl_modifs elt_type id =\r
- let propagate_final_attribute final modif_arg cl_modif =\r
- { modif_arg with final = final } :: cl_modif in\r
- let merge_modifications (final, cl_modif) cl_modif' =\r
- List.fold_right (propagate_final_attribute final) cl_modif cl_modif' in\r
- let cl_modif = List.fold_right merge_modifications cl_modifs [] in\r
- { elt_type with\r
- Types.element_nature = modify_element_nature ctx cl_modif elt_type id\r
- }\r
-\r
-and modify_element_nature ctx cl_modif elt_type id =\r
- match elt_type.Types.element_nature with\r
- | _ when elt_type.Types.final ->\r
- raise (CompilError\r
- {err_msg = ["_FinalElemModifNotAllowed"; id];\r
- err_info = [];\r
- err_ctx = ctx}) (*error*)\r
- | Types.ComponentElement cpnt_type ->\r
- Types.ComponentElement (modify_component_type ctx cl_modif cpnt_type)\r
- | Types.ClassElement cl_spec ->\r
- let cl_spec' = lazy (modify_class_specifier ctx cl_modif cl_spec) in\r
- Types.ClassElement cl_spec'\r
- | Types.ComponentTypeElement cpnt_type ->\r
- let cpnt_type' = modify_component_type ctx cl_modif cpnt_type in\r
- Types.ComponentTypeElement cpnt_type'\r
- | Types.PredefinedTypeElement predef ->\r
- Types.PredefinedTypeElement (modify_predefined_type ctx cl_modif predef)\r
-\r
-and modify_element_value ctx val_modifs elt_type id =\r
- match val_modifs with\r
- | [] -> elt_type\r
- | [_] when elt_type.Types.final ->\r
- raise (CompilError\r
- {err_msg = ["_FinalElemModifNotAllowed"; id];\r
- err_info = [];\r
- err_ctx = ctx}) (*error*)\r
- | [final] -> { elt_type with Types.final = final }\r
- | _ :: _ :: _ ->\r
- raise (CompilError\r
- {err_msg = ["_DuplicatedModifOfElem"; id];\r
- err_info = [];\r
- err_ctx = ctx}) (*error*)\r
-\r
-and modify_component_type ctx cl_modif cpnt_type =\r
- { cpnt_type with\r
- Types.base_class =\r
- lazy (modify_class_specifier ctx cl_modif cpnt_type.Types.base_class)\r
- }\r
-\r
-and resolve_type_modification ctx cpnt_type cl_modif =\r
- let cl_spec = (evaluate cpnt_type).Types.base_class in\r
- resolve_class_modification_option ctx cl_spec cl_modif\r
-\r
-and resolve_component_modification ctx cpnt_type = function\r
- | None -> None\r
- | Some modif' ->\r
- let elt_nat = Types.ComponentElement (evaluate cpnt_type) in\r
- Some (resolve_modification ctx elt_nat modif')\r
-\r
-and resolve_class_modification_option ctx cl_spec = function\r
- | None -> []\r
- | Some cl_modif -> resolve_class_modification ctx cl_spec cl_modif\r
-\r
-and resolve_modification ctx elt_nat modif =\r
- let ctx = {ctx with location = modif.Syntax.info} in\r
- match elt_nat, modif.Syntax.nature with\r
- | Types.ComponentElement cpnt_type, Syntax.Modification (cl_modif, expr) |\r
- Types.ComponentTypeElement cpnt_type,\r
- Syntax.Modification (cl_modif, (None as expr)) ->\r
- resolve_component_type_modification ctx cpnt_type cl_modif expr\r
- | Types.ComponentTypeElement _, Syntax.Modification (_, Some _) ->\r
- raise (CompilError\r
- {err_msg = ["_InvalidClassElemModif"];\r
- err_info = [];\r
- err_ctx = ctx}) (*error*)\r
- | Types.ClassElement cl_spec, Syntax.Modification (cl_modif, None) ->\r
- let cl_modif' = resolve_class_modification ctx cl_spec cl_modif in\r
- Modification (cl_modif', None)\r
- | Types.ClassElement _, Syntax.Modification (_, Some _) ->\r
- raise (CompilError\r
- {err_msg = ["_InvalidClassElemModif"];\r
- err_info = [];\r
- err_ctx = ctx}) (*error*)\r
- | (Types.PredefinedTypeElement _),\r
- (Syntax.Modification _ | Syntax.Eq _ | Syntax.ColEq _) ->\r
- raise (CompilError\r
- {err_msg = ["_InvalidClassElemModif"];\r
- err_info = [];\r
- err_ctx = ctx}) (*error*)\r
- | Types.ComponentElement cpnt_type, Syntax.Eq expr ->\r
- let expr' = lazy (resolve_modification_equation ctx cpnt_type expr) in\r
- Equality expr'\r
- | Types.ComponentElement cpnt_type, Syntax.ColEq expr ->\r
- let expr' = lazy (resolve_modification_algorithm ctx cpnt_type expr) in\r
- Assignment expr'\r
- | (Types.ClassElement _ | Types.ComponentTypeElement _),\r
- (Syntax.Eq _ | Syntax.ColEq _) ->\r
- raise (CompilError\r
- {err_msg = ["_InvalidClassElemModif"];\r
- err_info = [];\r
- err_ctx = ctx}) (*error*)\r
-\r
-and resolve_component_type_modification ctx cpnt_type cl_modif expr =\r
- let ctx = {ctx with location = cl_modif.Syntax.info} in\r
- let cl_spec = cpnt_type.Types.base_class in\r
- let cl_modif' = resolve_class_modification ctx cl_spec cl_modif in\r
- let cpnt_type' = modify_component_type ctx cl_modif' cpnt_type in\r
- let expr' = resolve_value_modification_option ctx cpnt_type' expr in\r
- Modification (cl_modif', expr')\r
-\r
-and resolve_value_modification_option ctx cpnt_type = function\r
- | None -> None\r
- | Some expr -> Some (lazy (resolve_modification_equation ctx cpnt_type expr))\r
-\r
-and resolve_modification_equation ctx cpnt_type expr =\r
- let ctx = {ctx with location = expr.Syntax.info} in\r
- let resolve_modification_equation' cpnt_type' expr' =\r
- let var = evaluate cpnt_type.Types.variability\r
- and var' = evaluate cpnt_type'.Types.variability in\r
- match Types.compare_component_types cpnt_type cpnt_type' with\r
- | Types.SameType\r
- when Types.higher_variability var var' -> expr'\r
- | Types.SameType ->\r
- let var = Types.string_of_variability var\r
- and var' = Types.string_of_variability var' in\r
- raise (CompilError\r
- {err_msg = ["_VariabilityConflicts"];\r
- err_info = [("_ExprKind", "A = B");\r
- ("_VariabilityOfA", var);\r
- ("_VariabilityOfB", var')];\r
- err_ctx = ctx}) (*error*)\r
- | _ ->\r
- let type_A = Types.string_of_component_type cpnt_type\r
- and type_B = Types.string_of_component_type cpnt_type' in\r
- raise (CompilError\r
- {err_msg = [ "_EquTermsNotOfTheSameType"];\r
- err_info = [("_ExprKind", "A = B");\r
- ("_TypeOfA", type_A);\r
- ("_TypeOfB", type_B)];\r
- err_ctx = ctx}) (*error*) in\r
- let expr' = resolve_expression ctx expr in\r
- let expr' = apply_rhs_coercions cpnt_type expr' in\r
- match expr'.info.type_description with\r
- | Types.ComponentElement cpnt_type' ->\r
- resolve_modification_equation' cpnt_type' expr'\r
- | Types.ClassElement _ | Types.ComponentTypeElement _ |\r
- Types.PredefinedTypeElement _ ->\r
- raise (CompilError\r
- {err_msg = ["_ClassElemFoundInExpr"];\r
- err_info = [];\r
- err_ctx = ctx}) (*error*)\r
-\r
-and resolve_modification_algorithm ctx cpnt_type expr =\r
- let ctx = {ctx with location = expr.Syntax.info} in\r
- let resolve_modification_algorithm' cpnt_type' expr' =\r
- let var = evaluate cpnt_type.Types.variability\r
- and var' = evaluate cpnt_type'.Types.variability in\r
- match Types.compare_component_types cpnt_type cpnt_type' with\r
- | Types.SameType\r
- when Types.higher_variability var var' -> expr'\r
- | Types.SameType ->\r
- let var = Types.string_of_variability var\r
- and var' = Types.string_of_variability var' in\r
- raise (CompilError\r
- {err_msg = ["_VariabilityConflicts"];\r
- err_info = [("_ExprKind", "A := B");\r
- ("_VariabilityOfA", var);\r
- ("_VariabilityOfB", var')];\r
- err_ctx = ctx}) (*error*)\r
- | _ ->\r
- let type_A = Types.string_of_component_type cpnt_type\r
- and type_B = Types.string_of_component_type cpnt_type' in\r
- raise (CompilError\r
- {err_msg = [ "_TypeConflictsInAssign"];\r
- err_info = [("_ExprKind", "A := B");\r
- ("_TypeOfA", type_A);\r
- ("_TypeOfB", type_B)];\r
- err_ctx = ctx}) (*error*) in\r
- let expr' = resolve_expression ctx expr in\r
- let expr' = apply_rhs_coercions cpnt_type expr' in\r
- match expr'.info.type_description with\r
- | Types.ComponentElement cpnt_type' ->\r
- resolve_modification_algorithm' cpnt_type' expr'\r
- | Types.ClassElement _ | Types.ComponentTypeElement _ |\r
- Types.PredefinedTypeElement _ ->\r
- raise (CompilError\r
- {err_msg = ["_ClassElemFoundInExpr"];\r
- err_info = [];\r
- err_ctx = ctx}) (*error*)\r
-\r
-and resolve_class_modification ctx cl_spec cl_modif =\r
- match cl_modif.Syntax.nature with\r
- | Syntax.ClassModification args ->\r
- List.map (resolve_modification_argument ctx cl_spec) args\r
-\r
-and resolve_modification_argument ctx cl_spec arg =\r
- let ctx = {ctx with location = arg.Syntax.info} in\r
- let apply_each each =\r
- let rec drop_dimensions cl_spec = match cl_spec with\r
- | Types.ArrayType (_, cl_spec') -> drop_dimensions cl_spec'\r
- | Types.PredefinedType _ | Types.ClassType _ | Types.ComponentType _ |\r
- Types.TupleType _ -> cl_spec in\r
- let cl_spec' = evaluate cl_spec in\r
- match cl_spec' with\r
- | Types.ArrayType _ when each -> drop_dimensions cl_spec'\r
- | Types.PredefinedType _\r
- | Types.ClassType _\r
- | Types.ComponentType _\r
- | Types.TupleType _ when each ->\r
- raise (CompilError\r
- {err_msg = ["_EachAppliedToNonArrayElem"];\r
- err_info = [];\r
- err_ctx = ctx}) (*error*)\r
- | Types.ArrayType _ | Types.PredefinedType _ | Types.ClassType _ |\r
- Types.ComponentType _ | Types.TupleType _ -> cl_spec' in\r
- match arg.Syntax.nature with\r
- | Syntax.ElementModification (each, final, expr, modif, _) ->\r
- let each' = bool_of_each each\r
- and final' = bool_of_final final in\r
- let cl_spec' = apply_each each' in\r
- resolve_element_modification ctx cl_spec' each' final' expr modif\r
- | Syntax.ElementRedeclaration (each, final, elt_def) ->\r
- let each' = bool_of_each each\r
- and final' = bool_of_final final in\r
- let cl_spec' = apply_each each' in\r
- resolve_element_redeclaration ctx cl_spec' each' final' elt_def\r
-\r
-and bool_of_each = function\r
- | None -> false\r
- | Some Syntax.Each -> true\r
-\r
-and bool_of_final = function\r
- | None -> false\r
- | Some Syntax.Final -> true\r
-\r
-and resolve_element_modification ctx cl_spec each final expr modif =\r
- let ctx = {ctx with location = expr.Syntax.info} in\r
- let rec path_of_expression path expr = match expr.Syntax.nature with\r
- | Syntax.Identifier id ->\r
- modification_arguments_of_path cl_spec each final id (List.rev path)\r
- | Syntax.FieldAccess (expr, id) -> path_of_expression (id :: path) expr\r
- | _ ->\r
- raise (CompilError\r
- {err_msg = ["_InvalidExprInElemModif"];\r
- err_info = [];\r
- err_ctx = ctx}) (*error*)\r
- and modification_arguments_of_path cl_spec each final id path =\r
- let flow = false\r
- and var = Types.Continuous\r
- and inout = Types.Acausal in\r
- let elt_nat = element_field_type_nature ctx flow var inout cl_spec id in\r
- {\r
- each = each;\r
- final = final;\r
- target = id;\r
- action = resolve_modification_action ctx modif elt_nat path\r
- }\r
- and resolve_modification_action ctx modif elt_nat = function\r
- | [] -> resolve_modification_option ctx elt_nat modif\r
- | id :: path ->\r
- raise (CompilError\r
- {err_msg = ["_NotYetImplemented"; "_FieldAccessInElemModifExpr"];\r
- err_info = [];\r
- err_ctx = ctx})\r
- and resolve_modification_option ctx elt_nat = function\r
- | None -> None\r
- | Some modif ->\r
- Some (ElementModification (resolve_modification ctx elt_nat modif)) in\r
- path_of_expression [] expr\r
-\r
-and resolve_element_redeclaration ctx cl_spec each final elt_def =\r
- let ctx = {ctx with location = elt_def.Syntax.info} in\r
- raise (CompilError\r
- {err_msg = ["_NotYetImplemented"; "_ElementRedeclaration"];\r
- err_info = [];\r
- err_ctx = ctx})\r
-\r
-and resolve_unnamed_elements ctx other_elts =\r
- let class_kind =\r
- let class_context' cl_spec = match cl_spec with\r
- | Types.ClassType cl_type ->\r
- Some (evaluate cl_type.Types.kind)\r
- | _ -> None in\r
- match ctx.context_nature with\r
- | ClassContext cl_def ->\r
- class_context' (evaluate cl_def.class_type)\r
- | _ -> None in\r
- let add_equation_or_algorithm_clause other_elt acc =\r
- match other_elt.Syntax.nature, class_kind with\r
- | (Syntax.EquationClause _), Some kind\r
- when List.mem kind [Types.Function; Types.Record; Types.Connector] ->\r
- raise (CompilError\r
- {err_msg = ["_EquNotAllowedInTheDefOf"; Types.string_of_kind kind];\r
- err_info = [];\r
- err_ctx = ctx}) (*error*)\r
- | Syntax.EquationClause (init, equ_defs), _ ->\r
- let init' = bool_of_initial init\r
- and equ_defs' = resolve_equation_definitions ctx equ_defs in\r
- EquationClause (init', equ_defs') :: acc\r
- | Syntax.AlgorithmClause (init, algo_defs), _ ->\r
- let init' = bool_of_initial init\r
- and algo_defs' = resolve_algorithm_definitions ctx algo_defs in\r
- AlgorithmClause (init', algo_defs') :: acc\r
- | (Syntax.Public _ | Syntax.Protected _), _ -> acc in\r
- List.fold_right add_equation_or_algorithm_clause other_elts []\r
-\r
-and bool_of_initial = function\r
- | None -> Permanent\r
- | Some Syntax.Initial -> Initial\r
-\r
-and resolve_equation_definitions ctx equ_defs =\r
- let resolve_equation_definition equ_def = match equ_def.Syntax.nature with\r
- | Syntax.Equation (equ, _, _) -> resolve_equation ctx equ in\r
- List.flatten (List.map resolve_equation_definition equ_defs)\r
-\r
-and resolve_algorithm_definitions ctx algo_defs =\r
- let resolve_algorithm_definition algo_def = match algo_def.Syntax.nature with\r
- | Syntax.Algorithm (algo, _, _) -> resolve_algorithm ctx algo in\r
- List.map resolve_algorithm_definition algo_defs\r
-\r
-and resolve_equation ctx equ =\r
- let ctx = {ctx with location = equ.Syntax.info} in\r
- match equ.Syntax.nature with\r
- | Syntax.Equal (expr, expr') -> resolve_equal ctx equ expr expr'\r
- | Syntax.ConditionalEquationE (alts, default) ->\r
- resolve_conditional_equation_e ctx equ alts default\r
- | Syntax.ForClauseE (for_inds, equs) ->\r
- resolve_for_clause_e ctx equ for_inds equs\r
- | Syntax.ConnectClause (expr, expr') ->\r
- resolve_connect_clause ctx equ expr expr'\r
- | Syntax.WhenClauseE alts ->\r
- resolve_when_clause_e ctx equ alts\r
- | Syntax.FunctionCallE (expr, fun_args) ->\r
- resolve_functional_call_e ctx equ expr fun_args\r
-\r
-and resolve_equal ctx equ expres expres' =\r
- let resolve_equal' cpnt_type expr cpnt_type' expr' =\r
- let resolved_equation syn expr expr' =\r
- {\r
- nature = Equal (expr, expr');\r
- info = syn\r
- } in\r
- let var = evaluate cpnt_type.Types.variability\r
- and var' = evaluate cpnt_type'.Types.variability in\r
- match var, var' with\r
- | Types.Continuous, _ | _, Types.Continuous ->\r
- equations ctx equ resolved_equation cpnt_type expr cpnt_type' expr'\r
- | Types.Discrete, _ | _, Types.Discrete\r
- when expression_of_variable expres ->\r
- equations ctx equ resolved_equation cpnt_type expr cpnt_type' expr'\r
- | Types.Discrete, _ | _, Types.Discrete ->\r
- raise (CompilError\r
- {err_msg = ["_LHSOfDiscreteEquMustBeAVar"];\r
- err_info = [];\r
- err_ctx = {ctx with location = expres.Syntax.info}}) (*error*)\r
- | _ ->\r
- equations ctx equ resolved_equation cpnt_type expr cpnt_type' expr' in\r
- let expr = resolve_expression ctx expres\r
- and expr' = resolve_expression ctx expres' in\r
- let exprs = apply_binary_coercions [ expr; expr' ] in\r
- let expr = List.nth exprs 0\r
- and expr' = List.nth exprs 1 in\r
- let elt_nat = expr.info.type_description\r
- and elt_nat' = expr'.info.type_description in\r
- match elt_nat, elt_nat' with\r
- | Types.ComponentElement cpnt_type, Types.ComponentElement cpnt_type' ->\r
- resolve_equal' cpnt_type expr cpnt_type' expr'\r
- | (Types.ClassElement _ | Types.ComponentTypeElement _ |\r
- Types.PredefinedTypeElement _), _ ->\r
- let ctx = {ctx with location = expres.Syntax.info} in\r
- raise (CompilError\r
- {err_msg = ["_ClassElemFoundInExpr"];\r
- err_info = [];\r
- err_ctx = ctx}) (*error*)\r
- | _, (Types.ClassElement _ | Types.ComponentTypeElement _ |\r
- Types.PredefinedTypeElement _) ->\r
- let ctx = {ctx with location = expres'.Syntax.info} in\r
- raise (CompilError\r
- {err_msg = ["_ClassElemFoundInExpr"];\r
- err_info = [];\r
- err_ctx = ctx}) (*error*)\r
-\r
-and resolve_conditional_equation_e ctx equ alts default =\r
- let resolve_alternative (expr, equs) =\r
- let ctx = {ctx with location = expr.Syntax.info} in\r
- let expr' = resolve_expression ctx expr in\r
- let resolve_alternative' cpnt_type =\r
- let cl_spec = evaluate cpnt_type.Types.base_class in\r
- match cl_spec with\r
- | Types.PredefinedType { Types.base_type = Types.BooleanType } ->\r
- let equs' = List.flatten (List.map (resolve_equation ctx) equs) in\r
- expr', equs'\r
- | Types.PredefinedType _ | Types.ClassType _ | Types.ComponentType _ |\r
- Types.ArrayType _ | Types.TupleType _ ->\r
- raise (CompilError\r
- {err_msg = ["_NonBooleanIfCondExpr"];\r
- err_info =\r
- [("_ExprKind", "...if A then...");\r
- ("_TypeOfA", Types.string_of_class_specifier cl_spec)];\r
- err_ctx = ctx}) (*error*) in\r
- match expr'.info.type_description with\r
- | Types.ComponentElement cpnt_type -> resolve_alternative' cpnt_type\r
- | Types.ClassElement _ | Types.ComponentTypeElement _ |\r
- Types.PredefinedTypeElement _ ->\r
- raise (CompilError\r
- {err_msg = ["_ClassElemFoundInExpr"];\r
- err_info = [];\r
- err_ctx = ctx}) (*error*) in\r
- let alts' = List.map resolve_alternative alts in\r
- let default' = match default with\r
- | None -> []\r
- | Some equs -> List.flatten (List.map (resolve_equation ctx) equs) in\r
- [{\r
- nature = ConditionalEquationE (alts', default');\r
- info = Some equ\r
- }]\r
-\r
-and resolve_for_clause_e ctx equ for_inds equs =\r
- let range_element_type expr range =\r
- let ctx = {ctx with location = expr.Syntax.info} in\r
- let sub_dimension cl_spec = match cl_spec with\r
- | Types.ArrayType (dim, cl_spec) -> cl_spec\r
- | Types.PredefinedType _ | Types.ClassType _ |\r
- Types.ComponentType _ | Types.TupleType _ ->\r
- raise (CompilError\r
- {err_msg = ["_InvalidTypeInRangeExpr"];\r
- err_info =\r
- [("_ExpectedType", "Integer");\r
- ("_TypeFound", Types.string_of_class_specifier cl_spec)];\r
- err_ctx = ctx}) (*error*) in\r
- match range.info.type_description with\r
- | Types.ComponentElement cpnt_type ->\r
- let cl_spec = evaluate cpnt_type.Types.base_class in\r
- let cpnt_type' =\r
- { cpnt_type with\r
- Types.base_class = lazy (sub_dimension cl_spec)\r
- } in\r
- Types.ComponentElement cpnt_type'\r
- | Types.ClassElement _ | Types.ComponentTypeElement _ |\r
- Types.PredefinedTypeElement _ ->\r
- raise (CompilError\r
- {err_msg = ["_ClassElemFoundInExpr"];\r
- err_info = [];\r
- err_ctx = ctx}) (*error*) in\r
- let rec resolve_for_clause_e' acc ctx = function\r
- | [] ->\r
- let equs' = List.flatten (List.map (resolve_equation ctx) equs) in\r
- [{\r
- nature = ForClauseE (List.rev acc, equs');\r
- info = Some equ\r
- }]\r
- | (_, None) :: _ ->\r
- raise (CompilError\r
- {err_msg = ["_NotYetImplemented"; "_ImplicitIterRange"];\r
- err_info = [];\r
- err_ctx = ctx})\r
- | (id, Some expr) :: for_inds ->\r
- let range = resolve_expression ctx expr in\r
- let elt_nat = range_element_type expr range in\r
- let ctx' =\r
- { ctx with\r
- context_nature = ForContext (ctx, id, elt_nat)\r
- } in\r
- resolve_for_clause_e' (range :: acc) ctx' for_inds in\r
- resolve_for_clause_e' [] ctx for_inds\r
-\r
-and resolve_connect_clause ctx equ expres expres' =\r
- let expr = resolve_expression ctx expres\r
- and expr' = resolve_expression ctx expres' in\r
- let resolve_connect_clause' cpnt_typ cpnt_typ' =\r
- let rec class_type_of_class_specifier cl_spec = match cl_spec with\r
- | Types.ClassType cl_type -> cl_type\r
- | Types.ComponentType cpnt_type ->\r
- let cl_spec = evaluate cpnt_type.Types.base_class in\r
- class_type_of_class_specifier cl_spec\r
- | Types.ArrayType (_, cl_spec) -> class_type_of_class_specifier cl_spec\r
- | Types.PredefinedType _ | Types.TupleType _ ->\r
- raise (CompilError\r
- {err_msg = ["_InvalidTypeOfArgInConnectStat"];\r
- err_info =\r
- [("_ExprKind", "connect(A, B)");\r
- ("_TypeOfA", Types.string_of_component_type cpnt_typ);\r
- ("_TypeOfB", Types.string_of_component_type cpnt_typ')];\r
- err_ctx = ctx}) (*error*) in\r
- let connector_sign expr =\r
- let is_connector_type expr =\r
- let is_connector_type' cpnt_type =\r
- let cl_spec = evaluate cpnt_type.Types.base_class in\r
- let cl_type = class_type_of_class_specifier cl_spec in\r
- match evaluate cl_type.Types.kind with\r
- | Types.Connector | Types.ExpandableConnector -> true\r
- | Types.Class | Types.Model | Types.Block -> false\r
- | Types.Record ->\r
- raise (CompilError\r
- {err_msg =\r
- ["record"; "_InstanceUsedInConnection"];\r
- err_info = [];\r
- err_ctx = ctx}) (*error*)\r
- | Types.Package ->\r
- raise (CompilError\r
- {err_msg =\r
- ["package"; "_InstanceUsedInConnection"];\r
- err_info = [];\r
- err_ctx = ctx}) (*error*)\r
- | Types.Function ->\r
- raise (CompilError\r
- {err_msg =\r
- ["function"; "_InstanceUsedInConnection"];\r
- err_info = [];\r
- err_ctx = ctx}) (*error*) in\r
- match expr.info.type_description with\r
- | Types.ComponentElement cpnt_type ->\r
- is_connector_type' cpnt_type\r
- | _ ->\r
- raise (CompilError\r
- {err_msg = ["_ClassElemFoundInExpr"];\r
- err_info = [];\r
- err_ctx = ctx}) (*error*) in\r
- let is_connectable expr =\r
- let is_connectable' cpnt_type =\r
- let cl_spec = evaluate cpnt_type.Types.base_class in\r
- let cl_type = class_type_of_class_specifier cl_spec in\r
- match evaluate cl_type.Types.kind with\r
- | Types.Class | Types.Model | Types.Block -> true\r
- | Types.Connector | Types.ExpandableConnector -> false\r
- | Types.Record ->\r
- raise (CompilError\r
- {err_msg =\r
- ["record"; "_InstanceUsedInConnection"];\r
- err_info = [];\r
- err_ctx = ctx}) (*error*)\r
- | Types.Package ->\r
- raise (CompilError\r
- {err_msg =\r
- ["package"; "_InstanceUsedInConnection"];\r
- err_info = [];\r
- err_ctx = ctx}) (*error*)\r
- | Types.Function ->\r
- raise (CompilError\r
- {err_msg =\r
- ["function"; "_InstanceUsedInConnection"];\r
- err_info = [];\r
- err_ctx = ctx}) (*error*) in\r
- match expr.info.type_description with\r
- | Types.ComponentElement cpnt_type ->\r
- is_connectable' cpnt_type\r
- | _ ->\r
- raise (CompilError\r
- {err_msg = ["_ClassElemFoundInExpr"];\r
- err_info = [];\r
- err_ctx = ctx}) (*error*) in\r
- let rec connector_sign' expr = match expr.nature with\r
- | LocalIdentifier (0, _) when is_connector_type expr -> Some Negative\r
- | LocalIdentifier (0, _) when is_connectable expr -> Some Positive\r
- | (FieldAccess (expr', _) | IndexedAccess (expr', _))\r
- when is_connector_type expr -> connector_sign' expr'\r
- | (FieldAccess (expr', _) | IndexedAccess (expr', _))\r
- when is_connectable expr' -> connector_sign' expr'\r
- | _ ->\r
- raise (CompilError\r
- {err_msg = ["_InvalidTypeOfArgInConnectStat"];\r
- err_info =\r
- [("_ExprKind", "connect(A, B)");\r
- ("_TypeOfA", Types.string_of_component_type cpnt_typ);\r
- ("_TypeOfB", Types.string_of_component_type cpnt_typ')];\r
- err_ctx = ctx}) (*error*) in\r
- match expr.nature with\r
- | _ when not (is_connector_type expr) ->\r
- raise (CompilError\r
- {err_msg = ["_InvalidTypeOfArgInConnectStat"];\r
- err_info =\r
- [("_ExprKind", "connect(A, B)");\r
- ("_TypeOfA", Types.string_of_component_type cpnt_typ);\r
- ("_TypeOfB", Types.string_of_component_type cpnt_typ')];\r
- err_ctx = ctx}) (*error*)\r
- | LocalIdentifier (0, _) -> Some Negative\r
- | _ -> connector_sign' expr in\r
- let connect sign cpnt_type sign' cpnt_type' =\r
- let resolved_equation syn expr expr' =\r
- let elt_nat = expr.info.type_description\r
- and elt_nat' = expr'.info.type_description in\r
- let flow, _, _ = type_prefixes_of_element_nature elt_nat\r
- and flow', _, _ = type_prefixes_of_element_nature elt_nat' in\r
- match flow, flow' with\r
- | false, false ->\r
- {\r
- nature = Equal (expr, expr');\r
- info = syn\r
- }\r
- | true, true ->\r
- {\r
- nature = ConnectFlows (sign, expr, sign', expr');\r
- info = syn\r
- }\r
- | false, true ->\r
- raise (CompilError\r
- {err_msg = ["_CannotConnectFlowAndNonFlowComp"];\r
- err_info =\r
- [("_ExprKind", "connect(A, B)");\r
- ("_TypeOfA", "non-flow connector");\r
- ("_TypeOfB", "flow connector")];\r
- err_ctx = ctx}) (*error*)\r
- | true, false ->\r
- raise (CompilError\r
- {err_msg = ["_CannotConnectFlowAndNonFlowComp"];\r
- err_info =\r
- [("_ExprKind", "connect(A, B)");\r
- ("_TypeOfA", "flow connector");\r
- ("_TypeOfB", "non-flow connector")];\r
- err_ctx = ctx}) (*error*) in\r
- equations ctx equ resolved_equation cpnt_type expr cpnt_type' expr' in\r
- match connector_sign expr, connector_sign expr' with\r
- | Some sign, Some sign' -> connect sign cpnt_typ sign' cpnt_typ'\r
- | None, Some _ -> assert false\r
- | Some _, None -> assert false\r
- | None, None -> assert false in\r
- let elt_nat = expr.info.type_description\r
- and elt_nat' = expr'.info.type_description in\r
- match elt_nat, elt_nat' with\r
- | Types.ComponentElement cpnt_typ, Types.ComponentElement cpnt_typ' ->\r
- resolve_connect_clause' cpnt_typ cpnt_typ'\r
- | _, _ ->\r
- raise (CompilError\r
- {err_msg = ["_InvalidTypeOfArgInConnectStat"];\r
- err_info =\r
- [("_ExprKind", "connect(A, B)");\r
- ("_TypeOfA", Types.string_of_element_nature elt_nat);\r
- ("_TypeOfB", Types.string_of_element_nature elt_nat')];\r
- err_ctx = ctx}) (*error*)\r
-\r
-and resolve_when_clause_e ctx equ alts =\r
- let resolve_alternative (expr, equs) =\r
- let expr' = resolve_expression ctx expr in\r
- let rec check_equation equ =\r
- let check_equal expr expr' =\r
- match expr.Syntax.nature, expr'.Syntax.nature with\r
- | _, _ when expression_of_variable expr -> true\r
- | Syntax.Tuple exprs, Syntax.FunctionCall _\r
- when List.for_all expression_of_variable exprs -> true\r
- | _, _ -> raise (CompilError\r
- {err_msg = ["_InvalidWhenEquation"];\r
- err_info = [];\r
- err_ctx = {ctx with location = expr.Syntax.info}}) (*error*) in\r
- let check_alternative (expr, equs) =\r
- List.for_all check_equation equs in\r
- let check_function_call_e expr fun_args =\r
- match expr.Syntax.nature with\r
- | Syntax.Identifier "assert" |\r
- Syntax.Identifier "terminate" |\r
- Syntax.Identifier "reinit" -> true\r
- | _ ->\r
- raise (CompilError\r
- {err_msg = ["_InvalidWhenEquation"];\r
- err_info = [];\r
- err_ctx = {ctx with location = expr.Syntax.info}}) in\r
- match equ.Syntax.nature with\r
- | Syntax.Equal (expr, expr') -> check_equal expr expr'\r
- | Syntax.ConditionalEquationE (alts, None) ->\r
- List.for_all check_alternative alts\r
- | Syntax.ConditionalEquationE (alts, Some equs) ->\r
- (List.for_all check_alternative alts) &&\r
- (List.for_all check_equation equs)\r
- | Syntax.ForClauseE (for_inds, equs) ->\r
- List.for_all check_equation equs\r
- | Syntax.ConnectClause (expr, expr') ->\r
- raise (CompilError\r
- {err_msg = ["_InvalidWhenEquation"];\r
- err_info = [];\r
- err_ctx = {ctx with location = equ.Syntax.info}}) (*error*)\r
- | Syntax.WhenClauseE alts ->\r
- raise (CompilError\r
- {err_msg = ["_WhenClausesCannotBeNested"];\r
- err_info = [];\r
- err_ctx = {ctx with location = equ.Syntax.info}}) (*error*)\r
- | Syntax.FunctionCallE (expr, fun_args) ->\r
- check_function_call_e expr fun_args in\r
- let resolve_alternative' cpnt_type =\r
- let cl_spec = evaluate cpnt_type.Types.base_class in\r
- match cl_spec with\r
- | Types.ArrayType (Types.DiscreteDimension, _) ->\r
- raise (CompilError\r
- {err_msg = ["_InvalidTypeOfWhenCond"];\r
- err_info =\r
- [("_ExprKind", "...when A then...");\r
- ("_TypeOfA", Types.string_of_class_specifier cl_spec)];\r
- err_ctx = {ctx with location = expr.Syntax.info}}) (*error*)\r
- | Types.PredefinedType { Types.base_type = Types.BooleanType } |\r
- Types.ArrayType\r
- (_, Types.PredefinedType { Types.base_type = Types.BooleanType })\r
- when List.for_all check_equation equs ->\r
- let equs' = List.flatten (List.map (resolve_equation ctx) equs) in\r
- expr', equs'\r
- | Types.PredefinedType _ | Types.ClassType _ | Types.ComponentType _ |\r
- Types.ArrayType _ | Types.TupleType _ ->\r
- raise (CompilError\r
- {err_msg = ["_InvalidTypeOfWhenCond"];\r
- err_info =\r
- [("_ExprKind", "...when A then...");\r
- ("_TypeOfA", Types.string_of_class_specifier cl_spec)];\r
- err_ctx = {ctx with location = expr.Syntax.info}}) (*error*) in\r
- match expr'.info.type_description with\r
- | Types.ComponentElement cpnt_type\r
- when (evaluate cpnt_type.Types.variability) <> Types.Continuous ->\r
- resolve_alternative' cpnt_type\r
- | Types.ComponentElement cpnt_type ->\r
- raise (CompilError\r
- {err_msg = ["_WhenConditionMustBeDiscrete"];\r
- err_info = [];\r
- err_ctx = {ctx with location = expr.Syntax.info}}) (*error*)\r
- | Types.ClassElement _ | Types.ComponentTypeElement _ |\r
- Types.PredefinedTypeElement _ ->\r
- raise (CompilError\r
- {err_msg = ["_ClassElemFoundInExpr"];\r
- err_info = [];\r
- err_ctx = {ctx with location = expr.Syntax.info}}) (*error*) in\r
- let alts' = List.map resolve_alternative alts in\r
- [{\r
- nature = WhenClauseE alts';\r
- info = Some equ\r
- }]\r
-\r
-and resolve_functional_call_e ctx equ expr fun_args =\r
- let ctx = {ctx with location = equ.Syntax.info} in\r
- let res =\r
- let nat = Tuple []\r
- and elt_nat = Types.empty_tuple_type Types.Constant in\r
- resolved_expression None nat elt_nat in\r
- let fun_call = resolve_function_call ctx None expr fun_args in\r
- let resolve_functional_call_e cpnt_type =\r
- let cl_spec = evaluate cpnt_type.Types.base_class in\r
- match cl_spec with\r
- | Types.TupleType [] ->\r
- [{\r
- nature = Equal (res, fun_call);\r
- info = Some equ\r
- }]\r
- | _ ->\r
- raise (CompilError\r
- {err_msg = ["_NonEmptyFuncCallUsedAsAnEqu"];\r
- err_info =\r
- [("_TypeOfFuncValue", Types.string_of_class_specifier cl_spec)];\r
- err_ctx = ctx}) (*error*) in\r
- match fun_call.info.type_description with\r
- | Types.ComponentElement cpnt_type -> resolve_functional_call_e cpnt_type\r
- | Types.ClassElement _ | Types.ComponentTypeElement _ |\r
- Types.PredefinedTypeElement _ ->\r
- raise (CompilError\r
- {err_msg = ["_ClassElemFoundInExpr"];\r
- err_info = [];\r
- err_ctx = ctx}) (*error*)\r
-\r
-and equations ctx equ resolved_equation cpnt_type expr cpnt_type' expr' =\r
- let equivalent_types predef predef' =\r
- match Types.compare_predefined_types predef predef',\r
- Types.compare_predefined_types predef' predef with\r
- | _, Types.NotRelated | Types.NotRelated, _ -> false\r
- | _ -> true in\r
- let rec equations' i subs cl_spec expr cl_spec' expr' =\r
- match cl_spec, cl_spec' with\r
- | Types.PredefinedType predef, Types.PredefinedType predef'\r
- when equivalent_types predef predef' ->\r
- [equation subs expr expr']\r
- | Types.ComponentType cpnt_type, Types.ComponentType cpnt_type' ->\r
- raise (CompilError\r
- {err_msg = ["_NotYetImplemented"; "_ComponentTypeEqu"];\r
- err_info = [];\r
- err_ctx = ctx})\r
- | Types.ClassType cl_type, Types.ClassType cl_type' ->\r
- record_equations subs cl_type expr cl_type' expr'\r
- | Types.ArrayType (dim, cl_spec), Types.ArrayType (dim', cl_spec') ->\r
- [for_equation i subs dim cl_spec expr dim' cl_spec' expr']\r
- | Types.TupleType cl_specs, Types.TupleType cl_specs' ->\r
- [{\r
- nature = Equal (expr, expr');\r
- info = Some equ\r
- }]\r
- | (Types.PredefinedType _ | Types.ComponentType _ | Types.ArrayType _ |\r
- Types.TupleType _ | Types.ClassType _),\r
- (Types.PredefinedType _ | Types.ComponentType _ | Types.ArrayType _ |\r
- Types.TupleType _ | Types.ClassType _) ->\r
- raise (CompilError\r
- {err_msg = ["_EquTermsNotOfTheSameType"];\r
- err_info =\r
- [("_ExprKind", "A = B");\r
- ("_TypeOfA", Types.string_of_class_specifier cl_spec);\r
- ("_TypeOfB", Types.string_of_class_specifier cl_spec')];\r
- err_ctx = {ctx with location = equ.Syntax.info}}) (*error*)\r
- and for_equation i subs dim cl_spec expr dim' cl_spec' expr' =\r
- match dim, dim' with\r
- | Types.ConstantDimension n, Types.ConstantDimension n' when n <> n' ->\r
- let type_A = Types.string_of_component_type cpnt_type\r
- and type_B = Types.string_of_component_type cpnt_type' in\r
- raise (CompilError\r
- {err_msg = ["_ArrayDimMismatchInEqu"];\r
- err_info = [("_ExprKind", "A = B");\r
- ("_TypeOfA", type_A);\r
- ("_TypeOfB", type_B)];\r
- err_ctx = ctx}) (*error*)\r
- | (Types.ConstantDimension _ | Types.ParameterDimension),\r
- (Types.ConstantDimension _ | Types.ParameterDimension) ->\r
- let range = resolve_colon ctx expr (Int32.of_int i) dim in\r
- let subs =\r
- let nat = LoopVariable (i - 1)\r
- and elt_nat = Types.integer_type Types.Constant in\r
- resolved_expression None nat elt_nat :: subs in\r
- let equs = equations' (i + 1) subs cl_spec expr cl_spec' expr' in\r
- {\r
- nature = ForClauseE ([range], equs);\r
- info = Some equ\r
- }\r
- | (Types.ConstantDimension _ | Types.ParameterDimension |\r
- Types.DiscreteDimension),\r
- (Types.ConstantDimension _ | Types.ParameterDimension |\r
- Types.DiscreteDimension) ->\r
- let type_A = Types.string_of_component_type cpnt_type\r
- and type_B = Types.string_of_component_type cpnt_type' in\r
- raise (CompilError\r
- {err_msg = ["_ArrayDimMismatchInEqu"];\r
- err_info = [("_ExprKind", "A = B");\r
- ("_TypeOfA", type_A);\r
- ("_TypeOfB", type_B)];\r
- err_ctx = ctx}) (*error*)\r
- and record_equations subs cl_type expr cl_type' expr' =\r
- let named_elts = cl_type.Types.named_elements\r
- and named_elts' = cl_type'.Types.named_elements in\r
- let record_equations' expr expr' =\r
- let class_spec_of_element_type elt_type =\r
- let elt_type' = evaluate elt_type in\r
- element_nature_class ctx elt_type'.Types.element_nature in\r
- let record_equation (id, elt_type) =\r
- let elt_type' =\r
- try\r
- List.assoc id named_elts'\r
- with _ ->\r
- raise (CompilError\r
- {err_msg = ["_EquTermsNotOfTheSameType"];\r
- err_info =\r
- [("_ExprKind", "A = B");\r
- ("_TypeOfA", Types.string_of_component_type cpnt_type);\r
- ("_TypeOfB", Types.string_of_component_type cpnt_type')];\r
- err_ctx = {ctx with location = equ.Syntax.info}}) (*error*) in\r
- let cl_spec = class_spec_of_element_type elt_type\r
- and cl_spec' = class_spec_of_element_type elt_type' in\r
- let expr =\r
- let nat = FieldAccess (expr, id)\r
- and flow, var, inout =\r
- type_prefixes_of_element_nature expr.info.type_description\r
- and cl_spec = element_nature_class ctx expr.info.type_description in\r
- let elt_nat =\r
- element_field_type_nature ctx flow var inout cl_spec id in\r
- resolved_expression None nat elt_nat\r
- and expr' =\r
- let nat = FieldAccess (expr', id)\r
- and flow, var, inout =\r
- type_prefixes_of_element_nature expr'.info.type_description\r
- and cl_spec = element_nature_class ctx expr'.info.type_description in\r
- let elt_nat =\r
- element_field_type_nature ctx flow var inout cl_spec id in\r
- resolved_expression None nat elt_nat in\r
- equations' 1 [] cl_spec expr cl_spec' expr' in\r
- List.flatten (List.map record_equation named_elts) in\r
- match subs with\r
- | [] -> record_equations' expr expr'\r
- | subs ->\r
- let expr =\r
- let elt_nat = expr.info.type_description in\r
- let nat = IndexedAccess (expr, subs)\r
- and elt_nat' = scalar_element_nature elt_nat in\r
- resolved_expression None nat elt_nat'\r
- and expr' =\r
- let elt_nat = expr'.info.type_description in\r
- let nat = IndexedAccess (expr', subs)\r
- and elt_nat' = scalar_element_nature elt_nat in\r
- resolved_expression None nat elt_nat' in\r
- record_equations' expr expr'\r
- and equation subs expr expr' = match subs with\r
- | [] -> resolved_equation (Some equ) expr expr'\r
- | subs ->\r
- let expr =\r
- let elt_nat = expr.info.type_description in\r
- let nat = IndexedAccess (expr, subs)\r
- and elt_nat' = scalar_element_nature elt_nat in\r
- resolved_expression None nat elt_nat'\r
- and expr' =\r
- let elt_nat = expr'.info.type_description in\r
- let nat = IndexedAccess (expr', subs)\r
- and elt_nat' = scalar_element_nature elt_nat in\r
- resolved_expression None nat elt_nat' in\r
- resolved_equation None expr expr' in\r
- let cl_spec = evaluate cpnt_type.Types.base_class\r
- and cl_spec' = evaluate cpnt_type'.Types.base_class in\r
- equations' 1 [] cl_spec expr cl_spec' expr'\r
-\r
-and resolve_algorithm ctx algo =\r
- let ctx = {ctx with location = algo.Syntax.info} in\r
- match algo.Syntax.nature with\r
- | Syntax.Assign _ |\r
- Syntax.FunctionCallA _ |\r
- Syntax.MultipleAssign _ |\r
- Syntax.Break |\r
- Syntax.Return |\r
- Syntax.ConditionalEquationA _ |\r
- Syntax.ForClauseA _ |\r
- Syntax.WhileClause _ |\r
- Syntax.WhenClauseA _ ->\r
- raise (CompilError\r
- {err_msg = ["_NotYetImplemented"; "_AlgoClause"];\r
- err_info = [];\r
- err_ctx = ctx})\r
-\r
-and resolve_expression ctx expr =\r
- let ctx = {ctx with location = expr.Syntax.info} in\r
- match expr.Syntax.nature with\r
- | Syntax.BinaryOperation (kind, arg1, arg2) ->\r
- resolve_binary_operation ctx expr kind arg1 arg2\r
- | Syntax.End -> resolve_end ctx expr\r
- | Syntax.False -> resolve_false ctx expr\r
- | Syntax.FieldAccess (expr', id) -> resolve_field_access ctx expr expr' id\r
- | Syntax.FunctionCall (expr', fun_args) ->\r
- resolve_function_call ctx (Some expr) expr' fun_args\r
- | Syntax.Identifier id -> resolve_identifier ctx expr id\r
- | Syntax.If (alts, expr') -> resolve_if ctx expr alts expr'\r
- | Syntax.IndexedAccess (expr', subs) ->\r
- resolve_indexed_access ctx expr expr' subs\r
- | Syntax.Integer s -> resolve_integer ctx expr s\r
- | Syntax.MatrixConstruction exprss ->\r
- resolve_matrix_construction ctx expr exprss\r
- | Syntax.NoEvent expr' ->\r
- resolve_no_event ctx expr expr'\r
- | Syntax.Range (start, step, stop) ->\r
- resolve_range ctx expr start step stop\r
- | Syntax.Real s -> resolve_real ctx expr s\r
- | Syntax.String s -> resolve_string ctx expr s\r
- | Syntax.True -> resolve_true ctx expr\r
- | Syntax.Tuple exprs -> resolve_tuple ctx expr exprs\r
- | Syntax.UnaryOperation (kind, arg) ->\r
- resolve_unuary_operation ctx expr kind arg\r
- | Syntax.Vector vec_elts -> resolve_vector ctx expr vec_elts\r
-\r
-and resolve_binary_operation ctx expr kind arg1 arg2 =\r
- let arg1' = resolve_expression ctx arg1\r
- and arg2' = resolve_expression ctx arg2 in\r
- let args' = apply_binary_coercions [ arg1'; arg2' ] in\r
- let arg1' = List.nth args' 0\r
- and arg2' = List.nth args' 1 in\r
- match kind.Syntax.nature with\r
- | Syntax.Plus -> resolve_addition ctx expr arg1' arg2'\r
- | Syntax.And -> resolve_and ctx expr arg1' arg2'\r
- | Syntax.Divide -> resolve_division ctx expr arg1' arg2'\r
- | Syntax.EqualEqual -> raise (CompilError\r
- {err_msg = ["_NotYetImplemented"; "_BinaryOperEQUEQU"];\r
- err_info = [];\r
- err_ctx = ctx})\r
- | Syntax.GreaterEqual ->\r
- resolve_comparison ctx expr GreaterEqual arg1' arg2'\r
- | Syntax.Greater -> resolve_comparison ctx expr Greater arg1' arg2'\r
- | Syntax.LessEqual -> resolve_comparison ctx expr LessEqual arg1' arg2'\r
- | Syntax.Less -> resolve_comparison ctx expr Less arg1' arg2'\r
- | Syntax.Times -> resolve_multiplication ctx expr arg1' arg2'\r
- | Syntax.NotEqual -> raise (CompilError\r
- {err_msg = ["_NotYetImplemented"; "_BinaryOperDIFF"];\r
- err_info = [];\r
- err_ctx = ctx})\r
- | Syntax.Or -> resolve_or ctx expr arg1' arg2'\r
- | Syntax.Power -> resolve_power ctx expr arg1' arg2'\r
- | Syntax.Minus -> resolve_subtraction ctx expr arg1' arg2'\r
-\r
-and resolve_end ctx expr =\r
- let ctx = {ctx with location = expr.Syntax.info} in\r
- match ctx.context_nature with\r
- | SubscriptContext (_, _, _, Types.ConstantDimension n) ->\r
- let nat = Integer n\r
- and elt_nat = Types.integer_type Types.Constant in\r
- resolved_expression (Some expr) nat elt_nat\r
- | SubscriptContext (_, expr', n, Types.ParameterDimension) ->\r
- size_function_call ctx (Some expr) expr' n\r
- | SubscriptContext (_, expr', n, Types.DiscreteDimension) ->\r
- size_function_call ctx (Some expr) expr' n\r
- | ForContext (ctx', _, _) -> resolve_end ctx' expr\r
- | ToplevelContext | ClassContext _ ->\r
- raise (CompilError\r
- {err_msg = ["_InvalidKeyWordEndInExpr"];\r
- err_info = [];\r
- err_ctx = ctx}) (*error*)\r
-\r
-and resolve_false ctx expr =\r
- resolved_expression (Some expr) False (Types.boolean_type Types.Constant)\r
-\r
-and resolve_field_access ctx expr expr' id =\r
- let expr' = resolve_expression ctx expr' in\r
- let resolve_field_access' expr' id =\r
- let nat = FieldAccess (expr', id)\r
- and flow, var, inout =\r
- type_prefixes_of_element_nature expr'.info.type_description\r
- and cl_spec = element_nature_class ctx expr'.info.type_description in\r
- let elt_nat = element_field_type_nature ctx flow var inout cl_spec id in\r
- resolved_expression (Some expr) nat elt_nat in\r
- let is_package cl_spec = match evaluate cl_spec with\r
- | Types.ClassType cl_type\r
- when evaluate cl_type.Types.kind = Types.Package -> true\r
- | _ -> false in\r
- match expr'.info.type_description with\r
- | Types.ComponentElement _ ->\r
- resolve_field_access' expr' id\r
- | Types.ClassElement cl_spec when is_package cl_spec ->\r
- resolve_field_access' expr' id\r
- | _ ->\r
- raise (CompilError\r
- {err_msg = ["component or package"; "_ElemExpected"];\r
- err_info = [];\r
- err_ctx = { ctx with location = expr.Syntax.info }}) (*error*)\r
-\r
-and type_prefixes_of_element_nature = function\r
- | Types.ComponentElement cpnt_type ->\r
- evaluate cpnt_type.Types.flow,\r
- evaluate cpnt_type.Types.variability,\r
- evaluate cpnt_type.Types.causality\r
- | Types.ClassElement _ | Types.ComponentTypeElement _ |\r
- Types.PredefinedTypeElement _ ->\r
- false, Types.Constant, Types.Acausal\r
-\r
-and resolve_function_call ctx syn expr fun_args =\r
- let ctx = {ctx with location = expr.Syntax.info} in\r
- let expr' = resolve_expression ctx expr in\r
- let resolve_function_arguments named_elts =\r
- let reversed_additional_dimensions input_types args =\r
- let additional_named_element_dimensions id arg =\r
- let rec subtract_dimensions fun_dims arg_dims =\r
- match fun_dims, arg_dims with\r
- | [], _ -> arg_dims\r
- | _, [] ->\r
- raise (CompilError\r
- {err_msg = ["_ArgDimMismatch"];\r
- err_info = [];\r
- err_ctx = ctx}) (*error*)\r
- | Types.ConstantDimension i :: _, Types.ConstantDimension i' :: _\r
- when i <> i' ->\r
- raise (CompilError\r
- {err_msg = ["_ArgDimMismatch"];\r
- err_info = [];\r
- err_ctx = ctx}) (*error*)\r
- | _ :: fun_dims, _ :: arg_dims ->\r
- subtract_dimensions fun_dims arg_dims in\r
- let elt_type = List.assoc id input_types in\r
- let elt_type' = evaluate elt_type in\r
- let fun_dims =\r
- Types.reversed_element_dimensions elt_type'.Types.element_nature\r
- and arg_dims =\r
- Types.reversed_element_dimensions arg.info.type_description in\r
- subtract_dimensions fun_dims arg_dims in\r
- let rec reversed_additional_dimensions' ids dims args =\r
- match args with\r
- | [] -> ids, dims\r
- | (id, arg) :: args ->\r
- let dims' = additional_named_element_dimensions id arg in\r
- update_additional_dimensions ids dims id dims' args\r
- and update_additional_dimensions ids dims id dims' args =\r
- match dims, dims' with\r
- | _, [] -> reversed_additional_dimensions' ids dims args\r
- | [], _ :: _ ->\r
- let ids' = id :: ids in\r
- reversed_additional_dimensions' ids' dims' args\r
- | _ :: _, _ :: _ when dims <> dims' ->\r
- raise (CompilError\r
- {err_msg = ["_ArgDimMismatchInVectCall"];\r
- err_info = [];\r
- err_ctx = ctx}) (*error*)\r
- | _ :: _, _ :: _ ->\r
- let ids' = id :: ids in\r
- reversed_additional_dimensions' ids' dims args in\r
- reversed_additional_dimensions' [] [] args in\r
- let function_call ids rev_dims input_types output_types args =\r
- let ndims = List.length rev_dims in\r
- let rec expressions_of_named_arguments pos input_types =\r
- let expression_of_default_argument id elt_type =\r
- let elt_type' = evaluate elt_type in\r
- let func =\r
- let nat = FunctionArgument 0\r
- and elt_nat = expr'.info.type_description in\r
- resolved_expression None nat elt_nat in\r
- let nat = FieldAccess (func, id)\r
- and elt_nat = elt_type'.Types.element_nature in\r
- resolved_expression None nat elt_nat\r
- and expression_of_named_argument pos id elt_type =\r
- let rec loop_variables = function\r
- | 0 -> []\r
- | ndims ->\r
- let nat = LoopVariable (ndims - 1)\r
- and elt_nat = (Types.integer_type Types.Constant) in\r
- let loop_var = resolved_expression None nat elt_nat in\r
- loop_var :: loop_variables (ndims - 1) in\r
- let elt_type' = evaluate elt_type in\r
- let elt_nat = elt_type'.Types.element_nature in\r
- let nat = match List.mem id ids with\r
- | false -> FunctionArgument pos\r
- | true ->\r
- let arg = List.assoc id args in\r
- let nat = FunctionArgument pos\r
- and elt_nat = arg.info.type_description in\r
- let expr = resolved_expression None nat elt_nat in\r
- IndexedAccess (expr, loop_variables ndims) in\r
- resolved_expression None nat elt_nat in\r
- match input_types with\r
- | [] -> []\r
- | (id, elt_type) :: input_types when not (List.mem_assoc id args) ->\r
- let arg = expression_of_default_argument id elt_type in\r
- arg :: expressions_of_named_arguments pos input_types\r
- | (id, elt_type) :: input_types ->\r
- let arg = expression_of_named_argument pos id elt_type in\r
- arg :: expressions_of_named_arguments (pos + 1) input_types in\r
- let ranges arg rev_dims =\r
- let rec ranges' acc n rev_dims =\r
- let range_of_dimension dim =\r
- let range_to stop =\r
- let nat = Range (one, one, stop)\r
- and elt_nat = Types.integer_array_type Types.Constant dim in\r
- resolved_expression None nat elt_nat in\r
- match dim with\r
- | Types.ConstantDimension i ->\r
- let stop =\r
- let nat = Integer i\r
- and elt_nat = (Types.integer_type Types.Constant) in\r
- resolved_expression None nat elt_nat in\r
- range_to stop\r
- | Types.ParameterDimension ->\r
- let stop = size_function_call ctx None arg n in\r
- range_to stop\r
- | Types.DiscreteDimension ->\r
- let stop = size_function_call ctx None arg n in\r
- range_to stop in\r
- match rev_dims with\r
- | [] -> acc\r
- | dim :: rev_dims ->\r
- let range = range_of_dimension dim in\r
- ranges' (range :: acc) (Int32.succ n) rev_dims in\r
- ranges' [] 1l rev_dims in\r
- let rec sorted_arguments_of_named_arguments = function\r
- | [] -> []\r
- | (id, _) :: input_types when not (List.mem_assoc id args) ->\r
- sorted_arguments_of_named_arguments input_types\r
- | (id, _) :: input_types ->\r
- let arg = List.assoc id args in\r
- arg :: sorted_arguments_of_named_arguments input_types in\r
- let wrap_function_invocation cpnt_type =\r
- let add_dimensions cpnt_type =\r
- let rec add_dimensions cl_spec = function\r
- | [] -> cl_spec\r
- | dim :: rev_dims ->\r
- let cl_spec' = Types.ArrayType (dim, cl_spec) in\r
- add_dimensions cl_spec' rev_dims in\r
- let base_class = cpnt_type.Types.base_class in\r
- { cpnt_type with\r
- Types.base_class =\r
- lazy (add_dimensions (evaluate base_class) rev_dims)\r
- } in\r
- let wrap_function_invocation' cpnt_type rev_dims =\r
- let nat =\r
- let exprs = expressions_of_named_arguments 1 input_types in\r
- FunctionInvocation exprs\r
- and elt_nat = Types.ComponentElement cpnt_type in\r
- match ids with\r
- | [] ->\r
- resolved_expression syn nat elt_nat\r
- | id :: _ ->\r
- let cpnt_type' = add_dimensions cpnt_type in\r
- let nat =\r
- let ranges =\r
- let arg = List.assoc id args in\r
- ranges arg rev_dims\r
- and expr = resolved_expression None nat elt_nat in\r
- VectorReduction (ranges, expr)\r
- and elt_nat = Types.ComponentElement cpnt_type' in\r
- resolved_expression None nat elt_nat in\r
- wrap_function_invocation' cpnt_type rev_dims in\r
- let component_type_of_output_types output_types =\r
- let component_type_of_output_type cpnt_type (_, elt_type) =\r
- let add_class_specifier cl_spec cl_spec' =\r
- match cl_spec, cl_spec' with\r
- | Types.TupleType [], _ -> cl_spec'\r
- | (Types.TupleType cl_specs), _ ->\r
- Types.TupleType (cl_spec' :: cl_specs)\r
- | _, _ -> Types.TupleType [cl_spec'; cl_spec] in\r
- let var = evaluate cpnt_type.Types.variability\r
- and cl_spec = evaluate cpnt_type.Types.base_class in\r
- let elt_type' = evaluate elt_type in\r
- match elt_type'.Types.element_nature with\r
- | Types.ComponentElement cpnt_type' ->\r
- let var' = evaluate cpnt_type'.Types.variability\r
- and cl_spec' = evaluate cpnt_type'.Types.base_class in\r
- {\r
- Types.flow = lazy false;\r
- Types.variability = lazy (Types.max_variability var var');\r
- Types.causality = lazy Types.Acausal;\r
- Types.base_class = lazy (add_class_specifier cl_spec cl_spec')\r
- }\r
- | Types.ClassElement _ | Types.ComponentTypeElement _ |\r
- Types.PredefinedTypeElement _ ->\r
- raise (CompilError\r
- {err_msg = ["_ClassElemFoundInExpr"];\r
- err_info = [];\r
- err_ctx = ctx}) (*error*) in\r
- let cpnt_type =\r
- {\r
- Types.flow = lazy false;\r
- Types.variability = lazy Types.Constant;\r
- Types.causality = lazy Types.Acausal;\r
- Types.base_class = lazy (Types.TupleType [])\r
- } in\r
- List.fold_left component_type_of_output_type cpnt_type output_types in\r
- let args' = sorted_arguments_of_named_arguments input_types\r
- and cpnt_type = component_type_of_output_types output_types in\r
- let func_invoc = wrap_function_invocation cpnt_type in\r
- let nat = FunctionCall (expr', args', func_invoc)\r
- and elt_nat = func_invoc.info.type_description in\r
- resolved_expression syn nat elt_nat in\r
- let resolve_function_arguments' fun_args =\r
- match fun_args.Syntax.nature with\r
- | Syntax.Reduction _ ->\r
- raise (CompilError\r
- {err_msg = ["_NotYetImplemented"; "_FuncArgumentReduction"];\r
- err_info = [];\r
- err_ctx = ctx})\r
- | Syntax.ArgumentList args ->\r
- let input_types, output_types, named_args =\r
- resolve_function_argument_list ctx expr' named_elts args in\r
- let ids, rev_dims =\r
- reversed_additional_dimensions input_types named_args in\r
- function_call ids rev_dims input_types output_types named_args in\r
- match fun_args with\r
- | None ->\r
- let fun_args = { Syntax.nature = Syntax.ArgumentList [];\r
- Syntax.info = ctx.location } in\r
- resolve_function_arguments' fun_args\r
- | Some fun_args -> resolve_function_arguments' fun_args in\r
- let resolve_class_function_call cl_type =\r
- match evaluate cl_type.Types.kind with\r
- | Types.Function ->\r
- resolve_function_arguments cl_type.Types.named_elements\r
- | Types.Class | Types.Model | Types.Block | Types.Record |\r
- Types.ExpandableConnector | Types.Connector | Types.Package ->\r
- raise (CompilError\r
- {err_msg = ["function"; "_ElemExpected"];\r
- err_info = [];\r
- err_ctx = ctx}) (*error*) in\r
- let resolve_function_call' cl_spec =\r
- match evaluate cl_spec with\r
- | Types.ClassType cl_type ->\r
- resolve_class_function_call cl_type\r
- | _ ->\r
- raise (CompilError\r
- {err_msg = ["function"; "_ElemExpected"];\r
- err_info = [];\r
- err_ctx = ctx}) (*error*) in\r
- match expr'.info.type_description with\r
- | Types.ClassElement cl_spec -> resolve_function_call' cl_spec\r
- | Types.ComponentElement cpnt_type ->\r
- let cl_spec = cpnt_type.Types.base_class in\r
- resolve_function_call' cl_spec\r
- | Types.ComponentTypeElement _ | Types.PredefinedTypeElement _ ->\r
- raise (CompilError\r
- {err_msg = ["function"; "_ElemExpected"];\r
- err_info = [];\r
- err_ctx = ctx}) (*error*)\r
-\r
-and resolve_function_argument_list ctx expr' named_elts args =\r
- let rec class_kind ctx =\r
- let class_context' cl_spec = match cl_spec with\r
- | Types.ClassType cl_type ->\r
- Some (evaluate cl_type.Types.kind)\r
- | _ -> None in\r
- match ctx.context_nature with\r
- | ClassContext cl_def ->\r
- class_context' (evaluate cl_def.class_type)\r
- | SubscriptContext (ctx, _, _, _) | ForContext (ctx, _, _) ->\r
- class_kind ctx\r
- | _ -> None in\r
- let add_function_inout_argument ((id, elt_type) as named_elt) inouts =\r
- let add_function_inout_argument' cpnt_type =\r
- match inouts, evaluate cpnt_type.Types.causality with\r
- | (ins, outs), Types.Input -> named_elt :: ins, outs\r
- | (ins, outs), Types.Output -> ins, named_elt :: outs\r
- | _, Types.Acausal -> inouts in\r
- let elt_type' = evaluate elt_type in\r
- match elt_type'.Types.element_nature with\r
- | Types.ComponentElement cpnt_type when not elt_type'.Types.protected ->\r
- add_function_inout_argument' cpnt_type\r
- | _ -> inouts in\r
- let add_argument id arg arg' elt_type acc =\r
- let matchable_types cpnt_type cpnt_type' =\r
- let cl_spec = evaluate cpnt_type.Types.base_class\r
- and cl_spec' = evaluate cpnt_type'.Types.base_class in\r
- let rec matchable_types' cl_spec cl_spec' = match cl_spec, cl_spec' with\r
- | Types.ArrayType (dim, cl_spec), _ ->\r
- matchable_types' cl_spec cl_spec'\r
- | _, Types.ArrayType (dim', cl_spec') ->\r
- matchable_types' cl_spec cl_spec'\r
- | _, _ ->\r
- let type_compare = Types.compare_specifiers cl_spec cl_spec' in\r
- (type_compare = Types.SameType) ||\r
- (type_compare = Types.Supertype) in\r
- matchable_types' cl_spec cl_spec' in\r
- let matchable_variabilities cpnt_type cpnt_type' =\r
- let var = evaluate cpnt_type.Types.variability\r
- and var' = evaluate cpnt_type'.Types.variability in\r
- Types.higher_variability var var' in\r
- let elt_type = evaluate elt_type in\r
- let cpnt_type = match elt_type.Types.element_nature with\r
- | Types.ComponentElement cpnt_type -> cpnt_type\r
- | _ -> assert false in\r
- let arg' = apply_rhs_coercions cpnt_type arg' in\r
- match arg'.info.type_description with\r
- | Types.ComponentElement cpnt_type'\r
- when not (matchable_types cpnt_type cpnt_type') ->\r
- raise (CompilError\r
- {err_msg = ["_ArgTypeMismatch"];\r
- err_info =\r
- [("_ExpectedType", Types.string_of_component_type cpnt_type);\r
- ("_TypeFound", Types.string_of_component_type cpnt_type')];\r
- err_ctx = {ctx with location = arg.Syntax.info}}) (*error*)\r
- | Types.ComponentElement cpnt_type'\r
- when not (matchable_variabilities cpnt_type cpnt_type') ->\r
- let var = evaluate cpnt_type.Types.variability\r
- and var' = evaluate cpnt_type'.Types.variability in\r
- let var = Types.string_of_variability var\r
- and var' = Types.string_of_variability var' in\r
- raise (CompilError\r
- {err_msg = ["_ArgVariabilityMismatch"];\r
- err_info = [("_ExpectedVariability", var);\r
- ("_VariabilityFound", var')];\r
- err_ctx = {ctx with location = arg.Syntax.info}}) (*error*)\r
- | Types.ComponentElement cpnt_type' -> (id, arg') :: acc\r
- | _ -> raise (CompilError\r
- {err_msg = ["_ClassElemFoundInExpr"];\r
- err_info = [];\r
- err_ctx = {ctx with location = arg.Syntax.info}}) (*error*) in\r
- let named_arguments_of_arguments input_types args =\r
- let rec add_positional_arguments acc input_types args =\r
- match input_types, args with\r
- | [], [] -> acc\r
- | [], _ ->\r
- raise (CompilError\r
- {err_msg = ["_TooManyArgsInFuncCall"];\r
- err_info = [];\r
- err_ctx = ctx}) (*error*)\r
- | _, [] ->\r
- raise (CompilError\r
- {err_msg = ["_TooFewArgsInFuncCall"];\r
- err_info = [];\r
- err_ctx = ctx}) (*error*)\r
- | (id, elt_type) :: input_types,\r
- { Syntax.nature = Syntax.Argument arg } :: args ->\r
- let arg' = resolve_expression ctx arg in\r
- let acc = add_argument id arg arg' elt_type acc in\r
- add_positional_arguments acc input_types args\r
- | _, { Syntax.nature = Syntax.NamedArgument _ } :: _ ->\r
- add_named_arguments acc input_types args\r
- and add_named_arguments acc input_types args =\r
- match input_types, args with\r
- | [], [] -> acc\r
- | [], _ ->\r
- raise (CompilError\r
- {err_msg = ["_TooManyArgsInFuncCall"];\r
- err_info = [];\r
- err_ctx = ctx}) (*error*)\r
- | _, [] ->\r
- raise (CompilError\r
- {err_msg = ["_TooFewArgsInFuncCall"];\r
- err_info = [];\r
- err_ctx = ctx}) (*error*)\r
- | _, { Syntax.nature = Syntax.Argument _ } :: _ ->\r
- raise (CompilError\r
- {err_msg = ["_MixedPositAndNamedFuncArgPass"];\r
- err_info = [];\r
- err_ctx = ctx}) (*error*)\r
- | _, { Syntax.nature = Syntax.NamedArgument (id, _) } :: _\r
- when List.mem_assoc id acc ->\r
- raise (CompilError\r
- {err_msg = ["_FuncCallWithDuplicateArg"; id];\r
- err_info = [];\r
- err_ctx = ctx}) (*error*)\r
- | _, { Syntax.nature = Syntax.NamedArgument (id, _) } :: _\r
- when not (List.mem_assoc id input_types) ->\r
- raise (CompilError\r
- {err_msg = ["_NonInputFuncArgElem"; id];\r
- err_info = [];\r
- err_ctx = ctx}) (*error*)\r
- | _, { Syntax.nature = Syntax.NamedArgument (id, arg) } :: args ->\r
- let arg' = resolve_expression ctx arg\r
- and elt_type = List.assoc id input_types in\r
- let acc = add_argument id arg arg' elt_type acc in\r
- add_named_arguments acc input_types args in\r
- add_positional_arguments [] input_types args in\r
- let resolve_built_in_function_argument arg = match arg with\r
- | { Syntax.nature = Syntax.Argument arg } ->\r
- arg, (resolve_expression ctx arg)\r
- | { Syntax.nature = Syntax.NamedArgument _; Syntax.info = info } ->\r
- raise (CompilError\r
- {err_msg = ["_CannotUseNamedArgWithBuiltInOper"];\r
- err_info = [];\r
- err_ctx = {ctx with location = info}}) (*error*) in\r
- let rec built_in_function_named_arguments acc input_types args' =\r
- match input_types, args' with\r
- | [], [] -> acc\r
- | [], _ ->\r
- raise (CompilError\r
- {err_msg = ["_TooManyArgsInFuncCall"];\r
- err_info = [];\r
- err_ctx = ctx}) (*error*)\r
- | _, [] ->\r
- raise (CompilError\r
- {err_msg = ["_TooFewArgsInFuncCall"];\r
- err_info = [];\r
- err_ctx = ctx}) (*error*)\r
- | (id, elt_type) :: input_types, (arg, arg') :: args' ->\r
- let acc = add_argument id arg arg' elt_type acc in\r
- built_in_function_named_arguments acc input_types args' in\r
- let built_in_function_inout_types ctx id (in_types, out_types) args' =\r
- let argument_component_type (arg, arg') =\r
- match arg'.info.type_description with\r
- | Types.ComponentElement cpnt_type ->\r
- cpnt_type\r
- | _ -> raise (CompilError\r
- {err_msg = ["_ClassElemFoundInExpr"];\r
- err_info = [];\r
- err_ctx = {ctx with location = arg.Syntax.info}}) (*error*) in\r
- let scalar_base_class_specifier (arg, arg') =\r
- let rec scalar_base_class_specifier' cl_spec = match cl_spec with\r
- | Types.ArrayType (dim, cl_spec) -> scalar_base_class_specifier' cl_spec\r
- | _ -> cl_spec in\r
- let cpnt_type = argument_component_type (arg, arg') in\r
- let cl_spec = evaluate cpnt_type.Types.base_class in\r
- scalar_base_class_specifier' cl_spec in\r
- let argument_base_type bt (arg, arg') =\r
- let cl_spec = scalar_base_class_specifier (arg, arg') in\r
- match cl_spec with\r
- | Types.PredefinedType predef when predef.Types.base_type = bt -> true\r
- | _ -> false in\r
- let argument_base_types bt args =\r
- List.for_all (argument_base_type bt) args in\r
- let argument_variability var (arg, arg') =\r
- let cpnt_type = argument_component_type (arg, arg') in\r
- let var' = evaluate cpnt_type.Types.variability in\r
- var = var' in\r
- let neg f = function x -> not (f x) in\r
- let ndims arg' =\r
- let cpnt_type = component_type_of_expression ctx arg' in\r
- let rec ndims' cl_spec =\r
- match cl_spec with\r
- | Types.ArrayType (dim, cl_spec) -> ndims' cl_spec + 1\r
- | _ -> 0 in\r
- ndims' (evaluate cpnt_type.Types.base_class) in\r
- let numeric_base_type arg' =\r
- let cl_spec = scalar_class_specifier ctx arg' in\r
- (Types.compare_specifiers Types.integer_class_type cl_spec =\r
- Types.SameType) ||\r
- (Types.compare_specifiers Types.real_class_type cl_spec =\r
- Types.SameType) in\r
- let rec argument_types i args = match args with\r
- | [] -> []\r
- | (arg, arg') :: args ->\r
- let cpnt_type = component_type_of_expression ctx arg'\r
- and name = Printf.sprintf "@%d" i in\r
- (name, cpnt_type) :: (argument_types (i + 1) args) in\r
- let element_types input_types output_types =\r
- let element_type inout (id, cpnt_type) =\r
- (id,\r
- lazy\r
- {\r
- Types.protected = false;\r
- Types.final = true;\r
- Types.replaceable = false;\r
- Types.dynamic_scope = None;\r
- Types.element_nature =\r
- Types.ComponentElement\r
- { cpnt_type with Types.causality = lazy inout }\r
- }) in\r
- (List.map (element_type Types.Input) input_types),\r
- (List.map (element_type Types.Output) output_types) in\r
- match id, args' with\r
- | ("der" | "initial" | "terminal" | "sample" | "pre" | "edge" | "change" |\r
- "reinit" | "delay"), _ when (class_kind ctx) = Some Types.Function ->\r
- raise (CompilError\r
- {err_msg = [id; "_OperCannotBeUsedWithinFuncDef"];\r
- err_info = [];\r
- err_ctx = ctx}) (*error*)\r
- | ("pre" | "edge" | "change"), [arg, arg'] | "reinit", [(arg, arg'); _]\r
- when not (expression_of_variable arg) ->\r
- raise (CompilError\r
- {err_msg = [id; "_OperArgMustBeAVar"];\r
- err_info = [];\r
- err_ctx = {ctx with location = arg.Syntax.info}}) (*error*)\r
- | ("ceil" | "floor" | "integer" | "der"), [arg, arg'] |\r
- "reinit", [(arg, arg'); _] |\r
- "smooth", [_; (arg, arg')]\r
- when not (argument_base_type Types.RealType (arg, arg')) ->\r
- let cl_spec = scalar_base_class_specifier (arg, arg') in\r
- raise (CompilError\r
- {err_msg = ["_ArgTypeMismatch"];\r
- err_info =\r
- [("_ExpectedType", "Real");\r
- ("_TypeFound", Types.string_of_class_specifier cl_spec)];\r
- err_ctx = {ctx with location = arg.Syntax.info}}) (*error*)\r
- | "delay", _\r
- when not (List.for_all (argument_base_type Types.RealType) args') ->\r
- let (arg, arg') =\r
- List.find (neg (argument_base_type Types.RealType)) args' in\r
- let cl_spec = scalar_base_class_specifier (arg, arg') in\r
- raise (CompilError\r
- {err_msg = ["_ArgTypeMismatch"];\r
- err_info =\r
- [("_ExpectedType", "Real");\r
- ("_TypeFound", Types.string_of_class_specifier cl_spec)];\r
- err_ctx = {ctx with location = arg.Syntax.info}}) (*error*)\r
- | "der", [arg, arg']\r
- when not (argument_variability Types.Continuous (arg, arg')) ->\r
- let cpnt_type = argument_component_type (arg, arg') in\r
- let var = evaluate cpnt_type.Types.variability in\r
- let var = Types.string_of_variability var in\r
- raise (CompilError\r
- {err_msg = ["_ArgVariabilityMismatch"];\r
- err_info = [("_ExpectedVariability", "Continuous");\r
- ("_VariabilityFound", var)];\r
- err_ctx = {ctx with location = arg.Syntax.info}}) (*error*)\r
- | "delay", _ when List.length args' = 3 ->\r
- let input_types =\r
- [("@1", Types.real_component_type Types.Continuous);\r
- ("@2", Types.real_component_type Types.Continuous);\r
- ("@3", Types.real_component_type Types.Parameter)]\r
- and output_types =\r
- ["@4", Types.real_component_type Types.Continuous] in\r
- element_types input_types output_types\r
- | "abs", [arg, arg']\r
- when argument_base_type Types.IntegerType (arg, arg') ->\r
- let input_types = ["@1", Types.integer_component_type Types.Discrete]\r
- and output_types =\r
- ["@2", Types.integer_component_type Types.Discrete] in\r
- element_types input_types output_types\r
- | ("ones" | "zeros"), _\r
- when not (argument_base_types Types.IntegerType args') ->\r
- let (arg, arg') =\r
- List.find (neg (argument_base_type Types.IntegerType)) args' in\r
- raise (CompilError\r
- {err_msg = ["_ArgTypeMismatch"];\r
- err_info = [];\r
- err_ctx = {ctx with location = arg.Syntax.info}}) (*error*)\r
- | "fill", _ :: args'\r
- when not (argument_base_types Types.IntegerType args') ->\r
- let (arg, arg') =\r
- List.find (neg (argument_base_type Types.IntegerType)) args' in\r
- raise (CompilError\r
- {err_msg = ["_ArgTypeMismatch"];\r
- err_info = [];\r
- err_ctx = {ctx with location = arg.Syntax.info}}) (*error*)\r
- | ("sum" | "product" | "max" | "min" | "scalar"), [arg, arg']\r
- when ndims arg' = 0 ->\r
- raise (CompilError\r
- {err_msg = ["_ArgTypeMismatch"];\r
- err_info = [];\r
- err_ctx = {ctx with location = arg.Syntax.info}}) (*error*)\r
- | "diagonal", [arg, arg']\r
- when ndims arg' <> 1 ->\r
- raise (CompilError\r
- {err_msg = ["_ArgTypeMismatch"];\r
- err_info = [];\r
- err_ctx = {ctx with location = arg.Syntax.info}}) (*error*)\r
- | ("scalar"), [arg, arg'] ->\r
- let cpnt_type = component_type_of_expression ctx arg' in\r
- let input_types = ["@1", cpnt_type]\r
- and output_types =\r
- ["@2", Types.scalar_component_type cpnt_type ] in\r
- element_types input_types output_types\r
- | ("sum" | "product" | "max" | "min" | "diagonal"), [arg, arg']\r
- when not (numeric_base_type arg') ->\r
- raise (CompilError\r
- {err_msg = ["_ArgTypeMismatch"];\r
- err_info = [];\r
- err_ctx = {ctx with location = arg.Syntax.info}}) (*error*)\r
- | ("sum" | "product" | "max" | "min"), [arg, arg'] ->\r
- let cpnt_type = component_type_of_expression ctx arg' in\r
- let input_types = ["@1", cpnt_type]\r
- and output_types =\r
- ["@2", Types.scalar_component_type cpnt_type ] in\r
- element_types input_types output_types\r
- | ("ones" | "zeros"), _ :: _ ->\r
- let input_types = argument_types 1 args'\r
- and output_types =\r
- let n = List.length args'\r
- and dims =\r
- List.map (function _ -> Types.ParameterDimension) args' in\r
- let cpnt_type =\r
- { \r
- Types.flow = lazy false;\r
- variability = lazy Types.Parameter;\r
- Types.causality = lazy Types.Acausal;\r
- base_class =\r
- lazy(Types.add_dimensions dims Types.integer_class_type)\r
- } in\r
- [ Printf.sprintf "@%d" (n + 1), cpnt_type ] in\r
- element_types input_types output_types\r
- | "fill", (arg, arg') :: (_ :: _ as args) ->\r
- let input_types = argument_types 1 args'\r
- and output_types =\r
- let n = List.length args\r
- and dims =\r
- List.map (function _ -> Types.ParameterDimension) args in\r
- let cpnt_type = component_type_of_expression ctx arg' in\r
- let lcl_spec = lazy\r
- (Types.add_dimensions\r
- dims \r
- (evaluate cpnt_type.Types.base_class)) in\r
- [ \r
- Printf.sprintf "@%d" (n + 1),\r
- { cpnt_type with Types.base_class = lcl_spec }\r
- ] in\r
- element_types input_types output_types\r
- | "diagonal", [ arg, arg' ] ->\r
- let cpnt_type = component_type_of_expression ctx arg' in\r
- let input_types = [ "@1", cpnt_type ]\r
- and output_types =\r
- let dims = [ Types.ParameterDimension ] in\r
- let lcl_spec = lazy\r
- (Types.add_dimensions\r
- dims\r
- (evaluate cpnt_type.Types.base_class)) in\r
- [ "@2", { cpnt_type with Types.base_class = lcl_spec } ] in\r
- element_types input_types output_types\r
- | ("div" | "mod" | "rem" | "max" | "min"), _\r
- when List.for_all (argument_base_type Types.IntegerType) args' ->\r
- let input_types =\r
- [\r
- "@1", Types.integer_component_type Types.Discrete;\r
- "@2", Types.integer_component_type Types.Discrete\r
- ]\r
- and output_types =\r
- ["@3", Types.integer_component_type Types.Discrete] in\r
- element_types input_types output_types\r
- | ("pre" | "change"), [arg, arg'] ->\r
- let cpnt_type = argument_component_type (arg, arg') in\r
- let input_types =\r
- ["@1", { cpnt_type with Types.variability = lazy Types.Continuous }]\r
- and output_types =\r
- ["@2", { cpnt_type with Types.variability = lazy Types.Discrete }] in\r
- element_types input_types output_types\r
- | _, _ -> in_types, out_types in\r
- match expr'.nature with\r
- | PredefinedIdentifier id ->\r
- let args' = List.map resolve_built_in_function_argument args in\r
- let input_types, output_types =\r
- let inout_types =\r
- List.fold_right add_function_inout_argument named_elts ([], []) in\r
- built_in_function_inout_types ctx id inout_types args' in\r
- let named_args =\r
- built_in_function_named_arguments [] input_types args' in\r
- input_types, output_types, named_args\r
- | _ ->\r
- let input_types, output_types =\r
- List.fold_right add_function_inout_argument named_elts ([], []) in\r
- let named_args = named_arguments_of_arguments input_types args in\r
- input_types, output_types, named_args\r
-\r
-and resolve_identifier ctx expr id =\r
- let rec resolve_predefined_identifier ctx expr id = match id with\r
- | "Boolean" ->\r
- let nat = PredefinedIdentifier "Boolean"\r
- and elt_nat = Types.ClassElement (lazy (Types.boolean_class_type)) in\r
- resolved_expression (Some expr) nat elt_nat\r
- | "Integer" ->\r
- let nat = PredefinedIdentifier "Integer"\r
- and elt_nat = Types.ClassElement (lazy (Types.integer_class_type)) in\r
- resolved_expression (Some expr) nat elt_nat\r
- | "Real" ->\r
- let nat = PredefinedIdentifier "Real"\r
- and elt_nat = Types.ClassElement (lazy (Types.real_class_type)) in\r
- resolved_expression (Some expr) nat elt_nat\r
- | "String" ->\r
- let nat = PredefinedIdentifier "String"\r
- and elt_nat = Types.ClassElement (lazy (Types.string_class_type)) in\r
- resolved_expression (Some expr) nat elt_nat\r
- | "reinit" ->\r
- let nat = PredefinedIdentifier "reinit"\r
- and elt_nat =\r
- let inputs =\r
- ["@1", Types.real_component_type Types.Continuous;\r
- "@2", Types.real_component_type Types.Continuous]\r
- and outputs = [] in\r
- Types.function_type inputs outputs in\r
- resolved_expression (Some expr) nat elt_nat\r
- | "time" ->\r
- let nat = PredefinedIdentifier "time"\r
- and elt_nat = Types.real_type Types.Continuous in\r
- resolved_expression (Some expr) nat elt_nat\r
- | "pre" | "change" ->\r
- let nat = PredefinedIdentifier "pre"\r
- and elt_nat =\r
- let inputs = ["@1", Types.real_component_type Types.Continuous]\r
- and outputs = ["@2", Types.real_component_type Types.Discrete] in\r
- Types.function_type inputs outputs in\r
- resolved_expression (Some expr) nat elt_nat\r
- | "edge" ->\r
- let nat = PredefinedIdentifier "edge"\r
- and elt_nat =\r
- let inputs = ["@1", Types.boolean_component_type Types.Discrete]\r
- and outputs = ["@2", Types.boolean_component_type Types.Discrete] in\r
- Types.function_type inputs outputs in\r
- resolved_expression (Some expr) nat elt_nat\r
- | "initial" ->\r
- let nat = PredefinedIdentifier "initial"\r
- and elt_nat =\r
- let inputs = []\r
- and outputs = [] in\r
- Types.function_type inputs outputs in\r
- resolved_expression (Some expr) nat elt_nat\r
- | "terminal" ->\r
- let nat = PredefinedIdentifier "terminal"\r
- and elt_nat =\r
- let inputs = []\r
- and outputs = [] in\r
- Types.function_type inputs outputs in\r
- resolved_expression (Some expr) nat elt_nat\r
- | "sample" ->\r
- let nat = PredefinedIdentifier "sample"\r
- and elt_nat =\r
- let inputs = [("@1", Types.real_component_type Types.Parameter);\r
- ("@2", Types.real_component_type Types.Parameter)]\r
- and outputs = ["@3", Types.boolean_component_type Types.Parameter] in\r
- Types.function_type inputs outputs in\r
- resolved_expression (Some expr) nat elt_nat\r
- | "delay" ->\r
- let nat = PredefinedIdentifier "delay"\r
- and elt_nat =\r
- let inputs = [("@1", Types.real_component_type Types.Continuous);\r
- ("@2", Types.real_component_type Types.Parameter)]\r
- and outputs = ["@3", Types.real_component_type Types.Continuous] in\r
- Types.function_type inputs outputs in\r
- resolved_expression (Some expr) nat elt_nat\r
- | "assert" ->\r
- let nat = PredefinedIdentifier "assert"\r
- and elt_nat =\r
- let inputs = [("@1", Types.boolean_component_type Types.Discrete);\r
- ("@2", Types.string_component_type Types.Discrete)]\r
- and outputs = [] in\r
- Types.function_type inputs outputs in\r
- resolved_expression (Some expr) nat elt_nat\r
- | "terminate" ->\r
- let nat = PredefinedIdentifier "terminate"\r
- and elt_nat =\r
- let inputs = [("@1", Types.string_component_type Types.Discrete)]\r
- and outputs = [] in\r
- Types.function_type inputs outputs in\r
- resolved_expression (Some expr) nat elt_nat\r
- | "abs" | "cos" | "sin" | "tan" | "exp" | "log" | "sqrt" |\r
- "asin" | "acos" | "atan" | "sinh" | "cosh" | "tanh" | "asinh" |\r
- "acosh" | "atanh" | "log10" | "ceil" | "floor" | "der" ->\r
- let nat = PredefinedIdentifier id\r
- and elt_nat =\r
- let inputs = ["@1", Types.real_component_type Types.Continuous]\r
- and outputs = ["@2", Types.real_component_type Types.Continuous] in\r
- Types.function_type inputs outputs in\r
- resolved_expression (Some expr) nat elt_nat\r
- | "sign" | "integer" | "ones" | "zeros" ->\r
- let nat = PredefinedIdentifier id\r
- and elt_nat =\r
- let inputs = ["@1", Types.real_component_type Types.Continuous]\r
- and outputs = ["@2", Types.integer_component_type Types.Discrete] in\r
- Types.function_type inputs outputs in\r
- resolved_expression (Some expr) nat elt_nat\r
- | "max" | "min" | "div" | "mod" | "rem" | "fill" ->\r
- let nat = PredefinedIdentifier id\r
- and elt_nat =\r
- let inputs =\r
- [\r
- "@1", Types.real_component_type Types.Continuous;\r
- "@2", Types.real_component_type Types.Continuous\r
- ]\r
- and outputs = ["@3", Types.real_component_type Types.Continuous] in\r
- Types.function_type inputs outputs in\r
- resolved_expression (Some expr) nat elt_nat\r
- | "smooth" ->\r
- let nat = PredefinedIdentifier id\r
- and elt_nat =\r
- let inputs =\r
- [\r
- "@1", Types.integer_component_type Types.Discrete;\r
- "@2", Types.real_component_type Types.Continuous\r
- ]\r
- and outputs = ["@3", Types.real_component_type Types.Continuous] in\r
- Types.function_type inputs outputs in\r
- resolved_expression (Some expr) nat elt_nat\r
- | "identity" ->\r
- let nat = PredefinedIdentifier id\r
- and elt_nat =\r
- let inputs = [ "@1", Types.integer_component_type Types.Parameter ]\r
- and outputs =\r
- let dims =\r
- [Types.ParameterDimension; Types.ParameterDimension] in\r
- [ \r
- "@2",\r
- Types.integer_array_component_type Types.Parameter dims\r
- ] in\r
- Types.function_type inputs outputs in\r
- resolved_expression (Some expr) nat elt_nat\r
- | "diagonal" ->\r
- let nat = PredefinedIdentifier id\r
- and elt_nat =\r
- let inputs =\r
- let dim = [ Types.ParameterDimension ] in\r
- [ "@1", Types.integer_array_component_type Types.Parameter dim ]\r
- and outputs =\r
- let dims =\r
- [Types.ParameterDimension; Types.ParameterDimension] in\r
- [ \r
- "@2",\r
- Types.integer_array_component_type Types.Parameter dims\r
- ] in\r
- Types.function_type inputs outputs in\r
- resolved_expression (Some expr) nat elt_nat\r
- | "sum" | "product" | "scalar" ->\r
- let nat = PredefinedIdentifier id\r
- and elt_nat =\r
- let inputs =\r
- let dim = [ Types.DiscreteDimension ] in\r
- [ "@1", Types.integer_array_component_type Types.Discrete dim ]\r
- and outputs = ["@2", Types.integer_component_type Types.Discrete] in\r
- Types.function_type inputs outputs in\r
- resolved_expression (Some expr) nat elt_nat\r
- | _ -> raise (CompilError\r
- {err_msg = ["_UnknownIdentifier"; id];\r
- err_info = [];\r
- err_ctx = ctx})\r
- and search_in_toplevel dic =\r
- try\r
- let elt_desc = List.assoc id (evaluate dic) in\r
- let elt_type = evaluate elt_desc.element_type in\r
- match elt_type.Types.dynamic_scope with\r
- | None | Some Types.Inner ->\r
- let nat = ToplevelIdentifier id in\r
- resolved_expression (Some expr) nat elt_type.Types.element_nature\r
- | Some Types.Outer | Some Types.InnerOuter ->\r
- raise (CompilError\r
- {err_msg = ["_NoInnerDeclForOuterElem"; id];\r
- err_info = [];\r
- err_ctx = ctx}) (*error*)\r
- with Not_found -> resolve_predefined_identifier ctx expr id\r
- and search_in_class level cl_def = match evaluate cl_def.class_type with\r
- | Types.ClassType cl_type -> search_in_class_type level cl_def cl_type\r
- | Types.PredefinedType _ | Types.ComponentType _ | Types.ArrayType _ |\r
- Types.TupleType _ ->\r
- raise (CompilError\r
- {err_msg = ["_NoInnerDeclForOuterElem"; id];\r
- err_info = [];\r
- err_ctx = ctx}) (*error*)\r
- and search_in_class_type level cl_def cl_type =\r
- try\r
- let elt_type = evaluate (List.assoc id cl_type.Types.named_elements) in\r
- match elt_type.Types.dynamic_scope with\r
- | None | Some Types.Inner ->\r
- let nat = LocalIdentifier (level, id) in\r
- resolved_expression (Some expr) nat elt_type.Types.element_nature\r
- | Some Types.Outer | Some Types.InnerOuter ->\r
- let nat = DynamicIdentifier (level, id) in\r
- resolved_expression (Some expr) nat elt_type.Types.element_nature\r
- with Not_found -> search_in_parent level cl_def\r
- and search_in_parent level cl_def = match cl_def.enclosing_class with\r
- | _ when cl_def.encapsulated -> search_in_toplevel ctx.toplevel\r
- | Some cl_def -> search_in_class (level + 1) cl_def\r
- | None -> search_in_toplevel ctx.toplevel\r
- and search_in_for_loop_variables level ctx = match ctx.context_nature with\r
- | ToplevelContext -> search_in_toplevel ctx.toplevel\r
- | ClassContext cl_def -> search_in_class 0 cl_def\r
- | SubscriptContext (ctx', _, _, _) ->\r
- search_in_for_loop_variables level ctx'\r
- | ForContext (_, id', elt_nat) when id' = id ->\r
- let nat = LoopVariable level in\r
- resolved_expression (Some expr) nat elt_nat\r
- | ForContext (ctx', _, _) ->\r
- search_in_for_loop_variables (level + 1) ctx' in\r
- search_in_for_loop_variables 0 ctx\r
-\r
-(*and resolve_if ctx expr alts expr' =\r
- let expres' = resolve_expression ctx expr' in\r
- let elt_nat' = expres'.info.type_description in\r
- let rec resolve_alternative (cond, expr) =\r
- resolve_condition cond,\r
- resolve_alternative_expression expr\r
- and resolve_condition cond =\r
- let ctx = {ctx with location = cond.Syntax.info} in\r
- let cond' = resolve_expression ctx cond in\r
- let condition cpnt_type =\r
- let cl_spec = evaluate cpnt_type.Types.base_class in\r
- match cl_spec with\r
- | Types.PredefinedType { Types.base_type = Types.BooleanType } -> cond'\r
- | Types.PredefinedType _ | Types.ClassType _ | Types.ComponentType _ |\r
- Types.ArrayType _ | Types.TupleType _ -> \r
- raise (CompilError\r
- {err_msg = ["_NonBooleanIfCondExpr"];\r
- err_info =\r
- [("_ExprKind", "...if A then...");\r
- ("_TypeOfA", Types.string_of_class_specifier cl_spec)];\r
- err_ctx = ctx}) (*error*) in\r
- match cond'.info.type_description with\r
- | Types.ComponentElement cpnt_type -> condition cpnt_type\r
- | _ -> raise (CompilError\r
- {err_msg = ["_ClassElemFoundInExpr"];\r
- err_info = [];\r
- err_ctx = {ctx with location = cond.Syntax.info}}) (*error*)\r
- and resolve_alternative_expression expr =\r
- let ctx = {ctx with location = expr.Syntax.info} in\r
- let expres = resolve_expression ctx expr in\r
- let elt_nat = expres.info.type_description in\r
- let display_error elt_nat elt_nat' = match elt_nat, elt_nat' with\r
- | Types.ComponentElement cpnt_type, Types.ComponentElement cpnt_type' ->\r
- raise (CompilError\r
- {err_msg = ["_TypeConflictsInIfAlternExprs"];\r
- err_info =\r
- [("_TypeOfThenBranche",\r
- Types.string_of_component_type cpnt_type);\r
- ("_TypeOfElseBranche",\r
- Types.string_of_component_type cpnt_type')];\r
- err_ctx = ctx}) (*error*)\r
- | Types.ComponentElement cpnt_type, _ ->\r
- raise (CompilError\r
- {err_msg = ["_ClassElemFoundInExpr"];\r
- err_info =\r
- [("_TypeOfThenBranche",\r
- Types.string_of_component_type cpnt_type);\r
- ("_TypeOfElseBranche", "_ClassElement")];\r
- err_ctx = ctx}) (*error*)\r
- | _, Types.ComponentElement cpnt_type' ->\r
- raise (CompilError\r
- {err_msg = ["_ClassElemFoundInExpr"];\r
- err_info =\r
- [("_TypeOfThenBranche", "_ClassElement");\r
- ("_TypeOfElseBranche",\r
- Types.string_of_component_type cpnt_type')];\r
- err_ctx = ctx}) (*error*)\r
- | _, _ ->\r
- raise (CompilError\r
- {err_msg = ["_ClassElemFoundInExpr"];\r
- err_info =\r
- [("_TypeOfThenBranche", "_ClassElement");\r
- ("_TypeOfElseBranche", "_ClassElement")];\r
- err_ctx = ctx}) (*error*) in\r
- match Types.compare_element_natures elt_nat elt_nat' with\r
- | Types.NotRelated -> display_error elt_nat elt_nat'\r
- | _ -> expres in\r
- let alts = List.map resolve_alternative alts in\r
- let nat = If (alts, expres') in\r
- resolved_expression (Some expr) nat elt_nat'*)\r
-\r
-and resolve_if ctx expr alts expr' =\r
- let resolve_data_expression ctx expr =\r
- let expr' = resolve_expression ctx expr in\r
- match expr'.info.type_description with\r
- | Types.ComponentElement cpnt_type -> expr'\r
- | _ ->\r
- raise (CompilError\r
- {err_msg = ["_ClassElemFoundInExpr"];\r
- err_info = [];\r
- err_ctx = {ctx with location = expr.Syntax.info}}) (*error*) in\r
- let resolve_condition cond =\r
- let ctx = {ctx with location = cond.Syntax.info} in\r
- let cond' = resolve_data_expression ctx cond in\r
- let condition cpnt_type =\r
- match evaluate cpnt_type.Types.base_class with\r
- | Types.PredefinedType { Types.base_type = Types.BooleanType } -> cond'\r
- | cl_spec -> \r
- raise (CompilError\r
- {err_msg = ["_NonBooleanIfCondExpr"];\r
- err_info =\r
- [("_ExprKind", "...if A then...");\r
- ("_TypeOfA", Types.string_of_class_specifier cl_spec)];\r
- err_ctx = ctx}) (*error*) in\r
- match cond'.info.type_description with\r
- | Types.ComponentElement cpnt_type -> condition cpnt_type\r
- | _ ->\r
- raise (CompilError\r
- {err_msg = ["_DataElemExpected"];\r
- err_info = [];\r
- err_ctx = ctx}) (*error*) in\r
- let resolve_alternatives (alts, expr') (cond, expr) =\r
- let ctx = {ctx with location = expr.Syntax.info} in\r
- let cond' = resolve_condition cond\r
- and expr = resolve_data_expression ctx expr in\r
- let exprs = apply_binary_coercions [ expr'; expr] in\r
- let expr' = List.nth exprs 0\r
- and expr = List.nth exprs 1 in\r
- let elt_nat = expr.info.type_description\r
- and elt_nat' = expr'.info.type_description in\r
- match Types.compare_element_natures elt_nat elt_nat' with\r
- | Types.SameType ->\r
- (alts @ [cond', expr]), expr'\r
- | _ ->\r
- raise (CompilError\r
- {err_msg = ["_TypeConflictsInIfAlternExprs"];\r
- err_info =\r
- [("_TypeOfThenBranche",\r
- Types.string_of_element_nature elt_nat);\r
- ("_TypeOfElseBranche",\r
- Types.string_of_element_nature elt_nat')];\r
- err_ctx = ctx}) (*error*) in\r
- let expr' = resolve_data_expression ctx expr' in\r
- let alts, expr' = List.fold_left resolve_alternatives ([], expr') alts in\r
- let nat = If (alts, expr') in\r
- resolved_expression (Some expr) nat expr'.info.type_description\r
-\r
-and resolve_indexed_access ctx expr expr' subs =\r
- let expres' = resolve_expression ctx expr' in\r
- let rec resolve_component_indexed_access cl_spec subs =\r
- match cl_spec, subs with\r
- | (Types.PredefinedType _ | Types.ClassType _ | Types.ComponentType _ |\r
- Types.ArrayType _ | Types.TupleType _), [] -> cl_spec\r
- | (Types.PredefinedType _ | Types.ClassType _ | Types.ComponentType _ |\r
- Types.TupleType _), _ :: _ ->\r
- raise (CompilError\r
- {err_msg = ["_CannotSubscriptANonArrayTypeElem"];\r
- err_info =\r
- [("_ExpectedType", "_ArrayType");\r
- ("_TypeFound", Types.string_of_class_specifier cl_spec)];\r
- err_ctx = ctx}) (*error*)\r
- | Types.ArrayType (_, cl_spec'), sub :: subs' ->\r
- let cl_spec' = resolve_component_indexed_access cl_spec' subs' in\r
- subarray_access sub cl_spec'\r
- and subarray_access sub cl_spec =\r
- let subarray_access' = function\r
- | Types.PredefinedType { Types.base_type = Types.IntegerType } -> cl_spec\r
- | Types.ArrayType\r
- (dim, Types.PredefinedType { Types.base_type = Types.IntegerType }) ->\r
- Types.ArrayType (dim, cl_spec)\r
- | Types.PredefinedType _ | Types.ClassType _ | Types.ComponentType _ |\r
- Types.ArrayType _ | Types.TupleType _ -> assert false (*error*) in\r
- match sub.info.type_description with\r
- | Types.ComponentElement cpnt_type ->\r
- let cl_spec' = evaluate cpnt_type.Types.base_class in\r
- subarray_access' cl_spec'\r
- | Types.ClassElement _ | Types.ComponentTypeElement _ |\r
- Types.PredefinedTypeElement _ -> assert false (*error*) in\r
- match expres'.info.type_description with\r
- | Types.ComponentElement cpnt_type ->\r
- let cl_spec = evaluate cpnt_type.Types.base_class in\r
- let subs' = resolve_subscripts ctx expres' cl_spec subs in\r
- let cpnt_type' = \r
- { cpnt_type with\r
- Types.base_class =\r
- lazy (resolve_component_indexed_access cl_spec subs')\r
- } in\r
- let info =\r
- {\r
- syntax = Some expr;\r
- type_description = Types.ComponentElement cpnt_type'\r
- } in\r
- { nature = IndexedAccess (expres', subs'); info = info }\r
- | Types.ClassElement _ | Types.ComponentTypeElement _ |\r
- Types.PredefinedTypeElement _ ->\r
- raise (CompilError\r
- {err_msg = ["_ClassElemFoundInExpr"];\r
- err_info = [];\r
- err_ctx = ctx}) (*error*)\r
-\r
-and resolve_integer ctx expr s =\r
- let nat =\r
- try\r
- Integer (Int32.of_string s)\r
- with\r
- | _ ->\r
- raise (CompilError\r
- {err_msg = ["_InvalidInteger"; s];\r
- err_info = [];\r
- err_ctx = ctx}) in\r
- resolved_expression (Some expr) nat (Types.integer_type Types.Constant)\r
-\r
-and resolve_matrix_construction ctx expr exprss =\r
- raise (CompilError\r
- {err_msg = ["_NotYetImplemented"; "_MatrixExpr"];\r
- err_info = [];\r
- err_ctx = ctx})\r
-\r
-and resolve_no_event ctx expr expr' =\r
- let expr' = resolve_expression ctx expr' in\r
- match expr'.info.type_description with\r
- | Types.ComponentElement cpnt_type ->\r
- let nat = NoEvent expr'\r
- and flow = lazy (evaluate cpnt_type.Types.flow)\r
- and var = lazy Types.Continuous\r
- and inout = cpnt_type.Types.causality\r
- and cl_spec = cpnt_type.Types.base_class in\r
- let cpnt_type =\r
- component_element flow var inout cl_spec in\r
- let elt_nat = Types.ComponentElement cpnt_type in\r
- resolved_expression (Some expr) nat elt_nat\r
- | _ ->\r
- raise (CompilError\r
- {err_msg = ["_ClassElemFoundInExpr"];\r
- err_info = [];\r
- err_ctx = ctx}) (*error*)\r
-\r
-and resolve_range ctx expr start step stop =\r
- let integer_range var start' step' stop' =\r
- let integer_range' =\r
- match start'.nature, step'.nature, stop'.nature with\r
- | _, _, _ when Types.higher_variability var Types.Discrete ->\r
- let var = Types.string_of_variability var in\r
- raise (CompilError\r
- {err_msg = ["_InvalidVarOfRangeExpr"];\r
- err_info = [("_Expr", Syntax.string_of_range start step stop);\r
- ("_ExpectedVariability", "parameter");\r
- ("_VariabilityFound", var)];\r
- err_ctx = ctx}) \r
- | Integer i, Integer p, Integer j when p = Int32.zero ->\r
- raise (CompilError\r
- {err_msg = ["_RangeStepValueCannotBeNull"];\r
- err_info = [("_Expr", Syntax.string_of_range start step stop)];\r
- err_ctx = ctx})\r
- | Integer i, Integer p, Integer j ->\r
- let dim = Int32.div (Int32.succ (Int32.sub j i)) p in\r
- Types.integer_array_type var (Types.ConstantDimension dim)\r
- | (Integer _ | DynamicIdentifier _ | LocalIdentifier _ |\r
- LoopVariable _ | PredefinedIdentifier _ | ToplevelIdentifier _),\r
- (Integer _ | DynamicIdentifier _ | LocalIdentifier _ |\r
- LoopVariable _ | PredefinedIdentifier _ | ToplevelIdentifier _),\r
- (Integer _ | DynamicIdentifier _ | LocalIdentifier _ |\r
- LoopVariable _ | PredefinedIdentifier _ | ToplevelIdentifier _) ->\r
- Types.integer_array_type var Types.ParameterDimension\r
- | _, _, _ ->\r
- raise (CompilError\r
- {err_msg = ["_NotYetImplemented"; "_NonIntegerRangeExpr"];\r
- err_info = [("_Expr", Syntax.string_of_range start step stop)];\r
- err_ctx = ctx}) in\r
- let nat = Range (start', step', stop') in\r
- let elt_nat = integer_range' in\r
- resolved_expression (Some expr) nat elt_nat in\r
- let start' = resolve_expression ctx start\r
- and step' = match step with\r
- | None -> one\r
- | Some expr -> resolve_expression ctx expr\r
- and stop' = resolve_expression ctx stop in\r
- let resolve_range' var start_cl_spec step_cl_spec stop_cl_spec =\r
- match start_cl_spec, step_cl_spec, stop_cl_spec with\r
- | Types.PredefinedType { Types.base_type = Types.IntegerType },\r
- Types.PredefinedType { Types.base_type = Types.IntegerType },\r
- Types.PredefinedType { Types.base_type = Types.IntegerType } ->\r
- integer_range var start' step' stop'\r
- (*| Types.PredefinedType { Types.base_type = Types.IntegerType },\r
- Types.PredefinedType { Types.base_type = Types.IntegerType },\r
- _ -> assert false*)\r
- | _ -> raise (CompilError\r
- {err_msg = ["_NotYetImplemented"; "_NonIntegerRangeExpr"];\r
- err_info = [("_Expr", Syntax.string_of_range start step stop)];\r
- err_ctx = ctx}) in\r
- let start_elt_nat = start'.info.type_description\r
- and step_elt_nat = step'.info.type_description\r
- and stop_elt_nat = stop'.info.type_description in\r
- match start_elt_nat, step_elt_nat, stop_elt_nat with\r
- | Types.ComponentElement start_cpnt_type,\r
- Types.ComponentElement step_cpnt_type,\r
- Types.ComponentElement stop_cpnt_type ->\r
- let start_cl_spec = evaluate start_cpnt_type.Types.base_class\r
- and step_cl_spec = evaluate step_cpnt_type.Types.base_class\r
- and stop_cl_spec = evaluate stop_cpnt_type.Types.base_class\r
- and start_var = evaluate start_cpnt_type.Types.variability\r
- and step_var = evaluate step_cpnt_type.Types.variability\r
- and stop_var = evaluate stop_cpnt_type.Types.variability in\r
- let var =\r
- let var' = Types.max_variability step_var stop_var in\r
- Types.max_variability start_var var' in\r
- resolve_range' var start_cl_spec step_cl_spec stop_cl_spec\r
- | _ -> raise (CompilError\r
- {err_msg = ["_InvalidTypeInRangeExpr"];\r
- err_info = [("_Expr", Syntax.string_of_range start step stop)];\r
- err_ctx = ctx}) (*error*)\r
-\r
-and resolve_real ctx expr s =\r
- let nat = Real (float_of_string s) in\r
- resolved_expression (Some expr) nat (Types.real_type Types.Constant)\r
-\r
-and resolve_string ctx expr s =\r
- resolved_expression (Some expr) (String s) (Types.string_type Types.Constant)\r
-\r
-and resolve_true ctx expr =\r
- resolved_expression (Some expr) True (Types.boolean_type Types.Constant)\r
-\r
-and resolve_tuple ctx expr exprs =\r
- let max_element_variability var expr expr' =\r
- match expr'.info.type_description with\r
- | Types.ComponentElement cpnt_type ->\r
- let var' = evaluate cpnt_type.Types.variability in\r
- Types.max_variability var var'\r
- | Types.ClassElement _ | Types.ComponentTypeElement _ |\r
- Types.PredefinedTypeElement _ ->\r
- raise (CompilError\r
- {err_msg = ["_ClassElemFoundInExpr"];\r
- err_info = [];\r
- err_ctx = ctx}) (*error*)\r
- and class_specifier expr expr' =\r
- match expr'.info.type_description with\r
- | Types.ComponentElement cpnt_type -> evaluate cpnt_type.Types.base_class\r
- | Types.ClassElement _ | Types.ComponentTypeElement _ |\r
- Types.PredefinedTypeElement _ ->\r
- raise (CompilError\r
- {err_msg = ["_ClassElemFoundInExpr"];\r
- err_info = [];\r
- err_ctx = ctx}) (*error*) in\r
- let exprs' = List.map (resolve_expression ctx) exprs in\r
- let flow = lazy false\r
- and var =\r
- lazy (List.fold_left2 max_element_variability Types.Constant exprs exprs')\r
- and inout = lazy Types.Acausal\r
- and cl_spec = lazy (Types.TupleType (List.map2 class_specifier exprs exprs')) in\r
- {\r
- nature = Tuple exprs';\r
- info =\r
- {\r
- syntax = Some expr;\r
- type_description =\r
- Types.ComponentElement (component_element flow var inout cl_spec)\r
- }\r
- }\r
-\r
-and resolve_unuary_operation ctx expr kind arg =\r
- let arg' = resolve_expression ctx arg in\r
- match kind.Syntax.nature with\r
- | Syntax.UnaryMinus -> resolve_unary_minus ctx expr arg'\r
- | Syntax.Not -> resolve_not ctx expr arg'\r
- | Syntax.UnaryPlus ->\r
- raise (CompilError\r
- {err_msg = ["_NotYetImplemented"; "_UnaryOperPLUS"];\r
- err_info = [];\r
- err_ctx = ctx})\r
-\r
-and resolve_vector ctx expr vec_elts = match vec_elts.Syntax.nature with\r
- | Syntax.VectorReduction (expr', for_inds) ->\r
- resolve_vector_reduction ctx expr expr' for_inds\r
- | Syntax.VectorElements exprs -> resolve_vector_elements ctx expr exprs\r
-\r
-and resolve_vector_reduction ctx expr expr' for_inds =\r
- let vector_reduction_type acc expr expr' =\r
- let add_dimension elt_nat cl_spec =\r
- let add_dimension' cl_spec' = match cl_spec' with\r
- | Types.ArrayType (dim, _) -> Types.ArrayType (dim, cl_spec)\r
- | Types.PredefinedType _ | Types.ClassType _ |\r
- Types.ComponentType _ | Types.TupleType _ -> \r
- raise (CompilError\r
- {err_msg = ["_InvalidTypeInRangeExpr"];\r
- err_info =\r
- [("_ExpectedType", "_ArrayType");\r
- ("_TypeFound",\r
- Types.string_of_class_specifier cl_spec')];\r
- err_ctx = ctx}) (*error*) in\r
- match elt_nat with\r
- | Types.ComponentElement cpnt_type ->\r
- let cl_spec' = evaluate cpnt_type.Types.base_class in\r
- add_dimension' cl_spec'\r
- | Types.ClassElement _ | Types.ComponentTypeElement _ |\r
- Types.PredefinedTypeElement _ ->\r
- raise (CompilError\r
- {err_msg = ["_ClassElemFoundInExpr"];\r
- err_info = [];\r
- err_ctx = ctx}) (*error*) in\r
- let rec vector_reduction_type' acc cl_spec = match acc with\r
- | [] -> cl_spec\r
- | range :: acc ->\r
- let elt_nat = range.info.type_description in\r
- let cl_spec' = add_dimension elt_nat cl_spec in\r
- vector_reduction_type' acc cl_spec' in\r
- match expr'.info.type_description with\r
- | Types.ComponentElement cpnt_type ->\r
- let cl_spec = evaluate cpnt_type.Types.base_class in\r
- let cpnt_type' =\r
- { cpnt_type with\r
- Types.base_class = lazy (vector_reduction_type' acc cl_spec)\r
- } in\r
- Types.ComponentElement cpnt_type'\r
- | Types.ClassElement _ | Types.ComponentTypeElement _ |\r
- Types.PredefinedTypeElement _ ->\r
- raise (CompilError\r
- {err_msg = ["_ClassElemFoundInExpr"];\r
- err_info = [];\r
- err_ctx = ctx}) (*error*)\r
- and range_element_type range range' =\r
- let sub_dimension cl_spec = match cl_spec with\r
- | Types.ArrayType (dim, cl_spec) -> cl_spec\r
- | Types.PredefinedType _ | Types.ClassType _ |\r
- Types.ComponentType _ | Types.TupleType _ -> \r
- raise (CompilError\r
- {err_msg = ["_InvalidTypeInRangeExpr"];\r
- err_info =\r
- [("_ExpectedType", "_ArrayType");\r
- ("_TypeFound", Types.string_of_class_specifier cl_spec)];\r
- err_ctx = ctx}) (*error*) in\r
- match range'.info.type_description with\r
- | Types.ComponentElement cpnt_type ->\r
- let cl_spec = evaluate cpnt_type.Types.base_class in\r
- let cpnt_type' =\r
- { cpnt_type with\r
- Types.base_class = lazy (sub_dimension cl_spec)\r
- } in\r
- Types.ComponentElement cpnt_type'\r
- | Types.ClassElement _ | Types.ComponentTypeElement _ |\r
- Types.PredefinedTypeElement _ ->\r
- raise (CompilError\r
- {err_msg = ["_ClassElemFoundInExpr"];\r
- err_info = [];\r
- err_ctx = ctx}) (*error*) in\r
- let rec resolve_vector_reduction' acc ctx = function\r
- | [] ->\r
- let expres' = resolve_expression ctx expr' in\r
- let nat = VectorReduction (List.rev acc, expres')\r
- and elt_nat = vector_reduction_type acc expr' expres' in\r
- resolved_expression (Some expr) nat elt_nat\r
- | (_, None) :: _ ->\r
- raise (CompilError\r
- {err_msg = ["_NotYetImplemented"; "_ImplicitIterRange"];\r
- err_info = [("_Expr", Syntax.string_of_for_inds for_inds)];\r
- err_ctx = ctx})\r
- | (id, Some range) :: for_inds ->\r
- let range' = resolve_expression ctx range in\r
- let elt_nat = range_element_type range range' in\r
- let ctx' =\r
- { ctx with\r
- context_nature = ForContext (ctx, id, elt_nat)\r
- } in\r
- resolve_vector_reduction' (range' :: acc) ctx' for_inds in\r
- resolve_vector_reduction' [] ctx for_inds\r
-\r
-and resolve_vector_elements ctx expr exprs =\r
- let max_variability var cpnt_type =\r
- let var' = evaluate cpnt_type.Types.variability in\r
- Types.max_variability var var' in\r
- let type_of_elements cpnt_types =\r
- let rec type_of_elements' cl_spec = function\r
- | [] -> cl_spec\r
- | cpnt_type :: cpnt_types ->\r
- let cl_spec' = evaluate cpnt_type.Types.base_class in\r
- type_of_elements' (update cl_spec cl_spec') cpnt_types\r
- and update cl_spec cl_spec' =\r
- match Types.compare_specifiers cl_spec cl_spec' with\r
- | Types.SameType | Types.Supertype -> cl_spec\r
- | Types.Subtype -> cl_spec'\r
- | _ ->\r
- raise (CompilError\r
- {err_msg = ["_TypeConflictsInVectorExpr"];\r
- err_info =\r
- [("_MismatchingTypes",\r
- Types.string_of_class_specifier cl_spec ^ ", " ^\r
- Types.string_of_class_specifier cl_spec')];\r
- err_ctx = ctx}) in\r
- match cpnt_types with\r
- | [] -> assert false (*error*)\r
- | cpnt_type :: cpnt_types ->\r
- let cl_spec' = evaluate cpnt_type.Types.base_class in\r
- type_of_elements' cl_spec' cpnt_types in\r
- let exprs' = List.map (resolve_expression ctx) exprs in\r
- let exprs' = apply_binary_coercions exprs' in\r
- let cpnt_types = List.map (component_type_of_expression ctx) exprs' in\r
- let var = lazy (List.fold_left max_variability Types.Constant cpnt_types) in\r
- let cl_spec = type_of_elements cpnt_types in\r
- let dim = Types.ConstantDimension (Int32.of_int (List.length exprs')) in\r
- let cl_spec' = lazy (Types.ArrayType (dim, cl_spec)) in\r
- let cpnt_type =\r
- {\r
- Types.flow = lazy false;\r
- variability = var;\r
- causality = lazy Types.Acausal;\r
- base_class = cl_spec'\r
- } in\r
- let nat = Vector exprs'\r
- and elt_nat = Types.ComponentElement cpnt_type in\r
- resolved_expression (Some expr) nat elt_nat\r
-\r
-and resolve_and ctx expr arg arg' =\r
- let resolve_and' cpnt_type cpnt_type' =\r
- let rec and_type cl_spec cl_spec' = match cl_spec, cl_spec' with\r
- | Types.PredefinedType { Types.base_type = Types.BooleanType },\r
- Types.PredefinedType { Types.base_type = Types.BooleanType } ->\r
- Types.PredefinedType\r
- { Types.base_type = Types.BooleanType; attributes = [] }\r
- | Types.PredefinedType { Types.base_type = Types.BooleanType },\r
- (Types.PredefinedType _ | Types.ClassType _ | Types.ComponentType _ |\r
- Types.ArrayType _ | Types.TupleType _) ->\r
- raise (CompilError\r
- {err_msg = ["and"; "_OperAppliedToNonBoolExpr"];\r
- err_info =\r
- [("_ExpectedType", "Boolean");\r
- ("_TypeFound", Types.string_of_class_specifier cl_spec')];\r
- err_ctx = ctx}) (*error*)\r
- | (Types.PredefinedType _ | Types.ClassType _ | Types.ComponentType _ |\r
- Types.ArrayType _ | Types.TupleType _),\r
- (Types.PredefinedType _ | Types.ClassType _ | Types.ComponentType _ |\r
- Types.ArrayType _ | Types.TupleType _) ->\r
- raise (CompilError\r
- {err_msg = ["and"; "_OperAppliedToNonBoolExpr"];\r
- err_info =\r
- [("_ExpectedType", "Boolean");\r
- ("_TypeFound", Types.string_of_class_specifier cl_spec)];\r
- err_ctx = ctx}) (*error*) in\r
- let var =\r
- lazy (\r
- let var = evaluate cpnt_type.Types.variability\r
- and var' = evaluate cpnt_type'.Types.variability in\r
- Types.max_variability var var')\r
- and inout = Types.Acausal\r
- and cl_spec =\r
- lazy (\r
- let cl_spec = evaluate cpnt_type.Types.base_class\r
- and cl_spec' = evaluate cpnt_type'.Types.base_class in\r
- and_type cl_spec cl_spec') in\r
- let nat = BinaryOperation (And, arg, arg') in\r
- let elt_nat =\r
- let cpnt_type =\r
- component_element (lazy false) var (lazy inout) cl_spec in\r
- Types.ComponentElement cpnt_type in\r
- resolved_expression (Some expr) nat elt_nat in\r
- match arg.info.type_description, arg'.info.type_description with\r
- | Types.ComponentElement cpnt_type, Types.ComponentElement cpnt_type' ->\r
- resolve_and' cpnt_type cpnt_type'\r
- | Types.ComponentElement _,\r
- (Types.ClassElement _ | Types.ComponentTypeElement _ |\r
- Types.PredefinedTypeElement _) ->\r
- raise (CompilError\r
- {err_msg = ["_ClassElemFoundInExpr"];\r
- err_info = [];\r
- err_ctx = ctx}) (*error*)\r
- | (Types.ClassElement _ | Types.ComponentTypeElement _ |\r
- Types.PredefinedTypeElement _),\r
- (Types.ComponentElement _ | Types.ClassElement _ |\r
- Types.ComponentTypeElement _ | Types.PredefinedTypeElement _) ->\r
- raise (CompilError\r
- {err_msg = ["_ClassElemFoundInExpr"];\r
- err_info = [];\r
- err_ctx = ctx}) (*error*)\r
-\r
-and resolve_or ctx expr arg arg' =\r
- let resolve_or' cpnt_type cpnt_type' =\r
- let rec or_type cl_spec cl_spec' = match cl_spec, cl_spec' with\r
- | Types.PredefinedType { Types.base_type = Types.BooleanType },\r
- Types.PredefinedType { Types.base_type = Types.BooleanType } ->\r
- Types.PredefinedType\r
- { Types.base_type = Types.BooleanType; attributes = [] }\r
- | Types.PredefinedType { Types.base_type = Types.BooleanType },\r
- (Types.PredefinedType _ | Types.ClassType _ | Types.ComponentType _ |\r
- Types.ArrayType _ | Types.TupleType _) ->\r
- raise (CompilError\r
- {err_msg = ["or"; "_OperAppliedToNonBoolExpr"];\r
- err_info =\r
- [("_ExpectedType", "Boolean");\r
- ("_TypeFound", Types.string_of_class_specifier cl_spec')];\r
- err_ctx = ctx}) (*error*)\r
- | (Types.PredefinedType _ | Types.ClassType _ | Types.ComponentType _ |\r
- Types.ArrayType _ | Types.TupleType _),\r
- (Types.PredefinedType _ | Types.ClassType _ | Types.ComponentType _ |\r
- Types.ArrayType _ | Types.TupleType _) ->\r
- raise (CompilError\r
- {err_msg = ["or"; "_OperAppliedToNonBoolExpr"];\r
- err_info =\r
- [("_ExpectedType", "Boolean");\r
- ("_TypeFound", Types.string_of_class_specifier cl_spec)];\r
- err_ctx = ctx}) (*error*) in\r
- let var =\r
- lazy (let var = evaluate cpnt_type.Types.variability\r
- and var' = evaluate cpnt_type'.Types.variability in\r
- Types.max_variability var var')\r
- and inout = Types.Acausal\r
- and cl_spec =\r
- lazy (let cl_spec = evaluate cpnt_type.Types.base_class\r
- and cl_spec' = evaluate cpnt_type'.Types.base_class in\r
- or_type cl_spec cl_spec') in\r
- let nat = BinaryOperation (Or, arg, arg') in\r
- let elt_nat =\r
- let cpnt_type =\r
- component_element (lazy false) var (lazy inout) cl_spec in\r
- Types.ComponentElement cpnt_type in\r
- resolved_expression (Some expr) nat elt_nat in\r
- match arg.info.type_description, arg'.info.type_description with\r
- | Types.ComponentElement cpnt_type, Types.ComponentElement cpnt_type' ->\r
- resolve_or' cpnt_type cpnt_type'\r
- | (Types.ComponentElement _ | Types.ClassElement _ |\r
- Types.ComponentTypeElement _ | Types.PredefinedTypeElement _),\r
- (Types.ComponentElement _ | Types.ClassElement _ |\r
- Types.ComponentTypeElement _ | Types.PredefinedTypeElement _) ->\r
- raise (CompilError\r
- {err_msg = ["_ClassElemFoundInExpr"];\r
- err_info = [];\r
- err_ctx = ctx}) (*error*)\r
-\r
-and resolve_addition ctx expr arg arg' =\r
- let resolve_addition' cpnt_type cpnt_type' =\r
- let rec addition_type cl_spec cl_spec' = match cl_spec, cl_spec' with\r
- | Types.ArrayType (Types.ConstantDimension n, _),\r
- Types.ArrayType (Types.ConstantDimension n', _) when n <> n' ->\r
- raise (CompilError\r
- {err_msg = ["_ArrayDimMustAgreeToPerform"; "_Addition"];\r
- err_info =\r
- [("_ExprKind", "A + B");\r
- ("_TypeOfA", Types.string_of_class_specifier cl_spec);\r
- ("_TypeOfB", Types.string_of_class_specifier cl_spec')];\r
- err_ctx = ctx}) (*error*)\r
- | Types.ArrayType (Types.ConstantDimension _, cl_spec),\r
- Types.ArrayType (dim, cl_spec') |\r
- Types.ArrayType (dim, cl_spec),\r
- Types.ArrayType (Types.ConstantDimension _, cl_spec') ->\r
- Types.ArrayType (dim, addition_type cl_spec cl_spec')\r
- | Types.ArrayType (Types.ParameterDimension, cl_spec),\r
- Types.ArrayType (dim, cl_spec') |\r
- Types.ArrayType (dim, cl_spec),\r
- Types.ArrayType (Types.ParameterDimension, cl_spec') ->\r
- Types.ArrayType (dim, addition_type cl_spec cl_spec')\r
- | Types.ArrayType (Types.DiscreteDimension, cl_spec),\r
- Types.ArrayType (Types.DiscreteDimension, cl_spec') ->\r
- Types.ArrayType\r
- (Types.DiscreteDimension, addition_type cl_spec cl_spec')\r
- | Types.PredefinedType { Types.base_type = Types.IntegerType },\r
- Types.PredefinedType { Types.base_type = Types.IntegerType } ->\r
- Types.PredefinedType\r
- { Types.base_type = Types.IntegerType; attributes = [] }\r
- | Types.PredefinedType\r
- { Types.base_type = Types.RealType | Types.IntegerType },\r
- Types.PredefinedType\r
- { Types.base_type = Types.RealType | Types.IntegerType } ->\r
- Types.PredefinedType\r
- { Types.base_type = Types.RealType; attributes = [] }\r
- | Types.PredefinedType _, Types.ArrayType _ \r
- | Types.ArrayType _, Types.PredefinedType _ -> \r
- raise (CompilError\r
- {err_msg = ["+"; "_OperBetweenScalarAndArray"];\r
- err_info =\r
- [("_ExprKind", "A + B");\r
- ("_TypeOfA", Types.string_of_class_specifier cl_spec);\r
- ("_TypeOfB", Types.string_of_class_specifier cl_spec')];\r
- err_ctx = ctx}) (*error*)\r
- | _, _ -> \r
- raise (CompilError\r
- {err_msg = ["+"; "_OperAppliedToNonNumericExpr"];\r
- err_info =\r
- [("_ExprKind", "A + B");\r
- ("_TypeOfA", Types.string_of_class_specifier cl_spec);\r
- ("_TypeOfB", Types.string_of_class_specifier cl_spec')];\r
- err_ctx = ctx}) (*error*) in\r
- let var =\r
- lazy (let var = evaluate cpnt_type.Types.variability\r
- and var' = evaluate cpnt_type'.Types.variability in\r
- Types.max_variability var var')\r
- and inout = Types.Acausal\r
- and cl_spec =\r
- lazy (let cl_spec = evaluate cpnt_type.Types.base_class\r
- and cl_spec' = evaluate cpnt_type'.Types.base_class in\r
- addition_type cl_spec cl_spec') in\r
- let nat = BinaryOperation (Plus, arg, arg') in\r
- let elt_nat =\r
- let cpnt_type =\r
- component_element (lazy false) var (lazy inout) cl_spec in\r
- Types.ComponentElement cpnt_type in\r
- resolved_expression (Some expr) nat elt_nat in\r
- match arg.info.type_description, arg'.info.type_description with\r
- | Types.ComponentElement cpnt_type, Types.ComponentElement cpnt_type' ->\r
- resolve_addition' cpnt_type cpnt_type'\r
- | (Types.ComponentElement _ | Types.ClassElement _ |\r
- Types.ComponentTypeElement _ | Types.PredefinedTypeElement _),\r
- (Types.ComponentElement _ | Types.ClassElement _ |\r
- Types.ComponentTypeElement _ | Types.PredefinedTypeElement _) ->\r
- raise (CompilError\r
- {err_msg = ["_ClassElemFoundInExpr"];\r
- err_info = [];\r
- err_ctx = ctx}) (*error*)\r
-\r
-and resolve_comparison ctx expr kind arg arg' =\r
- let resolve_comparison' cpnt_type cpnt_type' =\r
- let rec comparison_type cl_spec cl_spec' = match cl_spec, cl_spec' with\r
- | Types.PredefinedType\r
- { Types.base_type = Types.IntegerType | Types.RealType },\r
- Types.PredefinedType\r
- { Types.base_type = Types.IntegerType | Types.RealType } ->\r
- Types.PredefinedType\r
- { Types.base_type = Types.BooleanType; attributes = [] }\r
- | (Types.PredefinedType _ | Types.ClassType _ | Types.ComponentType _ |\r
- Types.ArrayType _ | Types.TupleType _),\r
- (Types.PredefinedType _ | Types.ClassType _ | Types.ComponentType _ |\r
- Types.ArrayType _ | Types.TupleType _) ->\r
- raise (CompilError\r
- {err_msg = ["_TypeInconsistWithComparOper"];\r
- err_info =\r
- [("_ExprKind", "A" ^ (string_of_bin_oper_kind kind) ^ "B");\r
- ("_TypeOfA", Types.string_of_class_specifier cl_spec);\r
- ("_TypeOfB", Types.string_of_class_specifier cl_spec')];\r
- err_ctx = ctx}) (*error*) in\r
- (*let var =\r
- let var = evaluate cpnt_type.Types.variability\r
- and var' = evaluate cpnt_type'.Types.variability in\r
- Types.max_variability var var'*)\r
- let var = Types.Discrete\r
- and inout = Types.Acausal\r
- and cl_spec =\r
- lazy (let cl_spec = evaluate cpnt_type.Types.base_class\r
- and cl_spec' = evaluate cpnt_type'.Types.base_class in\r
- comparison_type cl_spec cl_spec') in\r
- let nat = BinaryOperation (kind, arg, arg') in\r
- let elt_nat =\r
- let cpnt_type =\r
- component_element (lazy false) (lazy var) (lazy inout) cl_spec in\r
- Types.ComponentElement cpnt_type in\r
- resolved_expression (Some expr) nat elt_nat in\r
- match arg.info.type_description, arg'.info.type_description with\r
- | Types.ComponentElement cpnt_type, Types.ComponentElement cpnt_type' ->\r
- resolve_comparison' cpnt_type cpnt_type'\r
- | (Types.ComponentElement _ | Types.ClassElement _ |\r
- Types.ComponentTypeElement _ | Types.PredefinedTypeElement _),\r
- (Types.ComponentElement _ | Types.ClassElement _ |\r
- Types.ComponentTypeElement _ | Types.PredefinedTypeElement _) ->\r
- raise (CompilError\r
- {err_msg = ["_ClassElemFoundInExpr"];\r
- err_info = [];\r
- err_ctx = ctx}) (*error*)\r
-\r
-and resolve_division ctx expr arg arg' =\r
- let resolve_division' cpnt_type cpnt_type' =\r
- let rec division_type cl_spec cl_spec' = match cl_spec, cl_spec' with\r
- | Types.ArrayType (dim, cl_spec),\r
- Types.PredefinedType\r
- { Types.base_type = Types.IntegerType | Types.RealType } ->\r
- Types.ArrayType (dim, division_type cl_spec cl_spec')\r
- | Types.PredefinedType\r
- { Types.base_type = Types.RealType | Types.IntegerType },\r
- Types.PredefinedType\r
- { Types.base_type = Types.RealType | Types.IntegerType } ->\r
- Types.PredefinedType\r
- { Types.base_type = Types.RealType; attributes = [] }\r
- | (Types.PredefinedType _ | Types.ClassType _ | Types.ComponentType _ |\r
- Types.ArrayType _ | Types.TupleType _),\r
- (Types.PredefinedType _ | Types.ClassType _ | Types.ComponentType _ |\r
- Types.ArrayType _ | Types.TupleType _) ->\r
- raise (CompilError\r
- {err_msg = ["_TypeInconsistentWithDivOper"];\r
- err_info =\r
- [("_ExprKind", "A / B");\r
- ("_TypeOfA", Types.string_of_class_specifier cl_spec);\r
- ("_TypeOfB", Types.string_of_class_specifier cl_spec')];\r
- err_ctx = ctx}) (*error*) in\r
- let var =\r
- lazy (let var = evaluate cpnt_type.Types.variability\r
- and var' = evaluate cpnt_type'.Types.variability in\r
- Types.max_variability var var')\r
- and inout = Types.Acausal\r
- and cl_spec =\r
- lazy (let cl_spec = evaluate cpnt_type.Types.base_class\r
- and cl_spec' = evaluate cpnt_type'.Types.base_class in\r
- division_type cl_spec cl_spec') in\r
- let nat = BinaryOperation (Divide, arg, arg') in\r
- let elt_nat =\r
- let cpnt_type =\r
- component_element (lazy false) var (lazy inout) cl_spec in\r
- Types.ComponentElement cpnt_type in\r
- resolved_expression (Some expr) nat elt_nat in\r
- match arg.info.type_description, arg'.info.type_description with\r
- | Types.ComponentElement cpnt_type, Types.ComponentElement cpnt_type' ->\r
- resolve_division' cpnt_type cpnt_type'\r
- | (Types.ComponentElement _ | Types.ClassElement _ |\r
- Types.ComponentTypeElement _ | Types.PredefinedTypeElement _),\r
- (Types.ComponentElement _ | Types.ClassElement _ |\r
- Types.ComponentTypeElement _ | Types.PredefinedTypeElement _) ->\r
- raise (CompilError\r
- {err_msg = ["_ClassElemFoundInExpr"];\r
- err_info = [];\r
- err_ctx = ctx}) (*error*)\r
-\r
-and resolve_multiplication ctx expr arg arg' =\r
- let resolve_multiplication' cpnt_type cpnt_type' =\r
- let rec multiplication_type cl_spec cl_spec' = match cl_spec, cl_spec' with\r
- | Types.ArrayType (_, Types.ArrayType (Types.ConstantDimension n, _)),\r
- Types.ArrayType (Types.ConstantDimension n', Types.ArrayType _)\r
- when n <> n' ->\r
- raise (CompilError\r
- {err_msg = ["_ArrayDimsNonCompatibleWithMult"];\r
- err_info =\r
- [("_ExprKind", "A * B");\r
- ("_TypeOfA", Types.string_of_component_type cpnt_type);\r
- ("_TypeOfB", Types.string_of_component_type cpnt_type')];\r
- err_ctx = ctx}) (*error*)\r
- | Types.ArrayType\r
- (dim, Types.ArrayType\r
- (_, Types.PredefinedType\r
- { Types.base_type = Types.IntegerType })),\r
- Types.ArrayType\r
- (_, Types.ArrayType\r
- (dim', Types.PredefinedType\r
- { Types.base_type = Types.IntegerType })) ->\r
- Types.ArrayType\r
- (dim, Types.ArrayType\r
- (dim', Types.PredefinedType\r
- { Types.base_type = Types.IntegerType; attributes = [] }))\r
- | Types.ArrayType\r
- (dim, Types.ArrayType\r
- (_, Types.PredefinedType\r
- { Types.base_type = Types.IntegerType | Types.RealType })),\r
- Types.ArrayType\r
- (_, Types.ArrayType\r
- (dim', Types.PredefinedType\r
- { Types.base_type = Types.IntegerType | Types.RealType })) ->\r
- Types.ArrayType\r
- (dim, Types.ArrayType\r
- (dim', Types.PredefinedType\r
- { Types.base_type = Types.RealType; attributes = [] }))\r
- | Types.ArrayType (_, Types.ArrayType (Types.ConstantDimension n, _)),\r
- Types.ArrayType (Types.ConstantDimension n', _)\r
- when n <> n' ->\r
- raise (CompilError\r
- {err_msg = ["_ArrayDimsNonCompatibleWithMult"];\r
- err_info =\r
- [("_ExprKind", "A * B");\r
- ("_TypeOfA", Types.string_of_class_specifier cl_spec);\r
- ("_TypeOfB", Types.string_of_class_specifier cl_spec')];\r
- err_ctx = ctx}) (*error*)\r
- | Types.ArrayType\r
- (dim, Types.ArrayType\r
- (_, Types.PredefinedType\r
- { Types.base_type = Types.IntegerType })),\r
- Types.ArrayType\r
- (_, Types.PredefinedType\r
- { Types.base_type = Types.IntegerType }) ->\r
- Types.ArrayType\r
- (dim, Types.PredefinedType\r
- { Types.base_type = Types.IntegerType; attributes = [] })\r
- | Types.ArrayType\r
- (dim, Types.ArrayType\r
- (_, Types.PredefinedType\r
- { Types.base_type = Types.IntegerType | Types.RealType })),\r
- Types.ArrayType\r
- (_, Types.PredefinedType\r
- { Types.base_type = Types.IntegerType | Types.RealType }) ->\r
- Types.ArrayType\r
- (dim, Types.PredefinedType\r
- { Types.base_type = Types.RealType; attributes = [] })\r
- | Types.ArrayType (Types.ConstantDimension n, _),\r
- Types.ArrayType (Types.ConstantDimension n', Types.ArrayType _)\r
- when n <> n' ->\r
- raise (CompilError\r
- {err_msg = ["_ArrayDimsNonCompatibleWithMult"];\r
- err_info =\r
- [("_ExprKind", "A * B");\r
- ("_TypeOfA", Types.string_of_class_specifier cl_spec);\r
- ("_TypeOfB", Types.string_of_class_specifier cl_spec')];\r
- err_ctx = ctx}) (*error*)\r
- | Types.ArrayType\r
- (_, Types.PredefinedType\r
- { Types.base_type = Types.IntegerType }),\r
- Types.ArrayType\r
- (_, Types.ArrayType\r
- (dim, Types.PredefinedType\r
- { Types.base_type = Types.IntegerType })) ->\r
- Types.ArrayType\r
- (dim, Types.PredefinedType\r
- { Types.base_type = Types.IntegerType; attributes = [] })\r
- | Types.ArrayType\r
- (_, Types.PredefinedType\r
- { Types.base_type = Types.IntegerType | Types.RealType }),\r
- Types.ArrayType\r
- (_, Types.ArrayType\r
- (dim, Types.PredefinedType\r
- { Types.base_type = Types.IntegerType | Types.RealType })) ->\r
- Types.ArrayType\r
- (dim, Types.PredefinedType\r
- { Types.base_type = Types.RealType; attributes = [] })\r
- | Types.ArrayType (Types.ConstantDimension n, _),\r
- Types.ArrayType (Types.ConstantDimension n', _)\r
- when n <> n' ->\r
- raise (CompilError\r
- {err_msg = ["_ArrayDimsNonCompatibleWithMult"];\r
- err_info =\r
- [("_ExprKind", "A * B");\r
- ("_TypeOfA", Types.string_of_class_specifier cl_spec);\r
- ("_TypeOfB", Types.string_of_class_specifier cl_spec')];\r
- err_ctx = ctx}) (*error*)\r
- | Types.ArrayType\r
- (_, Types.PredefinedType\r
- { Types.base_type = Types.IntegerType }),\r
- Types.ArrayType\r
- (_, Types.PredefinedType\r
- { Types.base_type = Types.IntegerType }) ->\r
- Types.PredefinedType\r
- { Types.base_type = Types.IntegerType; attributes = [] }\r
- | Types.ArrayType\r
- (_, Types.PredefinedType\r
- { Types.base_type = Types.IntegerType | Types.RealType }),\r
- Types.ArrayType\r
- (_, Types.PredefinedType\r
- { Types.base_type = Types.IntegerType | Types.RealType }) ->\r
- Types.PredefinedType\r
- { Types.base_type = Types.RealType; attributes = [] }\r
- | Types.PredefinedType\r
- { Types.base_type = Types.IntegerType | Types.RealType },\r
- Types.ArrayType (dim, cl_spec') ->\r
- Types.ArrayType (dim, multiplication_type cl_spec cl_spec')\r
- | Types.ArrayType (dim, cl_spec),\r
- Types.PredefinedType\r
- { Types.base_type = Types.IntegerType | Types.RealType } ->\r
- Types.ArrayType (dim, multiplication_type cl_spec cl_spec')\r
- | Types.PredefinedType { Types.base_type = Types.IntegerType },\r
- Types.PredefinedType { Types.base_type = Types.IntegerType } ->\r
- Types.PredefinedType\r
- { Types.base_type = Types.IntegerType; attributes = [] }\r
- | Types.PredefinedType\r
- { Types.base_type = Types.RealType | Types.IntegerType },\r
- Types.PredefinedType\r
- { Types.base_type = Types.RealType | Types.IntegerType } ->\r
- Types.PredefinedType\r
- { Types.base_type = Types.RealType; attributes = [] }\r
- | (Types.PredefinedType _ | Types.ClassType _ | Types.ComponentType _ |\r
- Types.ArrayType _ | Types.TupleType _),\r
- (Types.PredefinedType _ | Types.ClassType _ | Types.ComponentType _ |\r
- Types.ArrayType _ | Types.TupleType _) ->\r
- raise (CompilError\r
- {err_msg = ["*"; "_OperAppliedToNonNumericExpr"];\r
- err_info =\r
- [("_ExprKind", "A * B");\r
- ("_TypeOfA", Types.string_of_class_specifier cl_spec);\r
- ("_TypeOfB", Types.string_of_class_specifier cl_spec')];\r
- err_ctx = ctx}) (*error*) in\r
- let var =\r
- lazy (let var = evaluate cpnt_type.Types.variability\r
- and var' = evaluate cpnt_type'.Types.variability in\r
- Types.max_variability var var')\r
- and inout = Types.Acausal\r
- and cl_spec =\r
- lazy (let cl_spec = evaluate cpnt_type.Types.base_class\r
- and cl_spec' = evaluate cpnt_type'.Types.base_class in\r
- multiplication_type cl_spec cl_spec') in\r
- let nat = BinaryOperation (Times, arg, arg') in\r
- let elt_nat =\r
- let cpnt_type =\r
- component_element (lazy false) var (lazy inout) cl_spec in\r
- Types.ComponentElement cpnt_type in\r
- resolved_expression (Some expr) nat elt_nat in\r
- match arg.info.type_description, arg'.info.type_description with\r
- | Types.ComponentElement cpnt_type, Types.ComponentElement cpnt_type' ->\r
- resolve_multiplication' cpnt_type cpnt_type'\r
- | (Types.ComponentElement _ | Types.ClassElement _ |\r
- Types.ComponentTypeElement _ | Types.PredefinedTypeElement _),\r
- (Types.ComponentElement _ | Types.ClassElement _ |\r
- Types.ComponentTypeElement _ | Types.PredefinedTypeElement _) ->\r
- raise (CompilError\r
- {err_msg = ["_ClassElemFoundInExpr"];\r
- err_info = [];\r
- err_ctx = ctx}) (*error*)\r
-\r
-and resolve_power ctx expr arg arg' =\r
- let resolve_power' cpnt_type cpnt_type' =\r
- let rec power_type cl_spec cl_spec' = match cl_spec, cl_spec' with\r
- | Types.ArrayType\r
- (Types.ConstantDimension n, Types.ArrayType\r
- (Types.ConstantDimension n', _)),\r
- Types.PredefinedType { Types.base_type = Types.IntegerType }\r
- when n <> n' ->\r
- raise (CompilError\r
- {err_msg = ["_PowerOperOnNonSquareArray"];\r
- err_info =\r
- [("_ExprKind", "A ^ B");\r
- ("_TypeOfA", Types.string_of_class_specifier cl_spec);\r
- ("_TypeOfB", Types.string_of_class_specifier cl_spec')];\r
- err_ctx = ctx}) (*error*)\r
- | Types.ArrayType\r
- (dim, Types.ArrayType\r
- (dim', Types.PredefinedType\r
- { Types.base_type = Types.IntegerType })),\r
- Types.PredefinedType { Types.base_type = Types.IntegerType } ->\r
- Types.ArrayType\r
- (dim, Types.ArrayType\r
- (dim', Types.PredefinedType\r
- { Types.base_type = Types.RealType; attributes = [] }))\r
- | Types.ArrayType\r
- (dim, Types.ArrayType\r
- (dim', Types.PredefinedType { Types.base_type = Types.RealType })),\r
- Types.PredefinedType { Types.base_type = Types.IntegerType } ->\r
- Types.ArrayType\r
- (dim, Types.ArrayType\r
- (dim', Types.PredefinedType\r
- { Types.base_type = Types.RealType; attributes = [] }))\r
- | Types.PredefinedType { Types.base_type = Types.IntegerType },\r
- Types.PredefinedType { Types.base_type = Types.IntegerType } ->\r
- Types.PredefinedType\r
- { Types.base_type = Types.RealType; attributes = [] }\r
- | Types.PredefinedType\r
- { Types.base_type = Types.RealType | Types.IntegerType },\r
- Types.PredefinedType\r
- { Types.base_type = Types.RealType | Types.IntegerType } ->\r
- Types.PredefinedType\r
- { Types.base_type = Types.RealType; attributes = [] }\r
- | (Types.PredefinedType _ | Types.ClassType _ | Types.ComponentType _ |\r
- Types.ArrayType _ | Types.TupleType _),\r
- (Types.PredefinedType _ | Types.ClassType _ | Types.ComponentType _ |\r
- Types.ArrayType _ | Types.TupleType _) ->\r
- raise (CompilError\r
- {err_msg = ["^"; "_OperAppliedToNonNumericExpr"];\r
- err_info =\r
- [("_ExprKind", "A ^ B");\r
- ("_TypeOfA", Types.string_of_class_specifier cl_spec);\r
- ("_TypeOfB", Types.string_of_class_specifier cl_spec')];\r
- err_ctx = ctx}) (*error*) in\r
- let var =\r
- lazy (let var = evaluate cpnt_type.Types.variability\r
- and var' = evaluate cpnt_type'.Types.variability in\r
- Types.max_variability var var')\r
- and inout = Types.Acausal\r
- and cl_spec =\r
- lazy (let cl_spec = evaluate cpnt_type.Types.base_class\r
- and cl_spec' = evaluate cpnt_type'.Types.base_class in\r
- power_type cl_spec cl_spec') in\r
- let nat = BinaryOperation (Power, arg, arg') in\r
- let elt_nat =\r
- let cpnt_type =\r
- component_element (lazy false) var (lazy inout) cl_spec in\r
- Types.ComponentElement cpnt_type in\r
- resolved_expression (Some expr) nat elt_nat in\r
- match arg.info.type_description, arg'.info.type_description with\r
- | Types.ComponentElement cpnt_type, Types.ComponentElement cpnt_type' ->\r
- resolve_power' cpnt_type cpnt_type'\r
- | (Types.ComponentElement _ | Types.ClassElement _ |\r
- Types.ComponentTypeElement _ | Types.PredefinedTypeElement _),\r
- (Types.ComponentElement _ | Types.ClassElement _ |\r
- Types.ComponentTypeElement _ | Types.PredefinedTypeElement _) ->\r
- raise (CompilError\r
- {err_msg = ["_ClassElemFoundInExpr"];\r
- err_info = [];\r
- err_ctx = ctx}) (*error*)\r
-\r
-and resolve_subtraction ctx expr arg arg' =\r
- let resolve_subtraction' cpnt_type cpnt_type' =\r
- let rec subtraction_type cl_spec cl_spec' = match cl_spec, cl_spec' with\r
- | Types.ArrayType (Types.ConstantDimension n, _),\r
- Types.ArrayType (Types.ConstantDimension n', _) when n <> n' ->\r
- raise (CompilError\r
- {err_msg = ["_ArrayDimMustAgreeToPerform"; "_Subtraction"];\r
- err_info =\r
- [("_ExprKind", "A - B");\r
- ("_TypeOfA", Types.string_of_class_specifier cl_spec);\r
- ("_TypeOfB", Types.string_of_class_specifier cl_spec')];\r
- err_ctx = ctx}) (*error*)\r
- | Types.ArrayType (Types.ConstantDimension _, cl_spec),\r
- Types.ArrayType (dim, cl_spec') |\r
- Types.ArrayType (dim, cl_spec),\r
- Types.ArrayType (Types.ConstantDimension _, cl_spec') ->\r
- Types.ArrayType (dim, subtraction_type cl_spec cl_spec')\r
- | Types.ArrayType (Types.ParameterDimension, cl_spec),\r
- Types.ArrayType (dim, cl_spec') |\r
- Types.ArrayType (dim, cl_spec),\r
- Types.ArrayType (Types.ParameterDimension, cl_spec') ->\r
- Types.ArrayType (dim, subtraction_type cl_spec cl_spec')\r
- | Types.ArrayType (Types.DiscreteDimension, cl_spec),\r
- Types.ArrayType (Types.DiscreteDimension, cl_spec') ->\r
- Types.ArrayType\r
- (Types.DiscreteDimension, subtraction_type cl_spec cl_spec')\r
- | Types.PredefinedType { Types.base_type = Types.IntegerType },\r
- Types.PredefinedType { Types.base_type = Types.IntegerType } ->\r
- Types.PredefinedType\r
- { Types.base_type = Types.IntegerType; attributes = [] }\r
- | Types.PredefinedType\r
- { Types.base_type = Types.RealType | Types.IntegerType },\r
- Types.PredefinedType\r
- { Types.base_type = Types.RealType | Types.IntegerType } ->\r
- Types.PredefinedType\r
- { Types.base_type = Types.RealType; attributes = [] }\r
- | (Types.PredefinedType _ | Types.ClassType _ | Types.ComponentType _ |\r
- Types.ArrayType _ | Types.TupleType _),\r
- (Types.PredefinedType _ | Types.ClassType _ | Types.ComponentType _ |\r
- Types.ArrayType _ | Types.TupleType _) ->\r
- raise (CompilError\r
- {err_msg = ["-"; "_OperAppliedToNonNumericExpr"];\r
- err_info =\r
- [("_ExprKind", "A - B");\r
- ("_TypeOfA", Types.string_of_class_specifier cl_spec);\r
- ("_TypeOfB", Types.string_of_class_specifier cl_spec')];\r
- err_ctx = ctx}) (*error*) in\r
- let var =\r
- lazy (let var = evaluate cpnt_type.Types.variability\r
- and var' = evaluate cpnt_type'.Types.variability in\r
- Types.max_variability var var')\r
- and inout = Types.Acausal\r
- and cl_spec =\r
- lazy (let cl_spec = evaluate cpnt_type.Types.base_class\r
- and cl_spec' = evaluate cpnt_type'.Types.base_class in\r
- subtraction_type cl_spec cl_spec') in\r
- let nat = BinaryOperation (Minus, arg, arg') in\r
- let elt_nat =\r
- let cpnt_type =\r
- component_element (lazy false) var (lazy inout) cl_spec in\r
- Types.ComponentElement cpnt_type in\r
- resolved_expression (Some expr) nat elt_nat in\r
- match arg.info.type_description, arg'.info.type_description with\r
- | Types.ComponentElement cpnt_type, Types.ComponentElement cpnt_type' ->\r
- resolve_subtraction' cpnt_type cpnt_type'\r
- | (Types.ComponentElement _ | Types.ClassElement _ |\r
- Types.ComponentTypeElement _ | Types.PredefinedTypeElement _),\r
- (Types.ComponentElement _ | Types.ClassElement _ |\r
- Types.ComponentTypeElement _ | Types.PredefinedTypeElement _) ->\r
- raise (CompilError\r
- {err_msg = ["_ClassElemFoundInExpr"];\r
- err_info = [];\r
- err_ctx = ctx}) (*error*)\r
-\r
-and resolve_unary_minus ctx expr arg =\r
- let resolve_unary_minus' cpnt_type =\r
- let rec unary_minus_type cl_spec = match cl_spec with\r
- | Types.ArrayType (dim, cl_spec) ->\r
- Types.ArrayType (dim, unary_minus_type cl_spec)\r
- | Types.PredefinedType\r
- { Types.base_type = Types.RealType | Types.IntegerType } -> cl_spec\r
- | (Types.PredefinedType _ | Types.ClassType _ | Types.ComponentType _ |\r
- Types.TupleType _) -> \r
- raise (CompilError\r
- {err_msg = ["-"; "_OperAppliedToNonNumericExpr"];\r
- err_info =\r
- [("_ExprKind", "- A");\r
- ("_TypeOfA", Types.string_of_class_specifier cl_spec)];\r
- err_ctx = ctx}) (*error*) in\r
- let var = cpnt_type.Types.variability\r
- and inout = Types.Acausal\r
- and cl_spec =\r
- lazy (let cl_spec = evaluate cpnt_type.Types.base_class in\r
- unary_minus_type cl_spec) in\r
- let nat = UnaryOperation (UnaryMinus, arg) in\r
- let elt_nat =\r
- let cpnt_type =\r
- component_element (lazy false) var (lazy inout) cl_spec in\r
- Types.ComponentElement cpnt_type in\r
- resolved_expression (Some expr) nat elt_nat in\r
- match arg.info.type_description with\r
- | Types.ComponentElement cpnt_type -> resolve_unary_minus' cpnt_type\r
- | Types.ClassElement _ |\r
- Types.ComponentTypeElement _ | Types.PredefinedTypeElement _ ->\r
- raise (CompilError\r
- {err_msg = ["_ClassElemFoundInExpr"];\r
- err_info = [];\r
- err_ctx = ctx}) (*error*)\r
-\r
-and resolve_not ctx expr arg =\r
- let resolve_not' cpnt_type =\r
- let rec not_type cl_spec = match cl_spec with\r
- | Types.PredefinedType { Types.base_type = Types.BooleanType } -> cl_spec\r
- | (Types.PredefinedType _ | Types.ArrayType _ | Types.ClassType _ |\r
- Types.ComponentType _ | Types.TupleType _) ->\r
- raise (CompilError\r
- {err_msg = ["not"; "_OperAppliedToNonBoolExpr"];\r
- err_info =\r
- [("_ExprKind", "not A");\r
- ("_TypeOfA", Types.string_of_class_specifier cl_spec)];\r
- err_ctx = ctx}) (*error*) in\r
- let var = cpnt_type.Types.variability\r
- and inout = Types.Acausal\r
- and cl_spec =\r
- lazy (let cl_spec = evaluate cpnt_type.Types.base_class in\r
- not_type cl_spec) in\r
- let nat = UnaryOperation (Not, arg) in\r
- let elt_nat =\r
- let cpnt_type =\r
- component_element (lazy false) var (lazy inout) cl_spec in\r
- Types.ComponentElement cpnt_type in\r
- resolved_expression (Some expr) nat elt_nat in\r
- match arg.info.type_description with\r
- | Types.ComponentElement cpnt_type -> resolve_not' cpnt_type\r
- | Types.ClassElement _ |\r
- Types.ComponentTypeElement _ | Types.PredefinedTypeElement _ ->\r
- raise (CompilError\r
- {err_msg = ["_ClassElemFoundInExpr"];\r
- err_info = [];\r
- err_ctx = ctx}) (*error*)\r
-\r
-and component_element flow var inout cl_spec =\r
- {\r
- Types.flow = flow;\r
- variability = var;\r
- causality = inout;\r
- base_class = cl_spec\r
- }\r
-\r
-and element_nature_class ctx = function\r
- | Types.ClassElement cl_spec -> evaluate cl_spec\r
- | Types.ComponentElement cpnt_type -> evaluate cpnt_type.Types.base_class\r
- | Types.PredefinedTypeElement predef -> Types.PredefinedType predef\r
- | Types.ComponentTypeElement _ -> assert false (*error*)\r
-\r
-and element_field_type_nature ctx flow var inout cl_spec id =\r
- let add_dimension dim = function\r
- | Types.ComponentElement cpnt_type ->\r
- let cpnt_type' =\r
- { cpnt_type with\r
- Types.base_class =\r
- lazy (Types.ArrayType (dim, evaluate cpnt_type.Types.base_class))\r
- } in\r
- Types.ComponentElement cpnt_type'\r
- | Types.ClassElement _\r
- | Types.ComponentTypeElement _\r
- | Types.PredefinedTypeElement _ ->\r
- raise (CompilError\r
- {err_msg = ["_InvalidClassElemModif"];\r
- err_info = [];\r
- err_ctx = ctx}) (*error*) in\r
- let find_predefined_local_identifier predef id =\r
- match predef.Types.base_type with\r
- | Types.BooleanType when id = "start" -> Types.boolean_type Types.Parameter\r
- | Types.IntegerType when id = "start" ->\r
- Types.integer_type Types.Parameter\r
- | Types.RealType when id = "start" ->\r
- Types.real_type Types.Parameter\r
- | Types.StringType when id = "start" -> Types.string_type Types.Parameter\r
- | Types.EnumerationType enum_lits when id = "start" ->\r
- Types.enumeration_type Types.Parameter enum_lits\r
- | _ when id = "fixed" -> Types.boolean_type Types.Constant\r
- | Types.IntegerType when id = "nominal" ->\r
- Types.integer_type Types.Constant\r
- | Types.RealType when id = "nominal" ->\r
- Types.real_type Types.Constant\r
- | _ ->\r
- raise (CompilError\r
- {err_msg = ["_NotYetImplemented"; "_PredefinedTypeAttribModif"; id];\r
- err_info = [];\r
- err_ctx = ctx})\r
- and find_class_local_identifier flow var inout cl_type id =\r
- let apply_prefixes elt_nat = match elt_nat with\r
- | Types.ComponentElement cpnt_type ->\r
- let flow' = lazy (flow || evaluate cpnt_type.Types.flow) in\r
- Types.ComponentElement { cpnt_type with Types.flow = flow' }\r
- | Types.ClassElement _ | Types.ComponentTypeElement _ |\r
- Types.PredefinedTypeElement _ -> elt_nat in\r
- try\r
- let elt_type =\r
- evaluate (List.assoc id cl_type.Types.named_elements) in\r
- match elt_type.Types.dynamic_scope with\r
- | None | Some Types.Inner | Some Types.InnerOuter\r
- when not elt_type.Types.protected ->\r
- apply_prefixes elt_type.Types.element_nature\r
- | None | Some Types.Inner | Some Types.InnerOuter ->\r
- raise (CompilError\r
- {err_msg = ["_CannotAccessProtectElem"; id];\r
- err_info = [];\r
- err_ctx = ctx}) (*error*)\r
- | Some Types.Outer ->\r
- raise (CompilError\r
- {err_msg = ["_CannotAccessOuterElem"; id];\r
- err_info = [];\r
- err_ctx = ctx}) (*error*)\r
- with Not_found ->\r
- raise (CompilError\r
- {err_msg = ["_UnknownIdentifier"; id];\r
- err_info = [];\r
- err_ctx = ctx }) (*error*) in\r
- let rec find_local_identifier flow var inout = function\r
- | Types.PredefinedType predef_type ->\r
- find_predefined_local_identifier predef_type id\r
- | Types.ClassType cl_type ->\r
- find_class_local_identifier flow var inout cl_type id\r
- | Types.ComponentType cpnt_type ->\r
- let flow = flow || evaluate cpnt_type.Types.flow\r
- and var =\r
- Types.max_variability var (evaluate cpnt_type.Types.variability)\r
- and inout = evaluate cpnt_type.Types.causality\r
- and base_class = evaluate cpnt_type.Types.base_class in\r
- find_local_identifier flow var inout base_class\r
- | Types.ArrayType (dim, cl_spec) ->\r
- add_dimension dim (find_local_identifier flow var inout cl_spec)\r
- | Types.TupleType _ -> assert false (*error*) in\r
- find_local_identifier flow var inout cl_spec\r
-\r
-and scalar_element_nature elt_nat =\r
- let rec scalar_element_nature' cl_spec = match cl_spec with\r
- | Types.PredefinedType _ | Types.ClassType _ | Types.ComponentType _ |\r
- Types.TupleType _ -> cl_spec\r
- | Types.ArrayType (_, cl_spec) -> scalar_element_nature' cl_spec in\r
- match elt_nat with\r
- | Types.ComponentElement cpnt_type ->\r
- let base_class' =\r
- lazy (scalar_element_nature' (evaluate cpnt_type.Types.base_class)) in\r
- Types.ComponentElement { cpnt_type with Types.base_class = base_class' }\r
- | Types.ClassElement _ | Types.ComponentTypeElement _ |\r
- Types.PredefinedTypeElement _ -> elt_nat\r
-\r
-and resolve_lhs_expression ctx expr =\r
- raise (CompilError\r
- {err_msg = ["_NotYetImplemented";\r
- "_ExternalCallWithLeftHandSideExpr"];\r
- err_info = [];\r
- err_ctx = ctx})\r
-\r
-and resolve_subscripts ctx expr cl_spec subs =\r
- let rec resolve_subscripts' n cl_spec subs = match cl_spec, subs with\r
- | _, [] -> []\r
- | Types.ArrayType (dim, cl_spec'), sub :: subs' ->\r
- let sub' = resolve_subscript ctx expr n dim sub in\r
- sub' :: resolve_subscripts' (Int32.add n 1l) cl_spec' subs'\r
- | (Types.PredefinedType _ | Types.ClassType _ | Types.ComponentType _ |\r
- Types.TupleType _), _ :: _ ->\r
- raise (CompilError\r
- {err_msg = ["_CannotSubscriptANonArrayTypeElem"];\r
- err_info =\r
- [("_ExpectedType", "_ArrayType");\r
- ("_TypeFound", Types.string_of_class_specifier cl_spec)];\r
- err_ctx = ctx}) (*error*) in\r
- match subs.Syntax.nature with\r
- | Syntax.Subscripts subs' -> resolve_subscripts' 1l cl_spec subs'\r
-\r
-and resolve_subscript ctx expr n dim sub = match sub.Syntax.nature with\r
- | Syntax.Colon -> resolve_colon ctx expr n dim\r
- | Syntax.Subscript expr' ->\r
- let ctx' =\r
- { ctx with\r
- context_nature = SubscriptContext (ctx, expr, n, dim);\r
- location = expr'.Syntax.info } in\r
- resolve_subscript_expression ctx' expr'\r
-\r
-and resolve_colon ctx expr n dim =\r
- let range var stop =\r
- let nat = Range (one, one, stop)\r
- and elt_nat = Types.integer_array_type var dim in\r
- resolved_expression None nat elt_nat in\r
- match dim with\r
- | Types.ConstantDimension n ->\r
- let stop =\r
- let nat = Integer n\r
- and elt_nat = Types.integer_type Types.Constant in\r
- resolved_expression None nat elt_nat in\r
- range Types.Constant stop\r
- | Types.ParameterDimension ->\r
- let stop = size_function_call ctx None expr n in\r
- range Types.Parameter stop\r
- | Types.DiscreteDimension ->\r
- let stop = size_function_call ctx None expr n in\r
- range Types.Discrete stop\r
-\r
-and resolve_subscript_expression ctx expr =\r
- let expr' = resolve_expression ctx expr in\r
- let resolve_subscript_expression' cpnt_type =\r
- let cl_spec = evaluate cpnt_type.Types.base_class in\r
- match cl_spec with\r
- | Types.PredefinedType { Types.base_type = Types.IntegerType } |\r
- Types.ArrayType\r
- (_, Types.PredefinedType { Types.base_type = Types.IntegerType }) ->\r
- expr'\r
- | Types.PredefinedType _ | Types.ClassType _ | Types.ComponentType _ |\r
- Types.ArrayType _ | Types.TupleType _ ->\r
- raise (CompilError\r
- {err_msg = ["_NonIntegerArraySubscript"];\r
- err_info =\r
- [("_ExpectedType", "Integer");\r
- ("_TypeFound", Types.string_of_class_specifier cl_spec)];\r
- err_ctx = ctx}) (*error*) in\r
- match expr'.info.type_description with\r
- | Types.ComponentElement cpnt_type ->\r
- resolve_subscript_expression' cpnt_type\r
- | Types.ClassElement _ | Types.ComponentTypeElement _ |\r
- Types.PredefinedTypeElement _ ->\r
- raise (CompilError\r
- {err_msg = ["_ClassElemFoundInExpr"];\r
- err_info = [];\r
- err_ctx = ctx}) (*error*)\r
-\r
-and size_function_call ctx syn arg n =\r
- let size_function_call' cpnt_type =\r
- let cpnt_type' =\r
- { cpnt_type with\r
- Types.base_class = lazy (Types.integer_class_type)\r
- } in\r
- let size =\r
- let nat = PredefinedIdentifier "size"\r
- and elt_nat =\r
- Types.function_type\r
- [("@1", cpnt_type);\r
- ("@2", Types.integer_component_type Types.Constant)]\r
- ["@3", cpnt_type'] in\r
- resolved_expression None nat elt_nat in\r
- let elt_nat = Types.ComponentElement cpnt_type' in\r
- let num =\r
- let nat = Integer n\r
- and elt_nat = Types.integer_type Types.Constant in\r
- resolved_expression None nat elt_nat\r
- and expr =\r
- let args =\r
- let arg1 =\r
- let nat = FunctionArgument 1\r
- and elt_nat = arg.info.type_description in\r
- resolved_expression None nat elt_nat\r
- and arg2 =\r
- let nat = FunctionArgument 2\r
- and elt_nat = Types.integer_type Types.Constant in\r
- resolved_expression None nat elt_nat in\r
- [arg1; arg2] in\r
- let nat = FunctionInvocation args in\r
- resolved_expression None nat elt_nat in\r
- let nat = FunctionCall (size, [arg; num], expr) in\r
- resolved_expression syn nat elt_nat in\r
- match arg.info.type_description with\r
- | Types.ComponentElement cpnt_type -> size_function_call' cpnt_type\r
- | Types.ClassElement _ | Types.ComponentTypeElement _ |\r
- Types.PredefinedTypeElement _ ->\r
- raise (CompilError\r
- {err_msg = ["_ClassElemFoundInExpr"];\r
- err_info = [];\r
- err_ctx = ctx}) (*error*)\r
-\r
-and element_type ctx protect final repl dyn_scope elt_desc =\r
- {\r
- Types.protected = protect;\r
- final = bool_of_final final;\r
- replaceable = bool_of_replaceable repl;\r
- dynamic_scope = dynamic_scope_of_dynamic_scope dyn_scope;\r
- element_nature = element_nature_type ctx elt_desc\r
- }\r
-\r
-and bool_of_replaceable = function\r
- | None -> false\r
- | Some Syntax.Replaceable -> true\r
-\r
-and dynamic_scope_of_dynamic_scope = function\r
- | None -> None\r
- | Some Syntax.Inner -> Some Types.Inner\r
- | Some Syntax.Outer -> Some Types.Outer\r
- | Some Syntax.InnerOuter -> Some Types.InnerOuter\r
-\r
-and element_nature_type ctx elt_desc =\r
- let elt_nat = match elt_desc.element_nature with\r
- | Component cpnt_desc -> Types.ComponentElement (evaluate cpnt_desc.component_type)\r
- | Class cl_def -> Types.ClassElement cl_def.class_type\r
- | ComponentType cpnt_type_desc ->\r
- Types.ComponentTypeElement (evaluate cpnt_type_desc.described_type)\r
- | PredefinedType predef -> Types.PredefinedTypeElement predef in\r
- elt_nat\r
-\r
-and class_specifier_type ctx part kind cl_def cl_spec =\r
- let class_kind kind cl_type =\r
- let check_class () =\r
- if has_inouts cl_type then\r
- raise (CompilError\r
- {err_msg = ["_CannotUseCausPrefixInGenClass";\r
- class_specifier_name cl_spec];\r
- err_info = [];\r
- err_ctx = ctx}) (*error*)\r
- else kind\r
- and check_model () = kind\r
- and check_block () =\r
- raise (CompilError\r
- {err_msg = ["_NotYetImplemented"; "_BlockElem"];\r
- err_info = [];\r
- err_ctx = ctx})\r
- and check_record () = kind\r
- and check_expandable_connector () =\r
- raise (CompilError\r
- {err_msg = ["_NotYetImplemented"; "_ExpandableConnector"];\r
- err_info = [];\r
- err_ctx = ctx})\r
- and check_connector () = kind\r
- and check_package () = kind\r
- and check_function () = kind in\r
- match kind with\r
- | Types.Class -> check_class ()\r
- | Types.Model -> check_model ()\r
- | Types.Block -> check_block ()\r
- | Types.Record -> check_record ()\r
- | Types.ExpandableConnector -> check_expandable_connector ()\r
- | Types.Connector -> check_connector ()\r
- | Types.Package -> check_package ()\r
- | Types.Function -> check_function () in\r
- let rec cl_type =\r
- {\r
- Types.partial = bool_of_partial part;\r
- kind = lazy (class_kind kind cl_type);\r
- named_elements = class_type_elements ctx kind cl_def\r
- } in\r
- Types.ClassType cl_type\r
-\r
-and bool_of_partial = function\r
- | None -> false\r
- | Some Syntax.Partial -> true\r
-\r
-and class_type_elements ctx kind cl_def = match evaluate cl_def.description with\r
- | LongDescription long_desc -> long_description_type_elements ctx kind long_desc\r
- | ShortDescription short_desc -> short_description_type_elements ctx kind short_desc\r
-\r
-and short_description_type_elements ctx kind short_desc =\r
- let cl_type = evaluate short_desc.modified_class_type in\r
- let kind' = evaluate cl_type.Types.kind in\r
- match kind, kind' with\r
- | Types.Class, Types.Class |\r
- Types.Model, Types.Model |\r
- Types.Block, Types.Block |\r
- Types.Record, Types.Record |\r
- Types.ExpandableConnector, Types.ExpandableConnector |\r
- Types.Connector, Types.Connector |\r
- Types.Package, Types.Package |\r
- Types.Function, Types.Function -> cl_type.Types.named_elements\r
- | (Types.Class | Types.Model | Types.Block | Types.Record |\r
- Types.ExpandableConnector | Types.Connector | Types.Package | Types.Function),\r
- (Types.Class | Types.Model | Types.Block | Types.Record |\r
- Types.ExpandableConnector | Types.Connector | Types.Package | Types.Function) ->\r
- raise (CompilError\r
- {err_msg = ["_InheritFromDiffClassKindsNotAllowed"];\r
- err_info = [];\r
- err_ctx = ctx}) (*error*)\r
-\r
-and long_description_type_elements ctx kind long_desc =\r
- let type_element (id, elt_desc) = id, elt_desc.element_type in\r
- let local_elts = List.map type_element long_desc.named_elements in\r
- let add_extensions kinds exts =\r
- let add_named_element protected named_elt named_elts =\r
- let element_type elt_type =\r
- let elt_type' = evaluate elt_type in\r
- { elt_type' with Types.protected =\r
- elt_type'.Types.protected || protected } in\r
- match named_elt with\r
- | id, _ when List.mem_assoc id named_elts ->\r
- raise (CompilError\r
- {err_msg = [id; "_AlreadyDeclaredInParentClass"];\r
- err_info = [];\r
- err_ctx = ctx}) (*error*)\r
- | id, elt_type -> (id, lazy (element_type elt_type)) :: named_elts in\r
- let add_extension_contribution (visibility, modif_cl) named_elts =\r
- let protected = bool_of_visibility visibility\r
- and cl_type = evaluate modif_cl.modified_class_type in\r
- let named_elts' = cl_type.Types.named_elements in\r
- if List.mem (evaluate cl_type.Types.kind) kinds then\r
- List.fold_right (add_named_element protected) named_elts' named_elts\r
- else\r
- raise (CompilError\r
- {err_msg = ["_InheritFromDiffClassKindsNotAllowed"];\r
- err_info = [];\r
- err_ctx = ctx}) (*error*) in\r
- List.fold_right add_extension_contribution exts local_elts in\r
- match kind, long_desc.extensions with\r
- | Types.Function, [] -> local_elts\r
- | Types.Function, _ :: _ ->\r
- raise (CompilError\r
- {err_msg = ["_InheritFromFunctionNotAllowed"];\r
- err_info = [];\r
- err_ctx = ctx}) (*error*)\r
- | (Types.Class | Types.Model | Types.Block | Types.Record | Types.Connector | Types.Package),\r
- exts -> add_extensions [kind] exts\r
- | Types.ExpandableConnector, exts ->\r
- add_extensions [kind; Types.Connector] exts\r
-\r
-and bool_of_visibility = function\r
- | Public -> false\r
- | Protected -> true\r
-\r
-and has_inouts cl_type =\r
- let is_inout_component cpnt_type =\r
- match evaluate cpnt_type.Types.causality with\r
- | Types.Input | Types.Output -> true\r
- | Types.Acausal -> false in\r
- let is_inout = function\r
- | Types.ComponentElement cpnt_type -> is_inout_component cpnt_type\r
- | Types.ClassElement _ | Types.ComponentTypeElement _ |\r
- Types.PredefinedTypeElement _ -> false\r
- and element_nature (_, elt_type) = (evaluate elt_type).Types.element_nature in\r
- List.exists\r
- (function named_elt -> is_inout (element_nature named_elt))\r
- cl_type.Types.named_elements\r
-\r
-and component_type_of_expression ctx expr =\r
- match expr.info.type_description with\r
- | Types.ComponentElement cpnt_type -> cpnt_type\r
- | Types.ClassElement _ | Types.ComponentTypeElement _ |\r
- Types.PredefinedTypeElement _ ->\r
- raise (CompilError\r
- {err_msg = ["_ClassElemFoundInExpr"];\r
- err_info = [];\r
- err_ctx = ctx}) (*error*)\r
-\r
-and scalar_class_specifier ctx expr =\r
- let rec scalar_class_specifier' cl_spec = match cl_spec with\r
- | Types.ArrayType (dim, cl_spec) ->\r
- scalar_class_specifier' cl_spec\r
- | _ -> cl_spec in\r
- let cpnt_type = component_type_of_expression ctx expr in\r
- let cl_spec = evaluate cpnt_type.Types.base_class in\r
- scalar_class_specifier' cl_spec\r
-\r
-and expression_of_variable expr =\r
- let vector_variables vec_elts = match vec_elts.Syntax.nature with\r
- | Syntax.VectorReduction _ -> false\r
- | Syntax.VectorElements exprs ->\r
- List.for_all expression_of_variable exprs in\r
- match expr.Syntax.nature with\r
- | Syntax.Identifier _ -> true\r
- | Syntax.FieldAccess (expr', _) -> expression_of_variable expr'\r
- | Syntax.IndexedAccess (expr', subs) ->\r
- expression_of_variable expr'\r
- | Syntax.MatrixConstruction exprss ->\r
- List.for_all (List.for_all expression_of_variable) exprss\r
- | Syntax.Tuple exprs ->\r
- List.for_all expression_of_variable exprs\r
- | Syntax.Vector vec_elts -> vector_variables vec_elts\r
- | _ -> false\r
-\r
-and string_of_bin_oper_kind kind = match kind with\r
- | And -> " and "\r
- | Divide -> " / "\r
- | EqualEqual -> " == "\r
- | GreaterEqual -> " >= "\r
- | Greater -> " > "\r
- | LessEqual -> " <= "\r
- | Less -> " < "\r
- | Times -> " * "\r
- | NotEqual -> " <> "\r
- | Or -> " or "\r
- | Plus -> " + "\r
- | Power -> " ^ "\r
- | Minus -> " - "\r
-\r
-and string_of_un_oper_kind kind = match kind with\r
- | Not -> " not "\r
- | UnaryMinus -> "- "\r
- | UnaryPlus -> "+ "\r
-\r
-and apply_binary_coercions exprs =\r
- let base_type expr =\r
- let rec base_type' cl_spec = match cl_spec with\r
- | Types.ArrayType (_, cl_spec) -> base_type' cl_spec\r
- | Types.PredefinedType pt -> Some pt.Types.base_type\r
- | _ -> None in\r
- match expr.info.type_description with\r
- | Types.ComponentElement cpnt_type ->\r
- let cl_spec = evaluate cpnt_type.Types.base_class in\r
- base_type' cl_spec\r
- | _ -> None\r
- and real_type bt = match bt with\r
- | Some Types.RealType -> true\r
- | _ -> false\r
- and integer_type bt = match bt with\r
- | Some Types.IntegerType -> true\r
- | _ -> false in\r
- match List.map base_type exprs with\r
- | [] | [ _ ] -> exprs\r
- | bts when (List.exists real_type bts) &&\r
- (List.exists integer_type bts) ->\r
- let cpnt_type = Types.real_component_type Types.Continuous in\r
- List.map (apply_rhs_coercions cpnt_type) exprs\r
- | _ -> exprs\r
-\r
-and apply_rhs_coercions cpnt_type expr =\r
- let apply_real_of_integer cpnt_type cpnt_type' =\r
- let rec apply_real_of_integer' cl_spec cl_spec' =\r
- match cl_spec, cl_spec' with\r
- | Types.ArrayType (dim, cl_spec), _ ->\r
- apply_real_of_integer' cl_spec cl_spec'\r
- | _, Types.ArrayType (dim', cl_spec') ->\r
- let coer, cl_spec' = apply_real_of_integer' cl_spec cl_spec' in\r
- coer, Types.ArrayType (dim', cl_spec')\r
- | Types.PredefinedType { Types.base_type = Types.RealType },\r
- Types.PredefinedType { Types.base_type = Types.IntegerType } ->\r
- Some RealOfInteger, Types.real_class_type\r
- | _, _ -> None, cl_spec' in\r
- let cl_spec = evaluate cpnt_type.Types.base_class\r
- and cl_spec' = evaluate cpnt_type'.Types.base_class in\r
- match apply_real_of_integer' cl_spec cl_spec' with\r
- | Some RealOfInteger, cl_spec' ->\r
- let cpnt_type' =\r
- {\r
- cpnt_type' with\r
- Types.base_class = lazy cl_spec'\r
- }\r
- and nat' = Coercion (RealOfInteger, expr) in\r
- let elt_nat' = Types.ComponentElement cpnt_type' in\r
- resolved_expression expr.info.syntax nat' elt_nat'\r
- | _ -> expr in\r
- match expr.info.type_description with\r
- | Types.ComponentElement cpnt_type' ->\r
- apply_real_of_integer cpnt_type cpnt_type'\r
- | _ -> expr\r
-\r
-(* for debug *)\r
-and string_of_expression expr = match expr.nature with\r
- | BinaryOperation (bin_oper_kind, expr, expr') ->\r
- Printf.sprintf "BinaryOperation(_, %s, %s)"\r
- (string_of_expression expr)\r
- (string_of_expression expr')\r
- | DynamicIdentifier (i, s) -> "DynamicIdentifier"\r
- | False -> "False"\r
- | FieldAccess (expr, s) -> "FieldAccess"\r
- | FunctionArgument i -> "FunctionArgument"\r
- | FunctionCall (expr, exprs, expr') ->\r
- Printf.sprintf "FunctionCall(%s, {%s}, %s)"\r
- (string_of_expression expr)\r
- (String.concat "," (List.map string_of_expression exprs))\r
- (string_of_expression expr') \r
- | FunctionInvocation exprs -> "FunctionInvocation"\r
- | If (alts, expr) -> "If"\r
- | IndexedAccess (expr, exprs) -> "IndexedAccess"\r
- | Integer i ->\r
- Printf.sprintf "Integer(%d)" (Int32.to_int i)\r
- | LocalIdentifier (i, s) ->\r
- Printf.sprintf "LocalIdentifier(%d, %s)" i s\r
- | LoopVariable i -> "LoopVariable"\r
- | NoEvent expr -> "NoEvent"\r
- | PredefinedIdentifier s ->\r
- Printf.sprintf "PredefinedIdentifier(%s)" s\r
- | Range (start, step, stop) ->\r
- Printf.sprintf "Range(%s, %s, %s)"\r
- (string_of_expression start)\r
- (string_of_expression step)\r
- (string_of_expression stop)\r
- | Real f -> "Real"\r
- | String s -> "String"\r
- | ToplevelIdentifier s -> "ToplevelIdentifier"\r
- | True -> "True"\r
- | Tuple exprs -> "Tuple"\r
- | UnaryOperation (un_oper_kind, expr) -> "UnaryOperation"\r
- | Vector exprs -> "Vector"\r
- | VectorReduction (exprs, expr) -> "VectorReduction"\r
- | Coercion _ -> "Coercion"\r
+(*
+ * Translator from Modelica 2.x to flat Modelica
+ *
+ * Copyright (C) 2005 - 2007 Imagine S.A.
+ * For more information or commercial use please contact us at www.amesim.com
+ *
+ * This program is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this program; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
+ *
+ *)
+
+(** Resolution of types for Modelica elements from the abstract syntax tree.
+The main functions are:
+{ul
+{- [ resolve_toplevel ]: Main function. Resolve a list of top level syntax element}
+{- [ resolve_variable_definition ]: Resolution of a variable definition}
+{- [ resolve_class_definition ]: Resolution of a class definition}
+{- [ resolve_modification ]: Resolution of modifications}
+{- [ resolve_expression ]: Resolution of syntax expressions
+ {ul
+ {- [ resolve_binary_operation ]: Resolve binary operation expression }
+ {- [ resolve_unuary_operation ]: Resolve unary operation }
+ {- [ resolve_identifier ]: scoping algorithm and resolution of identifiers}
+ {- [ apply_binary_coercions, apply_rhs_coercions ]: Adding of Real to Integer implicit coercions}
+ {- [ resolve_function_call ]: Resolution of a function call expression }
+ {- [ resolve_field_access ]: Resolve field access }
+ {- [ resolve_if ]: Resolve [ if ] expression }
+ {- [ resolve_indexed_access ]: Resolve indexed access }
+ {- [ resolve_vector ]: Resolve vector expression }
+ {- [ resolve_range ]: resolve range expression }
+ }
+}
+{- [ resolve_equation ]: Resolution of an equation
+ {ul
+ {- [ resolve_equal ]: Resolution of a simple equation of the form [ expr1 = expr2 ] }
+ {- [ resolve_conditional_equation_e ]: Resolution of conditional equations }
+ {- [ resolve_for_clause_e ]: Resolution of for equations }
+ {- [ resolve_connect_clause ]: resolution of connect equations }
+ {- [ resolve_when_clause_e ]: resolution of when equations}
+ {- [ equations ]: resolution of array, record and for equations
+ }
+}
+}
+*)
+
+(* The type [ node ] is used to attach syntax information to resolved elements *)
+type ('a, 'b) node =
+ {
+ nature: 'a;
+ info: 'b
+ }
+
+(* Type of resolved elements *)
+
+and element_description =
+ {
+ element_type: Types.element_type Lazy.t;
+ redeclare: bool;
+ element_nature: element_nature;
+ element_location: Parser.location
+ }
+
+and element_nature =
+ | Component of component_description
+ | Class of class_definition
+ | ComponentType of component_type_description
+ | PredefinedType of Types.predefined_type
+
+and component_description =
+ {
+ component_type: Types.component_type Lazy.t;
+ type_specifier: expression Lazy.t;
+ dimensions: dimension list Lazy.t;
+ modification: modification option Lazy.t;
+ comment: string
+ }
+
+and dimension =
+ | Colon
+ | Expression of expression
+
+and class_definition =
+ {
+ class_type: Types.class_specifier Lazy.t;
+ enclosing_class: class_definition option;
+ encapsulated: bool;
+ description: class_description Lazy.t;
+ }
+
+and class_description =
+ | LongDescription of long_description
+ | ShortDescription of modified_class
+
+and long_description =
+ {
+ class_annotations: (annotation list) Lazy.t;
+ imports: import_description list;
+ extensions: (visibility * modified_class) list;
+ named_elements: named_element list;
+ unnamed_elements: equation_or_algorithm_clause list Lazy.t;
+ external_call: external_call option Lazy.t
+ }
+
+and annotation =
+ | InverseFunction of inverse_function Lazy.t
+ | UnknownAnnotation of (Parser.location Syntax.class_modification) Lazy.t
+
+and inverse_function =
+ {
+ function_class: expression;
+ arguments: (string * string) list
+ }
+
+and import_description = unit
+
+and visibility = Public | Protected
+
+and named_element = string * element_description
+
+and modified_class =
+ {
+ modified_class_type: Types.class_type Lazy.t;
+ base_class: expression Lazy.t;
+ class_modification: class_modification Lazy.t
+ }
+
+and component_type_description =
+ {
+ described_type: Types.component_type Lazy.t;
+ base_type: expression Lazy.t;
+ type_dimensions: dimension list Lazy.t;
+ type_modification: class_modification Lazy.t
+ }
+
+and external_call = (external_call_desc, Parser.location Syntax.externalll) node
+
+and external_call_desc =
+ | PrimitiveCall of string
+ | ExternalProcedureCall of language *
+ expression option (* rhs *) * string * expression list
+
+and language = C | FORTRAN
+
+and modification =
+ | Modification of class_modification * expression Lazy.t option
+ | Assignment of expression Lazy.t
+ | Equality of expression Lazy.t
+
+and class_modification = modification_argument list
+
+and modification_argument =
+ {
+ each: bool;
+ final: bool;
+ target: string;
+ action: modification_action option
+ }
+
+and modification_action =
+ | ElementModification of modification
+ | ElementRedeclaration of element_description
+
+(* Type of equations and algorithms *)
+
+and equation_or_algorithm_clause =
+ | EquationClause of validity * equation list
+ | AlgorithmClause of validity * algorithm list
+
+and validity = Initial | Permanent
+
+and equation = (equation_desc, Parser.location Syntax.equation option) node
+
+and equation_desc =
+ | Equal of expression * expression
+ | ConditionalEquationE of (expression * equation list) list * equation list
+ | ForClauseE of expression list (* ranges *) * equation list
+ | ConnectFlows of sign * expression * sign * expression
+ | WhenClauseE of (expression * equation list) list
+
+and sign = Positive | Negative
+
+and algorithm = (algorithm_desc, Parser.location Syntax.algorithm option) node
+
+and algorithm_desc =
+ | Assign of expression * expression
+ | FunctionCallA of expression * expression list
+ | MultipleAssign of expression list * expression * expression list
+ | Break
+ | Return
+ | ConditionalEquationA of (expression * algorithm list) list *
+ algorithm list
+ | ForClauseA of expression list (* ranges *) * algorithm list
+ | WhileClause of expression * algorithm list
+ | WhenClauseA of (expression * algorithm list) list
+
+(* Type of expressions *)
+
+and expression = (expression_desc, expression_information) node
+
+(* Type of a resolved expression:
+- [ syntax ]: expression syntax (this information is optional, some expressions
+ are dynamicaly created during typing analysis)
+- [ type_description ]: expression type *)
+and expression_information =
+ {
+ syntax: Parser.location Syntax.expression option;
+ type_description: Types.element_nature
+ }
+
+and expression_desc =
+ | BinaryOperation of binary_operator_kind * expression * expression
+ | DynamicIdentifier of int (** number of nested classes to skip *) *
+ string (** name to be searched for at instanciation time *)
+ | False
+ | FieldAccess of expression * string
+ | FunctionArgument of int (** the position of the argument in the call *)
+ | FunctionCall of expression (** function *) *
+ expression list (** arguments *) *
+ expression (** the expression involving the function call *)
+ (** creation of a dynamic function context *)
+ | FunctionInvocation of expression list
+ (** invocation of the current function in context *)
+ | If of (expression (** condition *) * expression) list *
+ expression (** default *)
+ | IndexedAccess of expression * expression list (* subscripts *)
+ | Integer of int32
+ | LocalIdentifier of int (** number of nested classes to skip *) *
+ string (** key in the dictionary of the defining class *)
+ | LoopVariable of int (** number of nested for loops to skip *)
+ | NoEvent of expression
+ | PredefinedIdentifier of string (** predefined identifier *)
+ | Range of expression * expression * expression
+ | Real of float
+ | String of string
+ | ToplevelIdentifier of string (** key in the toplevel dictionary *)
+ | True
+ | Tuple of expression list
+ | UnaryOperation of unary_operator_kind * expression
+ | Vector of expression list
+ | VectorReduction of expression list (** nested ranges *) * expression
+ | Coercion of coercion_kind * expression
+
+and coercion_kind =
+ | RealOfInteger (** Implicit conversion of Integer to Real *)
+
+and unary_operator_kind =
+ | Not
+ | UnaryMinus
+ | UnaryPlus
+
+and binary_operator_kind =
+ | And
+ | Divide
+ | EqualEqual
+ | GreaterEqual
+ | Greater
+ | LessEqual
+ | Less
+ | Times