2 * Translator from Modelica 2.x to flat Modelica
4 * Copyright (C) 2005 - 2007 Imagine S.A.
5 * For more information or commercial use please contact us at www.amesim.com
7 * This program is free software; you can redistribute it and/or
8 * modify it under the terms of the GNU General Public License
9 * as published by the Free Software Foundation; either version 2
10 * of the License, or (at your option) any later version.
12 * This program is distributed in the hope that it will be useful,
13 * but WITHOUT ANY WARRANTY; without even the implied warranty of
14 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 * GNU General Public License for more details.
17 * You should have received a copy of the GNU General Public License
18 * along with this program; if not, write to the Free Software
19 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
31 enclosing_instance: instance option;
33 elements: instance_elements Lazy.t
36 and instance_elements =
38 named_elements: (string * element_description) list;
39 unnamed_elements: equation_or_algorithm_clause list
42 and element_description =
45 element_nature: element_nature Lazy.t
49 | Class of class_definition
50 | Component of component_description
52 and class_definition =
54 class_type: Types.class_specifier;
56 class_flow: bool option;
57 class_variability: Types.variability option;
58 class_causality: Types.causality option;
59 description: description;
60 modification: modification_argument list;
61 class_location: Parser.location
64 and path = path_element list
71 | ClassDescription of context * class_description
72 | PredefinedType of predefined_type
74 and class_description =
76 class_kind: Types.kind;
77 class_annotations: (annotation list) Lazy.t;
78 long_description: NameResolve.long_description
82 | InverseFunction of inverse_function Lazy.t
83 | UnknownAnnotation of Parser.location Syntax.class_modification Lazy.t
85 and inverse_function =
87 function_class: class_definition;
88 arguments: (string * string) list
91 and class_modification = (string * modification_argument) list
93 and modification_argument =
96 action: modification_action
99 and modification_action =
100 | ElementModification of modification
101 | ElementRedeclaration of element_description
104 | Modification of class_modification * expression Lazy.t option
105 | Assignment of expression Lazy.t
106 | Equality of expression Lazy.t
108 and component_description =
110 component_path: path;
112 variability: Types.variability;
113 causality: Types.causality;
114 component_nature: component_nature Lazy.t;
115 declaration_equation: expression Lazy.t option;
117 component_location: Parser.location;
121 and component_nature =
122 | DynamicArray of component_description
123 (* one representative member of the collection *)
124 | Instance of instance
125 | PredefinedTypeInstance of predefined_type_instance
126 | StaticArray of component_description array
128 and predefined_type_instance =
130 predefined_type: predefined_type;
131 attributes: (string * expression Lazy.t) list
134 and predefined_type =
141 and equation_or_algorithm_clause =
142 | EquationClause of NameResolve.validity * equation list Lazy.t
143 | AlgorithmClause of NameResolve.validity * algorithm list Lazy.t
145 and validity = Initial | Permanent
147 and equation = (equation_desc list, NameResolve.equation) node
150 | Equal of expression * expression
151 | ConditionalEquationE of (expression * equation list) list *
153 | ConnectFlows of NameResolve.sign * expression *
154 NameResolve.sign * expression
155 | WhenClauseE of (expression * equation list) list
157 and algorithm = (algorithm_desc list, NameResolve.algorithm) node
160 | Assign of expression * expression
161 | FunctionCallA of expression * expression list
162 | MultipleAssign of expression list * expression * expression list
165 | ConditionalEquationA of (expression * algorithm list) list *
167 | ForClauseA of expression (* range *) * algorithm list
168 | WhileClause of expression * algorithm list
169 | WhenClauseA of (expression * algorithm list) list
172 | BinaryOperation of binary_operator_kind * expression * expression
173 | ClassReference of class_definition
174 | ComponentReference of component_description
175 | EnumerationElement of string
177 | FieldAccess of expression * string
178 | FunctionCall of expression * expression list
179 | If of (expression (* condition *) * expression) list *
180 expression (* default *)
181 | IndexedAccess of expression * expression list (* subscripts *)
183 | LoopVariable of int (* number of nested for loops to skip *)
184 | NoEvent of expression
185 | PredefinedIdentifier of string
186 | Range of expression * expression * expression
188 | Record of (string * expression) list
191 | Tuple of expression list
192 | UnaryOperation of unary_operator_kind * expression
193 | Vector of expression array
194 | VectorReduction of expression list (* ranges *) * expression
196 and unary_operator_kind =
200 and binary_operator_kind =
217 toplevel: (string * element_description) list Lazy.t;
219 context_flow: bool option;
220 context_variability: Types.variability option;
221 context_causality: Types.causality option;
222 parent_context: context option; (* for normal parent scope lookup *)
223 class_context: context_nature; (* for normal (class-based) lookup *)
224 instance_context: instance option; (* for dynamically scoped identifiers *)
225 location: Parser.location;
226 instance_nature: instance_nature
231 | InstanceContext of instance
232 | ForContext of context *
233 expression option (* current value of the loop variable, if available *)
234 | FunctionEvaluationContext of context * expression * expression list
236 (* Error description *)
237 and error_description =
239 err_msg: string list;
240 err_info: (string * string) list;
244 and instance_nature =
246 | ComponentElement of string
248 exception InstantError of error_description
255 let spaces () = for i = 1 to !levels do Printf.printf " " done
258 spaces (); Printf.printf "ForContext %ld\n" i;
262 spaces (); Printf.printf "ReductionContext %ld\n" i;
267 spaces (); Printf.printf "Leaving ForContext\n"
269 let evaluate x = Lazy.force x
274 let l = Array.length a
275 and l' = Array.length a' in
276 if l <> l' then invalid_arg "ArrayExt.map2"
278 let create_array i = f a.(i) a'.(i) in
279 Array.init l create_array
281 let for_all2 f a a' =
282 let l = Array.length a
283 and l' = Array.length a' in
284 if l <> l' then invalid_arg "ArrayExt.for_all2"
286 let rec for_all2' i =
287 i = l || (f a.(i) a'.(i) && for_all2' (i + 1)) in
291 let l = Array.length a
292 and l' = Array.length a' in
293 if l <> l' then invalid_arg "ArrayExt.exists2"
296 i < l && (f a.(i) a'.(i) || exists2' (i + 1)) in
302 (* Instantiation functions *)
304 let rec evaluate_toplevel_definitions dic defs =
307 toplevel = lazy (dic @ evaluate defs');
310 context_variability = None;
311 context_causality = None;
312 parent_context = None;
313 class_context = ToplevelContext;
314 instance_context = None;
315 location = {Parser.start = 0; Parser.enddd = 0; filename = Parser.CommandLine};
316 instance_nature = ClassElement
318 and defs' = lazy (List.map (evaluate_toplevel_definition ctx) defs) in
321 and evaluate_toplevel_definition ctx (id, elt_desc) =
322 let elt_loc = [Name id] in
325 location = elt_desc.NameResolve.element_location;
326 instance_nature = instance_nature_of_element elt_desc} in
327 let elt_nat = elt_desc.NameResolve.element_nature in
331 element_nature = lazy (evaluate_toplevel_element ctx elt_loc elt_nat)
335 and evaluate_toplevel_element ctx elt_loc = function
336 | NameResolve.Component cpnt_desc ->
338 instantiate_component_description ctx [] None elt_loc cpnt_desc in
340 | NameResolve.Class cl_def ->
341 let cl_def' = evaluate_class_definition ctx [] elt_loc cl_def in
343 | NameResolve.ComponentType _ ->
345 { err_msg = ["_NotYetImplemented"; "_ComponentTypeElemInstant"];
347 err_ctx = ctx }) (*error*)
348 | NameResolve.PredefinedType _ ->
350 { err_msg = ["_NotYetImplemented"; "_PredefinedTypeElemInstant"];
352 err_ctx = ctx }) (*error*)
354 and instantiate_class_description ctx modifs rhs elt_loc cl_desc =
358 toplevel = lazy (evaluate ctx.toplevel);
360 parent_context = Some ctx;
361 class_context = InstanceContext inst;
362 instance_context = None
364 instantiate_class_elements ctx' modifs rhs cl_desc.long_description in
367 enclosing_instance = enclosing_instance ctx;
368 kind = cl_desc.class_kind;
369 elements = lazy (elements inst)
373 and enclosing_instance ctx = match ctx.class_context with
374 | ToplevelContext -> None
375 | InstanceContext inst -> Some inst
376 | ForContext (ctx', _) | FunctionEvaluationContext (ctx', _, _) ->
377 enclosing_instance ctx'
379 and instantiate_class_elements ctx modifs rhs long_desc =
380 let rec merge_elements named_elts unnamed_elts = function
383 named_elements = named_elts;
384 unnamed_elements = unnamed_elts
386 | inherited_elts :: inherited_eltss ->
387 let named_elts' = named_elts @ inherited_elts.named_elements
388 and unnamed_elts' = unnamed_elts @ inherited_elts.unnamed_elements in
389 merge_elements named_elts' unnamed_elts' inherited_eltss in
390 let named_elts = long_desc.NameResolve.named_elements
391 and unnamed_elts = long_desc.NameResolve.unnamed_elements
392 and exts = long_desc.NameResolve.extensions in
393 let named_elts' = instantiate_local_named_elements ctx modifs rhs named_elts
394 and unnamed_elts' = instantiate_local_unnamed_elements ctx unnamed_elts
395 and inherited_eltss = instantiate_inherited_elements ctx modifs rhs exts in
396 merge_elements named_elts' unnamed_elts' inherited_eltss
398 and instantiate_local_named_elements ctx modifs rhs named_elts =
399 List.fold_right (instantiate_local_named_element ctx modifs rhs) named_elts []
401 and instantiate_local_named_element ctx modifs rhs (id, elt_desc) named_elts =
402 let rec filter_current_element_modifications = function
404 | (id', arg) :: modifs when id' = id ->
405 arg :: filter_current_element_modifications modifs
406 | _ :: modifs -> filter_current_element_modifications modifs
407 and select_current_element_value = function
409 | Some expr -> Some (lazy (field_access ctx (evaluate expr) id)) in
410 let modifs' = filter_current_element_modifications modifs
411 and rhs' = select_current_element_value rhs
412 and elt_loc = ctx.path @ [Name id] in
415 location = elt_desc.NameResolve.element_location;
416 instance_nature = instance_nature_of_element elt_desc} in
418 lazy (instantiate_local_element_nature ctx modifs' rhs' elt_loc elt_desc) in
422 redeclare = elt_desc.NameResolve.redeclare;
423 element_nature = elt_nat
425 named_elt :: named_elts
427 and instantiate_local_element_nature ctx modifs rhs elt_loc elt_desc =
428 match elt_desc.NameResolve.element_nature with
429 | NameResolve.Component cpnt_desc ->
431 instantiate_component_description ctx modifs rhs elt_loc cpnt_desc in
433 | NameResolve.Class cl_def ->
434 let cl_def' = evaluate_class_definition ctx modifs elt_loc cl_def in
436 | NameResolve.ComponentType _ ->
438 { err_msg = ["_NotYetImplemented"; "_ComponentTypeElemInstant"];
441 | NameResolve.PredefinedType _ ->
443 { err_msg = ["_NotYetImplemented"; "_PredefinedTypeElemInstant"];
447 and instantiate_component_description ctx modifs rhs elt_loc cpnt_desc =
448 let cpnt_type = evaluate cpnt_desc.NameResolve.component_type in
449 let flow = evaluate cpnt_type.Types.flow
450 and var = evaluate cpnt_type.Types.variability
451 and inout = evaluate cpnt_type.Types.causality
452 and type_spec = evaluate cpnt_desc.NameResolve.type_specifier
453 and dims = evaluate cpnt_desc.NameResolve.dimensions
454 and modifs' = match evaluate cpnt_desc.NameResolve.modification with
457 let modif' = evaluate_modification ctx modif in
458 modifs @ [{ each = false; action = ElementModification modif' }]
459 and cmt = cpnt_desc.NameResolve.comment in
460 component_nature ctx modifs' rhs elt_loc flow var inout type_spec dims cmt
462 and component_nature ctx modifs rhs elt_loc flow var inout type_spec dims cmt =
463 let type_spec' = evaluate_expression ctx type_spec in
464 let ctx = {ctx with location = expression_location ctx type_spec} in
465 expand_array ctx modifs rhs elt_loc flow var inout type_spec' dims cmt
467 and expand_array ctx modifs rhs elt_loc flow var inout type_spec dims cmt =
468 let rec expand_along_dimension dim dims = match dim with
469 | NameResolve.Colon -> expand_dynamic_array dims
470 | NameResolve.Expression expr ->
471 let expr' = evaluate_expression ctx expr in
472 expand_static_array dims expr' expr
473 and expand_dynamic_array dims =
474 (* No need to select modifications since all of them have 'each' set *)
475 let elt_loc' = elt_loc @ [Index 0] in
476 let ctx = { ctx with path = elt_loc' } in
478 expand_array ctx modifs rhs elt_loc' flow var inout type_spec dims cmt in
480 and expand_static_array dims expr' expr =
481 let ctx = {ctx with location = expression_location ctx expr} in
482 let expand_element i =
483 let rec select_subargument arg = match arg.each with
485 | false -> { arg with action = select_subarray arg.action }
486 and select_subarray arg = match arg with
487 | ElementModification modif ->
488 ElementModification (select_submodification modif)
489 | ElementRedeclaration _ -> arg
490 and select_sub_class_modification_element (id, arg) =
491 id, select_subargument arg
492 and select_submodification = function
493 | Modification (modifs, rhs) ->
494 let modifs' = List.map select_sub_class_modification_element modifs
495 and rhs' = select_rhs_subarray rhs in
496 Modification (modifs', rhs')
498 let expr' = lazy (select_row i (evaluate expr)) in
501 let expr' = lazy (select_row i (evaluate expr)) in
503 and select_rhs_subarray = function
505 | Some expr -> Some (lazy (select_row i (evaluate expr)))
506 and select_row i = function
512 | _ -> raise (InstantError
513 { err_msg = ["_IndexOutOfBound"];
515 err_ctx = ctx}) (*error*)
518 let subs = [Integer (Int32.succ (Int32.of_int i))] in
519 evaluate_indexed_access ctx expr subs in
520 let modifs = List.map select_subargument modifs
521 and rhs = select_rhs_subarray rhs
522 and elt_loc = elt_loc @ [Index i] in
523 expand_array ctx modifs rhs elt_loc flow var inout type_spec dims cmt in
526 let a = Array.init (Int32.to_int i) expand_element in
530 { err_msg = ["_NonIntegerArrayDim"];
532 err_ctx = ctx }) (*error*) in
535 let cl_def = class_definition_of_type_specification ctx type_spec in
536 create_instance ctx modifs rhs elt_loc flow var inout cl_def cmt
539 component_path = elt_loc;
543 component_nature = lazy (expand_along_dimension dim dims);
544 declaration_equation = rhs;
546 component_location = ctx.location;
547 class_name = instance_class_name ctx.instance_nature
550 and create_instance ctx modifs rhs elt_loc flow var inout cl_def cmt =
551 let merge_class_modifications arg modifs = match arg.action with
552 | ElementModification (Modification (modifs', _)) -> modifs' @ modifs
553 | ElementModification (Assignment _ | Equality _) -> modifs
554 | ElementRedeclaration _ -> modifs in
555 let rec declaration_equation modifs rhs =
556 let rec declaration_equation' = function
560 ElementModification (
561 Modification (_, Some expr) | Assignment expr | Equality expr)
563 | _ :: args -> declaration_equation' args in
565 | None -> declaration_equation' modifs
567 let flow' = match cl_def.class_flow, ctx.context_flow with
569 | Some flow', None | None, Some flow' -> flow || flow'
570 | Some flow', Some flow'' -> flow || flow' || flow''
571 and var' = match cl_def.class_variability, ctx.context_variability with
573 | Some var', None | None, Some var' -> Types.min_variability var var'
574 | Some var', Some var'' ->
575 Types.min_variability var (Types.min_variability var' var'')
576 and inout' = match inout, cl_def.class_causality with
577 | Types.Input, _ | _, Some Types.Input -> Types.Input
578 | Types.Output, _ | _, Some Types.Output -> Types.Output
579 | _ -> Types.Acausal in
582 merge_class_modifications
583 (modifs @ cl_def.modification)
585 and rhs' = declaration_equation modifs rhs in
586 match cl_def.description with
587 | ClassDescription (ctx', cl_desc) ->
588 let class_name = instance_class_name ctx.instance_nature in
591 context_flow = Some flow';
592 context_variability = Some var';
593 context_causality = Some inout';
594 instance_context = enclosing_instance ctx;
595 instance_nature = ComponentElement class_name
598 component_path = elt_loc;
603 lazy (create_class_instance ctx' modifs' rhs' elt_loc cl_desc);
604 declaration_equation = rhs';
606 component_location = ctx'.location;
607 class_name = class_name
609 | PredefinedType predef ->
610 let class_name = instance_class_name ctx.instance_nature in
613 context_flow = Some flow';
614 context_variability = Some var';
615 context_causality = Some inout';
616 instance_nature = ComponentElement class_name
619 component_path = elt_loc;
624 lazy (create_predefined_type_instance ctx' modifs' predef);
625 declaration_equation = rhs';
627 component_location = ctx'.location;
628 class_name = class_name
631 and create_temporary_instance ctx cl_def =
632 match cl_def.description with
633 | ClassDescription (ctx', cl_desc) ->
637 variability = Types.Continuous;
638 causality = Types.Acausal;
640 lazy (create_class_instance ctx' [] None [] cl_desc);
641 declaration_equation = None;
643 component_location = ctx'.location;
644 class_name = instance_class_name ctx.instance_nature
646 | PredefinedType predef -> assert false (*error*)
648 and class_definition_of_type_specification ctx type_spec =
649 let predefined_class_specifier = function
650 | "Boolean" -> Types.boolean_class_type
651 | "Integer" -> Types.integer_class_type
652 | "Real" -> Types.real_class_type
653 | "String" -> Types.string_class_type
656 { err_msg = ["_UnknownIdentifier"; s];
658 err_ctx = ctx }) (*error*)
659 and predefined_class_description = function
660 | "Boolean" -> PredefinedType BooleanType
661 | "Integer" -> PredefinedType IntegerType
662 | "Real" -> PredefinedType RealType
663 | "String" -> PredefinedType StringType
666 { err_msg = ["_UnknownIdentifier"; s];
668 err_ctx = ctx }) (*error*) in
670 | ClassReference cl_def -> cl_def
671 | PredefinedIdentifier id ->
673 class_type = predefined_class_specifier id;
674 class_path = [Name id];
676 class_variability = None;
677 class_causality = None;
678 description = predefined_class_description id;
680 class_location = ctx.location
682 | _ -> assert false (*error*)
684 and create_class_instance ctx modifs rhs elt_loc cl_desc =
685 let inst = instantiate_class_description ctx modifs rhs elt_loc cl_desc in
688 and create_predefined_type_instance ctx modifs predef =
691 predefined_type = predef;
692 attributes = predefined_type_attributes ctx modifs
694 PredefinedTypeInstance inst
696 and predefined_type_attributes ctx modifs =
697 let rec predefined_type_attributes attrs = function
699 | (id, { action = ElementModification (Equality expr) }) :: modifs
700 when not (List.mem_assoc id attrs) ->
701 let attrs' = (id, expr) :: attrs in
702 predefined_type_attributes attrs' modifs
703 | _ :: modifs -> predefined_type_attributes attrs modifs in
704 predefined_type_attributes [] modifs
706 and instantiate_inherited_elements ctx modifs rhs exts =
707 List.fold_right (instantiate_inherited_element ctx modifs rhs) exts []
709 and instantiate_inherited_element ctx modifs rhs (_, modif_cl) inherited_elts =
710 let instantiate_inherited_element' modifs cl_def =
711 match cl_def.description with
712 | ClassDescription (ctx', cl_desc) ->
713 let ctx' = { ctx with parent_context = Some ctx' } in
714 let long_desc = cl_desc.long_description in
715 instantiate_class_elements ctx' modifs rhs long_desc
716 | PredefinedType _ -> assert false (*error*) in
717 let type_spec = evaluate modif_cl.NameResolve.base_class
718 and modifs' = evaluate modif_cl.NameResolve.class_modification in
719 let type_spec' = evaluate_expression ctx type_spec
720 and ctx = {ctx with location = expression_location ctx type_spec} in
721 let modifs = modifs @ evaluate_class_modification ctx modifs' in
722 match type_spec' with
723 | ClassReference cl_def ->
724 instantiate_inherited_element' modifs cl_def :: inherited_elts
725 | _ -> assert false (*error*)
727 and evaluate_class_definition ctx modifs elt_loc cl_def =
728 match evaluate cl_def.NameResolve.description with
729 | NameResolve.LongDescription long_desc ->
730 let cl_anns = long_desc.NameResolve.class_annotations in
733 class_kind = Types.Class;
734 class_annotations = lazy (evaluate_class_annotations ctx cl_anns);
735 long_description = long_desc
738 class_type = evaluate cl_def.NameResolve.class_type;
739 class_path = elt_loc;
741 class_variability = None;
742 class_causality = None;
743 description = ClassDescription (ctx, cl_def');
744 modification = modifs;
745 class_location = ctx.location
747 | NameResolve.ShortDescription short_desc ->
749 {err_msg = ["_NotYetImplemented"; "_ShortClassDef"];
751 err_ctx = {ctx with path = elt_loc;
752 instance_nature = ClassElement}})
754 and evaluate_class_annotations ctx cl_anns =
755 let evaluate_inverse_function inv_func =
756 let inv_func = evaluate inv_func in
758 evaluate_expression ctx inv_func.NameResolve.function_class in
760 | ClassReference cl_def ->
762 function_class = cl_def;
763 arguments = inv_func.NameResolve.arguments
765 | _ -> assert false (*error*) in
766 let evaluate_class_annotation cl_ann = match cl_ann with
767 | NameResolve.InverseFunction inv_func ->
768 InverseFunction (lazy (evaluate_inverse_function inv_func))
769 | NameResolve.UnknownAnnotation cl_ann ->
770 UnknownAnnotation cl_ann in
771 List.map evaluate_class_annotation (evaluate cl_anns)
773 and evaluate_class_modification ctx cl_modif =
774 let add_modification_argument arg cl_modif' =
775 match arg.NameResolve.action with
779 arg.NameResolve.target,
781 each = arg.NameResolve.each;
782 action = evaluate_modification_action ctx modif
785 List.fold_right add_modification_argument cl_modif []
787 and evaluate_modification_action ctx = function
788 | NameResolve.ElementModification modif ->
789 let modif' = evaluate_modification ctx modif in
790 ElementModification modif'
791 | NameResolve.ElementRedeclaration elt_desc ->
793 { err_msg = ["_NotYetImplemented"; "_ElementRedeclaration"];
797 and evaluate_modification ctx = function
798 | NameResolve.Modification (modifs, rhs) ->
799 let modifs' = evaluate_class_modification ctx modifs
800 and rhs' = evaluate_modification_expression ctx rhs in
801 Modification (modifs', rhs')
802 | NameResolve.Assignment expr ->
803 let expr = evaluate expr in
804 let ctx = {ctx with location = expression_location ctx expr} in
806 { err_msg = ["_NotYetImplemented"; "_AssignExprInElemModif"];
809 | NameResolve.Equality expr ->
810 let expr' = lazy (evaluate_expression ctx (evaluate expr)) in
813 and evaluate_modification_expression ctx = function
816 let expr' = lazy (evaluate_expression ctx (evaluate expr)) in
819 and instantiate_local_unnamed_elements ctx unnamed_elts =
820 List.map (instantiate_local_unnamed_element ctx) (evaluate unnamed_elts)
822 and instantiate_local_unnamed_element ctx unnamed_elt =
823 match unnamed_elt with
824 | NameResolve.EquationClause (validity, equs) ->
825 EquationClause (validity, lazy (instantiate_equations ctx equs))
826 | NameResolve.AlgorithmClause (validity, algs) ->
828 { err_msg = ["_NotYetImplemented"; "_AlgoClause"];
832 and instantiate_equations ctx equs =
833 let instantiate_equations' equ equs =
834 let equs' = instantiate_equation ctx equ in
835 { nature = equs'; info = equ } :: equs in
836 List.fold_right instantiate_equations' equs []
838 and instantiate_equation ctx equ = match equ.NameResolve.nature with
839 | NameResolve.Equal (expr, expr') -> instantiate_equal ctx expr expr'
840 | NameResolve.ConditionalEquationE (alts, default) ->
841 instantiate_conditional_equation ctx alts default
842 | NameResolve.ForClauseE (ranges, equs) ->
843 instantiate_for_clause_e ctx ranges equs
844 | NameResolve.ConnectFlows (sign, expr, sign', expr') ->
845 instantiate_connection ctx sign expr sign' expr'
846 | NameResolve.WhenClauseE alts ->
847 instantiate_when_clause_e ctx alts
849 and instantiate_equal ctx expr expr' =
850 let rec equal_expr expr expr' =
851 match expr, expr' with
852 | BinaryOperation (bin_oper_kind, expr1, expr2),
853 BinaryOperation (bin_oper_kind', expr1', expr2') ->
854 (bin_oper_kind = bin_oper_kind') &&
855 (equal_expr expr1 expr1') &&
856 (equal_expr expr2 expr2')
857 | ClassReference cl_def, ClassReference cl_def' ->
858 cl_def.class_path = cl_def'.class_path
859 | ComponentReference cpnt_desc, ComponentReference cpnt_desc' ->
860 cpnt_desc.component_path = cpnt_desc'.component_path
861 | EnumerationElement s, EnumerationElement s' -> s = s'
862 | False, False -> true
863 | FieldAccess (expr, s), FieldAccess (expr', s') ->
864 (equal_expr expr expr') && (s = s')
865 | FunctionCall (expr, exprs), FunctionCall (expr', exprs') ->
866 (equal_expr expr expr') &&
867 (List.length exprs = List.length exprs') &&
868 (List.for_all2 (=) exprs exprs')
869 | If (alts, default), If (alts', default') ->
870 let f (cond, expr) (cond', expr') =
871 (equal_expr cond cond') && (equal_expr expr expr') in
872 (List.length alts = List.length alts') &&
873 (List.for_all2 f alts alts') &&
874 (equal_expr default default')
875 | IndexedAccess (expr, exprs), IndexedAccess (expr', exprs') ->
876 (equal_expr expr expr') &&
877 (List.length exprs = List.length exprs') &&
878 (List.for_all2 (=) exprs exprs')
879 | Integer i, Integer i' -> Int32.compare i i' = 0
880 | LoopVariable i, LoopVariable i' -> i = i'
881 | NoEvent expr, NoEvent expr' -> equal_expr expr expr'
882 | PredefinedIdentifier s, PredefinedIdentifier s' -> s = s'
883 | Range (start, step, stop), Range (start', step', stop') ->
884 (equal_expr start start') &&
885 (equal_expr step step') &&
886 (equal_expr stop stop')
887 | Real f, Real f' -> f = f'
888 | Record elts, Record elts' ->
889 let f (s, expr) (s', expr') =
890 (s = s') && (equal_expr expr expr') in
891 (List.length elts = List.length elts') &&
892 (List.for_all2 f elts elts')
893 | String s, String s' -> s = s'
895 | Tuple exprs, Tuple exprs' ->
896 (List.length exprs = List.length exprs') &&
897 (List.for_all2 equal_expr exprs exprs')
898 | UnaryOperation (un_oper_kind, expr),
899 UnaryOperation (un_oper_kind', expr') ->
900 (un_oper_kind = un_oper_kind') &&
901 (equal_expr expr expr')
902 | Vector exprs, Vector exprs' ->
903 (Array.length exprs = Array.length exprs') &&
904 (ArrayExt.for_all2 equal_expr exprs exprs')
905 | VectorReduction (exprs, expr), VectorReduction (exprs', expr') ->
906 (List.length exprs = List.length exprs') &&
907 (List.for_all2 equal_expr exprs exprs') &&
908 (equal_expr expr expr')
910 let expr = evaluate_expression ctx expr
911 and expr' = evaluate_expression ctx expr' in
912 match equal_expr expr expr' with
914 | false -> [ Equal (expr, expr') ]
916 and instantiate_conditional_equation ctx alts default =
917 let rec instantiate_alternatives acc = function
918 | [] -> instantiate_default acc default
919 | (cond, equs) :: alts -> instantiate_alternative acc cond equs alts
920 and instantiate_alternative acc cond equs alts =
921 let cond' = evaluate_expression ctx cond in
923 | False -> instantiate_alternatives acc alts
924 | True -> instantiate_default acc equs
926 let equs' = instantiate_equations ctx equs in
927 instantiate_alternatives ((cond', equs') :: acc) alts
928 and instantiate_default acc equs =
929 let equs' = instantiate_equations ctx equs in
930 [ConditionalEquationE (List.rev acc, equs')] in
931 let alts' = instantiate_alternatives [] alts in
932 List.flatten (List.map (expand_equation ctx) alts')
934 and expand_equation ctx equ =
935 let rec expand_equation' equ =
936 let expand_conditional_equation alts default =
937 let add_alternative (b, equs) altss =
938 let g equ = List.flatten (List.map expand_equation' equ.nature) in
939 let equs' = List.flatten (List.map g equs) in
940 let f (expr1, expr2) (expr1', expr2') = match expr1, expr2 with
941 | If (alts1, default1), If (alts2, default2) ->
942 If ((b, expr1') :: alts1, default1),
943 If ((b, expr2') :: alts2, default2)
944 | _ -> assert false in
946 List.map2 f altss equs'
950 {err_msg = ["_InvalidCondEquation"];
953 let g equ = List.flatten (List.map expand_equation' equ.nature) in
954 let default' = List.flatten (List.map g default) in
955 let f = function (expr1, expr2) -> If ([], expr1), If ([], expr2) in
956 List.fold_right add_alternative alts (List.map f default') in
958 | ConditionalEquationE (alts, default) ->
959 expand_conditional_equation alts default
960 | Equal (expr, expr') -> [ expr, expr' ]
963 {err_msg = ["_InvalidCondEquation"];
966 let f (expr, expr') = Equal (expr, expr') in
967 List.map f (expand_equation' equ)
969 and instantiate_when_clause_e ctx alts =
970 let instantiate_alternative (cond, equs) =
971 let cond' = evaluate_expression ctx cond in
972 let equs' = instantiate_equations ctx equs in
974 [WhenClauseE (List.map instantiate_alternative alts)]
976 and instantiate_connection ctx sign expr sign' expr' =
977 let expr = evaluate_expression ctx expr
978 and expr' = evaluate_expression ctx expr' in
979 [ConnectFlows (sign, expr, sign', expr')]
981 and instantiate_for_clause_e ctx ranges equs =
982 let rec instantiate_for_clause_e' ctx = function
983 | [] -> List.flatten (List.map (instantiate_equation ctx) equs)
984 | ranges -> equations_of_reduction ctx ranges
985 and equations_of_reduction ctx ranges = match ranges with
986 | (Vector exprs) :: ranges ->
990 class_context = ForContext (ctx, Some expr)
992 instantiate_for_clause_e' ctx' ranges in
993 List.flatten (List.map f (Array.to_list exprs))
996 {err_msg = ["_InvalidForClauseRange"];
999 let ranges = List.map (evaluate_expression ctx) ranges in
1000 instantiate_for_clause_e' ctx ranges
1002 and evaluate_expression ctx expr =
1003 let ctx = {ctx with location = expression_location ctx expr} in
1004 match expr.NameResolve.nature with
1005 | NameResolve.BinaryOperation (binop, expr, expr') ->
1006 evaluate_binary_operation ctx binop expr expr'
1007 | NameResolve.DynamicIdentifier (level, id) ->
1008 evaluate_dynamic_identifier ctx level id
1009 | NameResolve.False -> False
1010 | NameResolve.FieldAccess (expr, id) ->
1011 evaluate_field_access ctx expr id
1012 | NameResolve.FunctionArgument pos -> evaluate_function_argument ctx pos
1013 | NameResolve.FunctionCall (expr, exprs, expr') ->
1014 evaluate_function_call ctx expr exprs expr'
1015 | NameResolve.FunctionInvocation exprs ->
1016 evaluate_function_invocation ctx exprs
1017 | NameResolve.If (alts, default) -> evaluate_if ctx alts default
1018 | NameResolve.IndexedAccess (expr, exprs) ->
1019 let expr = evaluate_expression ctx expr
1020 and exprs = List.map (evaluate_expression ctx) exprs in
1021 evaluate_indexed_access ctx expr exprs
1022 | NameResolve.Integer i -> Integer i
1023 | NameResolve.LocalIdentifier (level, id) ->
1024 evaluate_local_identifier ctx level id
1025 | NameResolve.LoopVariable level -> evaluate_loop_variable ctx level
1026 | NameResolve.NoEvent expr -> evaluate_no_event ctx expr
1027 | NameResolve.PredefinedIdentifier id -> PredefinedIdentifier id
1028 | NameResolve.Range (start, step, stop) ->
1029 evaluate_range ctx start step stop
1030 | NameResolve.Real f -> Real f
1031 | NameResolve.String s -> String s
1032 | NameResolve.ToplevelIdentifier id ->
1033 evaluate_toplevel_identifier ctx id
1034 | NameResolve.True -> True
1035 | NameResolve.Tuple exprs -> evaluate_tuple ctx exprs
1036 | NameResolve.UnaryOperation (unop, expr) ->
1037 evaluate_unary_operation ctx unop expr
1038 | NameResolve.VectorReduction (ranges, expr) ->
1039 evaluate_vector_reduction ctx ranges expr
1040 | NameResolve.Vector exprs -> evaluate_vector ctx exprs
1041 | NameResolve.Coercion (coer, expr) ->
1042 evaluate_coercion ctx coer expr
1044 and evaluate_binary_operation ctx binop expr expr' =
1045 let expr = evaluate_expression ctx expr
1046 and expr' = evaluate_expression ctx expr' in
1047 let expr = flatten_expression expr
1048 and expr' = flatten_expression expr' in
1050 | NameResolve.And -> evaluate_and expr expr'
1051 | NameResolve.Divide -> evaluate_divide ctx expr expr'
1052 | NameResolve.EqualEqual -> evaluate_equalequal expr expr'
1053 | NameResolve.GreaterEqual -> evaluate_greater_equal expr expr'
1054 | NameResolve.Greater -> evaluate_greater expr expr'
1055 | NameResolve.LessEqual -> evaluate_less_equal expr expr'
1056 | NameResolve.Less -> evaluate_less expr expr'
1057 | NameResolve.Times -> evaluate_times expr expr'
1058 | NameResolve.NotEqual -> evaluate_not_equal expr expr'
1059 | NameResolve.Or -> evaluate_or expr expr'
1060 | NameResolve.Plus -> evaluate_plus expr expr'
1061 | NameResolve.Power -> evaluate_power ctx expr expr'
1062 | NameResolve.Minus -> evaluate_minus expr expr'
1064 and evaluate_dynamic_identifier ctx level id =
1065 let rec evaluate_dynamic_identifier' inst level =
1066 match level, inst.enclosing_instance with
1067 | 0, _ -> instance_field_access ctx inst id
1068 | _, Some inst -> evaluate_dynamic_identifier' inst (level - 1)
1069 | _, None -> assert false (*error*) in
1070 match ctx.instance_context with
1071 | Some inst -> evaluate_dynamic_identifier' inst level
1072 | None -> assert false (*error*)
1074 and evaluate_field_access ctx expr id =
1075 let expr = evaluate_expression ctx expr in
1076 field_access ctx expr id
1078 and evaluate_function_argument ctx pos = match ctx.class_context with
1079 | FunctionEvaluationContext (_, expr, _) when pos = 0 -> expr
1080 | FunctionEvaluationContext (_, _, exprs) -> List.nth exprs (pos - 1)
1081 | ForContext (ctx', _) -> evaluate_function_argument ctx' pos
1082 | InstanceContext _ | ToplevelContext -> assert false (*error*)
1084 and evaluate_function_call ctx expr exprs expr' =
1085 let expr = evaluate_expression ctx expr
1086 and exprs = List.map (evaluate_expression ctx) exprs in
1087 let exprs = List.map flatten_expression exprs in
1090 class_context = FunctionEvaluationContext (ctx, expr, exprs)
1092 evaluate_expression ctx' expr'
1094 and evaluate_function_invocation ctx exprs =
1095 let exprs = List.map (evaluate_expression ctx) exprs in
1096 let exprs = List.map flatten_expression exprs in
1097 let evaluate_function_with_arguments = function
1098 | ClassReference cl_def ->
1099 evaluate_class_function_invocation cl_def exprs
1100 | PredefinedIdentifier s ->
1101 evaluate_predefined_function_invocation ctx s exprs
1102 | ComponentReference _ ->
1104 { err_msg = ["_NotYetImplemented"; "_ComponentFuncInvocation"];
1107 | _ -> assert false (*error*) in
1108 let rec evaluate_function_invocation' ctx = match ctx.class_context with
1109 | FunctionEvaluationContext (_, expr, _) ->
1110 evaluate_function_with_arguments expr
1111 | ForContext (ctx', _) -> evaluate_function_invocation' ctx'
1112 | InstanceContext _ | ToplevelContext -> assert false (*error*) in
1113 evaluate_function_invocation' ctx
1115 and evaluate_if ctx alts default =
1116 let create_if alts default = match alts with
1118 | _ :: _ -> If (alts, default) in
1119 let rec evaluate_alternatives alts' alts = match alts with
1121 let default = evaluate_expression ctx default in
1122 create_if (List.rev alts') default
1123 | (expr, expr') :: alts ->
1124 let expr = evaluate_expression ctx expr in
1125 evaluate_alternative expr expr' alts' alts
1126 and evaluate_alternative expr expr' alts' alts = match expr with
1128 let default = evaluate_expression ctx expr' in
1129 create_if (List.rev alts') default
1130 | False -> evaluate_alternatives alts' alts
1132 let expr' = evaluate_expression ctx expr' in
1133 evaluate_alternatives ((expr, expr') :: alts') alts in
1134 evaluate_alternatives [] alts
1136 and evaluate_indexed_access ctx expr exprs =
1137 let rec vector_indexed_access exprs' exprs = match exprs with
1139 | Integer i :: exprs ->
1142 exprs'.(Int32.to_int i - 1)
1145 { err_msg = ["_IndexOutOfBound"];
1147 err_ctx = ctx}) (*error*) in
1148 evaluate_indexed_access ctx expr' exprs
1149 | (Vector subs) :: exprs ->
1150 let f sub = vector_indexed_access exprs' (sub :: exprs) in
1151 Vector (Array.map f subs)
1152 | _ -> IndexedAccess (expr, exprs)
1153 and component_indexed_access cpnt_desc exprs =
1154 let rec static_array_indexed_access cpnt_descs exprs = match exprs with
1156 | Integer i :: exprs ->
1157 let i' = Int32.to_int i in
1158 if Array.length cpnt_descs >= i' then
1159 let cpnt_desc = cpnt_descs.(i' - 1) in
1160 let expr' = ComponentReference cpnt_desc in
1161 evaluate_indexed_access ctx expr' exprs
1164 { err_msg = ["_IndexOutOfBound"];
1166 err_ctx = ctx}) (*error*)
1167 | (Vector subs) :: exprs ->
1168 let f sub = static_array_indexed_access cpnt_descs (sub :: exprs) in
1169 Vector (Array.map f subs)
1170 | exprs -> IndexedAccess (expr, exprs) in
1171 match evaluate cpnt_desc.component_nature with
1172 | DynamicArray _ -> IndexedAccess (ComponentReference cpnt_desc, exprs)
1173 | StaticArray cpnt_descs ->
1174 static_array_indexed_access cpnt_descs exprs
1175 | Instance _ | PredefinedTypeInstance _ -> expr in
1176 match expr, exprs with
1178 | ComponentReference cpnt_desc, _ ->
1179 component_indexed_access cpnt_desc exprs
1180 | Vector exprs', _ ->
1181 vector_indexed_access exprs' exprs
1182 | If (alts, default), _ ->
1183 let f (cond, expr) = (cond, evaluate_indexed_access ctx expr exprs) in
1184 If (List.map f alts, evaluate_indexed_access ctx default exprs)
1185 | _ -> IndexedAccess (expr, exprs)
1187 and evaluate_local_identifier ctx level id =
1188 let rec evaluate_local_identifier' ctx inst level =
1189 match level, ctx.parent_context with
1190 | 0, _ -> instance_field_access ctx inst id
1191 | _, Some ctx -> evaluate_local_identifier ctx (level - 1) id
1192 | _, None -> assert false (*error*) in
1193 match ctx.class_context with
1194 | ForContext (ctx, _) | FunctionEvaluationContext (ctx, _, _) ->
1195 evaluate_local_identifier ctx level id
1196 | InstanceContext inst -> evaluate_local_identifier' ctx inst level
1197 | ToplevelContext -> assert false (*error*)
1199 and evaluate_loop_variable ctx level =
1200 let rec evaluate_loop_variable' ctx level' =
1201 match level', ctx.class_context with
1202 | 0, ForContext (_, None) -> assert false (*LoopVariable level'*)
1203 | 0, ForContext (_, Some expr) -> expr
1204 | _, ForContext (ctx, _) -> evaluate_loop_variable ctx (level' - 1)
1205 | _, FunctionEvaluationContext (ctx, _, _) ->
1206 evaluate_loop_variable' ctx level'
1207 | _, (InstanceContext _ | ToplevelContext) -> assert false (*error*) in
1208 evaluate_loop_variable' ctx level
1210 and evaluate_no_event ctx expr =
1211 let expr = evaluate_expression ctx expr in
1213 | True | False | Integer _ | Real _ | String _ | EnumerationElement _ ->
1217 and evaluate_range ctx start step stop =
1218 let start = evaluate_expression ctx start
1219 and step = evaluate_expression ctx step
1220 and stop = evaluate_expression ctx stop in
1221 let real_of_expression expr = match expr with
1223 | Integer i -> Int32.to_float i
1224 | _ -> assert false in
1225 let integer_interval istart istep istop = match istart, istep, istop with
1227 when (Int32.compare istop istart) *
1228 (Int32.compare istep Int32.zero) < 0 ->
1229 Vector (Array.make 0 (Integer istart))
1232 Int32.div (Int32.sub istop istart) istep in
1233 let n' = Int32.to_int (Int32.succ n) in
1235 let i' = Int32.of_int i in
1237 Int32.add istart (Int32.mul i' istep) in
1239 Vector (Array.init n' f)
1240 and real_interval rstart rstep rstop = match rstart, rstep, rstop with
1241 | _ when (rstop -. rstart) /. rstep < 0. ->
1242 Vector (Array.make 0 (Real rstart))
1244 let n = truncate ((rstop -. rstart) /. rstep) + 1
1245 and f i = Real (rstart +. float_of_int i *. rstep) in
1246 Vector (Array.init n f) in
1247 match start, step, stop with
1248 | _, Integer istep, _
1249 when Int32.compare istep Int32.zero = 0 ->
1251 {err_msg = ["_RangeStepValueCannotBeNull"];
1254 | _, Real rstep, _ when rstep = 0. ->
1256 {err_msg = ["_RangeStepValueCannotBeNull"];
1259 | Integer istart, Integer istep, Integer istop ->
1260 integer_interval istart istep istop
1261 | (Integer _ | Real _), (Integer _ | Real _), (Integer _ | Real _) ->
1262 let rstart = real_of_expression start
1263 and rstep = real_of_expression step
1264 and rstop = real_of_expression stop in
1265 real_interval rstart rstep rstop
1266 | _, _, _ -> Range (start, step, stop)
1268 and evaluate_coercion ctx coer expr =
1269 let rec evaluate_real_of_integer expr' = match expr' with
1270 | Integer i -> Real (Int32.to_float i)
1272 Vector (Array.map evaluate_real_of_integer exprs)
1274 let expr' = evaluate_expression ctx expr in
1276 | NameResolve.RealOfInteger -> evaluate_real_of_integer expr'
1278 and evaluate_toplevel_identifier ctx id =
1279 let elt_desc = List.assoc id (evaluate ctx.toplevel) in
1280 match evaluate elt_desc.element_nature with
1281 | Class cl_def -> ClassReference cl_def
1282 | Component cpnt_desc -> ComponentReference cpnt_desc
1284 and evaluate_tuple ctx exprs =
1285 Tuple (List.map (evaluate_expression ctx) exprs)
1287 and evaluate_unary_operation ctx unop expr =
1288 let expr = evaluate_expression ctx expr in
1289 let expr = flatten_expression expr in
1291 | NameResolve.Not -> evaluate_not expr
1292 | NameResolve.UnaryMinus -> evaluate_unary_minus expr
1293 | NameResolve.UnaryPlus -> expr
1295 (*and evaluate_vector_reduction ctx ranges expr =
1296 let rec evaluate_vector_reduction' ctx = function
1297 | [] -> evaluate_expression ctx expr
1298 | ranges -> vector_of_reduction ctx ranges
1299 and vector_of_reduction ctx = function
1300 | Range (Integer start, Integer step, Integer stop) :: ranges ->
1301 vector_of_range ctx start step stop ranges
1305 class_context = ForContext (ctx, None)
1307 VectorReduction (ranges, evaluate_expression ctx' expr)
1308 and vector_of_range ctx start step stop ranges =
1309 let rec expression_list pred start = match pred start with
1314 class_context = ForContext (ctx, Some (Integer start))
1316 let expr = evaluate_vector_reduction' ctx' ranges in
1317 expr :: expression_list pred (Int32.add start step) in
1318 let cmp = Int32.compare step 0l in
1320 | 0 when Int32.compare start stop <> 0 -> assert false (*error*)
1323 let pred = function i -> Int32.compare i stop < 0 in
1324 let exprs = expression_list pred start in
1325 Vector (Array.of_list exprs)
1327 let pred = function i -> Int32.compare i stop > 0 in
1328 let exprs = expression_list pred start in
1329 Vector (Array.of_list exprs) in
1330 let ranges = List.map (evaluate_expression ctx) ranges in
1331 evaluate_vector_reduction' ctx ranges*)
1333 and evaluate_vector_reduction ctx ranges expr =
1334 let rec evaluate_vector_reduction' ctx = function
1335 | [] -> evaluate_expression ctx expr
1336 | ranges -> vector_of_reduction ctx ranges
1337 and vector_of_reduction ctx = function
1338 | Range (Integer u, Integer p, Integer v) :: ranges ->
1339 vector_of_integer_range ctx u p v ranges
1340 | Range (Real u, Real p, Real v) :: ranges ->
1341 vector_of_real_range ctx u p v ranges
1342 | Vector exprs :: ranges ->
1346 class_context = ForContext (ctx, Some exprs.(i))
1348 evaluate_vector_reduction' ctx' ranges in
1349 Vector (Array.init (Array.length exprs) f)
1351 and vector_of_integer_range ctx start step stop ranges =
1352 let rec expression_list pred start = match pred start with
1355 let expr = Integer start in
1359 ForContext (ctx, Some expr)
1361 let expr = evaluate_vector_reduction' ctx' ranges in
1362 let next = Int32.add start step in
1363 expr :: expression_list pred next in
1365 | _ when Int32.compare step Int32.zero = 0 ->
1367 {err_msg = ["_RangeStepValueCannotBeNull"];
1370 | _ when Int32.compare step Int32.zero < 0 ->
1371 let pred = function i -> (Int32.compare i stop < 0) in
1372 Vector (Array.of_list (expression_list pred start))
1374 let pred = function i -> (Int32.compare i stop > 0) in
1375 Vector (Array.of_list (expression_list pred start))
1376 and vector_of_real_range ctx start step stop ranges =
1377 let rec expression_list pred start = match pred start with
1380 let expr = Real start in
1383 class_context = ForContext (ctx, Some expr)
1385 let expr = evaluate_vector_reduction' ctx' ranges in
1386 expr :: expression_list pred (start +. step) in
1390 {err_msg = ["_RangeStepValueCannotBeNull"];
1393 | _ when step < 0. ->
1394 let pred = function f -> f < stop in
1395 Vector (Array.of_list (expression_list pred start))
1397 let pred = function f -> f > stop in
1398 Vector (Array.of_list (expression_list pred start)) in
1399 let ranges = List.map (evaluate_expression ctx) ranges in
1400 evaluate_vector_reduction' ctx ranges
1402 and evaluate_vector ctx exprs =
1403 let exprs = List.map (evaluate_expression ctx) exprs in
1404 Vector (Array.of_list exprs)
1406 and evaluate_and expr expr' = match expr, expr' with
1407 | False, (False | True) | True, False -> False
1408 | True, True -> True
1409 | Vector exprs, Vector exprs' ->
1410 Vector (ArrayExt.map2 evaluate_and exprs exprs')
1411 | _ -> BinaryOperation (And, expr, expr')
1413 and evaluate_divide ctx expr expr' = match expr, expr' with
1416 { err_msg = ["_DivisionByZero"];
1418 err_ctx = ctx }) (*error*)
1419 | Integer 0l, _ -> Integer 0l
1420 | Integer i, Integer i' ->
1421 Real ((Int32.to_float i) /. (Int32.to_float i'))
1424 { err_msg = ["_DivisionByZero"];
1426 err_ctx = ctx }) (*error*)
1427 | Integer i, Real f -> Real (Int32.to_float i /. f)
1428 | Real f, Integer i -> Real (f /. Int32.to_float i)
1429 | Real f, Real f' -> Real (f /. f')
1430 | Vector exprs, _ ->
1431 let divide_element expr = evaluate_divide ctx expr expr' in
1432 Vector (Array.map divide_element exprs)
1433 | _ -> BinaryOperation (Divide, expr, expr')
1435 and evaluate_equalequal expr expr' = match expr, expr' with
1436 | Integer i, Integer i' when i = i' -> True
1437 | Integer i, Real f | Real f, Integer i when f = Int32.to_float i -> True
1438 | Real f, Real f' when f = f' -> True
1439 | (Integer _ | Real _), (Integer _ | Real _) -> False
1440 | Vector exprs, Vector exprs'
1443 (fun expr expr' -> evaluate_equalequal expr expr' = True)
1446 | Vector _, Vector _ -> False
1447 | _ -> BinaryOperation (EqualEqual, expr, expr')
1449 and evaluate_greater_equal expr expr' = match expr, expr' with
1450 | Integer i, Integer i' when i >= i' -> True
1451 | Integer i, Real f when Int32.to_float i >= f -> True
1452 | Real f, Integer i when f >= Int32.to_float i -> True
1453 | Real f, Real f' when f >= f' -> True
1454 | (Integer _ | Real _), (Integer _ | Real _) -> False
1455 | _ -> BinaryOperation (GreaterEqual, expr, expr')
1457 and evaluate_greater expr expr' = match expr, expr' with
1458 | Integer i, Integer i' when i > i' -> True
1459 | Integer i, Real f when Int32.to_float i > f -> True
1460 | Real f, Integer i when f > Int32.to_float i -> True
1461 | Real f, Real f' when f > f' -> True
1462 | (Integer _ | Real _), (Integer _ | Real _) -> False
1463 | _ -> BinaryOperation (Greater, expr, expr')
1465 and evaluate_less_equal expr expr' = match expr, expr' with
1466 | Integer i, Integer i' when i <= i' -> True
1467 | Integer i, Real f when Int32.to_float i <= f -> True
1468 | Real f, Integer i when f <= Int32.to_float i -> True
1469 | Real f, Real f' when f <= f' -> True
1470 | (Integer _ | Real _), (Integer _ | Real _) -> False
1471 | _ -> BinaryOperation (LessEqual, expr, expr')
1473 and evaluate_less expr expr' = match expr, expr' with
1474 | Integer i, Integer i' when i < i' -> True
1475 | Integer i, Real f when Int32.to_float i < f -> True
1476 | Real f, Integer i when f < Int32.to_float i -> True
1477 | Real f, Real f' when f < f' -> True
1478 | (Integer _ | Real _), (Integer _ | Real _) -> False
1479 | _ -> BinaryOperation (Less, expr, expr')
1481 and evaluate_times expr expr' =
1482 let rec line exprs i = match exprs.(i) with
1483 | Vector exprs -> exprs
1485 and column exprs j =
1486 let f i = match exprs.(i) with
1487 | Vector exprs -> exprs.(j)
1488 | _ -> assert false in
1489 Array.init (Array.length exprs) f
1490 and ndims expr = match expr with
1491 | Vector exprs when Array.length exprs = 0 -> assert false
1492 | Vector exprs -> 1 + ndims exprs.(0)
1494 and size expr i = match expr, i with
1495 | _, 0 -> assert false
1496 | Vector exprs, 1 -> Array.length exprs
1498 | Vector exprs, _ when i > 1 -> size exprs.(0) (i - 1)
1499 | _, _ -> assert false
1500 and vector_mult exprs exprs' =
1501 let exprs = ArrayExt.map2 evaluate_times exprs exprs' in
1502 match Array.length exprs with
1506 let exprs' = Array.sub exprs 1 (n - 1) in
1507 Array.fold_left evaluate_plus exprs.(0) exprs' in
1508 match expr, expr' with
1509 | Integer 0l, _ | _, Integer 0l -> Integer 0l
1510 | Integer 1l, _ -> expr'
1511 | _, Integer 1l -> expr
1512 | Integer i, Integer i' -> Integer (Int32.mul i i')
1513 | Integer i, Real f | Real f, Integer i -> Real (f *. Int32.to_float i)
1514 | Real f, Real f' -> Real (f *. f')
1515 | _, Vector exprs' when (ndims expr = 0) ->
1516 Vector (Array.map (evaluate_times expr) exprs')
1517 | Vector exprs, _ when (ndims expr' = 0) ->
1518 Vector (Array.map (evaluate_times expr') exprs)
1519 | Vector exprs, Vector exprs' when (ndims expr = 1) && (ndims expr' = 1) ->
1520 vector_mult exprs exprs'
1521 | Vector exprs, Vector exprs' when (ndims expr = 1) && (ndims expr' = 2) ->
1522 let f j = vector_mult exprs (column exprs' j) in
1523 Vector (Array.init (size expr' 2) f)
1524 | Vector exprs, Vector exprs' when (ndims expr = 2) && (ndims expr' = 1) ->
1525 let f i = vector_mult (line exprs i) exprs' in
1526 Vector (Array.init (size expr 1) f)
1527 | Vector exprs, Vector exprs' when (ndims expr = 2) && (ndims expr' = 2) ->
1528 let f i j = vector_mult (line exprs i) (column exprs' j) in
1529 let g i = Vector (Array.init (size expr' 2) (f i)) in
1530 Vector (Array.init (size expr 1) g)
1531 | _ -> BinaryOperation (Times, expr, expr')
1533 and evaluate_not_equal expr expr' = match expr, expr' with
1534 | Integer i, Integer i' when i <> i' -> True
1535 | Integer i, Real f | Real f, Integer i when f <> Int32.to_float i -> True
1536 | Real f, Real f' when f <> f' -> True
1537 | (Integer _ | Real _), (Integer _ | Real _) -> False
1538 | Vector exprs, Vector exprs'
1541 (fun expr expr' -> evaluate_equalequal expr expr' = False)
1544 | Vector _, Vector _ -> False
1545 | _ -> BinaryOperation (NotEqual, expr, expr')
1547 and evaluate_or expr expr' = match expr, expr' with
1548 | True, (False | True) | False, True -> True
1549 | False, False -> False
1550 | Vector exprs, Vector exprs' ->
1551 Vector (ArrayExt.map2 evaluate_or exprs exprs')
1552 | _ -> BinaryOperation (Or, expr, expr')
1554 and evaluate_plus expr expr' = match expr, expr' with
1555 | Integer 0l, _ -> expr'
1556 | _, Integer 0l -> expr
1557 | Integer i, Integer i' -> Integer (Int32.add i i')
1558 | Integer i, Real f | Real f, Integer i -> Real (f +. Int32.to_float i)
1559 | Real f, Real f' -> Real (f +. f')
1560 | Vector exprs, Vector exprs' ->
1561 Vector (ArrayExt.map2 evaluate_plus exprs exprs')
1562 | _ -> BinaryOperation (Plus, expr, expr')
1564 and evaluate_power ctx expr expr' =
1565 match expr, expr' with
1566 | (Integer 0l | Real 0.), (Integer 0l | Real 0.) ->
1568 { err_msg = ["_ZeroRaisedToTheZeroPower"];
1570 err_ctx = ctx }) (*error*)
1571 | (Integer 0l | Real 0.), Integer i'
1572 when Int32.compare i' 0l < 0 ->
1574 { err_msg = ["_ZeroRaisedToNegativePower"];
1576 err_ctx = ctx }) (*error*)
1577 | (Integer 0l | Real 0.), Real f' when f' < 0. ->
1579 { err_msg = ["_ZeroRaisedToNegativePower"];
1581 err_ctx = ctx }) (*error*)
1582 | Integer 0l, Integer _ ->
1583 (* We know the answer for sure since second argument is constant *)
1585 | (Integer 0l | Real 0.), (Integer _ | Real _) -> Real 0.
1586 | Integer i, Real _ when Int32.compare i 0l < 0 ->
1588 { err_msg = ["_RealExponentOfNegativeNumber"];
1590 err_ctx = ctx }) (*error*)
1591 | Real f, Real _ when f < 0. ->
1593 { err_msg = ["_RealExponentOfNegativeNumber"];
1595 err_ctx = ctx }) (*error*)
1596 | Integer i, Integer i' ->
1597 Real ((Int32.to_float i) ** (Int32.to_float i'))
1598 | Integer i, Real f -> Real ((Int32.to_float i) ** f)
1599 | Real f, Integer i' -> Real (f ** (Int32.to_float i'))
1600 | Real f, Real f' -> Real (f ** f')
1601 | Vector exprs, Integer i ->
1603 { err_msg = ["_NotYetImplemented";
1604 "_VectorRaisedToIntegerPower"];
1607 | _ -> BinaryOperation (Power, expr, expr')
1609 and evaluate_minus expr expr' = match expr, expr' with
1610 | Integer 0l, _ -> evaluate_unary_minus expr'
1611 | _, Integer 0l -> expr
1612 | Integer i, Integer i' -> Integer (Int32.sub i i')
1613 | Integer i, Real f -> Real (Int32.to_float i -. f)
1614 | Real f, Integer i -> Real (f -. Int32.to_float i)
1615 | Real f, Real f' -> Real (f -. f')
1616 | Vector exprs, Vector exprs' ->
1617 Vector (ArrayExt.map2 evaluate_minus exprs exprs')
1618 | _ -> BinaryOperation (Minus, expr, expr')
1620 and evaluate_class_function_invocation cl_def exprs =
1621 FunctionCall (ClassReference cl_def, exprs)
1623 and evaluate_predefined_function_invocation ctx s exprs =
1625 | "size", _ -> evaluate_size exprs
1626 | "reinit", [expr; expr'] -> evaluate_reinit expr expr'
1627 | "der", [expr] -> evaluate_der expr
1628 | "pre", [expr] -> evaluate_pre expr
1629 | ("edge" | "change" | "initial" | "terminal" | "sample" |
1630 "delay" | "assert" | "terminate"), _ ->
1632 { err_msg = ["_NotYetImplemented"; "_PredefinedOperator"; s];
1634 err_ctx = ctx}) (*error*)
1635 | "abs", [expr] -> evaluate_abs expr
1636 | "sign", [expr] -> evaluate_sign expr
1637 | "cos", [expr] -> evaluate_cos expr
1638 | "sin", [expr] -> evaluate_sin expr
1639 | "tan", [expr] -> evaluate_tan expr
1640 | "exp", [expr] -> evaluate_exp expr
1641 | "log", [expr] -> evaluate_log expr
1642 | "sqrt", [expr] -> evaluate_sqrt expr
1643 | "asin", [expr] -> evaluate_asin expr
1644 | "acos", [expr] -> evaluate_acos expr
1645 | "atan", [expr] -> evaluate_atan expr
1646 | "sinh", [expr] -> evaluate_sinh expr
1647 | "cosh", [expr] -> evaluate_cosh expr
1648 | "tanh", [expr] -> evaluate_tanh expr
1649 | "asinh", [expr] -> evaluate_asinh expr
1650 | "acosh", [expr] -> evaluate_acosh expr
1651 | "atanh", [expr] -> evaluate_atanh expr
1652 | "log10", [expr] -> evaluate_log10 expr
1653 | "max", [expr; expr'] -> evaluate_max expr expr'
1654 | "min", [expr; expr'] -> evaluate_min expr expr'
1655 | "div", [expr; expr'] -> evaluate_div ctx expr expr'
1656 | "mod", [expr; expr'] -> evaluate_mod expr expr'
1657 | "rem", [expr; expr'] -> evaluate_rem expr expr'
1658 | "ceil", [expr] -> evaluate_ceil expr
1659 | "floor", [expr] -> evaluate_floor expr
1660 | "max", [expr] -> evaluate_max_array expr
1661 | "min", [expr] -> evaluate_min_array expr
1662 | "sum", [expr] -> evaluate_sum expr
1663 | "product", [expr] -> evaluate_product expr
1664 | "scalar", [expr] -> evaluate_scalar ctx expr
1665 | "ones", exprs -> evaluate_ones ctx exprs
1666 | "zeros", exprs -> evaluate_zeros ctx exprs
1667 | "fill", expr :: exprs -> evaluate_fill ctx expr exprs
1668 | "identity", [expr] -> evaluate_identity ctx expr
1669 | "diagonal", [expr] -> evaluate_diagonal ctx expr
1670 | "vector", [ expr ] -> evaluate_vector_operator ctx expr
1671 | "matrix", [ expr ] -> evaluate_matrix_operator ctx expr
1672 | "transpose", [ expr ] -> evaluate_transpose expr
1673 | "symmetric", [ expr ] -> evaluate_symmetric ctx expr
1676 { err_msg = ["_UnknownFunction"; s];
1678 err_ctx = ctx}) (*error*)
1680 and evaluate_symmetric ctx expr = match expr with
1681 | Vector [||] -> assert false
1682 | Vector exprs when size exprs.(0) 0 <> Array.length exprs ->
1684 { err_msg = ["_InvalidArgOfOper"; "symmetric"];
1686 err_ctx = ctx }) (*error*)
1689 if i > j then element i (element j expr)
1690 else element j (element i expr) in
1691 let n = Array.length exprs in
1692 let g i = Vector (Array.init n (f i)) in
1693 Vector (Array.init n g)
1696 and evaluate_transpose expr =
1699 let f i = Vector (Array.map (element i) exprs) in
1700 Vector (Array.init (size expr 1) f)
1703 and evaluate_matrix_operator ctx expr =
1704 let rec scalar expr = match expr with
1705 | Vector [| expr |] -> scalar expr
1708 { err_msg = ["_InvalidArgOfOper"; "matrix"];
1710 err_ctx = ctx }) (*error*)
1713 | _ when ndims expr < 2 ->
1714 evaluate_promote ctx 2 expr
1715 | _ when ndims expr = 2 -> expr
1717 let f expr = Vector (Array.map scalar (array_elements expr)) in
1718 Vector (Array.map f exprs)
1721 and evaluate_promote ctx n expr =
1722 let rec evaluate_promote' i expr =
1724 | _ when i = 0 -> expr
1725 | Vector exprs when i > 0 ->
1726 Vector (Array.map (evaluate_promote' i) exprs)
1728 Vector [| evaluate_promote' (i - 1) expr |]
1729 | _ -> assert false in
1730 match ndims expr with
1732 evaluate_promote' (n - n') expr
1735 and evaluate_vector_operator ctx expr =
1736 let rec evaluate_scalar expr = match expr with
1737 | Vector [| expr |] -> evaluate_scalar expr
1740 { err_msg = ["_InvalidArgOfOper"; "vector"];
1742 err_ctx = ctx }) (*error*)
1744 and evaluate_vector_operator' expr = match expr with
1745 | Vector [| expr |] -> evaluate_vector_operator' expr
1747 Array.map evaluate_scalar exprs
1748 | _ -> [| expr |] in
1749 Vector (evaluate_vector_operator' expr)
1751 and evaluate_max_array expr =
1752 let rec evaluate_max_list exprs = match exprs with
1753 | [] -> assert false
1756 evaluate_max expr (evaluate_max_list exprs) in
1757 evaluate_max_list (scalar_elements expr)
1759 and evaluate_min_array expr =
1760 let rec evaluate_min_list exprs = match exprs with
1761 | [] -> assert false
1764 evaluate_min expr (evaluate_min_list exprs) in
1765 evaluate_min_list (scalar_elements expr)
1767 and evaluate_sum expr =
1768 let rec evaluate_sum_list exprs = match exprs with
1769 | [] -> Integer Int32.zero
1772 evaluate_plus expr (evaluate_sum_list exprs) in
1775 evaluate_sum_list (scalar_elements expr)
1778 and evaluate_product expr =
1779 let rec evaluate_product_list exprs = match exprs with
1780 | [] -> Integer Int32.one
1783 evaluate_times expr (evaluate_product_list exprs) in
1786 evaluate_product_list (scalar_elements expr)
1789 and evaluate_fill ctx expr exprs =
1790 let rec evaluate_fill' dims = match dims with
1792 | Integer i :: dims when Int32.compare i Int32.zero > 0 ->
1793 let i = Int32.to_int i in
1794 Vector (Array.make i (evaluate_fill' dims))
1797 { err_msg = ["_InvalidArgOfOper"; "fill"];
1799 err_ctx = ctx }) (*error*) in
1800 evaluate_fill' exprs
1802 and evaluate_zeros ctx exprs =
1803 let rec evaluate_zeros' dims = match dims with
1804 | [] -> Integer Int32.zero
1805 | Integer i :: dims when Int32.compare i Int32.zero > 0 ->
1806 let i = Int32.to_int i in
1807 Vector (Array.make i (evaluate_zeros' dims))
1810 { err_msg = ["_InvalidArgOfOper"; "zeros"];
1812 err_ctx = ctx }) (*error*) in
1813 evaluate_zeros' exprs
1815 and evaluate_ones ctx exprs =
1816 let rec evaluate_ones' dims = match dims with
1817 | [] -> Integer Int32.one
1818 | Integer i :: dims when Int32.compare i Int32.zero > 0 ->
1819 let i = Int32.to_int i in
1820 Vector (Array.make i (evaluate_ones' dims))
1823 { err_msg = ["_InvalidArgOfOper"; "ones"];
1825 err_ctx = ctx }) (*error*) in
1826 evaluate_ones' exprs
1828 and evaluate_identity ctx expr =
1829 let n = match expr with
1830 | Integer i when Int32.compare i Int32.zero > 0 ->
1834 { err_msg = ["_InvalidArgOfOper"; "identity"];
1836 err_ctx = ctx }) (*error*) in
1838 Integer (if j = i then Int32.one else Int32.zero) in
1839 let g i = Vector (Array.init n (f i)) in
1840 Vector (Array.init n g)
1842 and evaluate_diagonal ctx expr =
1843 let exprs = match expr with
1846 { err_msg = ["_InvalidArgOfOper"; "diagonal"];
1848 err_ctx = ctx }) (*error*)
1849 | Vector exprs -> exprs
1852 { err_msg = ["_InvalidArgOfOper"; "diagonal"];
1854 err_ctx = ctx }) (*error*) in
1855 let n = Array.length exprs in
1857 if j = i then exprs.(i) else Integer Int32.zero in
1858 let g i = Vector (Array.init n (f i)) in
1859 Vector (Array.init n g)
1861 and evaluate_scalar ctx expr =
1862 let rec evaluate_scalar' expr = match expr with
1863 | Vector [| expr |] -> evaluate_scalar' expr
1866 { err_msg = ["_InvalidArgOfOper"; "scalar"];
1868 err_ctx = ctx }) (*error*)
1871 | Vector [| expr |] -> evaluate_scalar' expr
1874 { err_msg = ["_InvalidArgOfOper"; "scalar"];
1876 err_ctx = ctx }) (*error*)
1878 and evaluate_reinit expr expr' = match expr, expr' with
1879 | Vector exprs, Vector exprs' ->
1880 Vector (ArrayExt.map2 evaluate_reinit exprs exprs')
1882 FunctionCall (PredefinedIdentifier "reinit", [ expr; expr' ])
1884 and evaluate_der expr = match expr with
1885 | Integer _ | String _ | Real _ -> Real 0.
1886 | Vector exprs -> Vector (Array.map evaluate_der exprs)
1887 | BinaryOperation (Plus, expr, expr') ->
1888 let expr = evaluate_der expr
1889 and expr' = evaluate_der expr' in
1890 BinaryOperation (Plus, expr, expr')
1891 | BinaryOperation (Minus, expr, expr') ->
1892 let expr = evaluate_der expr
1893 and expr' = evaluate_der expr' in
1894 BinaryOperation (Minus, expr, expr')
1895 | BinaryOperation (Times, expr1, expr2) ->
1896 let expr1' = evaluate_der expr1
1897 and expr2' = evaluate_der expr2 in
1898 let expr1 = BinaryOperation (Times, expr1', expr2)
1899 and expr2 = BinaryOperation (Times, expr1, expr2') in
1900 BinaryOperation (Plus, expr1, expr2)
1901 | BinaryOperation (Divide, expr1, expr2) ->
1902 let expr1' = evaluate_der expr1
1903 and expr2' = evaluate_der expr2 in
1904 let expr1' = BinaryOperation (Times, expr1', expr2)
1905 and expr2' = BinaryOperation (Times, expr1, expr2') in
1906 let expr1 = BinaryOperation (Minus, expr1', expr2')
1907 and expr2 = BinaryOperation (Times, expr2, expr2) in
1908 BinaryOperation (Divide, expr1, expr2)
1909 | BinaryOperation (Power, expr, Integer i) ->
1910 let expr' = evaluate_der expr
1911 and j = Int32.sub i Int32.one in
1912 let expr' = BinaryOperation (Times, Integer i, expr')
1913 and expr = BinaryOperation (Power, expr, Integer j) in
1914 BinaryOperation (Times, expr', expr)
1915 | BinaryOperation (Power, expr, Real f) ->
1916 let expr' = evaluate_der expr
1918 let expr' = BinaryOperation (Times, Real f, expr')
1919 and expr = BinaryOperation (Power, expr, Real f') in
1920 BinaryOperation (Times, expr', expr)
1921 | FunctionCall (PredefinedIdentifier "cos", [ expr ]) ->
1922 let expr' = evaluate_der expr
1923 and expr = FunctionCall (PredefinedIdentifier "sin", [ expr ]) in
1924 let expr = UnaryOperation (UnaryMinus, expr) in
1925 BinaryOperation (Times, expr', expr)
1926 | FunctionCall (PredefinedIdentifier "sin", [ expr ]) ->
1927 let expr' = evaluate_der expr
1928 and expr = FunctionCall (PredefinedIdentifier "cos", [ expr ]) in
1929 BinaryOperation (Times, expr', expr)
1930 | FunctionCall (PredefinedIdentifier "tan", [ expr1 ]) ->
1931 let expr1' = evaluate_der expr1
1932 and expr = BinaryOperation (Times, expr, expr) in
1933 let expr = BinaryOperation (Plus, Real 1., expr) in
1934 BinaryOperation (Times, expr1', expr)
1935 | FunctionCall (PredefinedIdentifier "exp", [ expr1 ]) ->
1936 let expr1' = evaluate_der expr1 in
1937 BinaryOperation (Times, expr1', expr)
1938 | FunctionCall (PredefinedIdentifier "log", [ expr1 ]) ->
1939 let expr1' = evaluate_der expr1 in
1940 BinaryOperation (Divide, expr1', expr)
1941 | FunctionCall (PredefinedIdentifier "sqrt", [ expr1 ]) ->
1942 evaluate_der (BinaryOperation (Power, expr1, Real 0.5))
1943 | FunctionCall (PredefinedIdentifier "asin", [ expr1 ]) ->
1944 let expr1' = evaluate_der expr1 in
1945 let expr1 = BinaryOperation (Times, expr1, expr1) in
1946 let expr1 = BinaryOperation (Minus, Real 1., expr1) in
1947 let expr1 = FunctionCall (PredefinedIdentifier "sqrt", [ expr1 ]) in
1948 BinaryOperation (Divide, expr1', expr1)
1949 | FunctionCall (PredefinedIdentifier "acos", [ expr1 ]) ->
1950 let expr1' = UnaryOperation (UnaryMinus, evaluate_der expr1) in
1951 let expr1 = BinaryOperation (Times, expr1, expr1) in
1952 let expr1 = BinaryOperation (Minus, Real 1., expr1) in
1953 let expr1 = FunctionCall (PredefinedIdentifier "sqrt", [ expr1 ]) in
1954 BinaryOperation (Divide, expr1', expr1)
1955 | FunctionCall (PredefinedIdentifier "atan", [ expr1 ]) ->
1956 let expr1' = evaluate_der expr1 in
1957 let expr1 = BinaryOperation (Times, expr1, expr1) in
1958 let expr1 = BinaryOperation (Plus, Real 1., expr1) in
1959 BinaryOperation (Divide, expr1', expr1)
1960 | FunctionCall (PredefinedIdentifier "sinh", [ expr1 ]) ->
1961 let expr1' = evaluate_der expr1 in
1962 let expr1 = FunctionCall (PredefinedIdentifier "cosh", [ expr1 ]) in
1963 BinaryOperation (Times, expr1', expr1)
1964 | FunctionCall (PredefinedIdentifier "cosh", [ expr1 ]) ->
1965 let expr1' = evaluate_der expr1 in
1966 let expr1 = FunctionCall (PredefinedIdentifier "sinh", [ expr1 ]) in
1967 BinaryOperation (Times, expr1', expr1)
1968 | FunctionCall (PredefinedIdentifier "tanh", [ expr1 ]) ->
1969 let expr1' = evaluate_der expr1 in
1970 let expr1 = BinaryOperation (Times, expr, expr) in
1971 let expr1 = BinaryOperation (Minus, Real 1., expr1) in
1972 BinaryOperation (Times, expr1', expr1)
1973 | FunctionCall (PredefinedIdentifier "asinh", [ expr1 ]) ->
1974 let expr1' = evaluate_der expr1 in
1975 let expr1 = BinaryOperation (Times, expr1, expr1) in
1976 let expr1 = BinaryOperation (Plus, Real 1., expr1) in
1977 let expr1 = FunctionCall (PredefinedIdentifier "sqrt", [ expr1 ]) in
1978 BinaryOperation (Divide, expr1', expr1)
1979 | FunctionCall (PredefinedIdentifier "acosh", [ expr1 ]) ->
1980 let expr1' = evaluate_der expr1 in
1981 let expr1 = BinaryOperation (Times, expr1, expr1) in
1982 let expr1 = BinaryOperation (Minus, expr1, Real 1.) in
1983 let expr1 = FunctionCall (PredefinedIdentifier "sqrt", [ expr1 ]) in
1984 BinaryOperation (Divide, expr1', expr1)
1985 | FunctionCall (PredefinedIdentifier "atanh", [ expr1 ]) ->
1986 let expr1' = evaluate_der expr1 in
1987 let expr1 = BinaryOperation (Times, expr1, expr1) in
1988 let expr1 = BinaryOperation (Minus, expr1, Real 1.) in
1989 BinaryOperation (Divide, expr1', expr1)
1990 | FunctionCall (PredefinedIdentifier "log10", [ expr1 ]) ->
1991 let expr1 = FunctionCall (PredefinedIdentifier "log", [ expr1 ]) in
1992 BinaryOperation (Divide, evaluate_der expr1, Real (log 10.))
1994 (PredefinedIdentifier ("div" | "mod" | "rem" | "ceil" | "floor"), _) ->
1996 | If (alts, default) ->
1998 List.map (function (cond, expr) -> (cond, evaluate_der expr)) alts in
1999 If (alts', evaluate_der default)
2000 | NoEvent expr -> NoEvent (evaluate_der expr)
2001 | UnaryOperation (UnaryMinus, expr) ->
2002 UnaryOperation (UnaryMinus, evaluate_der expr)
2003 | VectorReduction (exprs, expr) ->
2004 VectorReduction (exprs, evaluate_der expr)
2005 | _ -> FunctionCall (PredefinedIdentifier "der", [ expr ])
2007 and evaluate_pre expr = match expr with
2009 Vector (Array.map evaluate_pre exprs)
2011 FunctionCall (PredefinedIdentifier "pre", [ expr ])
2013 and evaluate_cos expr = match expr with
2015 Vector (Array.map evaluate_cos exprs)
2017 FunctionCall (PredefinedIdentifier "cos", [ expr ])
2019 and evaluate_sin expr = match expr with
2021 Vector (Array.map evaluate_sin exprs)
2023 FunctionCall (PredefinedIdentifier "sin", [ expr ])
2025 and evaluate_tan expr = match expr with
2027 Vector (Array.map evaluate_tan exprs)
2029 FunctionCall (PredefinedIdentifier "tan", [ expr ])
2031 and evaluate_exp expr = match expr with
2033 Vector (Array.map evaluate_exp exprs)
2035 FunctionCall (PredefinedIdentifier "exp", [ expr ])
2037 and evaluate_log expr = match expr with
2039 Vector (Array.map evaluate_log exprs)
2041 FunctionCall (PredefinedIdentifier "log", [ expr ])
2043 and evaluate_sqrt expr = match expr with
2045 Vector (Array.map evaluate_sqrt exprs)
2047 FunctionCall (PredefinedIdentifier "sqrt", [ expr ])
2049 and evaluate_asin expr = match expr with
2051 Vector (Array.map evaluate_asin exprs)
2053 FunctionCall (PredefinedIdentifier "asin", [ expr ])
2055 and evaluate_acos expr = match expr with
2057 Vector (Array.map evaluate_acos exprs)
2059 FunctionCall (PredefinedIdentifier "acos", [ expr ])
2061 and evaluate_atan expr = match expr with
2063 Vector (Array.map evaluate_atan exprs)
2065 FunctionCall (PredefinedIdentifier "atan", [ expr ])
2067 and evaluate_sinh expr = match expr with
2069 Vector (Array.map evaluate_sinh exprs)
2071 FunctionCall (PredefinedIdentifier "sinh", [ expr ])
2073 and evaluate_cosh expr = match expr with
2075 Vector (Array.map evaluate_cosh exprs)
2077 FunctionCall (PredefinedIdentifier "cosh", [ expr ])
2079 and evaluate_tanh expr = match expr with
2081 Vector (Array.map evaluate_tanh exprs)
2083 FunctionCall (PredefinedIdentifier "tanh", [ expr ])
2085 and evaluate_asinh expr = match expr with
2087 Vector (Array.map evaluate_asinh exprs)
2089 FunctionCall (PredefinedIdentifier "asinh", [ expr ])
2091 and evaluate_acosh expr = match expr with
2093 Vector (Array.map evaluate_acosh exprs)
2095 FunctionCall (PredefinedIdentifier "acosh", [ expr ])
2097 and evaluate_atanh expr = match expr with
2099 Vector (Array.map evaluate_atanh exprs)
2101 FunctionCall (PredefinedIdentifier "atanh", [ expr ])
2103 and evaluate_log10 expr = match expr with
2105 Vector (Array.map evaluate_log10 exprs)
2107 FunctionCall (PredefinedIdentifier "log10", [ expr ])
2109 and evaluate_max expr expr' = match expr, expr' with
2110 | Vector exprs, Vector exprs' ->
2111 Vector (ArrayExt.map2 evaluate_max exprs exprs')
2112 | Real f, Real f' -> Real (max f f')
2114 let b = BinaryOperation (GreaterEqual, expr, expr') in
2115 If ([b, expr], expr')
2117 and evaluate_min expr expr' = match expr, expr' with
2118 | Vector exprs, Vector exprs' ->
2119 Vector (ArrayExt.map2 evaluate_min exprs exprs')
2120 | Real f, Real f' -> Real (min f f')
2122 let b = BinaryOperation (GreaterEqual, expr', expr) in
2123 If ([b, expr], expr')
2125 and evaluate_abs expr = match expr with
2127 Vector (Array.map evaluate_abs exprs)
2128 | Real f -> Real (abs_float f)
2129 | Integer i -> Integer (Int32.abs i)
2131 let b = BinaryOperation (GreaterEqual, expr, Real 0.)
2132 and default = UnaryOperation (UnaryMinus, expr) in
2133 If ([b, expr], default)
2135 and evaluate_sign expr = match expr with
2137 Vector (Array.map evaluate_sign exprs)
2138 | Real f when f > 0. -> Real 1.
2139 | Real f when f < 0. -> Real (-. 1.)
2141 | Integer i when Int32.compare i Int32.zero > 0 ->
2143 | Integer i when Int32.compare i Int32.zero < 0 ->
2144 Integer Int32.minus_one
2145 | Integer _ -> Integer Int32.zero
2147 let b = BinaryOperation (Greater, expr, Real 0.)
2148 and b' = BinaryOperation (Greater, Real 0., expr) in
2149 If ([(b, Integer Int32.one); (b', Integer Int32.minus_one)],
2152 and evaluate_div ctx expr expr' = match expr, expr' with
2153 | Vector exprs, Vector exprs' ->
2154 Vector (ArrayExt.map2 (evaluate_div ctx) exprs exprs')
2157 { err_msg = ["_DivisionByZero"];
2159 err_ctx = ctx }) (*error*)
2160 | _, Integer i when i = Int32.zero ->
2162 { err_msg = ["_DivisionByZero"];
2164 err_ctx = ctx }) (*error*)
2165 | Integer i, Integer i' -> Integer (Int32.div i i')
2166 | Real f, Integer i' ->
2167 let f' = Int32.to_float i' in
2168 Real (float_of_int (truncate (f /. f')))
2169 | Integer i, Real f' ->
2170 let f = Int32.to_float i in
2171 Real (float_of_int (truncate (f /. f')))
2172 | Real f, Real f' ->
2173 Real (float_of_int (truncate (f /. f')))
2175 FunctionCall (PredefinedIdentifier "div", [ expr; expr' ])
2177 and evaluate_mod expr expr' = match expr, expr' with
2178 | Vector exprs, Vector exprs' ->
2179 Vector (ArrayExt.map2 evaluate_mod exprs exprs')
2181 FunctionCall (PredefinedIdentifier "mod", [ expr; expr' ])
2183 and evaluate_rem expr expr' = match expr, expr' with
2184 | Vector exprs, Vector exprs' ->
2185 Vector (ArrayExt.map2 evaluate_rem exprs exprs')
2187 FunctionCall (PredefinedIdentifier "rem", [ expr; expr' ])
2189 and evaluate_ceil expr = match expr with
2191 Vector (Array.map evaluate_ceil exprs)
2193 FunctionCall (PredefinedIdentifier "ceil", [ expr ])
2195 and evaluate_floor expr = match expr with
2197 Vector (Array.map evaluate_floor exprs)
2199 FunctionCall (PredefinedIdentifier "floor", [ expr ])
2201 and evaluate_size exprs =
2202 let rec evaluate_size' expr i = match expr, i with
2203 | ComponentReference cpnt_desc, _ ->
2204 evaluate_component_size cpnt_desc i
2205 | Vector exprs, 1 -> Integer (Int32.of_int (Array.length exprs))
2206 | Vector exprs, _ -> evaluate_size' exprs.(0) (i - 1)
2207 | _ -> assert false (*error*)
2208 and evaluate_component_size cpnt_desc i =
2209 match evaluate cpnt_desc.component_nature, i with
2210 | DynamicArray _, _ -> FunctionCall (PredefinedIdentifier "size", exprs)
2211 | StaticArray cpnt_descs, 1 ->
2212 Integer (Int32.of_int (Array.length cpnt_descs))
2213 | StaticArray cpnt_descs, _ ->
2214 evaluate_component_size cpnt_descs.(i) (i - 1)
2215 | _ -> assert false (*error*)
2216 and evaluate_size_list = function
2217 | ComponentReference cpnt_desc -> assert false
2219 let size = Integer (Int32.of_int (Array.length exprs)) in
2220 size :: evaluate_size_list exprs.(0)
2223 | [expr] -> Vector (Array.of_list (evaluate_size_list expr))
2224 | [expr; Integer i] -> evaluate_size' expr (Int32.to_int i)
2225 | [expr; _] -> FunctionCall (PredefinedIdentifier "size", exprs)
2226 | _ -> assert false (*error*)
2228 and evaluate_not expr = match expr with
2231 | Vector exprs -> Vector (Array.map evaluate_not exprs)
2232 | _ -> UnaryOperation (Not, expr)
2234 and evaluate_unary_minus expr = match expr with
2235 | Integer i -> Integer (Int32.neg i)
2236 | Real f -> Real (~-. f)
2237 | Vector exprs -> Vector (Array.map evaluate_unary_minus exprs)
2238 | _ -> UnaryOperation (UnaryMinus, expr)
2240 and field_access ctx expr id =
2241 let rec field_access' = function
2242 | ClassReference cl_def ->
2243 let cpnt_desc = create_temporary_instance ctx cl_def in
2244 component_field_access cpnt_desc
2245 | ComponentReference cpnt_desc -> component_field_access cpnt_desc
2246 | Record fields -> List.assoc id fields
2247 | Vector exprs -> Vector (Array.map field_access' exprs)
2248 | _ -> FieldAccess (expr, id)
2249 and component_field_access cpnt_desc =
2250 match evaluate cpnt_desc.component_nature with
2251 | DynamicArray _ -> FieldAccess (expr, id)
2252 | Instance inst -> instance_field_access ctx inst id
2253 | PredefinedTypeInstance _ ->
2255 { err_msg = ["_CannotAccessToPredefTypeAttrib"; id];
2257 err_ctx = ctx}) (*error*)
2258 | StaticArray cpnt_descs ->
2259 Vector (Array.map component_field_access cpnt_descs) in
2262 and instance_field_access ctx inst id =
2263 let evaluate_component cpnt_desc =
2264 let evaluate_declaration_equation = function
2265 | Some expr -> evaluate expr
2268 { err_msg = ["_MissingDeclEquForFixedId"; id];
2270 err_ctx = ctx}) (*error*) in
2271 let rec evaluate_parameter cpnt_desc =
2272 let evaluate_predefined_type_instance predef =
2273 match evaluate (List.assoc "fixed" predef.attributes) with
2274 | True -> evaluate_declaration_equation cpnt_desc.declaration_equation
2275 | False -> ComponentReference cpnt_desc
2276 | _ -> assert false (*error*) in
2277 match evaluate cpnt_desc.component_nature with
2278 | PredefinedTypeInstance predef
2279 when List.mem_assoc "fixed" predef.attributes ->
2280 evaluate_predefined_type_instance predef
2281 | DynamicArray cpnt_desc -> assert false
2282 | Instance _ -> ComponentReference cpnt_desc
2283 | PredefinedTypeInstance _ ->
2284 evaluate_declaration_equation cpnt_desc.declaration_equation
2285 | StaticArray cpnt_descs ->
2286 Vector (Array.map evaluate_parameter cpnt_descs)
2288 let decl_equ = cpnt_descs.(i).declaration_equation in
2289 evaluate_declaration_equation decl_equ in
2290 Vector (Array.init (Array.length cpnt_descs) f)*) in
2291 match cpnt_desc.variability with
2293 evaluate_declaration_equation cpnt_desc.declaration_equation
2294 | Types.Parameter -> evaluate_parameter cpnt_desc
2295 | _ -> ComponentReference cpnt_desc in
2296 let elts = evaluate inst.elements in
2297 let elt_desc = List.assoc id elts.named_elements in
2298 match evaluate elt_desc.element_nature with
2299 | Class cl_def -> ClassReference cl_def
2300 | Component cpnt_desc -> evaluate_component cpnt_desc
2302 and expression_location ctx expr =
2303 match expr.NameResolve.info.NameResolve.syntax with
2304 | None -> ctx.location
2305 | Some expr -> expr.Syntax.info
2307 and class_name_of_component cpnt_desc =
2308 let type_spec = Lazy.force cpnt_desc.NameResolve.type_specifier in
2309 let expr_info = type_spec.NameResolve.info in
2310 match expr_info.NameResolve.syntax with
2312 | Some expr -> Syntax.string_of_expression expr
2314 and instance_nature_of_element elt_desc =
2315 match elt_desc.NameResolve.element_nature with
2316 | NameResolve.Component cpnt_desc ->
2317 ComponentElement (class_name_of_component cpnt_desc)
2320 and instance_class_name instance_nature =
2321 match instance_nature with
2322 | ComponentElement s -> s
2323 | ClassElement -> ""
2325 and flatten_expression expr =
2326 let rec flatten_component cpnt_desc =
2327 match evaluate cpnt_desc.component_nature with
2328 | StaticArray cpnt_descs ->
2329 Vector (Array.map flatten_component cpnt_descs)
2330 | _ -> ComponentReference cpnt_desc in
2332 | ComponentReference cpnt_desc ->
2333 flatten_component cpnt_desc
2336 and size expr i = match expr, i with
2337 | Vector [||], _ -> 0
2338 | Vector exprs, 0 -> Array.length exprs
2339 | Vector exprs, _ when i > 0 -> size exprs.(0) (i - 1)
2340 | _ -> invalid_arg "_IndexOutOfBound"
2343 Array.init (ndims expr) (size expr)
2346 let rec ndims' i expr = match expr with
2347 | Vector [||] -> i + 1
2348 | Vector exprs -> ndims' (i + 1) exprs.(0)
2352 and element i expr = match expr with
2353 | Vector exprs -> exprs.(i)
2356 and array_elements expr = match expr with
2357 | Vector exprs -> exprs
2360 and scalar_elements expr = match expr with
2363 Array.to_list (Array.map scalar_elements exprs) in
2369 and generate_expression oc = function
2370 | BinaryOperation (bin_op, expr, expr') ->
2371 generate_binary_operation oc bin_op expr expr'
2372 | ClassReference cl_def ->
2373 generate_class_reference oc cl_def
2374 | ComponentReference cpnt_desc ->
2375 generate_component_reference oc cpnt_desc
2376 | EnumerationElement _ -> assert false
2377 | False -> assert false
2378 | FieldAccess _ -> assert false
2379 | FunctionCall (expr, exprs) ->
2380 generate_function_call oc expr exprs
2381 | If (alts, expr) -> generate_if oc alts expr
2382 | IndexedAccess _ -> assert false
2383 | Integer i when Int32.to_int i >= 0 ->
2384 Printf.fprintf oc "%ld" i
2386 let expr = Integer (Int32.neg i)
2387 and un_op = UnaryMinus in
2388 generate_unary_operation oc un_op expr
2389 | LoopVariable _ -> Printf.fprintf oc "LoopVariable"
2390 | NoEvent expr -> generate_no_event oc expr
2391 | PredefinedIdentifier id -> Printf.fprintf oc "%s" id
2392 | Range _ -> Printf.fprintf oc "Range"
2394 Printf.fprintf oc "%s" (string_of_float f)
2395 | Record _ -> Printf.fprintf oc "Record"
2396 | String _ -> Printf.fprintf oc "String"
2397 | True -> Printf.fprintf oc "True"
2398 | Tuple _ -> Printf.fprintf oc "Tuple"
2399 | UnaryOperation (un_op, expr) ->
2400 generate_unary_operation oc un_op expr
2402 generate_vector oc exprs
2403 | VectorReduction _ -> Printf.fprintf oc "VectorReduction"
2405 and generate_binary_operation oc bin_op expr expr' =
2406 let string_of_binary_operation_kind = function
2409 | EqualEqual -> "=="
2410 | GreaterEqual -> ">="
2420 Printf.fprintf oc "(";
2421 generate_expression oc expr;
2422 Printf.fprintf oc " %s " (string_of_binary_operation_kind bin_op);
2423 generate_expression oc expr';
2424 Printf.fprintf oc ")"
2426 and generate_class_reference oc cl_def =
2427 let rec last = function
2428 | [] -> assert false
2430 | [Index _] -> assert false
2431 | _ :: path -> last path in
2432 let generate_external_call ext_call =
2433 match ext_call.NameResolve.nature with
2434 | NameResolve.PrimitiveCall "builtin" ->
2435 Printf.fprintf oc "builtin"
2436 | NameResolve.PrimitiveCall "C" ->
2437 Printf.fprintf oc "PrimitiveCall"
2438 | NameResolve.PrimitiveCall lang -> assert false
2439 | NameResolve.ExternalProcedureCall _ -> assert false in
2440 let generate_long_dscription long_desc =
2441 match evaluate long_desc.NameResolve.external_call with
2442 | None -> assert false
2443 | Some ext_call -> generate_external_call ext_call in
2444 match cl_def.description with
2445 | ClassDescription (_, cl_desc) ->
2446 generate_long_dscription cl_desc.long_description
2447 | PredefinedType _ -> assert false
2449 and generate_component_reference oc cpnt_desc =
2450 let name = ident_of_path cpnt_desc.component_path in
2451 Printf.fprintf oc "%s" name
2453 and generate_function_call oc expr exprs =
2454 generate_expression oc expr;
2455 Printf.fprintf oc "(";
2456 generate_expressions oc exprs;
2457 Printf.fprintf oc ")"
2459 and generate_expressions oc = function
2461 | [expr] -> generate_expression oc expr;
2463 generate_expression oc expr;
2464 Printf.fprintf oc ", ";
2465 generate_expressions oc exprs
2467 and generate_if oc alts expr =
2468 let rec generate_alternatives = function
2469 | [] -> Printf.fprintf oc " "; generate_expression oc expr
2470 | (expr, expr') :: alts ->
2471 Printf.fprintf oc "(if ";
2472 generate_expression oc expr;
2473 Printf.fprintf oc " then ";
2474 generate_expression oc expr';
2475 Printf.fprintf oc " else";
2476 generate_alternatives alts;
2477 Printf.fprintf oc ")" in
2478 generate_alternatives alts
2480 and generate_no_event oc expr =
2481 Printf.fprintf oc "noEvent(";
2482 generate_expression oc expr;
2483 Printf.fprintf oc ")"
2485 and generate_unary_operation oc un_op expr =
2486 let string_of_unary_operation_kind = function
2488 | UnaryMinus -> "-" in
2489 Printf.fprintf oc "(%s " (string_of_unary_operation_kind un_op);
2490 generate_expression oc expr;
2491 Printf.fprintf oc ")"
2493 and generate_vector oc exprs =
2494 let exprs' = Array.to_list exprs in
2495 Printf.fprintf oc "{ ";
2496 generate_expressions oc exprs';
2497 Printf.fprintf oc " }"
2500 let rec last_id' id path = match path with
2502 | (Name id) :: path -> last_id' id path
2503 | (Index _) :: path -> last_id' id path in
2506 and string_of_float f =
2507 let add_parenthesis s =
2508 if String.contains s '-' then Printf.sprintf "(%s)" s else s in
2509 match Printf.sprintf "%.16g" f with
2510 | s when (String.contains s '.') || (String.contains s 'e') ->
2512 | s -> add_parenthesis (Printf.sprintf "%s." s)
2514 and ident_of_path path =
2515 let rec ident_of_path' path =
2517 | [] -> assert false
2519 | [Index i] -> Printf.sprintf "[%d]" (i + 1)
2520 | Name id :: path ->
2521 Printf.sprintf "%s.%s" id (ident_of_path' path)
2522 | Index i :: path ->
2523 Printf.sprintf "[%d].%s" (i + 1) (ident_of_path' path) in
2525 | [] -> assert false
2526 | [Name id] -> assert false
2527 | [Index i] -> assert false
2528 | Name id :: path ->
2529 Printf.sprintf "`%s`" (ident_of_path' path)
2530 | Index i :: path -> assert false