scilab/modules/scicos/src/translator/instantiation/instantiation.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 type ('a, 'b) node =\r
  24   {\r
  25     nature: 'a;\r
  26     info: 'b\r
  27   }\r
  28 \r
  29 type instance =\r
  30   {\r
  31     enclosing_instance: instance option;\r
  32     kind: Types.kind;\r
  33     elements: instance_elements Lazy.t\r
  34   }\r
  35 \r
  36 and instance_elements =\r
  37   {\r
  38     named_elements: (string * element_description) list;\r
  39     unnamed_elements: equation_or_algorithm_clause list\r
  40   }\r
  41 \r
  42 and element_description =\r
  43   {\r
  44     redeclare: bool;\r
  45     element_nature: element_nature Lazy.t\r
  46   }\r
  47 \r
  48 and element_nature =\r
  49   | Class of class_definition\r
  50   | Component of component_description\r
  51 \r
  52 and class_definition =\r
  53   {\r
  54     class_type: Types.class_specifier;\r
  55     class_path: path;\r
  56     class_flow: bool option;\r
  57     class_variability: Types.variability option;\r
  58     class_causality: Types.causality option;\r
  59     description: description;\r
  60     modification: modification_argument list;\r
  61     class_location: Parser.location\r
  62   }\r
  63 \r
  64 and path = path_element list\r
  65 \r
  66 and path_element =\r
  67   | Name of string\r
  68   | Index of int\r
  69 \r
  70 and description =\r
  71   | ClassDescription of context * class_description\r
  72   | PredefinedType of predefined_type\r
  73 \r
  74 and class_description =\r
  75   {\r
  76     class_kind: Types.kind;\r
  77     class_annotations: (annotation list) Lazy.t;\r
  78     long_description: NameResolve.long_description\r
  79   }\r
  80 \r
  81 and annotation =\r
  82   | InverseFunction of inverse_function Lazy.t\r
  83   | UnknownAnnotation of Parser.location Syntax.class_modification Lazy.t\r
  84 \r
  85 and inverse_function =\r
  86   {\r
  87     function_class: class_definition;\r
  88     arguments: (string * string) list\r
  89   }\r
  90 \r
  91 and class_modification = (string * modification_argument) list\r
  92 \r
  93 and modification_argument =\r
  94   {\r
  95     each: bool;\r
  96     action: modification_action\r
  97   }\r
  98 \r
  99 and modification_action =\r
 100   | ElementModification of modification\r
 101   | ElementRedeclaration of element_description\r
 102 \r
 103 and modification =\r
 104   | Modification of class_modification * expression Lazy.t option\r
 105   | Assignment of expression Lazy.t\r
 106   | Equality of expression Lazy.t\r
 107 \r
 108 and component_description =\r
 109   {\r
 110     component_path: path;\r
 111     flow: bool;\r
 112     variability: Types.variability;\r
 113     causality: Types.causality;\r
 114     component_nature: component_nature Lazy.t;\r
 115     declaration_equation: expression Lazy.t option;\r
 116     comment: string;\r
 117     component_location: Parser.location;\r
 118     class_name: string\r
 119   }\r
 120 \r
 121 and component_nature =\r
 122   | DynamicArray of component_description\r
 123       (* one representative member of the collection *)\r
 124   | Instance of instance\r
 125   | PredefinedTypeInstance of predefined_type_instance\r
 126   | StaticArray of component_description array\r
 127 \r
 128 and predefined_type_instance =\r
 129   {\r
 130     predefined_type: predefined_type;\r
 131     attributes: (string * expression Lazy.t) list\r
 132   }\r
 133 \r
 134 and predefined_type =\r
 135   | BooleanType\r
 136   | IntegerType\r
 137   | RealType\r
 138   | StringType\r
 139   | EnumerationType\r
 140 \r
 141 and equation_or_algorithm_clause =\r
 142   | EquationClause of NameResolve.validity * equation list Lazy.t\r
 143   | AlgorithmClause of NameResolve.validity * algorithm list Lazy.t\r
 144 \r
 145 and validity = Initial | Permanent\r
 146 \r
 147 and equation = (equation_desc list, NameResolve.equation) node\r
 148 \r
 149 and equation_desc =\r
 150   | Equal of expression * expression\r
 151   | ConditionalEquationE of (expression * equation list) list *\r
 152       equation list\r
 153   | ConnectFlows of NameResolve.sign * expression *\r
 154       NameResolve.sign * expression\r
 155   | WhenClauseE of (expression * equation list) list\r
 156 \r
 157 and algorithm = (algorithm_desc list, NameResolve.algorithm) node\r
 158 \r
 159 and algorithm_desc =\r
 160   | Assign of expression * expression\r
 161   | FunctionCallA of expression * expression list\r
 162   | MultipleAssign of expression list * expression * expression list\r
 163   | Break\r
 164   | Return\r
 165   | ConditionalEquationA of (expression * algorithm list) list *\r
 166       algorithm list\r
 167   | ForClauseA of expression (* range *) * algorithm list\r
 168   | WhileClause of expression * algorithm list\r
 169   | WhenClauseA of (expression * algorithm list) list\r
 170 \r
 171 and expression =\r
 172   | BinaryOperation of binary_operator_kind * expression * expression\r
 173   | ClassReference of class_definition\r
 174   | ComponentReference of component_description\r
 175   | EnumerationElement of string\r
 176   | False\r
 177   | FieldAccess of expression * string\r
 178   | FunctionCall of expression * expression list\r
 179   | If of (expression (* condition *) * expression) list *\r
 180       expression (* default *)\r
 181   | IndexedAccess of expression * expression list (* subscripts *)\r
 182   | Integer of int32\r
 183   | LoopVariable of int (* number of nested for loops to skip *)\r
 184   | NoEvent of expression\r
 185   | PredefinedIdentifier of string\r
 186   | Range of expression * expression * expression\r
 187   | Real of float\r
 188   | Record of (string * expression) list\r
 189   | String of string\r
 190   | True\r
 191   | Tuple of expression list\r
 192   | UnaryOperation of unary_operator_kind * expression\r
 193   | Vector of expression array\r
 194   | VectorReduction of expression list (* ranges *) * expression\r
 195 \r
 196 and unary_operator_kind =\r
 197   | Not\r
 198   | UnaryMinus\r
 199 \r
 200 and binary_operator_kind =\r
 201   | And\r
 202   | Divide\r
 203   | EqualEqual\r
 204   | GreaterEqual\r
 205   | Greater\r
 206   | LessEqual\r
 207   | Less\r
 208   | Times\r
 209   | NotEqual\r
 210   | Or\r
 211   | Plus\r
 212   | Power\r
 213   | Minus\r
 214 \r
 215 and context =\r
 216   {\r
 217     toplevel: (string * element_description) list Lazy.t;\r
 218     path: path;\r
 219     context_flow: bool option;\r
 220     context_variability: Types.variability option;\r
 221     context_causality: Types.causality option;\r
 222     parent_context: context option; (* for normal parent scope lookup *)\r
 223     class_context: context_nature; (* for normal (class-based) lookup *)\r
 224     instance_context: instance option; (* for dynamically scoped identifiers *)\r
 225     location: Parser.location;\r
 226     instance_nature: instance_nature\r
 227   }\r
 228 \r
 229 and context_nature =\r
 230   | ToplevelContext\r
 231   | InstanceContext of instance\r
 232   | ForContext of context *\r
 233       expression option (* current value of the loop variable, if available *)\r
 234   | FunctionEvaluationContext of context * expression * expression list\r
 235 \r
 236 (* Error description *)\r
 237 and error_description =\r
 238   {\r
 239     err_msg: string list;\r
 240     err_info: (string * string) list;\r
 241     err_ctx: context\r
 242   }\r
 243 \r
 244 and instance_nature =\r
 245   | ClassElement\r
 246   | ComponentElement of string\r
 247 \r
 248 exception InstantError of error_description\r
 249 \r
 250 \r
 251 (* Utilities *)\r
 252 \r
 253 let levels = ref 0\r
 254 \r
 255 let spaces () = for i = 1 to !levels do Printf.printf "  " done\r
 256 \r
 257 let nest i =\r
 258   spaces (); Printf.printf "ForContext %ld\n" i;\r
 259   incr levels\r
 260 \r
 261 let nest2 i =\r
 262   spaces (); Printf.printf "ReductionContext %ld\n" i;\r
 263   incr levels\r
 264 \r
 265 let unnest () =\r
 266   decr levels;\r
 267   spaces (); Printf.printf "Leaving ForContext\n"\r
 268 \r
 269 let evaluate x = Lazy.force x\r
 270 \r
 271 module ArrayExt =\r
 272   struct\r
 273     let map2 f a a' =\r
 274       let l = Array.length a\r
 275       and l' = Array.length a' in\r
 276       if l <> l' then invalid_arg "ArrayExt.map2"\r
 277       else begin\r
 278         let create_array i = f a.(i) a'.(i) in\r
 279         Array.init l create_array\r
 280       end\r
 281     let for_all2 f a a' =\r
 282       let l = Array.length a\r
 283       and l' = Array.length a' in\r
 284       if l <> l' then invalid_arg "ArrayExt.for_all2"\r
 285       else begin\r
 286         let rec for_all2' i =\r
 287           i = l || (f a.(i) a'.(i) && for_all2' (i + 1)) in\r
 288         for_all2' 0\r
 289       end\r
 290     let exists2 f a a' =\r
 291       let l = Array.length a\r
 292       and l' = Array.length a' in\r
 293       if l <> l' then invalid_arg "ArrayExt.exists2"\r
 294       else begin\r
 295         let rec exists2' i =\r
 296           i < l && (f a.(i) a'.(i) || exists2' (i + 1)) in\r
 297         exists2' 0\r
 298       end\r
 299   end\r
 300 \r
 301 \r
 302 (* Instantiation functions *)\r
 303 \r
 304 let rec evaluate_toplevel_definitions dic defs =\r
 305   let rec ctx =\r
 306     {\r
 307       toplevel = lazy (dic @ evaluate defs');\r
 308       path = [];\r
 309       context_flow = None;\r
 310       context_variability = None;\r
 311       context_causality = None;\r
 312       parent_context = None;\r
 313       class_context = ToplevelContext;\r
 314       instance_context = None;\r
 315       location = {Parser.start = 0; Parser.enddd = 0; filename = Parser.CommandLine};\r
 316       instance_nature = ClassElement\r
 317     }\r
 318   and defs' = lazy (List.map (evaluate_toplevel_definition ctx) defs) in\r
 319   evaluate defs'\r
 320 \r
 321 and evaluate_toplevel_definition ctx (id, elt_desc) =\r
 322   let elt_loc = [Name id] in\r
 323   let ctx = {ctx with\r
 324                path = elt_loc;\r
 325                location = elt_desc.NameResolve.element_location;\r
 326                instance_nature = instance_nature_of_element elt_desc} in\r
 327   let elt_nat = elt_desc.NameResolve.element_nature in\r
 328   let elt_desc' =\r
 329     {\r
 330       redeclare = false;\r
 331       element_nature = lazy (evaluate_toplevel_element ctx elt_loc elt_nat)\r
 332     } in\r
 333   id, elt_desc'\r
 334 \r
 335 and evaluate_toplevel_element ctx elt_loc = function\r
 336   | NameResolve.Component cpnt_desc ->\r
 337       let cpnt_desc' =\r
 338         instantiate_component_description ctx [] None elt_loc cpnt_desc in\r
 339       Component cpnt_desc'\r
 340   | NameResolve.Class cl_def ->\r
 341       let cl_def' = evaluate_class_definition ctx [] elt_loc cl_def in\r
 342       Class cl_def'\r
 343   | NameResolve.ComponentType _ ->\r
 344       raise (InstantError\r
 345         { err_msg = ["_NotYetImplemented"; "_ComponentTypeElemInstant"];\r
 346           err_info = [];\r
 347           err_ctx = ctx }) (*error*)\r
 348   | NameResolve.PredefinedType _ ->\r
 349       raise (InstantError\r
 350         { err_msg = ["_NotYetImplemented"; "_PredefinedTypeElemInstant"];\r
 351           err_info = [];\r
 352           err_ctx = ctx }) (*error*)\r
 353 \r
 354 and instantiate_class_description ctx modifs rhs elt_loc cl_desc =\r
 355   let elements inst =\r
 356     let ctx' =\r
 357       { ctx with\r
 358         toplevel = lazy (evaluate ctx.toplevel);\r
 359         path = elt_loc;\r
 360         parent_context = Some ctx;\r
 361         class_context = InstanceContext inst;\r
 362         instance_context = None\r
 363       } in\r
 364     instantiate_class_elements ctx' modifs rhs cl_desc.long_description in\r
 365   let rec inst =\r
 366     {\r
 367       enclosing_instance = enclosing_instance ctx;\r
 368       kind = cl_desc.class_kind;\r
 369       elements = lazy (elements inst)\r
 370     } in\r
 371   inst\r
 372 \r
 373 and enclosing_instance ctx = match ctx.class_context with\r
 374   | ToplevelContext -> None\r
 375   | InstanceContext inst -> Some inst\r
 376   | ForContext (ctx', _) | FunctionEvaluationContext (ctx', _, _) ->\r
 377       enclosing_instance ctx'\r
 378 \r
 379 and instantiate_class_elements ctx modifs rhs long_desc =\r
 380   let rec merge_elements named_elts unnamed_elts = function\r
 381     | [] ->\r
 382         {\r
 383           named_elements = named_elts;\r
 384           unnamed_elements = unnamed_elts\r
 385         }\r
 386     | inherited_elts :: inherited_eltss ->\r
 387         let named_elts' = named_elts @ inherited_elts.named_elements\r
 388         and unnamed_elts' = unnamed_elts @ inherited_elts.unnamed_elements in\r
 389         merge_elements named_elts' unnamed_elts' inherited_eltss in\r
 390   let named_elts = long_desc.NameResolve.named_elements\r
 391   and unnamed_elts = long_desc.NameResolve.unnamed_elements\r
 392   and exts = long_desc.NameResolve.extensions in\r
 393   let named_elts' = instantiate_local_named_elements ctx modifs rhs named_elts\r
 394   and unnamed_elts' = instantiate_local_unnamed_elements ctx unnamed_elts\r
 395   and inherited_eltss = instantiate_inherited_elements ctx modifs rhs exts in\r
 396   merge_elements named_elts' unnamed_elts' inherited_eltss\r
 397 \r
 398 and instantiate_local_named_elements ctx modifs rhs named_elts =\r
 399   List.fold_right (instantiate_local_named_element ctx modifs rhs) named_elts []\r
 400 \r
 401 and instantiate_local_named_element ctx modifs rhs (id, elt_desc) named_elts =\r
 402   let rec filter_current_element_modifications = function\r
 403     | [] -> []\r
 404     | (id', arg) :: modifs when id' = id ->\r
 405         arg :: filter_current_element_modifications modifs\r
 406     | _ :: modifs -> filter_current_element_modifications modifs\r
 407   and select_current_element_value = function\r
 408     | None -> None\r
 409     | Some expr -> Some (lazy (field_access ctx (evaluate expr) id)) in\r
 410   let modifs' = filter_current_element_modifications modifs\r
 411   and rhs' = select_current_element_value rhs\r
 412   and elt_loc = ctx.path @ [Name id] in\r
 413   let ctx = {ctx with\r
 414                path = elt_loc;\r
 415                location = elt_desc.NameResolve.element_location;\r
 416                instance_nature = instance_nature_of_element elt_desc} in\r
 417   let elt_nat =\r
 418     lazy (instantiate_local_element_nature ctx modifs' rhs' elt_loc elt_desc) in\r
 419   let named_elt =\r
 420     id,\r
 421     {\r
 422       redeclare = elt_desc.NameResolve.redeclare;\r
 423       element_nature = elt_nat\r
 424     } in\r
 425   named_elt :: named_elts\r
 426 \r
 427 and instantiate_local_element_nature ctx modifs rhs elt_loc elt_desc =\r
 428   match elt_desc.NameResolve.element_nature with\r
 429     | NameResolve.Component cpnt_desc ->\r
 430         let cpnt_desc' =\r
 431           instantiate_component_description ctx modifs rhs elt_loc cpnt_desc in\r
 432        Component cpnt_desc'\r
 433     | NameResolve.Class cl_def ->\r
 434         let cl_def' = evaluate_class_definition ctx modifs elt_loc cl_def in\r
 435         Class cl_def'\r
 436     | NameResolve.ComponentType _ ->\r
 437         raise (InstantError\r
 438           { err_msg = ["_NotYetImplemented"; "_ComponentTypeElemInstant"];\r
 439             err_info = [];\r
 440             err_ctx = ctx })\r
 441     | NameResolve.PredefinedType _ ->\r
 442         raise (InstantError\r
 443           { err_msg = ["_NotYetImplemented"; "_PredefinedTypeElemInstant"];\r
 444             err_info = [];\r
 445             err_ctx = ctx })\r
 446 \r
 447 and instantiate_component_description ctx modifs rhs elt_loc cpnt_desc =\r
 448   let cpnt_type = evaluate cpnt_desc.NameResolve.component_type in\r
 449   let flow = evaluate cpnt_type.Types.flow\r
 450   and var = evaluate cpnt_type.Types.variability\r
 451   and inout = evaluate cpnt_type.Types.causality\r
 452   and type_spec = evaluate cpnt_desc.NameResolve.type_specifier\r
 453   and dims = evaluate cpnt_desc.NameResolve.dimensions\r
 454   and modifs' = match evaluate cpnt_desc.NameResolve.modification with\r
 455     | None -> modifs\r
 456     | Some modif ->\r
 457         let modif' = evaluate_modification ctx modif in\r
 458         modifs @ [{ each = false; action = ElementModification modif' }]\r
 459   and cmt = cpnt_desc.NameResolve.comment in\r
 460   component_nature ctx modifs' rhs elt_loc flow var inout type_spec dims cmt\r
 461 \r
 462 and component_nature ctx modifs rhs elt_loc flow var inout type_spec dims cmt =\r
 463   let type_spec' = evaluate_expression ctx type_spec in\r
 464   let ctx = {ctx with location = expression_location ctx type_spec} in\r
 465   expand_array ctx modifs rhs elt_loc flow var inout type_spec' dims cmt\r
 466 \r
 467 and expand_array ctx modifs rhs elt_loc flow var inout type_spec dims cmt =\r
 468   let rec expand_along_dimension dim dims = match dim with\r
 469     | NameResolve.Colon -> expand_dynamic_array dims\r
 470     | NameResolve.Expression expr ->\r
 471         let expr' = evaluate_expression ctx expr in\r
 472         expand_static_array dims expr' expr\r
 473   and expand_dynamic_array dims =\r
 474     (* No need to select modifications since all of them have 'each' set *)\r
 475     let elt_loc' = elt_loc @ [Index 0] in\r
 476     let ctx = { ctx with path = elt_loc' } in\r
 477     let expr =\r
 478       expand_array ctx modifs rhs elt_loc' flow var inout type_spec dims cmt in\r
 479     DynamicArray expr\r
 480   and expand_static_array dims expr' expr =\r
 481     let ctx = {ctx with location = expression_location ctx expr} in\r
 482     let expand_element i =\r
 483       let rec select_subargument arg = match arg.each with\r
 484         | true -> arg\r
 485         | false -> { arg with action = select_subarray arg.action }\r
 486       and select_subarray arg = match arg with\r
 487         | ElementModification modif ->\r
 488             ElementModification (select_submodification modif)\r
 489         | ElementRedeclaration _ -> arg\r
 490       and select_sub_class_modification_element (id, arg) =\r
 491         id, select_subargument arg\r
 492       and select_submodification = function\r
 493         | Modification (modifs, rhs) ->\r
 494             let modifs' = List.map select_sub_class_modification_element modifs\r
 495             and rhs' = select_rhs_subarray rhs in\r
 496             Modification (modifs', rhs')\r
 497         | Assignment expr ->\r
 498             let expr' = lazy (select_row i (evaluate expr)) in\r
 499             Assignment expr'\r
 500         | Equality expr ->\r
 501             let expr' = lazy (select_row i (evaluate expr)) in\r
 502             Equality expr'\r
 503       and select_rhs_subarray = function\r
 504         | None -> None\r
 505         | Some expr -> Some (lazy (select_row i (evaluate expr)))\r
 506       and select_row i = function\r
 507               | Vector exprs ->\r
 508             begin\r
 509               try\r
 510                 exprs.(i)\r
 511               with\r
 512               | _ -> raise (InstantError\r
 513                   { err_msg = ["_IndexOutOfBound"];\r
 514                     err_info = [];\r
 515                     err_ctx = ctx}) (*error*)\r
 516             end\r
 517         | expr ->\r
 518             let subs = [Integer (Int32.succ (Int32.of_int i))] in\r
 519             evaluate_indexed_access ctx expr subs in\r
 520       let modifs = List.map select_subargument modifs\r
 521       and rhs = select_rhs_subarray rhs\r
 522       and elt_loc = elt_loc @ [Index i] in\r
 523       expand_array ctx modifs rhs elt_loc flow var inout type_spec dims cmt in\r
 524     match expr' with\r
 525       | Integer i ->\r
 526           let a = Array.init (Int32.to_int i) expand_element in\r
 527           StaticArray a\r
 528       | _ ->\r
 529           raise (InstantError\r
 530           { err_msg = ["_NonIntegerArrayDim"];\r
 531             err_info = [];\r
 532             err_ctx = ctx }) (*error*) in\r
 533   match dims with\r
 534     | [] ->\r
 535         let cl_def = class_definition_of_type_specification ctx type_spec in\r
 536         create_instance ctx modifs rhs elt_loc flow var inout cl_def cmt\r
 537     | dim :: dims ->\r
 538         {\r
 539           component_path = elt_loc;\r
 540           flow = flow;\r
 541           variability = var;\r
 542           causality = inout;\r
 543           component_nature = lazy (expand_along_dimension dim dims);\r
 544           declaration_equation = rhs;\r
 545           comment = cmt;\r
 546           component_location = ctx.location;\r
 547           class_name = instance_class_name ctx.instance_nature\r
 548         }\r
 549 \r
 550 and create_instance ctx modifs rhs elt_loc flow var inout cl_def cmt =\r
 551   let merge_class_modifications arg modifs = match arg.action with\r
 552     | ElementModification (Modification (modifs', _)) -> modifs' @ modifs\r
 553     | ElementModification (Assignment _ | Equality _) -> modifs\r
 554     | ElementRedeclaration _ -> modifs in\r
 555   let rec declaration_equation modifs rhs =\r
 556     let rec declaration_equation' = function\r
 557       | [] -> None\r
 558       | {\r
 559           action =\r
 560             ElementModification (\r
 561               Modification (_, Some expr) | Assignment expr | Equality expr)\r
 562         } :: _ -> Some expr\r
 563       | _ :: args -> declaration_equation' args in\r
 564     match rhs with\r
 565       | None -> declaration_equation' modifs\r
 566       | Some _ -> rhs in\r
 567   let flow' = match cl_def.class_flow, ctx.context_flow with\r
 568     | None, None -> flow\r
 569     | Some flow', None | None, Some flow' -> flow || flow'\r
 570     | Some flow', Some flow'' -> flow || flow' || flow''\r
 571   and var' = match cl_def.class_variability, ctx.context_variability with\r
 572     | None, None -> var\r
 573     | Some var', None | None, Some var' -> Types.min_variability var var'\r
 574     | Some var', Some var'' ->\r
 575         Types.min_variability var (Types.min_variability var' var'')\r
 576   and inout' = match inout, cl_def.class_causality with\r
 577     | Types.Input, _ | _, Some Types.Input -> Types.Input\r
 578     | Types.Output, _ | _, Some Types.Output -> Types.Output\r
 579     | _ -> Types.Acausal in\r
 580   let modifs' =\r
 581     List.fold_right\r
 582       merge_class_modifications\r
 583       (modifs @ cl_def.modification)\r
 584       []\r
 585   and rhs' = declaration_equation modifs rhs in\r
 586   match cl_def.description with\r
 587     | ClassDescription (ctx', cl_desc) ->\r
 588         let class_name = instance_class_name ctx.instance_nature in\r
 589         let ctx' =\r
 590           { ctx' with\r
 591             context_flow = Some flow';\r
 592             context_variability = Some var';\r
 593             context_causality = Some inout';\r
 594             instance_context = enclosing_instance ctx;\r
 595             instance_nature = ComponentElement class_name\r
 596           } in\r
 597         {\r
 598           component_path = elt_loc;\r
 599           flow = flow';\r
 600           variability = var';\r
 601           causality = inout';\r
 602           component_nature =\r
 603             lazy (create_class_instance ctx' modifs' rhs' elt_loc cl_desc);\r
 604           declaration_equation = rhs';\r
 605           comment = cmt;\r
 606           component_location = ctx'.location;\r
 607           class_name = class_name\r
 608         }\r
 609     | PredefinedType predef ->\r
 610         let class_name = instance_class_name ctx.instance_nature in\r
 611         let ctx' =\r
 612           { ctx with\r
 613             context_flow = Some flow';\r
 614             context_variability = Some var';\r
 615             context_causality = Some inout';\r
 616             instance_nature = ComponentElement class_name\r
 617           } in\r
 618         {\r
 619           component_path = elt_loc;\r
 620           flow = flow';\r
 621           variability = var';\r
 622           causality = inout';\r
 623           component_nature =\r
 624             lazy (create_predefined_type_instance ctx' modifs' predef);\r
 625           declaration_equation = rhs';\r
 626           comment = cmt;\r
 627           component_location = ctx'.location;\r
 628           class_name = class_name\r
 629         }\r
 630 \r
 631 and create_temporary_instance ctx cl_def =\r
 632   match cl_def.description with\r
 633     | ClassDescription (ctx', cl_desc) ->\r
 634         {\r
 635           component_path = [];\r
 636           flow = false;\r
 637           variability = Types.Continuous;\r
 638           causality = Types.Acausal;\r
 639           component_nature =\r
 640             lazy (create_class_instance ctx' [] None [] cl_desc);\r
 641           declaration_equation = None;\r
 642           comment = "";\r
 643           component_location = ctx'.location;\r
 644           class_name = instance_class_name ctx.instance_nature\r
 645         }\r
 646     | PredefinedType predef -> assert false (*error*)\r
 647 \r
 648 and class_definition_of_type_specification ctx type_spec =\r
 649   let predefined_class_specifier = function\r
 650     | "Boolean" -> Types.boolean_class_type\r
 651     | "Integer" -> Types.integer_class_type\r
 652     | "Real" -> Types.real_class_type\r
 653     | "String" -> Types.string_class_type\r
 654     | s ->\r
 655         raise (InstantError\r
 656           { err_msg = ["_UnknownIdentifier"; s];\r
 657             err_info = [];\r
 658             err_ctx = ctx }) (*error*)\r
 659   and predefined_class_description = function\r
 660     | "Boolean" -> PredefinedType BooleanType\r
 661     | "Integer" -> PredefinedType IntegerType\r
 662     | "Real" -> PredefinedType RealType\r
 663     | "String" -> PredefinedType StringType\r
 664     | s ->\r
 665         raise (InstantError\r
 666           { err_msg = ["_UnknownIdentifier"; s];\r
 667             err_info = [];\r
 668             err_ctx = ctx }) (*error*) in\r
 669   match type_spec with\r
 670     | ClassReference cl_def -> cl_def\r
 671     | PredefinedIdentifier id ->\r
 672         {\r
 673           class_type = predefined_class_specifier id;\r
 674           class_path = [Name id];\r
 675           class_flow = None;\r
 676           class_variability = None;\r
 677           class_causality = None;\r
 678           description = predefined_class_description id;\r
 679           modification = [];\r
 680           class_location = ctx.location\r
 681         }\r
 682     | _ -> assert false (*error*)\r
 683 \r
 684 and create_class_instance ctx modifs rhs elt_loc cl_desc =\r
 685   let inst = instantiate_class_description ctx modifs rhs elt_loc cl_desc in\r
 686   Instance inst\r
 687 \r
 688 and create_predefined_type_instance ctx modifs predef =\r
 689   let inst =\r
 690     {\r
 691       predefined_type = predef;\r
 692       attributes = predefined_type_attributes ctx modifs\r
 693     } in\r
 694   PredefinedTypeInstance inst\r
 695 \r
 696 and predefined_type_attributes ctx modifs =\r
 697   let rec predefined_type_attributes attrs = function\r
 698     | [] -> attrs\r
 699     | (id, { action = ElementModification (Equality expr) }) :: modifs\r
 700       when not (List.mem_assoc id attrs) ->\r
 701         let attrs' = (id, expr) :: attrs in\r
 702         predefined_type_attributes attrs' modifs\r
 703     | _ :: modifs -> predefined_type_attributes attrs modifs in\r
 704   predefined_type_attributes [] modifs\r
 705 \r
 706 and instantiate_inherited_elements ctx modifs rhs exts =\r
 707   List.fold_right (instantiate_inherited_element ctx modifs rhs) exts []\r
 708 \r
 709 and instantiate_inherited_element ctx modifs rhs (_, modif_cl) inherited_elts =\r
 710   let instantiate_inherited_element' modifs cl_def =\r
 711     match cl_def.description with\r
 712       | ClassDescription (ctx', cl_desc) ->\r
 713           let ctx' = { ctx with parent_context = Some ctx' } in\r
 714           let long_desc = cl_desc.long_description in\r
 715           instantiate_class_elements ctx' modifs rhs long_desc\r
 716       | PredefinedType _ -> assert false (*error*) in\r
 717   let type_spec = evaluate modif_cl.NameResolve.base_class\r
 718   and modifs' = evaluate modif_cl.NameResolve.class_modification in\r
 719   let type_spec' = evaluate_expression ctx type_spec\r
 720   and ctx = {ctx with location = expression_location ctx type_spec} in\r
 721   let modifs = modifs @ evaluate_class_modification ctx modifs' in\r
 722   match type_spec' with\r
 723     | ClassReference cl_def ->\r
 724         instantiate_inherited_element' modifs cl_def :: inherited_elts\r
 725     | _ -> assert false (*error*)\r
 726  \r
 727 and evaluate_class_definition ctx modifs elt_loc cl_def =\r
 728   match evaluate cl_def.NameResolve.description with\r
 729     | NameResolve.LongDescription long_desc ->\r
 730         let cl_anns = long_desc.NameResolve.class_annotations in\r
 731         let cl_def' =\r
 732           {\r
 733             class_kind = Types.Class;\r
 734             class_annotations = lazy (evaluate_class_annotations ctx cl_anns);\r
 735             long_description = long_desc\r
 736           } in\r
 737         {\r
 738           class_type = evaluate cl_def.NameResolve.class_type;\r
 739           class_path = elt_loc;\r
 740           class_flow = None;\r
 741           class_variability = None;\r
 742           class_causality = None;\r
 743           description = ClassDescription (ctx, cl_def');\r
 744           modification = modifs;\r
 745           class_location = ctx.location\r
 746         }\r
 747     | NameResolve.ShortDescription short_desc ->\r
 748         raise (InstantError\r
 749           {err_msg = ["_NotYetImplemented"; "_ShortClassDef"];\r
 750            err_info = [];\r
 751            err_ctx = {ctx with path = elt_loc;\r
 752                       instance_nature = ClassElement}})\r
 753 \r
 754 and evaluate_class_annotations ctx cl_anns =\r
 755   let evaluate_inverse_function inv_func =\r
 756     let inv_func = evaluate inv_func in\r
 757     let expr =\r
 758       evaluate_expression ctx inv_func.NameResolve.function_class in\r
 759     match expr with\r
 760     | ClassReference cl_def ->\r
 761         {\r
 762           function_class = cl_def;\r
 763           arguments = inv_func.NameResolve.arguments\r
 764         }\r
 765     | _ -> assert false (*error*) in\r
 766   let evaluate_class_annotation cl_ann = match cl_ann with\r
 767     | NameResolve.InverseFunction inv_func ->\r
 768         InverseFunction (lazy (evaluate_inverse_function inv_func))\r
 769     | NameResolve.UnknownAnnotation cl_ann ->\r
 770         UnknownAnnotation cl_ann in\r
 771   List.map evaluate_class_annotation (evaluate cl_anns)\r
 772 \r
 773 and evaluate_class_modification ctx cl_modif =\r
 774   let add_modification_argument arg cl_modif' =\r
 775     match arg.NameResolve.action with\r
 776       | None -> cl_modif'\r
 777       | Some modif ->\r
 778           let arg' =\r
 779             arg.NameResolve.target,\r
 780             {\r
 781               each = arg.NameResolve.each;\r
 782               action = evaluate_modification_action ctx modif\r
 783             } in\r
 784           arg' :: cl_modif' in\r
 785   List.fold_right add_modification_argument cl_modif []\r
 786 \r
 787 and evaluate_modification_action ctx = function\r
 788   | NameResolve.ElementModification modif ->\r
 789       let modif' = evaluate_modification ctx modif in\r
 790       ElementModification modif'\r
 791   | NameResolve.ElementRedeclaration elt_desc ->\r
 792       raise (InstantError\r
 793         { err_msg = ["_NotYetImplemented"; "_ElementRedeclaration"];\r
 794           err_info = [];\r
 795           err_ctx = ctx })\r
 796 \r
 797 and evaluate_modification ctx = function\r
 798   | NameResolve.Modification (modifs, rhs) ->\r
 799       let modifs' = evaluate_class_modification ctx modifs\r
 800       and rhs' = evaluate_modification_expression ctx rhs in\r
 801       Modification (modifs', rhs')\r
 802   | NameResolve.Assignment expr ->\r
 803       let expr = evaluate expr in\r
 804       let ctx = {ctx with location = expression_location ctx expr} in\r
 805       raise (InstantError\r
 806         { err_msg = ["_NotYetImplemented"; "_AssignExprInElemModif"];\r
 807           err_info = [];\r
 808           err_ctx = ctx })\r
 809   | NameResolve.Equality expr ->\r
 810       let expr' = lazy (evaluate_expression ctx (evaluate expr)) in\r
 811       Equality expr'\r
 812 \r
 813 and evaluate_modification_expression ctx = function\r
 814   | None -> None\r
 815   | Some expr ->\r
 816       let expr' = lazy (evaluate_expression ctx (evaluate expr)) in\r
 817       Some expr'\r
 818 \r
 819 and instantiate_local_unnamed_elements ctx unnamed_elts =\r
 820   List.map (instantiate_local_unnamed_element ctx) (evaluate unnamed_elts)\r
 821 \r
 822 and instantiate_local_unnamed_element ctx unnamed_elt =\r
 823   match unnamed_elt with\r
 824     | NameResolve.EquationClause (validity, equs) ->\r
 825         EquationClause (validity, lazy (instantiate_equations ctx equs))\r
 826     | NameResolve.AlgorithmClause (validity, algs) ->\r
 827         raise (InstantError\r
 828           { err_msg = ["_NotYetImplemented"; "_AlgoClause"];\r
 829             err_info = [];\r
 830             err_ctx = ctx })\r
 831 \r
 832 and instantiate_equations ctx equs =\r
 833   let instantiate_equations' equ equs =\r
 834     let equs' =  instantiate_equation ctx equ in\r
 835     { nature = equs'; info = equ } :: equs in\r
 836   List.fold_right instantiate_equations' equs []\r
 837 \r
 838 and instantiate_equation ctx equ = match equ.NameResolve.nature with\r
 839   | NameResolve.Equal (expr, expr') -> instantiate_equal ctx expr expr'\r
 840   | NameResolve.ConditionalEquationE (alts, default) ->\r
 841       instantiate_conditional_equation ctx alts default\r
 842   | NameResolve.ForClauseE (ranges, equs) ->\r
 843       instantiate_for_clause_e ctx ranges equs\r
 844   | NameResolve.ConnectFlows (sign, expr, sign', expr') ->\r
 845       instantiate_connection ctx sign expr sign' expr'\r
 846   | NameResolve.WhenClauseE alts ->\r
 847       instantiate_when_clause_e ctx alts\r
 848 \r
 849 and instantiate_equal ctx expr expr' =\r
 850   let rec equal_expr expr expr' =\r
 851     match expr, expr' with\r
 852     | BinaryOperation (bin_oper_kind, expr1, expr2),\r
 853       BinaryOperation (bin_oper_kind', expr1', expr2') ->\r
 854         (bin_oper_kind = bin_oper_kind') &&\r
 855         (equal_expr expr1 expr1') &&\r
 856         (equal_expr expr2 expr2')\r
 857     | ClassReference cl_def, ClassReference cl_def' ->\r
 858         cl_def.class_path = cl_def'.class_path\r
 859     | ComponentReference cpnt_desc, ComponentReference cpnt_desc' ->\r
 860         cpnt_desc.component_path = cpnt_desc'.component_path\r
 861     | EnumerationElement s, EnumerationElement s' -> s = s'\r
 862     | False, False -> true\r
 863     | FieldAccess (expr, s), FieldAccess (expr', s') ->\r
 864         (equal_expr expr expr') && (s = s')\r
 865     | FunctionCall (expr, exprs), FunctionCall (expr', exprs') ->\r
 866         (equal_expr expr expr') &&\r
 867         (List.length exprs = List.length exprs') &&\r
 868         (List.for_all2 (=) exprs exprs')\r
 869     | If (alts, default), If (alts', default') ->\r
 870         let f (cond, expr) (cond', expr') =\r
 871           (equal_expr cond cond') && (equal_expr expr expr') in\r
 872         (List.length alts = List.length alts') &&\r
 873         (List.for_all2 f alts alts') &&\r
 874         (equal_expr default default')\r
 875     | IndexedAccess (expr, exprs), IndexedAccess (expr', exprs') ->\r
 876         (equal_expr expr expr') &&\r
 877         (List.length exprs = List.length exprs') &&\r
 878         (List.for_all2 (=) exprs exprs')\r
 879     | Integer i, Integer i' -> Int32.compare i i' = 0\r
 880     | LoopVariable i, LoopVariable i' -> i = i'\r
 881     | NoEvent expr, NoEvent expr' -> equal_expr expr expr'\r
 882     | PredefinedIdentifier s, PredefinedIdentifier s' -> s = s'\r
 883     | Range (start, step, stop), Range (start', step', stop') ->\r
 884         (equal_expr start start') &&\r
 885         (equal_expr step step') &&\r
 886         (equal_expr stop stop')\r
 887     | Real f, Real f' -> f = f'\r
 888     | Record elts, Record elts' ->\r
 889         let f (s, expr) (s', expr') =\r
 890           (s = s') && (equal_expr expr expr') in\r
 891         (List.length elts = List.length elts') &&\r
 892         (List.for_all2 f elts elts')\r
 893     | String s, String s' -> s = s'\r
 894     | True, True -> true\r
 895     | Tuple exprs, Tuple exprs' ->\r
 896         (List.length exprs = List.length exprs') &&\r
 897         (List.for_all2 equal_expr exprs exprs')\r
 898     | UnaryOperation (un_oper_kind, expr),\r
 899       UnaryOperation (un_oper_kind', expr') ->\r
 900         (un_oper_kind = un_oper_kind') &&\r
 901         (equal_expr expr expr')\r
 902     | Vector exprs, Vector exprs' ->\r
 903         (Array.length exprs = Array.length exprs') &&\r
 904         (ArrayExt.for_all2 equal_expr exprs exprs')\r
 905     | VectorReduction (exprs, expr), VectorReduction (exprs', expr') ->\r
 906         (List.length exprs = List.length exprs') &&\r
 907         (List.for_all2 equal_expr exprs exprs') &&\r
 908         (equal_expr expr expr')\r
 909     | _ -> false in\r
 910   let expr = evaluate_expression ctx expr\r
 911   and expr' = evaluate_expression ctx expr' in\r
 912   match equal_expr expr expr' with\r
 913   | true -> []\r
 914   | false -> [ Equal (expr, expr') ]\r
 915 \r
 916 and instantiate_conditional_equation ctx alts default =\r
 917   let rec instantiate_alternatives acc = function\r
 918     | [] -> instantiate_default acc default\r
 919     | (cond, equs) :: alts -> instantiate_alternative acc cond equs alts\r
 920   and instantiate_alternative acc cond equs alts =\r
 921     let cond' = evaluate_expression ctx cond in\r
 922     match cond' with\r
 923       | False -> instantiate_alternatives acc alts\r
 924       | True -> instantiate_default acc equs\r
 925       | _ ->\r
 926           let equs' = instantiate_equations ctx equs in\r
 927           instantiate_alternatives ((cond', equs') :: acc) alts\r
 928   and instantiate_default acc equs =\r
 929     let equs' = instantiate_equations ctx equs in\r
 930     [ConditionalEquationE (List.rev acc, equs')] in\r
 931   let alts' = instantiate_alternatives [] alts in\r
 932   List.flatten (List.map (expand_equation ctx) alts')\r
 933 \r
 934 and expand_equation ctx equ =\r
 935   let rec expand_equation' equ =\r
 936     let expand_conditional_equation alts default =\r
 937       let add_alternative (b, equs) altss =\r
 938         let g equ = List.flatten (List.map expand_equation' equ.nature) in\r
 939         let equs' = List.flatten (List.map g equs) in\r
 940         let f (expr1, expr2) (expr1', expr2') = match expr1, expr2 with\r
 941           | If (alts1, default1), If (alts2, default2) ->\r
 942               If ((b, expr1') :: alts1, default1),\r
 943               If ((b, expr2') :: alts2, default2)\r
 944           | _ -> assert false in\r
 945         try\r
 946           List.map2 f altss equs'\r
 947         with\r
 948         | _ ->\r
 949             raise (InstantError\r
 950               {err_msg = ["_InvalidCondEquation"];\r
 951                err_info = [];\r
 952                err_ctx = ctx}) in\r
 953       let g equ = List.flatten (List.map expand_equation' equ.nature) in\r
 954       let default' = List.flatten (List.map g default) in\r
 955       let f = function (expr1, expr2) -> If ([], expr1), If ([], expr2) in\r
 956       List.fold_right add_alternative alts (List.map f default') in\r
 957     match equ with\r
 958     | ConditionalEquationE (alts, default) ->\r
 959         expand_conditional_equation alts default\r
 960     | Equal (expr, expr') -> [ expr, expr' ]\r
 961     | _ ->\r
 962         raise (InstantError\r
 963           {err_msg = ["_InvalidCondEquation"];\r
 964            err_info = [];\r
 965            err_ctx = ctx}) in\r
 966   let f (expr, expr') = Equal (expr, expr') in\r
 967   List.map f (expand_equation' equ)\r
 968 \r
 969 and instantiate_when_clause_e ctx alts =\r
 970   let instantiate_alternative (cond, equs) =\r
 971     let cond' = evaluate_expression ctx cond in\r
 972     let equs' = instantiate_equations ctx equs in\r
 973     cond', equs' in\r
 974   [WhenClauseE (List.map instantiate_alternative alts)]\r
 975 \r
 976 and instantiate_connection ctx sign expr sign' expr' =\r
 977   let expr = evaluate_expression ctx expr\r
 978   and expr' = evaluate_expression ctx expr' in\r
 979   [ConnectFlows (sign, expr, sign', expr')]\r
 980 \r
 981 and instantiate_for_clause_e ctx ranges equs =\r
 982   let rec instantiate_for_clause_e' ctx = function\r
 983     | [] -> List.flatten (List.map (instantiate_equation ctx) equs)\r
 984     | ranges -> equations_of_reduction ctx ranges\r
 985   and equations_of_reduction ctx ranges = match ranges with\r
 986     | (Vector exprs) :: ranges ->\r
 987         let f expr =\r
 988           let ctx' =\r
 989             { ctx with\r
 990               class_context = ForContext (ctx, Some expr)\r
 991             } in\r
 992           instantiate_for_clause_e' ctx' ranges in\r
 993         List.flatten (List.map f (Array.to_list exprs))\r
 994     | _ ->\r
 995         raise (InstantError\r
 996           {err_msg = ["_InvalidForClauseRange"];\r
 997            err_info = [];\r
 998            err_ctx = ctx}) in\r
 999   let ranges = List.map (evaluate_expression ctx) ranges in\r
1000   instantiate_for_clause_e' ctx ranges\r
1001 \r
1002 and evaluate_expression ctx expr =\r
1003   let ctx = {ctx with location = expression_location ctx expr} in\r
1004   match expr.NameResolve.nature with\r
1005     | NameResolve.BinaryOperation (binop, expr, expr') ->\r
1006         evaluate_binary_operation ctx binop expr expr'\r
1007     | NameResolve.DynamicIdentifier (level, id) ->\r
1008         evaluate_dynamic_identifier ctx level id\r
1009     | NameResolve.False -> False\r
1010     | NameResolve.FieldAccess (expr, id) ->\r
1011         evaluate_field_access ctx expr id\r
1012     | NameResolve.FunctionArgument pos -> evaluate_function_argument ctx pos\r
1013     | NameResolve.FunctionCall (expr, exprs, expr') ->\r
1014         evaluate_function_call ctx expr exprs expr'\r
1015     | NameResolve.FunctionInvocation exprs ->\r
1016         evaluate_function_invocation ctx exprs\r
1017     | NameResolve.If (alts, default) -> evaluate_if ctx alts default\r
1018     | NameResolve.IndexedAccess (expr, exprs) ->\r
1019         let expr = evaluate_expression ctx expr\r
1020         and exprs = List.map (evaluate_expression ctx) exprs in\r
1021         evaluate_indexed_access ctx expr exprs\r
1022     | NameResolve.Integer i -> Integer i\r
1023     | NameResolve.LocalIdentifier (level, id) ->\r
1024         evaluate_local_identifier ctx level id\r
1025     | NameResolve.LoopVariable level -> evaluate_loop_variable ctx level\r
1026     | NameResolve.NoEvent expr -> evaluate_no_event ctx expr\r
1027     | NameResolve.PredefinedIdentifier id -> PredefinedIdentifier id\r
1028     | NameResolve.Range (start, step, stop) ->\r
1029         evaluate_range ctx start step stop\r
1030     | NameResolve.Real f -> Real f\r
1031     | NameResolve.String s -> String s\r
1032     | NameResolve.ToplevelIdentifier id ->\r
1033         evaluate_toplevel_identifier ctx id\r
1034     | NameResolve.True -> True\r
1035     | NameResolve.Tuple exprs -> evaluate_tuple ctx exprs\r
1036     | NameResolve.UnaryOperation (unop, expr) ->\r
1037         evaluate_unary_operation ctx unop expr\r
1038     | NameResolve.VectorReduction (ranges, expr) ->\r
1039         evaluate_vector_reduction ctx ranges expr\r
1040     | NameResolve.Vector exprs -> evaluate_vector ctx exprs\r
1041     | NameResolve.Coercion (coer, expr) ->\r
1042         evaluate_coercion ctx coer expr\r
1043 \r
1044 and evaluate_binary_operation ctx binop expr expr' =\r
1045   let expr = evaluate_expression ctx expr\r
1046   and expr' = evaluate_expression ctx expr' in\r
1047   let expr = flatten_expression expr\r
1048   and expr' = flatten_expression expr' in\r
1049   match binop with\r
1050     | NameResolve.And -> evaluate_and expr expr'\r
1051     | NameResolve.Divide -> evaluate_divide ctx expr expr'\r
1052     | NameResolve.EqualEqual -> evaluate_equalequal expr expr'\r
1053     | NameResolve.GreaterEqual -> evaluate_greater_equal expr expr'\r
1054     | NameResolve.Greater -> evaluate_greater expr expr'\r
1055     | NameResolve.LessEqual -> evaluate_less_equal expr expr'\r
1056     | NameResolve.Less -> evaluate_less expr expr'\r
1057     | NameResolve.Times -> evaluate_times expr expr'\r
1058     | NameResolve.NotEqual -> evaluate_not_equal expr expr'\r
1059     | NameResolve.Or -> evaluate_or expr expr'\r
1060     | NameResolve.Plus -> evaluate_plus expr expr'\r
1061     | NameResolve.Power -> evaluate_power ctx expr expr'\r
1062     | NameResolve.Minus -> evaluate_minus expr expr'\r
1063 \r
1064 and evaluate_dynamic_identifier ctx level id =\r
1065   let rec evaluate_dynamic_identifier' inst level =\r
1066     match level, inst.enclosing_instance with\r
1067     | 0, _ -> instance_field_access ctx inst id\r
1068     | _, Some inst -> evaluate_dynamic_identifier' inst (level - 1)\r
1069     | _, None -> assert false (*error*) in\r
1070   match ctx.instance_context with\r
1071     | Some inst -> evaluate_dynamic_identifier' inst level\r
1072     | None -> assert false (*error*)\r
1073 \r
1074 and evaluate_field_access ctx expr id =\r
1075   let expr = evaluate_expression ctx expr in\r
1076   field_access ctx expr id\r
1077 \r
1078 and evaluate_function_argument ctx pos = match ctx.class_context with\r
1079   | FunctionEvaluationContext (_, expr, _) when pos = 0 -> expr\r
1080   | FunctionEvaluationContext (_, _, exprs) -> List.nth exprs (pos - 1)\r
1081   | ForContext (ctx', _) -> evaluate_function_argument ctx' pos\r
1082   | InstanceContext _ | ToplevelContext -> assert false (*error*)\r
1083 \r
1084 and evaluate_function_call ctx expr exprs expr' =\r
1085   let expr = evaluate_expression ctx expr\r
1086   and exprs = List.map (evaluate_expression ctx) exprs in\r
1087   let exprs = List.map flatten_expression exprs in\r
1088   let ctx' =\r
1089     { ctx with\r
1090       class_context = FunctionEvaluationContext (ctx, expr, exprs)\r
1091     } in\r
1092   evaluate_expression ctx' expr'\r
1093 \r
1094 and evaluate_function_invocation ctx exprs =\r
1095   let exprs = List.map (evaluate_expression ctx) exprs in\r
1096   let exprs = List.map flatten_expression exprs in\r
1097   let evaluate_function_with_arguments = function\r
1098     | ClassReference cl_def ->\r
1099         evaluate_class_function_invocation cl_def exprs\r
1100     | PredefinedIdentifier s ->\r
1101         evaluate_predefined_function_invocation ctx s exprs\r
1102     | ComponentReference _ ->\r
1103         raise (InstantError\r
1104           { err_msg = ["_NotYetImplemented"; "_ComponentFuncInvocation"];\r
1105             err_info = [];\r
1106             err_ctx = ctx })\r
1107     | _ -> assert false (*error*) in\r
1108   let rec evaluate_function_invocation' ctx = match ctx.class_context with\r
1109     | FunctionEvaluationContext (_, expr, _) ->\r
1110         evaluate_function_with_arguments expr\r
1111     | ForContext (ctx', _) -> evaluate_function_invocation' ctx'\r
1112     | InstanceContext _ | ToplevelContext -> assert false (*error*) in\r
1113   evaluate_function_invocation' ctx\r
1114 \r
1115 and evaluate_if ctx alts default =\r
1116   let create_if alts default = match alts with\r
1117     | [] -> default\r
1118     | _ :: _ -> If (alts, default) in\r
1119   let rec evaluate_alternatives alts' alts = match alts with\r
1120     | [] ->\r
1121         let default = evaluate_expression ctx default in\r
1122         create_if (List.rev alts') default\r
1123     | (expr, expr') :: alts ->\r
1124         let expr = evaluate_expression ctx expr in\r
1125         evaluate_alternative expr expr' alts' alts\r
1126   and evaluate_alternative expr expr' alts' alts = match expr with\r
1127     | True ->\r
1128         let default = evaluate_expression ctx expr' in\r
1129         create_if (List.rev alts') default\r
1130     | False -> evaluate_alternatives alts' alts\r
1131     | _ ->\r
1132         let expr' = evaluate_expression ctx expr' in\r
1133         evaluate_alternatives ((expr, expr') :: alts') alts in\r
1134   evaluate_alternatives [] alts\r
1135 \r
1136 and evaluate_indexed_access ctx expr exprs =\r
1137   let rec vector_indexed_access exprs' exprs = match exprs with\r
1138     | [] -> expr\r
1139     | Integer i :: exprs ->\r
1140         let expr' =\r
1141           try\r
1142             exprs'.(Int32.to_int i - 1)\r
1143           with _ ->\r
1144               raise (InstantError\r
1145                 { err_msg = ["_IndexOutOfBound"];\r
1146                   err_info = [];\r
1147                   err_ctx = ctx}) (*error*) in\r
1148         evaluate_indexed_access ctx expr' exprs\r
1149     | (Vector subs) :: exprs ->\r
1150         let f sub = vector_indexed_access exprs' (sub :: exprs) in\r
1151         Vector (Array.map f subs)\r
1152     | _ -> IndexedAccess (expr, exprs)\r
1153   and component_indexed_access cpnt_desc exprs =\r
1154     let rec static_array_indexed_access cpnt_descs exprs = match exprs with\r
1155       | [] -> expr\r
1156       | Integer i :: exprs ->\r
1157           let i' = Int32.to_int i in\r
1158           if Array.length cpnt_descs >= i' then\r
1159             let cpnt_desc = cpnt_descs.(i' - 1) in\r
1160             let expr' = ComponentReference cpnt_desc in\r
1161             evaluate_indexed_access ctx expr' exprs\r
1162           else\r
1163             raise (InstantError\r
1164               { err_msg = ["_IndexOutOfBound"];\r
1165                 err_info = [];\r
1166                 err_ctx = ctx}) (*error*)\r
1167       | (Vector subs) :: exprs ->\r
1168           let f sub = static_array_indexed_access cpnt_descs (sub :: exprs) in\r
1169           Vector (Array.map f subs)\r
1170       | exprs -> IndexedAccess (expr, exprs) in\r
1171     match evaluate cpnt_desc.component_nature with\r
1172     | DynamicArray _ -> IndexedAccess (ComponentReference cpnt_desc, exprs)\r
1173     | StaticArray cpnt_descs ->\r
1174         static_array_indexed_access cpnt_descs exprs\r
1175     | Instance _ | PredefinedTypeInstance _ -> expr in\r
1176   match expr, exprs with\r
1177   | _, [] -> expr\r
1178   | ComponentReference cpnt_desc, _ ->\r
1179       component_indexed_access cpnt_desc exprs\r
1180   | Vector exprs', _ ->\r
1181       vector_indexed_access exprs' exprs\r
1182   | If (alts, default), _ ->\r
1183       let f (cond, expr) = (cond, evaluate_indexed_access ctx expr exprs) in\r
1184       If (List.map f alts, evaluate_indexed_access ctx default exprs)\r
1185   | _ -> IndexedAccess (expr, exprs)\r
1186 \r
1187 and evaluate_local_identifier ctx level id =\r
1188   let rec evaluate_local_identifier' ctx inst level =\r
1189     match level, ctx.parent_context with\r
1190       | 0, _ -> instance_field_access ctx inst id\r
1191       | _, Some ctx -> evaluate_local_identifier ctx (level - 1) id\r
1192       | _, None -> assert false (*error*) in\r
1193   match ctx.class_context with\r
1194     | ForContext (ctx, _) | FunctionEvaluationContext (ctx, _, _) ->\r
1195         evaluate_local_identifier ctx level id\r
1196     | InstanceContext inst -> evaluate_local_identifier' ctx inst level\r
1197     | ToplevelContext -> assert false (*error*)\r
1198 \r
1199 and evaluate_loop_variable ctx level =\r
1200   let rec evaluate_loop_variable' ctx level' =\r
1201     match level', ctx.class_context with\r
1202       | 0, ForContext (_, None) -> assert false (*LoopVariable level'*)\r
1203       | 0, ForContext (_, Some expr) -> expr\r
1204       | _, ForContext (ctx, _) -> evaluate_loop_variable ctx (level' - 1)\r
1205       | _, FunctionEvaluationContext (ctx, _, _) ->\r
1206           evaluate_loop_variable' ctx level'\r
1207       | _, (InstanceContext _ | ToplevelContext) -> assert false (*error*) in\r
1208   evaluate_loop_variable' ctx level\r
1209 \r
1210 and evaluate_no_event ctx expr =\r
1211   let expr = evaluate_expression ctx expr in\r
1212   match expr with\r
1213     | True | False | Integer _ | Real _ | String _ | EnumerationElement _ ->\r
1214         expr\r
1215     | _ -> NoEvent expr\r
1216 \r
1217 and evaluate_range ctx start step stop =\r
1218   let start = evaluate_expression ctx start\r
1219   and step = evaluate_expression ctx step\r
1220   and stop = evaluate_expression ctx stop in\r
1221   let real_of_expression expr = match expr with\r
1222     | Real r -> r\r
1223     | Integer i -> Int32.to_float i\r
1224     | _ -> assert false in\r
1225   let integer_interval istart istep istop = match istart, istep, istop with\r
1226     | _\r
1227       when (Int32.compare istop istart) *\r
1228         (Int32.compare istep Int32.zero) < 0 ->\r
1229         Vector (Array.make 0 (Integer istart))\r
1230     | _ ->\r
1231         let n =\r
1232           Int32.div (Int32.sub istop istart) istep in\r
1233         let n' = Int32.to_int (Int32.succ n) in\r
1234         let f i =\r
1235           let i' = Int32.of_int i in\r
1236           let j =\r
1237             Int32.add istart (Int32.mul i' istep) in\r
1238           Integer j in\r
1239         Vector (Array.init n' f)\r
1240   and real_interval rstart rstep rstop = match rstart, rstep, rstop with\r
1241     | _ when (rstop -. rstart) /. rstep < 0. ->\r
1242         Vector (Array.make 0 (Real rstart))\r
1243     | _ ->\r
1244         let n = truncate ((rstop -. rstart) /. rstep) + 1\r
1245         and f i = Real (rstart +. float_of_int i *. rstep) in\r
1246         Vector (Array.init n f) in\r
1247   match start, step, stop with\r
1248   | _, Integer istep, _\r
1249     when Int32.compare istep Int32.zero = 0 ->\r
1250       raise (InstantError\r
1251         {err_msg = ["_RangeStepValueCannotBeNull"];\r
1252          err_info = [];\r
1253          err_ctx = ctx})\r
1254   | _, Real rstep, _ when rstep = 0. ->\r
1255       raise (InstantError\r
1256         {err_msg = ["_RangeStepValueCannotBeNull"];\r
1257          err_info = [];\r
1258          err_ctx = ctx})\r
1259   | Integer istart, Integer istep, Integer istop ->\r
1260       integer_interval istart istep istop\r
1261   | (Integer _ | Real _), (Integer _ | Real _), (Integer _ | Real _) ->\r
1262       let rstart = real_of_expression start\r
1263       and rstep = real_of_expression step\r
1264       and rstop = real_of_expression stop in\r
1265       real_interval rstart rstep rstop\r
1266   | _, _, _ -> Range (start, step, stop)\r
1267 \r
1268 and evaluate_coercion ctx coer expr =\r
1269   let rec evaluate_real_of_integer expr' = match expr' with\r
1270     | Integer i -> Real (Int32.to_float i)\r
1271     | Vector exprs ->\r
1272         Vector (Array.map evaluate_real_of_integer exprs)\r
1273     | _ -> expr' in\r
1274   let expr' = evaluate_expression ctx expr in\r
1275   match coer with\r
1276   | NameResolve.RealOfInteger -> evaluate_real_of_integer expr'\r
1277 \r
1278 and evaluate_toplevel_identifier ctx id =\r
1279   let elt_desc = List.assoc id (evaluate ctx.toplevel) in\r
1280   match evaluate elt_desc.element_nature with\r
1281     | Class cl_def -> ClassReference cl_def\r
1282     | Component cpnt_desc -> ComponentReference cpnt_desc\r
1283 \r
1284 and evaluate_tuple ctx exprs =\r
1285   Tuple (List.map (evaluate_expression ctx) exprs)\r
1286 \r
1287 and evaluate_unary_operation ctx unop expr =\r
1288   let expr = evaluate_expression ctx expr in\r
1289   let expr = flatten_expression expr in\r
1290   match unop with\r
1291     | NameResolve.Not -> evaluate_not expr\r
1292     | NameResolve.UnaryMinus -> evaluate_unary_minus expr\r
1293     | NameResolve.UnaryPlus -> expr\r
1294 \r
1295 (*and evaluate_vector_reduction ctx ranges expr =\r
1296   let rec evaluate_vector_reduction' ctx = function\r
1297     | [] -> evaluate_expression ctx expr\r
1298     | ranges -> vector_of_reduction ctx ranges\r
1299   and vector_of_reduction ctx = function\r
1300     | Range (Integer start, Integer step, Integer stop) :: ranges ->\r
1301         vector_of_range ctx start step stop ranges\r
1302     | ranges ->\r
1303         let ctx' =\r
1304           { ctx with\r
1305             class_context = ForContext (ctx, None)\r
1306           } in\r
1307         VectorReduction (ranges, evaluate_expression ctx' expr)\r
1308   and vector_of_range ctx start step stop ranges =\r
1309     let rec expression_list pred start = match pred start with\r
1310       | true -> []\r
1311       | false ->\r
1312           let ctx' =\r
1313             { ctx with\r
1314               class_context = ForContext (ctx, Some (Integer start))\r
1315             } in\r
1316           let expr = evaluate_vector_reduction' ctx' ranges in\r
1317           expr :: expression_list pred (Int32.add start step) in\r
1318     let cmp = Int32.compare step 0l in\r
1319     match cmp with\r
1320       | 0 when Int32.compare start stop <> 0 -> assert false (*error*)\r
1321       | 0 -> Vector [||]\r
1322       | _ when cmp < 0 ->\r
1323           let pred = function i -> Int32.compare i stop < 0 in\r
1324           let exprs = expression_list pred start in\r
1325           Vector (Array.of_list exprs)\r
1326       | _ ->\r
1327           let pred = function i -> Int32.compare i stop > 0 in\r
1328           let exprs = expression_list pred start in\r
1329           Vector (Array.of_list exprs) in\r
1330   let ranges = List.map (evaluate_expression ctx) ranges in\r
1331   evaluate_vector_reduction' ctx ranges*)\r
1332 \r
1333 and evaluate_vector_reduction ctx ranges expr =\r
1334   let rec evaluate_vector_reduction' ctx = function\r
1335     | [] -> evaluate_expression ctx expr\r
1336     | ranges -> vector_of_reduction ctx ranges\r
1337   and vector_of_reduction ctx = function\r
1338     | Range (Integer u, Integer p, Integer v) :: ranges ->\r
1339         vector_of_integer_range ctx u p v ranges\r
1340     | Range (Real u, Real p, Real v) :: ranges ->\r
1341         vector_of_real_range ctx u p v ranges\r
1342     | Vector exprs :: ranges ->\r
1343         let f i =\r
1344           let ctx' =\r
1345             { ctx with\r
1346               class_context = ForContext (ctx, Some exprs.(i))\r
1347             } in\r
1348           evaluate_vector_reduction' ctx' ranges in\r
1349         Vector (Array.init (Array.length exprs) f)\r
1350     | _ -> assert false\r
1351   and vector_of_integer_range ctx start step stop ranges =\r
1352     let rec expression_list pred start = match pred start with\r
1353       | true -> []\r
1354       | false ->\r
1355           let expr = Integer start in\r
1356           let ctx' =\r
1357             { ctx with\r
1358               class_context =\r
1359                 ForContext (ctx, Some expr)\r
1360             } in\r
1361           let expr = evaluate_vector_reduction' ctx' ranges in\r
1362           let next = Int32.add start step in\r
1363           expr :: expression_list pred next in\r
1364     match step with\r
1365     | _ when Int32.compare step Int32.zero = 0 ->\r
1366         raise (InstantError\r
1367           {err_msg = ["_RangeStepValueCannotBeNull"];\r
1368            err_info = [];\r
1369            err_ctx = ctx})\r
1370     | _ when Int32.compare step Int32.zero < 0 ->\r
1371         let pred = function i -> (Int32.compare i stop < 0) in\r
1372         Vector (Array.of_list (expression_list pred start))\r
1373     | _ ->\r
1374         let pred = function i -> (Int32.compare i stop > 0) in\r
1375         Vector (Array.of_list (expression_list pred start))\r
1376   and vector_of_real_range ctx start step stop ranges =\r
1377     let rec expression_list pred start = match pred start with\r
1378       | true -> []\r
1379       | false ->\r
1380           let expr = Real start in\r
1381           let ctx' =\r
1382             { ctx with\r
1383               class_context = ForContext (ctx, Some expr)\r
1384             } in\r
1385           let expr = evaluate_vector_reduction' ctx' ranges in\r
1386           expr :: expression_list pred (start +. step) in\r
1387     match step with\r
1388     | 0. ->\r
1389         raise (InstantError\r
1390           {err_msg = ["_RangeStepValueCannotBeNull"];\r
1391            err_info = [];\r
1392            err_ctx = ctx})\r
1393     | _ when step < 0. ->\r
1394         let pred = function f -> f < stop in\r
1395         Vector (Array.of_list (expression_list pred start))\r
1396     | _ ->\r
1397         let pred = function f -> f > stop in\r
1398         Vector (Array.of_list (expression_list pred start)) in\r
1399   let ranges = List.map (evaluate_expression ctx) ranges in\r
1400   evaluate_vector_reduction' ctx ranges\r
1401 \r
1402 and evaluate_vector ctx exprs =\r
1403   let exprs = List.map (evaluate_expression ctx) exprs in\r
1404   Vector (Array.of_list exprs)\r
1405 \r
1406 and evaluate_and expr expr' = match expr, expr' with\r
1407   | False, (False | True) | True, False -> False\r
1408   | True, True -> True\r
1409   | Vector exprs, Vector exprs' ->\r
1410       Vector (ArrayExt.map2 evaluate_and exprs exprs')\r
1411   | _ -> BinaryOperation (And, expr, expr')\r
1412 \r
1413 and evaluate_divide ctx expr expr' = match expr, expr' with\r
1414   | _, Integer 0l ->\r
1415       raise (InstantError\r
1416         { err_msg = ["_DivisionByZero"];\r
1417           err_info = [];\r
1418           err_ctx = ctx }) (*error*)\r
1419   | Integer 0l, _ -> Integer 0l\r
1420   | Integer i, Integer i' ->\r
1421       Real ((Int32.to_float i) /. (Int32.to_float i'))\r
1422   | _, Real 0. ->\r
1423       raise (InstantError\r
1424         { err_msg = ["_DivisionByZero"];\r
1425           err_info = [];\r
1426           err_ctx = ctx }) (*error*)\r
1427   | Integer i, Real f -> Real (Int32.to_float i /. f)\r
1428   | Real f, Integer i -> Real (f /. Int32.to_float i)\r
1429   | Real f, Real f' -> Real (f /. f')\r
1430   | Vector exprs, _ ->\r
1431       let divide_element expr = evaluate_divide ctx expr expr' in\r
1432       Vector (Array.map divide_element exprs)\r
1433   | _ -> BinaryOperation (Divide, expr, expr')\r
1434 \r
1435 and evaluate_equalequal expr expr' = match expr, expr' with\r
1436   | Integer i, Integer i' when i = i' -> True\r
1437   | Integer i, Real f | Real f, Integer i when f = Int32.to_float i -> True\r
1438   | Real f, Real f' when f = f' -> True\r
1439   | (Integer _ | Real _), (Integer _ | Real _) -> False\r
1440   | Vector exprs, Vector exprs'\r
1441     when\r
1442       ArrayExt.for_all2\r
1443         (fun expr expr' -> evaluate_equalequal expr expr' = True)\r
1444         exprs\r
1445         exprs' -> True\r
1446   | Vector _, Vector _ -> False\r
1447   | _ -> BinaryOperation (EqualEqual, expr, expr')\r
1448 \r
1449 and evaluate_greater_equal expr expr' = match expr, expr' with\r
1450   | Integer i, Integer i' when i >= i' -> True\r
1451   | Integer i, Real f when Int32.to_float i >= f -> True\r
1452   | Real f, Integer i when f >= Int32.to_float i -> True\r
1453   | Real f, Real f' when f >= f' -> True\r
1454   | (Integer _ | Real _), (Integer _ | Real _) -> False\r
1455   | _ -> BinaryOperation (GreaterEqual, expr, expr')\r
1456 \r
1457 and evaluate_greater expr expr' = match expr, expr' with\r
1458   | Integer i, Integer i' when i > i' -> True\r
1459   | Integer i, Real f when Int32.to_float i > f -> True\r
1460   | Real f, Integer i when f > Int32.to_float i -> True\r
1461   | Real f, Real f' when f > f' -> True\r
1462   | (Integer _ | Real _), (Integer _ | Real _) -> False\r
1463   | _ -> BinaryOperation (Greater, expr, expr')\r
1464 \r
1465 and evaluate_less_equal expr expr' = match expr, expr' with\r
1466   | Integer i, Integer i' when i <= i' -> True\r
1467   | Integer i, Real f when Int32.to_float i <= f -> True\r
1468   | Real f, Integer i when f <= Int32.to_float i -> True\r
1469   | Real f, Real f' when f <= f' -> True\r
1470   | (Integer _ | Real _), (Integer _ | Real _) -> False\r
1471   | _ -> BinaryOperation (LessEqual, expr, expr')\r
1472 \r
1473 and evaluate_less expr expr' = match expr, expr' with\r
1474   | Integer i, Integer i' when i < i' -> True\r
1475   | Integer i, Real f when Int32.to_float i < f -> True\r
1476   | Real f, Integer i when f < Int32.to_float i -> True\r
1477   | Real f, Real f' when f < f' -> True\r
1478   | (Integer _ | Real _), (Integer _ | Real _) -> False\r
1479   | _ -> BinaryOperation (Less, expr, expr')\r
1480 \r
1481 and evaluate_times expr expr' =\r
1482   let rec line exprs i = match exprs.(i) with\r
1483     | Vector exprs -> exprs\r
1484     | _ -> assert false\r
1485   and column exprs j =\r
1486     let f i = match exprs.(i) with\r
1487       | Vector exprs -> exprs.(j)\r
1488       | _ -> assert false in\r
1489     Array.init (Array.length exprs) f\r
1490   and ndims expr = match expr with\r
1491     | Vector exprs when Array.length exprs = 0 -> assert false\r
1492     | Vector exprs -> 1 + ndims exprs.(0)\r
1493     | _ -> 0\r
1494   and size expr i = match expr, i with\r
1495     | _, 0 -> assert false\r
1496     | Vector exprs, 1 -> Array.length exprs\r
1497     | _, 1 -> 0\r
1498     | Vector exprs, _ when i > 1 -> size exprs.(0) (i - 1)\r
1499     | _, _ -> assert false\r
1500   and vector_mult exprs exprs' =\r
1501     let exprs = ArrayExt.map2 evaluate_times exprs exprs' in\r
1502     match Array.length exprs with\r
1503     | 0 -> assert false\r
1504     | 1 -> exprs.(0)\r
1505     | n ->\r
1506         let exprs' = Array.sub exprs 1 (n - 1) in\r
1507         Array.fold_left evaluate_plus exprs.(0) exprs' in\r
1508   match expr, expr' with\r
1509   | Integer 0l, _ | _, Integer 0l -> Integer 0l\r
1510   | Integer 1l, _ -> expr'\r
1511   | _, Integer 1l -> expr\r
1512   | Integer i, Integer i' -> Integer (Int32.mul i i')\r
1513   | Integer i, Real f | Real f, Integer i -> Real (f *. Int32.to_float i)\r
1514   | Real f, Real f' -> Real (f *. f')\r
1515   | _, Vector exprs' when (ndims expr = 0) ->\r
1516       Vector (Array.map (evaluate_times expr) exprs')\r
1517   | Vector exprs, _ when (ndims expr' = 0) ->\r
1518       Vector (Array.map (evaluate_times expr') exprs)\r
1519   | Vector exprs, Vector exprs' when (ndims expr = 1) && (ndims expr' = 1) ->\r
1520       vector_mult exprs exprs'\r
1521   | Vector exprs, Vector exprs' when (ndims expr = 1) && (ndims expr' = 2) ->\r
1522       let f j = vector_mult exprs (column exprs' j) in\r
1523       Vector (Array.init (size expr' 2) f)\r
1524   | Vector exprs, Vector exprs' when (ndims expr = 2) && (ndims expr' = 1) ->\r
1525       let f i = vector_mult (line exprs i) exprs' in\r
1526       Vector (Array.init (size expr 1) f)\r
1527   | Vector exprs, Vector exprs' when (ndims expr = 2) && (ndims expr' = 2) ->\r
1528       let f i j = vector_mult (line exprs i) (column exprs' j) in\r
1529       let g i = Vector (Array.init (size expr' 2) (f i)) in\r
1530       Vector (Array.init (size expr 1) g)\r
1531   | _ -> BinaryOperation (Times, expr, expr')\r
1532 \r
1533 and evaluate_not_equal expr expr' = match expr, expr' with\r
1534   | Integer i, Integer i' when i <> i' -> True\r
1535   | Integer i, Real f | Real f, Integer i when f <> Int32.to_float i -> True\r
1536   | Real f, Real f' when f <> f' -> True\r
1537   | (Integer _ | Real _), (Integer _ | Real _) -> False\r
1538   | Vector exprs, Vector exprs'\r
1539     when\r
1540       ArrayExt.exists2\r
1541         (fun expr expr' -> evaluate_equalequal expr expr' = False)\r
1542         exprs\r
1543         exprs' -> True\r
1544   | Vector _, Vector _ -> False\r
1545   | _ -> BinaryOperation (NotEqual, expr, expr')\r
1546 \r
1547 and evaluate_or expr expr' = match expr, expr' with\r
1548   | True, (False | True) | False, True -> True\r
1549   | False, False -> False\r
1550   | Vector exprs, Vector exprs' ->\r
1551       Vector (ArrayExt.map2 evaluate_or exprs exprs')\r
1552   | _ -> BinaryOperation (Or, expr, expr')\r
1553 \r
1554 and evaluate_plus expr expr' = match expr, expr' with\r
1555   | Integer 0l, _ -> expr'\r
1556   | _, Integer 0l -> expr\r
1557   | Integer i, Integer i' -> Integer (Int32.add i i')\r
1558   | Integer i, Real f | Real f, Integer i -> Real (f +. Int32.to_float i)\r
1559   | Real f, Real f' -> Real (f +. f')\r
1560   | Vector exprs, Vector exprs' ->\r
1561       Vector (ArrayExt.map2 evaluate_plus exprs exprs')\r
1562   | _ -> BinaryOperation (Plus, expr, expr')\r
1563 \r
1564 and evaluate_power ctx expr expr' =\r
1565   match expr, expr' with\r
1566   | (Integer 0l | Real 0.), (Integer 0l | Real 0.) ->\r
1567       raise (InstantError\r
1568         { err_msg = ["_ZeroRaisedToTheZeroPower"];\r
1569           err_info = [];\r
1570           err_ctx = ctx }) (*error*)\r
1571   | (Integer 0l | Real 0.), Integer i'\r
1572     when Int32.compare i' 0l < 0 ->\r
1573       raise (InstantError\r
1574         { err_msg = ["_ZeroRaisedToNegativePower"];\r
1575           err_info = [];\r
1576           err_ctx = ctx }) (*error*)\r
1577   | (Integer 0l | Real 0.), Real f' when f' < 0. ->\r
1578       raise (InstantError\r
1579         { err_msg = ["_ZeroRaisedToNegativePower"];\r
1580           err_info = [];\r
1581           err_ctx = ctx }) (*error*)\r
1582   | Integer 0l, Integer _ ->\r
1583       (* We know the answer for sure since second argument is constant *)\r
1584       Real 0.\r
1585   | (Integer 0l | Real 0.), (Integer _ | Real _) -> Real 0.\r
1586   | Integer i, Real _ when Int32.compare i 0l < 0 ->\r
1587       raise (InstantError\r
1588         { err_msg = ["_RealExponentOfNegativeNumber"];\r
1589           err_info = [];\r
1590           err_ctx = ctx }) (*error*)\r
1591   | Real f, Real _ when f < 0. ->\r
1592       raise (InstantError\r
1593         { err_msg = ["_RealExponentOfNegativeNumber"];\r
1594           err_info = [];\r
1595           err_ctx = ctx }) (*error*)\r
1596   | Integer i, Integer i' ->\r
1597       Real ((Int32.to_float i) ** (Int32.to_float i'))\r
1598   | Integer i, Real f -> Real ((Int32.to_float i) ** f)\r
1599   | Real f, Integer i' -> Real (f ** (Int32.to_float i'))\r
1600   | Real f, Real f' -> Real (f ** f')\r
1601   | Vector exprs, Integer i ->\r
1602       raise (InstantError\r
1603         { err_msg = ["_NotYetImplemented";\r
1604                      "_VectorRaisedToIntegerPower"];\r
1605           err_info = [];\r
1606           err_ctx = ctx })\r
1607   | _ -> BinaryOperation (Power, expr, expr')\r
1608 \r
1609 and evaluate_minus expr expr' = match expr, expr' with\r
1610   | Integer 0l, _ -> evaluate_unary_minus expr'\r
1611   | _, Integer 0l -> expr\r
1612   | Integer i, Integer i' -> Integer (Int32.sub i i')\r
1613   | Integer i, Real f -> Real (Int32.to_float i -. f)\r
1614   | Real f, Integer i -> Real (f -. Int32.to_float i)\r
1615   | Real f, Real f' -> Real (f -. f')\r
1616   | Vector exprs, Vector exprs' ->\r
1617       Vector (ArrayExt.map2 evaluate_minus exprs exprs')\r
1618   | _ -> BinaryOperation (Minus, expr, expr')\r
1619 \r
1620 and evaluate_class_function_invocation cl_def exprs =\r
1621   FunctionCall (ClassReference cl_def, exprs)\r
1622 \r
1623 and evaluate_predefined_function_invocation ctx s exprs =\r
1624   match s, exprs with\r
1625   | "size", _ -> evaluate_size exprs\r
1626   | "reinit", [expr; expr'] -> evaluate_reinit expr expr'\r
1627   | "der", [expr] -> evaluate_der expr\r
1628   | "pre", [expr] -> evaluate_pre expr\r
1629   | ("edge" | "change" | "initial" | "terminal" | "sample" |\r
1630     "delay" | "assert" | "terminate"), _ ->\r
1631       raise (InstantError\r
1632         { err_msg = ["_NotYetImplemented"; "_PredefinedOperator"; s];\r
1633           err_info = [];\r
1634           err_ctx = ctx}) (*error*)\r
1635   | "abs", [expr] -> evaluate_abs expr\r
1636   | "sign", [expr] -> evaluate_sign expr\r
1637   | "cos", [expr] -> evaluate_cos expr\r
1638   | "sin", [expr] -> evaluate_sin expr\r
1639   | "tan", [expr] -> evaluate_tan expr\r
1640   | "exp", [expr] -> evaluate_exp expr\r
1641   | "log", [expr] -> evaluate_log expr\r
1642   | "sqrt", [expr] -> evaluate_sqrt expr\r
1643   | "asin", [expr] -> evaluate_asin expr\r
1644   | "acos", [expr] -> evaluate_acos expr\r
1645   | "atan", [expr] -> evaluate_atan expr\r
1646   | "sinh", [expr] -> evaluate_sinh expr\r
1647   | "cosh", [expr] -> evaluate_cosh expr\r
1648   | "tanh", [expr] -> evaluate_tanh expr\r
1649   | "asinh", [expr] -> evaluate_asinh expr\r
1650   | "acosh", [expr] -> evaluate_acosh expr\r
1651   | "atanh", [expr] -> evaluate_atanh expr\r
1652   | "log10", [expr] -> evaluate_log10 expr\r
1653   | "max", [expr; expr'] -> evaluate_max expr expr'\r
1654   | "min", [expr; expr'] -> evaluate_min expr expr'\r
1655   | "div", [expr; expr'] -> evaluate_div ctx expr expr'\r
1656   | "mod", [expr; expr'] -> evaluate_mod expr expr'\r
1657   | "rem", [expr; expr'] -> evaluate_rem expr expr'\r
1658   | "ceil", [expr] -> evaluate_ceil expr\r
1659   | "floor", [expr] -> evaluate_floor expr\r
1660   | "max", [expr] -> evaluate_max_array expr\r
1661   | "min", [expr] -> evaluate_min_array expr\r
1662   | "sum", [expr] -> evaluate_sum expr\r
1663   | "product", [expr] -> evaluate_product expr\r
1664   | "scalar", [expr] -> evaluate_scalar ctx expr\r
1665   | "ones", exprs -> evaluate_ones ctx exprs\r
1666   | "zeros", exprs -> evaluate_zeros ctx exprs\r
1667   | "fill", expr :: exprs -> evaluate_fill ctx expr exprs\r
1668   | "identity", [expr] -> evaluate_identity ctx expr\r
1669   | "diagonal", [expr] -> evaluate_diagonal ctx expr\r
1670   | "vector", [ expr ] -> evaluate_vector_operator ctx expr\r
1671   | "matrix", [ expr ] -> evaluate_matrix_operator ctx expr\r
1672   | "transpose", [ expr ] -> evaluate_transpose expr\r
1673   | "symmetric", [ expr ] -> evaluate_symmetric ctx expr\r
1674   | _ ->\r
1675       raise (InstantError\r
1676         { err_msg = ["_UnknownFunction"; s];\r
1677           err_info = [];\r
1678           err_ctx = ctx}) (*error*)\r
1679 \r
1680 and evaluate_symmetric ctx expr = match expr with\r
1681   | Vector [||] -> assert false\r
1682   | Vector exprs when size exprs.(0) 0 <> Array.length exprs ->\r
1683       raise (InstantError\r
1684         { err_msg = ["_InvalidArgOfOper"; "symmetric"];\r
1685           err_info = [];\r
1686           err_ctx = ctx }) (*error*)\r
1687   | Vector exprs ->\r
1688       let f i j =\r
1689         if i > j then element i (element j expr)\r
1690         else element j (element i expr) in\r
1691       let n = Array.length exprs in\r
1692       let g i = Vector (Array.init n (f i)) in\r
1693       Vector (Array.init n g)\r
1694    | _ -> assert false\r
1695 \r
1696 and evaluate_transpose expr =\r
1697   match expr with\r
1698   | Vector exprs  ->\r
1699       let f i = Vector (Array.map (element i) exprs) in\r
1700       Vector (Array.init (size expr 1) f)\r
1701   | _ -> assert false\r
1702 \r
1703 and evaluate_matrix_operator ctx expr =\r
1704   let rec scalar expr = match expr with\r
1705     | Vector [| expr |] -> scalar expr\r
1706     | Vector _ ->\r
1707         raise (InstantError\r
1708           { err_msg = ["_InvalidArgOfOper"; "matrix"];\r
1709             err_info = [];\r
1710             err_ctx = ctx }) (*error*)\r
1711     | _ -> expr in\r
1712   match expr with\r
1713   | _ when ndims expr < 2 ->\r
1714       evaluate_promote ctx 2 expr\r
1715   | _ when ndims expr = 2 -> expr\r
1716   | Vector exprs ->\r
1717       let f expr = Vector (Array.map scalar (array_elements expr)) in\r
1718       Vector (Array.map f exprs)\r
1719   | _ -> assert false\r
1720 \r
1721 and evaluate_promote ctx n expr =\r
1722   let rec evaluate_promote' i expr =\r
1723     match expr with\r
1724     | _ when i = 0 -> expr\r
1725     | Vector exprs when i > 0 ->\r
1726         Vector (Array.map (evaluate_promote' i) exprs)\r
1727     | _ when i > 0 ->\r
1728         Vector [| evaluate_promote' (i - 1) expr |]\r
1729     | _ -> assert false in\r
1730   match ndims expr with\r
1731   | n' when n' < n ->\r
1732       evaluate_promote' (n - n') expr\r
1733   | _ -> expr\r
1734 \r
1735 and evaluate_vector_operator ctx expr =\r
1736   let rec evaluate_scalar expr = match expr with\r
1737     | Vector [| expr |] -> evaluate_scalar expr\r
1738     | Vector _ ->\r
1739         raise (InstantError\r
1740           { err_msg = ["_InvalidArgOfOper"; "vector"];\r
1741             err_info = [];\r
1742             err_ctx = ctx }) (*error*)\r
1743     | _ -> expr\r
1744   and evaluate_vector_operator' expr = match expr with\r
1745     | Vector [| expr |] -> evaluate_vector_operator' expr\r
1746     | Vector exprs ->\r
1747         Array.map evaluate_scalar exprs\r
1748     | _ -> [| expr |] in\r
1749   Vector (evaluate_vector_operator' expr)\r
1750 \r
1751 and evaluate_max_array expr =\r
1752   let rec evaluate_max_list exprs = match exprs with\r
1753     | [] -> assert false\r
1754     | [ expr ] -> expr\r
1755     | expr :: exprs ->\r
1756         evaluate_max expr (evaluate_max_list exprs) in\r
1757   evaluate_max_list (scalar_elements expr)\r
1758 \r
1759 and evaluate_min_array expr =\r
1760   let rec evaluate_min_list exprs = match exprs with\r
1761     | [] -> assert false\r
1762     | [ expr ] -> expr\r
1763     | expr :: exprs ->\r
1764         evaluate_min expr (evaluate_min_list exprs) in\r
1765   evaluate_min_list (scalar_elements expr)\r
1766 \r
1767 and evaluate_sum expr =\r
1768   let rec evaluate_sum_list exprs = match exprs with\r
1769     | [] -> Integer Int32.zero\r
1770     | [ expr ] -> expr\r
1771     | expr :: exprs ->\r
1772         evaluate_plus expr (evaluate_sum_list exprs) in\r
1773   match expr with\r
1774   | Vector exprs ->\r
1775       evaluate_sum_list (scalar_elements expr)\r
1776   | _ -> assert false\r
1777 \r
1778 and evaluate_product expr =\r
1779   let rec evaluate_product_list exprs = match exprs with\r
1780     | [] -> Integer Int32.one\r
1781     | [ expr ] -> expr\r
1782     | expr :: exprs ->\r
1783         evaluate_times expr (evaluate_product_list exprs) in\r
1784   match expr with\r
1785   | Vector exprs ->\r
1786       evaluate_product_list (scalar_elements expr)\r
1787   | _ -> assert false\r
1788 \r
1789 and evaluate_fill ctx expr exprs =\r
1790   let rec evaluate_fill' dims = match dims with\r
1791     | [] -> expr\r
1792     | Integer i :: dims when Int32.compare i Int32.zero > 0 ->\r
1793       let i = Int32.to_int i in\r
1794         Vector (Array.make i (evaluate_fill' dims))\r
1795   | _ ->\r
1796       raise (InstantError\r
1797         { err_msg = ["_InvalidArgOfOper"; "fill"];\r
1798           err_info = [];\r
1799             err_ctx = ctx }) (*error*) in\r
1800   evaluate_fill' exprs\r
1801 \r
1802 and evaluate_zeros ctx exprs =\r
1803   let rec evaluate_zeros' dims = match dims with\r
1804     | [] -> Integer Int32.zero\r
1805     | Integer i :: dims when Int32.compare i Int32.zero > 0 ->\r
1806       let i = Int32.to_int i in\r
1807         Vector (Array.make i (evaluate_zeros' dims))\r
1808   | _ ->\r
1809       raise (InstantError\r
1810         { err_msg = ["_InvalidArgOfOper"; "zeros"];\r
1811           err_info = [];\r
1812             err_ctx = ctx }) (*error*) in\r
1813   evaluate_zeros' exprs\r
1814 \r
1815 and evaluate_ones ctx exprs =\r
1816   let rec evaluate_ones' dims = match dims with\r
1817     | [] -> Integer Int32.one\r
1818     | Integer i :: dims when Int32.compare i Int32.zero > 0 ->\r
1819       let i = Int32.to_int i in\r
1820         Vector (Array.make i (evaluate_ones' dims))\r
1821   | _ ->\r
1822       raise (InstantError\r
1823         { err_msg = ["_InvalidArgOfOper"; "ones"];\r
1824           err_info = [];\r
1825             err_ctx = ctx }) (*error*) in\r
1826   evaluate_ones' exprs\r
1827 \r
1828 and evaluate_identity ctx expr =\r
1829   let n = match expr with\r
1830     | Integer i when Int32.compare i Int32.zero > 0 ->\r
1831         Int32.to_int i\r
1832   | _ ->\r
1833       raise (InstantError\r
1834         { err_msg = ["_InvalidArgOfOper"; "identity"];\r
1835           err_info = [];\r
1836             err_ctx = ctx }) (*error*) in\r
1837   let f i j =\r
1838     Integer (if j = i then Int32.one else Int32.zero) in\r
1839   let g i = Vector (Array.init n (f i)) in\r
1840   Vector (Array.init n g)\r
1841 \r
1842 and evaluate_diagonal ctx expr =\r
1843   let exprs = match expr with\r
1844     | Vector [||] ->\r
1845       raise (InstantError\r
1846         { err_msg = ["_InvalidArgOfOper"; "diagonal"];\r
1847           err_info = [];\r
1848           err_ctx = ctx }) (*error*)\r
1849     | Vector exprs -> exprs\r
1850   | _ ->\r
1851       raise (InstantError\r
1852         { err_msg = ["_InvalidArgOfOper"; "diagonal"];\r
1853           err_info = [];\r
1854             err_ctx = ctx }) (*error*) in\r
1855   let n = Array.length exprs in\r
1856   let f i j =\r
1857     if j = i then exprs.(i) else Integer Int32.zero in\r
1858   let g i = Vector (Array.init n (f i)) in\r
1859   Vector (Array.init n g)\r
1860 \r
1861 and evaluate_scalar ctx expr =\r
1862   let rec evaluate_scalar' expr = match expr with\r
1863     | Vector [| expr |] -> evaluate_scalar' expr\r
1864     | Vector _ ->\r
1865         raise (InstantError\r
1866           { err_msg = ["_InvalidArgOfOper"; "scalar"];\r
1867             err_info = [];\r
1868             err_ctx = ctx }) (*error*)\r
1869     | _ -> expr in\r
1870   match expr with\r
1871   | Vector [| expr |] -> evaluate_scalar' expr\r
1872   | _ ->\r
1873       raise (InstantError\r
1874         { err_msg = ["_InvalidArgOfOper"; "scalar"];\r
1875           err_info = [];\r
1876           err_ctx = ctx }) (*error*)\r
1877 \r
1878 and evaluate_reinit expr expr' = match expr, expr' with\r
1879   | Vector exprs, Vector exprs' ->\r
1880       Vector (ArrayExt.map2 evaluate_reinit exprs exprs')\r
1881   | _, _ ->\r
1882       FunctionCall (PredefinedIdentifier "reinit", [ expr; expr' ])\r
1883 \r
1884 and evaluate_der expr = match expr with\r
1885   | Integer _ | String _ | Real _ -> Real 0.\r
1886   | Vector exprs -> Vector (Array.map evaluate_der exprs)\r
1887   | BinaryOperation (Plus, expr, expr') ->\r
1888       let expr = evaluate_der expr\r
1889       and expr' = evaluate_der expr' in\r
1890       BinaryOperation (Plus, expr, expr')\r
1891   | BinaryOperation (Minus, expr, expr') ->\r
1892       let expr = evaluate_der expr\r
1893       and expr' = evaluate_der expr' in\r
1894       BinaryOperation (Minus, expr, expr')\r
1895   | BinaryOperation (Times, expr1, expr2) ->\r
1896       let expr1' = evaluate_der expr1\r
1897       and expr2' = evaluate_der expr2 in\r
1898       let expr1 = BinaryOperation (Times, expr1', expr2)\r
1899       and expr2 = BinaryOperation (Times, expr1, expr2') in\r
1900       BinaryOperation (Plus, expr1, expr2)\r
1901   | BinaryOperation (Divide, expr1, expr2) ->\r
1902       let expr1' = evaluate_der expr1\r
1903       and expr2' = evaluate_der expr2 in\r
1904       let expr1' = BinaryOperation (Times, expr1', expr2)\r
1905       and expr2' = BinaryOperation (Times, expr1, expr2') in\r
1906       let expr1 = BinaryOperation (Minus, expr1', expr2')\r
1907       and expr2 = BinaryOperation (Times, expr2, expr2) in\r
1908       BinaryOperation (Divide, expr1, expr2)\r
1909   | BinaryOperation (Power, expr, Integer i) ->\r
1910       let expr' = evaluate_der expr\r
1911       and j = Int32.sub i Int32.one in\r
1912       let expr' = BinaryOperation (Times, Integer i, expr')\r
1913       and expr = BinaryOperation (Power, expr, Integer j) in\r
1914       BinaryOperation (Times, expr', expr)\r
1915   | BinaryOperation (Power, expr, Real f) ->\r
1916       let expr' = evaluate_der expr\r
1917       and f' = f -. 1. in\r
1918       let expr' = BinaryOperation (Times, Real f, expr')\r
1919       and expr = BinaryOperation (Power, expr, Real f') in\r
1920       BinaryOperation (Times, expr', expr)\r
1921   | FunctionCall (PredefinedIdentifier "cos", [ expr ]) ->\r
1922       let expr' = evaluate_der expr\r
1923       and expr = FunctionCall (PredefinedIdentifier "sin", [ expr ]) in\r
1924       let expr = UnaryOperation (UnaryMinus, expr) in\r
1925       BinaryOperation (Times, expr', expr)\r
1926   | FunctionCall (PredefinedIdentifier "sin", [ expr ]) ->\r
1927       let expr' = evaluate_der expr\r
1928       and expr = FunctionCall (PredefinedIdentifier "cos", [ expr ]) in\r
1929       BinaryOperation (Times, expr', expr)\r
1930   | FunctionCall (PredefinedIdentifier "tan", [ expr1 ]) ->\r
1931       let expr1' = evaluate_der expr1\r
1932       and expr = BinaryOperation (Times, expr, expr) in\r
1933       let expr = BinaryOperation (Plus, Real 1., expr) in\r
1934       BinaryOperation (Times, expr1', expr)\r
1935   | FunctionCall (PredefinedIdentifier "exp", [ expr1 ]) ->\r
1936       let expr1' = evaluate_der expr1 in\r
1937       BinaryOperation (Times, expr1', expr)\r
1938   | FunctionCall (PredefinedIdentifier "log", [ expr1 ]) ->\r
1939       let expr1' = evaluate_der expr1 in\r
1940       BinaryOperation (Divide, expr1', expr)\r
1941   | FunctionCall (PredefinedIdentifier "sqrt", [ expr1 ]) ->\r
1942       evaluate_der (BinaryOperation (Power, expr1, Real 0.5))\r
1943   | FunctionCall (PredefinedIdentifier "asin", [ expr1 ]) ->\r
1944       let expr1' = evaluate_der expr1 in\r
1945       let expr1 = BinaryOperation (Times, expr1, expr1) in\r
1946       let expr1 = BinaryOperation (Minus, Real 1., expr1) in\r
1947       let expr1 = FunctionCall (PredefinedIdentifier "sqrt", [ expr1 ]) in\r
1948       BinaryOperation (Divide, expr1', expr1)\r
1949   | FunctionCall (PredefinedIdentifier "acos", [ expr1 ]) ->\r
1950       let expr1' = UnaryOperation (UnaryMinus, evaluate_der expr1) in\r
1951       let expr1 = BinaryOperation (Times, expr1, expr1) in\r
1952       let expr1 = BinaryOperation (Minus, Real 1., expr1) in\r
1953       let expr1 = FunctionCall (PredefinedIdentifier "sqrt", [ expr1 ]) in\r
1954       BinaryOperation (Divide, expr1', expr1)\r
1955   | FunctionCall (PredefinedIdentifier "atan", [ expr1 ]) ->\r
1956       let expr1' = evaluate_der expr1 in\r
1957       let expr1 = BinaryOperation (Times, expr1, expr1) in\r
1958       let expr1 = BinaryOperation (Plus, Real 1., expr1) in\r
1959       BinaryOperation (Divide, expr1', expr1)\r
1960   | FunctionCall (PredefinedIdentifier "sinh", [ expr1 ]) ->\r
1961       let expr1' = evaluate_der expr1 in\r
1962       let expr1 = FunctionCall (PredefinedIdentifier "cosh", [ expr1 ]) in\r
1963       BinaryOperation (Times, expr1', expr1)\r
1964   | FunctionCall (PredefinedIdentifier "cosh", [ expr1 ]) ->\r
1965       let expr1' = evaluate_der expr1 in\r
1966       let expr1 = FunctionCall (PredefinedIdentifier "sinh", [ expr1 ]) in\r
1967       BinaryOperation (Times, expr1', expr1)\r
1968   | FunctionCall (PredefinedIdentifier "tanh", [ expr1 ]) ->\r
1969       let expr1' = evaluate_der expr1 in\r
1970       let expr1 = BinaryOperation (Times, expr, expr) in\r
1971       let expr1 = BinaryOperation (Minus, Real 1., expr1) in\r
1972       BinaryOperation (Times, expr1', expr1)\r
1973   | FunctionCall (PredefinedIdentifier "asinh", [ expr1 ]) ->\r
1974       let expr1' = evaluate_der expr1 in\r
1975       let expr1 = BinaryOperation (Times, expr1, expr1) in\r
1976       let expr1 = BinaryOperation (Plus, Real 1., expr1) in\r
1977       let expr1 = FunctionCall (PredefinedIdentifier "sqrt", [ expr1 ]) in\r
1978       BinaryOperation (Divide, expr1', expr1)\r
1979   | FunctionCall (PredefinedIdentifier "acosh", [ expr1 ]) ->\r
1980       let expr1' = evaluate_der expr1 in\r
1981       let expr1 = BinaryOperation (Times, expr1, expr1) in\r
1982       let expr1 = BinaryOperation (Minus, expr1, Real 1.) in\r
1983       let expr1 = FunctionCall (PredefinedIdentifier "sqrt", [ expr1 ]) in\r
1984       BinaryOperation (Divide, expr1', expr1)\r
1985   | FunctionCall (PredefinedIdentifier "atanh", [ expr1 ]) ->\r
1986       let expr1' = evaluate_der expr1 in\r
1987       let expr1 = BinaryOperation (Times, expr1, expr1) in\r
1988       let expr1 = BinaryOperation (Minus, expr1, Real 1.) in\r
1989       BinaryOperation (Divide, expr1', expr1)\r
1990   | FunctionCall (PredefinedIdentifier "log10", [ expr1 ]) ->\r
1991       let expr1 = FunctionCall (PredefinedIdentifier "log", [ expr1 ]) in\r
1992       BinaryOperation (Divide, evaluate_der expr1, Real (log 10.))\r
1993   | FunctionCall\r
1994       (PredefinedIdentifier ("div" | "mod" | "rem" | "ceil" | "floor"), _) ->\r
1995       Real 0.\r
1996   | If (alts, default) ->\r
1997       let alts' =\r
1998         List.map (function (cond, expr) -> (cond, evaluate_der expr)) alts in\r
1999       If (alts', evaluate_der default)\r
2000   | NoEvent expr -> NoEvent (evaluate_der expr)\r
2001   | UnaryOperation (UnaryMinus, expr) ->\r
2002       UnaryOperation (UnaryMinus, evaluate_der expr)\r
2003   | VectorReduction (exprs, expr) ->\r
2004       VectorReduction (exprs, evaluate_der expr)\r
2005   | _ -> FunctionCall (PredefinedIdentifier "der", [ expr ])\r
2006 \r
2007 and evaluate_pre expr = match expr with\r
2008   | Vector exprs ->\r
2009       Vector (Array.map evaluate_pre exprs)\r
2010   | _ ->\r
2011       FunctionCall (PredefinedIdentifier "pre", [ expr ])\r
2012 \r
2013 and evaluate_cos expr = match expr with\r
2014   | Vector exprs ->\r
2015       Vector (Array.map evaluate_cos exprs)\r
2016   | _ ->\r
2017       FunctionCall (PredefinedIdentifier "cos", [ expr ])\r
2018 \r
2019 and evaluate_sin expr = match expr with\r
2020   | Vector exprs ->\r
2021       Vector (Array.map evaluate_sin exprs)\r
2022   | _ ->\r
2023       FunctionCall (PredefinedIdentifier "sin", [ expr ])\r
2024 \r
2025 and evaluate_tan expr = match expr with\r
2026   | Vector exprs ->\r
2027       Vector (Array.map evaluate_tan exprs)\r
2028   | _ ->\r
2029       FunctionCall (PredefinedIdentifier "tan", [ expr ])\r
2030 \r
2031 and evaluate_exp expr = match expr with\r
2032   | Vector exprs ->\r
2033       Vector (Array.map evaluate_exp exprs)\r
2034   | _ ->\r
2035       FunctionCall (PredefinedIdentifier "exp", [ expr ])\r
2036 \r
2037 and evaluate_log expr = match expr with\r
2038   | Vector exprs ->\r
2039       Vector (Array.map evaluate_log exprs)\r
2040   | _ ->\r
2041       FunctionCall (PredefinedIdentifier "log", [ expr ])\r
2042 \r
2043 and evaluate_sqrt expr = match expr with\r
2044   | Vector exprs ->\r
2045       Vector (Array.map evaluate_sqrt exprs)\r
2046   | _ ->\r
2047       FunctionCall (PredefinedIdentifier "sqrt", [ expr ])\r
2048 \r
2049 and evaluate_asin expr = match expr with\r
2050   | Vector exprs ->\r
2051       Vector (Array.map evaluate_asin exprs)\r
2052   | _ ->\r
2053       FunctionCall (PredefinedIdentifier "asin", [ expr ])\r
2054 \r
2055 and evaluate_acos expr = match expr with\r
2056   | Vector exprs ->\r
2057       Vector (Array.map evaluate_acos exprs)\r
2058   | _ ->\r
2059       FunctionCall (PredefinedIdentifier "acos", [ expr ])\r
2060 \r
2061 and evaluate_atan expr = match expr with\r
2062   | Vector exprs ->\r
2063       Vector (Array.map evaluate_atan exprs)\r
2064   | _ ->\r
2065       FunctionCall (PredefinedIdentifier "atan", [ expr ])\r
2066 \r
2067 and evaluate_sinh expr = match expr with\r
2068   | Vector exprs ->\r
2069       Vector (Array.map evaluate_sinh exprs)\r
2070   | _ ->\r
2071       FunctionCall (PredefinedIdentifier "sinh", [ expr ])\r
2072 \r
2073 and evaluate_cosh expr = match expr with\r
2074   | Vector exprs ->\r
2075       Vector (Array.map evaluate_cosh exprs)\r
2076   | _ ->\r
2077       FunctionCall (PredefinedIdentifier "cosh", [ expr ])\r
2078 \r
2079 and evaluate_tanh expr = match expr with\r
2080   | Vector exprs ->\r
2081       Vector (Array.map evaluate_tanh exprs)\r
2082   | _ ->\r
2083       FunctionCall (PredefinedIdentifier "tanh", [ expr ])\r
2084 \r
2085 and evaluate_asinh expr = match expr with\r
2086   | Vector exprs ->\r
2087       Vector (Array.map evaluate_asinh exprs)\r
2088   | _ ->\r
2089       FunctionCall (PredefinedIdentifier "asinh", [ expr ])\r
2090 \r
2091 and evaluate_acosh expr = match expr with\r
2092   | Vector exprs ->\r
2093       Vector (Array.map evaluate_acosh exprs)\r
2094   | _ ->\r
2095       FunctionCall (PredefinedIdentifier "acosh", [ expr ])\r
2096 \r
2097 and evaluate_atanh expr = match expr with\r
2098   | Vector exprs ->\r
2099       Vector (Array.map evaluate_atanh exprs)\r
2100   | _ ->\r
2101       FunctionCall (PredefinedIdentifier "atanh", [ expr ])\r
2102 \r
2103 and evaluate_log10 expr = match expr with\r
2104   | Vector exprs ->\r
2105       Vector (Array.map evaluate_log10 exprs)\r
2106   | _ ->\r
2107       FunctionCall (PredefinedIdentifier "log10", [ expr ])\r
2108 \r
2109 and evaluate_max expr expr' = match expr, expr' with\r
2110   | Vector exprs, Vector exprs' ->\r
2111       Vector (ArrayExt.map2 evaluate_max exprs exprs')\r
2112   | Real f, Real f' -> Real (max f f')\r
2113   | _, _ ->\r
2114       let b = BinaryOperation (GreaterEqual, expr, expr') in\r
2115       If ([b, expr], expr')\r
2116 \r
2117 and evaluate_min expr expr' = match expr, expr' with\r
2118   | Vector exprs, Vector exprs' ->\r
2119       Vector (ArrayExt.map2 evaluate_min exprs exprs')\r
2120   | Real f, Real f' -> Real (min f f')\r
2121   | _, _ ->\r
2122       let b = BinaryOperation (GreaterEqual, expr', expr) in\r
2123       If ([b, expr], expr')\r
2124 \r
2125 and evaluate_abs expr = match expr with\r
2126   | Vector exprs ->\r
2127       Vector (Array.map evaluate_abs exprs)\r
2128   | Real f -> Real (abs_float f)\r
2129   | Integer i -> Integer (Int32.abs i)\r
2130   | _ ->\r
2131       let b = BinaryOperation (GreaterEqual, expr, Real 0.)\r
2132       and default = UnaryOperation (UnaryMinus, expr) in\r
2133       If ([b, expr], default)\r
2134 \r
2135 and evaluate_sign expr = match expr with\r
2136   | Vector exprs ->\r
2137       Vector (Array.map evaluate_sign exprs)\r
2138   | Real f when f > 0. -> Real 1.\r
2139   | Real f when f < 0. -> Real (-. 1.)\r
2140   | Real _ -> Real 0.\r
2141   | Integer i when Int32.compare i Int32.zero > 0 ->\r
2142       Integer Int32.one\r
2143   | Integer i when Int32.compare i Int32.zero < 0 ->\r
2144       Integer Int32.minus_one\r
2145   | Integer _ -> Integer Int32.zero\r
2146   | _ ->\r
2147       let b = BinaryOperation (Greater, expr, Real 0.)\r
2148       and b' = BinaryOperation (Greater, Real 0., expr) in\r
2149       If ([(b, Integer Int32.one); (b', Integer Int32.minus_one)],\r
2150           Integer Int32.zero)\r
2151 \r
2152 and evaluate_div ctx expr expr' = match expr, expr' with\r
2153   | Vector exprs, Vector exprs' ->\r
2154       Vector (ArrayExt.map2 (evaluate_div ctx) exprs exprs')\r
2155   | _, Real 0. ->\r
2156       raise (InstantError\r
2157         { err_msg = ["_DivisionByZero"];\r
2158           err_info = [];\r
2159           err_ctx = ctx }) (*error*)\r
2160   | _, Integer i when i = Int32.zero ->\r
2161       raise (InstantError\r
2162         { err_msg = ["_DivisionByZero"];\r
2163           err_info = [];\r
2164           err_ctx = ctx }) (*error*)\r
2165   | Integer i, Integer i' -> Integer (Int32.div i i')\r
2166   | Real f, Integer i' ->\r
2167       let f' = Int32.to_float i' in\r
2168       Real (float_of_int (truncate (f /. f')))\r
2169   | Integer i, Real f' ->\r
2170       let f = Int32.to_float i in\r
2171       Real (float_of_int (truncate (f /. f')))\r
2172   | Real f, Real f' ->\r
2173       Real (float_of_int (truncate (f /. f')))\r
2174   | _, _ ->\r
2175       FunctionCall (PredefinedIdentifier "div", [ expr; expr' ])\r
2176 \r
2177 and evaluate_mod expr expr' = match expr, expr' with\r
2178   | Vector exprs, Vector exprs' ->\r
2179       Vector (ArrayExt.map2 evaluate_mod exprs exprs')\r
2180   | _, _ ->\r
2181       FunctionCall (PredefinedIdentifier "mod", [ expr; expr' ])\r
2182 \r
2183 and evaluate_rem expr expr' = match expr, expr' with\r
2184   | Vector exprs, Vector exprs' ->\r
2185       Vector (ArrayExt.map2 evaluate_rem exprs exprs')\r
2186   | _, _ ->\r
2187       FunctionCall (PredefinedIdentifier "rem", [ expr; expr' ])\r
2188 \r
2189 and evaluate_ceil expr = match expr with\r
2190   | Vector exprs ->\r
2191       Vector (Array.map evaluate_ceil exprs)\r
2192   | _ ->\r
2193       FunctionCall (PredefinedIdentifier "ceil", [ expr ])\r
2194 \r
2195 and evaluate_floor expr = match expr with\r
2196   | Vector exprs ->\r
2197       Vector (Array.map evaluate_floor exprs)\r
2198   | _ ->\r
2199       FunctionCall (PredefinedIdentifier "floor", [ expr ])\r
2200 \r
2201 and evaluate_size exprs =\r
2202   let rec evaluate_size' expr i = match expr, i with\r
2203     | ComponentReference cpnt_desc, _ ->\r
2204         evaluate_component_size cpnt_desc i\r
2205     | Vector exprs, 1 -> Integer (Int32.of_int (Array.length exprs))\r
2206     | Vector exprs, _ -> evaluate_size' exprs.(0) (i - 1)\r
2207     | _ -> assert false (*error*)\r
2208   and evaluate_component_size cpnt_desc i =\r
2209     match evaluate cpnt_desc.component_nature, i with\r
2210       | DynamicArray _, _ -> FunctionCall (PredefinedIdentifier "size", exprs)\r
2211       | StaticArray cpnt_descs, 1 ->\r
2212           Integer (Int32.of_int (Array.length cpnt_descs))\r
2213       | StaticArray cpnt_descs, _ ->\r
2214           evaluate_component_size cpnt_descs.(i) (i - 1)\r
2215       | _ -> assert false (*error*)\r
2216   and evaluate_size_list = function\r
2217     | ComponentReference cpnt_desc -> assert false\r
2218     | Vector exprs ->\r
2219         let size = Integer (Int32.of_int (Array.length exprs)) in\r
2220         size :: evaluate_size_list exprs.(0)\r
2221     | _ -> [] in\r
2222   match exprs with\r
2223     | [expr] -> Vector (Array.of_list (evaluate_size_list expr))\r
2224     | [expr; Integer i] -> evaluate_size' expr (Int32.to_int i)\r
2225     | [expr; _] -> FunctionCall (PredefinedIdentifier "size", exprs)\r
2226     | _ -> assert false (*error*)\r
2227 \r
2228 and evaluate_not expr = match expr with\r
2229   | True -> False\r
2230   | False -> True\r
2231   | Vector exprs -> Vector (Array.map evaluate_not exprs)\r
2232   | _ -> UnaryOperation (Not, expr)\r
2233 \r
2234 and evaluate_unary_minus expr = match expr with\r
2235   | Integer i -> Integer (Int32.neg i)\r
2236   | Real f -> Real (~-. f)\r
2237   | Vector exprs -> Vector (Array.map evaluate_unary_minus exprs)\r
2238   | _ -> UnaryOperation (UnaryMinus, expr)\r
2239 \r
2240 and field_access ctx expr id =\r
2241   let rec field_access' = function\r
2242     | ClassReference cl_def ->\r
2243         let cpnt_desc = create_temporary_instance ctx cl_def in\r
2244         component_field_access cpnt_desc\r
2245     | ComponentReference cpnt_desc -> component_field_access cpnt_desc\r
2246     | Record fields -> List.assoc id fields\r
2247     | Vector exprs -> Vector (Array.map field_access' exprs)\r
2248     | _ -> FieldAccess (expr, id)\r
2249   and component_field_access cpnt_desc =\r
2250     match evaluate cpnt_desc.component_nature with\r
2251       | DynamicArray _ -> FieldAccess (expr, id)\r
2252       | Instance inst -> instance_field_access ctx inst id\r
2253       | PredefinedTypeInstance _ ->\r
2254           raise (InstantError\r
2255             { err_msg = ["_CannotAccessToPredefTypeAttrib"; id];\r
2256               err_info = [];\r
2257               err_ctx = ctx}) (*error*)\r
2258       | StaticArray cpnt_descs ->\r
2259           Vector (Array.map component_field_access cpnt_descs) in\r
2260   field_access' expr\r
2261 \r
2262 and instance_field_access ctx inst id =\r
2263   let evaluate_component cpnt_desc =\r
2264     let evaluate_declaration_equation = function\r
2265       | Some expr -> evaluate expr\r
2266       | None ->\r
2267           raise (InstantError\r
2268             { err_msg = ["_MissingDeclEquForFixedId"; id];\r
2269               err_info = [];\r
2270               err_ctx = ctx}) (*error*) in\r
2271     let rec evaluate_parameter cpnt_desc =\r
2272       let evaluate_predefined_type_instance predef =\r
2273         match evaluate (List.assoc "fixed" predef.attributes) with\r
2274         | True -> evaluate_declaration_equation cpnt_desc.declaration_equation\r
2275         | False -> ComponentReference cpnt_desc\r
2276         | _ -> assert false (*error*) in\r
2277       match evaluate cpnt_desc.component_nature with\r
2278       | PredefinedTypeInstance predef\r
2279         when List.mem_assoc "fixed" predef.attributes ->\r
2280           evaluate_predefined_type_instance predef\r
2281       | DynamicArray cpnt_desc -> assert false\r
2282       | Instance _ -> ComponentReference cpnt_desc\r
2283       | PredefinedTypeInstance _ ->\r
2284           evaluate_declaration_equation cpnt_desc.declaration_equation\r
2285       | StaticArray cpnt_descs ->\r
2286           Vector (Array.map evaluate_parameter cpnt_descs)\r
2287           (*let f i =\r
2288             let decl_equ = cpnt_descs.(i).declaration_equation in\r
2289             evaluate_declaration_equation decl_equ in\r
2290           Vector (Array.init (Array.length cpnt_descs) f)*) in\r
2291     match cpnt_desc.variability with\r
2292       | Types.Constant ->\r
2293           evaluate_declaration_equation cpnt_desc.declaration_equation\r
2294       | Types.Parameter -> evaluate_parameter cpnt_desc\r
2295       | _ -> ComponentReference cpnt_desc in\r
2296   let elts = evaluate inst.elements in\r
2297   let elt_desc = List.assoc id elts.named_elements in\r
2298   match evaluate elt_desc.element_nature with\r
2299   | Class cl_def -> ClassReference cl_def\r
2300   | Component cpnt_desc -> evaluate_component cpnt_desc\r
2301 \r
2302 and expression_location ctx expr =\r
2303   match expr.NameResolve.info.NameResolve.syntax with\r
2304     | None -> ctx.location\r
2305     | Some expr -> expr.Syntax.info\r
2306 \r
2307 and class_name_of_component cpnt_desc =\r
2308   let type_spec = Lazy.force cpnt_desc.NameResolve.type_specifier in\r
2309   let expr_info = type_spec.NameResolve.info in\r
2310   match expr_info.NameResolve.syntax with\r
2311   | None -> ""\r
2312   | Some expr -> Syntax.string_of_expression expr\r
2313 \r
2314 and instance_nature_of_element elt_desc =\r
2315   match elt_desc.NameResolve.element_nature with\r
2316     | NameResolve.Component cpnt_desc ->\r
2317         ComponentElement (class_name_of_component cpnt_desc)\r
2318     | _ -> ClassElement\r
2319 \r
2320 and instance_class_name instance_nature =\r
2321   match instance_nature with\r
2322     | ComponentElement s -> s\r
2323     | ClassElement -> ""\r
2324 \r
2325 and flatten_expression expr =\r
2326   let rec flatten_component cpnt_desc =\r
2327     match evaluate cpnt_desc.component_nature with\r
2328     | StaticArray cpnt_descs ->\r
2329         Vector (Array.map flatten_component cpnt_descs)\r
2330     | _ -> ComponentReference cpnt_desc in\r
2331   match expr with\r
2332   | ComponentReference cpnt_desc ->\r
2333       flatten_component cpnt_desc\r
2334   | _ -> expr\r
2335 \r
2336 and size expr i = match expr, i with\r
2337   | Vector [||], _ -> 0\r
2338   | Vector exprs, 0 -> Array.length exprs\r
2339   | Vector exprs, _ when i > 0 -> size exprs.(0) (i - 1)\r
2340   | _ -> invalid_arg "_IndexOutOfBound"\r
2341 \r
2342 and sizes expr =\r
2343   Array.init (ndims expr) (size expr)\r
2344 \r
2345 and ndims expr =\r
2346   let rec ndims' i expr = match expr with\r
2347     | Vector [||] -> i + 1\r
2348     | Vector exprs -> ndims' (i + 1) exprs.(0)\r
2349     | _ -> i in\r
2350   ndims' 0 expr\r
2351 \r
2352 and element i expr = match expr with\r
2353   | Vector exprs -> exprs.(i)\r
2354   | _ -> assert false\r
2355 \r
2356 and array_elements expr = match expr with\r
2357   | Vector exprs -> exprs\r
2358   | _ -> assert false\r
2359 \r
2360 and scalar_elements expr = match expr with\r
2361   | Vector exprs ->\r
2362       let exprss =\r
2363         Array.to_list (Array.map scalar_elements exprs) in\r
2364       List.flatten exprss\r
2365   | _ -> [ expr ]\r
2366 \r
2367 (* for debug*)\r
2368 \r
2369 and generate_expression oc = function\r
2370   | BinaryOperation (bin_op, expr, expr') ->\r
2371       generate_binary_operation oc bin_op expr expr'\r
2372   | ClassReference cl_def ->\r
2373       generate_class_reference oc cl_def\r
2374   | ComponentReference cpnt_desc ->\r
2375       generate_component_reference oc cpnt_desc\r
2376   | EnumerationElement _ -> assert false\r
2377   | False -> assert false\r
2378   | FieldAccess _ -> assert false\r
2379   | FunctionCall (expr, exprs) ->\r
2380       generate_function_call oc expr exprs\r
2381   | If (alts, expr) -> generate_if oc alts expr\r
2382   | IndexedAccess _ -> assert false\r
2383   | Integer i when Int32.to_int i >= 0 ->\r
2384       Printf.fprintf oc "%ld" i\r
2385   | Integer i ->\r
2386       let expr = Integer (Int32.neg i)\r
2387       and un_op = UnaryMinus in\r
2388       generate_unary_operation oc un_op expr\r
2389   | LoopVariable _ -> Printf.fprintf oc "LoopVariable"\r
2390   | NoEvent expr -> generate_no_event oc expr\r
2391   | PredefinedIdentifier id -> Printf.fprintf oc "%s" id\r
2392   | Range _ -> Printf.fprintf oc "Range"\r
2393   | Real f ->\r
2394       Printf.fprintf oc "%s" (string_of_float f)\r
2395   | Record _ -> Printf.fprintf oc "Record"\r
2396   | String _ -> Printf.fprintf oc "String"\r
2397   | True -> Printf.fprintf oc "True"\r
2398   | Tuple _ -> Printf.fprintf oc "Tuple"\r
2399   | UnaryOperation (un_op, expr) ->\r
2400       generate_unary_operation oc un_op expr\r
2401   | Vector exprs ->\r
2402       generate_vector oc exprs\r
2403   | VectorReduction _ -> Printf.fprintf oc "VectorReduction"\r
2404 \r
2405 and generate_binary_operation oc bin_op expr expr' =\r
2406   let string_of_binary_operation_kind = function\r
2407     | And -> "and"\r
2408     | Divide -> "/"\r
2409     | EqualEqual -> "=="\r
2410     | GreaterEqual -> ">="\r
2411     | Greater -> ">"\r
2412     | LessEqual -> "<="\r
2413     | Less -> "<"\r
2414     | Times -> "*"\r
2415     | NotEqual -> "<>"\r
2416     | Or -> "or"\r
2417     | Plus -> "+"\r
2418     | Power -> "^"\r
2419     | Minus -> "-" in\r
2420   Printf.fprintf oc "(";\r
2421   generate_expression oc expr;\r
2422   Printf.fprintf oc " %s " (string_of_binary_operation_kind bin_op);\r
2423   generate_expression oc expr';\r
2424   Printf.fprintf oc ")"\r
2425 \r
2426 and generate_class_reference oc cl_def =\r
2427   let rec last = function\r
2428     | [] -> assert false\r
2429     | [Name id] -> id\r
2430     | [Index _] -> assert false\r
2431     | _ :: path -> last path in\r
2432   let generate_external_call ext_call =\r
2433     match ext_call.NameResolve.nature with\r
2434       | NameResolve.PrimitiveCall "builtin" ->\r
2435           Printf.fprintf oc "builtin"\r
2436       | NameResolve.PrimitiveCall "C" ->\r
2437           Printf.fprintf oc "PrimitiveCall"\r
2438       | NameResolve.PrimitiveCall lang -> assert false\r
2439       | NameResolve.ExternalProcedureCall _ -> assert false in\r
2440   let generate_long_dscription long_desc =\r
2441     match evaluate long_desc.NameResolve.external_call with\r
2442       | None -> assert false\r
2443       | Some ext_call -> generate_external_call ext_call in\r
2444   match cl_def.description with\r
2445     | ClassDescription (_, cl_desc) ->\r
2446         generate_long_dscription cl_desc.long_description\r
2447     | PredefinedType _ -> assert false\r
2448 \r
2449 and generate_component_reference oc cpnt_desc =\r
2450   let name = ident_of_path cpnt_desc.component_path in\r
2451   Printf.fprintf oc "%s" name\r
2452 \r
2453 and generate_function_call oc expr exprs =\r
2454   generate_expression oc expr;  \r
2455   Printf.fprintf oc "(";\r
2456   generate_expressions oc exprs;\r
2457   Printf.fprintf oc ")"\r
2458 \r
2459 and generate_expressions oc = function\r
2460   | [] -> ()\r
2461   | [expr] -> generate_expression oc expr;\r
2462   | expr :: exprs ->\r
2463       generate_expression oc expr;\r
2464       Printf.fprintf oc ", ";\r
2465       generate_expressions oc exprs\r
2466 \r
2467 and generate_if oc alts expr =\r
2468   let rec generate_alternatives = function\r
2469     | [] -> Printf.fprintf oc " "; generate_expression oc expr\r
2470     | (expr, expr') :: alts ->\r
2471         Printf.fprintf oc "(if ";\r
2472         generate_expression oc expr;\r
2473         Printf.fprintf oc " then ";\r
2474         generate_expression oc expr';\r
2475         Printf.fprintf oc " else";\r
2476         generate_alternatives alts;\r
2477         Printf.fprintf oc ")" in\r
2478   generate_alternatives alts\r
2479 \r
2480 and generate_no_event oc expr =\r
2481   Printf.fprintf oc "noEvent(";\r
2482   generate_expression oc expr;\r
2483   Printf.fprintf oc ")"\r
2484 \r
2485 and generate_unary_operation oc un_op expr =\r
2486   let string_of_unary_operation_kind = function\r
2487     | Not -> "not"\r
2488     | UnaryMinus -> "-" in\r
2489   Printf.fprintf oc "(%s " (string_of_unary_operation_kind un_op);\r
2490   generate_expression oc expr;\r
2491   Printf.fprintf oc ")"\r
2492 \r
2493 and generate_vector oc exprs =\r
2494   let exprs' = Array.to_list exprs in\r
2495   Printf.fprintf oc "{ ";\r
2496   generate_expressions oc exprs';\r
2497   Printf.fprintf oc " }"\r
2498 \r
2499 and last_id path =\r
2500   let rec last_id' id path = match path with\r
2501     | [] -> id\r
2502     | (Name id) :: path -> last_id' id path\r
2503     | (Index _) :: path -> last_id' id path in\r
2504   last_id' "" path\r
2505 \r
2506 and string_of_float f =\r
2507   let add_parenthesis s =\r
2508     if String.contains s '-' then Printf.sprintf "(%s)" s else s in\r
2509   match Printf.sprintf "%.16g" f with\r
2510   | s when (String.contains s '.') || (String.contains s 'e') ->\r
2511       add_parenthesis s\r
2512   | s -> add_parenthesis (Printf.sprintf "%s." s)\r
2513 \r
2514 and ident_of_path path =\r
2515   let rec ident_of_path' path =\r
2516     match path with\r
2517     | [] -> assert false\r
2518     | [Name id] -> id\r
2519     | [Index i] -> Printf.sprintf "[%d]" (i + 1)\r
2520     | Name id :: path ->\r
2521         Printf.sprintf "%s.%s" id (ident_of_path' path)\r
2522     | Index i :: path ->\r
2523         Printf.sprintf "[%d].%s" (i + 1) (ident_of_path' path) in\r
2524   match path with\r
2525   | [] -> assert false\r
2526   | [Name id] -> assert false\r
2527   | [Index i] -> assert false\r
2528   | Name id :: path ->\r
2529       Printf.sprintf "`%s`" (ident_of_path' path)\r
2530   | Index i :: path -> assert false\r
2531 \r