end of line
[scilab.git] / scilab / modules / scicos / src / translator / instantiation / instantiation.ml
1 (*
2  *  Translator from Modelica 2.x to flat Modelica
3  *
4  *  Copyright (C) 2005 - 2007 Imagine S.A.
5  *  For more information or commercial use please contact us at www.amesim.com
6  *
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.
11  *
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.
16  *
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.
20  *
21  *)
22
23 type ('a, 'b) node =
24   {
25     nature: 'a;
26     info: 'b
27   }
28
29 type instance =
30   {
31     enclosing_instance: instance option;
32     kind: Types.kind;
33     elements: instance_elements Lazy.t
34   }
35
36 and instance_elements =
37   {
38     named_elements: (string * element_description) list;
39     unnamed_elements: equation_or_algorithm_clause list
40   }
41
42 and element_description =
43   {
44     redeclare: bool;
45     element_nature: element_nature Lazy.t
46   }
47
48 and element_nature =
49   | Class of class_definition
50   | Component of component_description
51
52 and class_definition =
53   {
54     class_type: Types.class_specifier;
55     class_path: path;
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
62   }
63
64 and path = path_element list
65
66 and path_element =
67   | Name of string
68   | Index of int
69
70 and description =
71   | ClassDescription of context * class_description
72   | PredefinedType of predefined_type
73
74 and class_description =
75   {
76     class_kind: Types.kind;
77     class_annotations: (annotation list) Lazy.t;
78     long_description: NameResolve.long_description
79   }
80
81 and annotation =
82   | InverseFunction of inverse_function Lazy.t
83   | UnknownAnnotation of Parser.location Syntax.class_modification Lazy.t
84
85 and inverse_function =
86   {
87     function_class: class_definition;
88     arguments: (string * string) list
89   }
90
91 and class_modification = (string * modification_argument) list
92
93 and modification_argument =
94   {
95     each: bool;
96     action: modification_action
97   }
98
99 and modification_action =
100   | ElementModification of modification
101   | ElementRedeclaration of element_description
102
103 and modification =
104   | Modification of class_modification * expression Lazy.t option
105   | Assignment of expression Lazy.t
106   | Equality of expression Lazy.t
107
108 and component_description =
109   {
110     component_path: path;
111     flow: bool;
112     variability: Types.variability;
113     causality: Types.causality;
114     component_nature: component_nature Lazy.t;
115     declaration_equation: expression Lazy.t option;
116     comment: string;
117     component_location: Parser.location;
118     class_name: string
119   }
120
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
127
128 and predefined_type_instance =
129   {
130     predefined_type: predefined_type;
131     attributes: (string * expression Lazy.t) list
132   }
133
134 and predefined_type =
135   | BooleanType
136   | IntegerType
137   | RealType
138   | StringType
139   | EnumerationType
140
141 and equation_or_algorithm_clause =
142   | EquationClause of NameResolve.validity * equation list Lazy.t
143   | AlgorithmClause of NameResolve.validity * algorithm list Lazy.t
144
145 and validity = Initial | Permanent
146
147 and equation = (equation_desc list, NameResolve.equation) node
148
149 and equation_desc =
150   | Equal of expression * expression
151   | ConditionalEquationE of (expression * equation list) list *
152       equation list
153   | ConnectFlows of NameResolve.sign * expression *
154       NameResolve.sign * expression
155   | WhenClauseE of (expression * equation list) list
156
157 and algorithm = (algorithm_desc list, NameResolve.algorithm) node
158
159 and algorithm_desc =
160   | Assign of expression * expression
161   | FunctionCallA of expression * expression list
162   | MultipleAssign of expression list * expression * expression list
163   | Break
164   | Return
165   | ConditionalEquationA of (expression * algorithm list) list *
166       algorithm list
167   | ForClauseA of expression (* range *) * algorithm list
168   | WhileClause of expression * algorithm list
169   | WhenClauseA of (expression * algorithm list) list
170
171 and expression =
172   | BinaryOperation of binary_operator_kind * expression * expression
173   | ClassReference of class_definition
174   | ComponentReference of component_description
175   | EnumerationElement of string
176   | False
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 *)
182   | Integer of int32
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
187   | Real of float
188   | Record of (string * expression) list
189   | String of string
190   | True
191   | Tuple of expression list
192   | UnaryOperation of unary_operator_kind * expression
193   | Vector of expression array
194   | VectorReduction of expression list (* ranges *) * expression
195
196 and unary_operator_kind =
197   | Not
198   | UnaryMinus
199
200 and binary_operator_kind =
201   | And
202   | Divide
203   | EqualEqual
204   | GreaterEqual
205   | Greater
206   | LessEqual
207   | Less
208   | Times
209   | NotEqual
210   | Or
211   | Plus
212   | Power
213   | Minus
214
215 and context =
216   {
217     toplevel: (string * element_description) list Lazy.t;
218     path: path;
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
227   }
228
229 and context_nature =
230   | ToplevelContext
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
235
236 (* Error description *)
237 and error_description =
238   {
239     err_msg: string list;
240     err_info: (string * string) list;
241     err_ctx: context
242   }
243
244 and instance_nature =
245   | ClassElement
246   | ComponentElement of string
247
248 exception InstantError of error_description
249
250
251 (* Utilities *)
252
253 let levels = ref 0
254
255 let spaces () = for i = 1 to !levels do Printf.printf "  " done
256
257 let nest i =
258   spaces (); Printf.printf "ForContext %ld\n" i;
259   incr levels
260
261 let nest2 i =
262   spaces (); Printf.printf "ReductionContext %ld\n" i;
263   incr levels
264
265 let unnest () =
266   decr levels;
267   spaces (); Printf.printf "Leaving ForContext\n"
268
269 let evaluate x = Lazy.force x
270
271 module ArrayExt =
272   struct
273     let map2 f a a' =
274       let l = Array.length a
275       and l' = Array.length a' in
276       if l <> l' then invalid_arg "ArrayExt.map2"
277       else begin
278         let create_array i = f a.(i) a'.(i) in
279         Array.init l create_array
280       end
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"
285       else begin
286         let rec for_all2' i =
287           i = l || (f a.(i) a'.(i) && for_all2' (i + 1)) in
288         for_all2' 0
289       end
290     let exists2 f a a' =
291       let l = Array.length a
292       and l' = Array.length a' in
293       if l <> l' then invalid_arg "ArrayExt.exists2"
294       else begin
295         let rec exists2' i =
296           i < l && (f a.(i) a'.(i) || exists2' (i + 1)) in
297         exists2' 0
298       end
299   end
300
301
302 (* Instantiation functions *)
303
304 let rec evaluate_toplevel_definitions dic defs =
305   let rec ctx =
306     {
307       toplevel = lazy (dic @ evaluate defs');
308       path = [];
309       context_flow = None;
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
317     }
318   and defs' = lazy (List.map (evaluate_toplevel_definition ctx) defs) in
319   evaluate defs'
320
321 and evaluate_toplevel_definition ctx (id, elt_desc) =
322   let elt_loc = [Name id] in
323   let ctx = {ctx with
324                path = elt_loc;
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
328   let elt_desc' =
329     {
330       redeclare = false;
331       element_nature = lazy (evaluate_toplevel_element ctx elt_loc elt_nat)
332     } in
333   id, elt_desc'
334
335 and evaluate_toplevel_element ctx elt_loc = function
336   | NameResolve.Component cpnt_desc ->
337       let cpnt_desc' =
338         instantiate_component_description ctx [] None elt_loc cpnt_desc in
339       Component cpnt_desc'
340   | NameResolve.Class cl_def ->
341       let cl_def' = evaluate_class_definition ctx [] elt_loc cl_def in
342       Class cl_def'
343   | NameResolve.ComponentType _ ->
344       raise (InstantError
345         { err_msg = ["_NotYetImplemented"; "_ComponentTypeElemInstant"];
346           err_info = [];
347           err_ctx = ctx }) (*error*)
348   | NameResolve.PredefinedType _ ->
349       raise (InstantError
350         { err_msg = ["_NotYetImplemented"; "_PredefinedTypeElemInstant"];
351           err_info = [];
352           err_ctx = ctx }) (*error*)
353
354 and instantiate_class_description ctx modifs rhs elt_loc cl_desc =
355   let elements inst =
356     let ctx' =
357       { ctx with
358         toplevel = lazy (evaluate ctx.toplevel);
359         path = elt_loc;
360         parent_context = Some ctx;
361         class_context = InstanceContext inst;
362         instance_context = None
363       } in
364     instantiate_class_elements ctx' modifs rhs cl_desc.long_description in
365   let rec inst =
366     {
367       enclosing_instance = enclosing_instance ctx;
368       kind = cl_desc.class_kind;
369       elements = lazy (elements inst)
370     } in
371   inst
372
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'
378
379 and instantiate_class_elements ctx modifs rhs long_desc =
380   let rec merge_elements named_elts unnamed_elts = function
381     | [] ->
382         {
383           named_elements = named_elts;
384           unnamed_elements = unnamed_elts
385         }
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
397
398 and instantiate_local_named_elements ctx modifs rhs named_elts =
399   List.fold_right (instantiate_local_named_element ctx modifs rhs) named_elts []
400
401 and instantiate_local_named_element ctx modifs rhs (id, elt_desc) named_elts =
402   let rec filter_current_element_modifications = function
403     | [] -> []
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
408     | None -> None
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
413   let ctx = {ctx with
414                path = elt_loc;
415                location = elt_desc.NameResolve.element_location;
416                instance_nature = instance_nature_of_element elt_desc} in
417   let elt_nat =
418     lazy (instantiate_local_element_nature ctx modifs' rhs' elt_loc elt_desc) in
419   let named_elt =
420     id,
421     {
422       redeclare = elt_desc.NameResolve.redeclare;
423       element_nature = elt_nat
424     } in
425   named_elt :: named_elts
426
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 ->
430         let cpnt_desc' =
431           instantiate_component_description ctx modifs rhs elt_loc cpnt_desc in
432        Component cpnt_desc'
433     | NameResolve.Class cl_def ->
434         let cl_def' = evaluate_class_definition ctx modifs elt_loc cl_def in
435         Class cl_def'
436     | NameResolve.ComponentType _ ->
437         raise (InstantError
438           { err_msg = ["_NotYetImplemented"; "_ComponentTypeElemInstant"];
439             err_info = [];
440             err_ctx = ctx })
441     | NameResolve.PredefinedType _ ->
442         raise (InstantError
443           { err_msg = ["_NotYetImplemented"; "_PredefinedTypeElemInstant"];
444             err_info = [];
445             err_ctx = ctx })
446
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
455     | None -> modifs
456     | Some modif ->
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
461
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
466
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
477     let expr =
478       expand_array ctx modifs rhs elt_loc' flow var inout type_spec dims cmt in
479     DynamicArray expr
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
484         | true -> arg
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')
497         | Assignment expr ->
498             let expr' = lazy (select_row i (evaluate expr)) in
499             Assignment expr'
500         | Equality expr ->
501             let expr' = lazy (select_row i (evaluate expr)) in
502             Equality expr'
503       and select_rhs_subarray = function
504         | None -> None
505         | Some expr -> Some (lazy (select_row i (evaluate expr)))
506       and select_row i = function
507               | Vector exprs ->
508             begin
509               try
510                 exprs.(i)
511               with
512               | _ -> raise (InstantError
513                   { err_msg = ["_IndexOutOfBound"];
514                     err_info = [];
515                     err_ctx = ctx}) (*error*)
516             end
517         | expr ->
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
524     match expr' with
525       | Integer i ->
526           let a = Array.init (Int32.to_int i) expand_element in
527           StaticArray a
528       | _ ->
529           raise (InstantError
530           { err_msg = ["_NonIntegerArrayDim"];
531             err_info = [];
532             err_ctx = ctx }) (*error*) in
533   match dims with
534     | [] ->
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
537     | dim :: dims ->
538         {
539           component_path = elt_loc;
540           flow = flow;
541           variability = var;
542           causality = inout;
543           component_nature = lazy (expand_along_dimension dim dims);
544           declaration_equation = rhs;
545           comment = cmt;
546           component_location = ctx.location;
547           class_name = instance_class_name ctx.instance_nature
548         }
549
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
557       | [] -> None
558       | {
559           action =
560             ElementModification (
561               Modification (_, Some expr) | Assignment expr | Equality expr)
562         } :: _ -> Some expr
563       | _ :: args -> declaration_equation' args in
564     match rhs with
565       | None -> declaration_equation' modifs
566       | Some _ -> rhs in
567   let flow' = match cl_def.class_flow, ctx.context_flow with
568     | None, None -> flow
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
572     | None, None -> var
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
580   let modifs' =
581     List.fold_right
582       merge_class_modifications
583       (modifs @ cl_def.modification)
584       []
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
589         let ctx' =
590           { ctx' with
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
596           } in
597         {
598           component_path = elt_loc;
599           flow = flow';
600           variability = var';
601           causality = inout';
602           component_nature =
603             lazy (create_class_instance ctx' modifs' rhs' elt_loc cl_desc);
604           declaration_equation = rhs';
605           comment = cmt;
606           component_location = ctx'.location;
607           class_name = class_name
608         }
609     | PredefinedType predef ->
610         let class_name = instance_class_name ctx.instance_nature in
611         let ctx' =
612           { ctx with
613             context_flow = Some flow';
614             context_variability = Some var';
615             context_causality = Some inout';
616             instance_nature = ComponentElement class_name
617           } in
618         {
619           component_path = elt_loc;
620           flow = flow';
621           variability = var';
622           causality = inout';
623           component_nature =
624             lazy (create_predefined_type_instance ctx' modifs' predef);
625           declaration_equation = rhs';
626           comment = cmt;
627           component_location = ctx'.location;
628           class_name = class_name
629         }
630
631 and create_temporary_instance ctx cl_def =
632   match cl_def.description with
633     | ClassDescription (ctx', cl_desc) ->
634         {
635           component_path = [];
636           flow = false;
637           variability = Types.Continuous;
638           causality = Types.Acausal;
639           component_nature =
640             lazy (create_class_instance ctx' [] None [] cl_desc);
641           declaration_equation = None;
642           comment = "";
643           component_location = ctx'.location;
644           class_name = instance_class_name ctx.instance_nature
645         }
646     | PredefinedType predef -> assert false (*error*)
647
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
654     | s ->
655         raise (InstantError
656           { err_msg = ["_UnknownIdentifier"; s];
657             err_info = [];
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
664     | s ->
665         raise (InstantError
666           { err_msg = ["_UnknownIdentifier"; s];
667             err_info = [];
668             err_ctx = ctx }) (*error*) in
669   match type_spec with
670     | ClassReference cl_def -> cl_def
671     | PredefinedIdentifier id ->
672         {
673           class_type = predefined_class_specifier id;
674           class_path = [Name id];
675           class_flow = None;
676           class_variability = None;
677           class_causality = None;
678           description = predefined_class_description id;
679           modification = [];
680           class_location = ctx.location
681         }
682     | _ -> assert false (*error*)
683
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
686   Instance inst
687
688 and create_predefined_type_instance ctx modifs predef =
689   let inst =
690     {
691       predefined_type = predef;
692       attributes = predefined_type_attributes ctx modifs
693     } in
694   PredefinedTypeInstance inst
695
696 and predefined_type_attributes ctx modifs =
697   let rec predefined_type_attributes attrs = function
698     | [] -> attrs
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
705
706 and instantiate_inherited_elements ctx modifs rhs exts =
707   List.fold_right (instantiate_inherited_element ctx modifs rhs) exts []
708
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*)
726  
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
731         let cl_def' =
732           {
733             class_kind = Types.Class;
734             class_annotations = lazy (evaluate_class_annotations ctx cl_anns);
735             long_description = long_desc
736           } in
737         {
738           class_type = evaluate cl_def.NameResolve.class_type;
739           class_path = elt_loc;
740           class_flow = None;
741           class_variability = None;
742           class_causality = None;
743           description = ClassDescription (ctx, cl_def');
744           modification = modifs;
745           class_location = ctx.location
746         }
747     | NameResolve.ShortDescription short_desc ->
748         raise (InstantError
749           {err_msg = ["_NotYetImplemented"; "_ShortClassDef"];
750            err_info = [];
751            err_ctx = {ctx with path = elt_loc;
752                       instance_nature = ClassElement}})
753
754 and evaluate_class_annotations ctx cl_anns =
755   let evaluate_inverse_function inv_func =
756     let inv_func = evaluate inv_func in
757     let expr =
758       evaluate_expression ctx inv_func.NameResolve.function_class in
759     match expr with
760     | ClassReference cl_def ->
761         {
762           function_class = cl_def;
763           arguments = inv_func.NameResolve.arguments
764         }
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)
772
773 and evaluate_class_modification ctx cl_modif =
774   let add_modification_argument arg cl_modif' =
775     match arg.NameResolve.action with
776       | None -> cl_modif'
777       | Some modif ->
778           let arg' =
779             arg.NameResolve.target,
780             {
781               each = arg.NameResolve.each;
782               action = evaluate_modification_action ctx modif
783             } in
784           arg' :: cl_modif' in
785   List.fold_right add_modification_argument cl_modif []
786
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 ->
792       raise (InstantError
793         { err_msg = ["_NotYetImplemented"; "_ElementRedeclaration"];
794           err_info = [];
795           err_ctx = ctx })
796
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
805       raise (InstantError
806         { err_msg = ["_NotYetImplemented"; "_AssignExprInElemModif"];
807           err_info = [];
808           err_ctx = ctx })
809   | NameResolve.Equality expr ->
810       let expr' = lazy (evaluate_expression ctx (evaluate expr)) in
811       Equality expr'
812
813 and evaluate_modification_expression ctx = function
814   | None -> None
815   | Some expr ->
816       let expr' = lazy (evaluate_expression ctx (evaluate expr)) in
817       Some expr'
818
819 and instantiate_local_unnamed_elements ctx unnamed_elts =
820   List.map (instantiate_local_unnamed_element ctx) (evaluate unnamed_elts)
821
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) ->
827         raise (InstantError
828           { err_msg = ["_NotYetImplemented"; "_AlgoClause"];
829             err_info = [];
830             err_ctx = ctx })
831
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 []
837
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
848
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'
894     | True, True -> true
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')
909     | _ -> false in
910   let expr = evaluate_expression ctx expr
911   and expr' = evaluate_expression ctx expr' in
912   match equal_expr expr expr' with
913   | true -> []
914   | false -> [ Equal (expr, expr') ]
915
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
922     match cond' with
923       | False -> instantiate_alternatives acc alts
924       | True -> instantiate_default acc equs
925       | _ ->
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')
933
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
945         try
946           List.map2 f altss equs'
947         with
948         | _ ->
949             raise (InstantError
950               {err_msg = ["_InvalidCondEquation"];
951                err_info = [];
952                err_ctx = ctx}) in
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
957     match equ with
958     | ConditionalEquationE (alts, default) ->
959         expand_conditional_equation alts default
960     | Equal (expr, expr') -> [ expr, expr' ]
961     | _ ->
962         raise (InstantError
963           {err_msg = ["_InvalidCondEquation"];
964            err_info = [];
965            err_ctx = ctx}) in
966   let f (expr, expr') = Equal (expr, expr') in
967   List.map f (expand_equation' equ)
968
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
973     cond', equs' in
974   [WhenClauseE (List.map instantiate_alternative alts)]
975
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')]
980
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 ->
987         let f expr =
988           let ctx' =
989             { ctx with
990               class_context = ForContext (ctx, Some expr)
991             } in
992           instantiate_for_clause_e' ctx' ranges in
993         List.flatten (List.map f (Array.to_list exprs))
994     | _ ->
995         raise (InstantError
996           {err_msg = ["_InvalidForClauseRange"];
997            err_info = [];
998            err_ctx = ctx}) in
999   let ranges = List.map (evaluate_expression ctx) ranges in
1000   instantiate_for_clause_e' ctx ranges
1001
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
1043
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
1049   match binop with
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'
1063
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*)
1073
1074 and evaluate_field_access ctx expr id =
1075   let expr = evaluate_expression ctx expr in
1076   field_access ctx expr id
1077
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*)
1083
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
1088   let ctx' =
1089     { ctx with
1090       class_context = FunctionEvaluationContext (ctx, expr, exprs)
1091     } in
1092   evaluate_expression ctx' expr'
1093
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 _ ->
1103         raise (InstantError
1104           { err_msg = ["_NotYetImplemented"; "_ComponentFuncInvocation"];
1105             err_info = [];
1106             err_ctx = ctx })
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
1114
1115 and evaluate_if ctx alts default =
1116   let create_if alts default = match alts with
1117     | [] -> default
1118     | _ :: _ -> If (alts, default) in
1119   let rec evaluate_alternatives alts' alts = match alts with
1120     | [] ->
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
1127     | True ->
1128         let default = evaluate_expression ctx expr' in
1129         create_if (List.rev alts') default
1130     | False -> evaluate_alternatives alts' alts
1131     | _ ->
1132         let expr' = evaluate_expression ctx expr' in
1133         evaluate_alternatives ((expr, expr') :: alts') alts in
1134   evaluate_alternatives [] alts
1135
1136 and evaluate_indexed_access ctx expr exprs =
1137   let rec vector_indexed_access exprs' exprs = match exprs with
1138     | [] -> expr
1139     | Integer i :: exprs ->
1140         let expr' =
1141           try
1142             exprs'.(Int32.to_int i - 1)
1143           with _ ->
1144               raise (InstantError
1145                 { err_msg = ["_IndexOutOfBound"];
1146                   err_info = [];
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
1155       | [] -> expr
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
1162           else
1163             raise (InstantError
1164               { err_msg = ["_IndexOutOfBound"];
1165                 err_info = [];
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
1177   | _, [] -> expr
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)
1186
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*)
1198
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
1209
1210 and evaluate_no_event ctx expr =
1211   let expr = evaluate_expression ctx expr in
1212   match expr with
1213     | True | False | Integer _ | Real _ | String _ | EnumerationElement _ ->
1214         expr
1215     | _ -> NoEvent expr
1216
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
1222     | Real r -> r
1223     | Integer i -> Int32.to_float i
1224     | _ -> assert false in
1225   let integer_interval istart istep istop = match istart, istep, istop with
1226     | _
1227       when (Int32.compare istop istart) *
1228         (Int32.compare istep Int32.zero) < 0 ->
1229         Vector (Array.make 0 (Integer istart))
1230     | _ ->
1231         let n =
1232           Int32.div (Int32.sub istop istart) istep in
1233         let n' = Int32.to_int (Int32.succ n) in
1234         let f i =
1235           let i' = Int32.of_int i in
1236           let j =
1237             Int32.add istart (Int32.mul i' istep) in
1238           Integer j 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))
1243     | _ ->
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 ->
1250       raise (InstantError
1251         {err_msg = ["_RangeStepValueCannotBeNull"];
1252          err_info = [];
1253          err_ctx = ctx})
1254   | _, Real rstep, _ when rstep = 0. ->
1255       raise (InstantError
1256         {err_msg = ["_RangeStepValueCannotBeNull"];
1257          err_info = [];
1258          err_ctx = ctx})
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)
1267
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)
1271     | Vector exprs ->
1272         Vector (Array.map evaluate_real_of_integer exprs)
1273     | _ -> expr' in
1274   let expr' = evaluate_expression ctx expr in
1275   match coer with
1276   | NameResolve.RealOfInteger -> evaluate_real_of_integer expr'
1277
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
1283
1284 and evaluate_tuple ctx exprs =
1285   Tuple (List.map (evaluate_expression ctx) exprs)
1286
1287 and evaluate_unary_operation ctx unop expr =
1288   let expr = evaluate_expression ctx expr in
1289   let expr = flatten_expression expr in
1290   match unop with
1291     | NameResolve.Not -> evaluate_not expr
1292     | NameResolve.UnaryMinus -> evaluate_unary_minus expr
1293     | NameResolve.UnaryPlus -> expr
1294
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
1302     | ranges ->
1303         let ctx' =
1304           { ctx with
1305             class_context = ForContext (ctx, None)
1306           } in
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
1310       | true -> []
1311       | false ->
1312           let ctx' =
1313             { ctx with
1314               class_context = ForContext (ctx, Some (Integer start))
1315             } in
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
1319     match cmp with
1320       | 0 when Int32.compare start stop <> 0 -> assert false (*error*)
1321       | 0 -> Vector [||]
1322       | _ when cmp < 0 ->
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)
1326       | _ ->
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*)
1332
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 ->
1343         let f i =
1344           let ctx' =
1345             { ctx with
1346               class_context = ForContext (ctx, Some exprs.(i))
1347             } in
1348           evaluate_vector_reduction' ctx' ranges in
1349         Vector (Array.init (Array.length exprs) f)
1350     | _ -> assert false
1351   and vector_of_integer_range ctx start step stop ranges =
1352     let rec expression_list pred start = match pred start with
1353       | true -> []
1354       | false ->
1355           let expr = Integer start in
1356           let ctx' =
1357             { ctx with
1358               class_context =
1359                 ForContext (ctx, Some expr)
1360             } in
1361           let expr = evaluate_vector_reduction' ctx' ranges in
1362           let next = Int32.add start step in
1363           expr :: expression_list pred next in
1364     match step with
1365     | _ when Int32.compare step Int32.zero = 0 ->
1366         raise (InstantError
1367           {err_msg = ["_RangeStepValueCannotBeNull"];
1368            err_info = [];
1369            err_ctx = ctx})
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))
1373     | _ ->
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
1378       | true -> []
1379       | false ->
1380           let expr = Real start in
1381           let ctx' =
1382             { ctx with
1383               class_context = ForContext (ctx, Some expr)
1384             } in
1385           let expr = evaluate_vector_reduction' ctx' ranges in
1386           expr :: expression_list pred (start +. step) in
1387     match step with
1388     | 0. ->
1389         raise (InstantError
1390           {err_msg = ["_RangeStepValueCannotBeNull"];
1391            err_info = [];
1392            err_ctx = ctx})
1393     | _ when step < 0. ->
1394         let pred = function f -> f < stop in
1395         Vector (Array.of_list (expression_list pred start))
1396     | _ ->
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
1401
1402 and evaluate_vector ctx exprs =
1403   let exprs = List.map (evaluate_expression ctx) exprs in
1404   Vector (Array.of_list exprs)
1405
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')
1412
1413 and evaluate_divide ctx expr expr' = match expr, expr' with
1414   | _, Integer 0l ->
1415       raise (InstantError
1416         { err_msg = ["_DivisionByZero"];
1417           err_info = [];
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'))
1422   | _, Real 0. ->
1423       raise (InstantError
1424         { err_msg = ["_DivisionByZero"];
1425           err_info = [];
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')
1434
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'
1441     when
1442       ArrayExt.for_all2
1443         (fun expr expr' -> evaluate_equalequal expr expr' = True)
1444         exprs
1445         exprs' -> True
1446   | Vector _, Vector _ -> False
1447   | _ -> BinaryOperation (EqualEqual, expr, expr')
1448
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')
1456
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')
1464
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')
1472
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')
1480
1481 and evaluate_times expr expr' =
1482   let rec line exprs i = match exprs.(i) with
1483     | Vector exprs -> exprs
1484     | _ -> assert false
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)
1493     | _ -> 0
1494   and size expr i = match expr, i with
1495     | _, 0 -> assert false
1496     | Vector exprs, 1 -> Array.length exprs
1497     | _, 1 -> 0
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
1503     | 0 -> assert false
1504     | 1 -> exprs.(0)
1505     | n ->
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')
1532
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'
1539     when
1540       ArrayExt.exists2
1541         (fun expr expr' -> evaluate_equalequal expr expr' = False)
1542         exprs
1543         exprs' -> True
1544   | Vector _, Vector _ -> False
1545   | _ -> BinaryOperation (NotEqual, expr, expr')
1546
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')
1553
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')
1563
1564 and evaluate_power ctx expr expr' =
1565   match expr, expr' with
1566   | (Integer 0l | Real 0.), (Integer 0l | Real 0.) ->
1567       raise (InstantError
1568         { err_msg = ["_ZeroRaisedToTheZeroPower"];
1569           err_info = [];
1570           err_ctx = ctx }) (*error*)
1571   | (Integer 0l | Real 0.), Integer i'
1572     when Int32.compare i' 0l < 0 ->
1573       raise (InstantError
1574         { err_msg = ["_ZeroRaisedToNegativePower"];
1575           err_info = [];
1576           err_ctx = ctx }) (*error*)
1577   | (Integer 0l | Real 0.), Real f' when f' < 0. ->
1578       raise (InstantError
1579         { err_msg = ["_ZeroRaisedToNegativePower"];
1580           err_info = [];
1581           err_ctx = ctx }) (*error*)
1582   | Integer 0l, Integer _ ->
1583       (* We know the answer for sure since second argument is constant *)
1584       Real 0.
1585   | (Integer 0l | Real 0.), (Integer _ | Real _) -> Real 0.
1586   | Integer i, Real _ when Int32.compare i 0l < 0 ->
1587       raise (InstantError
1588         { err_msg = ["_RealExponentOfNegativeNumber"];
1589           err_info = [];
1590           err_ctx = ctx }) (*error*)
1591   | Real f, Real _ when f < 0. ->
1592       raise (InstantError
1593         { err_msg = ["_RealExponentOfNegativeNumber"];
1594           err_info = [];
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 ->
1602       raise (InstantError
1603         { err_msg = ["_NotYetImplemented";
1604                      "_VectorRaisedToIntegerPower"];
1605           err_info = [];
1606           err_ctx = ctx })
1607   | _ -> BinaryOperation (Power, expr, expr')
1608
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')
1619
1620 and evaluate_class_function_invocation cl_def exprs =
1621   FunctionCall (ClassReference cl_def, exprs)
1622
1623 and evaluate_predefined_function_invocation ctx s exprs =
1624   match s, exprs with
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"), _ ->
1631       raise (InstantError
1632         { err_msg = ["_NotYetImplemented"; "_PredefinedOperator"; s];
1633           err_info = [];
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
1674   | _ ->
1675       raise (InstantError
1676         { err_msg = ["_UnknownFunction"; s];
1677           err_info = [];
1678           err_ctx = ctx}) (*error*)
1679
1680 and evaluate_symmetric ctx expr = match expr with
1681   | Vector [||] -> assert false
1682   | Vector exprs when size exprs.(0) 0 <> Array.length exprs ->
1683       raise (InstantError
1684         { err_msg = ["_InvalidArgOfOper"; "symmetric"];
1685           err_info = [];
1686           err_ctx = ctx }) (*error*)
1687   | Vector exprs ->
1688       let f i j =
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)
1694    | _ -> assert false
1695
1696 and evaluate_transpose expr =
1697   match expr with
1698   | Vector exprs  ->
1699       let f i = Vector (Array.map (element i) exprs) in
1700       Vector (Array.init (size expr 1) f)
1701   | _ -> assert false
1702
1703 and evaluate_matrix_operator ctx expr =
1704   let rec scalar expr = match expr with
1705     | Vector [| expr |] -> scalar expr
1706     | Vector _ ->
1707         raise (InstantError
1708           { err_msg = ["_InvalidArgOfOper"; "matrix"];
1709             err_info = [];
1710             err_ctx = ctx }) (*error*)
1711     | _ -> expr in
1712   match expr with
1713   | _ when ndims expr < 2 ->
1714       evaluate_promote ctx 2 expr
1715   | _ when ndims expr = 2 -> expr
1716   | Vector exprs ->
1717       let f expr = Vector (Array.map scalar (array_elements expr)) in
1718       Vector (Array.map f exprs)
1719   | _ -> assert false
1720
1721 and evaluate_promote ctx n expr =
1722   let rec evaluate_promote' i expr =
1723     match expr with
1724     | _ when i = 0 -> expr
1725     | Vector exprs when i > 0 ->
1726         Vector (Array.map (evaluate_promote' i) exprs)
1727     | _ when i > 0 ->
1728         Vector [| evaluate_promote' (i - 1) expr |]
1729     | _ -> assert false in
1730   match ndims expr with
1731   | n' when n' < n ->
1732       evaluate_promote' (n - n') expr
1733   | _ -> expr
1734
1735 and evaluate_vector_operator ctx expr =
1736   let rec evaluate_scalar expr = match expr with
1737     | Vector [| expr |] -> evaluate_scalar expr
1738     | Vector _ ->
1739         raise (InstantError
1740           { err_msg = ["_InvalidArgOfOper"; "vector"];
1741             err_info = [];
1742             err_ctx = ctx }) (*error*)
1743     | _ -> expr
1744   and evaluate_vector_operator' expr = match expr with
1745     | Vector [| expr |] -> evaluate_vector_operator' expr
1746     | Vector exprs ->
1747         Array.map evaluate_scalar exprs
1748     | _ -> [| expr |] in
1749   Vector (evaluate_vector_operator' expr)
1750
1751 and evaluate_max_array expr =
1752   let rec evaluate_max_list exprs = match exprs with
1753     | [] -> assert false
1754     | [ expr ] -> expr
1755     | expr :: exprs ->
1756         evaluate_max expr (evaluate_max_list exprs) in
1757   evaluate_max_list (scalar_elements expr)
1758
1759 and evaluate_min_array expr =
1760   let rec evaluate_min_list exprs = match exprs with
1761     | [] -> assert false
1762     | [ expr ] -> expr
1763     | expr :: exprs ->
1764         evaluate_min expr (evaluate_min_list exprs) in
1765   evaluate_min_list (scalar_elements expr)
1766
1767 and evaluate_sum expr =
1768   let rec evaluate_sum_list exprs = match exprs with
1769     | [] -> Integer Int32.zero
1770     | [ expr ] -> expr
1771     | expr :: exprs ->
1772         evaluate_plus expr (evaluate_sum_list exprs) in
1773   match expr with
1774   | Vector exprs ->
1775       evaluate_sum_list (scalar_elements expr)
1776   | _ -> assert false
1777
1778 and evaluate_product expr =
1779   let rec evaluate_product_list exprs = match exprs with
1780     | [] -> Integer Int32.one
1781     | [ expr ] -> expr
1782     | expr :: exprs ->
1783         evaluate_times expr (evaluate_product_list exprs) in
1784   match expr with
1785   | Vector exprs ->
1786       evaluate_product_list (scalar_elements expr)
1787   | _ -> assert false
1788
1789 and evaluate_fill ctx expr exprs =
1790   let rec evaluate_fill' dims = match dims with
1791     | [] -> expr
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))
1795   | _ ->
1796       raise (InstantError
1797         { err_msg = ["_InvalidArgOfOper"; "fill"];
1798           err_info = [];
1799             err_ctx = ctx }) (*error*) in
1800   evaluate_fill' exprs
1801
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))
1808   | _ ->
1809       raise (InstantError
1810         { err_msg = ["_InvalidArgOfOper"; "zeros"];
1811           err_info = [];
1812             err_ctx = ctx }) (*error*) in
1813   evaluate_zeros' exprs
1814
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))
1821   | _ ->
1822       raise (InstantError
1823         { err_msg = ["_InvalidArgOfOper"; "ones"];
1824           err_info = [];
1825             err_ctx = ctx }) (*error*) in
1826   evaluate_ones' exprs
1827
1828 and evaluate_identity ctx expr =
1829   let n = match expr with
1830     | Integer i when Int32.compare i Int32.zero > 0 ->
1831         Int32.to_int i
1832   | _ ->
1833       raise (InstantError
1834         { err_msg = ["_InvalidArgOfOper"; "identity"];
1835           err_info = [];
1836             err_ctx = ctx }) (*error*) in
1837   let f i j =
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)
1841
1842 and evaluate_diagonal ctx expr =
1843   let exprs = match expr with
1844     | Vector [||] ->
1845       raise (InstantError
1846         { err_msg = ["_InvalidArgOfOper"; "diagonal"];
1847           err_info = [];
1848           err_ctx = ctx }) (*error*)
1849     | Vector exprs -> exprs
1850   | _ ->
1851       raise (InstantError
1852         { err_msg = ["_InvalidArgOfOper"; "diagonal"];
1853           err_info = [];
1854             err_ctx = ctx }) (*error*) in
1855   let n = Array.length exprs in
1856   let f i j =
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)
1860
1861 and evaluate_scalar ctx expr =
1862   let rec evaluate_scalar' expr = match expr with
1863     | Vector [| expr |] -> evaluate_scalar' expr
1864     | Vector _ ->
1865         raise (InstantError
1866           { err_msg = ["_InvalidArgOfOper"; "scalar"];
1867             err_info = [];
1868             err_ctx = ctx }) (*error*)
1869     | _ -> expr in
1870   match expr with
1871   | Vector [| expr |] -> evaluate_scalar' expr
1872   | _ ->
1873       raise (InstantError
1874         { err_msg = ["_InvalidArgOfOper"; "scalar"];
1875           err_info = [];
1876           err_ctx = ctx }) (*error*)
1877
1878 and evaluate_reinit expr expr' = match expr, expr' with
1879   | Vector exprs, Vector exprs' ->
1880       Vector (ArrayExt.map2 evaluate_reinit exprs exprs')
1881   | _, _ ->
1882       FunctionCall (PredefinedIdentifier "reinit", [ expr; expr' ])
1883
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
1917       and f' = f -. 1. in
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.))
1993   | FunctionCall
1994       (PredefinedIdentifier ("div" | "mod" | "rem" | "ceil" | "floor"), _) ->
1995       Real 0.
1996   | If (alts, default) ->
1997       let alts' =
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 ])
2006
2007 and evaluate_pre expr = match expr with
2008   | Vector exprs ->
2009       Vector (Array.map evaluate_pre exprs)
2010   | _ ->
2011       FunctionCall (PredefinedIdentifier "pre", [ expr ])
2012
2013 and evaluate_cos expr = match expr with
2014   | Vector exprs ->
2015       Vector (Array.map evaluate_cos exprs)
2016   | _ ->
2017       FunctionCall (PredefinedIdentifier "cos", [ expr ])
2018
2019 and evaluate_sin expr = match expr with
2020   | Vector exprs ->
2021       Vector (Array.map evaluate_sin exprs)
2022   | _ ->
2023       FunctionCall (PredefinedIdentifier "sin", [ expr ])
2024
2025 and evaluate_tan expr = match expr with
2026   | Vector exprs ->
2027       Vector (Array.map evaluate_tan exprs)
2028   | _ ->
2029       FunctionCall (PredefinedIdentifier "tan", [ expr ])
2030
2031 and evaluate_exp expr = match expr with
2032   | Vector exprs ->
2033       Vector (Array.map evaluate_exp exprs)
2034   | _ ->
2035       FunctionCall (PredefinedIdentifier "exp", [ expr ])
2036
2037 and evaluate_log expr = match expr with
2038   | Vector exprs ->
2039       Vector (Array.map evaluate_log exprs)
2040   | _ ->
2041       FunctionCall (PredefinedIdentifier "log", [ expr ])
2042
2043 and evaluate_sqrt expr = match expr with
2044   | Vector exprs ->
2045       Vector (Array.map evaluate_sqrt exprs)
2046   | _ ->
2047       FunctionCall (PredefinedIdentifier "sqrt", [ expr ])
2048
2049 and evaluate_asin expr = match expr with
2050   | Vector exprs ->
2051       Vector (Array.map evaluate_asin exprs)
2052   | _ ->
2053       FunctionCall (PredefinedIdentifier "asin", [ expr ])
2054
2055 and evaluate_acos expr = match expr with
2056   | Vector exprs ->
2057       Vector (Array.map evaluate_acos exprs)
2058   | _ ->
2059       FunctionCall (PredefinedIdentifier "acos", [ expr ])
2060
2061 and evaluate_atan expr = match expr with
2062   | Vector exprs ->
2063       Vector (Array.map evaluate_atan exprs)
2064   | _ ->
2065       FunctionCall (PredefinedIdentifier "atan", [ expr ])
2066
2067 and evaluate_sinh expr = match expr with
2068   | Vector exprs ->
2069       Vector (Array.map evaluate_sinh exprs)
2070   | _ ->
2071       FunctionCall (PredefinedIdentifier "sinh", [ expr ])
2072
2073 and evaluate_cosh expr = match expr with
2074   | Vector exprs ->
2075       Vector (Array.map evaluate_cosh exprs)
2076   | _ ->
2077       FunctionCall (PredefinedIdentifier "cosh", [ expr ])
2078
2079 and evaluate_tanh expr = match expr with
2080   | Vector exprs ->
2081       Vector (Array.map evaluate_tanh exprs)
2082   | _ ->
2083       FunctionCall (PredefinedIdentifier "tanh", [ expr ])
2084
2085 and evaluate_asinh expr = match expr with
2086   | Vector exprs ->
2087       Vector (Array.map evaluate_asinh exprs)
2088   | _ ->
2089       FunctionCall (PredefinedIdentifier "asinh", [ expr ])
2090
2091 and evaluate_acosh expr = match expr with
2092   | Vector exprs ->
2093       Vector (Array.map evaluate_acosh exprs)
2094   | _ ->
2095       FunctionCall (PredefinedIdentifier "acosh", [ expr ])
2096
2097 and evaluate_atanh expr = match expr with
2098   | Vector exprs ->
2099       Vector (Array.map evaluate_atanh exprs)
2100   | _ ->
2101       FunctionCall (PredefinedIdentifier "atanh", [ expr ])
2102
2103 and evaluate_log10 expr = match expr with
2104   | Vector exprs ->
2105       Vector (Array.map evaluate_log10 exprs)
2106   | _ ->
2107       FunctionCall (PredefinedIdentifier "log10", [ expr ])
2108
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')
2113   | _, _ ->
2114       let b = BinaryOperation (GreaterEqual, expr, expr') in
2115       If ([b, expr], expr')
2116
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')
2121   | _, _ ->
2122       let b = BinaryOperation (GreaterEqual, expr', expr) in
2123       If ([b, expr], expr')
2124
2125 and evaluate_abs expr = match expr with
2126   | Vector exprs ->
2127       Vector (Array.map evaluate_abs exprs)
2128   | Real f -> Real (abs_float f)
2129   | Integer i -> Integer (Int32.abs i)
2130   | _ ->
2131       let b = BinaryOperation (GreaterEqual, expr, Real 0.)
2132       and default = UnaryOperation (UnaryMinus, expr) in
2133       If ([b, expr], default)
2134
2135 and evaluate_sign expr = match expr with
2136   | Vector exprs ->
2137       Vector (Array.map evaluate_sign exprs)
2138   | Real f when f > 0. -> Real 1.
2139   | Real f when f < 0. -> Real (-. 1.)
2140   | Real _ -> Real 0.
2141   | Integer i when Int32.compare i Int32.zero > 0 ->
2142       Integer Int32.one
2143   | Integer i when Int32.compare i Int32.zero < 0 ->
2144       Integer Int32.minus_one
2145   | Integer _ -> Integer Int32.zero
2146   | _ ->
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)],
2150           Integer Int32.zero)
2151
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')
2155   | _, Real 0. ->
2156       raise (InstantError
2157         { err_msg = ["_DivisionByZero"];
2158           err_info = [];
2159           err_ctx = ctx }) (*error*)
2160   | _, Integer i when i = Int32.zero ->
2161       raise (InstantError
2162         { err_msg = ["_DivisionByZero"];
2163           err_info = [];
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')))
2174   | _, _ ->
2175       FunctionCall (PredefinedIdentifier "div", [ expr; expr' ])
2176
2177 and evaluate_mod expr expr' = match expr, expr' with
2178   | Vector exprs, Vector exprs' ->
2179       Vector (ArrayExt.map2 evaluate_mod exprs exprs')
2180   | _, _ ->
2181       FunctionCall (PredefinedIdentifier "mod", [ expr; expr' ])
2182
2183 and evaluate_rem expr expr' = match expr, expr' with
2184   | Vector exprs, Vector exprs' ->
2185       Vector (ArrayExt.map2 evaluate_rem exprs exprs')
2186   | _, _ ->
2187       FunctionCall (PredefinedIdentifier "rem", [ expr; expr' ])
2188
2189 and evaluate_ceil expr = match expr with
2190   | Vector exprs ->
2191       Vector (Array.map evaluate_ceil exprs)
2192   | _ ->
2193       FunctionCall (PredefinedIdentifier "ceil", [ expr ])
2194
2195 and evaluate_floor expr = match expr with
2196   | Vector exprs ->
2197       Vector (Array.map evaluate_floor exprs)
2198   | _ ->
2199       FunctionCall (PredefinedIdentifier "floor", [ expr ])
2200
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
2218     | Vector exprs ->
2219         let size = Integer (Int32.of_int (Array.length exprs)) in
2220         size :: evaluate_size_list exprs.(0)
2221     | _ -> [] in
2222   match exprs with
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*)
2227
2228 and evaluate_not expr = match expr with
2229   | True -> False
2230   | False -> True
2231   | Vector exprs -> Vector (Array.map evaluate_not exprs)
2232   | _ -> UnaryOperation (Not, expr)
2233
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)
2239
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 _ ->
2254           raise (InstantError
2255             { err_msg = ["_CannotAccessToPredefTypeAttrib"; id];
2256               err_info = [];
2257               err_ctx = ctx}) (*error*)
2258       | StaticArray cpnt_descs ->
2259           Vector (Array.map component_field_access cpnt_descs) in
2260   field_access' expr
2261
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
2266       | None ->
2267           raise (InstantError
2268             { err_msg = ["_MissingDeclEquForFixedId"; id];
2269               err_info = [];
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)
2287           (*let f i =
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
2292       | Types.Constant ->
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
2301
2302 and expression_location ctx expr =
2303   match expr.NameResolve.info.NameResolve.syntax with
2304     | None -> ctx.location
2305     | Some expr -> expr.Syntax.info
2306
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
2311   | None -> ""
2312   | Some expr -> Syntax.string_of_expression expr
2313
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)
2318     | _ -> ClassElement
2319
2320 and instance_class_name instance_nature =
2321   match instance_nature with
2322     | ComponentElement s -> s
2323     | ClassElement -> ""
2324
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
2331   match expr with
2332   | ComponentReference cpnt_desc ->
2333       flatten_component cpnt_desc
2334   | _ -> expr
2335
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"
2341
2342 and sizes expr =
2343   Array.init (ndims expr) (size expr)
2344
2345 and ndims expr =
2346   let rec ndims' i expr = match expr with
2347     | Vector [||] -> i + 1
2348     | Vector exprs -> ndims' (i + 1) exprs.(0)
2349     | _ -> i in
2350   ndims' 0 expr
2351
2352 and element i expr = match expr with
2353   | Vector exprs -> exprs.(i)
2354   | _ -> assert false
2355
2356 and array_elements expr = match expr with
2357   | Vector exprs -> exprs
2358   | _ -> assert false
2359
2360 and scalar_elements expr = match expr with
2361   | Vector exprs ->
2362       let exprss =
2363         Array.to_list (Array.map scalar_elements exprs) in
2364       List.flatten exprss
2365   | _ -> [ expr ]
2366
2367 (* for debug*)
2368
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
2385   | Integer 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"
2393   | Real f ->
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
2401   | Vector exprs ->
2402       generate_vector oc exprs
2403   | VectorReduction _ -> Printf.fprintf oc "VectorReduction"
2404
2405 and generate_binary_operation oc bin_op expr expr' =
2406   let string_of_binary_operation_kind = function
2407     | And -> "and"
2408     | Divide -> "/"
2409     | EqualEqual -> "=="
2410     | GreaterEqual -> ">="
2411     | Greater -> ">"
2412     | LessEqual -> "<="
2413     | Less -> "<"
2414     | Times -> "*"
2415     | NotEqual -> "<>"
2416     | Or -> "or"
2417     | Plus -> "+"
2418     | Power -> "^"
2419     | Minus -> "-" in
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 ")"
2425
2426 and generate_class_reference oc cl_def =
2427   let rec last = function
2428     | [] -> assert false
2429     | [Name id] -> id
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
2448
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
2452
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 ")"
2458
2459 and generate_expressions oc = function
2460   | [] -> ()
2461   | [expr] -> generate_expression oc expr;
2462   | expr :: exprs ->
2463       generate_expression oc expr;
2464       Printf.fprintf oc ", ";
2465       generate_expressions oc exprs
2466
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
2479
2480 and generate_no_event oc expr =
2481   Printf.fprintf oc "noEvent(";
2482   generate_expression oc expr;
2483   Printf.fprintf oc ")"
2484
2485 and generate_unary_operation oc un_op expr =
2486   let string_of_unary_operation_kind = function
2487     | Not -> "not"
2488     | UnaryMinus -> "-" in
2489   Printf.fprintf oc "(%s " (string_of_unary_operation_kind un_op);
2490   generate_expression oc expr;
2491   Printf.fprintf oc ")"
2492
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 " }"
2498
2499 and last_id path =
2500   let rec last_id' id path = match path with
2501     | [] -> id
2502     | (Name id) :: path -> last_id' id path
2503     | (Index _) :: path -> last_id' id path in
2504   last_id' "" path
2505
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') ->
2511       add_parenthesis s
2512   | s -> add_parenthesis (Printf.sprintf "%s." s)
2513
2514 and ident_of_path path =
2515   let rec ident_of_path' path =
2516     match path with
2517     | [] -> assert false
2518     | [Name id] -> id
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
2524   match path with
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
2531