scilab/modules/scicos/src/translator/compilation/nameResolve.ml

   1 (*\r
   2  *  Translator from Modelica 2.x to flat Modelica\r
   3  *\r
   4  *  Copyright (C) 2005 - 2007 Imagine S.A.\r
   5  *  For more information or commercial use please contact us at www.amesim.com\r
   6  *\r
   7  *  This program is free software; you can redistribute it and/or\r
   8  *  modify it under the terms of the GNU General Public License\r
   9  *  as published by the Free Software Foundation; either version 2\r
  10  *  of the License, or (at your option) any later version.\r
  11  *\r
  12  *  This program is distributed in the hope that it will be useful,\r
  13  *  but WITHOUT ANY WARRANTY; without even the implied warranty of\r
  14  *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the\r
  15  *  GNU General Public License for more details.\r
  16  *\r
  17  *  You should have received a copy of the GNU General Public License\r
  18  *  along with this program; if not, write to the Free Software\r
  19  *  Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA.\r
  20  *\r
  21  *)\r
  22 \r
  23 (** Resolution of types for Modelica elements from the abstract syntax tree.\r
  24 The main functions are:\r
  25 {ul\r
  26 {- [ resolve_toplevel ]: Main function. Resolve a list of top level syntax element}\r
  27 {- [ resolve_variable_definition ]: Resolution of a variable definition}\r
  28 {- [ resolve_class_definition ]: Resolution of a class definition}\r
  29 {- [ resolve_modification ]: Resolution of modifications}\r
  30 {- [ resolve_expression ]: Resolution of syntax expressions\r
  31   {ul\r
  32   {- [ resolve_binary_operation ]: Resolve binary operation expression }\r
  33   {- [ resolve_unuary_operation ]: Resolve unary operation }\r
  34   {- [ resolve_identifier ]: scoping algorithm and resolution of identifiers}\r
  35   {- [ apply_binary_coercions, apply_rhs_coercions ]: Adding of Real to Integer implicit coercions}\r
  36   {- [ resolve_function_call ]: Resolution of a function call expression }\r
  37   {- [ resolve_field_access ]: Resolve field access }\r
  38   {- [ resolve_if ]: Resolve [ if ] expression }\r
  39   {- [ resolve_indexed_access ]: Resolve indexed access }\r
  40   {- [ resolve_vector ]: Resolve vector expression }\r
  41   {- [ resolve_range ]: resolve range expression }\r
  42   }\r
  43 }\r
  44 {- [ resolve_equation ]: Resolution of an equation\r
  45   {ul\r
  46   {- [ resolve_equal ]: Resolution of a simple equation of the form [ expr1 = expr2 ] }\r
  47   {- [ resolve_conditional_equation_e ]: Resolution of conditional equations }\r
  48   {- [ resolve_for_clause_e ]: Resolution of for equations }\r
  49   {- [ resolve_connect_clause ]: resolution of connect equations }\r
  50   {- [ resolve_when_clause_e ]: resolution of when equations}\r
  51   {- [ equations ]: resolution of array, record and for equations\r
  52   }\r
  53 }\r
  54 }\r
  55 *)\r
  56 \r
  57 (* The type [ node ] is used to attach syntax information to resolved elements *)\r
  58 type ('a, 'b) node =\r
  59   {\r
  60     nature: 'a;\r
  61     info: 'b\r
  62   }\r
  63 \r
  64 (* Type of resolved elements *)\r
  65 \r
  66 and element_description =\r
  67   {\r
  68     element_type: Types.element_type Lazy.t;\r
  69     redeclare: bool;\r
  70     element_nature: element_nature;\r
  71     element_location: Parser.location\r
  72   }\r
  73 \r
  74 and element_nature =\r
  75   | Component of component_description\r
  76   | Class of class_definition\r
  77   | ComponentType of component_type_description\r
  78   | PredefinedType of Types.predefined_type\r
  79 \r
  80 and component_description =\r
  81   {\r
  82     component_type: Types.component_type Lazy.t;\r
  83     type_specifier: expression Lazy.t;\r
  84     dimensions: dimension list Lazy.t;\r
  85     modification: modification option Lazy.t;\r
  86     comment: string\r
  87   }\r
  88 \r
  89 and dimension =\r
  90   | Colon\r
  91   | Expression of expression\r
  92 \r
  93 and class_definition =\r
  94   {\r
  95     class_type: Types.class_specifier Lazy.t;\r
  96     enclosing_class: class_definition option;\r
  97     encapsulated: bool;\r
  98     description: class_description Lazy.t;\r
  99   }\r
 100 \r
 101 and class_description =\r
 102   | LongDescription of long_description\r
 103   | ShortDescription of modified_class\r
 104 \r
 105 and long_description =\r
 106   {\r
 107     class_annotations: (annotation list) Lazy.t;\r
 108     imports: import_description list;\r
 109     extensions: (visibility * modified_class) list;\r
 110     named_elements: named_element list;\r
 111     unnamed_elements: equation_or_algorithm_clause list Lazy.t;\r
 112     external_call: external_call option Lazy.t\r
 113   }\r
 114 \r
 115 and annotation =\r
 116   | InverseFunction of inverse_function Lazy.t\r
 117   | UnknownAnnotation of (Parser.location Syntax.class_modification) Lazy.t\r
 118 \r
 119 and inverse_function =\r
 120   {\r
 121     function_class: expression;\r
 122     arguments: (string * string) list\r
 123   }\r
 124 \r
 125 and import_description = unit\r
 126 \r
 127 and visibility = Public | Protected\r
 128 \r
 129 and named_element = string * element_description\r
 130 \r
 131 and modified_class =\r
 132   {\r
 133     modified_class_type: Types.class_type Lazy.t;\r
 134     base_class: expression Lazy.t;\r
 135     class_modification: class_modification Lazy.t\r
 136   }\r
 137 \r
 138 and component_type_description =\r
 139   {\r
 140     described_type: Types.component_type Lazy.t;\r
 141     base_type: expression Lazy.t;\r
 142     type_dimensions: dimension list Lazy.t;\r
 143     type_modification: class_modification Lazy.t\r
 144   }\r
 145 \r
 146 and external_call = (external_call_desc, Parser.location Syntax.externalll) node\r
 147 \r
 148 and external_call_desc =\r
 149   | PrimitiveCall of string\r
 150   | ExternalProcedureCall of language *\r
 151       expression option (* rhs *) * string * expression list\r
 152 \r
 153 and language = C | FORTRAN\r
 154 \r
 155 and modification =\r
 156   | Modification of class_modification * expression Lazy.t option\r
 157   | Assignment of expression Lazy.t\r
 158   | Equality of expression Lazy.t\r
 159 \r
 160 and class_modification = modification_argument list\r
 161 \r
 162 and modification_argument =\r
 163   {\r
 164     each: bool;\r
 165     final: bool;\r
 166     target: string;\r
 167     action: modification_action option\r
 168   }\r
 169 \r
 170 and modification_action =\r
 171   | ElementModification of modification\r
 172   | ElementRedeclaration of element_description\r
 173 \r
 174 (* Type of equations and algorithms *)\r
 175 \r
 176 and equation_or_algorithm_clause =\r
 177   | EquationClause of validity * equation list\r
 178   | AlgorithmClause of validity * algorithm list\r
 179 \r
 180 and validity = Initial | Permanent\r
 181 \r
 182 and equation = (equation_desc, Parser.location Syntax.equation option) node\r
 183 \r
 184 and equation_desc =\r
 185   | Equal of expression * expression\r
 186   | ConditionalEquationE of (expression * equation list) list * equation list\r
 187   | ForClauseE of expression list (* ranges *) * equation list\r
 188   | ConnectFlows of sign * expression * sign * expression\r
 189   | WhenClauseE of (expression * equation list) list\r
 190 \r
 191 and sign = Positive | Negative\r
 192 \r
 193 and algorithm = (algorithm_desc, Parser.location Syntax.algorithm option) node\r
 194 \r
 195 and algorithm_desc =\r
 196   | Assign of expression * expression\r
 197   | FunctionCallA of expression * expression list\r
 198   | MultipleAssign of expression list * expression * expression list\r
 199   | Break\r
 200   | Return\r
 201   | ConditionalEquationA of (expression * algorithm list) list *\r
 202       algorithm list\r
 203   | ForClauseA of expression list (* ranges *) * algorithm list\r
 204   | WhileClause of expression * algorithm list\r
 205   | WhenClauseA of (expression * algorithm list) list\r
 206 \r
 207 (* Type of expressions *)\r
 208 \r
 209 and expression = (expression_desc, expression_information) node\r
 210 \r
 211 (* Type of a resolved expression:\r
 212 - [ syntax ]: expression syntax (this information is optional, some expressions\r
 213   are dynamicaly created during typing analysis)\r
 214 - [ type_description ]: expression type *)\r
 215 and expression_information =\r
 216   {\r
 217     syntax: Parser.location Syntax.expression option;\r
 218     type_description: Types.element_nature\r
 219   }\r
 220 \r
 221 and expression_desc =\r
 222   | BinaryOperation of binary_operator_kind * expression * expression\r
 223   | DynamicIdentifier of int (** number of nested classes to skip *) *\r
 224       string (** name to be searched for at instanciation time *)\r
 225   | False\r
 226   | FieldAccess of expression * string\r
 227   | FunctionArgument of int (** the position of the argument in the call *)\r
 228   | FunctionCall of expression (** function *) *\r
 229       expression list (** arguments *) *\r
 230       expression (** the expression involving the function call *)\r
 231       (** creation of a dynamic function context *)\r
 232   | FunctionInvocation of expression list\r
 233       (** invocation of the current function in context *)\r
 234   | If of (expression (** condition *) * expression) list *\r
 235       expression (** default *)\r
 236   | IndexedAccess of expression * expression list (* subscripts *)\r
 237   | Integer of int32\r
 238   | LocalIdentifier of int (** number of nested classes to skip *) *\r
 239       string (** key in the dictionary of the defining class *)\r
 240   | LoopVariable of int (** number of nested for loops to skip *)\r
 241   | NoEvent of expression\r
 242   | PredefinedIdentifier of string (** predefined identifier *)\r
 243   | Range of expression * expression * expression\r
 244   | Real of float\r
 245   | String of string\r
 246   | ToplevelIdentifier of string (** key in the toplevel dictionary *)\r
 247   | True\r
 248   | Tuple of expression list\r
 249   | UnaryOperation of unary_operator_kind * expression\r
 250   | Vector of expression list\r
 251   | VectorReduction of expression list (** nested ranges *) * expression\r
 252   | Coercion of coercion_kind * expression\r
 253 \r
 254 and coercion_kind =\r
 255   | RealOfInteger (** Implicit conversion of Integer to Real *)\r
 256 \r
 257 and unary_operator_kind =\r
 258   | Not\r
 259   | UnaryMinus\r
 260   | UnaryPlus\r
 261 \r
 262 and binary_operator_kind =\r
 263   | And\r
 264   | Divide\r
 265   | EqualEqual\r
 266   | GreaterEqual\r
 267   | Greater\r
 268   | LessEqual\r
 269   | Less\r
 270   | Times\r
 271   | NotEqual\r
 272   | Or\r
 273   | Plus\r
 274   | Power\r
 275   | Minus\r
 276 \r
 277 (* Context types. Contexts are used to resolve identifiers in expressions *)\r
 278 \r
 279 type context =\r
 280   {\r
 281     toplevel: (string * element_description) list Lazy.t;\r
 282     context_nature: context_nature;\r
 283     location: Parser.location\r
 284   }\r
 285 \r
 286 and context_nature =\r
 287   | ToplevelContext\r
 288   | ClassContext of class_definition\r
 289   | SubscriptContext of\r
 290       context * expression (* evaluating to an array *) *\r
 291       int32 (* dimension index *) * Types.dimension\r
 292   | ForContext of context * string * Types.element_nature\r
 293 \r
 294 (* Type Errors detected during compilation *)\r
 295 \r
 296 type error_description =\r
 297   {\r
 298     err_msg: string list;\r
 299     err_info: (string * string) list;\r
 300     err_ctx: context\r
 301   }\r
 302 \r
 303 exception CompilError of error_description\r
 304 \r
 305 (* Utilities *)\r
 306 \r
 307 let evaluate x = Lazy.force x\r
 308 \r
 309 let resolve_elements add_element elts other_elts =\r
 310   let resolve_other_elements other_elt acc = match other_elt.Syntax.nature with\r
 311     | Syntax.Public elts -> List.fold_right (add_element Public) elts acc\r
 312     | Syntax.Protected elts -> List.fold_right (add_element Protected) elts acc\r
 313     | Syntax.EquationClause _ | Syntax.AlgorithmClause _ -> acc in\r
 314   List.fold_right\r
 315     (add_element Public)\r
 316     elts\r
 317     (List.fold_right resolve_other_elements other_elts [])\r
 318 \r
 319 let resolved_expression syntax nat elt_nat =\r
 320   {\r
 321     nature = nat;\r
 322     info = { syntax = syntax; type_description = elt_nat }\r
 323   }\r
 324 \r
 325 let one =\r
 326   let nat = Integer 1l\r
 327   and elt_nat = Types.integer_type Types.Constant in\r
 328   resolved_expression None nat elt_nat\r
 329 \r
 330 \r
 331 (* Name resolution functions *)\r
 332 \r
 333 let rec resolve_toplevel dic nodes =\r
 334   let add_element ctx acc (id, elt_desc) =\r
 335     match List.mem_assoc id acc with\r
 336     | true ->\r
 337         let ctx = { ctx with location = elt_desc.element_location } in\r
 338         raise (CompilError\r
 339           {err_msg = ["_DuplicateDeclarationOfElement"; id];\r
 340            err_info = [];\r
 341            err_ctx = ctx}) (*error*)\r
 342     | false -> acc @ [ (id, elt_desc) ] in\r
 343   let rec ctx =\r
 344     {\r
 345       toplevel =\r
 346         lazy (List.fold_left (add_element ctx) dic (evaluate elt_descs));\r
 347       context_nature = ToplevelContext;\r
 348       location =\r
 349         {\r
 350           Parser.start = 0;\r
 351                   Parser.enddd = 0;\r
 352           Parser.filename = Parser.CommandLine\r
 353         }\r
 354     }\r
 355   and elt_descs = lazy (resolve_toplevel_nodes ctx nodes) in\r
 356   evaluate ctx.toplevel\r
 357 \r
 358 and resolve_toplevel_nodes ctx nodes =\r
 359   let rec resolve_toplevel_nodes' nodes' =\r
 360     match nodes' with\r
 361       | [] -> []\r
 362       | node :: nodes' ->\r
 363           (resolve_toplevel_statements ctx node) @\r
 364           (resolve_toplevel_nodes' nodes') in\r
 365   let collect_toplevel_defs (cl_defs, nodes) node =\r
 366     match node.Syntax.nature with\r
 367       | Syntax.ClassDefinitions cl_defs' -> cl_defs' @ cl_defs, nodes\r
 368       | _ -> cl_defs, [node] @ nodes in\r
 369   let cl_defs, nodes = List.fold_left collect_toplevel_defs ([], []) nodes in\r
 370   let node = {Syntax.nature = Syntax.ClassDefinitions cl_defs;\r
 371               Syntax.info = ctx.location} in\r
 372   (resolve_toplevel_statements ctx node) @\r
 373   resolve_toplevel_nodes' nodes\r
 374 \r
 375 and resolve_toplevel_statements ctx node = match node.Syntax.nature with\r
 376   | Syntax.ClassDefinitions cl_defs -> resolve_class_definitions ctx cl_defs\r
 377   | Syntax.Expression expr -> raise (CompilError\r
 378       {err_msg = ["_NotYetImplemented"; "_TopLevelExpr"];\r
 379        err_info = [];\r
 380        err_ctx = {ctx with location = expr.Syntax.info}})\r
 381   | Syntax.VariablesDefinitions (expr, subs, cpnt_decls) ->\r
 382       resole_variables_definitions ctx expr subs cpnt_decls\r
 383   | Syntax.Command algo -> raise (CompilError\r
 384       {err_msg = ["_NotYetImplemented"; "_TopLevelAlgorithm"];\r
 385        err_info = [];\r
 386        err_ctx = {ctx with location = algo.Syntax.info}})\r
 387   | Syntax.Within path -> raise (CompilError\r
 388       {err_msg = ["_NotYetImplemented"; "_WithinClause"];\r
 389        err_info = [("_Expr", Syntax.string_of_toplevel_element node)];\r
 390        err_ctx = {ctx with location = node.Syntax.info}})\r
 391   | Syntax.Import imprt -> raise (CompilError\r
 392       {err_msg = ["_NotYetImplemented"; "_ImportClause"];\r
 393        err_info = [("_Expr", Syntax.string_of_toplevel_element node)];\r
 394        err_ctx = {ctx with location = imprt.Syntax.info}})\r
 395 \r
 396 and resole_variables_definitions ctx expr subs cpnt_decls =\r
 397   let type_spec = lazy (resolve_expression ctx expr)\r
 398   and dims = lazy (resolve_dimensions ctx subs) in\r
 399   List.map (resolve_variable_definition ctx type_spec dims expr) cpnt_decls\r
 400 \r
 401 and resolve_variable_definition ctx type_spec dims expr cpnt_decl =\r
 402   let type_pref = false, None, Types.Acausal in\r
 403   let id, elt_nat, elt_loc =\r
 404     resolve_component_declaration ctx type_pref type_spec dims expr cpnt_decl in\r
 405   let rec elt_desc =\r
 406     {\r
 407       element_type =\r
 408         lazy (element_type ctx false None None None elt_desc);\r
 409       redeclare = false;\r
 410       element_nature = elt_nat;\r
 411       element_location = elt_loc\r
 412     } in\r
 413   id, elt_desc\r
 414 \r
 415 and resolve_class_definitions ctx cl_defs =\r
 416   List.map (resolve_class_definition ctx) cl_defs\r
 417 \r
 418 and resolve_class_definition ctx cl_def = match cl_def.Syntax.nature with\r
 419   | Syntax.ClassDefinition (final, def) ->\r
 420       let loc = (match def.Syntax.nature with\r
 421         | Syntax.Definition (_, _, _, cl_spec) -> cl_spec.Syntax.info) in\r
 422       let rec elt_desc =\r
 423         {\r
 424           element_type = lazy (element_type ctx false final None None elt_desc);\r
 425           redeclare = false;\r
 426           element_nature = resolve_definition ctx def;\r
 427           element_location = loc\r
 428         } in\r
 429       let s = class_definition_name def in\r
 430       s, elt_desc\r
 431 \r
 432 and class_definition_name def = match def.Syntax.nature with\r
 433   | Syntax.Definition (_, _, _, cl_spec) -> class_specifier_name cl_spec\r
 434 \r
 435 and class_specifier_name cl_spec = match cl_spec.Syntax.nature with\r
 436   | Syntax.LongSpecifier (id, _, _) |\r
 437     Syntax.ShortSpecifier (id, _, _, _, _, _) |\r
 438     Syntax.EnumerationSpecifier (id, _, _) |\r
 439     Syntax.ExtensionSpecifier (id, _, _, _) -> id\r
 440 \r
 441 and resolve_definition ctx def =\r
 442   let ctx = {ctx with location = def.Syntax.info} in \r
 443   match def.Syntax.nature with\r
 444     | Syntax.Definition (encap, part, kind, cl_spec) ->\r
 445         resolve_specification ctx encap part kind cl_spec\r
 446 \r
 447 and resolve_specification ctx encap part kind cl_spec =\r
 448   let encap' = bool_of_encapsulated encap in\r
 449   match kind with\r
 450     | Syntax.Class ->\r
 451         resolve_class_specification ctx encap' part Types.Class cl_spec\r
 452     | Syntax.Model ->\r
 453         resolve_class_specification ctx encap' part Types.Model cl_spec\r
 454     | Syntax.Block ->\r
 455         resolve_class_specification ctx encap' part Types.Block cl_spec\r
 456     | Syntax.Record ->\r
 457         resolve_class_specification ctx encap' part Types.Record cl_spec\r
 458     | Syntax.ExpandableConnector ->\r
 459         resolve_class_specification\r
 460           ctx\r
 461           encap'\r
 462           part\r
 463           Types.ExpandableConnector\r
 464           cl_spec\r
 465     | Syntax.Connector ->\r
 466         resolve_class_specification ctx encap' part Types.Connector cl_spec\r
 467     | Syntax.Type when encap' ->\r
 468         raise (CompilError\r
 469           {err_msg = ["_EncapsulatedCannotBeAppliedTo"; "_TypeDef"];\r
 470            err_info = [];\r
 471            err_ctx = ctx}) (*error*)\r
 472     | Syntax.Type -> resolve_type_specification ctx cl_spec\r
 473     | Syntax.Package ->\r
 474         resolve_class_specification ctx encap' part Types.Package cl_spec\r
 475     | Syntax.Function ->\r
 476         resolve_class_specification ctx encap' part Types.Function cl_spec\r
 477 \r
 478 and resolve_type_specification ctx cl_spec =\r
 479   let ctx = {ctx with location = cl_spec.Syntax.info} in\r
 480   match cl_spec.Syntax.nature with\r
 481     | Syntax.LongSpecifier _ ->\r
 482         raise (CompilError\r
 483           {err_msg = ["_InvalidTypeDef"];\r
 484            err_info = [];\r
 485            err_ctx = ctx}) (*error*)\r
 486     | Syntax.ExtensionSpecifier _ ->\r
 487         raise (CompilError\r
 488           {err_msg = ["_InvalidTypeDef"];\r
 489            err_info = [];\r
 490            err_ctx = ctx}) (*error*)\r
 491     | Syntax.ShortSpecifier (_, base_pref, cl_spec, subs, cl_modif, _) ->\r
 492         let cpnt_type =\r
 493           resolve_type_composition ctx base_pref cl_spec subs cl_modif in\r
 494         ComponentType cpnt_type\r
 495     | Syntax.EnumerationSpecifier (idt, enum_comp, _) ->\r
 496         let enum_type = resolve_enumeration_composition ctx enum_comp in\r
 497         PredefinedType enum_type\r
 498 \r
 499 and resolve_type_composition ctx base_pref cl_spec subs cl_modif =\r
 500   let base_pref' = type_prefix base_pref\r
 501   and base_type = lazy (resolve_expression ctx cl_spec)\r
 502   and dims = lazy (resolve_dimensions ctx subs) in\r
 503   let cpnt_type = lazy (component_type ctx base_pref' base_type dims) in\r
 504   let cl_modif' = lazy (resolve_type_modification ctx cpnt_type cl_modif) in\r
 505   {\r
 506     described_type = lazy (modified_described_type ctx cpnt_type cl_modif');\r
 507     base_type = base_type;\r
 508     type_dimensions = dims;\r
 509     type_modification = cl_modif'\r
 510   }\r
 511 \r
 512 and resolve_enumeration_composition ctx enum_comp =\r
 513   let resolve_enumeration_literal enum_lit ids =\r
 514     match enum_lit.Syntax.nature with\r
 515       | Syntax.EnumerationLiteral (id, _) when List.mem id ids ->\r
 516           raise (CompilError\r
 517             {err_msg = ["_EnumTypeDefWithDuplicLit"; id];\r
 518              err_info = [];\r
 519              err_ctx = {ctx with location = enum_lit.Syntax.info}}) (*error*)\r
 520       | Syntax.EnumerationLiteral (id, _) -> id :: ids in\r
 521   match enum_comp.Syntax.nature with\r
 522     | Syntax.EnumList (Some enum_lits) ->\r
 523         let elts = List.fold_right resolve_enumeration_literal enum_lits [] in\r
 524         {\r
 525           Types.base_type = Types.EnumerationType elts;\r
 526                 attributes = ["start", false]\r
 527         }\r
 528     | Syntax.EnumList None ->\r
 529         raise (CompilError\r
 530           {err_msg = ["_UnspecifiedEnumLits"];\r
 531            err_info = [];\r
 532            err_ctx = {ctx with location = enum_comp.Syntax.info}}) (*error*)\r
 533     | Syntax.EnumColon ->\r
 534         raise (CompilError\r
 535           {err_msg = ["_UnspecifiedEnumLits"];\r
 536            err_info = [];\r
 537            err_ctx = {ctx with location = enum_comp.Syntax.info}}) (*error*)\r
 538 \r
 539 and resolve_class_specification ctx encap part kind cl_spec =\r
 540   let ctx = {ctx with location = cl_spec.Syntax.info} in\r
 541   let resolve_specifier encap' cl_def =\r
 542     let ctx' = {ctx with context_nature = ClassContext cl_def} in\r
 543     resolve_class_specifier ctx ctx' encap cl_spec in\r
 544   let rec cl_def =\r
 545     {\r
 546       class_type = lazy (class_specifier_type ctx part kind cl_def cl_spec);\r
 547       enclosing_class = enclosing_class ctx;\r
 548       encapsulated = encap;\r
 549       description = lazy (resolve_specifier encap cl_def)\r
 550     } in\r
 551   Class cl_def\r
 552 \r
 553 and enclosing_class ctx = match ctx.context_nature with\r
 554   | ToplevelContext -> None\r
 555   | ClassContext cl_def -> Some cl_def\r
 556   | SubscriptContext (ctx, _, _, _) |\r
 557     ForContext (ctx, _, _) -> enclosing_class ctx\r
 558 \r
 559 and bool_of_encapsulated = function\r
 560   | None -> false\r
 561   | Some Syntax.Encapsulated -> true\r
 562 \r
 563 and resolve_class_specifier ctx ctx' encap cl_spec =\r
 564   let ctx = {ctx with location = cl_spec.Syntax.info}\r
 565   and ctx' = {ctx' with location = cl_spec.Syntax.info} in\r
 566   match cl_spec.Syntax.nature with\r
 567     | Syntax.LongSpecifier (_, _, comp) ->\r
 568         LongDescription (resolve_composition ctx ctx' comp)\r
 569     | Syntax.ShortSpecifier _ when encap ->\r
 570         raise (CompilError\r
 571           {err_msg = ["_EncapsulatedCannotBeAppliedTo"; "_ShortClassDef"];\r
 572            err_info = [];\r
 573            err_ctx = ctx}) (*error*)\r
 574     | Syntax.ShortSpecifier (_, base_pref, cl_spec, subs, cl_modif, _) ->\r
 575         let short_desc =\r
 576           resolve_short_specifier ctx base_pref cl_spec subs cl_modif in\r
 577         ShortDescription short_desc\r
 578     | Syntax.ExtensionSpecifier _ when encap ->\r
 579         raise (CompilError\r
 580           {err_msg = ["_EncapsulatedCannotBeAppliedTo"; "_ClassDefByExtension"];\r
 581            err_info = [];\r
 582            err_ctx = ctx}) (*error*)\r
 583     | Syntax.ExtensionSpecifier (id , cl_modif, _, comp) ->\r
 584         let long_desc =\r
 585           resolve_extension_composition ctx ctx' id cl_modif comp in\r
 586         LongDescription long_desc\r
 587     | Syntax.EnumerationSpecifier _ ->\r
 588         raise (CompilError\r
 589           {err_msg = ["_InvalidUseOfEnumKeyword"];\r
 590            err_info = [];\r
 591            err_ctx = ctx}) (*error*)\r
 592 \r
 593 and resolve_short_specifier ctx base_pref cl_spec subs cl_modif =\r
 594   let ctx = {ctx with location = cl_spec.Syntax.info} in\r
 595   match base_pref.Syntax.nature, subs with\r
 596     | Syntax.TypePrefix (None, None, None), None ->\r
 597         resolve_modified_class ctx ctx cl_spec cl_modif\r
 598     | (Syntax.TypePrefix (Some _, _, _) | Syntax.TypePrefix (_, Some _, _) |\r
 599        Syntax.TypePrefix (_, _, Some _)), _ ->\r
 600         raise (CompilError\r
 601           {err_msg = ["_UseOfTypePrefixInShortClassDef"];\r
 602            err_info =\r
 603              [("_TypePrefix", Syntax.string_of_base_prefix base_pref)];\r
 604            err_ctx = {ctx with location = base_pref.Syntax.info}}) (*error*)\r
 605     | Syntax.TypePrefix (None, None, None), Some subs ->\r
 606         raise (CompilError\r
 607           {err_msg = ["_UseOfSubsInShortClassDef"];\r
 608            err_info = [];\r
 609            err_ctx = {ctx with location = subs.Syntax.info}}) (*error*)\r
 610 \r
 611 and resolve_extension_composition ctx ctx' id cl_modif comp =\r
 612   raise (CompilError\r
 613     {err_msg = ["_NotYetImplemented"; "_ClassExtendsDef"];\r
 614      err_info = [];\r
 615      err_ctx = ctx})\r
 616 \r
 617 and resolve_composition ctx ctx' comp = match comp.Syntax.nature with\r
 618   | Syntax.Composition (elts, other_elts, extern) ->\r
 619       {\r
 620         class_annotations = lazy (resolve_class_annotations ctx' elts other_elts);\r
 621         imports = resolve_imports ctx' elts other_elts;\r
 622         extensions = resolve_extensions ctx ctx' elts other_elts;\r
 623         named_elements = resolve_named_elements ctx' elts other_elts;\r
 624         unnamed_elements = lazy (resolve_unnamed_elements ctx' other_elts);\r
 625         external_call = lazy (resolve_external_call ctx' extern)\r
 626       }\r
 627 \r
 628 and resolve_external_call ctx extern =\r
 629   let resolve_external_call' extern' = match extern'.Syntax.nature with\r
 630     | Syntax.External (Some id, None, _, _) ->\r
 631         { nature = PrimitiveCall id; info = extern' }\r
 632     | Syntax.External (Some lang, Some extern_call, _, _) ->\r
 633         raise (CompilError\r
 634           {err_msg = ["_NotYetImplemented"; "_ExternalProcedureCall"];\r
 635            err_info = [];\r
 636            err_ctx =\r
 637               {ctx with location = extern'.Syntax.info}}) (*error*)\r
 638     | Syntax.External (None, _, _, _) ->\r
 639         { nature = PrimitiveCall "C"; info = extern' } in\r
 640         (*raise (CompilError\r
 641           {err_msg = ["_UnspecifiedExtCallLang"];\r
 642            err_info = [];\r
 643            err_ctx =\r
 644               {ctx with location = extern'.Syntax.info}}) (*error*) in*)\r
 645   match extern with\r
 646     | None -> None\r
 647     | Some extern' -> Some (resolve_external_call' extern')\r
 648 \r
 649 and resolve_class_annotations ctx elts other_elts =\r
 650   let add_class_annotation vis elt anns = match vis, elt.Syntax.nature with\r
 651     | _, Syntax.ClassAnnotation ann ->\r
 652         begin match resolve_class_annotation ctx ann with\r
 653           | [] -> anns\r
 654           | anns' -> anns' @ anns\r
 655         end\r
 656     | _, (Syntax.ImportClause _ | Syntax.ExtendsClause _ |\r
 657       Syntax.ElementDefinition _) -> anns in\r
 658   resolve_elements add_class_annotation elts other_elts\r
 659 \r
 660 and resolve_imports ctx elts other_elts =\r
 661   let add_import vis elt imps = match vis, elt.Syntax.nature with\r
 662     | _, Syntax.ImportClause (imp_clause, _) ->\r
 663         resolve_import_clause ctx imp_clause :: imps\r
 664     | _, (Syntax.ClassAnnotation _ | Syntax.ExtendsClause _ |\r
 665       Syntax.ElementDefinition _) -> imps in\r
 666   resolve_elements add_import elts other_elts\r
 667 \r
 668 and resolve_extensions ctx ctx' elts other_elts =\r
 669   let add_extension vis elt exts = match vis, elt.Syntax.nature with\r
 670     | Public, Syntax.ExtendsClause (ext_clause, _) ->\r
 671         (Public, resolve_extends_clause ctx ctx' ext_clause) :: exts\r
 672     | Protected, Syntax.ExtendsClause (ext_clause, _) ->\r
 673         (Protected, resolve_extends_clause ctx ctx' ext_clause) :: exts\r
 674     | _, (Syntax.ClassAnnotation _ | Syntax.ImportClause _ |\r
 675       Syntax.ElementDefinition _) -> exts in\r
 676   resolve_elements add_extension elts other_elts\r
 677 \r
 678 and resolve_named_elements ctx elts other_elts =\r
 679   let add_named_element (id, elt_desc) elts =\r
 680     match List.mem_assoc id elts with\r
 681     | true ->\r
 682         raise (CompilError\r
 683           {err_msg = ["_DuplicateDeclarationOfElement"; id];\r
 684            err_info = [];\r
 685            err_ctx = ctx}) (*error*)\r
 686     | false -> (id, elt_desc) :: elts in\r
 687   let add_named_elements vis elt elts = match vis, elt.Syntax.nature with\r
 688     | Public,\r
 689       Syntax.ElementDefinition (redecl, final, dyn_scope, elt_def, _) ->\r
 690         let elts' =\r
 691           resolve_element_definition ctx false redecl final dyn_scope elt_def in\r
 692         List.fold_right add_named_element elts' elts\r
 693     | Protected,\r
 694       Syntax.ElementDefinition (redecl, final, dyn_scope, elt_def, _) ->\r
 695         let elts' =\r
 696           resolve_element_definition ctx true redecl final dyn_scope elt_def in\r
 697         List.fold_right add_named_element elts' elts\r
 698     | _, (Syntax.ClassAnnotation _ | Syntax.ImportClause _ |\r
 699       Syntax.ExtendsClause _) -> elts in\r
 700   resolve_elements add_named_elements elts other_elts\r
 701 \r
 702 and resolve_class_annotation ctx ann =\r
 703   let rec resolve_class_annotation' cl_modif =\r
 704     let add_annotation_information arg acc = match arg.Syntax.nature with\r
 705       | Syntax.ElementModification (\r
 706           None,\r
 707           None,\r
 708           { Syntax.nature = Syntax.Identifier "Imagine" },\r
 709           Some\r
 710             {\r
 711               Syntax.nature =\r
 712                 Syntax.Modification (\r
 713                   {\r
 714                     Syntax.nature =\r
 715                       Syntax.ClassModification\r
 716                         [\r
 717                           {\r
 718                             Syntax.nature =\r
 719                               Syntax.ElementModification (\r
 720                                 None,\r
 721                                 None,\r
 722                                 {\r
 723                                   Syntax.nature = Syntax.Identifier "AMESim"\r
 724                                 },\r
 725                                 Some\r
 726                                   {\r
 727                                     Syntax.nature =\r
 728                                       Syntax.Modification (cl_modif, None)\r
 729                                   },\r
 730                                 [])\r
 731                           }\r
 732                         ]\r
 733                   },\r
 734                   None)\r
 735             },\r
 736           []) -> add_amesim_annotations ctx cl_modif acc\r
 737       | Syntax.ElementModification _ | Syntax.ElementRedeclaration _ ->\r
 738           (UnknownAnnotation (lazy cl_modif)) :: acc in\r
 739     match cl_modif.Syntax.nature with\r
 740     | Syntax.ClassModification args ->\r
 741         List.fold_right add_annotation_information args [] in\r
 742   match ann.Syntax.nature with\r
 743   | Syntax.Annotation cl_modif -> resolve_class_annotation' cl_modif\r
 744 \r
 745 and add_amesim_annotations ctx cl_modif acc =\r
 746   let add_inverse_declarations cl_modif =\r
 747     let add_inverse_declaration arg acc =\r
 748       let add_inverse_declaration' expr modif =\r
 749         match expr.Syntax.nature, modif.Syntax.nature with\r
 750         | Syntax.IndexedAccess (\r
 751             { Syntax.nature = Syntax.Identifier "inverse" }, _),\r
 752           Syntax.Eq\r
 753             {\r
 754               Syntax.nature =\r
 755                 Syntax.FunctionCall (expr, Some fun_args)\r
 756             } -> (resolve_inverse_declaration ctx expr fun_args) :: acc\r
 757         | _ ->\r
 758             raise (CompilError\r
 759               {err_msg = ["_InvalidAnnOfInvFunc"; "_InvalidModifExpr"];\r
 760                err_info = [];\r
 761                err_ctx =\r
 762                  {ctx with location = expr.Syntax.info}}) (*error*) in\r
 763       match arg.Syntax.nature with\r
 764       | Syntax.ElementModification (Some _, _, _, _, _) ->\r
 765           raise (CompilError\r
 766             {err_msg = ["_InvalidAnnOfInvFunc"; "_UseOfEachKeywordNotAllowed"];\r
 767              err_info = [];\r
 768              err_ctx = {ctx with location = arg.Syntax.info}}) (*error*)\r
 769       | Syntax.ElementModification (None, Some _, _, _, _) ->\r
 770           raise (CompilError\r
 771             {err_msg = ["_InvalidAnnOfInvFunc"; "_UseOfFinalKeywordNotAllowed"];\r
 772              err_info = [];\r
 773              err_ctx = {ctx with location = arg.Syntax.info}}) (*error*)\r
 774       | Syntax.ElementModification (None, None, _, None, _) ->\r
 775           raise (CompilError\r
 776             {err_msg = ["_InvalidAnnOfInvFunc"; "_UnspecifiedModification"];\r
 777              err_info = [];\r
 778              err_ctx = {ctx with location = arg.Syntax.info}}) (*error*)\r
 779       | Syntax.ElementModification (None, None, expr, Some modif, _) ->\r
 780           add_inverse_declaration' expr modif\r
 781       | Syntax.ElementRedeclaration _ ->\r
 782           raise (CompilError\r
 783             {err_msg = ["_InvalidAnnOfInvFunc"; "_RedeclarationNotAllowed"];\r
 784              err_info = [];\r
 785              err_ctx = {ctx with location = arg.Syntax.info}}) (*error*) in\r
 786     match cl_modif.Syntax.nature with\r
 787     | Syntax.ClassModification args ->\r
 788         List.fold_right add_inverse_declaration args acc in\r
 789   match cl_modif.Syntax.nature with\r
 790   | Syntax.ClassModification\r
 791       [\r
 792         {\r
 793           Syntax.nature =\r
 794             Syntax.ElementModification (\r
 795               None,\r
 796               None,\r
 797               {\r
 798                 Syntax.nature = Syntax.Identifier "InverseFunctions"\r
 799               },\r
 800               Some\r
 801                 {\r
 802                   Syntax.nature =\r
 803                     Syntax.Modification (cl_modif, None)\r
 804                 },\r
 805                 [])\r
 806         }\r
 807       ] -> add_inverse_declarations cl_modif\r
 808   | Syntax.ClassModification _ -> acc\r
 809 \r
 810 and resolve_inverse_declaration ctx expr fun_args =\r
 811   let inverse_function_arguments expr' fun_args =\r
 812     let map_function_arguments named_args =\r
 813       let map_function_argument arg =\r
 814         match arg.Syntax.nature with\r
 815         | Syntax.NamedArgument (id, expr)\r
 816           when List.mem_assoc id named_args ->\r
 817             let expr' = resolve_expression ctx expr in\r
 818             begin match expr'.nature with\r
 819               | LocalIdentifier (0, id') -> id, id'\r
 820               | _ ->\r
 821                   raise (CompilError\r
 822                     {err_msg = ["_InvalidAnnOfInvFunc";\r
 823                                 "_InvalidFuncArgModif"];\r
 824                      err_info = [];\r
 825                      err_ctx =\r
 826                         {ctx with\r
 827                           location = expr.Syntax.info}}) (*error*)\r
 828             end\r
 829         | Syntax.NamedArgument (id, expr) ->\r
 830             raise (CompilError\r
 831               {err_msg = ["_InvalidAnnOfInvFunc";\r
 832                           "_UnknownArgName"; id];\r
 833                err_info = [];\r
 834                err_ctx =\r
 835                  {ctx with location = arg.Syntax.info}}) (*error*)\r
 836         | Syntax.Argument _ ->\r
 837             raise (CompilError\r
 838               {err_msg = ["_InvalidAnnOfInvFunc";\r
 839                           "_CannotUseUnnamedFuncArg"];\r
 840                err_info = [];\r
 841                err_ctx =\r
 842                  {ctx with location = arg.Syntax.info}}) (*error*) in\r
 843       match fun_args.Syntax.nature with\r
 844       | Syntax.ArgumentList args -> List.map map_function_argument args\r
 845       | Syntax.Reduction _ ->\r
 846           raise (CompilError\r
 847             {err_msg = ["_InvalidAnnOfInvFunc";\r
 848                         "_FuncArgReductionNotAllowed"];\r
 849              err_info = [];\r
 850              err_ctx =\r
 851                {ctx with location = fun_args.Syntax.info}}) (*error*) in\r
 852     let inverse_function_arguments' cl_type =\r
 853       match cl_type.Types.partial, evaluate cl_type.Types.kind with\r
 854       | true, _ ->\r
 855           raise (CompilError\r
 856             {err_msg = ["_InvalidAnnOfInvFunc";\r
 857                         "_UseOfPartialClassElement"];\r
 858              err_info = [("_ElementFound",\r
 859                           Syntax.string_of_expression expr)];\r
 860              err_ctx =\r
 861                {ctx with location = expr.Syntax.info}}) (*error*)\r
 862       | false, Types.Function ->\r
 863           map_function_arguments cl_type.Types.named_elements\r
 864       | _, kind ->\r
 865           raise (CompilError\r
 866             {err_msg = ["_InvalidAnnOfInvFunc";\r
 867                         "_InvalidTypeOfFuncCallExpr"];\r
 868              err_info = [("_ExpectedType", "_Function");\r
 869                          ("_TypeFound", Types.string_of_kind kind)];\r
 870              err_ctx =\r
 871                {ctx with location = expr.Syntax.info}}) (*error*) in\r
 872     let elt_nat = expr'.info.type_description in\r
 873     match elt_nat with\r
 874     | Types.ClassElement cl_spec ->\r
 875         let cl_spec = evaluate cl_spec in\r
 876         begin match cl_spec with\r
 877           | Types.ClassType cl_type ->\r
 878               inverse_function_arguments' cl_type\r
 879           | _ ->\r
 880               raise (CompilError\r
 881                 {err_msg = ["_InvalidAnnOfInvFunc";\r
 882                             "_InvalidTypeOfFuncCallExpr"];\r
 883                  err_info =\r
 884                    [("_ExpectedType", "_ClassType");\r
 885                     ("_TypeFound",\r
 886                      Types.string_of_class_specifier cl_spec)];\r
 887                  err_ctx =\r
 888                    {ctx with location = expr.Syntax.info}}) (*error*)\r
 889         end\r
 890     | Types.ComponentTypeElement _ ->\r
 891         raise (CompilError\r
 892           {err_msg = ["_InvalidAnnOfInvFunc";\r
 893                       "_InvalidTypeOfFuncCallExpr"];\r
 894            err_info = [("_ExpectedType", "_ClassElement");\r
 895                        ("_TypeFound", "_ComponentTypeElement")];\r
 896            err_ctx =\r
 897              {ctx with location = expr.Syntax.info}}) (*error*)\r
 898     | Types.PredefinedTypeElement _ ->\r
 899         raise (CompilError\r
 900           {err_msg = ["_InvalidAnnOfInvFunc";\r
 901                       "_InvalidTypeOfFuncCallExpr"];\r
 902            err_info = [("_ExpectedType", "_ClassElement");\r
 903                        ("_TypeFound", "_PredefinedTypeElement")];\r
 904            err_ctx =\r
 905              {ctx with location = expr.Syntax.info}}) (*error*)\r
 906     | Types.ComponentElement _ ->\r
 907         raise (CompilError\r
 908           {err_msg = ["_InvalidAnnOfInvFunc";\r
 909                       "_InvalidTypeOfFuncCallExpr"];\r
 910            err_info = [("_ExpectedType", "_ClassElement");\r
 911                        ("_TypeFound", "_ComponentElement")];\r
 912            err_ctx =\r
 913              {ctx with location = expr.Syntax.info}}) (*error*) in\r
 914   let expr' = resolve_expression ctx expr in\r
 915   match expr'.nature with\r
 916   | ToplevelIdentifier _ | LocalIdentifier _ ->\r
 917       InverseFunction\r
 918         (lazy\r
 919           {\r
 920             function_class = expr';\r
 921             arguments = inverse_function_arguments expr' fun_args\r
 922           })\r
 923   | _ ->\r
 924       raise (CompilError\r
 925         {err_msg = ["_InvalidAnnOfInvFunc"; "_InvalidFuncCallExpr"];\r
 926          err_info = [];\r
 927          err_ctx =\r
 928            {ctx with location = expr.Syntax.info}}) (*error*)\r
 929 \r
 930 (*and resolve_inverse_function_annotation ctx ann =\r
 931   let rec resolve_class_annotation' cl_modif =\r
 932     let resolve_inverse_declaration expr fun_args =\r
 933       let inverse_function_arguments expr' fun_args =\r
 934         let map_function_arguments named_args =\r
 935           let map_function_argument arg =\r
 936             match arg.Syntax.nature with\r
 937               | Syntax.NamedArgument (id, expr)\r
 938                 when List.mem_assoc id named_args ->\r
 939                   let expr' = resolve_expression ctx expr in\r
 940                   begin match expr'.nature with\r
 941                     | LocalIdentifier (0, id') -> id, id'\r
 942                     | _ ->\r
 943                         raise (CompilError\r
 944                           {err_msg = ["_InvalidAnnOfInvFunc";\r
 945                                       "_InvalidFuncArgModif"];\r
 946                            err_info = [];\r
 947                            err_ctx =\r
 948                               {ctx with\r
 949                                 location = expr.Syntax.info}}) (*error*)\r
 950                   end\r
 951               | Syntax.NamedArgument (id, expr) ->\r
 952                   raise (CompilError\r
 953                     {err_msg = ["_InvalidAnnOfInvFunc";\r
 954                                 "_UnknownArgName"; id];\r
 955                      err_info = [];\r
 956                      err_ctx =\r
 957                        {ctx with location = arg.Syntax.info}}) (*error*)\r
 958               | Syntax.Argument _ ->\r
 959                   raise (CompilError\r
 960                     {err_msg = ["_InvalidAnnOfInvFunc";\r
 961                                 "_CannotUseUnnamedFuncArg"];\r
 962                      err_info = [];\r
 963                      err_ctx =\r
 964                         {ctx with location = arg.Syntax.info}}) (*error*) in\r
 965           match fun_args.Syntax.nature with\r
 966             | Syntax.ArgumentList args -> List.map map_function_argument args\r
 967             | Syntax.Reduction _ ->\r
 968                 raise (CompilError\r
 969                   {err_msg = ["_InvalidAnnOfInvFunc";\r
 970                               "_FuncArgReductionNotAllowed"];\r
 971                    err_info = [];\r
 972                    err_ctx =\r
 973                       {ctx with location = fun_args.Syntax.info}}) (*error*) in\r
 974         let inverse_function_arguments' cl_type =\r
 975           match cl_type.Types.partial, evaluate cl_type.Types.kind with\r
 976             | true, _ ->\r
 977                 raise (CompilError\r
 978                   {err_msg = ["_InvalidAnnOfInvFunc";\r
 979                               "_UseOfPartialClassElement"];\r
 980                    err_info = [("_ElementFound",\r
 981                                 Syntax.string_of_expression expr)];\r
 982                    err_ctx =\r
 983                       {ctx with location = expr.Syntax.info}}) (*error*)\r
 984             | false, Types.Function ->\r
 985                 map_function_arguments cl_type.Types.named_elements\r
 986             | _, kind ->\r
 987                 raise (CompilError\r
 988                   {err_msg = ["_InvalidAnnOfInvFunc";\r
 989                               "_InvalidTypeOfFuncCallExpr"];\r
 990                    err_info = [("_ExpectedType", "_Function");\r
 991                                ("_TypeFound", Types.string_of_kind kind)];\r
 992                    err_ctx =\r
 993                      {ctx with location = expr.Syntax.info}}) (*error*) in\r
 994         let elt_nat = expr'.info.type_description in\r
 995         match elt_nat with\r
 996           | Types.ClassElement cl_spec ->\r
 997               let cl_spec = evaluate cl_spec in\r
 998               begin match cl_spec with\r
 999                 | Types.ClassType cl_type ->\r
1000                     inverse_function_arguments' cl_type\r
1001                 | _ ->\r
1002                     raise (CompilError\r
1003                       {err_msg = ["_InvalidAnnOfInvFunc";\r
1004                                   "_InvalidTypeOfFuncCallExpr"];\r
1005                        err_info =\r
1006                          [("_ExpectedType", "_ClassType");\r
1007                           ("_TypeFound",\r
1008                            Types.string_of_class_specifier cl_spec)];\r
1009                        err_ctx =\r
1010                          {ctx with location = expr.Syntax.info}}) (*error*)\r
1011               end\r
1012           | Types.ComponentTypeElement _ ->\r
1013               raise (CompilError\r
1014                 {err_msg = ["_InvalidAnnOfInvFunc";\r
1015                             "_InvalidTypeOfFuncCallExpr"];\r
1016                  err_info = [("_ExpectedType", "_ClassElement");\r
1017                              ("_TypeFound", "_ComponentTypeElement")];\r
1018                  err_ctx =\r
1019                    {ctx with location = expr.Syntax.info}}) (*error*)\r
1020           | Types.PredefinedTypeElement _ ->\r
1021               raise (CompilError\r
1022                 {err_msg = ["_InvalidAnnOfInvFunc";\r
1023                             "_InvalidTypeOfFuncCallExpr"];\r
1024                  err_info = [("_ExpectedType", "_ClassElement");\r
1025                              ("_TypeFound", "_PredefinedTypeElement")];\r
1026                  err_ctx =\r
1027                    {ctx with location = expr.Syntax.info}}) (*error*)\r
1028           | Types.ComponentElement _ ->\r
1029               raise (CompilError\r
1030                 {err_msg = ["_InvalidAnnOfInvFunc";\r
1031                             "_InvalidTypeOfFuncCallExpr"];\r
1032                  err_info = [("_ExpectedType", "_ClassElement");\r
1033                              ("_TypeFound", "_ComponentElement")];\r
1034                  err_ctx =\r
1035                    {ctx with location = expr.Syntax.info}}) (*error*) in\r
1036       let expr' = resolve_expression ctx expr in\r
1037       match expr'.nature with\r
1038         | ToplevelIdentifier _ | LocalIdentifier _ ->\r
1039             {\r
1040               function_class = expr';\r
1041               arguments =\r
1042                 inverse_function_arguments expr' fun_args\r
1043             }\r
1044         | _ ->\r
1045             raise (CompilError\r
1046               {err_msg = ["_InvalidAnnOfInvFunc"; "_InvalidFuncCallExpr"];\r
1047                err_info = [];\r
1048                err_ctx =\r
1049                  {ctx with location = expr.Syntax.info}}) (*error*) in\r
1050     let add_inverse_declaration arg acc =\r
1051       let add_inverse_declaration' expr modif =\r
1052         match expr.Syntax.nature, modif.Syntax.nature with\r
1053         | Syntax.IndexedAccess (\r
1054             { Syntax.nature = Syntax.Identifier "inverse" }, _),\r
1055           Syntax.Eq\r
1056             {\r
1057               Syntax.nature =\r
1058                 Syntax.FunctionCall (expr, Some fun_args)\r
1059             } -> lazy (resolve_inverse_declaration expr fun_args) :: acc\r
1060         | _ ->\r
1061             raise (CompilError\r
1062               {err_msg = ["_InvalidAnnOfInvFunc"; "_InvalidModifExpr"];\r
1063                err_info = [];\r
1064                err_ctx =\r
1065                  {ctx with location = expr.Syntax.info}}) (*error*) in\r
1066       match arg.Syntax.nature with\r
1067       | Syntax.ElementModification (Some _, _, _, _, _) ->\r
1068           raise (CompilError\r
1069             {err_msg = ["_InvalidAnnOfInvFunc"; "_UseOfEachKeywordNotAllowed"];\r
1070              err_info = [];\r
1071              err_ctx = {ctx with location = arg.Syntax.info}}) (*error*)\r
1072       | Syntax.ElementModification (None, Some _, _, _, _) ->\r
1073           raise (CompilError\r
1074             {err_msg = ["_InvalidAnnOfInvFunc"; "_UseOfFinalKeywordNotAllowed"];\r
1075              err_info = [];\r
1076              err_ctx = {ctx with location = arg.Syntax.info}}) (*error*)\r
1077       | Syntax.ElementModification (None, None, _, None, _) ->\r
1078           raise (CompilError\r
1079             {err_msg = ["_InvalidAnnOfInvFunc"; "_UnspecifiedModification"];\r
1080              err_info = [];\r
1081              err_ctx = {ctx with location = arg.Syntax.info}}) (*error*)\r
1082       | Syntax.ElementModification (None, None, expr, Some modif, _) ->\r
1083           add_inverse_declaration' expr modif\r
1084       | Syntax.ElementRedeclaration _ ->\r
1085           raise (CompilError\r
1086             {err_msg = ["_InvalidAnnOfInvFunc"; "_RedeclarationNotAllowed"];\r
1087              err_info = [];\r
1088              err_ctx = {ctx with location = arg.Syntax.info}}) (*error*) in\r
1089     let add_inverse_declarations cl_modif acc =\r
1090       let add_inverse_declarations' cl_modif = \r
1091         match cl_modif.Syntax.nature with\r
1092         | Syntax.ClassModification args ->\r
1093             List.fold_right add_inverse_declaration args acc in\r
1094       match cl_modif.Syntax.nature with\r
1095       | Syntax.ClassModification\r
1096           [\r
1097             {\r
1098               Syntax.nature =\r
1099                 Syntax.ElementModification (\r
1100                   None,\r
1101                   None,\r
1102                   {\r
1103                     Syntax.nature = Syntax.Identifier "InverseFunctions"\r
1104                   },\r
1105                   Some\r
1106                     {\r
1107                       Syntax.nature =\r
1108                         Syntax.Modification (cl_modif, None)\r
1109                     },\r
1110                     [])\r
1111             }\r
1112           ] -> add_inverse_declarations' cl_modif\r
1113       | Syntax.ClassModification _ -> acc in\r
1114     let add_annotation_information arg acc = match arg.Syntax.nature with\r
1115       | Syntax.ElementModification (\r
1116           None,\r
1117           None,\r
1118           { Syntax.nature = Syntax.Identifier "Imagine" },\r
1119           Some\r
1120             {\r
1121               Syntax.nature =\r
1122                 Syntax.Modification (\r
1123                   {\r
1124                     Syntax.nature =\r
1125                       Syntax.ClassModification\r
1126                         [\r
1127                           {\r
1128                             Syntax.nature =\r
1129                               Syntax.ElementModification (\r
1130                                 None,\r
1131                                 None,\r
1132                                 {\r
1133                                   Syntax.nature = Syntax.Identifier "AMESim"\r
1134                                 },\r
1135                                 Some\r
1136                                   {\r
1137                                     Syntax.nature =\r
1138                                       Syntax.Modification (cl_modif, None)\r
1139                                   },\r
1140                                 [])\r
1141                           }\r
1142                         ]\r
1143                   },\r
1144                   None)\r
1145             },\r
1146           []) -> add_inverse_declarations cl_modif acc\r
1147       | Syntax.ElementModification _ | Syntax.ElementRedeclaration _ -> acc in\r
1148     match cl_modif.Syntax.nature with\r
1149     | Syntax.ClassModification args ->\r
1150         List.fold_right add_annotation_information args [] in\r
1151   match ann.Syntax.nature with\r
1152   | Syntax.Annotation cl_modif -> resolve_class_annotation' cl_modif*)\r
1153 \r
1154 and resolve_import_clause ctx imp_clause =\r
1155   let ctx = {ctx with location = imp_clause.Syntax.info} in\r
1156   raise (CompilError\r
1157     {err_msg = ["_NotYetImplemented"; "_ImportClause"];\r
1158      err_info = [("_Expr", Syntax.string_of_import imp_clause)];\r
1159      err_ctx = ctx})\r
1160 \r
1161 and resolve_extends_clause ctx ctx' ext_clause =\r
1162   match ext_clause.Syntax.nature with\r
1163     | Syntax.Extends (cl_spec, cl_modif, _) ->\r
1164         resolve_extension ctx ctx' cl_spec cl_modif\r
1165 \r
1166 and resolve_extension ctx ctx' cl_spec cl_modif =\r
1167   let ctx' = {ctx' with location = cl_spec.Syntax.info} in\r
1168   let base_class = lazy (resolve_extension_expression ctx cl_spec) in\r
1169   let cl_spec' = lazy (base_class_type ctx' cl_spec base_class) in\r
1170   let cl_modif' =\r
1171     lazy (resolve_class_modification_option ctx' cl_spec' cl_modif) in\r
1172   {\r
1173     modified_class_type = lazy (modified_class_type ctx' cl_spec' cl_modif');\r
1174     base_class = base_class;\r
1175     class_modification = cl_modif'\r
1176   }\r
1177 \r
1178 and resolve_extension_expression ctx cl_spec =\r
1179   let rec modify_resolved_expression expr = match expr.nature with\r
1180     | LocalIdentifier (level, id) ->\r
1181         { expr with nature = LocalIdentifier (level + 1, id) }\r
1182     | FieldAccess (expr', id) ->\r
1183         { expr with\r
1184           nature = FieldAccess (modify_resolved_expression expr', id)\r
1185         }\r
1186     | IndexedAccess (expr', exprs') ->\r
1187         let exprs' = List.map modify_resolved_expression exprs' in\r
1188         { expr with\r
1189           nature = IndexedAccess (modify_resolved_expression expr', exprs')\r
1190         }\r
1191     | ToplevelIdentifier _ -> expr\r
1192     | _ ->\r
1193         raise (CompilError\r
1194           {err_msg = ["_InvalidExtensionDef"];\r
1195            err_info = [];\r
1196            err_ctx = ctx}) (*error*) in\r
1197   match ctx.context_nature with\r
1198     | ToplevelContext | ClassContext _ ->\r
1199         let base_class = resolve_expression ctx cl_spec in\r
1200         modify_resolved_expression base_class\r
1201     | SubscriptContext _ | ForContext _ ->\r
1202         raise (CompilError\r
1203           {err_msg = ["_InvalidExtensionDef"];\r
1204            err_info = [];\r
1205            err_ctx = ctx}) (*error*)\r
1206 \r
1207 and resolve_modified_class ctx ctx' cl_spec cl_modif =\r
1208   let ctx' = {ctx' with location = cl_spec.Syntax.info} in\r
1209   let base_class = lazy (resolve_expression ctx cl_spec) in\r
1210   let cl_spec' = lazy (base_class_type ctx' cl_spec base_class) in\r
1211   let cl_modif' =\r
1212     lazy (resolve_class_modification_option ctx' cl_spec' cl_modif) in\r
1213   {\r
1214     modified_class_type = lazy (modified_class_type ctx' cl_spec' cl_modif');\r
1215     base_class = base_class;\r
1216     class_modification = cl_modif'\r
1217   }\r
1218 \r
1219 and resolve_element_definition ctx protect redecl final dyn_scope elt_def =\r
1220   let repl = replaceable_attribute elt_def in\r
1221   let element_description (id, elt_nat, elt_loc) =\r
1222     let rec elt_desc =\r
1223       {\r
1224         element_type =\r
1225           lazy (element_type ctx protect final repl dyn_scope elt_desc);\r
1226         redeclare = bool_of_redeclare redecl;\r
1227         element_nature = elt_nat;\r
1228         element_location = elt_loc\r
1229       } in\r
1230     id, elt_desc in\r
1231   List.map element_description (declared_elements ctx elt_def)\r
1232 \r
1233 and replaceable_attribute elt_def = match elt_def.Syntax.nature with\r
1234   | Syntax.ClassDefinitionElement (repl, _, _) |\r
1235     Syntax.ComponentClauseElement (repl, _, _) -> repl\r
1236 \r
1237 and bool_of_redeclare = function\r
1238   | None -> false\r
1239   | Some Syntax.Redeclare -> true\r
1240 \r
1241 and resolve_type_constraint ctx elt_def = match elt_def.Syntax.nature with\r
1242   | Syntax.ClassDefinitionElement (_, _, []) |\r
1243     Syntax.ComponentClauseElement (_, _, []) -> None\r
1244   | Syntax.ClassDefinitionElement (_, _, _ :: _) |\r
1245     Syntax.ComponentClauseElement (_, _, _ :: _) -> assert false\r
1246 \r
1247 and declared_elements ctx elt_def = match elt_def.Syntax.nature with\r
1248   | Syntax.ClassDefinitionElement (_, def, _) ->\r
1249       let s = class_definition_name def\r
1250       and elt_nat = resolve_definition ctx def\r
1251       and loc = match def.Syntax.nature with\r
1252         | Syntax.Definition (encap, part, kind, cl_spec) ->\r
1253             cl_spec.Syntax.info in\r
1254       [s, elt_nat, loc]\r
1255   | Syntax.ComponentClauseElement (_, cpnt_cl, _) ->\r
1256       resolve_component_clause ctx cpnt_cl\r
1257 \r
1258 and resolve_component_clause ctx cpnt_cl = match cpnt_cl.Syntax.nature with\r
1259   | Syntax.ComponentClause (type_pref, type_spec, subs, cpnt_decls) ->\r
1260       let type_pref' = type_prefix type_pref\r
1261       and type_spec' = lazy (resolve_expression ctx type_spec)\r
1262       and dims = lazy (resolve_dimensions ctx subs) in\r
1263       List.map\r
1264         (resolve_component_declaration ctx type_pref' type_spec' dims type_spec)\r
1265         cpnt_decls\r
1266 \r
1267 and type_prefix type_pref =\r
1268   let bool_of_flow = function\r
1269     | None -> false\r
1270     | Some Syntax.Flow -> true\r
1271   and variability_of_variability = function\r
1272     | None -> None\r
1273     | Some Syntax.Constant -> Some Types.Constant\r
1274     | Some Syntax.Parameter -> Some Types.Parameter\r
1275     | Some Syntax.Discrete -> Some Types.Discrete\r
1276   and causality_of_inout = function\r
1277     | None -> Types.Acausal\r
1278     | Some Syntax.Input -> Types.Input\r
1279     | Some Syntax.Output -> Types.Output in\r
1280   match type_pref.Syntax.nature with\r
1281     | Syntax.TypePrefix (flow, var, inout) ->\r
1282         bool_of_flow flow,\r
1283         variability_of_variability var,\r
1284         causality_of_inout inout\r
1285 \r
1286 and resolve_component_declaration\r
1287   ctx type_pref type_spec' dims type_spec cpnt_decl =\r
1288     let build_comment_string cmt = match cmt.Syntax.nature with\r
1289       | Syntax.Comment (ss, _) -> List.fold_right ( ^ ) ss "" in\r
1290     match cpnt_decl.Syntax.nature with\r
1291       | Syntax.ComponentDeclaration (decl, cmt) ->\r
1292           let cmt' = build_comment_string cmt in\r
1293           resolve_declaration ctx type_pref type_spec' dims decl cmt' type_spec\r
1294 \r
1295 and resolve_declaration ctx type_pref type_spec' dims decl cmt type_spec =\r
1296   let ctx = {ctx with location = decl.Syntax.info} in\r
1297   match decl.Syntax.nature with\r
1298     | Syntax.Declaration (id, subs, modif) ->\r
1299         let dims = lazy ((resolve_dimensions ctx subs) @ (evaluate dims)) in\r
1300         let cpnt_type = lazy (component_type ctx type_pref type_spec' dims) in\r
1301         let modif' =\r
1302           lazy (resolve_component_modification ctx cpnt_type modif) in\r
1303         let cpnt_desc =\r
1304           {\r
1305             component_type =\r
1306               lazy (modified_component_type ctx (evaluate cpnt_type) modif');\r
1307             type_specifier = type_spec';\r
1308             dimensions = dims;\r
1309             modification = modif';\r
1310             comment = cmt;\r
1311           } in\r
1312         (id, Component cpnt_desc, decl.Syntax.info)\r
1313 \r
1314 and resolve_dimensions ctx subs =\r
1315   let resolve_dimension sub = match sub.Syntax.nature with\r
1316     | Syntax.Colon -> Colon\r
1317     | Syntax.Subscript expr ->\r
1318         Expression (resolve_subscript_expression ctx expr) in\r
1319   let resolve_dimensions' = function\r
1320     | None -> []\r
1321     | Some { Syntax.nature = Syntax.Subscripts subs_elts } ->\r
1322         List.map resolve_dimension subs_elts in\r
1323   resolve_dimensions' subs\r
1324 \r
1325 and base_class_type ctx cl_spec base_class =\r
1326   match (evaluate base_class).info.type_description with\r
1327     | Types.ClassElement cl_spec -> evaluate cl_spec\r
1328     | Types.ComponentTypeElement _ ->\r
1329         raise (CompilError\r
1330           {err_msg = ["_CannotInheritFrom"; "_ComponentTypeElement"];\r
1331            err_info =\r
1332              [("_ElemFound", Syntax.string_of_expression cl_spec)];\r
1333            err_ctx = {ctx with location = cl_spec.Syntax.info}}) (*error*)\r
1334     | Types.PredefinedTypeElement _ ->\r
1335         raise (CompilError\r
1336           {err_msg = ["_CannotInheritFrom"; "_PredefinedTypeElement"];\r
1337            err_info =\r
1338              [("_ElemFound", Syntax.string_of_expression cl_spec)];\r
1339            err_ctx = {ctx with location = cl_spec.Syntax.info}}) (*error*)\r
1340     | Types.ComponentElement _ ->\r
1341         raise (CompilError\r
1342           {err_msg = ["_CannotInheritFrom"; "_ComponentElement"];\r
1343            err_info = [];\r
1344            err_ctx = {ctx with location = cl_spec.Syntax.info}}) (*error*)\r
1345 \r
1346 and component_type ctx (flow, var, inout) base_type dims =\r
1347   let base_type = evaluate base_type in\r
1348   let lower_variability var var' = match var, var' with\r
1349     | Some Types.Constant,\r
1350       (Types.Constant | Types.Parameter | Types.Discrete | Types.Continuous) ->\r
1351         Types.Constant\r
1352     | Some Types.Parameter,\r
1353       (Types.Parameter | Types.Discrete | Types.Continuous) -> Types.Parameter\r
1354     | Some Types.Discrete, (Types.Discrete | Types.Continuous) -> Types.Discrete\r
1355     | Some Types.Continuous, Types.Continuous -> Types.Continuous\r
1356     | None, _ -> var'\r
1357     | Some var, (Types.Constant | Types.Parameter | Types.Discrete) ->\r
1358         raise (CompilError\r
1359           {err_msg = ["_VariablityConflictsInCompDef"];\r
1360            err_info =\r
1361              [("_TypePrefix", Types.string_of_variability var);\r
1362               ("_TypeSpecifierVariability", Types.string_of_variability var')];\r
1363            err_ctx = ctx}) (*error*)\r
1364   and propagate_causality inout inout' = match inout, inout' with\r
1365     | Types.Acausal, (Types.Acausal | Types.Input | Types.Output) -> inout'\r
1366     | (Types.Input | Types.Output), Types.Acausal -> inout\r
1367     | Types.Input, Types.Input | Types.Output, Types.Output -> inout\r
1368     | Types.Input, Types.Output | Types.Output, Types.Input ->\r
1369         raise (CompilError\r
1370           {err_msg = ["_CausalityConflictsInCompDef"];\r
1371            err_info = [("_TypePrefix", Types.string_of_causality inout);\r
1372                        ("_TypeSpecifierCausality",\r
1373                         Types.string_of_causality inout')];\r
1374            err_ctx = ctx}) (*error*) in\r
1375   let predefined_type_variability predef = match predef with\r
1376     | { Types.base_type = Types.RealType } -> Types.Continuous\r
1377     | _ -> Types.Discrete in\r
1378   let rec class_specifier_variability cl_spec = match cl_spec with\r
1379     | Types.PredefinedType predef -> predefined_type_variability predef\r
1380     | Types.ClassType cl_type -> Types.Continuous\r
1381     | Types.ComponentType cpnt_type -> evaluate cpnt_type.Types.variability\r
1382     | Types.ArrayType (dim, cl_spec) -> class_specifier_variability cl_spec\r
1383     | Types.TupleType cl_specs -> assert false in\r
1384   match base_type.info.type_description with\r
1385     | Types.ComponentElement _ ->\r
1386         raise (CompilError\r
1387           {err_msg = ["class"; "_ElemExpected"];\r
1388            err_info = [("TypeFound", "_ComponentElement")];\r
1389            err_ctx = ctx}) (*error*)\r
1390     | Types.ClassElement cl_spec ->\r
1391         let cl_spec = evaluate cl_spec in\r
1392         let var' = class_specifier_variability cl_spec in\r
1393         let var' = lazy (lower_variability var var')\r
1394         and base_class = lazy (add_dimensions dims cl_spec) in\r
1395         component_element (lazy flow) var' (lazy inout) base_class\r
1396     | Types.ComponentTypeElement cpnt_type ->\r
1397         let flow' = lazy (flow || evaluate cpnt_type.Types.flow)\r
1398         and var' =\r
1399           lazy (lower_variability var (evaluate cpnt_type.Types.variability))\r
1400         and inout' =\r
1401           lazy (propagate_causality inout (evaluate cpnt_type.Types.causality))\r
1402         and base_class =\r
1403           lazy (add_dimensions dims (Types.ComponentType cpnt_type)) in\r
1404         component_element flow' var' inout' base_class\r
1405     | Types.PredefinedTypeElement predef ->\r
1406         let var' = predefined_type_variability predef in\r
1407         let var' = lazy (lower_variability var var')\r
1408         and base_class =\r
1409           lazy (add_dimensions dims (Types.PredefinedType predef)) in\r
1410         component_element (lazy flow) var' (lazy inout) base_class\r
1411 \r
1412 and add_dimensions dims cl_spec =\r
1413   let add_dimension dim cl_spec = match dim with\r
1414     | Expression { nature = Integer i } ->\r
1415         Types.ArrayType (Types.ConstantDimension i, cl_spec)\r
1416     | Expression _ -> Types.ArrayType (Types.ParameterDimension, cl_spec)\r
1417     | Colon -> Types.ArrayType (Types.DiscreteDimension, cl_spec) in\r
1418   List.fold_right add_dimension (evaluate dims) cl_spec\r
1419 \r
1420 and modified_described_type ctx cpnt_type cl_modif =\r
1421   let cpnt_type' = evaluate cpnt_type in\r
1422   let cl_spec = cpnt_type'.Types.base_class in\r
1423   { cpnt_type' with\r
1424     Types.base_class =\r
1425       lazy (modify_class_specifier ctx (evaluate cl_modif) cl_spec)\r
1426   }\r
1427 \r
1428 and modified_class_type ctx cl_spec cl_modif =\r
1429   let cl_spec' = modify_class_specifier ctx (evaluate cl_modif) cl_spec in\r
1430   match cl_spec' with\r
1431     | Types.ClassType cl_type -> cl_type\r
1432     | Types.PredefinedType _ | Types.ComponentType _ | Types.ArrayType _ |\r
1433       Types.TupleType _ ->\r
1434         raise (CompilError\r
1435           {err_msg = ["class"; "_ElemExpected"];\r
1436            err_info = [("TypeFound",\r
1437                         Types.string_of_class_specifier cl_spec')];\r
1438            err_ctx = ctx}) (*error*)\r
1439 \r
1440 and modified_component_type ctx cpnt_type modif =\r
1441   let modified_component_type' = function\r
1442     | Modification (cl_modif, _) -> modify_component_type ctx cl_modif cpnt_type\r
1443     | Assignment _ | Equality _ -> cpnt_type in\r
1444   match evaluate modif with\r
1445     | None -> cpnt_type\r
1446     | Some modif' -> modified_component_type' modif'\r
1447 \r
1448 (* We can abstract dimensions away since they have been already checked at *)\r
1449 (* modification resolution time.                                           *)\r
1450 and modify_class_specifier ctx cl_modif cl_spec =\r
1451   let rec modify_class_specifier' cl_spec' = match cl_spec' with\r
1452     | Types.PredefinedType predef ->\r
1453         Types.PredefinedType (modify_predefined_type ctx cl_modif predef)\r
1454     | Types.ClassType cl_type ->\r
1455         Types.ClassType (modify_class_type ctx cl_modif cl_type)\r
1456     | Types.ComponentType cpnt_type ->\r
1457         Types.ComponentType (modify_component_type ctx cl_modif cpnt_type)\r
1458     | Types.ArrayType (dim, cl_spec) ->\r
1459         Types.ArrayType (dim, modify_class_specifier' cl_spec)\r
1460     | Types.TupleType _ ->\r
1461         raise (CompilError\r
1462           {err_msg = ["_InvalidTypeOfClassSpec"];\r
1463            err_info = [("_TypeFound",\r
1464                         Types.string_of_class_specifier cl_spec')];\r
1465            err_ctx = ctx}) (*error*) in\r
1466   modify_class_specifier' (evaluate cl_spec)\r
1467 \r
1468 and modify_predefined_type ctx cl_modif predef =\r
1469   { predef with\r
1470     Types.attributes =\r
1471       modify_predefined_attributes ctx cl_modif predef.Types.attributes\r
1472   }\r
1473 \r
1474 and modify_predefined_attributes ctx cl_modif attrs =\r
1475   let apply_modifications ((id, final) as attr) = function\r
1476     | [] -> attr\r
1477     | [_] when final -> assert false (*error*)\r
1478     | [final', (Assignment _ | Equality _)] -> id, final'\r
1479     | _ :: _ -> assert false (*error*) in\r
1480   let modify_attribute ((id, _) as attr) =\r
1481     let modifs, elt_descs = partition_modifications cl_modif id in\r
1482     match modifs, elt_descs with\r
1483       | [], [] -> attr\r
1484       | _ :: _, [] -> apply_modifications attr modifs\r
1485       | [], _ :: _\r
1486       | _ :: _, _ :: _ ->\r
1487           raise (CompilError\r
1488             {err_msg = ["_RedeclarePredefTypeAttrib"; id];\r
1489              err_info = [];\r
1490              err_ctx = ctx}) (*error*) in\r
1491   List.map modify_attribute attrs\r
1492 \r
1493 and modify_class_type ctx cl_modif cl_type =\r
1494   let modify_named_element (id, elt_type) =\r
1495     id, lazy (modify_element ctx cl_modif id (evaluate elt_type)) in\r
1496   { cl_type with\r
1497     Types.named_elements =\r
1498       List.map modify_named_element cl_type.Types.named_elements\r
1499   }\r
1500 \r
1501 and modify_element ctx cl_modif id elt_type =\r
1502   let modifs, elt_descs = partition_modifications cl_modif id in\r
1503   match modifs, elt_descs with\r
1504     | [], [] -> elt_type\r
1505     | _ :: _, [] -> apply_element_modifications ctx modifs elt_type id\r
1506     | [], [elt_desc] -> apply_element_redeclaration ctx elt_desc elt_type\r
1507     | [], _ :: _ :: _ ->\r
1508         raise (CompilError\r
1509           {err_msg = ["_InvalidElemModifDef"];\r
1510            err_info = [];\r
1511            err_ctx = ctx}) (*error*)\r
1512     | _ :: _, _ :: _ ->\r
1513         raise (CompilError\r
1514           {err_msg = ["_InvalidElemModifDef"];\r
1515            err_info = [];\r
1516            err_ctx = ctx}) (*error*)\r
1517 \r
1518 and partition_modifications cl_modif id =\r
1519   let add_element_modification modif_arg modifs = match modif_arg.action with\r
1520     | Some (ElementModification modif) -> (modif_arg.final, modif) :: modifs\r
1521     | None | Some (ElementRedeclaration _) -> modifs\r
1522   and add_element_redeclaration modif_arg elt_descs =\r
1523     match modif_arg.action with\r
1524       | None | Some (ElementModification _) -> elt_descs\r
1525       | Some (ElementRedeclaration elt_desc) ->\r
1526           (modif_arg.final, elt_desc) :: elt_descs in\r
1527   let is_current_element_modification modif_arg = modif_arg.target = id in\r
1528   let cl_modif' = List.filter is_current_element_modification cl_modif in\r
1529   let modifs = List.fold_right add_element_modification cl_modif' []\r
1530   and elt_descs = List.fold_right add_element_redeclaration cl_modif' [] in\r
1531   modifs, elt_descs\r
1532 \r
1533 and apply_element_redeclaration ctx elt_desc elt_type =\r
1534   raise (CompilError\r
1535     {err_msg = ["_NotYetImplemented"; "_ElementRedeclaration"];\r
1536      err_info = [];\r
1537      err_ctx = ctx})\r
1538 \r
1539 and apply_element_modifications ctx modifs elt_type id =\r
1540   let add_modification_arguments (final, modif) cl_modifs = match modif with\r
1541     | Modification (cl_modif, _) -> (final, cl_modif) :: cl_modifs\r
1542     | Assignment _ | Equality _ -> cl_modifs\r
1543   and add_value_modification (final, modif) val_modifs = match modif with\r
1544     | Modification (_, Some _) | Assignment _ | Equality _ ->\r
1545         final :: val_modifs\r
1546     | Modification (_, None) -> val_modifs in\r
1547   let cl_modifs = List.fold_right add_modification_arguments modifs []\r
1548   and val_modifs = List.fold_right add_value_modification modifs [] in\r
1549   let elt_type' = modify_element_type ctx cl_modifs elt_type id in\r
1550   modify_element_value ctx val_modifs elt_type' id\r
1551 \r
1552 and modify_element_type ctx cl_modifs elt_type id =\r
1553   let propagate_final_attribute final modif_arg cl_modif =\r
1554     { modif_arg with final = final } :: cl_modif in\r
1555   let merge_modifications (final, cl_modif) cl_modif' =\r
1556     List.fold_right (propagate_final_attribute final) cl_modif cl_modif' in\r
1557   let cl_modif = List.fold_right merge_modifications cl_modifs [] in\r
1558   { elt_type with\r
1559     Types.element_nature = modify_element_nature ctx cl_modif elt_type id\r
1560   }\r
1561 \r
1562 and modify_element_nature ctx cl_modif elt_type id =\r
1563   match elt_type.Types.element_nature with\r
1564     | _ when elt_type.Types.final ->\r
1565         raise (CompilError\r
1566           {err_msg = ["_FinalElemModifNotAllowed"; id];\r
1567            err_info = [];\r
1568            err_ctx = ctx}) (*error*)\r
1569     | Types.ComponentElement cpnt_type ->\r
1570         Types.ComponentElement (modify_component_type ctx cl_modif cpnt_type)\r
1571     | Types.ClassElement cl_spec ->\r
1572         let cl_spec' = lazy (modify_class_specifier ctx cl_modif cl_spec) in\r
1573         Types.ClassElement cl_spec'\r
1574     | Types.ComponentTypeElement cpnt_type ->\r
1575         let cpnt_type' = modify_component_type ctx cl_modif cpnt_type in\r
1576         Types.ComponentTypeElement cpnt_type'\r
1577     | Types.PredefinedTypeElement predef ->\r
1578         Types.PredefinedTypeElement (modify_predefined_type ctx cl_modif predef)\r
1579 \r
1580 and modify_element_value ctx val_modifs elt_type id =\r
1581   match val_modifs with\r
1582     | [] -> elt_type\r
1583     | [_] when elt_type.Types.final ->\r
1584         raise (CompilError\r
1585           {err_msg = ["_FinalElemModifNotAllowed"; id];\r
1586            err_info = [];\r
1587            err_ctx = ctx}) (*error*)\r
1588     | [final] -> { elt_type with Types.final = final }\r
1589     | _ :: _ :: _ ->\r
1590         raise (CompilError\r
1591           {err_msg = ["_DuplicatedModifOfElem"; id];\r
1592            err_info = [];\r
1593            err_ctx = ctx}) (*error*)\r
1594 \r
1595 and modify_component_type ctx cl_modif cpnt_type =\r
1596   { cpnt_type with\r
1597     Types.base_class =\r
1598       lazy (modify_class_specifier ctx cl_modif cpnt_type.Types.base_class)\r
1599   }\r
1600 \r
1601 and resolve_type_modification ctx cpnt_type cl_modif =\r
1602   let cl_spec = (evaluate cpnt_type).Types.base_class in\r
1603   resolve_class_modification_option ctx cl_spec cl_modif\r
1604 \r
1605 and resolve_component_modification ctx cpnt_type = function\r
1606   | None -> None\r
1607   | Some modif' ->\r
1608       let elt_nat = Types.ComponentElement (evaluate cpnt_type) in\r
1609       Some (resolve_modification ctx elt_nat modif')\r
1610 \r
1611 and resolve_class_modification_option ctx cl_spec = function\r
1612   | None -> []\r
1613   | Some cl_modif -> resolve_class_modification ctx cl_spec cl_modif\r
1614 \r
1615 and resolve_modification ctx elt_nat modif =\r
1616   let ctx = {ctx with location = modif.Syntax.info} in\r
1617   match elt_nat, modif.Syntax.nature with\r
1618     | Types.ComponentElement cpnt_type, Syntax.Modification (cl_modif, expr) |\r
1619       Types.ComponentTypeElement cpnt_type,\r
1620       Syntax.Modification (cl_modif, (None as expr)) ->\r
1621         resolve_component_type_modification ctx cpnt_type cl_modif expr\r
1622     | Types.ComponentTypeElement _, Syntax.Modification (_, Some _) ->\r
1623         raise (CompilError\r
1624           {err_msg = ["_InvalidClassElemModif"];\r
1625            err_info = [];\r
1626            err_ctx = ctx}) (*error*)\r
1627     | Types.ClassElement cl_spec, Syntax.Modification (cl_modif, None) ->\r
1628         let cl_modif' = resolve_class_modification ctx cl_spec cl_modif in\r
1629         Modification (cl_modif', None)\r
1630     | Types.ClassElement _, Syntax.Modification (_, Some _) ->\r
1631         raise (CompilError\r
1632           {err_msg = ["_InvalidClassElemModif"];\r
1633            err_info = [];\r
1634            err_ctx = ctx}) (*error*)\r
1635     | (Types.PredefinedTypeElement _),\r
1636       (Syntax.Modification _ | Syntax.Eq _ | Syntax.ColEq _) ->\r
1637         raise (CompilError\r
1638           {err_msg = ["_InvalidClassElemModif"];\r
1639            err_info = [];\r
1640            err_ctx = ctx}) (*error*)\r
1641     | Types.ComponentElement cpnt_type, Syntax.Eq expr ->\r
1642         let expr' = lazy (resolve_modification_equation ctx cpnt_type expr) in\r
1643         Equality expr'\r
1644     | Types.ComponentElement cpnt_type, Syntax.ColEq expr ->\r
1645         let expr' = lazy (resolve_modification_algorithm ctx cpnt_type expr) in\r
1646         Assignment expr'\r
1647     | (Types.ClassElement _ | Types.ComponentTypeElement _),\r
1648       (Syntax.Eq _ | Syntax.ColEq _) ->\r
1649         raise (CompilError\r
1650           {err_msg = ["_InvalidClassElemModif"];\r
1651            err_info = [];\r
1652            err_ctx = ctx}) (*error*)\r
1653 \r
1654 and resolve_component_type_modification ctx cpnt_type cl_modif expr =\r
1655   let ctx = {ctx with location = cl_modif.Syntax.info} in\r
1656   let cl_spec = cpnt_type.Types.base_class in\r
1657   let cl_modif' = resolve_class_modification ctx cl_spec cl_modif in\r
1658   let cpnt_type' = modify_component_type ctx cl_modif' cpnt_type in\r
1659   let expr' = resolve_value_modification_option ctx cpnt_type' expr in\r
1660   Modification (cl_modif', expr')\r
1661 \r
1662 and resolve_value_modification_option ctx cpnt_type = function\r
1663   | None -> None\r
1664   | Some expr -> Some (lazy (resolve_modification_equation ctx cpnt_type expr))\r
1665 \r
1666 and resolve_modification_equation ctx cpnt_type expr =\r
1667   let ctx = {ctx with location = expr.Syntax.info} in\r
1668   let resolve_modification_equation' cpnt_type' expr' =\r
1669     let var = evaluate cpnt_type.Types.variability\r
1670     and var' = evaluate cpnt_type'.Types.variability in\r
1671     match Types.compare_component_types cpnt_type cpnt_type' with\r
1672     | Types.SameType\r
1673       when Types.higher_variability var var' -> expr'\r
1674     | Types.SameType ->\r
1675         let var = Types.string_of_variability var\r
1676         and var' = Types.string_of_variability var' in\r
1677         raise (CompilError\r
1678           {err_msg = ["_VariabilityConflicts"];\r
1679            err_info = [("_ExprKind", "A = B");\r
1680                        ("_VariabilityOfA", var);\r
1681                        ("_VariabilityOfB", var')];\r
1682            err_ctx = ctx}) (*error*)\r
1683     | _ ->\r
1684               let type_A = Types.string_of_component_type cpnt_type\r
1685               and type_B = Types.string_of_component_type cpnt_type' in\r
1686               raise (CompilError\r
1687                 {err_msg = [ "_EquTermsNotOfTheSameType"];\r
1688                  err_info = [("_ExprKind", "A = B");\r
1689                              ("_TypeOfA", type_A);\r
1690                              ("_TypeOfB", type_B)];\r
1691            err_ctx = ctx}) (*error*) in\r
1692   let expr' = resolve_expression ctx expr in\r
1693   let expr' = apply_rhs_coercions cpnt_type expr' in\r
1694   match expr'.info.type_description with\r
1695   | Types.ComponentElement cpnt_type' ->\r
1696       resolve_modification_equation' cpnt_type' expr'\r
1697     | Types.ClassElement _ | Types.ComponentTypeElement _ |\r
1698       Types.PredefinedTypeElement _ ->\r
1699         raise (CompilError\r
1700           {err_msg = ["_ClassElemFoundInExpr"];\r
1701            err_info = [];\r
1702            err_ctx = ctx}) (*error*)\r
1703 \r
1704 and resolve_modification_algorithm ctx cpnt_type expr =\r
1705   let ctx = {ctx with location = expr.Syntax.info} in\r
1706   let resolve_modification_algorithm' cpnt_type' expr' =\r
1707           let var = evaluate cpnt_type.Types.variability\r
1708           and var' = evaluate cpnt_type'.Types.variability in\r
1709           match Types.compare_component_types cpnt_type cpnt_type' with\r
1710     | Types.SameType\r
1711               when Types.higher_variability var var' -> expr'\r
1712     | Types.SameType ->\r
1713               let var = Types.string_of_variability var\r
1714               and var' = Types.string_of_variability var' in\r
1715               raise (CompilError\r
1716           {err_msg = ["_VariabilityConflicts"];\r
1717                  err_info = [("_ExprKind", "A := B");\r
1718                              ("_VariabilityOfA", var);\r
1719                              ("_VariabilityOfB", var')];\r
1720                  err_ctx = ctx}) (*error*)\r
1721     | _ ->\r
1722               let type_A = Types.string_of_component_type cpnt_type\r
1723               and type_B = Types.string_of_component_type cpnt_type' in\r
1724               raise (CompilError\r
1725           {err_msg = [ "_TypeConflictsInAssign"];\r
1726                  err_info = [("_ExprKind", "A := B");\r
1727                              ("_TypeOfA", type_A);\r
1728                              ("_TypeOfB", type_B)];\r
1729            err_ctx = ctx}) (*error*) in\r
1730   let expr' = resolve_expression ctx expr in\r
1731   let expr' = apply_rhs_coercions cpnt_type expr' in\r
1732   match expr'.info.type_description with\r
1733   | Types.ComponentElement cpnt_type' ->\r
1734       resolve_modification_algorithm' cpnt_type' expr'\r
1735     | Types.ClassElement _ | Types.ComponentTypeElement _ |\r
1736       Types.PredefinedTypeElement _ ->\r
1737         raise (CompilError\r
1738           {err_msg = ["_ClassElemFoundInExpr"];\r
1739            err_info = [];\r
1740            err_ctx = ctx}) (*error*)\r
1741 \r
1742 and resolve_class_modification ctx cl_spec cl_modif =\r
1743   match cl_modif.Syntax.nature with\r
1744     | Syntax.ClassModification args ->\r
1745         List.map (resolve_modification_argument ctx cl_spec) args\r
1746 \r
1747 and resolve_modification_argument ctx cl_spec arg =\r
1748   let ctx = {ctx with location = arg.Syntax.info} in\r
1749   let apply_each each =\r
1750     let rec drop_dimensions cl_spec = match cl_spec with\r
1751       | Types.ArrayType (_, cl_spec') -> drop_dimensions cl_spec'\r
1752       | Types.PredefinedType _ | Types.ClassType _ | Types.ComponentType _ |\r
1753         Types.TupleType _ -> cl_spec in\r
1754     let cl_spec' = evaluate cl_spec in\r
1755     match cl_spec' with\r
1756       | Types.ArrayType _ when each -> drop_dimensions cl_spec'\r
1757       | Types.PredefinedType _\r
1758       | Types.ClassType _\r
1759       | Types.ComponentType _\r
1760       | Types.TupleType _ when each ->\r
1761           raise (CompilError\r
1762             {err_msg = ["_EachAppliedToNonArrayElem"];\r
1763              err_info = [];\r
1764              err_ctx = ctx}) (*error*)\r
1765       | Types.ArrayType _ | Types.PredefinedType _ | Types.ClassType _ |\r
1766         Types.ComponentType _ | Types.TupleType _ -> cl_spec' in\r
1767   match arg.Syntax.nature with\r
1768     | Syntax.ElementModification (each, final, expr, modif, _) ->\r
1769         let each' = bool_of_each each\r
1770         and final' = bool_of_final final in\r
1771         let cl_spec' = apply_each each' in\r
1772         resolve_element_modification ctx cl_spec' each' final' expr modif\r
1773     | Syntax.ElementRedeclaration (each, final, elt_def) ->\r
1774         let each' = bool_of_each each\r
1775         and final' = bool_of_final final in\r
1776         let cl_spec' = apply_each each' in\r
1777         resolve_element_redeclaration ctx cl_spec' each' final' elt_def\r
1778 \r
1779 and bool_of_each = function\r
1780   | None -> false\r
1781   | Some Syntax.Each -> true\r
1782 \r
1783 and bool_of_final = function\r
1784   | None -> false\r
1785   | Some Syntax.Final -> true\r
1786 \r
1787 and resolve_element_modification ctx cl_spec each final expr modif =\r
1788   let ctx = {ctx with location = expr.Syntax.info} in\r
1789   let rec path_of_expression path expr = match expr.Syntax.nature with\r
1790     | Syntax.Identifier id ->\r
1791         modification_arguments_of_path cl_spec each final id (List.rev path)\r
1792     | Syntax.FieldAccess (expr, id) -> path_of_expression (id :: path) expr\r
1793     | _ ->\r
1794         raise (CompilError\r
1795           {err_msg = ["_InvalidExprInElemModif"];\r
1796            err_info = [];\r
1797            err_ctx = ctx}) (*error*)\r
1798   and modification_arguments_of_path cl_spec each final id path =\r
1799     let flow = false\r
1800     and var = Types.Continuous\r
1801     and inout = Types.Acausal in\r
1802     let elt_nat = element_field_type_nature ctx flow var inout cl_spec id in\r
1803     {\r
1804       each = each;\r
1805       final = final;\r
1806       target = id;\r
1807       action = resolve_modification_action ctx modif elt_nat path\r
1808     }\r
1809   and resolve_modification_action ctx modif elt_nat = function\r
1810     | [] -> resolve_modification_option ctx elt_nat modif\r
1811     | id :: path ->\r
1812         raise (CompilError\r
1813           {err_msg = ["_NotYetImplemented"; "_FieldAccessInElemModifExpr"];\r
1814            err_info = [];\r
1815            err_ctx = ctx})\r
1816   and resolve_modification_option ctx elt_nat = function\r
1817     | None -> None\r
1818     | Some modif ->\r
1819         Some (ElementModification (resolve_modification ctx elt_nat modif)) in\r
1820   path_of_expression [] expr\r
1821 \r
1822 and resolve_element_redeclaration ctx cl_spec each final elt_def =\r
1823   let ctx = {ctx with location = elt_def.Syntax.info} in\r
1824   raise (CompilError\r
1825     {err_msg = ["_NotYetImplemented"; "_ElementRedeclaration"];\r
1826      err_info = [];\r
1827      err_ctx = ctx})\r
1828 \r
1829 and resolve_unnamed_elements ctx other_elts =\r
1830   let class_kind =\r
1831     let class_context' cl_spec = match cl_spec with\r
1832       | Types.ClassType cl_type ->\r
1833           Some (evaluate cl_type.Types.kind)\r
1834       | _ -> None in\r
1835     match ctx.context_nature with\r
1836     | ClassContext cl_def ->\r
1837         class_context' (evaluate cl_def.class_type)\r
1838     | _ -> None in\r
1839   let add_equation_or_algorithm_clause other_elt acc =\r
1840     match other_elt.Syntax.nature, class_kind with\r
1841       | (Syntax.EquationClause _), Some kind\r
1842         when List.mem kind [Types.Function; Types.Record; Types.Connector] ->\r
1843           raise (CompilError\r
1844             {err_msg = ["_EquNotAllowedInTheDefOf"; Types.string_of_kind kind];\r
1845              err_info = [];\r
1846              err_ctx = ctx}) (*error*)\r
1847       | Syntax.EquationClause (init, equ_defs), _ ->\r
1848           let init' = bool_of_initial init\r
1849           and equ_defs' = resolve_equation_definitions ctx equ_defs in\r
1850           EquationClause (init', equ_defs') :: acc\r
1851       | Syntax.AlgorithmClause (init, algo_defs), _ ->\r
1852           let init' = bool_of_initial init\r
1853           and algo_defs' = resolve_algorithm_definitions ctx algo_defs in\r
1854           AlgorithmClause (init', algo_defs') :: acc\r
1855       | (Syntax.Public _ | Syntax.Protected _), _ -> acc in\r
1856   List.fold_right add_equation_or_algorithm_clause other_elts []\r
1857 \r
1858 and bool_of_initial = function\r
1859   | None -> Permanent\r
1860   | Some Syntax.Initial -> Initial\r
1861 \r
1862 and resolve_equation_definitions ctx equ_defs =\r
1863   let resolve_equation_definition equ_def = match equ_def.Syntax.nature with\r
1864     | Syntax.Equation (equ, _, _) -> resolve_equation ctx equ in\r
1865   List.flatten (List.map resolve_equation_definition equ_defs)\r
1866 \r
1867 and resolve_algorithm_definitions ctx algo_defs =\r
1868   let resolve_algorithm_definition algo_def = match algo_def.Syntax.nature with\r
1869     | Syntax.Algorithm (algo, _, _) -> resolve_algorithm ctx algo in\r
1870   List.map resolve_algorithm_definition algo_defs\r
1871 \r
1872 and resolve_equation ctx equ =\r
1873   let ctx = {ctx with location = equ.Syntax.info} in\r
1874   match equ.Syntax.nature with\r
1875     | Syntax.Equal (expr, expr') -> resolve_equal ctx equ expr expr'\r
1876     | Syntax.ConditionalEquationE (alts, default) ->\r
1877         resolve_conditional_equation_e ctx equ alts default\r
1878     | Syntax.ForClauseE (for_inds, equs) ->\r
1879         resolve_for_clause_e ctx equ for_inds equs\r
1880     | Syntax.ConnectClause (expr, expr') ->\r
1881         resolve_connect_clause ctx equ expr expr'\r
1882     | Syntax.WhenClauseE alts ->\r
1883         resolve_when_clause_e ctx equ alts\r
1884     | Syntax.FunctionCallE (expr, fun_args) ->\r
1885         resolve_functional_call_e ctx equ expr fun_args\r
1886 \r
1887 and resolve_equal ctx equ expres expres' =\r
1888   let resolve_equal' cpnt_type expr cpnt_type' expr' =\r
1889     let resolved_equation syn expr expr' =\r
1890       {\r
1891         nature = Equal (expr, expr');\r
1892         info = syn\r
1893       } in\r
1894     let var = evaluate cpnt_type.Types.variability\r
1895     and var' = evaluate cpnt_type'.Types.variability in\r
1896     match var, var' with\r
1897     | Types.Continuous, _ | _, Types.Continuous ->\r
1898         equations ctx equ resolved_equation cpnt_type expr cpnt_type' expr'\r
1899     | Types.Discrete, _ | _, Types.Discrete\r
1900       when expression_of_variable expres ->\r
1901         equations ctx equ resolved_equation cpnt_type expr cpnt_type' expr'\r
1902     | Types.Discrete, _ | _, Types.Discrete ->\r
1903         raise (CompilError\r
1904           {err_msg = ["_LHSOfDiscreteEquMustBeAVar"];\r
1905            err_info = [];\r
1906            err_ctx = {ctx with location = expres.Syntax.info}}) (*error*)\r
1907     | _ ->\r
1908         equations ctx equ resolved_equation cpnt_type expr cpnt_type' expr' in\r
1909   let expr = resolve_expression ctx expres\r
1910   and expr' = resolve_expression ctx expres' in\r
1911   let exprs = apply_binary_coercions [ expr; expr' ] in\r
1912   let expr = List.nth exprs 0\r
1913   and expr' = List.nth exprs 1 in\r
1914   let elt_nat = expr.info.type_description\r
1915   and elt_nat' = expr'.info.type_description in\r
1916   match elt_nat, elt_nat' with\r
1917     | Types.ComponentElement cpnt_type, Types.ComponentElement cpnt_type' ->\r
1918         resolve_equal' cpnt_type expr cpnt_type' expr'\r
1919     | (Types.ClassElement _ | Types.ComponentTypeElement _ |\r
1920       Types.PredefinedTypeElement _), _ ->\r
1921         let ctx = {ctx with location = expres.Syntax.info} in\r
1922         raise (CompilError\r
1923           {err_msg = ["_ClassElemFoundInExpr"];\r
1924            err_info = [];\r
1925            err_ctx = ctx}) (*error*)\r
1926     | _, (Types.ClassElement _ | Types.ComponentTypeElement _ |\r
1927       Types.PredefinedTypeElement _) ->\r
1928         let ctx = {ctx with location = expres'.Syntax.info} in\r
1929         raise (CompilError\r
1930           {err_msg = ["_ClassElemFoundInExpr"];\r
1931            err_info = [];\r
1932            err_ctx = ctx}) (*error*)\r
1933 \r
1934 and resolve_conditional_equation_e ctx equ alts default =\r
1935   let resolve_alternative (expr, equs) =\r
1936     let ctx = {ctx with location = expr.Syntax.info} in\r
1937     let expr' = resolve_expression ctx expr in\r
1938     let resolve_alternative' cpnt_type =\r
1939       let cl_spec = evaluate cpnt_type.Types.base_class in\r
1940       match cl_spec with\r
1941         | Types.PredefinedType { Types.base_type = Types.BooleanType } ->\r
1942             let equs' = List.flatten (List.map (resolve_equation ctx) equs) in\r
1943             expr', equs'\r
1944         | Types.PredefinedType _ | Types.ClassType _ | Types.ComponentType _ |\r
1945           Types.ArrayType _ | Types.TupleType _ ->\r
1946             raise (CompilError\r
1947               {err_msg = ["_NonBooleanIfCondExpr"];\r
1948                err_info =\r
1949                  [("_ExprKind", "...if A then...");\r
1950                   ("_TypeOfA", Types.string_of_class_specifier cl_spec)];\r
1951                err_ctx = ctx}) (*error*) in\r
1952     match expr'.info.type_description with\r
1953       | Types.ComponentElement cpnt_type -> resolve_alternative' cpnt_type\r
1954       | Types.ClassElement _ | Types.ComponentTypeElement _ |\r
1955         Types.PredefinedTypeElement _ ->\r
1956           raise (CompilError\r
1957             {err_msg = ["_ClassElemFoundInExpr"];\r
1958              err_info = [];\r
1959              err_ctx = ctx}) (*error*) in\r
1960   let alts' = List.map resolve_alternative alts in\r
1961   let default' = match default with\r
1962     | None -> []\r
1963     | Some equs -> List.flatten (List.map (resolve_equation ctx) equs) in\r
1964   [{\r
1965     nature = ConditionalEquationE (alts', default');\r
1966     info = Some equ\r
1967   }]\r
1968 \r
1969 and resolve_for_clause_e ctx equ for_inds equs =\r
1970   let range_element_type expr range =\r
1971     let ctx = {ctx with location = expr.Syntax.info} in\r
1972     let sub_dimension cl_spec = match cl_spec with\r
1973       | Types.ArrayType (dim, cl_spec) -> cl_spec\r
1974       | Types.PredefinedType _ | Types.ClassType _ |\r
1975         Types.ComponentType _ | Types.TupleType _ ->\r
1976           raise (CompilError\r
1977             {err_msg = ["_InvalidTypeInRangeExpr"];\r
1978              err_info =\r
1979                [("_ExpectedType", "Integer");\r
1980                 ("_TypeFound", Types.string_of_class_specifier cl_spec)];\r
1981              err_ctx = ctx}) (*error*) in\r
1982     match range.info.type_description with\r
1983       | Types.ComponentElement cpnt_type ->\r
1984           let cl_spec = evaluate cpnt_type.Types.base_class in\r
1985           let cpnt_type' =\r
1986             { cpnt_type with\r
1987               Types.base_class = lazy (sub_dimension cl_spec)\r
1988             } in\r
1989           Types.ComponentElement cpnt_type'\r
1990       | Types.ClassElement _ | Types.ComponentTypeElement _ |\r
1991         Types.PredefinedTypeElement _ ->\r
1992           raise (CompilError\r
1993             {err_msg = ["_ClassElemFoundInExpr"];\r
1994              err_info = [];\r
1995              err_ctx = ctx}) (*error*) in\r
1996   let rec resolve_for_clause_e' acc ctx = function\r
1997     | [] ->\r
1998         let equs' = List.flatten (List.map (resolve_equation ctx) equs) in\r
1999         [{\r
2000           nature = ForClauseE (List.rev acc, equs');\r
2001           info = Some equ\r
2002         }]\r
2003     | (_, None) :: _ ->\r
2004         raise (CompilError\r
2005           {err_msg = ["_NotYetImplemented"; "_ImplicitIterRange"];\r
2006            err_info = [];\r
2007            err_ctx = ctx})\r
2008     | (id, Some expr) :: for_inds ->\r
2009         let range = resolve_expression ctx expr in\r
2010         let elt_nat = range_element_type expr range in\r
2011         let ctx' =\r
2012           { ctx with\r
2013             context_nature = ForContext (ctx, id, elt_nat)\r
2014           } in\r
2015         resolve_for_clause_e' (range :: acc) ctx' for_inds in\r
2016   resolve_for_clause_e' [] ctx for_inds\r
2017 \r
2018 and resolve_connect_clause ctx equ expres expres' =\r
2019   let expr = resolve_expression ctx expres\r
2020   and expr' = resolve_expression ctx expres' in\r
2021   let resolve_connect_clause' cpnt_typ cpnt_typ' =\r
2022     let rec class_type_of_class_specifier cl_spec = match cl_spec with\r
2023       | Types.ClassType cl_type -> cl_type\r
2024       | Types.ComponentType cpnt_type ->\r
2025           let cl_spec = evaluate cpnt_type.Types.base_class in\r
2026           class_type_of_class_specifier cl_spec\r
2027       | Types.ArrayType (_, cl_spec) -> class_type_of_class_specifier cl_spec\r
2028       | Types.PredefinedType _ | Types.TupleType _ ->\r
2029           raise (CompilError\r
2030               {err_msg = ["_InvalidTypeOfArgInConnectStat"];\r
2031                err_info =\r
2032                  [("_ExprKind", "connect(A, B)");\r
2033                   ("_TypeOfA", Types.string_of_component_type cpnt_typ);\r
2034                   ("_TypeOfB", Types.string_of_component_type cpnt_typ')];\r
2035                err_ctx = ctx}) (*error*) in\r
2036     let connector_sign expr =\r
2037       let is_connector_type expr =\r
2038         let is_connector_type' cpnt_type =\r
2039           let cl_spec = evaluate cpnt_type.Types.base_class in\r
2040           let cl_type = class_type_of_class_specifier cl_spec in\r
2041           match evaluate cl_type.Types.kind with\r
2042             | Types.Connector | Types.ExpandableConnector -> true\r
2043             | Types.Class | Types.Model | Types.Block -> false\r
2044             | Types.Record ->\r
2045                 raise (CompilError\r
2046                   {err_msg =\r
2047                      ["record"; "_InstanceUsedInConnection"];\r
2048                    err_info = [];\r
2049                    err_ctx = ctx}) (*error*)\r
2050             | Types.Package ->\r
2051                 raise (CompilError\r
2052                   {err_msg =\r
2053                      ["package"; "_InstanceUsedInConnection"];\r
2054                    err_info = [];\r
2055                    err_ctx = ctx}) (*error*)\r
2056             | Types.Function ->\r
2057                 raise (CompilError\r
2058                   {err_msg =\r
2059                      ["function"; "_InstanceUsedInConnection"];\r
2060                    err_info = [];\r
2061                    err_ctx = ctx}) (*error*) in\r
2062         match expr.info.type_description with\r
2063           | Types.ComponentElement cpnt_type ->\r
2064               is_connector_type' cpnt_type\r
2065           | _ ->\r
2066               raise (CompilError\r
2067                 {err_msg = ["_ClassElemFoundInExpr"];\r
2068                  err_info = [];\r
2069                  err_ctx = ctx}) (*error*) in\r
2070       let is_connectable expr =\r
2071         let is_connectable' cpnt_type =\r
2072           let cl_spec = evaluate cpnt_type.Types.base_class in\r
2073           let cl_type = class_type_of_class_specifier cl_spec in\r
2074           match evaluate cl_type.Types.kind with\r
2075             | Types.Class | Types.Model | Types.Block -> true\r
2076             | Types.Connector | Types.ExpandableConnector -> false\r
2077             | Types.Record ->\r
2078                 raise (CompilError\r
2079                   {err_msg =\r
2080                      ["record"; "_InstanceUsedInConnection"];\r
2081                    err_info = [];\r
2082                    err_ctx = ctx}) (*error*)\r
2083             | Types.Package ->\r
2084                 raise (CompilError\r
2085                   {err_msg =\r
2086                      ["package"; "_InstanceUsedInConnection"];\r
2087                    err_info = [];\r
2088                    err_ctx = ctx}) (*error*)\r
2089             | Types.Function ->\r
2090                 raise (CompilError\r
2091                   {err_msg =\r
2092                      ["function"; "_InstanceUsedInConnection"];\r
2093                    err_info = [];\r
2094                    err_ctx = ctx}) (*error*) in\r
2095         match expr.info.type_description with\r
2096           | Types.ComponentElement cpnt_type ->\r
2097               is_connectable' cpnt_type\r
2098           | _ ->\r
2099               raise (CompilError\r
2100                 {err_msg = ["_ClassElemFoundInExpr"];\r
2101                  err_info = [];\r
2102                  err_ctx = ctx}) (*error*) in\r
2103       let rec connector_sign' expr = match expr.nature with\r
2104         | LocalIdentifier (0, _) when is_connector_type expr -> Some Negative\r
2105         | LocalIdentifier (0, _) when is_connectable expr -> Some Positive\r
2106         | (FieldAccess (expr', _) | IndexedAccess (expr', _))\r
2107           when is_connector_type expr -> connector_sign' expr'\r
2108         | (FieldAccess (expr', _) | IndexedAccess (expr', _))\r
2109           when is_connectable expr' -> connector_sign' expr'\r
2110         | _ ->\r
2111             raise (CompilError\r
2112               {err_msg = ["_InvalidTypeOfArgInConnectStat"];\r
2113                err_info =\r
2114                  [("_ExprKind", "connect(A, B)");\r
2115                   ("_TypeOfA", Types.string_of_component_type cpnt_typ);\r
2116                   ("_TypeOfB", Types.string_of_component_type cpnt_typ')];\r
2117                err_ctx = ctx}) (*error*) in\r
2118       match expr.nature with\r
2119         | _ when not (is_connector_type expr) ->\r
2120             raise (CompilError\r
2121               {err_msg = ["_InvalidTypeOfArgInConnectStat"];\r
2122                err_info =\r
2123                  [("_ExprKind", "connect(A, B)");\r
2124                   ("_TypeOfA", Types.string_of_component_type cpnt_typ);\r
2125                   ("_TypeOfB", Types.string_of_component_type cpnt_typ')];\r
2126                err_ctx = ctx}) (*error*)\r
2127         | LocalIdentifier (0, _) -> Some Negative\r
2128         | _ -> connector_sign' expr in\r
2129     let connect sign cpnt_type sign' cpnt_type' =\r
2130       let resolved_equation syn expr expr' =\r
2131         let elt_nat = expr.info.type_description\r
2132         and elt_nat' = expr'.info.type_description in\r
2133         let flow, _, _ = type_prefixes_of_element_nature elt_nat\r
2134         and flow', _, _ = type_prefixes_of_element_nature elt_nat' in\r
2135         match flow, flow' with\r
2136           | false, false ->\r
2137               {\r
2138                 nature = Equal (expr, expr');\r
2139                 info = syn\r
2140               }\r
2141           | true, true ->\r
2142               {\r
2143                 nature = ConnectFlows (sign, expr, sign', expr');\r
2144                 info = syn\r
2145               }\r
2146           | false, true ->\r
2147               raise (CompilError\r
2148                 {err_msg = ["_CannotConnectFlowAndNonFlowComp"];\r
2149                  err_info =\r
2150                    [("_ExprKind", "connect(A, B)");\r
2151                     ("_TypeOfA", "non-flow connector");\r
2152                     ("_TypeOfB", "flow connector")];\r
2153                  err_ctx = ctx}) (*error*)\r
2154           | true, false ->\r
2155               raise (CompilError\r
2156                 {err_msg = ["_CannotConnectFlowAndNonFlowComp"];\r
2157                  err_info =\r
2158                    [("_ExprKind", "connect(A, B)");\r
2159                     ("_TypeOfA", "flow connector");\r
2160                     ("_TypeOfB", "non-flow connector")];\r
2161                  err_ctx = ctx}) (*error*) in\r
2162       equations ctx equ resolved_equation cpnt_type expr cpnt_type' expr' in\r
2163     match connector_sign expr, connector_sign expr' with\r
2164       | Some sign, Some sign' -> connect sign cpnt_typ sign' cpnt_typ'\r
2165       | None, Some _ -> assert false\r
2166       | Some _, None -> assert false\r
2167       | None, None -> assert false in\r
2168   let elt_nat = expr.info.type_description\r
2169   and elt_nat' = expr'.info.type_description in\r
2170   match elt_nat, elt_nat' with\r
2171     | Types.ComponentElement cpnt_typ, Types.ComponentElement cpnt_typ' ->\r
2172         resolve_connect_clause' cpnt_typ cpnt_typ'\r
2173     | _, _ ->\r
2174         raise (CompilError\r
2175             {err_msg = ["_InvalidTypeOfArgInConnectStat"];\r
2176              err_info =\r
2177                [("_ExprKind", "connect(A, B)");\r
2178                 ("_TypeOfA", Types.string_of_element_nature elt_nat);\r
2179                 ("_TypeOfB", Types.string_of_element_nature elt_nat')];\r
2180              err_ctx = ctx}) (*error*)\r
2181 \r
2182 and resolve_when_clause_e ctx equ alts =\r
2183   let resolve_alternative (expr, equs) =\r
2184     let expr' = resolve_expression ctx expr in\r
2185     let rec check_equation equ =\r
2186       let check_equal expr expr' =\r
2187         match expr.Syntax.nature, expr'.Syntax.nature with\r
2188         | _, _ when expression_of_variable expr -> true\r
2189         | Syntax.Tuple exprs, Syntax.FunctionCall _\r
2190             when List.for_all expression_of_variable exprs -> true\r
2191         | _, _ -> raise (CompilError\r
2192             {err_msg = ["_InvalidWhenEquation"];\r
2193              err_info = [];\r
2194              err_ctx = {ctx with location = expr.Syntax.info}}) (*error*) in\r
2195       let check_alternative (expr, equs) =\r
2196         List.for_all check_equation equs in\r
2197       let check_function_call_e expr fun_args =\r
2198         match expr.Syntax.nature with\r
2199         | Syntax.Identifier "assert" |\r
2200           Syntax.Identifier "terminate" |\r
2201           Syntax.Identifier "reinit" -> true\r
2202         | _ ->\r
2203             raise (CompilError\r
2204               {err_msg = ["_InvalidWhenEquation"];\r
2205                err_info = [];\r
2206                err_ctx = {ctx with location = expr.Syntax.info}}) in\r
2207       match equ.Syntax.nature with\r
2208       | Syntax.Equal (expr, expr') -> check_equal expr expr'\r
2209       | Syntax.ConditionalEquationE (alts, None) ->\r
2210           List.for_all check_alternative alts\r
2211       | Syntax.ConditionalEquationE (alts, Some equs) ->\r
2212           (List.for_all check_alternative alts) &&\r
2213           (List.for_all check_equation equs)\r
2214       | Syntax.ForClauseE (for_inds, equs) ->\r
2215           List.for_all check_equation equs\r
2216       | Syntax.ConnectClause (expr, expr') ->\r
2217           raise (CompilError\r
2218             {err_msg = ["_InvalidWhenEquation"];\r
2219              err_info = [];\r
2220              err_ctx = {ctx with location = equ.Syntax.info}}) (*error*)\r
2221       | Syntax.WhenClauseE alts ->\r
2222           raise (CompilError\r
2223             {err_msg = ["_WhenClausesCannotBeNested"];\r
2224              err_info = [];\r
2225              err_ctx = {ctx with location = equ.Syntax.info}}) (*error*)\r
2226       | Syntax.FunctionCallE (expr, fun_args) ->\r
2227           check_function_call_e expr fun_args in\r
2228     let resolve_alternative' cpnt_type =\r
2229       let cl_spec = evaluate cpnt_type.Types.base_class in\r
2230       match cl_spec with\r
2231       | Types.ArrayType (Types.DiscreteDimension, _) ->\r
2232           raise (CompilError\r
2233             {err_msg = ["_InvalidTypeOfWhenCond"];\r
2234              err_info =\r
2235                [("_ExprKind", "...when A then...");\r
2236                 ("_TypeOfA", Types.string_of_class_specifier cl_spec)];\r
2237              err_ctx = {ctx with location = expr.Syntax.info}}) (*error*)\r
2238       | Types.PredefinedType { Types.base_type = Types.BooleanType } |\r
2239         Types.ArrayType\r
2240           (_, Types.PredefinedType { Types.base_type = Types.BooleanType })\r
2241               when List.for_all check_equation equs ->\r
2242               let equs' = List.flatten (List.map (resolve_equation ctx) equs) in\r
2243               expr', equs'\r
2244       | Types.PredefinedType _ | Types.ClassType _ | Types.ComponentType _ |\r
2245         Types.ArrayType _ | Types.TupleType _ ->\r
2246           raise (CompilError\r
2247             {err_msg = ["_InvalidTypeOfWhenCond"];\r
2248              err_info =\r
2249                [("_ExprKind", "...when A then...");\r
2250                 ("_TypeOfA", Types.string_of_class_specifier cl_spec)];\r
2251              err_ctx = {ctx with location = expr.Syntax.info}}) (*error*) in\r
2252     match expr'.info.type_description with\r
2253     | Types.ComponentElement cpnt_type\r
2254         when (evaluate cpnt_type.Types.variability) <> Types.Continuous ->\r
2255           resolve_alternative' cpnt_type\r
2256     | Types.ComponentElement cpnt_type ->\r
2257         raise (CompilError\r
2258           {err_msg = ["_WhenConditionMustBeDiscrete"];\r
2259            err_info = [];\r
2260            err_ctx = {ctx with location = expr.Syntax.info}}) (*error*)\r
2261     | Types.ClassElement _ | Types.ComponentTypeElement _ |\r
2262       Types.PredefinedTypeElement _ ->\r
2263         raise (CompilError\r
2264           {err_msg = ["_ClassElemFoundInExpr"];\r
2265            err_info = [];\r
2266            err_ctx = {ctx with location = expr.Syntax.info}}) (*error*) in\r
2267   let alts' = List.map resolve_alternative alts in\r
2268   [{\r
2269     nature = WhenClauseE alts';\r
2270     info = Some equ\r
2271   }]\r
2272 \r
2273 and resolve_functional_call_e ctx equ expr fun_args =\r
2274   let ctx = {ctx with location = equ.Syntax.info} in\r
2275   let res =\r
2276     let nat = Tuple []\r
2277     and elt_nat = Types.empty_tuple_type Types.Constant in\r
2278     resolved_expression None nat elt_nat in\r
2279   let fun_call = resolve_function_call ctx None expr fun_args in\r
2280   let resolve_functional_call_e cpnt_type =\r
2281     let cl_spec = evaluate cpnt_type.Types.base_class in\r
2282     match cl_spec with\r
2283       | Types.TupleType [] ->\r
2284           [{\r
2285             nature = Equal (res, fun_call);\r
2286             info = Some equ\r
2287           }]\r
2288       | _ ->\r
2289           raise (CompilError\r
2290             {err_msg = ["_NonEmptyFuncCallUsedAsAnEqu"];\r
2291              err_info =\r
2292                [("_TypeOfFuncValue", Types.string_of_class_specifier cl_spec)];\r
2293              err_ctx = ctx}) (*error*) in\r
2294   match fun_call.info.type_description with\r
2295     | Types.ComponentElement cpnt_type -> resolve_functional_call_e cpnt_type\r
2296     | Types.ClassElement _ | Types.ComponentTypeElement _ |\r
2297       Types.PredefinedTypeElement _ ->\r
2298         raise (CompilError\r
2299           {err_msg = ["_ClassElemFoundInExpr"];\r
2300            err_info = [];\r
2301            err_ctx = ctx}) (*error*)\r
2302 \r
2303 and equations ctx equ resolved_equation cpnt_type expr cpnt_type' expr' =\r
2304   let equivalent_types predef predef' =\r
2305     match Types.compare_predefined_types predef predef',\r
2306           Types.compare_predefined_types predef' predef with\r
2307     | _, Types.NotRelated | Types.NotRelated, _ -> false\r
2308     | _ -> true in\r
2309   let rec equations' i subs cl_spec expr cl_spec' expr' =\r
2310     match cl_spec, cl_spec' with\r
2311       | Types.PredefinedType predef, Types.PredefinedType predef'\r
2312           when equivalent_types predef predef' ->\r
2313             [equation subs expr expr']\r
2314       | Types.ComponentType cpnt_type, Types.ComponentType cpnt_type' ->\r
2315           raise (CompilError\r
2316             {err_msg = ["_NotYetImplemented"; "_ComponentTypeEqu"];\r
2317              err_info = [];\r
2318              err_ctx = ctx})\r
2319       | Types.ClassType cl_type, Types.ClassType cl_type' ->\r
2320           record_equations subs cl_type expr cl_type' expr'\r
2321       | Types.ArrayType (dim, cl_spec), Types.ArrayType (dim', cl_spec') ->\r
2322           [for_equation i subs dim cl_spec expr dim' cl_spec' expr']\r
2323       | Types.TupleType cl_specs, Types.TupleType cl_specs' ->\r
2324           [{\r
2325             nature = Equal (expr, expr');\r
2326             info = Some equ\r
2327           }]\r
2328       | (Types.PredefinedType _ | Types.ComponentType _ | Types.ArrayType _ |\r
2329          Types.TupleType _ | Types.ClassType _),\r
2330         (Types.PredefinedType _ | Types.ComponentType _ | Types.ArrayType _ |\r
2331          Types.TupleType _ | Types.ClassType _) ->\r
2332           raise (CompilError\r
2333             {err_msg = ["_EquTermsNotOfTheSameType"];\r
2334              err_info =\r
2335                [("_ExprKind", "A = B");\r
2336                 ("_TypeOfA", Types.string_of_class_specifier cl_spec);\r
2337                 ("_TypeOfB", Types.string_of_class_specifier cl_spec')];\r
2338              err_ctx = {ctx with location = equ.Syntax.info}}) (*error*)\r
2339   and for_equation i subs dim cl_spec expr dim' cl_spec' expr' =\r
2340     match dim, dim' with\r
2341       | Types.ConstantDimension n, Types.ConstantDimension n' when n <> n' ->\r
2342           let type_A = Types.string_of_component_type cpnt_type\r
2343           and type_B = Types.string_of_component_type cpnt_type' in\r
2344           raise (CompilError\r
2345             {err_msg = ["_ArrayDimMismatchInEqu"];\r
2346              err_info = [("_ExprKind", "A = B");\r
2347                          ("_TypeOfA", type_A);\r
2348                          ("_TypeOfB", type_B)];\r
2349              err_ctx = ctx}) (*error*)\r
2350       | (Types.ConstantDimension _ | Types.ParameterDimension),\r
2351         (Types.ConstantDimension _ | Types.ParameterDimension) ->\r
2352           let range = resolve_colon ctx expr (Int32.of_int i) dim in\r
2353           let subs =\r
2354             let nat = LoopVariable (i - 1)\r
2355             and elt_nat = Types.integer_type Types.Constant in\r
2356             resolved_expression None nat elt_nat :: subs in\r
2357           let equs = equations' (i + 1) subs cl_spec expr cl_spec' expr' in\r
2358           {\r
2359             nature = ForClauseE ([range], equs);\r
2360             info = Some equ\r
2361           }\r
2362       | (Types.ConstantDimension _ | Types.ParameterDimension |\r
2363          Types.DiscreteDimension),\r
2364         (Types.ConstantDimension _ | Types.ParameterDimension |\r
2365          Types.DiscreteDimension) ->\r
2366           let type_A = Types.string_of_component_type cpnt_type\r
2367           and type_B = Types.string_of_component_type cpnt_type' in\r
2368           raise (CompilError\r
2369             {err_msg = ["_ArrayDimMismatchInEqu"];\r
2370              err_info = [("_ExprKind", "A = B");\r
2371                          ("_TypeOfA", type_A);\r
2372                          ("_TypeOfB", type_B)];\r
2373              err_ctx = ctx}) (*error*)\r
2374   and record_equations subs cl_type expr cl_type' expr' =\r
2375     let named_elts = cl_type.Types.named_elements\r
2376     and named_elts' = cl_type'.Types.named_elements in\r
2377     let record_equations' expr expr' =\r
2378       let class_spec_of_element_type elt_type =\r
2379         let elt_type' = evaluate elt_type in\r
2380         element_nature_class ctx elt_type'.Types.element_nature in\r
2381       let record_equation (id, elt_type) =\r
2382         let elt_type' =\r
2383           try\r
2384             List.assoc id named_elts'\r
2385           with _ ->\r
2386             raise (CompilError\r
2387               {err_msg = ["_EquTermsNotOfTheSameType"];\r
2388                err_info =\r
2389                  [("_ExprKind", "A = B");\r
2390                   ("_TypeOfA", Types.string_of_component_type cpnt_type);\r
2391                   ("_TypeOfB", Types.string_of_component_type cpnt_type')];\r
2392                err_ctx = {ctx with location = equ.Syntax.info}}) (*error*) in\r
2393         let cl_spec = class_spec_of_element_type elt_type\r
2394         and cl_spec' = class_spec_of_element_type elt_type' in\r
2395         let expr =\r
2396           let nat = FieldAccess (expr, id)\r
2397           and flow, var, inout =\r
2398             type_prefixes_of_element_nature expr.info.type_description\r
2399           and cl_spec = element_nature_class ctx expr.info.type_description in\r
2400           let elt_nat =\r
2401             element_field_type_nature ctx flow var inout cl_spec id in\r
2402           resolved_expression None nat elt_nat\r
2403         and expr' =\r
2404           let nat = FieldAccess (expr', id)\r
2405           and flow, var, inout =\r
2406             type_prefixes_of_element_nature expr'.info.type_description\r
2407           and cl_spec = element_nature_class ctx expr'.info.type_description in\r
2408           let elt_nat =\r
2409             element_field_type_nature ctx flow var inout cl_spec id in\r
2410           resolved_expression None nat elt_nat in\r
2411         equations' 1 [] cl_spec expr cl_spec' expr' in\r
2412       List.flatten (List.map record_equation named_elts) in\r
2413     match subs with\r
2414       | [] -> record_equations' expr expr'\r
2415       | subs ->\r
2416           let expr =\r
2417             let elt_nat = expr.info.type_description in\r
2418             let nat = IndexedAccess (expr, subs)\r
2419             and elt_nat' = scalar_element_nature elt_nat in\r
2420             resolved_expression None nat elt_nat'\r
2421           and expr' =\r
2422             let elt_nat = expr'.info.type_description in\r
2423             let nat = IndexedAccess (expr', subs)\r
2424             and elt_nat' = scalar_element_nature elt_nat in\r
2425             resolved_expression None nat elt_nat' in\r
2426           record_equations' expr expr'\r
2427   and equation subs expr expr' = match subs with\r
2428     | [] -> resolved_equation (Some equ) expr expr'\r
2429     | subs ->\r
2430         let expr =\r
2431           let elt_nat = expr.info.type_description in\r
2432           let nat = IndexedAccess (expr, subs)\r
2433           and elt_nat' = scalar_element_nature elt_nat in\r
2434           resolved_expression None nat elt_nat'\r
2435         and expr' =\r
2436           let elt_nat = expr'.info.type_description in\r
2437           let nat = IndexedAccess (expr', subs)\r
2438           and elt_nat' = scalar_element_nature elt_nat in\r
2439           resolved_expression None nat elt_nat' in\r
2440         resolved_equation None expr expr' in\r
2441   let cl_spec = evaluate cpnt_type.Types.base_class\r
2442   and cl_spec' = evaluate cpnt_type'.Types.base_class in\r
2443   equations' 1 [] cl_spec expr cl_spec' expr'\r
2444 \r
2445 and resolve_algorithm ctx algo =\r
2446   let ctx = {ctx with location = algo.Syntax.info} in\r
2447   match algo.Syntax.nature with\r
2448     | Syntax.Assign _ |\r
2449       Syntax.FunctionCallA _ |\r
2450       Syntax.MultipleAssign _ |\r
2451       Syntax.Break |\r
2452       Syntax.Return |\r
2453       Syntax.ConditionalEquationA _ |\r
2454       Syntax.ForClauseA _ |\r
2455       Syntax.WhileClause _ |\r
2456       Syntax.WhenClauseA _ ->\r
2457         raise (CompilError\r
2458           {err_msg = ["_NotYetImplemented"; "_AlgoClause"];\r
2459            err_info = [];\r
2460            err_ctx = ctx})\r
2461 \r
2462 and resolve_expression ctx expr =\r
2463   let ctx = {ctx with location = expr.Syntax.info} in\r
2464   match expr.Syntax.nature with\r
2465     | Syntax.BinaryOperation (kind, arg1, arg2) ->\r
2466         resolve_binary_operation ctx expr kind arg1 arg2\r
2467     | Syntax.End -> resolve_end ctx expr\r
2468     | Syntax.False -> resolve_false ctx expr\r
2469     | Syntax.FieldAccess (expr', id) -> resolve_field_access ctx expr expr' id\r
2470     | Syntax.FunctionCall (expr', fun_args) ->\r
2471         resolve_function_call ctx (Some expr) expr' fun_args\r
2472     | Syntax.Identifier id -> resolve_identifier ctx expr id\r
2473     | Syntax.If (alts, expr') -> resolve_if ctx expr alts expr'\r
2474     | Syntax.IndexedAccess (expr', subs) ->\r
2475         resolve_indexed_access ctx expr expr' subs\r
2476     | Syntax.Integer s -> resolve_integer ctx expr s\r
2477     | Syntax.MatrixConstruction exprss ->\r
2478         resolve_matrix_construction ctx expr exprss\r
2479     | Syntax.NoEvent expr' ->\r
2480         resolve_no_event ctx expr expr'\r
2481     | Syntax.Range (start, step, stop) ->\r
2482         resolve_range ctx expr start step stop\r
2483     | Syntax.Real s -> resolve_real ctx expr s\r
2484     | Syntax.String s -> resolve_string ctx expr s\r
2485     | Syntax.True -> resolve_true ctx expr\r
2486     | Syntax.Tuple exprs -> resolve_tuple ctx expr exprs\r
2487     | Syntax.UnaryOperation (kind, arg) ->\r
2488         resolve_unuary_operation ctx expr kind arg\r
2489     | Syntax.Vector vec_elts -> resolve_vector ctx expr vec_elts\r
2490 \r
2491 and resolve_binary_operation ctx expr kind arg1 arg2 =\r
2492   let arg1' = resolve_expression ctx arg1\r
2493   and arg2' = resolve_expression ctx arg2 in\r
2494   let args' = apply_binary_coercions [ arg1'; arg2' ] in\r
2495   let arg1' = List.nth args' 0\r
2496   and arg2' = List.nth args' 1 in\r
2497   match kind.Syntax.nature with\r
2498     | Syntax.Plus -> resolve_addition ctx expr arg1' arg2'\r
2499     | Syntax.And -> resolve_and ctx expr arg1' arg2'\r
2500     | Syntax.Divide -> resolve_division ctx expr arg1' arg2'\r
2501     | Syntax.EqualEqual -> raise (CompilError\r
2502         {err_msg = ["_NotYetImplemented"; "_BinaryOperEQUEQU"];\r
2503          err_info = [];\r
2504          err_ctx = ctx})\r
2505     | Syntax.GreaterEqual ->\r
2506         resolve_comparison ctx expr GreaterEqual arg1' arg2'\r
2507     | Syntax.Greater -> resolve_comparison ctx expr Greater arg1' arg2'\r
2508     | Syntax.LessEqual -> resolve_comparison ctx expr LessEqual arg1' arg2'\r
2509     | Syntax.Less -> resolve_comparison ctx expr Less arg1' arg2'\r
2510     | Syntax.Times -> resolve_multiplication ctx expr arg1' arg2'\r
2511     | Syntax.NotEqual -> raise (CompilError\r
2512         {err_msg = ["_NotYetImplemented"; "_BinaryOperDIFF"];\r
2513          err_info = [];\r
2514          err_ctx = ctx})\r
2515     | Syntax.Or -> resolve_or ctx expr arg1' arg2'\r
2516     | Syntax.Power -> resolve_power ctx expr arg1' arg2'\r
2517     | Syntax.Minus -> resolve_subtraction ctx expr arg1' arg2'\r
2518 \r
2519 and resolve_end ctx expr =\r
2520   let ctx = {ctx with location = expr.Syntax.info} in\r
2521   match ctx.context_nature with\r
2522     | SubscriptContext (_, _, _, Types.ConstantDimension n) ->\r
2523         let nat = Integer n\r
2524         and elt_nat = Types.integer_type Types.Constant in\r
2525         resolved_expression (Some expr) nat elt_nat\r
2526     | SubscriptContext (_, expr', n, Types.ParameterDimension) ->\r
2527         size_function_call ctx (Some expr) expr' n\r
2528     | SubscriptContext (_, expr', n, Types.DiscreteDimension) ->\r
2529         size_function_call ctx (Some expr) expr' n\r
2530     | ForContext (ctx', _, _) -> resolve_end ctx' expr\r
2531     | ToplevelContext | ClassContext _ ->\r
2532         raise (CompilError\r
2533           {err_msg = ["_InvalidKeyWordEndInExpr"];\r
2534            err_info = [];\r
2535            err_ctx = ctx}) (*error*)\r
2536 \r
2537 and resolve_false ctx expr =\r
2538   resolved_expression (Some expr) False (Types.boolean_type Types.Constant)\r
2539 \r
2540 and resolve_field_access ctx expr expr' id =\r
2541   let expr' = resolve_expression ctx expr' in\r
2542   let resolve_field_access' expr' id =\r
2543   let nat = FieldAccess (expr', id)\r
2544   and flow, var, inout =\r
2545     type_prefixes_of_element_nature expr'.info.type_description\r
2546   and cl_spec = element_nature_class ctx expr'.info.type_description in\r
2547   let elt_nat = element_field_type_nature ctx flow var inout cl_spec id in\r
2548     resolved_expression (Some expr) nat elt_nat in\r
2549   let is_package cl_spec = match evaluate cl_spec with\r
2550     | Types.ClassType cl_type\r
2551       when evaluate cl_type.Types.kind = Types.Package -> true\r
2552     | _ -> false in\r
2553   match expr'.info.type_description with\r
2554   | Types.ComponentElement _  ->\r
2555       resolve_field_access' expr' id\r
2556   | Types.ClassElement cl_spec when is_package cl_spec ->\r
2557       resolve_field_access' expr' id\r
2558   | _ ->\r
2559       raise (CompilError\r
2560         {err_msg = ["component or package"; "_ElemExpected"];\r
2561          err_info = [];\r
2562          err_ctx = { ctx with location = expr.Syntax.info }}) (*error*)\r
2563 \r
2564 and type_prefixes_of_element_nature = function\r
2565   | Types.ComponentElement cpnt_type ->\r
2566       evaluate cpnt_type.Types.flow,\r
2567       evaluate cpnt_type.Types.variability,\r
2568       evaluate cpnt_type.Types.causality\r
2569   | Types.ClassElement _ | Types.ComponentTypeElement _ |\r
2570     Types.PredefinedTypeElement _ ->\r
2571       false, Types.Constant, Types.Acausal\r
2572 \r
2573 and resolve_function_call ctx syn expr fun_args =\r
2574   let ctx = {ctx with location = expr.Syntax.info} in\r
2575   let expr' = resolve_expression ctx expr in\r
2576   let resolve_function_arguments named_elts =\r
2577     let reversed_additional_dimensions input_types args =\r
2578       let additional_named_element_dimensions id arg =\r
2579         let rec subtract_dimensions fun_dims arg_dims =\r
2580           match fun_dims, arg_dims with\r
2581             | [], _ ->  arg_dims\r
2582             | _, [] ->\r
2583                 raise (CompilError\r
2584                   {err_msg = ["_ArgDimMismatch"];\r
2585                    err_info = [];\r
2586                    err_ctx = ctx}) (*error*)\r
2587             | Types.ConstantDimension i :: _, Types.ConstantDimension i' :: _\r
2588               when i <> i' ->\r
2589                 raise (CompilError\r
2590                   {err_msg = ["_ArgDimMismatch"];\r
2591                    err_info = [];\r
2592                    err_ctx = ctx}) (*error*)\r
2593             | _ :: fun_dims, _ :: arg_dims ->\r
2594                 subtract_dimensions fun_dims arg_dims in\r
2595         let elt_type = List.assoc id input_types in\r
2596         let elt_type' = evaluate elt_type in\r
2597         let fun_dims =\r
2598           Types.reversed_element_dimensions elt_type'.Types.element_nature\r
2599         and arg_dims =\r
2600           Types.reversed_element_dimensions arg.info.type_description in\r
2601         subtract_dimensions fun_dims arg_dims in\r
2602       let rec reversed_additional_dimensions' ids dims args =\r
2603         match args with\r
2604           | [] -> ids, dims\r
2605           | (id, arg) :: args ->\r
2606               let dims' = additional_named_element_dimensions id arg in\r
2607               update_additional_dimensions ids dims id dims' args\r
2608       and update_additional_dimensions ids dims id dims' args =\r
2609         match dims, dims' with\r
2610           | _, [] -> reversed_additional_dimensions' ids dims args\r
2611           | [], _ :: _ ->\r
2612               let ids' = id :: ids in\r
2613               reversed_additional_dimensions' ids' dims' args\r
2614           | _ :: _, _ :: _ when dims <> dims' ->\r
2615               raise (CompilError\r
2616                 {err_msg = ["_ArgDimMismatchInVectCall"];\r
2617                  err_info = [];\r
2618                  err_ctx = ctx}) (*error*)\r
2619           | _ :: _, _ :: _ ->\r
2620               let ids' = id :: ids in\r
2621               reversed_additional_dimensions' ids' dims args in\r
2622       reversed_additional_dimensions' [] [] args in\r
2623     let function_call ids rev_dims input_types output_types args =\r
2624       let ndims = List.length rev_dims in\r
2625       let rec expressions_of_named_arguments pos input_types =\r
2626         let expression_of_default_argument id elt_type =\r
2627           let elt_type' = evaluate elt_type in\r
2628           let func =\r
2629             let nat = FunctionArgument 0\r
2630             and elt_nat = expr'.info.type_description in\r
2631             resolved_expression None nat elt_nat in\r
2632           let nat = FieldAccess (func, id)\r
2633           and elt_nat = elt_type'.Types.element_nature in\r
2634           resolved_expression None nat elt_nat\r
2635         and expression_of_named_argument pos id elt_type =\r
2636           let rec loop_variables = function\r
2637             | 0 -> []\r
2638             | ndims ->\r
2639                 let nat = LoopVariable (ndims - 1)\r
2640                 and elt_nat = (Types.integer_type Types.Constant) in\r
2641                 let loop_var = resolved_expression None nat elt_nat in\r
2642                 loop_var :: loop_variables (ndims - 1) in\r
2643           let elt_type' = evaluate elt_type in\r
2644           let elt_nat = elt_type'.Types.element_nature in\r
2645           let nat = match List.mem id ids with\r
2646             | false -> FunctionArgument pos\r
2647             | true ->\r
2648                 let arg = List.assoc id args in\r
2649                 let nat = FunctionArgument pos\r
2650                 and elt_nat = arg.info.type_description in\r
2651                 let expr = resolved_expression None nat elt_nat in\r
2652                 IndexedAccess (expr, loop_variables ndims) in\r
2653           resolved_expression None nat elt_nat in\r
2654         match input_types with\r
2655           | [] -> []\r
2656           | (id, elt_type) :: input_types when not (List.mem_assoc id args) ->\r
2657               let arg = expression_of_default_argument id elt_type in\r
2658               arg :: expressions_of_named_arguments pos input_types\r
2659           | (id, elt_type) :: input_types ->\r
2660               let arg = expression_of_named_argument pos id elt_type in\r
2661               arg :: expressions_of_named_arguments (pos + 1) input_types in\r
2662       let ranges arg rev_dims =\r
2663         let rec ranges' acc n rev_dims =\r
2664           let range_of_dimension dim =\r
2665             let range_to stop =\r
2666               let nat = Range (one, one, stop)\r
2667               and elt_nat = Types.integer_array_type Types.Constant dim in\r
2668               resolved_expression None nat elt_nat in\r
2669             match dim with\r
2670               | Types.ConstantDimension i ->\r
2671                   let stop =\r
2672                     let nat = Integer i\r
2673                     and elt_nat = (Types.integer_type Types.Constant) in\r
2674                     resolved_expression None nat elt_nat in\r
2675                   range_to stop\r
2676               | Types.ParameterDimension ->\r
2677                   let stop = size_function_call ctx None arg n in\r
2678                   range_to stop\r
2679               | Types.DiscreteDimension ->\r
2680                   let stop = size_function_call ctx None arg n in\r
2681                   range_to stop in\r
2682           match rev_dims with\r
2683             | [] -> acc\r
2684             | dim :: rev_dims ->\r
2685                 let range = range_of_dimension dim in\r
2686                 ranges' (range :: acc) (Int32.succ n) rev_dims in\r
2687         ranges' [] 1l rev_dims in\r
2688       let rec sorted_arguments_of_named_arguments = function\r
2689         | [] -> []\r
2690         | (id, _) :: input_types when not (List.mem_assoc id args) ->\r
2691             sorted_arguments_of_named_arguments input_types\r
2692         | (id, _) :: input_types ->\r
2693             let arg = List.assoc id args in\r
2694             arg :: sorted_arguments_of_named_arguments input_types in\r
2695       let wrap_function_invocation cpnt_type =\r
2696         let add_dimensions cpnt_type =\r
2697           let rec add_dimensions cl_spec = function\r
2698             | [] -> cl_spec\r
2699             | dim :: rev_dims ->\r
2700                 let cl_spec' = Types.ArrayType (dim, cl_spec) in\r
2701                 add_dimensions cl_spec' rev_dims in\r
2702           let base_class = cpnt_type.Types.base_class in\r
2703           { cpnt_type with\r
2704             Types.base_class =\r
2705               lazy (add_dimensions (evaluate base_class) rev_dims)\r
2706           } in\r
2707         let wrap_function_invocation' cpnt_type rev_dims =\r
2708           let nat =\r
2709             let exprs = expressions_of_named_arguments 1 input_types in\r
2710             FunctionInvocation exprs\r
2711           and elt_nat = Types.ComponentElement cpnt_type in\r
2712           match ids with\r
2713             | [] ->\r
2714                 resolved_expression syn nat elt_nat\r
2715             | id :: _ ->\r
2716                 let cpnt_type' = add_dimensions cpnt_type in\r
2717                 let nat =\r
2718                   let ranges =\r
2719                     let arg = List.assoc id args in\r
2720                     ranges arg rev_dims\r
2721                   and expr = resolved_expression None nat elt_nat in\r
2722                   VectorReduction (ranges, expr)\r
2723                 and elt_nat = Types.ComponentElement cpnt_type' in\r
2724                 resolved_expression None nat elt_nat in\r
2725         wrap_function_invocation' cpnt_type rev_dims in\r
2726       let component_type_of_output_types output_types =\r
2727         let component_type_of_output_type cpnt_type (_, elt_type) =\r
2728           let add_class_specifier cl_spec cl_spec' =\r
2729             match cl_spec, cl_spec' with\r
2730             | Types.TupleType [], _ -> cl_spec'\r
2731             | (Types.TupleType cl_specs), _ ->\r
2732                 Types.TupleType (cl_spec' :: cl_specs)\r
2733             | _, _ -> Types.TupleType [cl_spec'; cl_spec] in\r
2734           let var = evaluate cpnt_type.Types.variability\r
2735           and cl_spec = evaluate cpnt_type.Types.base_class in\r
2736           let elt_type' = evaluate elt_type in\r
2737           match elt_type'.Types.element_nature with\r
2738             | Types.ComponentElement cpnt_type' ->\r
2739                 let var' = evaluate cpnt_type'.Types.variability\r
2740                 and cl_spec' = evaluate cpnt_type'.Types.base_class in\r
2741                 {\r
2742                   Types.flow = lazy false;\r
2743                   Types.variability = lazy (Types.max_variability var var');\r
2744                   Types.causality = lazy Types.Acausal;\r
2745                   Types.base_class = lazy (add_class_specifier cl_spec cl_spec')\r
2746                 }\r
2747             | Types.ClassElement _ | Types.ComponentTypeElement _ |\r
2748               Types.PredefinedTypeElement _ ->\r
2749                 raise (CompilError\r
2750                   {err_msg = ["_ClassElemFoundInExpr"];\r
2751                    err_info = [];\r
2752                    err_ctx = ctx}) (*error*) in\r
2753         let cpnt_type =\r
2754           {\r
2755             Types.flow = lazy false;\r
2756             Types.variability = lazy Types.Constant;\r
2757             Types.causality = lazy Types.Acausal;\r
2758             Types.base_class = lazy (Types.TupleType [])\r
2759           } in\r
2760         List.fold_left component_type_of_output_type cpnt_type output_types in\r
2761       let args' = sorted_arguments_of_named_arguments input_types\r
2762       and cpnt_type = component_type_of_output_types output_types in\r
2763       let func_invoc = wrap_function_invocation cpnt_type in\r
2764       let nat = FunctionCall (expr', args', func_invoc)\r
2765       and elt_nat = func_invoc.info.type_description in\r
2766       resolved_expression syn nat elt_nat in\r
2767     let resolve_function_arguments' fun_args =\r
2768       match fun_args.Syntax.nature with\r
2769       | Syntax.Reduction _ ->\r
2770           raise (CompilError\r
2771             {err_msg = ["_NotYetImplemented"; "_FuncArgumentReduction"];\r
2772              err_info = [];\r
2773              err_ctx = ctx})\r
2774       | Syntax.ArgumentList args ->\r
2775           let input_types, output_types, named_args =\r
2776               resolve_function_argument_list ctx expr' named_elts args in\r
2777           let ids, rev_dims =\r
2778             reversed_additional_dimensions input_types named_args in\r
2779           function_call ids rev_dims input_types output_types named_args in\r
2780     match fun_args with\r
2781       | None ->\r
2782           let fun_args = { Syntax.nature = Syntax.ArgumentList [];\r
2783                            Syntax.info = ctx.location } in\r
2784           resolve_function_arguments' fun_args\r
2785       | Some fun_args -> resolve_function_arguments' fun_args in\r
2786   let resolve_class_function_call cl_type =\r
2787     match evaluate cl_type.Types.kind with\r
2788     | Types.Function ->\r
2789         resolve_function_arguments cl_type.Types.named_elements\r
2790     | Types.Class | Types.Model | Types.Block | Types.Record |\r
2791       Types.ExpandableConnector | Types.Connector | Types.Package ->\r
2792         raise (CompilError\r
2793           {err_msg = ["function"; "_ElemExpected"];\r
2794            err_info = [];\r
2795            err_ctx = ctx}) (*error*) in\r
2796   let resolve_function_call' cl_spec =\r
2797     match evaluate cl_spec with\r
2798     | Types.ClassType cl_type ->\r
2799         resolve_class_function_call cl_type\r
2800     | _ ->\r
2801         raise (CompilError\r
2802           {err_msg = ["function"; "_ElemExpected"];\r
2803            err_info = [];\r
2804            err_ctx = ctx}) (*error*) in\r
2805   match expr'.info.type_description with\r
2806   | Types.ClassElement cl_spec -> resolve_function_call' cl_spec\r
2807   | Types.ComponentElement cpnt_type ->\r
2808       let cl_spec = cpnt_type.Types.base_class in\r
2809       resolve_function_call' cl_spec\r
2810   | Types.ComponentTypeElement _ | Types.PredefinedTypeElement _ ->\r
2811       raise (CompilError\r
2812         {err_msg = ["function"; "_ElemExpected"];\r
2813          err_info = [];\r
2814          err_ctx = ctx}) (*error*)\r
2815 \r
2816 and resolve_function_argument_list ctx expr' named_elts args =\r
2817   let rec class_kind ctx =\r
2818     let class_context' cl_spec = match cl_spec with\r
2819       | Types.ClassType cl_type ->\r
2820           Some (evaluate cl_type.Types.kind)\r
2821       | _ -> None in\r
2822     match ctx.context_nature with\r
2823     | ClassContext cl_def ->\r
2824         class_context' (evaluate cl_def.class_type)\r
2825     | SubscriptContext (ctx, _, _, _) | ForContext (ctx, _, _) ->\r
2826         class_kind ctx\r
2827     | _ -> None in\r
2828   let add_function_inout_argument ((id, elt_type) as named_elt) inouts =\r
2829     let add_function_inout_argument' cpnt_type =\r
2830       match inouts, evaluate cpnt_type.Types.causality with\r
2831       | (ins, outs), Types.Input -> named_elt :: ins, outs\r
2832       | (ins, outs), Types.Output -> ins, named_elt :: outs\r
2833       | _, Types.Acausal -> inouts in\r
2834     let elt_type' = evaluate elt_type in\r
2835     match elt_type'.Types.element_nature with\r
2836       | Types.ComponentElement cpnt_type when not elt_type'.Types.protected ->\r
2837           add_function_inout_argument' cpnt_type\r
2838       | _ -> inouts in\r
2839   let add_argument id arg arg' elt_type acc =\r
2840     let matchable_types cpnt_type cpnt_type' =\r
2841       let cl_spec = evaluate cpnt_type.Types.base_class\r
2842       and cl_spec' = evaluate cpnt_type'.Types.base_class in\r
2843       let rec matchable_types' cl_spec cl_spec' = match cl_spec, cl_spec' with\r
2844         | Types.ArrayType (dim, cl_spec), _ ->\r
2845             matchable_types' cl_spec cl_spec'\r
2846         | _, Types.ArrayType (dim', cl_spec') ->\r
2847             matchable_types' cl_spec cl_spec'\r
2848         | _, _ ->\r
2849             let type_compare = Types.compare_specifiers cl_spec cl_spec' in\r
2850             (type_compare = Types.SameType) ||\r
2851             (type_compare = Types.Supertype) in\r
2852       matchable_types' cl_spec cl_spec' in\r
2853     let matchable_variabilities cpnt_type cpnt_type' =\r
2854       let var = evaluate cpnt_type.Types.variability\r
2855       and var' = evaluate cpnt_type'.Types.variability in\r
2856       Types.higher_variability var var' in\r
2857     let elt_type = evaluate elt_type in\r
2858     let cpnt_type = match elt_type.Types.element_nature with\r
2859       | Types.ComponentElement cpnt_type -> cpnt_type\r
2860       | _ -> assert false in\r
2861     let arg' = apply_rhs_coercions cpnt_type arg' in\r
2862     match arg'.info.type_description with\r
2863     | Types.ComponentElement cpnt_type'\r
2864         when not (matchable_types cpnt_type cpnt_type') ->\r
2865         raise (CompilError\r
2866           {err_msg = ["_ArgTypeMismatch"];\r
2867            err_info =\r
2868              [("_ExpectedType", Types.string_of_component_type cpnt_type);\r
2869               ("_TypeFound", Types.string_of_component_type cpnt_type')];\r
2870            err_ctx = {ctx with location = arg.Syntax.info}}) (*error*)\r
2871     | Types.ComponentElement cpnt_type'\r
2872         when not (matchable_variabilities cpnt_type cpnt_type') ->\r
2873         let var = evaluate cpnt_type.Types.variability\r
2874         and var' = evaluate cpnt_type'.Types.variability in\r
2875         let var = Types.string_of_variability var\r
2876         and var' = Types.string_of_variability var' in\r
2877         raise (CompilError\r
2878           {err_msg = ["_ArgVariabilityMismatch"];\r
2879            err_info = [("_ExpectedVariability", var);\r
2880                        ("_VariabilityFound", var')];\r
2881            err_ctx = {ctx with location = arg.Syntax.info}}) (*error*)\r
2882     | Types.ComponentElement cpnt_type' -> (id, arg') :: acc\r
2883     | _ -> raise (CompilError\r
2884         {err_msg = ["_ClassElemFoundInExpr"];\r
2885          err_info = [];\r
2886          err_ctx = {ctx with location = arg.Syntax.info}}) (*error*) in\r
2887   let named_arguments_of_arguments input_types args =\r
2888     let rec add_positional_arguments acc input_types args =\r
2889       match input_types, args with\r
2890       | [], [] -> acc\r
2891       | [], _ ->\r
2892           raise (CompilError\r
2893             {err_msg = ["_TooManyArgsInFuncCall"];\r
2894              err_info = [];\r
2895              err_ctx = ctx}) (*error*)\r
2896       | _, [] ->\r
2897           raise (CompilError\r
2898             {err_msg = ["_TooFewArgsInFuncCall"];\r
2899              err_info = [];\r
2900              err_ctx = ctx}) (*error*)\r
2901       | (id, elt_type) :: input_types,\r
2902         { Syntax.nature = Syntax.Argument arg } :: args ->\r
2903           let arg' = resolve_expression ctx arg in\r
2904           let acc = add_argument id arg arg' elt_type acc in\r
2905           add_positional_arguments acc input_types args\r
2906       | _, { Syntax.nature = Syntax.NamedArgument _ } :: _ ->\r
2907           add_named_arguments acc input_types args\r
2908     and add_named_arguments acc input_types args =\r
2909       match input_types, args with\r
2910       | [], [] -> acc\r
2911       | [], _ ->\r
2912           raise (CompilError\r
2913             {err_msg = ["_TooManyArgsInFuncCall"];\r
2914              err_info = [];\r
2915              err_ctx = ctx}) (*error*)\r
2916       | _, [] ->\r
2917           raise (CompilError\r
2918             {err_msg = ["_TooFewArgsInFuncCall"];\r
2919              err_info = [];\r
2920              err_ctx = ctx}) (*error*)\r
2921       | _, { Syntax.nature = Syntax.Argument _ } :: _ ->\r
2922           raise (CompilError\r
2923             {err_msg = ["_MixedPositAndNamedFuncArgPass"];\r
2924              err_info = [];\r
2925              err_ctx = ctx}) (*error*)\r
2926       | _, { Syntax.nature = Syntax.NamedArgument (id, _) } :: _\r
2927           when List.mem_assoc id acc ->\r
2928             raise (CompilError\r
2929               {err_msg = ["_FuncCallWithDuplicateArg"; id];\r
2930                err_info = [];\r
2931                err_ctx = ctx}) (*error*)\r
2932       | _, { Syntax.nature = Syntax.NamedArgument (id, _) } :: _\r
2933           when not (List.mem_assoc id input_types) ->\r
2934             raise (CompilError\r
2935               {err_msg = ["_NonInputFuncArgElem"; id];\r
2936                err_info = [];\r
2937                err_ctx = ctx}) (*error*)\r
2938       | _, { Syntax.nature = Syntax.NamedArgument (id, arg) } :: args ->\r
2939           let arg' = resolve_expression ctx arg\r
2940           and elt_type = List.assoc id input_types in\r
2941           let acc = add_argument id arg arg' elt_type acc in\r
2942           add_named_arguments acc input_types args in\r
2943     add_positional_arguments [] input_types args in\r
2944   let resolve_built_in_function_argument arg = match arg with\r
2945     | { Syntax.nature = Syntax.Argument arg } ->\r
2946         arg, (resolve_expression ctx arg)\r
2947     | { Syntax.nature = Syntax.NamedArgument _; Syntax.info = info } ->\r
2948         raise (CompilError\r
2949           {err_msg = ["_CannotUseNamedArgWithBuiltInOper"];\r
2950            err_info = [];\r
2951            err_ctx = {ctx with location = info}}) (*error*) in\r
2952   let rec built_in_function_named_arguments acc input_types args' =\r
2953     match input_types, args' with\r
2954     | [], [] -> acc\r
2955     | [], _ ->\r
2956         raise (CompilError\r
2957           {err_msg = ["_TooManyArgsInFuncCall"];\r
2958            err_info = [];\r
2959            err_ctx = ctx}) (*error*)\r
2960     | _, [] ->\r
2961         raise (CompilError\r
2962           {err_msg = ["_TooFewArgsInFuncCall"];\r
2963            err_info = [];\r
2964            err_ctx = ctx}) (*error*)\r
2965     | (id, elt_type) :: input_types, (arg, arg') :: args' ->\r
2966         let acc = add_argument id arg arg' elt_type acc in\r
2967         built_in_function_named_arguments acc input_types args' in\r
2968   let built_in_function_inout_types ctx id (in_types, out_types) args' =\r
2969     let argument_component_type (arg, arg') =\r
2970       match arg'.info.type_description with\r
2971       | Types.ComponentElement cpnt_type ->\r
2972           cpnt_type\r
2973       | _ -> raise (CompilError\r
2974           {err_msg = ["_ClassElemFoundInExpr"];\r
2975            err_info = [];\r
2976            err_ctx = {ctx with location = arg.Syntax.info}}) (*error*) in\r
2977     let scalar_base_class_specifier (arg, arg') =\r
2978       let rec scalar_base_class_specifier' cl_spec = match cl_spec with\r
2979         | Types.ArrayType (dim, cl_spec) -> scalar_base_class_specifier' cl_spec\r
2980         | _ -> cl_spec in\r
2981       let cpnt_type = argument_component_type (arg, arg') in\r
2982       let cl_spec = evaluate cpnt_type.Types.base_class in\r
2983       scalar_base_class_specifier' cl_spec in\r
2984     let argument_base_type bt (arg, arg') =\r
2985       let cl_spec = scalar_base_class_specifier (arg, arg') in\r
2986       match cl_spec with\r
2987       | Types.PredefinedType predef when predef.Types.base_type = bt -> true\r
2988       | _ -> false in\r
2989     let argument_base_types bt args =\r
2990       List.for_all (argument_base_type bt) args in\r
2991     let argument_variability var (arg, arg') =\r
2992       let cpnt_type = argument_component_type (arg, arg') in\r
2993       let var' = evaluate cpnt_type.Types.variability in\r
2994       var = var' in\r
2995     let neg f = function x -> not (f x) in\r
2996     let ndims arg' =\r
2997       let cpnt_type = component_type_of_expression ctx arg' in\r
2998       let rec ndims' cl_spec =\r
2999         match cl_spec with\r
3000         | Types.ArrayType (dim, cl_spec) -> ndims' cl_spec + 1\r
3001         | _ -> 0 in\r
3002       ndims' (evaluate cpnt_type.Types.base_class) in\r
3003     let numeric_base_type arg' =\r
3004       let cl_spec = scalar_class_specifier ctx arg' in\r
3005       (Types.compare_specifiers Types.integer_class_type cl_spec =\r
3006          Types.SameType) ||\r
3007       (Types.compare_specifiers Types.real_class_type cl_spec =\r
3008          Types.SameType) in\r
3009     let rec argument_types i args = match args with\r
3010       | [] -> []\r
3011       | (arg, arg') :: args ->\r
3012           let cpnt_type = component_type_of_expression ctx arg'\r
3013           and name = Printf.sprintf "@%d" i in\r
3014           (name, cpnt_type) :: (argument_types (i + 1) args) in\r
3015     let element_types input_types output_types =\r
3016       let element_type inout (id, cpnt_type) =\r
3017         (id,\r
3018          lazy\r
3019            {\r
3020              Types.protected = false;\r
3021              Types.final = true;\r
3022              Types.replaceable = false;\r
3023              Types.dynamic_scope = None;\r
3024              Types.element_nature =\r
3025                Types.ComponentElement\r
3026                  { cpnt_type with Types.causality = lazy inout }\r
3027            }) in\r
3028      (List.map (element_type Types.Input) input_types),\r
3029      (List.map (element_type Types.Output) output_types) in\r
3030     match id, args' with\r
3031     | ("der" | "initial" | "terminal" | "sample" | "pre" | "edge" | "change" |\r
3032        "reinit" | "delay"), _ when (class_kind ctx) = Some Types.Function ->\r
3033         raise (CompilError\r
3034           {err_msg = [id; "_OperCannotBeUsedWithinFuncDef"];\r
3035            err_info = [];\r
3036            err_ctx = ctx}) (*error*)\r
3037     | ("pre" | "edge" | "change"), [arg, arg'] | "reinit", [(arg, arg'); _]\r
3038         when not (expression_of_variable arg) ->\r
3039         raise (CompilError\r
3040           {err_msg = [id; "_OperArgMustBeAVar"];\r
3041            err_info = [];\r
3042            err_ctx = {ctx with location = arg.Syntax.info}}) (*error*)\r
3043     | ("ceil" | "floor" | "integer" | "der"), [arg, arg'] |\r
3044       "reinit", [(arg, arg'); _] |\r
3045       "smooth", [_; (arg, arg')]\r
3046         when not (argument_base_type Types.RealType (arg, arg')) ->\r
3047         let cl_spec = scalar_base_class_specifier (arg, arg') in\r
3048         raise (CompilError\r
3049           {err_msg = ["_ArgTypeMismatch"];\r
3050            err_info =\r
3051              [("_ExpectedType", "Real");\r
3052               ("_TypeFound", Types.string_of_class_specifier cl_spec)];\r
3053            err_ctx = {ctx with location = arg.Syntax.info}}) (*error*)\r
3054     | "delay", _\r
3055         when not (List.for_all (argument_base_type Types.RealType) args') ->\r
3056         let (arg, arg') =\r
3057           List.find (neg (argument_base_type Types.RealType)) args' in\r
3058         let cl_spec = scalar_base_class_specifier (arg, arg') in\r
3059         raise (CompilError\r
3060           {err_msg = ["_ArgTypeMismatch"];\r
3061            err_info =\r
3062              [("_ExpectedType", "Real");\r
3063               ("_TypeFound", Types.string_of_class_specifier cl_spec)];\r
3064            err_ctx = {ctx with location = arg.Syntax.info}}) (*error*)\r
3065     | "der", [arg, arg']\r
3066         when not (argument_variability Types.Continuous (arg, arg')) ->\r
3067         let cpnt_type = argument_component_type (arg, arg') in\r
3068         let var = evaluate cpnt_type.Types.variability in\r
3069         let var = Types.string_of_variability var in\r
3070         raise (CompilError\r
3071           {err_msg = ["_ArgVariabilityMismatch"];\r
3072            err_info = [("_ExpectedVariability", "Continuous");\r
3073                        ("_VariabilityFound", var)];\r
3074            err_ctx = {ctx with location = arg.Syntax.info}}) (*error*)\r
3075     | "delay", _ when List.length args' = 3 ->\r
3076         let input_types =\r
3077           [("@1", Types.real_component_type Types.Continuous);\r
3078            ("@2", Types.real_component_type Types.Continuous);\r
3079            ("@3", Types.real_component_type Types.Parameter)]\r
3080         and output_types =\r
3081           ["@4", Types.real_component_type Types.Continuous] in\r
3082         element_types input_types output_types\r
3083     | "abs", [arg, arg']\r
3084         when argument_base_type Types.IntegerType (arg, arg') ->\r
3085         let input_types = ["@1", Types.integer_component_type Types.Discrete]\r
3086         and output_types =\r
3087           ["@2", Types.integer_component_type Types.Discrete] in\r
3088         element_types input_types output_types\r
3089     | ("ones" | "zeros"), _\r
3090       when not (argument_base_types Types.IntegerType args') ->\r
3091         let (arg, arg') =\r
3092           List.find (neg (argument_base_type Types.IntegerType)) args' in\r
3093         raise (CompilError\r
3094           {err_msg = ["_ArgTypeMismatch"];\r
3095            err_info = [];\r
3096            err_ctx = {ctx with location = arg.Syntax.info}}) (*error*)\r
3097     | "fill", _ :: args'\r
3098       when not (argument_base_types Types.IntegerType args') ->\r
3099         let (arg, arg') =\r
3100           List.find (neg (argument_base_type Types.IntegerType)) args' in\r
3101         raise (CompilError\r
3102           {err_msg = ["_ArgTypeMismatch"];\r
3103            err_info = [];\r
3104            err_ctx = {ctx with location = arg.Syntax.info}}) (*error*)\r
3105     | ("sum" | "product" | "max" | "min" | "scalar"), [arg, arg']\r
3106       when ndims arg' = 0 ->\r
3107         raise (CompilError\r
3108           {err_msg = ["_ArgTypeMismatch"];\r
3109            err_info = [];\r
3110            err_ctx = {ctx with location = arg.Syntax.info}}) (*error*)\r
3111     | "diagonal", [arg, arg']\r
3112       when ndims arg' <> 1 ->\r
3113         raise (CompilError\r
3114           {err_msg = ["_ArgTypeMismatch"];\r
3115            err_info = [];\r
3116            err_ctx = {ctx with location = arg.Syntax.info}}) (*error*)\r
3117     | ("scalar"), [arg, arg'] ->\r
3118         let cpnt_type = component_type_of_expression ctx arg' in\r
3119         let input_types = ["@1", cpnt_type]\r
3120         and output_types =\r
3121           ["@2", Types.scalar_component_type cpnt_type ] in\r
3122         element_types input_types output_types\r
3123     | ("sum" | "product" | "max" | "min" | "diagonal"), [arg, arg']\r
3124       when not (numeric_base_type arg') ->\r
3125         raise (CompilError\r
3126           {err_msg = ["_ArgTypeMismatch"];\r
3127            err_info = [];\r
3128            err_ctx = {ctx with location = arg.Syntax.info}}) (*error*)\r
3129     | ("sum" | "product" | "max" | "min"), [arg, arg'] ->\r
3130         let cpnt_type = component_type_of_expression ctx arg' in\r
3131         let input_types = ["@1", cpnt_type]\r
3132         and output_types =\r
3133           ["@2", Types.scalar_component_type cpnt_type ] in\r
3134         element_types input_types output_types\r
3135     | ("ones" | "zeros"), _ :: _ ->\r
3136         let input_types = argument_types 1 args'\r
3137         and output_types =\r
3138           let n = List.length args'\r
3139           and dims =\r
3140             List.map (function _ -> Types.ParameterDimension) args' in\r
3141           let cpnt_type =\r
3142             { \r
3143               Types.flow = lazy false;\r
3144               variability = lazy Types.Parameter;\r
3145               Types.causality = lazy Types.Acausal;\r
3146               base_class =\r
3147                 lazy(Types.add_dimensions dims Types.integer_class_type)\r
3148             } in\r
3149           [ Printf.sprintf "@%d" (n + 1), cpnt_type ] in\r
3150         element_types input_types output_types\r
3151     | "fill", (arg, arg') :: (_ :: _ as args) ->\r
3152         let input_types = argument_types 1 args'\r
3153         and output_types =\r
3154           let n = List.length args\r
3155           and dims =\r
3156             List.map (function _ -> Types.ParameterDimension) args in\r
3157           let cpnt_type = component_type_of_expression ctx arg' in\r
3158           let lcl_spec = lazy\r
3159             (Types.add_dimensions\r
3160               dims \r
3161               (evaluate cpnt_type.Types.base_class)) in\r
3162           [ \r
3163             Printf.sprintf "@%d" (n + 1),\r
3164             { cpnt_type with Types.base_class = lcl_spec }\r
3165           ] in\r
3166         element_types input_types output_types\r
3167     | "diagonal", [ arg, arg' ] ->\r
3168         let cpnt_type = component_type_of_expression ctx arg' in\r
3169         let input_types = [ "@1", cpnt_type ]\r
3170         and output_types =\r
3171           let dims = [ Types.ParameterDimension ] in\r
3172           let lcl_spec = lazy\r
3173             (Types.add_dimensions\r
3174               dims\r
3175               (evaluate cpnt_type.Types.base_class)) in\r
3176           [ "@2", { cpnt_type with Types.base_class = lcl_spec } ] in\r
3177         element_types input_types output_types\r
3178     | ("div" | "mod" | "rem" | "max" | "min"), _\r
3179         when List.for_all (argument_base_type Types.IntegerType) args' ->\r
3180         let input_types =\r
3181           [\r
3182             "@1", Types.integer_component_type Types.Discrete;\r
3183             "@2", Types.integer_component_type Types.Discrete\r
3184           ]\r
3185         and output_types =\r
3186           ["@3", Types.integer_component_type Types.Discrete] in\r
3187         element_types input_types output_types\r
3188     | ("pre" | "change"), [arg, arg'] ->\r
3189         let cpnt_type = argument_component_type (arg, arg') in\r
3190         let input_types =\r
3191           ["@1", { cpnt_type with Types.variability = lazy Types.Continuous }]\r
3192         and output_types =\r
3193           ["@2", { cpnt_type with Types.variability = lazy Types.Discrete }] in\r
3194         element_types input_types output_types\r
3195     | _, _ -> in_types, out_types in\r
3196   match expr'.nature with\r
3197   | PredefinedIdentifier id ->\r
3198       let args' = List.map resolve_built_in_function_argument args in\r
3199       let input_types, output_types =\r
3200         let inout_types =\r
3201           List.fold_right add_function_inout_argument named_elts ([], []) in\r
3202         built_in_function_inout_types ctx id inout_types args' in\r
3203       let named_args =\r
3204         built_in_function_named_arguments [] input_types args' in\r
3205       input_types, output_types, named_args\r
3206   | _ ->\r
3207       let input_types, output_types =\r
3208         List.fold_right add_function_inout_argument named_elts ([], []) in\r
3209       let named_args = named_arguments_of_arguments input_types args in\r
3210       input_types, output_types, named_args\r
3211 \r
3212 and resolve_identifier ctx expr id =\r
3213   let rec resolve_predefined_identifier ctx expr id = match id with\r
3214     | "Boolean" ->\r
3215         let nat = PredefinedIdentifier "Boolean"\r
3216         and elt_nat = Types.ClassElement (lazy (Types.boolean_class_type)) in\r
3217         resolved_expression (Some expr) nat elt_nat\r
3218     | "Integer" ->\r
3219         let nat = PredefinedIdentifier "Integer"\r
3220         and elt_nat = Types.ClassElement (lazy (Types.integer_class_type)) in\r
3221         resolved_expression (Some expr) nat elt_nat\r
3222     | "Real" ->\r
3223         let nat = PredefinedIdentifier "Real"\r
3224         and elt_nat = Types.ClassElement (lazy (Types.real_class_type)) in\r
3225         resolved_expression (Some expr) nat elt_nat\r
3226     | "String" ->\r
3227         let nat = PredefinedIdentifier "String"\r
3228         and elt_nat = Types.ClassElement (lazy (Types.string_class_type)) in\r
3229         resolved_expression (Some expr) nat elt_nat\r
3230     | "reinit" ->\r
3231         let nat = PredefinedIdentifier "reinit"\r
3232         and elt_nat =\r
3233           let inputs =\r
3234             ["@1", Types.real_component_type Types.Continuous;\r
3235              "@2", Types.real_component_type Types.Continuous]\r
3236           and outputs = [] in\r
3237           Types.function_type inputs outputs in\r
3238         resolved_expression (Some expr) nat elt_nat\r
3239     | "time" ->\r
3240         let nat = PredefinedIdentifier "time"\r
3241         and elt_nat = Types.real_type Types.Continuous in\r
3242         resolved_expression (Some expr) nat elt_nat\r
3243     | "pre" | "change" ->\r
3244         let nat = PredefinedIdentifier "pre"\r
3245         and elt_nat =\r
3246           let inputs = ["@1", Types.real_component_type Types.Continuous]\r
3247           and outputs = ["@2", Types.real_component_type Types.Discrete] in\r
3248           Types.function_type inputs outputs in\r
3249         resolved_expression (Some expr) nat elt_nat\r
3250     | "edge" ->\r
3251         let nat = PredefinedIdentifier "edge"\r
3252         and elt_nat =\r
3253           let inputs = ["@1", Types.boolean_component_type Types.Discrete]\r
3254           and outputs = ["@2", Types.boolean_component_type Types.Discrete] in\r
3255           Types.function_type inputs outputs in\r
3256         resolved_expression (Some expr) nat elt_nat\r
3257     | "initial" ->\r
3258         let nat = PredefinedIdentifier "initial"\r
3259         and elt_nat =\r
3260           let inputs = []\r
3261           and outputs = [] in\r
3262           Types.function_type inputs outputs in\r
3263         resolved_expression (Some expr) nat elt_nat\r
3264     | "terminal" ->\r
3265         let nat = PredefinedIdentifier "terminal"\r
3266         and elt_nat =\r
3267           let inputs = []\r
3268           and outputs = [] in\r
3269           Types.function_type inputs outputs in\r
3270         resolved_expression (Some expr) nat elt_nat\r
3271     | "sample" ->\r
3272         let nat = PredefinedIdentifier "sample"\r
3273         and elt_nat =\r
3274           let inputs = [("@1", Types.real_component_type Types.Parameter);\r
3275                         ("@2", Types.real_component_type Types.Parameter)]\r
3276           and outputs = ["@3", Types.boolean_component_type Types.Parameter] in\r
3277           Types.function_type inputs outputs in\r
3278         resolved_expression (Some expr) nat elt_nat\r
3279     | "delay" ->\r
3280         let nat = PredefinedIdentifier "delay"\r
3281         and elt_nat =\r
3282           let inputs = [("@1", Types.real_component_type Types.Continuous);\r
3283                         ("@2", Types.real_component_type Types.Parameter)]\r
3284           and outputs = ["@3", Types.real_component_type Types.Continuous] in\r
3285           Types.function_type inputs outputs in\r
3286         resolved_expression (Some expr) nat elt_nat\r
3287     | "assert" ->\r
3288         let nat = PredefinedIdentifier "assert"\r
3289         and elt_nat =\r
3290           let inputs = [("@1", Types.boolean_component_type Types.Discrete);\r
3291                         ("@2", Types.string_component_type Types.Discrete)]\r
3292           and outputs = [] in\r
3293           Types.function_type inputs outputs in\r
3294         resolved_expression (Some expr) nat elt_nat\r
3295     | "terminate" ->\r
3296         let nat = PredefinedIdentifier "terminate"\r
3297         and elt_nat =\r
3298           let inputs = [("@1", Types.string_component_type Types.Discrete)]\r
3299           and outputs = [] in\r
3300           Types.function_type inputs outputs in\r
3301         resolved_expression (Some expr) nat elt_nat\r
3302     | "abs" | "cos" | "sin" | "tan" | "exp" | "log" | "sqrt" |\r
3303       "asin" | "acos" | "atan" | "sinh" | "cosh" | "tanh" | "asinh" |\r
3304       "acosh" | "atanh" | "log10" | "ceil" | "floor" | "der" ->\r
3305         let nat = PredefinedIdentifier id\r
3306         and elt_nat =\r
3307           let inputs = ["@1", Types.real_component_type Types.Continuous]\r
3308           and outputs = ["@2", Types.real_component_type Types.Continuous] in\r
3309           Types.function_type inputs outputs in\r
3310         resolved_expression (Some expr) nat elt_nat\r
3311     | "sign" | "integer" | "ones" | "zeros" ->\r
3312         let nat = PredefinedIdentifier id\r
3313         and elt_nat =\r
3314           let inputs = ["@1", Types.real_component_type Types.Continuous]\r
3315           and outputs = ["@2", Types.integer_component_type Types.Discrete] in\r
3316           Types.function_type inputs outputs in\r
3317         resolved_expression (Some expr) nat elt_nat\r
3318     | "max" | "min" | "div" | "mod" | "rem" | "fill" ->\r
3319         let nat = PredefinedIdentifier id\r
3320         and elt_nat =\r
3321           let inputs =\r
3322             [\r
3323               "@1", Types.real_component_type Types.Continuous;\r
3324               "@2", Types.real_component_type Types.Continuous\r
3325             ]\r
3326           and outputs = ["@3", Types.real_component_type Types.Continuous] in\r
3327           Types.function_type inputs outputs in\r
3328         resolved_expression (Some expr) nat elt_nat\r
3329     | "smooth" ->\r
3330         let nat = PredefinedIdentifier id\r
3331         and elt_nat =\r
3332           let inputs =\r
3333             [\r
3334               "@1", Types.integer_component_type Types.Discrete;\r
3335               "@2", Types.real_component_type Types.Continuous\r
3336             ]\r
3337           and outputs = ["@3", Types.real_component_type Types.Continuous] in\r
3338           Types.function_type inputs outputs in\r
3339         resolved_expression (Some expr) nat elt_nat\r
3340     | "identity" ->\r
3341         let nat = PredefinedIdentifier id\r
3342         and elt_nat =\r
3343           let inputs = [ "@1", Types.integer_component_type Types.Parameter ]\r
3344           and outputs =\r
3345             let dims =\r
3346               [Types.ParameterDimension; Types.ParameterDimension] in\r
3347             [ \r
3348               "@2",\r
3349               Types.integer_array_component_type Types.Parameter dims\r
3350             ] in\r
3351           Types.function_type inputs outputs in\r
3352         resolved_expression (Some expr) nat elt_nat\r
3353     | "diagonal" ->\r
3354         let nat = PredefinedIdentifier id\r
3355         and elt_nat =\r
3356           let inputs =\r
3357             let dim = [ Types.ParameterDimension ] in\r
3358             [ "@1", Types.integer_array_component_type Types.Parameter dim ]\r
3359           and outputs =\r
3360             let dims =\r
3361               [Types.ParameterDimension; Types.ParameterDimension] in\r
3362             [ \r
3363               "@2",\r
3364               Types.integer_array_component_type Types.Parameter dims\r
3365             ] in\r
3366           Types.function_type inputs outputs in\r
3367         resolved_expression (Some expr) nat elt_nat\r
3368     | "sum" | "product" | "scalar" ->\r
3369         let nat = PredefinedIdentifier id\r
3370         and elt_nat =\r
3371           let inputs =\r
3372             let dim = [ Types.DiscreteDimension ] in\r
3373               [ "@1", Types.integer_array_component_type Types.Discrete dim ]\r
3374           and outputs = ["@2", Types.integer_component_type Types.Discrete] in\r
3375           Types.function_type inputs outputs in\r
3376         resolved_expression (Some expr) nat elt_nat\r
3377     | _ -> raise (CompilError\r
3378         {err_msg = ["_UnknownIdentifier"; id];\r
3379          err_info = [];\r
3380          err_ctx = ctx})\r
3381   and search_in_toplevel dic =\r
3382     try\r
3383       let elt_desc = List.assoc id (evaluate dic) in\r
3384       let elt_type = evaluate elt_desc.element_type in\r
3385       match elt_type.Types.dynamic_scope with\r
3386         | None | Some Types.Inner ->\r
3387             let nat = ToplevelIdentifier id in\r
3388             resolved_expression (Some expr) nat elt_type.Types.element_nature\r
3389         | Some Types.Outer | Some Types.InnerOuter ->\r
3390             raise (CompilError\r
3391               {err_msg = ["_NoInnerDeclForOuterElem"; id];\r
3392                err_info = [];\r
3393                err_ctx = ctx}) (*error*)\r
3394     with Not_found -> resolve_predefined_identifier ctx expr id\r
3395   and search_in_class level cl_def = match evaluate cl_def.class_type with\r
3396     | Types.ClassType cl_type -> search_in_class_type level cl_def cl_type\r
3397     | Types.PredefinedType _ | Types.ComponentType _ | Types.ArrayType _ |\r
3398       Types.TupleType _ ->\r
3399         raise (CompilError\r
3400           {err_msg = ["_NoInnerDeclForOuterElem"; id];\r
3401            err_info = [];\r
3402            err_ctx = ctx}) (*error*)\r
3403   and search_in_class_type level cl_def cl_type =\r
3404     try\r
3405       let elt_type = evaluate (List.assoc id cl_type.Types.named_elements) in\r
3406       match elt_type.Types.dynamic_scope with\r
3407           | None | Some Types.Inner ->\r
3408               let nat = LocalIdentifier (level, id) in\r
3409               resolved_expression (Some expr) nat elt_type.Types.element_nature\r
3410           | Some Types.Outer | Some Types.InnerOuter ->\r
3411               let nat = DynamicIdentifier (level, id) in\r
3412               resolved_expression (Some expr) nat elt_type.Types.element_nature\r
3413     with Not_found -> search_in_parent level cl_def\r
3414   and search_in_parent level cl_def = match cl_def.enclosing_class with\r
3415     | _ when cl_def.encapsulated -> search_in_toplevel ctx.toplevel\r
3416     | Some cl_def -> search_in_class (level + 1) cl_def\r
3417     | None -> search_in_toplevel ctx.toplevel\r
3418   and search_in_for_loop_variables level ctx = match ctx.context_nature with\r
3419     | ToplevelContext -> search_in_toplevel ctx.toplevel\r
3420     | ClassContext cl_def -> search_in_class 0 cl_def\r
3421     | SubscriptContext (ctx', _, _, _) ->\r
3422         search_in_for_loop_variables level ctx'\r
3423     | ForContext (_, id', elt_nat) when id' = id ->\r
3424         let nat = LoopVariable level in\r
3425         resolved_expression (Some expr) nat elt_nat\r
3426     | ForContext (ctx', _, _) ->\r
3427         search_in_for_loop_variables (level + 1) ctx' in\r
3428   search_in_for_loop_variables 0 ctx\r
3429 \r
3430 (*and resolve_if ctx expr alts expr' =\r
3431   let expres' = resolve_expression ctx expr' in\r
3432   let elt_nat' = expres'.info.type_description in\r
3433   let rec resolve_alternative (cond, expr) =\r
3434     resolve_condition cond,\r
3435     resolve_alternative_expression expr\r
3436   and resolve_condition cond =\r
3437     let ctx = {ctx with location = cond.Syntax.info} in\r
3438     let cond' = resolve_expression ctx cond in\r
3439     let condition cpnt_type =\r
3440       let cl_spec = evaluate cpnt_type.Types.base_class in\r
3441       match cl_spec with\r
3442         | Types.PredefinedType { Types.base_type = Types.BooleanType } -> cond'\r
3443         | Types.PredefinedType _ | Types.ClassType _ | Types.ComponentType _ |\r
3444           Types.ArrayType _ | Types.TupleType _ -> \r
3445             raise (CompilError\r
3446               {err_msg = ["_NonBooleanIfCondExpr"];\r
3447                err_info =\r
3448                  [("_ExprKind", "...if A then...");\r
3449                   ("_TypeOfA", Types.string_of_class_specifier cl_spec)];\r
3450                err_ctx = ctx}) (*error*) in\r
3451     match cond'.info.type_description with\r
3452       | Types.ComponentElement cpnt_type -> condition cpnt_type\r
3453       | _ -> raise (CompilError\r
3454           {err_msg = ["_ClassElemFoundInExpr"];\r
3455            err_info = [];\r
3456            err_ctx = {ctx with location = cond.Syntax.info}}) (*error*)\r
3457   and resolve_alternative_expression expr =\r
3458     let ctx = {ctx with location = expr.Syntax.info} in\r
3459     let expres = resolve_expression ctx expr in\r
3460     let elt_nat = expres.info.type_description in\r
3461     let display_error elt_nat elt_nat' = match elt_nat, elt_nat' with\r
3462       | Types.ComponentElement cpnt_type, Types.ComponentElement cpnt_type' ->\r
3463           raise (CompilError\r
3464             {err_msg = ["_TypeConflictsInIfAlternExprs"];\r
3465              err_info =\r
3466                [("_TypeOfThenBranche",\r
3467                  Types.string_of_component_type cpnt_type);\r
3468                 ("_TypeOfElseBranche",\r
3469                  Types.string_of_component_type cpnt_type')];\r
3470              err_ctx = ctx}) (*error*)\r
3471       | Types.ComponentElement cpnt_type, _ ->\r
3472           raise (CompilError\r
3473             {err_msg = ["_ClassElemFoundInExpr"];\r
3474              err_info =\r
3475                [("_TypeOfThenBranche",\r
3476                  Types.string_of_component_type cpnt_type);\r
3477                 ("_TypeOfElseBranche", "_ClassElement")];\r
3478              err_ctx = ctx}) (*error*)\r
3479       | _, Types.ComponentElement cpnt_type' ->\r
3480           raise (CompilError\r
3481             {err_msg = ["_ClassElemFoundInExpr"];\r
3482              err_info =\r
3483                [("_TypeOfThenBranche", "_ClassElement");\r
3484                 ("_TypeOfElseBranche",\r
3485                  Types.string_of_component_type cpnt_type')];\r
3486              err_ctx = ctx}) (*error*)\r
3487       | _, _ ->\r
3488           raise (CompilError\r
3489             {err_msg = ["_ClassElemFoundInExpr"];\r
3490              err_info =\r
3491                [("_TypeOfThenBranche", "_ClassElement");\r
3492                 ("_TypeOfElseBranche", "_ClassElement")];\r
3493              err_ctx = ctx}) (*error*) in\r
3494     match Types.compare_element_natures elt_nat elt_nat' with\r
3495     | Types.NotRelated -> display_error elt_nat elt_nat'\r
3496     | _ -> expres in\r
3497   let alts = List.map resolve_alternative alts in\r
3498   let nat = If (alts, expres') in\r
3499   resolved_expression (Some expr) nat elt_nat'*)\r
3500 \r
3501 and resolve_if ctx expr alts expr' =\r
3502   let resolve_data_expression ctx expr =\r
3503     let expr' = resolve_expression ctx expr in\r
3504     match expr'.info.type_description with\r
3505     | Types.ComponentElement cpnt_type -> expr'\r
3506     | _ ->\r
3507         raise (CompilError\r
3508           {err_msg = ["_ClassElemFoundInExpr"];\r
3509            err_info = [];\r
3510            err_ctx = {ctx with location = expr.Syntax.info}}) (*error*) in\r
3511   let resolve_condition cond =\r
3512     let ctx = {ctx with location = cond.Syntax.info} in\r
3513     let cond' = resolve_data_expression ctx cond in\r
3514     let condition cpnt_type =\r
3515       match evaluate cpnt_type.Types.base_class with\r
3516       | Types.PredefinedType { Types.base_type = Types.BooleanType } -> cond'\r
3517       | cl_spec -> \r
3518           raise (CompilError\r
3519             {err_msg = ["_NonBooleanIfCondExpr"];\r
3520              err_info =\r
3521                [("_ExprKind", "...if A then...");\r
3522                 ("_TypeOfA", Types.string_of_class_specifier cl_spec)];\r
3523              err_ctx = ctx}) (*error*) in\r
3524     match cond'.info.type_description with\r
3525     | Types.ComponentElement cpnt_type -> condition cpnt_type\r
3526     | _ ->\r
3527         raise (CompilError\r
3528           {err_msg = ["_DataElemExpected"];\r
3529            err_info = [];\r
3530            err_ctx = ctx}) (*error*) in\r
3531   let resolve_alternatives (alts, expr') (cond, expr) =\r
3532     let ctx = {ctx with location = expr.Syntax.info} in\r
3533     let cond' = resolve_condition cond\r
3534     and expr = resolve_data_expression ctx expr in\r
3535     let exprs = apply_binary_coercions [ expr'; expr] in\r
3536     let expr' = List.nth exprs 0\r
3537     and expr = List.nth exprs 1 in\r
3538     let elt_nat = expr.info.type_description\r
3539     and elt_nat' = expr'.info.type_description in\r
3540     match Types.compare_element_natures elt_nat elt_nat' with\r
3541     | Types.SameType ->\r
3542         (alts @ [cond', expr]), expr'\r
3543     | _ ->\r
3544         raise (CompilError\r
3545           {err_msg = ["_TypeConflictsInIfAlternExprs"];\r
3546            err_info =\r
3547              [("_TypeOfThenBranche",\r
3548                Types.string_of_element_nature elt_nat);\r
3549               ("_TypeOfElseBranche",\r
3550                Types.string_of_element_nature elt_nat')];\r
3551            err_ctx = ctx}) (*error*) in\r
3552   let expr' = resolve_data_expression ctx expr' in\r
3553   let alts, expr' = List.fold_left resolve_alternatives ([], expr') alts in\r
3554   let nat = If (alts, expr') in\r
3555   resolved_expression (Some expr) nat expr'.info.type_description\r
3556 \r
3557 and resolve_indexed_access ctx expr expr' subs =\r
3558   let expres' = resolve_expression ctx expr' in\r
3559   let rec resolve_component_indexed_access cl_spec subs =\r
3560     match cl_spec, subs with\r
3561       | (Types.PredefinedType _ | Types.ClassType _ | Types.ComponentType _ |\r
3562          Types.ArrayType _ | Types.TupleType _), [] -> cl_spec\r
3563       | (Types.PredefinedType _ | Types.ClassType _ | Types.ComponentType _ |\r
3564          Types.TupleType _), _ :: _ ->\r
3565           raise (CompilError\r
3566             {err_msg = ["_CannotSubscriptANonArrayTypeElem"];\r
3567              err_info =\r
3568                [("_ExpectedType", "_ArrayType");\r
3569                 ("_TypeFound", Types.string_of_class_specifier cl_spec)];\r
3570              err_ctx = ctx}) (*error*)\r
3571       | Types.ArrayType (_, cl_spec'), sub :: subs' ->\r
3572           let cl_spec' = resolve_component_indexed_access cl_spec' subs' in\r
3573           subarray_access sub cl_spec'\r
3574   and subarray_access sub cl_spec =\r
3575     let subarray_access' = function\r
3576       | Types.PredefinedType { Types.base_type = Types.IntegerType } -> cl_spec\r
3577       | Types.ArrayType\r
3578           (dim, Types.PredefinedType { Types.base_type = Types.IntegerType }) ->\r
3579           Types.ArrayType (dim, cl_spec)\r
3580       | Types.PredefinedType _ | Types.ClassType _ | Types.ComponentType _ |\r
3581         Types.ArrayType _ | Types.TupleType _ -> assert false (*error*) in\r
3582     match sub.info.type_description with\r
3583       | Types.ComponentElement cpnt_type ->\r
3584           let cl_spec' = evaluate cpnt_type.Types.base_class in\r
3585           subarray_access' cl_spec'\r
3586       | Types.ClassElement _ | Types.ComponentTypeElement _ |\r
3587         Types.PredefinedTypeElement _ -> assert false (*error*) in\r
3588   match expres'.info.type_description with\r
3589     | Types.ComponentElement cpnt_type ->\r
3590         let cl_spec = evaluate cpnt_type.Types.base_class in\r
3591         let subs' = resolve_subscripts ctx expres' cl_spec subs in\r
3592         let cpnt_type' = \r
3593           { cpnt_type with\r
3594             Types.base_class =\r
3595               lazy (resolve_component_indexed_access cl_spec subs')\r
3596           } in\r
3597         let info =\r
3598           {\r
3599             syntax = Some expr;\r
3600             type_description = Types.ComponentElement cpnt_type'\r
3601           } in\r
3602         { nature = IndexedAccess (expres', subs'); info = info }\r
3603     | Types.ClassElement _ | Types.ComponentTypeElement _ |\r
3604       Types.PredefinedTypeElement _ ->\r
3605         raise (CompilError\r
3606           {err_msg = ["_ClassElemFoundInExpr"];\r
3607            err_info = [];\r
3608            err_ctx = ctx}) (*error*)\r
3609 \r
3610 and resolve_integer ctx expr s =\r
3611   let nat =\r
3612     try\r
3613       Integer (Int32.of_string s)\r
3614     with\r
3615     | _ ->\r
3616         raise (CompilError\r
3617           {err_msg = ["_InvalidInteger"; s];\r
3618            err_info = [];\r
3619            err_ctx = ctx}) in\r
3620   resolved_expression (Some expr) nat (Types.integer_type Types.Constant)\r
3621 \r
3622 and resolve_matrix_construction ctx expr exprss =\r
3623   raise (CompilError\r
3624     {err_msg = ["_NotYetImplemented"; "_MatrixExpr"];\r
3625      err_info = [];\r
3626      err_ctx = ctx})\r
3627 \r
3628 and resolve_no_event ctx expr expr' =\r
3629   let expr' = resolve_expression ctx expr' in\r
3630   match expr'.info.type_description with\r
3631   | Types.ComponentElement cpnt_type ->\r
3632       let nat = NoEvent expr'\r
3633       and flow = lazy (evaluate cpnt_type.Types.flow)\r
3634       and var = lazy Types.Continuous\r
3635       and inout = cpnt_type.Types.causality\r
3636       and cl_spec = cpnt_type.Types.base_class in\r
3637       let cpnt_type =\r
3638         component_element flow var inout cl_spec in\r
3639       let elt_nat = Types.ComponentElement cpnt_type in\r
3640       resolved_expression (Some expr) nat elt_nat\r
3641   | _ ->\r
3642       raise (CompilError\r
3643         {err_msg = ["_ClassElemFoundInExpr"];\r
3644          err_info = [];\r
3645          err_ctx = ctx}) (*error*)\r
3646 \r
3647 and resolve_range ctx expr start step stop =\r
3648   let integer_range var start' step' stop' =\r
3649     let integer_range' =\r
3650       match start'.nature, step'.nature, stop'.nature with\r
3651       | _, _, _ when Types.higher_variability var Types.Discrete ->\r
3652           let var = Types.string_of_variability var in\r
3653           raise (CompilError\r
3654             {err_msg = ["_InvalidVarOfRangeExpr"];\r
3655              err_info = [("_Expr", Syntax.string_of_range start step stop);\r
3656                          ("_ExpectedVariability", "parameter");\r
3657                          ("_VariabilityFound", var)];\r
3658              err_ctx = ctx}) \r
3659       | Integer i, Integer p, Integer j when p = Int32.zero ->\r
3660           raise (CompilError\r
3661             {err_msg = ["_RangeStepValueCannotBeNull"];\r
3662              err_info = [("_Expr", Syntax.string_of_range start step stop)];\r
3663              err_ctx = ctx})\r
3664       | Integer i, Integer p, Integer j ->\r
3665           let dim = Int32.div (Int32.succ (Int32.sub j i)) p in\r
3666           Types.integer_array_type var (Types.ConstantDimension dim)\r
3667       | (Integer _ | DynamicIdentifier _ | LocalIdentifier _ |\r
3668          LoopVariable _ | PredefinedIdentifier _ | ToplevelIdentifier _),\r
3669         (Integer _ | DynamicIdentifier _ | LocalIdentifier _ |\r
3670          LoopVariable _ | PredefinedIdentifier _ | ToplevelIdentifier _),\r
3671         (Integer _ | DynamicIdentifier _ | LocalIdentifier _ |\r
3672          LoopVariable _ | PredefinedIdentifier _ | ToplevelIdentifier _) ->\r
3673           Types.integer_array_type var Types.ParameterDimension\r
3674       | _, _, _ ->\r
3675           raise (CompilError\r
3676             {err_msg = ["_NotYetImplemented"; "_NonIntegerRangeExpr"];\r
3677              err_info = [("_Expr", Syntax.string_of_range start step stop)];\r
3678              err_ctx = ctx}) in\r
3679     let nat = Range (start', step', stop') in\r
3680     let elt_nat = integer_range' in\r
3681     resolved_expression (Some expr) nat elt_nat in\r
3682   let start' = resolve_expression ctx start\r
3683   and step' = match step with\r
3684     | None -> one\r
3685     | Some expr -> resolve_expression ctx expr\r
3686   and stop' = resolve_expression ctx stop in\r
3687   let resolve_range' var start_cl_spec step_cl_spec stop_cl_spec =\r
3688     match start_cl_spec, step_cl_spec, stop_cl_spec with\r
3689       | Types.PredefinedType { Types.base_type = Types.IntegerType },\r
3690         Types.PredefinedType { Types.base_type = Types.IntegerType },\r
3691         Types.PredefinedType { Types.base_type = Types.IntegerType } ->\r
3692           integer_range var start' step' stop'\r
3693       (*| Types.PredefinedType { Types.base_type = Types.IntegerType },\r
3694         Types.PredefinedType { Types.base_type = Types.IntegerType },\r
3695         _ -> assert false*)\r
3696       | _ -> raise (CompilError\r
3697           {err_msg = ["_NotYetImplemented"; "_NonIntegerRangeExpr"];\r
3698            err_info = [("_Expr", Syntax.string_of_range start step stop)];\r
3699            err_ctx = ctx}) in\r
3700   let start_elt_nat = start'.info.type_description\r
3701   and step_elt_nat = step'.info.type_description\r
3702   and stop_elt_nat = stop'.info.type_description in\r
3703   match start_elt_nat, step_elt_nat, stop_elt_nat with\r
3704     | Types.ComponentElement start_cpnt_type,\r
3705       Types.ComponentElement step_cpnt_type,\r
3706       Types.ComponentElement stop_cpnt_type ->\r
3707         let start_cl_spec = evaluate start_cpnt_type.Types.base_class\r
3708         and step_cl_spec = evaluate step_cpnt_type.Types.base_class\r
3709         and stop_cl_spec = evaluate stop_cpnt_type.Types.base_class\r
3710         and start_var = evaluate start_cpnt_type.Types.variability\r
3711         and step_var = evaluate step_cpnt_type.Types.variability\r
3712         and stop_var = evaluate stop_cpnt_type.Types.variability in\r
3713         let var =\r
3714           let var' = Types.max_variability step_var stop_var in\r
3715           Types.max_variability start_var var' in\r
3716         resolve_range' var start_cl_spec step_cl_spec stop_cl_spec\r
3717     | _ -> raise (CompilError\r
3718         {err_msg = ["_InvalidTypeInRangeExpr"];\r
3719          err_info = [("_Expr", Syntax.string_of_range start step stop)];\r
3720          err_ctx = ctx}) (*error*)\r
3721 \r
3722 and resolve_real ctx expr s =\r
3723   let nat = Real (float_of_string s) in\r
3724   resolved_expression (Some expr) nat (Types.real_type Types.Constant)\r
3725 \r
3726 and resolve_string ctx expr s =\r
3727   resolved_expression (Some expr) (String s) (Types.string_type Types.Constant)\r
3728 \r
3729 and resolve_true ctx expr =\r
3730   resolved_expression (Some expr) True (Types.boolean_type Types.Constant)\r
3731 \r
3732 and resolve_tuple ctx expr exprs =\r
3733   let max_element_variability var expr expr' =\r
3734     match expr'.info.type_description with\r
3735       | Types.ComponentElement cpnt_type ->\r
3736           let var' = evaluate cpnt_type.Types.variability in\r
3737           Types.max_variability var var'\r
3738       | Types.ClassElement _ | Types.ComponentTypeElement _ |\r
3739         Types.PredefinedTypeElement _ ->\r
3740           raise (CompilError\r
3741             {err_msg = ["_ClassElemFoundInExpr"];\r
3742              err_info = [];\r
3743              err_ctx = ctx}) (*error*)\r
3744   and class_specifier expr expr' =\r
3745     match expr'.info.type_description with\r
3746       | Types.ComponentElement cpnt_type -> evaluate cpnt_type.Types.base_class\r
3747       | Types.ClassElement _ | Types.ComponentTypeElement _ |\r
3748         Types.PredefinedTypeElement _ ->\r
3749           raise (CompilError\r
3750             {err_msg = ["_ClassElemFoundInExpr"];\r
3751              err_info = [];\r
3752              err_ctx = ctx}) (*error*) in\r
3753   let exprs' = List.map (resolve_expression ctx) exprs in\r
3754   let flow = lazy false\r
3755   and var =\r
3756     lazy (List.fold_left2 max_element_variability Types.Constant exprs exprs')\r
3757   and inout = lazy Types.Acausal\r
3758   and cl_spec = lazy (Types.TupleType (List.map2 class_specifier exprs exprs')) in\r
3759   {\r
3760     nature = Tuple exprs';\r
3761     info =\r
3762       {\r
3763         syntax = Some expr;\r
3764         type_description =\r
3765           Types.ComponentElement (component_element flow var inout cl_spec)\r
3766       }\r
3767   }\r
3768 \r
3769 and resolve_unuary_operation ctx expr kind arg =\r
3770   let arg' = resolve_expression ctx arg in\r
3771   match kind.Syntax.nature with\r
3772     | Syntax.UnaryMinus -> resolve_unary_minus ctx expr arg'\r
3773     | Syntax.Not -> resolve_not ctx expr arg'\r
3774     | Syntax.UnaryPlus ->\r
3775         raise (CompilError\r
3776           {err_msg = ["_NotYetImplemented"; "_UnaryOperPLUS"];\r
3777            err_info = [];\r
3778            err_ctx = ctx})\r
3779 \r
3780 and resolve_vector ctx expr vec_elts = match vec_elts.Syntax.nature with\r
3781   | Syntax.VectorReduction (expr', for_inds) ->\r
3782       resolve_vector_reduction ctx expr expr' for_inds\r
3783   | Syntax.VectorElements exprs -> resolve_vector_elements ctx expr exprs\r
3784 \r
3785 and resolve_vector_reduction ctx expr expr' for_inds =\r
3786   let vector_reduction_type acc expr expr' =\r
3787     let add_dimension elt_nat cl_spec =\r
3788       let add_dimension' cl_spec' = match cl_spec' with\r
3789         | Types.ArrayType (dim, _) -> Types.ArrayType (dim, cl_spec)\r
3790         | Types.PredefinedType _ | Types.ClassType _ |\r
3791           Types.ComponentType _ | Types.TupleType _ -> \r
3792             raise (CompilError\r
3793               {err_msg = ["_InvalidTypeInRangeExpr"];\r
3794                err_info =\r
3795                  [("_ExpectedType", "_ArrayType");\r
3796                   ("_TypeFound",\r
3797                    Types.string_of_class_specifier cl_spec')];\r
3798                err_ctx = ctx}) (*error*) in\r
3799       match elt_nat with\r
3800         | Types.ComponentElement cpnt_type ->\r
3801             let cl_spec' = evaluate cpnt_type.Types.base_class in\r
3802             add_dimension' cl_spec'\r
3803         | Types.ClassElement _ | Types.ComponentTypeElement _ |\r
3804           Types.PredefinedTypeElement _ ->\r
3805             raise (CompilError\r
3806               {err_msg = ["_ClassElemFoundInExpr"];\r
3807                err_info = [];\r
3808                err_ctx = ctx}) (*error*) in\r
3809     let rec vector_reduction_type' acc cl_spec = match acc with\r
3810       | [] -> cl_spec\r
3811       | range :: acc ->\r
3812           let elt_nat = range.info.type_description in\r
3813           let cl_spec' = add_dimension elt_nat cl_spec in\r
3814           vector_reduction_type' acc cl_spec' in\r
3815     match expr'.info.type_description with\r
3816       | Types.ComponentElement cpnt_type ->\r
3817           let cl_spec = evaluate cpnt_type.Types.base_class in\r
3818           let cpnt_type' =\r
3819             { cpnt_type with\r
3820               Types.base_class = lazy (vector_reduction_type' acc cl_spec)\r
3821             } in\r
3822           Types.ComponentElement cpnt_type'\r
3823       | Types.ClassElement _ | Types.ComponentTypeElement _ |\r
3824         Types.PredefinedTypeElement _ ->\r
3825           raise (CompilError\r
3826             {err_msg = ["_ClassElemFoundInExpr"];\r
3827              err_info = [];\r
3828              err_ctx = ctx}) (*error*)\r
3829   and range_element_type range range' =\r
3830     let sub_dimension cl_spec = match cl_spec with\r
3831       | Types.ArrayType (dim, cl_spec) -> cl_spec\r
3832       | Types.PredefinedType _ | Types.ClassType _ |\r
3833         Types.ComponentType _ | Types.TupleType _ -> \r
3834           raise (CompilError\r
3835             {err_msg = ["_InvalidTypeInRangeExpr"];\r
3836              err_info =\r
3837                [("_ExpectedType", "_ArrayType");\r
3838                 ("_TypeFound", Types.string_of_class_specifier cl_spec)];\r
3839              err_ctx = ctx}) (*error*) in\r
3840     match range'.info.type_description with\r
3841       | Types.ComponentElement cpnt_type ->\r
3842           let cl_spec = evaluate cpnt_type.Types.base_class in\r
3843           let cpnt_type' =\r
3844             { cpnt_type with\r
3845               Types.base_class = lazy (sub_dimension cl_spec)\r
3846             } in\r
3847           Types.ComponentElement cpnt_type'\r
3848       | Types.ClassElement _ | Types.ComponentTypeElement _ |\r
3849         Types.PredefinedTypeElement _ ->\r
3850           raise (CompilError\r
3851             {err_msg = ["_ClassElemFoundInExpr"];\r
3852              err_info = [];\r
3853              err_ctx = ctx}) (*error*) in\r
3854   let rec resolve_vector_reduction' acc ctx = function\r
3855     | [] ->\r
3856         let expres' = resolve_expression ctx expr' in\r
3857         let nat = VectorReduction (List.rev acc, expres')\r
3858         and elt_nat = vector_reduction_type acc expr' expres' in\r
3859         resolved_expression (Some expr) nat elt_nat\r
3860     | (_, None) :: _ ->\r
3861         raise (CompilError\r
3862           {err_msg = ["_NotYetImplemented"; "_ImplicitIterRange"];\r
3863            err_info = [("_Expr", Syntax.string_of_for_inds for_inds)];\r
3864            err_ctx = ctx})\r
3865     | (id, Some range) :: for_inds ->\r
3866         let range' = resolve_expression ctx range in\r
3867         let elt_nat = range_element_type range range' in\r
3868         let ctx' =\r
3869           { ctx with\r
3870             context_nature = ForContext (ctx, id, elt_nat)\r
3871           } in\r
3872         resolve_vector_reduction' (range' :: acc) ctx' for_inds in\r
3873   resolve_vector_reduction' [] ctx for_inds\r
3874 \r
3875 and resolve_vector_elements ctx expr exprs =\r
3876   let max_variability var cpnt_type =\r
3877     let var' = evaluate cpnt_type.Types.variability in\r
3878     Types.max_variability var var' in\r
3879   let type_of_elements cpnt_types =\r
3880     let rec type_of_elements' cl_spec = function\r
3881       | [] -> cl_spec\r
3882       | cpnt_type :: cpnt_types ->\r
3883           let cl_spec' = evaluate cpnt_type.Types.base_class in\r
3884           type_of_elements' (update cl_spec cl_spec') cpnt_types\r
3885     and update cl_spec cl_spec' =\r
3886       match Types.compare_specifiers cl_spec cl_spec' with\r
3887       | Types.SameType | Types.Supertype -> cl_spec\r
3888       | Types.Subtype -> cl_spec'\r
3889       | _ ->\r
3890           raise (CompilError\r
3891             {err_msg = ["_TypeConflictsInVectorExpr"];\r
3892              err_info =\r
3893                [("_MismatchingTypes",\r
3894                  Types.string_of_class_specifier cl_spec ^ ", " ^\r
3895                  Types.string_of_class_specifier cl_spec')];\r
3896              err_ctx = ctx}) in\r
3897     match cpnt_types with\r
3898       | [] -> assert false (*error*)\r
3899       | cpnt_type :: cpnt_types ->\r
3900           let cl_spec' = evaluate cpnt_type.Types.base_class in\r
3901           type_of_elements' cl_spec' cpnt_types in\r
3902   let exprs' = List.map (resolve_expression ctx) exprs in\r
3903   let exprs' = apply_binary_coercions exprs' in\r
3904   let cpnt_types = List.map (component_type_of_expression ctx) exprs' in\r
3905   let var = lazy (List.fold_left max_variability Types.Constant cpnt_types) in\r
3906   let cl_spec = type_of_elements cpnt_types in\r
3907   let dim = Types.ConstantDimension (Int32.of_int (List.length exprs')) in\r
3908   let cl_spec' = lazy (Types.ArrayType (dim, cl_spec)) in\r
3909   let cpnt_type =\r
3910     {\r
3911       Types.flow = lazy false;\r
3912             variability = var;\r
3913             causality = lazy Types.Acausal;\r
3914             base_class = cl_spec'\r
3915     } in\r
3916   let nat = Vector exprs'\r
3917   and elt_nat = Types.ComponentElement cpnt_type in\r
3918   resolved_expression (Some expr) nat elt_nat\r
3919 \r
3920 and resolve_and ctx expr arg arg' =\r
3921   let resolve_and' cpnt_type cpnt_type' =\r
3922     let rec and_type cl_spec cl_spec' = match cl_spec, cl_spec' with\r
3923       | Types.PredefinedType { Types.base_type = Types.BooleanType },\r
3924         Types.PredefinedType { Types.base_type = Types.BooleanType } ->\r
3925           Types.PredefinedType\r
3926             { Types.base_type = Types.BooleanType; attributes = [] }\r
3927       | Types.PredefinedType { Types.base_type = Types.BooleanType },\r
3928         (Types.PredefinedType _ | Types.ClassType _ | Types.ComponentType _ |\r
3929          Types.ArrayType _ | Types.TupleType _) ->\r
3930           raise (CompilError\r
3931             {err_msg = ["and"; "_OperAppliedToNonBoolExpr"];\r
3932              err_info =\r
3933                [("_ExpectedType", "Boolean");\r
3934                 ("_TypeFound", Types.string_of_class_specifier cl_spec')];\r
3935              err_ctx = ctx}) (*error*)\r
3936       | (Types.PredefinedType _ | Types.ClassType _ | Types.ComponentType _ |\r
3937          Types.ArrayType _ | Types.TupleType _),\r
3938         (Types.PredefinedType _ | Types.ClassType _ | Types.ComponentType _ |\r
3939          Types.ArrayType _ | Types.TupleType _) ->\r
3940           raise (CompilError\r
3941             {err_msg = ["and"; "_OperAppliedToNonBoolExpr"];\r
3942              err_info =\r
3943                [("_ExpectedType", "Boolean");\r
3944                 ("_TypeFound", Types.string_of_class_specifier cl_spec)];\r
3945              err_ctx = ctx}) (*error*) in\r
3946     let var =\r
3947       lazy (\r
3948         let var = evaluate cpnt_type.Types.variability\r
3949         and var' = evaluate cpnt_type'.Types.variability in\r
3950         Types.max_variability var var')\r
3951     and inout = Types.Acausal\r
3952     and cl_spec =\r
3953       lazy (\r
3954         let cl_spec = evaluate cpnt_type.Types.base_class\r
3955         and cl_spec' = evaluate cpnt_type'.Types.base_class in\r
3956         and_type cl_spec cl_spec') in\r
3957     let nat = BinaryOperation (And, arg, arg') in\r
3958     let elt_nat =\r
3959       let cpnt_type =\r
3960         component_element (lazy false) var (lazy inout) cl_spec in\r
3961       Types.ComponentElement cpnt_type in\r
3962     resolved_expression (Some expr) nat elt_nat in\r
3963   match arg.info.type_description, arg'.info.type_description with\r
3964     | Types.ComponentElement cpnt_type, Types.ComponentElement cpnt_type' ->\r
3965         resolve_and' cpnt_type cpnt_type'\r
3966     | Types.ComponentElement _,\r
3967       (Types.ClassElement _ | Types.ComponentTypeElement _ |\r
3968        Types.PredefinedTypeElement _) ->\r
3969         raise (CompilError\r
3970           {err_msg = ["_ClassElemFoundInExpr"];\r
3971            err_info = [];\r
3972            err_ctx = ctx}) (*error*)\r
3973     | (Types.ClassElement _ | Types.ComponentTypeElement _ |\r
3974        Types.PredefinedTypeElement _),\r
3975       (Types.ComponentElement _ | Types.ClassElement _ |\r
3976        Types.ComponentTypeElement _ | Types.PredefinedTypeElement _) ->\r
3977         raise (CompilError\r
3978           {err_msg = ["_ClassElemFoundInExpr"];\r
3979            err_info = [];\r
3980            err_ctx = ctx}) (*error*)\r
3981 \r
3982 and resolve_or ctx expr arg arg' =\r
3983   let resolve_or' cpnt_type cpnt_type' =\r
3984     let rec or_type cl_spec cl_spec' = match cl_spec, cl_spec' with\r
3985       | Types.PredefinedType { Types.base_type = Types.BooleanType },\r
3986         Types.PredefinedType { Types.base_type = Types.BooleanType } ->\r
3987           Types.PredefinedType\r
3988             { Types.base_type = Types.BooleanType; attributes = [] }\r
3989       | Types.PredefinedType { Types.base_type = Types.BooleanType },\r
3990         (Types.PredefinedType _ | Types.ClassType _ | Types.ComponentType _ |\r
3991          Types.ArrayType _ | Types.TupleType _) ->\r
3992           raise (CompilError\r
3993             {err_msg = ["or"; "_OperAppliedToNonBoolExpr"];\r
3994              err_info =\r
3995                [("_ExpectedType", "Boolean");\r
3996                 ("_TypeFound", Types.string_of_class_specifier cl_spec')];\r
3997              err_ctx = ctx}) (*error*)\r
3998       | (Types.PredefinedType _ | Types.ClassType _ | Types.ComponentType _ |\r
3999          Types.ArrayType _ | Types.TupleType _),\r
4000         (Types.PredefinedType _ | Types.ClassType _ | Types.ComponentType _ |\r
4001          Types.ArrayType _ | Types.TupleType _) ->\r
4002           raise (CompilError\r
4003             {err_msg = ["or"; "_OperAppliedToNonBoolExpr"];\r
4004              err_info =\r
4005                [("_ExpectedType", "Boolean");\r
4006                 ("_TypeFound", Types.string_of_class_specifier cl_spec)];\r
4007              err_ctx = ctx}) (*error*) in\r
4008     let var =\r
4009       lazy (let var = evaluate cpnt_type.Types.variability\r
4010         and var' = evaluate cpnt_type'.Types.variability in\r
4011         Types.max_variability var var')\r
4012     and inout = Types.Acausal\r
4013     and cl_spec =\r
4014       lazy (let cl_spec = evaluate cpnt_type.Types.base_class\r
4015         and cl_spec' = evaluate cpnt_type'.Types.base_class in\r
4016         or_type cl_spec cl_spec') in\r
4017     let nat = BinaryOperation (Or, arg, arg') in\r
4018     let elt_nat =\r
4019       let cpnt_type =\r
4020         component_element (lazy false) var (lazy inout) cl_spec in\r
4021       Types.ComponentElement cpnt_type in\r
4022     resolved_expression (Some expr) nat elt_nat in\r
4023   match arg.info.type_description, arg'.info.type_description with\r
4024     | Types.ComponentElement cpnt_type, Types.ComponentElement cpnt_type' ->\r
4025         resolve_or' cpnt_type cpnt_type'\r
4026     | (Types.ComponentElement _ | Types.ClassElement _ |\r
4027        Types.ComponentTypeElement _ | Types.PredefinedTypeElement _),\r
4028       (Types.ComponentElement _ | Types.ClassElement _ |\r
4029        Types.ComponentTypeElement _ | Types.PredefinedTypeElement _) ->\r
4030         raise (CompilError\r
4031           {err_msg = ["_ClassElemFoundInExpr"];\r
4032            err_info = [];\r
4033            err_ctx = ctx}) (*error*)\r
4034 \r
4035 and resolve_addition ctx expr arg arg' =\r
4036   let resolve_addition' cpnt_type cpnt_type' =\r
4037     let rec addition_type cl_spec cl_spec' = match cl_spec, cl_spec' with\r
4038       | Types.ArrayType (Types.ConstantDimension n, _),\r
4039         Types.ArrayType (Types.ConstantDimension n', _) when n <> n' ->\r
4040           raise (CompilError\r
4041             {err_msg = ["_ArrayDimMustAgreeToPerform"; "_Addition"];\r
4042              err_info =\r
4043                [("_ExprKind", "A + B");\r
4044                 ("_TypeOfA", Types.string_of_class_specifier cl_spec);\r
4045                 ("_TypeOfB", Types.string_of_class_specifier cl_spec')];\r
4046              err_ctx = ctx}) (*error*)\r
4047       | Types.ArrayType (Types.ConstantDimension _, cl_spec),\r
4048         Types.ArrayType (dim, cl_spec') |\r
4049         Types.ArrayType (dim, cl_spec),\r
4050         Types.ArrayType (Types.ConstantDimension _, cl_spec') ->\r
4051           Types.ArrayType (dim, addition_type cl_spec cl_spec')\r
4052       | Types.ArrayType (Types.ParameterDimension, cl_spec),\r
4053         Types.ArrayType (dim, cl_spec') |\r
4054         Types.ArrayType (dim, cl_spec),\r
4055         Types.ArrayType (Types.ParameterDimension, cl_spec') ->\r
4056           Types.ArrayType (dim, addition_type cl_spec cl_spec')\r
4057       | Types.ArrayType (Types.DiscreteDimension, cl_spec),\r
4058         Types.ArrayType (Types.DiscreteDimension, cl_spec') ->\r
4059           Types.ArrayType\r
4060             (Types.DiscreteDimension, addition_type cl_spec cl_spec')\r
4061       | Types.PredefinedType { Types.base_type = Types.IntegerType },\r
4062         Types.PredefinedType { Types.base_type = Types.IntegerType } ->\r
4063           Types.PredefinedType\r
4064             { Types.base_type = Types.IntegerType; attributes = [] }\r
4065       | Types.PredefinedType\r
4066           { Types.base_type = Types.RealType | Types.IntegerType },\r
4067         Types.PredefinedType\r
4068           { Types.base_type = Types.RealType | Types.IntegerType } ->\r
4069           Types.PredefinedType\r
4070             { Types.base_type = Types.RealType; attributes = [] }\r
4071       | Types.PredefinedType _, Types.ArrayType _ \r
4072       | Types.ArrayType _, Types.PredefinedType _ -> \r
4073           raise (CompilError\r
4074             {err_msg = ["+"; "_OperBetweenScalarAndArray"];\r
4075              err_info =\r
4076                [("_ExprKind", "A + B");\r
4077                 ("_TypeOfA", Types.string_of_class_specifier cl_spec);\r
4078                 ("_TypeOfB", Types.string_of_class_specifier cl_spec')];\r
4079              err_ctx = ctx}) (*error*)\r
4080       | _, _ -> \r
4081           raise (CompilError\r
4082             {err_msg = ["+"; "_OperAppliedToNonNumericExpr"];\r
4083              err_info =\r
4084                [("_ExprKind", "A + B");\r
4085                 ("_TypeOfA", Types.string_of_class_specifier cl_spec);\r
4086                 ("_TypeOfB", Types.string_of_class_specifier cl_spec')];\r
4087              err_ctx = ctx}) (*error*) in\r
4088     let var =\r
4089       lazy (let var = evaluate cpnt_type.Types.variability\r
4090         and var' = evaluate cpnt_type'.Types.variability in\r
4091         Types.max_variability var var')\r
4092     and inout = Types.Acausal\r
4093     and cl_spec =\r
4094       lazy (let cl_spec = evaluate cpnt_type.Types.base_class\r
4095         and cl_spec' = evaluate cpnt_type'.Types.base_class in\r
4096         addition_type cl_spec cl_spec') in\r
4097     let nat = BinaryOperation (Plus, arg, arg') in\r
4098     let elt_nat =\r
4099       let cpnt_type =\r
4100         component_element (lazy false) var (lazy inout) cl_spec in\r
4101       Types.ComponentElement cpnt_type in\r
4102     resolved_expression (Some expr) nat elt_nat in\r
4103   match arg.info.type_description, arg'.info.type_description with\r
4104     | Types.ComponentElement cpnt_type, Types.ComponentElement cpnt_type' ->\r
4105         resolve_addition' cpnt_type cpnt_type'\r
4106     | (Types.ComponentElement _ | Types.ClassElement _ |\r
4107        Types.ComponentTypeElement _ | Types.PredefinedTypeElement _),\r
4108       (Types.ComponentElement _ | Types.ClassElement _ |\r
4109        Types.ComponentTypeElement _ | Types.PredefinedTypeElement _) ->\r
4110         raise (CompilError\r
4111             {err_msg = ["_ClassElemFoundInExpr"];\r
4112              err_info = [];\r
4113              err_ctx = ctx}) (*error*)\r
4114 \r
4115 and resolve_comparison ctx expr kind arg arg' =\r
4116   let resolve_comparison' cpnt_type cpnt_type' =\r
4117     let rec comparison_type cl_spec cl_spec' = match cl_spec, cl_spec' with\r
4118       | Types.PredefinedType\r
4119           { Types.base_type = Types.IntegerType | Types.RealType },\r
4120         Types.PredefinedType\r
4121           { Types.base_type = Types.IntegerType | Types.RealType } ->\r
4122           Types.PredefinedType\r
4123             { Types.base_type = Types.BooleanType; attributes = [] }\r
4124       | (Types.PredefinedType _ | Types.ClassType _ | Types.ComponentType _ |\r
4125          Types.ArrayType _ | Types.TupleType _),\r
4126         (Types.PredefinedType _ | Types.ClassType _ | Types.ComponentType _ |\r
4127          Types.ArrayType _ | Types.TupleType _) ->\r
4128           raise (CompilError\r
4129             {err_msg = ["_TypeInconsistWithComparOper"];\r
4130              err_info =\r
4131                [("_ExprKind", "A" ^ (string_of_bin_oper_kind kind) ^ "B");\r
4132                 ("_TypeOfA", Types.string_of_class_specifier cl_spec);\r
4133                 ("_TypeOfB", Types.string_of_class_specifier cl_spec')];\r
4134              err_ctx = ctx}) (*error*) in\r
4135     (*let var =\r
4136       let var = evaluate cpnt_type.Types.variability\r
4137       and var' = evaluate cpnt_type'.Types.variability in\r
4138         Types.max_variability var var'*)\r
4139     let var = Types.Discrete\r
4140     and inout = Types.Acausal\r
4141     and cl_spec =\r
4142       lazy (let cl_spec = evaluate cpnt_type.Types.base_class\r
4143         and cl_spec' = evaluate cpnt_type'.Types.base_class in\r
4144         comparison_type cl_spec cl_spec') in\r
4145     let nat = BinaryOperation (kind, arg, arg') in\r
4146     let elt_nat =\r
4147       let cpnt_type =\r
4148         component_element (lazy false) (lazy var) (lazy inout) cl_spec in\r
4149       Types.ComponentElement cpnt_type in\r
4150     resolved_expression (Some expr) nat elt_nat in\r
4151   match arg.info.type_description, arg'.info.type_description with\r
4152     | Types.ComponentElement cpnt_type, Types.ComponentElement cpnt_type' ->\r
4153         resolve_comparison' cpnt_type cpnt_type'\r
4154     | (Types.ComponentElement _ | Types.ClassElement _ |\r
4155        Types.ComponentTypeElement _ | Types.PredefinedTypeElement _),\r
4156       (Types.ComponentElement _ | Types.ClassElement _ |\r
4157        Types.ComponentTypeElement _ | Types.PredefinedTypeElement _) ->\r
4158         raise (CompilError\r
4159           {err_msg = ["_ClassElemFoundInExpr"];\r
4160            err_info = [];\r
4161            err_ctx = ctx}) (*error*)\r
4162 \r
4163 and resolve_division ctx expr arg arg' =\r
4164   let resolve_division' cpnt_type cpnt_type' =\r
4165     let rec division_type cl_spec cl_spec' = match cl_spec, cl_spec' with\r
4166       | Types.ArrayType (dim, cl_spec),\r
4167         Types.PredefinedType\r
4168           { Types.base_type = Types.IntegerType | Types.RealType } ->\r
4169           Types.ArrayType (dim, division_type cl_spec cl_spec')\r
4170       | Types.PredefinedType\r
4171           { Types.base_type = Types.RealType | Types.IntegerType },\r
4172         Types.PredefinedType\r
4173           { Types.base_type = Types.RealType | Types.IntegerType } ->\r
4174           Types.PredefinedType\r
4175             { Types.base_type = Types.RealType; attributes = [] }\r
4176       | (Types.PredefinedType _ | Types.ClassType _ | Types.ComponentType _ |\r
4177          Types.ArrayType _ | Types.TupleType _),\r
4178         (Types.PredefinedType _ | Types.ClassType _ | Types.ComponentType _ |\r
4179          Types.ArrayType _ | Types.TupleType _) ->\r
4180           raise (CompilError\r
4181             {err_msg = ["_TypeInconsistentWithDivOper"];\r
4182              err_info =\r
4183                [("_ExprKind", "A / B");\r
4184                 ("_TypeOfA", Types.string_of_class_specifier cl_spec);\r
4185                 ("_TypeOfB", Types.string_of_class_specifier cl_spec')];\r
4186              err_ctx = ctx}) (*error*) in\r
4187     let var =\r
4188       lazy (let var = evaluate cpnt_type.Types.variability\r
4189         and var' = evaluate cpnt_type'.Types.variability in\r
4190         Types.max_variability var var')\r
4191     and inout = Types.Acausal\r
4192     and cl_spec =\r
4193       lazy (let cl_spec = evaluate cpnt_type.Types.base_class\r
4194         and cl_spec' = evaluate cpnt_type'.Types.base_class in\r
4195         division_type cl_spec cl_spec') in\r
4196     let nat = BinaryOperation (Divide, arg, arg') in\r
4197     let elt_nat =\r
4198       let cpnt_type =\r
4199         component_element (lazy false) var (lazy inout) cl_spec in\r
4200       Types.ComponentElement cpnt_type in\r
4201     resolved_expression (Some expr) nat elt_nat in\r
4202   match arg.info.type_description, arg'.info.type_description with\r
4203     | Types.ComponentElement cpnt_type, Types.ComponentElement cpnt_type' ->\r
4204         resolve_division' cpnt_type cpnt_type'\r
4205     | (Types.ComponentElement _ | Types.ClassElement _ |\r
4206        Types.ComponentTypeElement _ | Types.PredefinedTypeElement _),\r
4207       (Types.ComponentElement _ | Types.ClassElement _ |\r
4208        Types.ComponentTypeElement _ | Types.PredefinedTypeElement _) ->\r
4209         raise (CompilError\r
4210           {err_msg = ["_ClassElemFoundInExpr"];\r
4211            err_info = [];\r
4212            err_ctx = ctx}) (*error*)\r
4213 \r
4214 and resolve_multiplication ctx expr arg arg' =\r
4215   let resolve_multiplication' cpnt_type cpnt_type' =\r
4216     let rec multiplication_type cl_spec cl_spec' = match cl_spec, cl_spec' with\r
4217       | Types.ArrayType (_, Types.ArrayType (Types.ConstantDimension n, _)),\r
4218         Types.ArrayType (Types.ConstantDimension n', Types.ArrayType _)\r
4219         when n <> n' ->\r
4220           raise (CompilError\r
4221             {err_msg = ["_ArrayDimsNonCompatibleWithMult"];\r
4222              err_info =\r
4223                [("_ExprKind", "A * B");\r
4224                 ("_TypeOfA", Types.string_of_component_type cpnt_type);\r
4225                 ("_TypeOfB", Types.string_of_component_type cpnt_type')];\r
4226              err_ctx = ctx})  (*error*)\r
4227       | Types.ArrayType\r
4228           (dim, Types.ArrayType\r
4229             (_, Types.PredefinedType\r
4230               { Types.base_type = Types.IntegerType })),\r
4231         Types.ArrayType\r
4232           (_, Types.ArrayType\r
4233             (dim', Types.PredefinedType\r
4234               { Types.base_type = Types.IntegerType })) ->\r
4235           Types.ArrayType\r
4236             (dim, Types.ArrayType\r
4237               (dim', Types.PredefinedType\r
4238                 { Types.base_type = Types.IntegerType; attributes = [] }))\r
4239       | Types.ArrayType\r
4240           (dim, Types.ArrayType\r
4241             (_, Types.PredefinedType\r
4242               { Types.base_type = Types.IntegerType | Types.RealType })),\r
4243         Types.ArrayType\r
4244           (_, Types.ArrayType\r
4245             (dim', Types.PredefinedType\r
4246               { Types.base_type = Types.IntegerType | Types.RealType })) ->\r
4247           Types.ArrayType\r
4248             (dim, Types.ArrayType\r
4249               (dim', Types.PredefinedType\r
4250                 { Types.base_type = Types.RealType; attributes = [] }))\r
4251       | Types.ArrayType (_, Types.ArrayType (Types.ConstantDimension n, _)),\r
4252         Types.ArrayType (Types.ConstantDimension n', _)\r
4253         when n <> n' ->\r
4254           raise (CompilError\r
4255             {err_msg = ["_ArrayDimsNonCompatibleWithMult"];\r
4256              err_info =\r
4257                [("_ExprKind", "A * B");\r
4258                 ("_TypeOfA", Types.string_of_class_specifier cl_spec);\r
4259                 ("_TypeOfB", Types.string_of_class_specifier cl_spec')];\r
4260              err_ctx = ctx})  (*error*)\r
4261       | Types.ArrayType\r
4262           (dim, Types.ArrayType\r
4263             (_, Types.PredefinedType\r
4264               { Types.base_type = Types.IntegerType })),\r
4265         Types.ArrayType\r
4266           (_, Types.PredefinedType\r
4267             { Types.base_type = Types.IntegerType }) ->\r
4268           Types.ArrayType\r
4269             (dim, Types.PredefinedType\r
4270               { Types.base_type = Types.IntegerType; attributes = [] })\r
4271       | Types.ArrayType\r
4272           (dim, Types.ArrayType\r
4273             (_, Types.PredefinedType\r
4274               { Types.base_type = Types.IntegerType | Types.RealType })),\r
4275         Types.ArrayType\r
4276           (_, Types.PredefinedType\r
4277             { Types.base_type = Types.IntegerType | Types.RealType }) ->\r
4278           Types.ArrayType\r
4279             (dim, Types.PredefinedType\r
4280               { Types.base_type = Types.RealType; attributes = [] })\r
4281       | Types.ArrayType (Types.ConstantDimension n, _),\r
4282         Types.ArrayType (Types.ConstantDimension n', Types.ArrayType _)\r
4283         when n <> n' ->\r
4284           raise (CompilError\r
4285             {err_msg = ["_ArrayDimsNonCompatibleWithMult"];\r
4286              err_info =\r
4287                [("_ExprKind", "A * B");\r
4288                 ("_TypeOfA", Types.string_of_class_specifier cl_spec);\r
4289                 ("_TypeOfB", Types.string_of_class_specifier cl_spec')];\r
4290              err_ctx = ctx})  (*error*)\r
4291       | Types.ArrayType\r
4292           (_, Types.PredefinedType\r
4293             { Types.base_type = Types.IntegerType }),\r
4294         Types.ArrayType\r
4295           (_, Types.ArrayType\r
4296             (dim, Types.PredefinedType\r
4297               { Types.base_type = Types.IntegerType })) ->\r
4298           Types.ArrayType\r
4299             (dim, Types.PredefinedType\r
4300               { Types.base_type = Types.IntegerType; attributes = [] })\r
4301       | Types.ArrayType\r
4302           (_, Types.PredefinedType\r
4303             { Types.base_type = Types.IntegerType | Types.RealType }),\r
4304         Types.ArrayType\r
4305           (_, Types.ArrayType\r
4306             (dim, Types.PredefinedType\r
4307               { Types.base_type = Types.IntegerType | Types.RealType })) ->\r
4308           Types.ArrayType\r
4309             (dim, Types.PredefinedType\r
4310               { Types.base_type = Types.RealType; attributes = [] })\r
4311       | Types.ArrayType (Types.ConstantDimension n, _),\r
4312         Types.ArrayType (Types.ConstantDimension n', _)\r
4313         when n <> n' ->\r
4314           raise (CompilError\r
4315             {err_msg = ["_ArrayDimsNonCompatibleWithMult"];\r
4316              err_info =\r
4317                [("_ExprKind", "A * B");\r
4318                 ("_TypeOfA", Types.string_of_class_specifier cl_spec);\r
4319                 ("_TypeOfB", Types.string_of_class_specifier cl_spec')];\r
4320              err_ctx = ctx})  (*error*)\r
4321       | Types.ArrayType\r
4322           (_, Types.PredefinedType\r
4323             { Types.base_type = Types.IntegerType }),\r
4324         Types.ArrayType\r
4325           (_, Types.PredefinedType\r
4326             { Types.base_type = Types.IntegerType }) ->\r
4327           Types.PredefinedType\r
4328             { Types.base_type = Types.IntegerType; attributes = [] }\r
4329       | Types.ArrayType\r
4330           (_, Types.PredefinedType\r
4331             { Types.base_type = Types.IntegerType | Types.RealType }),\r
4332         Types.ArrayType\r
4333           (_, Types.PredefinedType\r
4334             { Types.base_type = Types.IntegerType | Types.RealType }) ->\r
4335           Types.PredefinedType\r
4336             { Types.base_type = Types.RealType; attributes = [] }\r
4337       | Types.PredefinedType\r
4338           { Types.base_type = Types.IntegerType | Types.RealType },\r
4339         Types.ArrayType (dim, cl_spec') ->\r
4340           Types.ArrayType (dim, multiplication_type cl_spec cl_spec')\r
4341       | Types.ArrayType (dim, cl_spec),\r
4342         Types.PredefinedType\r
4343           { Types.base_type = Types.IntegerType | Types.RealType } ->\r
4344           Types.ArrayType (dim, multiplication_type cl_spec cl_spec')\r
4345       | Types.PredefinedType { Types.base_type = Types.IntegerType },\r
4346         Types.PredefinedType { Types.base_type = Types.IntegerType } ->\r
4347           Types.PredefinedType\r
4348             { Types.base_type = Types.IntegerType; attributes = [] }\r
4349       | Types.PredefinedType\r
4350           { Types.base_type = Types.RealType | Types.IntegerType },\r
4351         Types.PredefinedType\r
4352           { Types.base_type = Types.RealType | Types.IntegerType } ->\r
4353           Types.PredefinedType\r
4354             { Types.base_type = Types.RealType; attributes = [] }\r
4355       | (Types.PredefinedType _ | Types.ClassType _ | Types.ComponentType _ |\r
4356          Types.ArrayType _ | Types.TupleType _),\r
4357         (Types.PredefinedType _ | Types.ClassType _ | Types.ComponentType _ |\r
4358          Types.ArrayType _ | Types.TupleType _) ->\r
4359           raise (CompilError\r
4360             {err_msg = ["*"; "_OperAppliedToNonNumericExpr"];\r
4361              err_info =\r
4362                [("_ExprKind", "A * B");\r
4363                 ("_TypeOfA", Types.string_of_class_specifier cl_spec);\r
4364                 ("_TypeOfB", Types.string_of_class_specifier cl_spec')];\r
4365              err_ctx = ctx})  (*error*) in\r
4366     let var =\r
4367       lazy (let var = evaluate cpnt_type.Types.variability\r
4368         and var' = evaluate cpnt_type'.Types.variability in\r
4369         Types.max_variability var var')\r
4370     and inout = Types.Acausal\r
4371     and cl_spec =\r
4372       lazy (let cl_spec = evaluate cpnt_type.Types.base_class\r
4373         and cl_spec' = evaluate cpnt_type'.Types.base_class in\r
4374         multiplication_type cl_spec cl_spec') in\r
4375     let nat = BinaryOperation (Times, arg, arg') in\r
4376     let elt_nat =\r
4377       let cpnt_type =\r
4378         component_element (lazy false) var (lazy inout) cl_spec in\r
4379       Types.ComponentElement cpnt_type in\r
4380     resolved_expression (Some expr) nat elt_nat in\r
4381   match  arg.info.type_description, arg'.info.type_description with\r
4382     | Types.ComponentElement cpnt_type, Types.ComponentElement cpnt_type' ->\r
4383         resolve_multiplication' cpnt_type cpnt_type'\r
4384     | (Types.ComponentElement _ | Types.ClassElement _ |\r
4385        Types.ComponentTypeElement _ | Types.PredefinedTypeElement _),\r
4386       (Types.ComponentElement _ | Types.ClassElement _ |\r
4387        Types.ComponentTypeElement _ | Types.PredefinedTypeElement _) ->\r
4388         raise (CompilError\r
4389           {err_msg = ["_ClassElemFoundInExpr"];\r
4390            err_info = [];\r
4391            err_ctx = ctx})  (*error*)\r
4392 \r
4393 and resolve_power ctx expr arg arg' =\r
4394   let resolve_power' cpnt_type cpnt_type' =\r
4395     let rec power_type cl_spec cl_spec' = match cl_spec, cl_spec' with\r
4396       | Types.ArrayType\r
4397           (Types.ConstantDimension n, Types.ArrayType\r
4398             (Types.ConstantDimension n', _)),\r
4399         Types.PredefinedType { Types.base_type = Types.IntegerType }\r
4400         when n <> n' ->\r
4401           raise (CompilError\r
4402             {err_msg = ["_PowerOperOnNonSquareArray"];\r
4403              err_info =\r
4404                [("_ExprKind", "A ^ B");\r
4405                 ("_TypeOfA", Types.string_of_class_specifier cl_spec);\r
4406                 ("_TypeOfB", Types.string_of_class_specifier cl_spec')];\r
4407              err_ctx = ctx}) (*error*)\r
4408       | Types.ArrayType\r
4409           (dim, Types.ArrayType\r
4410             (dim', Types.PredefinedType\r
4411               { Types.base_type = Types.IntegerType })),\r
4412         Types.PredefinedType { Types.base_type = Types.IntegerType } ->\r
4413           Types.ArrayType\r
4414             (dim, Types.ArrayType\r
4415               (dim', Types.PredefinedType\r
4416                 { Types.base_type = Types.RealType; attributes = [] }))\r
4417       | Types.ArrayType\r
4418           (dim, Types.ArrayType\r
4419             (dim', Types.PredefinedType { Types.base_type = Types.RealType })),\r
4420         Types.PredefinedType { Types.base_type = Types.IntegerType } ->\r
4421           Types.ArrayType\r
4422             (dim, Types.ArrayType\r
4423               (dim', Types.PredefinedType\r
4424                 { Types.base_type = Types.RealType; attributes = [] }))\r
4425       | Types.PredefinedType { Types.base_type = Types.IntegerType },\r
4426         Types.PredefinedType { Types.base_type = Types.IntegerType } ->\r
4427           Types.PredefinedType\r
4428             { Types.base_type = Types.RealType; attributes = [] }\r
4429       | Types.PredefinedType\r
4430           { Types.base_type = Types.RealType | Types.IntegerType },\r
4431         Types.PredefinedType\r
4432           { Types.base_type = Types.RealType | Types.IntegerType } ->\r
4433           Types.PredefinedType\r
4434             { Types.base_type = Types.RealType; attributes = [] }\r
4435       | (Types.PredefinedType _ | Types.ClassType _ | Types.ComponentType _ |\r
4436          Types.ArrayType _ | Types.TupleType _),\r
4437         (Types.PredefinedType _ | Types.ClassType _ | Types.ComponentType _ |\r
4438          Types.ArrayType _ | Types.TupleType _) ->\r
4439           raise (CompilError\r
4440             {err_msg = ["^"; "_OperAppliedToNonNumericExpr"];\r
4441              err_info =\r
4442                [("_ExprKind", "A ^ B");\r
4443                 ("_TypeOfA", Types.string_of_class_specifier cl_spec);\r
4444                 ("_TypeOfB", Types.string_of_class_specifier cl_spec')];\r
4445              err_ctx = ctx}) (*error*) in\r
4446     let var =\r
4447       lazy (let var = evaluate cpnt_type.Types.variability\r
4448         and var' = evaluate cpnt_type'.Types.variability in\r
4449         Types.max_variability var var')\r
4450     and inout = Types.Acausal\r
4451     and cl_spec =\r
4452       lazy (let cl_spec = evaluate cpnt_type.Types.base_class\r
4453         and cl_spec' = evaluate cpnt_type'.Types.base_class in\r
4454         power_type cl_spec cl_spec') in\r
4455     let nat = BinaryOperation (Power, arg, arg') in\r
4456     let elt_nat =\r
4457       let cpnt_type =\r
4458         component_element (lazy false) var (lazy inout) cl_spec in\r
4459       Types.ComponentElement cpnt_type in\r
4460     resolved_expression (Some expr) nat elt_nat in\r
4461   match arg.info.type_description, arg'.info.type_description with\r
4462     | Types.ComponentElement cpnt_type, Types.ComponentElement cpnt_type' ->\r
4463         resolve_power' cpnt_type cpnt_type'\r
4464     | (Types.ComponentElement _ | Types.ClassElement _ |\r
4465        Types.ComponentTypeElement _ | Types.PredefinedTypeElement _),\r
4466       (Types.ComponentElement _ | Types.ClassElement _ |\r
4467        Types.ComponentTypeElement _ | Types.PredefinedTypeElement _) ->\r
4468         raise (CompilError\r
4469           {err_msg = ["_ClassElemFoundInExpr"];\r
4470            err_info = [];\r
4471            err_ctx = ctx})  (*error*)\r
4472 \r
4473 and resolve_subtraction ctx expr arg arg' =\r
4474   let resolve_subtraction' cpnt_type cpnt_type' =\r
4475     let rec subtraction_type cl_spec cl_spec' = match cl_spec, cl_spec' with\r
4476       | Types.ArrayType (Types.ConstantDimension n, _),\r
4477         Types.ArrayType (Types.ConstantDimension n', _) when n <> n' ->\r
4478           raise (CompilError\r
4479           {err_msg = ["_ArrayDimMustAgreeToPerform"; "_Subtraction"];\r
4480            err_info =\r
4481              [("_ExprKind", "A - B");\r
4482               ("_TypeOfA", Types.string_of_class_specifier cl_spec);\r
4483               ("_TypeOfB", Types.string_of_class_specifier cl_spec')];\r
4484            err_ctx = ctx})  (*error*)\r
4485       | Types.ArrayType (Types.ConstantDimension _, cl_spec),\r
4486         Types.ArrayType (dim, cl_spec') |\r
4487         Types.ArrayType (dim, cl_spec),\r
4488         Types.ArrayType (Types.ConstantDimension _, cl_spec') ->\r
4489           Types.ArrayType (dim, subtraction_type cl_spec cl_spec')\r
4490       | Types.ArrayType (Types.ParameterDimension, cl_spec),\r
4491         Types.ArrayType (dim, cl_spec') |\r
4492         Types.ArrayType (dim, cl_spec),\r
4493         Types.ArrayType (Types.ParameterDimension, cl_spec') ->\r
4494           Types.ArrayType (dim, subtraction_type cl_spec cl_spec')\r
4495       | Types.ArrayType (Types.DiscreteDimension, cl_spec),\r
4496         Types.ArrayType (Types.DiscreteDimension, cl_spec') ->\r
4497           Types.ArrayType\r
4498             (Types.DiscreteDimension, subtraction_type cl_spec cl_spec')\r
4499       | Types.PredefinedType { Types.base_type = Types.IntegerType },\r
4500         Types.PredefinedType { Types.base_type = Types.IntegerType } ->\r
4501           Types.PredefinedType\r
4502             { Types.base_type = Types.IntegerType; attributes = [] }\r
4503       | Types.PredefinedType\r
4504           { Types.base_type = Types.RealType | Types.IntegerType },\r
4505         Types.PredefinedType\r
4506           { Types.base_type = Types.RealType | Types.IntegerType } ->\r
4507           Types.PredefinedType\r
4508             { Types.base_type = Types.RealType; attributes = [] }\r
4509       | (Types.PredefinedType _ | Types.ClassType _ | Types.ComponentType _ |\r
4510          Types.ArrayType _ | Types.TupleType _),\r
4511         (Types.PredefinedType _ | Types.ClassType _ | Types.ComponentType _ |\r
4512          Types.ArrayType _ | Types.TupleType _) ->\r
4513           raise (CompilError\r
4514             {err_msg = ["-"; "_OperAppliedToNonNumericExpr"];\r
4515              err_info =\r
4516                [("_ExprKind", "A - B");\r
4517                 ("_TypeOfA", Types.string_of_class_specifier cl_spec);\r
4518                 ("_TypeOfB", Types.string_of_class_specifier cl_spec')];\r
4519              err_ctx = ctx}) (*error*) in\r
4520     let var =\r
4521       lazy (let var = evaluate cpnt_type.Types.variability\r
4522         and var' = evaluate cpnt_type'.Types.variability in\r
4523         Types.max_variability var var')\r
4524     and inout = Types.Acausal\r
4525     and cl_spec =\r
4526       lazy (let cl_spec = evaluate cpnt_type.Types.base_class\r
4527         and cl_spec' = evaluate cpnt_type'.Types.base_class in\r
4528         subtraction_type cl_spec cl_spec') in\r
4529     let nat = BinaryOperation (Minus, arg, arg') in\r
4530     let elt_nat =\r
4531       let cpnt_type =\r
4532         component_element (lazy false) var (lazy inout) cl_spec in\r
4533       Types.ComponentElement cpnt_type in\r
4534     resolved_expression (Some expr) nat elt_nat in\r
4535   match arg.info.type_description, arg'.info.type_description with\r
4536     | Types.ComponentElement cpnt_type, Types.ComponentElement cpnt_type' ->\r
4537         resolve_subtraction' cpnt_type cpnt_type'\r
4538     | (Types.ComponentElement _ | Types.ClassElement _ |\r
4539        Types.ComponentTypeElement _ | Types.PredefinedTypeElement _),\r
4540       (Types.ComponentElement _ | Types.ClassElement _ |\r
4541        Types.ComponentTypeElement _ | Types.PredefinedTypeElement _) ->\r
4542         raise (CompilError\r
4543           {err_msg = ["_ClassElemFoundInExpr"];\r
4544            err_info = [];\r
4545            err_ctx = ctx})  (*error*)\r
4546 \r
4547 and resolve_unary_minus ctx expr arg =\r
4548   let resolve_unary_minus' cpnt_type =\r
4549     let rec unary_minus_type cl_spec = match cl_spec with\r
4550       | Types.ArrayType (dim, cl_spec) ->\r
4551           Types.ArrayType (dim, unary_minus_type cl_spec)\r
4552       | Types.PredefinedType\r
4553           { Types.base_type = Types.RealType | Types.IntegerType } -> cl_spec\r
4554       | (Types.PredefinedType _ | Types.ClassType _ | Types.ComponentType _ |\r
4555          Types.TupleType _) -> \r
4556           raise (CompilError\r
4557             {err_msg = ["-"; "_OperAppliedToNonNumericExpr"];\r
4558              err_info =\r
4559                [("_ExprKind", "- A");\r
4560                 ("_TypeOfA", Types.string_of_class_specifier cl_spec)];\r
4561              err_ctx = ctx})  (*error*) in\r
4562     let var = cpnt_type.Types.variability\r
4563     and inout = Types.Acausal\r
4564     and cl_spec =\r
4565       lazy (let cl_spec = evaluate cpnt_type.Types.base_class in\r
4566         unary_minus_type cl_spec) in\r
4567     let nat = UnaryOperation (UnaryMinus, arg) in\r
4568     let elt_nat =\r
4569       let cpnt_type =\r
4570         component_element (lazy false) var (lazy inout) cl_spec in\r
4571       Types.ComponentElement cpnt_type in\r
4572     resolved_expression (Some expr) nat elt_nat in\r
4573   match arg.info.type_description with\r
4574     | Types.ComponentElement cpnt_type -> resolve_unary_minus' cpnt_type\r
4575     | Types.ClassElement _ |\r
4576       Types.ComponentTypeElement _ | Types.PredefinedTypeElement _ ->\r
4577         raise (CompilError\r
4578           {err_msg = ["_ClassElemFoundInExpr"];\r
4579            err_info = [];\r
4580            err_ctx = ctx})  (*error*)\r
4581 \r
4582 and resolve_not ctx expr arg =\r
4583   let resolve_not' cpnt_type =\r
4584     let rec not_type cl_spec = match cl_spec with\r
4585       | Types.PredefinedType { Types.base_type = Types.BooleanType } -> cl_spec\r
4586       | (Types.PredefinedType _ | Types.ArrayType _ | Types.ClassType _ |\r
4587         Types.ComponentType _ | Types.TupleType _) ->\r
4588           raise (CompilError\r
4589             {err_msg = ["not"; "_OperAppliedToNonBoolExpr"];\r
4590              err_info =\r
4591                [("_ExprKind", "not A");\r
4592                 ("_TypeOfA", Types.string_of_class_specifier cl_spec)];\r
4593              err_ctx = ctx}) (*error*) in\r
4594     let var = cpnt_type.Types.variability\r
4595     and inout = Types.Acausal\r
4596     and cl_spec =\r
4597       lazy (let cl_spec = evaluate cpnt_type.Types.base_class in\r
4598         not_type cl_spec) in\r
4599     let nat = UnaryOperation (Not, arg) in\r
4600     let elt_nat =\r
4601       let cpnt_type =\r
4602         component_element (lazy false) var (lazy inout) cl_spec in\r
4603       Types.ComponentElement cpnt_type in\r
4604     resolved_expression (Some expr) nat elt_nat in\r
4605   match arg.info.type_description with\r
4606     | Types.ComponentElement cpnt_type -> resolve_not' cpnt_type\r
4607     | Types.ClassElement _ |\r
4608       Types.ComponentTypeElement _ | Types.PredefinedTypeElement _ ->\r
4609         raise (CompilError\r
4610           {err_msg = ["_ClassElemFoundInExpr"];\r
4611            err_info = [];\r
4612            err_ctx = ctx}) (*error*)\r
4613 \r
4614 and component_element flow var inout cl_spec =\r
4615   {\r
4616     Types.flow = flow;\r
4617           variability = var;\r
4618           causality = inout;\r
4619           base_class = cl_spec\r
4620   }\r
4621 \r
4622 and element_nature_class ctx = function\r
4623   | Types.ClassElement cl_spec -> evaluate cl_spec\r
4624   | Types.ComponentElement cpnt_type -> evaluate cpnt_type.Types.base_class\r
4625   | Types.PredefinedTypeElement predef -> Types.PredefinedType predef\r
4626   | Types.ComponentTypeElement _ -> assert false (*error*)\r
4627 \r
4628 and element_field_type_nature ctx flow var inout cl_spec id =\r
4629   let add_dimension dim = function\r
4630     | Types.ComponentElement cpnt_type ->\r
4631         let cpnt_type' =\r
4632           { cpnt_type with\r
4633             Types.base_class =\r
4634               lazy (Types.ArrayType (dim, evaluate cpnt_type.Types.base_class))\r
4635           } in\r
4636         Types.ComponentElement cpnt_type'\r
4637     | Types.ClassElement _\r
4638     | Types.ComponentTypeElement _\r
4639     | Types.PredefinedTypeElement _ ->\r
4640         raise (CompilError\r
4641           {err_msg = ["_InvalidClassElemModif"];\r
4642            err_info = [];\r
4643            err_ctx = ctx}) (*error*) in\r
4644   let find_predefined_local_identifier predef id =\r
4645     match predef.Types.base_type with\r
4646       | Types.BooleanType when id = "start" -> Types.boolean_type Types.Parameter\r
4647       | Types.IntegerType when id = "start" ->\r
4648           Types.integer_type Types.Parameter\r
4649       | Types.RealType when id = "start" ->\r
4650           Types.real_type Types.Parameter\r
4651       | Types.StringType when id = "start" -> Types.string_type Types.Parameter\r
4652       | Types.EnumerationType enum_lits when id = "start" ->\r
4653           Types.enumeration_type Types.Parameter enum_lits\r
4654       | _ when id = "fixed" -> Types.boolean_type Types.Constant\r
4655       | Types.IntegerType when id = "nominal" ->\r
4656           Types.integer_type Types.Constant\r
4657       | Types.RealType when id = "nominal" ->\r
4658           Types.real_type Types.Constant\r
4659       | _ ->\r
4660           raise (CompilError\r
4661             {err_msg = ["_NotYetImplemented"; "_PredefinedTypeAttribModif"; id];\r
4662              err_info = [];\r
4663              err_ctx = ctx})\r
4664   and find_class_local_identifier flow var inout cl_type id =\r
4665     let apply_prefixes elt_nat = match elt_nat with\r
4666       | Types.ComponentElement cpnt_type ->\r
4667           let flow' = lazy (flow || evaluate cpnt_type.Types.flow) in\r
4668           Types.ComponentElement { cpnt_type with Types.flow = flow' }\r
4669       | Types.ClassElement _ | Types.ComponentTypeElement _ |\r
4670         Types.PredefinedTypeElement _ -> elt_nat in\r
4671     try\r
4672       let elt_type =\r
4673         evaluate (List.assoc id cl_type.Types.named_elements) in\r
4674       match elt_type.Types.dynamic_scope with\r
4675         | None | Some Types.Inner | Some Types.InnerOuter\r
4676           when not elt_type.Types.protected ->\r
4677             apply_prefixes elt_type.Types.element_nature\r
4678         | None | Some Types.Inner | Some Types.InnerOuter ->\r
4679             raise (CompilError\r
4680               {err_msg = ["_CannotAccessProtectElem"; id];\r
4681                err_info = [];\r
4682                err_ctx = ctx}) (*error*)\r
4683         | Some Types.Outer ->\r
4684             raise (CompilError\r
4685               {err_msg = ["_CannotAccessOuterElem"; id];\r
4686                err_info = [];\r
4687                err_ctx = ctx}) (*error*)\r
4688     with Not_found ->\r
4689         raise (CompilError\r
4690           {err_msg = ["_UnknownIdentifier"; id];\r
4691            err_info = [];\r
4692            err_ctx = ctx }) (*error*) in\r
4693   let rec find_local_identifier flow var inout = function\r
4694     | Types.PredefinedType predef_type ->\r
4695         find_predefined_local_identifier predef_type id\r
4696     | Types.ClassType cl_type ->\r
4697         find_class_local_identifier flow var inout cl_type id\r
4698     | Types.ComponentType cpnt_type ->\r
4699         let flow = flow || evaluate cpnt_type.Types.flow\r
4700         and var =\r
4701           Types.max_variability var (evaluate cpnt_type.Types.variability)\r
4702         and inout = evaluate cpnt_type.Types.causality\r
4703         and base_class = evaluate cpnt_type.Types.base_class in\r
4704         find_local_identifier flow var inout base_class\r
4705     | Types.ArrayType (dim, cl_spec) ->\r
4706         add_dimension dim (find_local_identifier flow var inout cl_spec)\r
4707     | Types.TupleType _ -> assert false (*error*) in\r
4708   find_local_identifier flow var inout cl_spec\r
4709 \r
4710 and scalar_element_nature elt_nat =\r
4711   let rec scalar_element_nature' cl_spec = match cl_spec with\r
4712     | Types.PredefinedType _ | Types.ClassType _ | Types.ComponentType _ |\r
4713       Types.TupleType _ -> cl_spec\r
4714     | Types.ArrayType (_, cl_spec) -> scalar_element_nature' cl_spec in\r
4715   match elt_nat with\r
4716     | Types.ComponentElement cpnt_type ->\r
4717         let base_class' =\r
4718           lazy (scalar_element_nature' (evaluate cpnt_type.Types.base_class)) in\r
4719         Types.ComponentElement { cpnt_type with Types.base_class = base_class' }\r
4720     | Types.ClassElement _ | Types.ComponentTypeElement _ |\r
4721       Types.PredefinedTypeElement _ -> elt_nat\r
4722 \r
4723 and resolve_lhs_expression ctx expr =\r
4724   raise (CompilError\r
4725     {err_msg = ["_NotYetImplemented";\r
4726                 "_ExternalCallWithLeftHandSideExpr"];\r
4727      err_info = [];\r
4728      err_ctx = ctx})\r
4729 \r
4730 and resolve_subscripts ctx expr cl_spec subs =\r
4731   let rec resolve_subscripts' n cl_spec subs = match cl_spec, subs with\r
4732     | _, [] -> []\r
4733     | Types.ArrayType (dim, cl_spec'), sub :: subs' ->\r
4734         let sub' = resolve_subscript ctx expr n dim sub in\r
4735         sub' :: resolve_subscripts' (Int32.add n 1l) cl_spec' subs'\r
4736     | (Types.PredefinedType _ | Types.ClassType _ | Types.ComponentType _ |\r
4737        Types.TupleType _), _ :: _ ->\r
4738         raise (CompilError\r
4739           {err_msg = ["_CannotSubscriptANonArrayTypeElem"];\r
4740            err_info =\r
4741              [("_ExpectedType", "_ArrayType");\r
4742               ("_TypeFound", Types.string_of_class_specifier cl_spec)];\r
4743            err_ctx = ctx}) (*error*) in\r
4744   match subs.Syntax.nature with\r
4745     | Syntax.Subscripts subs' -> resolve_subscripts' 1l cl_spec subs'\r
4746 \r
4747 and resolve_subscript ctx expr n dim sub = match sub.Syntax.nature with\r
4748   | Syntax.Colon -> resolve_colon ctx expr n dim\r
4749   | Syntax.Subscript expr' ->\r
4750       let ctx' =\r
4751       { ctx with\r
4752         context_nature = SubscriptContext (ctx, expr, n, dim);\r
4753         location = expr'.Syntax.info } in\r
4754       resolve_subscript_expression ctx' expr'\r
4755 \r
4756 and resolve_colon ctx expr n dim =\r
4757   let range var stop =\r
4758     let nat = Range (one, one, stop)\r
4759     and elt_nat = Types.integer_array_type var dim in\r
4760     resolved_expression None nat elt_nat in\r
4761   match dim with\r
4762     | Types.ConstantDimension n ->\r
4763         let stop =\r
4764           let nat = Integer n\r
4765           and elt_nat = Types.integer_type Types.Constant in\r
4766           resolved_expression None nat elt_nat in\r
4767         range Types.Constant stop\r
4768     | Types.ParameterDimension ->\r
4769         let stop = size_function_call ctx None expr n in\r
4770         range Types.Parameter stop\r
4771     | Types.DiscreteDimension ->\r
4772         let stop = size_function_call ctx None expr n in\r
4773         range Types.Discrete stop\r
4774 \r
4775 and resolve_subscript_expression ctx expr =\r
4776   let expr' = resolve_expression ctx expr in\r
4777   let resolve_subscript_expression' cpnt_type =\r
4778     let cl_spec = evaluate cpnt_type.Types.base_class in\r
4779     match cl_spec with\r
4780       | Types.PredefinedType { Types.base_type = Types.IntegerType } |\r
4781         Types.ArrayType\r
4782           (_, Types.PredefinedType { Types.base_type = Types.IntegerType }) ->\r
4783           expr'\r
4784       | Types.PredefinedType _ | Types.ClassType _ | Types.ComponentType _ |\r
4785         Types.ArrayType _ | Types.TupleType _ ->\r
4786           raise (CompilError\r
4787             {err_msg = ["_NonIntegerArraySubscript"];\r
4788              err_info =\r
4789                [("_ExpectedType", "Integer");\r
4790                 ("_TypeFound", Types.string_of_class_specifier cl_spec)];\r
4791              err_ctx = ctx}) (*error*) in\r
4792   match expr'.info.type_description with\r
4793     | Types.ComponentElement cpnt_type ->\r
4794         resolve_subscript_expression' cpnt_type\r
4795     | Types.ClassElement _ | Types.ComponentTypeElement _ |\r
4796       Types.PredefinedTypeElement _ ->\r
4797         raise (CompilError\r
4798           {err_msg = ["_ClassElemFoundInExpr"];\r
4799            err_info = [];\r
4800            err_ctx = ctx}) (*error*)\r
4801 \r
4802 and size_function_call ctx syn arg n =\r
4803   let size_function_call' cpnt_type =\r
4804     let cpnt_type' =\r
4805       { cpnt_type with\r
4806         Types.base_class = lazy (Types.integer_class_type)\r
4807       } in\r
4808     let size =\r
4809       let nat = PredefinedIdentifier "size"\r
4810       and elt_nat =\r
4811         Types.function_type\r
4812           [("@1", cpnt_type);\r
4813            ("@2", Types.integer_component_type Types.Constant)]\r
4814           ["@3", cpnt_type'] in\r
4815       resolved_expression None nat elt_nat in\r
4816     let elt_nat = Types.ComponentElement cpnt_type' in\r
4817     let num =\r
4818       let nat = Integer n\r
4819       and elt_nat = Types.integer_type Types.Constant in\r
4820       resolved_expression None nat elt_nat\r
4821     and expr =\r
4822       let args =\r
4823         let arg1 =\r
4824           let nat = FunctionArgument 1\r
4825           and elt_nat = arg.info.type_description in\r
4826           resolved_expression None nat elt_nat\r
4827         and arg2 =\r
4828           let nat = FunctionArgument 2\r
4829           and elt_nat = Types.integer_type Types.Constant in\r
4830           resolved_expression None nat elt_nat in\r
4831         [arg1; arg2] in\r
4832       let nat = FunctionInvocation args in\r
4833       resolved_expression None nat elt_nat in\r
4834     let nat = FunctionCall (size, [arg; num], expr) in\r
4835     resolved_expression syn nat elt_nat in\r
4836   match arg.info.type_description with\r
4837     | Types.ComponentElement cpnt_type -> size_function_call' cpnt_type\r
4838     | Types.ClassElement _ | Types.ComponentTypeElement _ |\r
4839       Types.PredefinedTypeElement _ ->\r
4840         raise (CompilError\r
4841           {err_msg = ["_ClassElemFoundInExpr"];\r
4842            err_info = [];\r
4843            err_ctx = ctx}) (*error*)\r
4844 \r
4845 and element_type ctx protect final repl dyn_scope elt_desc =\r
4846   {\r
4847     Types.protected = protect;\r
4848           final = bool_of_final final;\r
4849           replaceable = bool_of_replaceable repl;\r
4850           dynamic_scope = dynamic_scope_of_dynamic_scope dyn_scope;\r
4851           element_nature = element_nature_type ctx elt_desc\r
4852   }\r
4853 \r
4854 and bool_of_replaceable = function\r
4855   | None -> false\r
4856   | Some Syntax.Replaceable -> true\r
4857 \r
4858 and dynamic_scope_of_dynamic_scope = function\r
4859   | None -> None\r
4860   | Some Syntax.Inner -> Some Types.Inner\r
4861   | Some Syntax.Outer -> Some Types.Outer\r
4862   | Some Syntax.InnerOuter -> Some Types.InnerOuter\r
4863 \r
4864 and element_nature_type ctx elt_desc =\r
4865   let elt_nat = match elt_desc.element_nature with\r
4866     | Component cpnt_desc -> Types.ComponentElement (evaluate cpnt_desc.component_type)\r
4867     | Class cl_def -> Types.ClassElement cl_def.class_type\r
4868     | ComponentType cpnt_type_desc ->\r
4869         Types.ComponentTypeElement (evaluate cpnt_type_desc.described_type)\r
4870     | PredefinedType predef -> Types.PredefinedTypeElement predef in\r
4871   elt_nat\r
4872 \r
4873 and class_specifier_type ctx part kind cl_def cl_spec =\r
4874   let class_kind kind cl_type =\r
4875     let check_class () =\r
4876       if has_inouts cl_type then\r
4877         raise (CompilError\r
4878           {err_msg = ["_CannotUseCausPrefixInGenClass";\r
4879                       class_specifier_name cl_spec];\r
4880            err_info = [];\r
4881            err_ctx = ctx}) (*error*)\r
4882       else kind\r
4883     and check_model () = kind\r
4884     and check_block () =\r
4885       raise (CompilError\r
4886         {err_msg = ["_NotYetImplemented"; "_BlockElem"];\r
4887          err_info = [];\r
4888          err_ctx = ctx})\r
4889     and check_record () = kind\r
4890     and check_expandable_connector () =\r
4891       raise (CompilError\r
4892         {err_msg = ["_NotYetImplemented"; "_ExpandableConnector"];\r
4893          err_info = [];\r
4894          err_ctx = ctx})\r
4895     and check_connector () = kind\r
4896     and check_package () = kind\r
4897     and check_function () = kind in\r
4898   match kind with\r
4899     | Types.Class -> check_class ()\r
4900     | Types.Model -> check_model ()\r
4901     | Types.Block -> check_block ()\r
4902     | Types.Record -> check_record ()\r
4903     | Types.ExpandableConnector -> check_expandable_connector ()\r
4904     | Types.Connector -> check_connector ()\r
4905     | Types.Package -> check_package ()\r
4906     | Types.Function -> check_function () in\r
4907   let rec cl_type =\r
4908     {\r
4909        Types.partial = bool_of_partial part;\r
4910             kind = lazy (class_kind kind cl_type);\r
4911             named_elements = class_type_elements ctx kind cl_def\r
4912     } in\r
4913   Types.ClassType cl_type\r
4914 \r
4915 and bool_of_partial = function\r
4916   | None -> false\r
4917   | Some Syntax.Partial -> true\r
4918 \r
4919 and class_type_elements ctx kind cl_def = match evaluate cl_def.description with\r
4920   | LongDescription long_desc -> long_description_type_elements ctx kind long_desc\r
4921   | ShortDescription short_desc -> short_description_type_elements ctx kind short_desc\r
4922 \r
4923 and short_description_type_elements ctx kind short_desc =\r
4924   let cl_type = evaluate short_desc.modified_class_type in\r
4925   let kind' = evaluate cl_type.Types.kind in\r
4926   match kind, kind' with\r
4927     | Types.Class, Types.Class |\r
4928       Types.Model, Types.Model |\r
4929       Types.Block, Types.Block |\r
4930       Types.Record, Types.Record |\r
4931       Types.ExpandableConnector, Types.ExpandableConnector |\r
4932       Types.Connector, Types.Connector |\r
4933       Types.Package, Types.Package |\r
4934       Types.Function, Types.Function -> cl_type.Types.named_elements\r
4935     | (Types.Class | Types.Model | Types.Block | Types.Record |\r
4936       Types.ExpandableConnector | Types.Connector | Types.Package | Types.Function),\r
4937       (Types.Class | Types.Model | Types.Block | Types.Record |\r
4938       Types.ExpandableConnector | Types.Connector | Types.Package | Types.Function) ->\r
4939         raise (CompilError\r
4940           {err_msg = ["_InheritFromDiffClassKindsNotAllowed"];\r
4941            err_info = [];\r
4942            err_ctx = ctx}) (*error*)\r
4943 \r
4944 and long_description_type_elements ctx kind long_desc =\r
4945   let type_element (id, elt_desc) = id, elt_desc.element_type in\r
4946   let local_elts = List.map type_element long_desc.named_elements in\r
4947   let add_extensions kinds exts =\r
4948     let add_named_element protected named_elt named_elts =\r
4949       let element_type elt_type =\r
4950         let elt_type' = evaluate elt_type in\r
4951         { elt_type' with Types.protected =\r
4952             elt_type'.Types.protected || protected } in\r
4953       match named_elt with\r
4954       | id, _ when List.mem_assoc id named_elts ->\r
4955           raise (CompilError\r
4956             {err_msg = [id; "_AlreadyDeclaredInParentClass"];\r
4957              err_info = [];\r
4958              err_ctx = ctx}) (*error*)\r
4959       | id, elt_type -> (id, lazy (element_type elt_type)) :: named_elts in\r
4960     let add_extension_contribution (visibility, modif_cl) named_elts =\r
4961       let protected = bool_of_visibility visibility\r
4962       and cl_type = evaluate modif_cl.modified_class_type in\r
4963       let named_elts' = cl_type.Types.named_elements in\r
4964       if List.mem (evaluate cl_type.Types.kind) kinds then\r
4965         List.fold_right (add_named_element protected) named_elts' named_elts\r
4966       else\r
4967         raise (CompilError\r
4968           {err_msg = ["_InheritFromDiffClassKindsNotAllowed"];\r
4969            err_info = [];\r
4970            err_ctx = ctx}) (*error*) in\r
4971     List.fold_right add_extension_contribution exts local_elts in\r
4972   match kind, long_desc.extensions with\r
4973   | Types.Function, [] -> local_elts\r
4974   | Types.Function, _ :: _ ->\r
4975       raise (CompilError\r
4976         {err_msg = ["_InheritFromFunctionNotAllowed"];\r
4977          err_info = [];\r
4978          err_ctx = ctx}) (*error*)\r
4979   | (Types.Class | Types.Model | Types.Block | Types.Record | Types.Connector | Types.Package),\r
4980     exts -> add_extensions [kind] exts\r
4981   | Types.ExpandableConnector, exts ->\r
4982       add_extensions [kind; Types.Connector] exts\r
4983 \r
4984 and bool_of_visibility = function\r
4985   | Public -> false\r
4986   | Protected -> true\r
4987 \r
4988 and has_inouts cl_type =\r
4989   let is_inout_component cpnt_type =\r
4990     match evaluate cpnt_type.Types.causality with\r
4991       | Types.Input | Types.Output -> true\r
4992       | Types.Acausal -> false in\r
4993   let is_inout = function\r
4994     | Types.ComponentElement cpnt_type -> is_inout_component cpnt_type\r
4995     | Types.ClassElement _ | Types.ComponentTypeElement _ |\r
4996       Types.PredefinedTypeElement _ -> false\r
4997   and element_nature (_, elt_type) = (evaluate elt_type).Types.element_nature in\r
4998   List.exists\r
4999     (function named_elt -> is_inout (element_nature named_elt))\r
5000     cl_type.Types.named_elements\r
5001 \r
5002 and component_type_of_expression ctx expr =\r
5003   match expr.info.type_description with\r
5004   | Types.ComponentElement cpnt_type -> cpnt_type\r
5005   | Types.ClassElement _ | Types.ComponentTypeElement _ |\r
5006     Types.PredefinedTypeElement _ ->\r
5007       raise (CompilError\r
5008         {err_msg = ["_ClassElemFoundInExpr"];\r
5009          err_info = [];\r
5010          err_ctx = ctx}) (*error*)\r
5011 \r
5012 and scalar_class_specifier ctx expr =\r
5013   let rec scalar_class_specifier' cl_spec = match cl_spec with\r
5014     | Types.ArrayType (dim, cl_spec) ->\r
5015         scalar_class_specifier' cl_spec\r
5016     | _ -> cl_spec in\r
5017   let cpnt_type = component_type_of_expression ctx expr in\r
5018   let cl_spec = evaluate cpnt_type.Types.base_class in\r
5019   scalar_class_specifier' cl_spec\r
5020 \r
5021 and expression_of_variable expr =\r
5022   let vector_variables vec_elts = match vec_elts.Syntax.nature with\r
5023     | Syntax.VectorReduction _ -> false\r
5024     | Syntax.VectorElements exprs ->\r
5025         List.for_all expression_of_variable exprs in\r
5026   match expr.Syntax.nature with\r
5027   | Syntax.Identifier _ -> true\r
5028   | Syntax.FieldAccess (expr', _) -> expression_of_variable expr'\r
5029   | Syntax.IndexedAccess (expr', subs) ->\r
5030       expression_of_variable expr'\r
5031   | Syntax.MatrixConstruction exprss ->\r
5032       List.for_all (List.for_all expression_of_variable) exprss\r
5033   | Syntax.Tuple exprs ->\r
5034       List.for_all expression_of_variable exprs\r
5035   | Syntax.Vector vec_elts -> vector_variables vec_elts\r
5036   | _ -> false\r
5037 \r
5038 and string_of_bin_oper_kind kind = match kind with\r
5039   | And -> " and "\r
5040   | Divide -> " / "\r
5041   | EqualEqual -> " == "\r
5042   | GreaterEqual -> " >= "\r
5043   | Greater -> " > "\r
5044   | LessEqual -> " <= "\r
5045   | Less -> " < "\r
5046   | Times -> " * "\r
5047   | NotEqual -> " <> "\r
5048   | Or -> " or "\r
5049   | Plus -> " + "\r
5050   | Power -> " ^ "\r
5051   | Minus -> " - "\r
5052 \r
5053 and string_of_un_oper_kind kind = match kind with\r
5054   | Not -> " not "\r
5055   | UnaryMinus -> "- "\r
5056   | UnaryPlus -> "+ "\r
5057 \r
5058 and apply_binary_coercions exprs =\r
5059   let base_type expr =\r
5060     let rec base_type' cl_spec = match cl_spec with\r
5061       | Types.ArrayType (_, cl_spec) -> base_type' cl_spec\r
5062       | Types.PredefinedType pt -> Some pt.Types.base_type\r
5063       | _ -> None in\r
5064     match expr.info.type_description with\r
5065     | Types.ComponentElement cpnt_type ->\r
5066         let cl_spec = evaluate cpnt_type.Types.base_class in\r
5067         base_type' cl_spec\r
5068     | _ -> None\r
5069   and real_type bt = match bt with\r
5070     | Some Types.RealType -> true\r
5071     | _ -> false\r
5072   and integer_type bt = match bt with\r
5073     | Some Types.IntegerType -> true\r
5074     | _ -> false in\r
5075   match List.map base_type exprs with\r
5076   | [] | [ _ ] -> exprs\r
5077   | bts when (List.exists real_type bts) &&\r
5078     (List.exists integer_type bts) ->\r
5079       let cpnt_type = Types.real_component_type Types.Continuous in\r
5080       List.map (apply_rhs_coercions cpnt_type) exprs\r
5081   | _ -> exprs\r
5082 \r
5083 and apply_rhs_coercions cpnt_type expr =\r
5084   let apply_real_of_integer cpnt_type cpnt_type' =\r
5085     let rec apply_real_of_integer' cl_spec cl_spec' =\r
5086       match cl_spec, cl_spec' with\r
5087       | Types.ArrayType (dim, cl_spec), _ ->\r
5088           apply_real_of_integer' cl_spec cl_spec'\r
5089       | _, Types.ArrayType (dim', cl_spec') ->\r
5090           let coer, cl_spec' = apply_real_of_integer' cl_spec cl_spec' in\r
5091           coer, Types.ArrayType (dim', cl_spec')\r
5092       | Types.PredefinedType { Types.base_type = Types.RealType },\r