From e01a2505d7be6a52506af8700a369dfc80088409 Mon Sep 17 00:00:00 2001 From: Allan CORNET Date: Wed, 6 Jan 2010 13:05:51 +0100 Subject: [PATCH] end of line --- .../scicos/src/modelica_compiler/README.txt | 366 +- .../src/modelica_compiler/causalityGraph.mli | 82 +- .../src/modelica_compiler/xMLCodeGeneration.ml | 902 +- .../src/translator/compilation/nameResolve.ml |10306 ++++++++++---------- .../scicos/src/translator/compilation/types.ml | 1260 +-- .../src/translator/exceptionHandling/errorDico.ml | 316 +- .../src/translator/exceptionHandling/msgDico.ml | 924 +- .../src/translator/instantiation/instantiation.ml | 5062 +++++----- .../modules/scicos/src/translator/parsing/lexer.ml | 142 +- .../scicos/src/translator/parsing/lexer.mll | 406 +- .../scicos/src/translator/parsing/linenum.ml | 50 +- .../scicos/src/translator/parsing/linenum.mll | 112 +- .../scicos/src/translator/parsing/parser.ml | 238 +- .../scicos/src/translator/parsing/parser.mly | 2302 ++--- .../scicos/src/translator/parsing/syntax.ml | 1292 +-- .../src/translator/translation/codeGeneration.ml | 2710 ++--- .../src/translator/translation/libraryManager.ml | 172 +- .../src/translator/translation/translator.ml | 248 +- .../src/translator/translation/versiondate.ml | 98 +- scilab/modules/scicos/src/xml2modelica/Makefile | 208 +- .../modules/scicos/src/xml2modelica/stringLexer.ml | 20 +- 21 files changed, 13608 insertions(+), 13608 deletions(-) diff --git a/scilab/modules/scicos/src/modelica_compiler/README.txt b/scilab/modules/scicos/src/modelica_compiler/README.txt index ae47738..00e7def 100644 --- a/scilab/modules/scicos/src/modelica_compiler/README.txt +++ b/scilab/modules/scicos/src/modelica_compiler/README.txt @@ -1,183 +1,183 @@ -1. Introduction -=============== - -This document describes the Modelica compiler Modelicac. -Modelicac is a tool that compiles a subset of the Modelica 2.0 language (see -section 4). This subset allows the description of continuous-time physical -models that can be simulated under AMESim. - - -2. How to compile Modelicac -=========================== - -Be sure to have a recent Objective Caml (v.3.06 or later) properly installed -on the machine. -In the source directory, type: - - make depend - -then: - - make (to compile a bytecode version of Modelicac) -or: - make opt (to compile a native-code version of Modelicac) - -Ocaml code HTML documentation can be automatically generated from module types -by typing: - - make doc - -This will create a directory named "doc" in the current directory. "index.html" -is the entry point of the documentation. - - -3. How to use Modelicac -======================= - -Modelicac compiles Modelica files whose name ends by ".mo". -The modelicac command, when invoked with the appropriate options, may produce: -- A C file containing a function suitable to be called by AMESim in - order to perform a model simulation; -- A "*.moc" file which is the format of a precompiled Modelica class stored for - later instantiation. - -It is required that each "*.mo" file contains exactly one Modelica class -(see section 4) and that the name of the class matches the name of the file that -contains its definition. - -By default, Modelicac removes every variable that is not reinitialized in a -"when" section and for which it can express its value with respect to the -remaining variables of the system. It is possible to disable this option by -specifying "-keep-all-variables" when calling Modelicac (see below). - -Usage ------ - -modelicac [-c] [-o ] [other options] - --c: Compile only, do not instantiate. Modelicac produces a "*.moc" file when - invoked with that option. --o : Set output file name to (this option also works - with -c option but is somewhat useless because of the class - name restrictions given above). -Other options include: --L : Add to the list of directories to be searched when - producing a C file (no effect when used with -c). --hpath : Specify a path to be added to #include directives in the - generated C code. --keep-all-variables: Do not remove any variable from the initial system. --jac: Generate analytic jacobian matrix code. --no-parameter-removal: Do not remove any parameter --no-simplifs: Same as -keep-all-variables -no-parameter-removal --xml: Generate an XML version of the model instead of target code --with-init-in : Generate code for 'separate initialization' mode - (where initialization data is loaded from - ) --with-init-out : Generate code for 'separate initialization' mode - (where initialization data is saved in - ) - -Examples -------- - -+------------------------------------------------------------------------------+ -| Modelicac invokation | Result | -+------------------------------+-----------------------------------------------+ -| modelicac foo.mo | Produces a file named "foo.c" containing a | -| | C function named "foo" to be called by AMESim.| -+------------------------------+-----------------------------------------------+ -| modelicac -c foo.mo | Produces a file named "foo.moc" containing a | -| | precompiled class named "foo". | -+------------------------------+-----------------------------------------------+ -| modelicac -o dir/bar.c | Same as "modelicac foo.mo", but output file | -| foo.mo | name is "bar.c" and the resulting file is | -| | located in directory "dir". | -+------------------------------+-----------------------------------------------+ -| modelicac -L dir1 -L dir2 ...| Same as "modelicac foo.mo", but if some | -| -L dirN foo.mo | precompiled class "bar" needed by class "foo" | -| | isn't found in the current directory (i.e. | -| | there is no file named "bar.moc" in the | -| | current directory), it is searched into | -| | "dir1", and, if not found, into "dir2", ..., | -| | "dirN" until a file named "bar.moc" is found. | -+------------------------------+-----------------------------------------------+ - - -3. The compiled Modelica subset -=============================== - - The Modelicac compiler compiles a subset of the Modelica language that allows -the description of some countinuous equational models. Each Modelica class is -stored in its own file whose name is the name of the class followed by the "mo" -extension. - -Restrictions on the declaration of a modelica class header ----------------------------------------------------------- - - only the keyword "class" is allowed to declare a Modelica class ("function" - is allowed to define functions, but in a very restrictive way, see below); - - "within" is not allowed ; - - a class cannot be "final" ; - - short class definitions (type declarations) are not allowed ; - - inheritance is not allowed ; - - "encapsulated" and "partial" classes are not allowed ; - -Restrictions on the declaration of the components of a class ------------------------------------------------------------- - - imports are not allowed ; - - inner classes are not allowed ; - - "inner", "outer" are not allowed ; - - "protected" component lists are not allowed ; - - "final" and "replaceable" are not allowed ; - - "external" is restricted (see "Restrictions on external function - definitions") ; - - "constant" is not allowed ; - - "input" and "output" may only be used to define I/O ports of the toplevel - class beeing compiled to C code (see example below) ; - - "algorithm" sections are not allowed ; - - arrays must contain numerical types. - -Restrictions on modifications ------------------------------ - - modifications may only apply to base types, scalar or not ; - - selections of subarrays are not allowed (i.e. a[:].b = ...) ; - - "redeclare", "each" and "final" are not allowed. - -Restrictions on equations -------------------------- - - equational "if" is not allowed in the specification of an equation. - -Restrictions on expressions ------------------------------ - - "for" expressions must have an integer range (since algorithms are not - allowed) ; - - selection of subarrays is restricted to numerical arrays ; - - array concatenation (using "[" and "]") is not allowed. - -Restrictions on external function definitions ---------------------------------------------- - Only functions taking zero or more Integer scalars, String scalars, -Real scalars or Real arrays and returning exactly one -Real scalar are supported. - External functions must be declared in the Modelica file that -contains models that use them. -The compiler assumes a corresponding C function with the same -name to be provided by the simulation environment. For example: - -function Blackbox - input Real u[:]; - output Real y; -external; -end Blackbox; - - This function can be called from a Modelica model using the following -syntax: - -...Blackbox(u)... - - The corresponding C function is declared with the following signature: - -double blackbox(double *, int ); - -(the last argument will be the size of the array whose first element -is pointed to by the first argument, as specified in the Modelica -Language Specification) +1. Introduction +=============== + +This document describes the Modelica compiler Modelicac. +Modelicac is a tool that compiles a subset of the Modelica 2.0 language (see +section 4). This subset allows the description of continuous-time physical +models that can be simulated under AMESim. + + +2. How to compile Modelicac +=========================== + +Be sure to have a recent Objective Caml (v.3.06 or later) properly installed +on the machine. +In the source directory, type: + + make depend + +then: + + make (to compile a bytecode version of Modelicac) +or: + make opt (to compile a native-code version of Modelicac) + +Ocaml code HTML documentation can be automatically generated from module types +by typing: + + make doc + +This will create a directory named "doc" in the current directory. "index.html" +is the entry point of the documentation. + + +3. How to use Modelicac +======================= + +Modelicac compiles Modelica files whose name ends by ".mo". +The modelicac command, when invoked with the appropriate options, may produce: +- A C file containing a function suitable to be called by AMESim in + order to perform a model simulation; +- A "*.moc" file which is the format of a precompiled Modelica class stored for + later instantiation. + +It is required that each "*.mo" file contains exactly one Modelica class +(see section 4) and that the name of the class matches the name of the file that +contains its definition. + +By default, Modelicac removes every variable that is not reinitialized in a +"when" section and for which it can express its value with respect to the +remaining variables of the system. It is possible to disable this option by +specifying "-keep-all-variables" when calling Modelicac (see below). + +Usage +----- + +modelicac [-c] [-o ] [other options] + +-c: Compile only, do not instantiate. Modelicac produces a "*.moc" file when + invoked with that option. +-o : Set output file name to (this option also works + with -c option but is somewhat useless because of the class + name restrictions given above). +Other options include: +-L : Add to the list of directories to be searched when + producing a C file (no effect when used with -c). +-hpath : Specify a path to be added to #include directives in the + generated C code. +-keep-all-variables: Do not remove any variable from the initial system. +-jac: Generate analytic jacobian matrix code. +-no-parameter-removal: Do not remove any parameter +-no-simplifs: Same as -keep-all-variables -no-parameter-removal +-xml: Generate an XML version of the model instead of target code +-with-init-in : Generate code for 'separate initialization' mode + (where initialization data is loaded from + ) +-with-init-out : Generate code for 'separate initialization' mode + (where initialization data is saved in + ) + +Examples +------- + ++------------------------------------------------------------------------------+ +| Modelicac invokation | Result | ++------------------------------+-----------------------------------------------+ +| modelicac foo.mo | Produces a file named "foo.c" containing a | +| | C function named "foo" to be called by AMESim.| ++------------------------------+-----------------------------------------------+ +| modelicac -c foo.mo | Produces a file named "foo.moc" containing a | +| | precompiled class named "foo". | ++------------------------------+-----------------------------------------------+ +| modelicac -o dir/bar.c | Same as "modelicac foo.mo", but output file | +| foo.mo | name is "bar.c" and the resulting file is | +| | located in directory "dir". | ++------------------------------+-----------------------------------------------+ +| modelicac -L dir1 -L dir2 ...| Same as "modelicac foo.mo", but if some | +| -L dirN foo.mo | precompiled class "bar" needed by class "foo" | +| | isn't found in the current directory (i.e. | +| | there is no file named "bar.moc" in the | +| | current directory), it is searched into | +| | "dir1", and, if not found, into "dir2", ..., | +| | "dirN" until a file named "bar.moc" is found. | ++------------------------------+-----------------------------------------------+ + + +3. The compiled Modelica subset +=============================== + + The Modelicac compiler compiles a subset of the Modelica language that allows +the description of some countinuous equational models. Each Modelica class is +stored in its own file whose name is the name of the class followed by the "mo" +extension. + +Restrictions on the declaration of a modelica class header +---------------------------------------------------------- + - only the keyword "class" is allowed to declare a Modelica class ("function" + is allowed to define functions, but in a very restrictive way, see below); + - "within" is not allowed ; + - a class cannot be "final" ; + - short class definitions (type declarations) are not allowed ; + - inheritance is not allowed ; + - "encapsulated" and "partial" classes are not allowed ; + +Restrictions on the declaration of the components of a class +------------------------------------------------------------ + - imports are not allowed ; + - inner classes are not allowed ; + - "inner", "outer" are not allowed ; + - "protected" component lists are not allowed ; + - "final" and "replaceable" are not allowed ; + - "external" is restricted (see "Restrictions on external function + definitions") ; + - "constant" is not allowed ; + - "input" and "output" may only be used to define I/O ports of the toplevel + class beeing compiled to C code (see example below) ; + - "algorithm" sections are not allowed ; + - arrays must contain numerical types. + +Restrictions on modifications +----------------------------- + - modifications may only apply to base types, scalar or not ; + - selections of subarrays are not allowed (i.e. a[:].b = ...) ; + - "redeclare", "each" and "final" are not allowed. + +Restrictions on equations +------------------------- + - equational "if" is not allowed in the specification of an equation. + +Restrictions on expressions +----------------------------- + - "for" expressions must have an integer range (since algorithms are not + allowed) ; + - selection of subarrays is restricted to numerical arrays ; + - array concatenation (using "[" and "]") is not allowed. + +Restrictions on external function definitions +--------------------------------------------- + Only functions taking zero or more Integer scalars, String scalars, +Real scalars or Real arrays and returning exactly one +Real scalar are supported. + External functions must be declared in the Modelica file that +contains models that use them. +The compiler assumes a corresponding C function with the same +name to be provided by the simulation environment. For example: + +function Blackbox + input Real u[:]; + output Real y; +external; +end Blackbox; + + This function can be called from a Modelica model using the following +syntax: + +...Blackbox(u)... + + The corresponding C function is declared with the following signature: + +double blackbox(double *, int ); + +(the last argument will be the size of the array whose first element +is pointed to by the first argument, as specified in the Modelica +Language Specification) diff --git a/scilab/modules/scicos/src/modelica_compiler/causalityGraph.mli b/scilab/modules/scicos/src/modelica_compiler/causalityGraph.mli index 3acaf5f..b63f8b5 100644 --- a/scilab/modules/scicos/src/modelica_compiler/causalityGraph.mli +++ b/scilab/modules/scicos/src/modelica_compiler/causalityGraph.mli @@ -1,41 +1,41 @@ -(* - * Modelicac - * - * Copyright (C) 2005 - 2007 Imagine S.A. - * For more information or commercial use please contact us at www.amesim.com - * - * This program is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. - * - *) - -(** This module provides a graph structure over which it is possible to apply -an algorithm that finds the strongly connected components of this graph. *) - -type t -(** The type of the graph used to perform the strongly connected component -finding algorithm. *) - -val create: int -> t -(** [create size] creates a graph with [size] unconnected nodes. *) - -val connect: int -> int -> t -> unit -(** [connect i j g] connects the [i]th node to the [j]th one in g. *) - -val strongly_connected_components: t -> int list list -(** [strongly_connected_components g] returns the stronly connected components -of [g] as a list of index lists. *) - -val print_with: (int -> unit) -> t -> unit -(** [print_with print_fun g] prints the connexions in [g] using [print_fun]. *) +(* + * Modelicac + * + * Copyright (C) 2005 - 2007 Imagine S.A. + * For more information or commercial use please contact us at www.amesim.com + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. + * + *) + +(** This module provides a graph structure over which it is possible to apply +an algorithm that finds the strongly connected components of this graph. *) + +type t +(** The type of the graph used to perform the strongly connected component +finding algorithm. *) + +val create: int -> t +(** [create size] creates a graph with [size] unconnected nodes. *) + +val connect: int -> int -> t -> unit +(** [connect i j g] connects the [i]th node to the [j]th one in g. *) + +val strongly_connected_components: t -> int list list +(** [strongly_connected_components g] returns the stronly connected components +of [g] as a list of index lists. *) + +val print_with: (int -> unit) -> t -> unit +(** [print_with print_fun g] prints the connexions in [g] using [print_fun]. *) diff --git a/scilab/modules/scicos/src/modelica_compiler/xMLCodeGeneration.ml b/scilab/modules/scicos/src/modelica_compiler/xMLCodeGeneration.ml index 68eee80..7c83a39 100644 --- a/scilab/modules/scicos/src/modelica_compiler/xMLCodeGeneration.ml +++ b/scilab/modules/scicos/src/modelica_compiler/xMLCodeGeneration.ml @@ -1,451 +1,451 @@ -(* - * Modelicac - * - * Copyright (C) 2005 - 2007 Imagine S.A. - * For more information or commercial use please contact us at www.amesim.com - * - * This program is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. - * - *) - -type 'a tree = Leaf of (string * 'a) | Node of string * 'a tree list - -(* function used to hide XML special characters *) -let hide_spc s = - let encoded_s = ref "" in - let hide_special_character c = match c with - | '<' -> encoded_s := !encoded_s ^ "<" - | '>' -> encoded_s := !encoded_s ^ ">" - | '&' -> encoded_s := !encoded_s ^ "&" - | '\'' -> encoded_s := !encoded_s ^ "'" - | '\"' -> encoded_s := !encoded_s ^ """ - | _ -> encoded_s := !encoded_s ^ (String.make 1 c) in - String.iter hide_special_character s; - !encoded_s - -let rec insert path x ts = - let rec insert' s path' = function - | [] -> [Node (s, insert path' x [])] - | Node (s', ts'') :: ts' when s = s' -> Node (s', insert path' x ts'') :: ts' - | t' :: ts' -> t' :: insert' s path' ts' - in match path with - | [s] -> Leaf (s, x) :: ts - | s :: path' -> insert' s path' ts - | [] -> assert false - -let cut_on_dot s = - let rec cut_on_dot' i = - if i = String.length s then s, None - else if s.[i] = '.' then String.sub s 0 i, Some (String.sub s (i + 1) (String.length s - i - 1)) - else cut_on_dot' (i + 1) - in cut_on_dot' 0 - -let rec split name = - let s, name_opt = cut_on_dot name in - match name_opt with - | None -> [s] - | Some name' -> s :: split name' - -type element = - { - kind: element_kind; - id: string; - comment: string; - initial_value: SymbolicExpression.t option; - output: bool - } - -and element_kind = - | Input - | Parameter - | Variable - | DiscreteVariable - -let build_tree model = - let bool_of_option = function - | None -> false - | Some _ -> true - in - let (_, ts) = - Array.fold_left - (fun (i, ts) s -> - i + 1, - insert - (split s) - { - kind = Input; - id = s; - comment = ""; - initial_value = Some SymbolicExpression.zero; - output = false - } - ts) - (0, []) - model.Optimization.inputs in - let (_, ts) = - Array.fold_left - (fun (i, ts) par -> - i + 1, - insert - (split par.Optimization.p_name) - { - kind = Parameter; - id = par.Optimization.p_name; - comment = par.Optimization.p_comment; - initial_value = Some par.Optimization.value; - output = false - } - ts) - (0, ts) - model.Optimization.parameters in - let (_, ts) = - Array.fold_left - (fun (i, ts) var -> - i + 1, - insert - (split var.Optimization.v_name) - { - kind = Variable; - id = var.Optimization.v_name; - comment = var.Optimization.v_comment; - initial_value = var.Optimization.start_value; - output = bool_of_option var.Optimization.output - } - ts) - (0, ts) - model.Optimization.variables in - let (_, ts) = - Array.fold_left - (fun (i, ts) dvar -> - i + 1, - insert - (split dvar.Optimization.d_v_name) - { - kind = DiscreteVariable; - id = dvar.Optimization.d_v_name; - comment = dvar.Optimization.d_v_comment; - initial_value = dvar.Optimization.d_start_value; - output = bool_of_option dvar.Optimization.d_output - } - ts) - (0, ts) - model.Optimization.discrete_variables in - ts - -let print_expression oc model expr = - let add_parenthesis expr_option sub_expr = - match expr_option with - | None -> sub_expr - | Some _ -> Printf.sprintf "(%s)" sub_expr in - let rec string_of_expression expr_option sub_expr = - let expr_option' = Some sub_expr in - match SymbolicExpression.nature sub_expr with - | SymbolicExpression.Addition [] -> "0" - | SymbolicExpression.Addition exprs -> - let exprs' = List.map (string_of_expression expr_option') exprs in - add_parenthesis expr_option (String.concat " + " exprs') - | SymbolicExpression.And [] -> "false" - | SymbolicExpression.And (exprs) -> - let s = List.map (string_of_expression expr_option') exprs in - add_parenthesis expr_option (String.concat " and " s) - | SymbolicExpression.ArcCosine expr -> - let s = string_of_expression expr_option' expr in - Printf.sprintf "acos(%s)" s - | SymbolicExpression.ArcHyperbolicCosine expr -> - let s = string_of_expression expr_option' expr in - Printf.sprintf "acosh(%s)" s - | SymbolicExpression.ArcHyperbolicSine expr -> - let s = string_of_expression expr_option' expr in - Printf.sprintf "asinh(%s)" s - | SymbolicExpression.ArcHyperbolicTangent expr -> - let s = string_of_expression expr_option' expr in - Printf.sprintf "atanh(%s)" s - | SymbolicExpression.ArcSine expr -> - let s = string_of_expression expr_option' expr in - Printf.sprintf "asin(%s)" s - | SymbolicExpression.ArcTangent expr -> - let s = string_of_expression expr_option' expr in - Printf.sprintf "atan(%s)" s - | SymbolicExpression.BlackBox (s, args) -> - let args' = List.map (string_of_argument expr_option') args in - let s' = String.concat ", " args' in - Printf.sprintf "%s(%s)" s s' - | SymbolicExpression.BooleanValue false -> Printf.sprintf "false" - | SymbolicExpression.BooleanValue true -> Printf.sprintf "true" - | SymbolicExpression.Constant s -> s - | SymbolicExpression.Cosine expr -> - let s = string_of_expression expr_option' expr in - Printf.sprintf "cos(%s)" s - | SymbolicExpression.Derivative (expr, Num.Int 1) -> - let s = string_of_expression expr_option' expr in - Printf.sprintf "der(%s)" s - | SymbolicExpression.Derivative _ -> assert false - | SymbolicExpression.DiscreteVariable i when i >= 0 -> - Printf.sprintf "`%s`" - model.Optimization.discrete_variables.(i).Optimization.d_v_name - | SymbolicExpression.DiscreteVariable i -> - Printf.sprintf "`%s`" model.Optimization.inputs.(-1 - i) - | SymbolicExpression.Equality (expr, expr') -> - let s = - Printf.sprintf "%s == %s" - (string_of_expression expr_option' expr) - (string_of_expression expr_option' expr') in - add_parenthesis expr_option s - | SymbolicExpression.Exponential expr -> - let s = string_of_expression expr_option' expr in - Printf.sprintf "exp(%s)" s - | SymbolicExpression.Floor expr -> - let s = string_of_expression expr_option' expr in - Printf.sprintf "floor(%s)" s - | SymbolicExpression.Greater (expr, expr') -> - let s = - Printf.sprintf "%s > %s" - (string_of_expression expr_option' expr) - (string_of_expression expr_option' expr') in - add_parenthesis expr_option s - | SymbolicExpression.GreaterEqual (expr, expr') -> - let s = - Printf.sprintf "%s >= %s" - (string_of_expression expr_option' expr) - (string_of_expression expr_option' expr') in - add_parenthesis expr_option s - | SymbolicExpression.HyperbolicCosine expr -> - let s = string_of_expression expr_option' expr in - Printf.sprintf "cosh(%s)" s - | SymbolicExpression.HyperbolicSine expr -> - let s = string_of_expression expr_option' expr in - Printf.sprintf "sinh(%s)" s - | SymbolicExpression.HyperbolicTangent expr -> - let s = string_of_expression expr_option' expr in - Printf.sprintf "tanh(%s)" s - | SymbolicExpression.If (expr, expr', expr'') -> - let s = - Printf.sprintf "if %s then %s else %s" - (string_of_expression expr_option' expr) - (string_of_expression expr_option' expr') - (string_of_expression expr_option' expr'') in - add_parenthesis expr_option s - | SymbolicExpression.Integer i -> - let s = Printf.sprintf "%ld" i in - add_parenthesis expr_option s - | SymbolicExpression.Logarithm expr -> - let s = string_of_expression expr_option' expr in - Printf.sprintf "log(%s)" s - | SymbolicExpression.Multiplication [] -> "1" - | SymbolicExpression.Multiplication exprs -> - let exprs' = List.map (string_of_expression expr_option') exprs in - let s = String.concat " * " exprs' in - add_parenthesis expr_option (Printf.sprintf "%s" s) - | SymbolicExpression.Not expr -> - let s = string_of_expression expr_option' expr in - add_parenthesis expr_option (Printf.sprintf "not %s" s) - | SymbolicExpression.Number num -> - let s = Printf.sprintf "%.16g" (Num.float_of_num num) in - add_parenthesis expr_option s - | SymbolicExpression.Or [] -> "true" - | SymbolicExpression.Or [expr] -> - string_of_expression expr_option' expr - | SymbolicExpression.Or [expr; expr'] -> - begin - let nat = SymbolicExpression.nature expr - and nat' = SymbolicExpression.nature expr' in - match nat, nat' with - | SymbolicExpression.Equality (expr1, expr2), - SymbolicExpression.Greater (expr1', expr2') | - SymbolicExpression.Greater (expr1', expr2'), - SymbolicExpression.Equality (expr1, expr2) - when expr1 == expr1' && expr2 == expr2' || expr1 == expr2' && - expr2 == expr1' -> - (* Special case to recognize '>=' *) - let s = Printf.sprintf "%s >= %s" - (string_of_expression expr_option' expr1') - (string_of_expression expr_option' expr2') in - add_parenthesis expr_option s - | _ -> - let s = Printf.sprintf "%s or %s" - (string_of_expression expr_option' expr) - (string_of_expression expr_option' expr') in - add_parenthesis expr_option s - end - | SymbolicExpression.Or exprs -> - let exprs' = List.map (string_of_expression expr_option') exprs in - add_parenthesis expr_option (String.concat " or " exprs') - | SymbolicExpression.Parameter i -> - Printf.sprintf "`%s`" - model.Optimization.parameters.(i).Optimization.p_name - | SymbolicExpression.PartialDerivative _ -> assert false - | SymbolicExpression.Pre expr -> - let s = string_of_expression expr_option' expr in - Printf.sprintf "pre(%s)" s - | SymbolicExpression.RationalPower (expr, num) -> - let s = Printf.sprintf "%s ^ (%s)" - (string_of_expression expr_option' expr) - (Num.string_of_num num) in - add_parenthesis expr_option s - | SymbolicExpression.Sign expr -> - let s = string_of_expression expr_option' expr in - Printf.sprintf "sgn(%s)" s - | SymbolicExpression.Sine expr -> - let s = string_of_expression expr_option' expr in - Printf.sprintf "sin(%s)" s - | SymbolicExpression.String s -> Printf.sprintf "\"%s\"" s - | SymbolicExpression.Tangent expr -> - let s = string_of_expression expr_option' expr in - Printf.sprintf "tan(%s)" s - | SymbolicExpression.TimeVariable -> "time" - | SymbolicExpression.Variable i -> - Printf.sprintf "`%s`" - model.Optimization.variables.(i).Optimization.v_name - and string_of_argument expr_option arg = - let string_of_array_argument dims exprs = - let rec repeat n sprintf (i, s) = - if n = 0 then i, "" - else if n = 1 then sprintf i s - else - let i, s = sprintf i s in - repeat (n - 1) sprintf (i, s ^ ", ") in - let rec string_of_array_argument' dim dims (i, s) = match dims with - | [] -> - repeat - dim - (fun i s -> i + 1, s ^ string_of_expression expr_option exprs.(i)) - (i, s) - | dim' :: dims -> - repeat - dim - (fun i s -> - let s = s ^ "{" in - let i, s = string_of_array_argument' dim' dims (i, s) in - i, s ^ "}") - (i, s) in - match dims with - | [] -> assert false - | dim :: dims -> - let _, s = string_of_array_argument' dim dims (0, "{") in - s ^ "}" in - match arg with - | SymbolicExpression.ScalarArgument expr -> - string_of_expression expr_option expr - | SymbolicExpression.ArrayArgument (dims, exprs) -> - string_of_array_argument dims exprs - in - Printf.fprintf oc "%s" (hide_spc (string_of_expression None expr)) - -let print_expression_option oc model expr_option = - match expr_option with - | None -> () - | Some expr -> print_expression oc model expr - -let print_tree oc model ts = - let rec print_tabs tabs = - if tabs > 0 then begin - Printf.fprintf oc " "; - print_tabs (tabs - 1); - end in - let string_of_kind = function - | Input -> "input" - | Parameter -> "fixed_parameter" - | Variable -> "variable" - | DiscreteVariable -> "discrete_variable" in - let rec print_tree_element tabs = function - | Node (s, ts) -> - print_tabs tabs; - Printf.fprintf oc "\n"; - print_tabs (tabs + 1); - Printf.fprintf oc "%s\n" (hide_spc s); - print_tabs (tabs + 1); - Printf.fprintf oc "\n"; - List.iter (print_tree_element (tabs + 2)) ts; - print_tabs (tabs + 1); - Printf.fprintf oc "\n"; - print_tabs tabs; - Printf.fprintf oc "\n" - | Leaf (s, elt) -> - print_tabs tabs; Printf.fprintf oc "\n"; - print_tabs (tabs + 1); - Printf.fprintf oc "%s\n" (hide_spc s); - print_tabs (tabs + 1); - Printf.fprintf oc "%s\n" (string_of_kind elt.kind); - print_tabs (tabs + 1); - Printf.fprintf oc "%s\n" (hide_spc elt.id); - print_tabs (tabs + 1); - Printf.fprintf oc "\n" (hide_spc elt.comment); - print_tabs (tabs + 1); - Printf.fprintf oc "\n"; - if elt.output then begin print_tabs (tabs + 1); - Printf.fprintf oc "\n" end; - if elt.kind <> Parameter && elt.initial_value <> None then - begin - print_tabs (tabs + 1); - Printf.fprintf oc "\n" + end; + print_tabs tabs; Printf.fprintf oc "\n" + in + Printf.fprintf oc " \n"; + List.iter (print_tree_element 2) ts; + Printf.fprintf oc " \n" + +let print_equations oc model = + Printf.fprintf oc " \n"; + Array.iteri + (fun i equ -> + Printf.fprintf oc " \n") + model.Optimization.equations; + Printf.fprintf oc " \n" + +let print_when_clauses oc model = + Printf.fprintf oc " \n"; + List.iter + (fun (cond, equs) -> + Printf.fprintf oc " + print_expression oc model expr; + Printf.fprintf oc " := "; + print_expression oc model expr'; + Printf.fprintf oc "; " + | Optimization.Reinit (expr, expr') -> + Printf.fprintf oc "reinit("; + print_expression oc model expr; + Printf.fprintf oc ", "; + print_expression oc model expr'; + Printf.fprintf oc "); ") + equs; + Printf.fprintf oc "end when;\"/>\n") + model.Optimization.when_clauses; + Printf.fprintf oc " \n" + +let generate_XML filename fun_name model = + let oc = open_out filename in + Printf.fprintf oc "\n"; + Printf.fprintf oc " %s\n" (hide_spc fun_name); + print_tree oc model (build_tree model); + print_equations oc model; + print_when_clauses oc model; + Printf.fprintf oc "\n"; + close_out oc diff --git a/scilab/modules/scicos/src/translator/compilation/nameResolve.ml b/scilab/modules/scicos/src/translator/compilation/nameResolve.ml index 9edbcf4..ab8fc01 100644 --- a/scilab/modules/scicos/src/translator/compilation/nameResolve.ml +++ b/scilab/modules/scicos/src/translator/compilation/nameResolve.ml @@ -1,5153 +1,5153 @@ -(* - * Translator from Modelica 2.x to flat Modelica - * - * Copyright (C) 2005 - 2007 Imagine S.A. - * For more information or commercial use please contact us at www.amesim.com - * - * This program is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. - * - *) - -(** Resolution of types for Modelica elements from the abstract syntax tree. -The main functions are: -{ul -{- [ resolve_toplevel ]: Main function. Resolve a list of top level syntax element} -{- [ resolve_variable_definition ]: Resolution of a variable definition} -{- [ resolve_class_definition ]: Resolution of a class definition} -{- [ resolve_modification ]: Resolution of modifications} -{- [ resolve_expression ]: Resolution of syntax expressions - {ul - {- [ resolve_binary_operation ]: Resolve binary operation expression } - {- [ resolve_unuary_operation ]: Resolve unary operation } - {- [ resolve_identifier ]: scoping algorithm and resolution of identifiers} - {- [ apply_binary_coercions, apply_rhs_coercions ]: Adding of Real to Integer implicit coercions} - {- [ resolve_function_call ]: Resolution of a function call expression } - {- [ resolve_field_access ]: Resolve field access } - {- [ resolve_if ]: Resolve [ if ] expression } - {- [ resolve_indexed_access ]: Resolve indexed access } - {- [ resolve_vector ]: Resolve vector expression } - {- [ resolve_range ]: resolve range expression } - } -} -{- [ resolve_equation ]: Resolution of an equation - {ul - {- [ resolve_equal ]: Resolution of a simple equation of the form [ expr1 = expr2 ] } - {- [ resolve_conditional_equation_e ]: Resolution of conditional equations } - {- [ resolve_for_clause_e ]: Resolution of for equations } - {- [ resolve_connect_clause ]: resolution of connect equations } - {- [ resolve_when_clause_e ]: resolution of when equations} - {- [ equations ]: resolution of array, record and for equations - } -} -} -*) - -(* The type [ node ] is used to attach syntax information to resolved elements *) -type ('a, 'b) node = - { - nature: 'a; - info: 'b - } - -(* Type of resolved elements *) - -and element_description = - { - element_type: Types.element_type Lazy.t; - redeclare: bool; - element_nature: element_nature; - element_location: Parser.location - } - -and element_nature = - | Component of component_description - | Class of class_definition - | ComponentType of component_type_description - | PredefinedType of Types.predefined_type - -and component_description = - { - component_type: Types.component_type Lazy.t; - type_specifier: expression Lazy.t; - dimensions: dimension list Lazy.t; - modification: modification option Lazy.t; - comment: string - } - -and dimension = - | Colon - | Expression of expression - -and class_definition = - { - class_type: Types.class_specifier Lazy.t; - enclosing_class: class_definition option; - encapsulated: bool; - description: class_description Lazy.t; - } - -and class_description = - | LongDescription of long_description - | ShortDescription of modified_class - -and long_description = - { - class_annotations: (annotation list) Lazy.t; - imports: import_description list; - extensions: (visibility * modified_class) list; - named_elements: named_element list; - unnamed_elements: equation_or_algorithm_clause list Lazy.t; - external_call: external_call option Lazy.t - } - -and annotation = - | InverseFunction of inverse_function Lazy.t - | UnknownAnnotation of (Parser.location Syntax.class_modification) Lazy.t - -and inverse_function = - { - function_class: expression; - arguments: (string * string) list - } - -and import_description = unit - -and visibility = Public | Protected - -and named_element = string * element_description - -and modified_class = - { - modified_class_type: Types.class_type Lazy.t; - base_class: expression Lazy.t; - class_modification: class_modification Lazy.t - } - -and component_type_description = - { - described_type: Types.component_type Lazy.t; - base_type: expression Lazy.t; - type_dimensions: dimension list Lazy.t; - type_modification: class_modification Lazy.t - } - -and external_call = (external_call_desc, Parser.location Syntax.externalll) node - -and external_call_desc = - | PrimitiveCall of string - | ExternalProcedureCall of language * - expression option (* rhs *) * string * expression list - -and language = C | FORTRAN - -and modification = - | Modification of class_modification * expression Lazy.t option - | Assignment of expression Lazy.t - | Equality of expression Lazy.t - -and class_modification = modification_argument list - -and modification_argument = - { - each: bool; - final: bool; - target: string; - action: modification_action option - } - -and modification_action = - | ElementModification of modification - | ElementRedeclaration of element_description - -(* Type of equations and algorithms *) - -and equation_or_algorithm_clause = - | EquationClause of validity * equation list - | AlgorithmClause of validity * algorithm list - -and validity = Initial | Permanent - -and equation = (equation_desc, Parser.location Syntax.equation option) node - -and equation_desc = - | Equal of expression * expression - | ConditionalEquationE of (expression * equation list) list * equation list - | ForClauseE of expression list (* ranges *) * equation list - | ConnectFlows of sign * expression * sign * expression - | WhenClauseE of (expression * equation list) list - -and sign = Positive | Negative - -and algorithm = (algorithm_desc, Parser.location Syntax.algorithm option) node - -and algorithm_desc = - | Assign of expression * expression - | FunctionCallA of expression * expression list - | MultipleAssign of expression list * expression * expression list - | Break - | Return - | ConditionalEquationA of (expression * algorithm list) list * - algorithm list - | ForClauseA of expression list (* ranges *) * algorithm list - | WhileClause of expression * algorithm list - | WhenClauseA of (expression * algorithm list) list - -(* Type of expressions *) - -and expression = (expression_desc, expression_information) node - -(* Type of a resolved expression: -- [ syntax ]: expression syntax (this information is optional, some expressions - are dynamicaly created during typing analysis) -- [ type_description ]: expression type *) -and expression_information = - { - syntax: Parser.location Syntax.expression option; - type_description: Types.element_nature - } - -and expression_desc = - | BinaryOperation of binary_operator_kind * expression * expression - | DynamicIdentifier of int (** number of nested classes to skip *) * - string (** name to be searched for at instanciation time *) - | False - | FieldAccess of expression * string - | FunctionArgument of int (** the position of the argument in the call *) - | FunctionCall of expression (** function *) * - expression list (** arguments *) * - expression (** the expression involving the function call *) - (** creation of a dynamic function context *) - | FunctionInvocation of expression list - (** invocation of the current function in context *) - | If of (expression (** condition *) * expression) list * - expression (** default *) - | IndexedAccess of expression * expression list (* subscripts *) - | Integer of int32 - | LocalIdentifier of int (** number of nested classes to skip *) * - string (** key in the dictionary of the defining class *) - | LoopVariable of int (** number of nested for loops to skip *) - | NoEvent of expression - | PredefinedIdentifier of string (** predefined identifier *) - | Range of expression * expression * expression - | Real of float - | String of string - | ToplevelIdentifier of string (** key in the toplevel dictionary *) - | True - | Tuple of expression list - | UnaryOperation of unary_operator_kind * expression - | Vector of expression list - | VectorReduction of expression list (** nested ranges *) * expression - | Coercion of coercion_kind * expression - -and coercion_kind = - | RealOfInteger (** Implicit conversion of Integer to Real *) - -and unary_operator_kind = - | Not - | UnaryMinus - | UnaryPlus - -and binary_operator_kind = - | And - | Divide - | EqualEqual - | GreaterEqual - | Greater - | LessEqual - | Less - | Times - | NotEqual - | Or - | Plus - | Power - | Minus - -(* Context types. Contexts are used to resolve identifiers in expressions *) - -type context = - { - toplevel: (string * element_description) list Lazy.t; - context_nature: context_nature; - location: Parser.location - } - -and context_nature = - | ToplevelContext - | ClassContext of class_definition - | SubscriptContext of - context * expression (* evaluating to an array *) * - int32 (* dimension index *) * Types.dimension - | ForContext of context * string * Types.element_nature - -(* Type Errors detected during compilation *) - -type error_description = - { - err_msg: string list; - err_info: (string * string) list; - err_ctx: context - } - -exception CompilError of error_description - -(* Utilities *) - -let evaluate x = Lazy.force x - -let resolve_elements add_element elts other_elts = - let resolve_other_elements other_elt acc = match other_elt.Syntax.nature with - | Syntax.Public elts -> List.fold_right (add_element Public) elts acc - | Syntax.Protected elts -> List.fold_right (add_element Protected) elts acc - | Syntax.EquationClause _ | Syntax.AlgorithmClause _ -> acc in - List.fold_right - (add_element Public) - elts - (List.fold_right resolve_other_elements other_elts []) - -let resolved_expression syntax nat elt_nat = - { - nature = nat; - info = { syntax = syntax; type_description = elt_nat } - } - -let one = - let nat = Integer 1l - and elt_nat = Types.integer_type Types.Constant in - resolved_expression None nat elt_nat - - -(* Name resolution functions *) - -let rec resolve_toplevel dic nodes = - let add_element ctx acc (id, elt_desc) = - match List.mem_assoc id acc with - | true -> - let ctx = { ctx with location = elt_desc.element_location } in - raise (CompilError - {err_msg = ["_DuplicateDeclarationOfElement"; id]; - err_info = []; - err_ctx = ctx}) (*error*) - | false -> acc @ [ (id, elt_desc) ] in - let rec ctx = - { - toplevel = - lazy (List.fold_left (add_element ctx) dic (evaluate elt_descs)); - context_nature = ToplevelContext; - location = - { - Parser.start = 0; - Parser.enddd = 0; - Parser.filename = Parser.CommandLine - } - } - and elt_descs = lazy (resolve_toplevel_nodes ctx nodes) in - evaluate ctx.toplevel - -and resolve_toplevel_nodes ctx nodes = - let rec resolve_toplevel_nodes' nodes' = - match nodes' with - | [] -> [] - | node :: nodes' -> - (resolve_toplevel_statements ctx node) @ - (resolve_toplevel_nodes' nodes') in - let collect_toplevel_defs (cl_defs, nodes) node = - match node.Syntax.nature with - | Syntax.ClassDefinitions cl_defs' -> cl_defs' @ cl_defs, nodes - | _ -> cl_defs, [node] @ nodes in - let cl_defs, nodes = List.fold_left collect_toplevel_defs ([], []) nodes in - let node = {Syntax.nature = Syntax.ClassDefinitions cl_defs; - Syntax.info = ctx.location} in - (resolve_toplevel_statements ctx node) @ - resolve_toplevel_nodes' nodes - -and resolve_toplevel_statements ctx node = match node.Syntax.nature with - | Syntax.ClassDefinitions cl_defs -> resolve_class_definitions ctx cl_defs - | Syntax.Expression expr -> raise (CompilError - {err_msg = ["_NotYetImplemented"; "_TopLevelExpr"]; - err_info = []; - err_ctx = {ctx with location = expr.Syntax.info}}) - | Syntax.VariablesDefinitions (expr, subs, cpnt_decls) -> - resole_variables_definitions ctx expr subs cpnt_decls - | Syntax.Command algo -> raise (CompilError - {err_msg = ["_NotYetImplemented"; "_TopLevelAlgorithm"]; - err_info = []; - err_ctx = {ctx with location = algo.Syntax.info}}) - | Syntax.Within path -> raise (CompilError - {err_msg = ["_NotYetImplemented"; "_WithinClause"]; - err_info = [("_Expr", Syntax.string_of_toplevel_element node)]; - err_ctx = {ctx with location = node.Syntax.info}}) - | Syntax.Import imprt -> raise (CompilError - {err_msg = ["_NotYetImplemented"; "_ImportClause"]; - err_info = [("_Expr", Syntax.string_of_toplevel_element node)]; - err_ctx = {ctx with location = imprt.Syntax.info}}) - -and resole_variables_definitions ctx expr subs cpnt_decls = - let type_spec = lazy (resolve_expression ctx expr) - and dims = lazy (resolve_dimensions ctx subs) in - List.map (resolve_variable_definition ctx type_spec dims expr) cpnt_decls - -and resolve_variable_definition ctx type_spec dims expr cpnt_decl = - let type_pref = false, None, Types.Acausal in - let id, elt_nat, elt_loc = - resolve_component_declaration ctx type_pref type_spec dims expr cpnt_decl in - let rec elt_desc = - { - element_type = - lazy (element_type ctx false None None None elt_desc); - redeclare = false; - element_nature = elt_nat; - element_location = elt_loc - } in - id, elt_desc - -and resolve_class_definitions ctx cl_defs = - List.map (resolve_class_definition ctx) cl_defs - -and resolve_class_definition ctx cl_def = match cl_def.Syntax.nature with - | Syntax.ClassDefinition (final, def) -> - let loc = (match def.Syntax.nature with - | Syntax.Definition (_, _, _, cl_spec) -> cl_spec.Syntax.info) in - let rec elt_desc = - { - element_type = lazy (element_type ctx false final None None elt_desc); - redeclare = false; - element_nature = resolve_definition ctx def; - element_location = loc - } in - let s = class_definition_name def in - s, elt_desc - -and class_definition_name def = match def.Syntax.nature with - | Syntax.Definition (_, _, _, cl_spec) -> class_specifier_name cl_spec - -and class_specifier_name cl_spec = match cl_spec.Syntax.nature with - | Syntax.LongSpecifier (id, _, _) | - Syntax.ShortSpecifier (id, _, _, _, _, _) | - Syntax.EnumerationSpecifier (id, _, _) | - Syntax.ExtensionSpecifier (id, _, _, _) -> id - -and resolve_definition ctx def = - let ctx = {ctx with location = def.Syntax.info} in - match def.Syntax.nature with - | Syntax.Definition (encap, part, kind, cl_spec) -> - resolve_specification ctx encap part kind cl_spec - -and resolve_specification ctx encap part kind cl_spec = - let encap' = bool_of_encapsulated encap in - match kind with - | Syntax.Class -> - resolve_class_specification ctx encap' part Types.Class cl_spec - | Syntax.Model -> - resolve_class_specification ctx encap' part Types.Model cl_spec - | Syntax.Block -> - resolve_class_specification ctx encap' part Types.Block cl_spec - | Syntax.Record -> - resolve_class_specification ctx encap' part Types.Record cl_spec - | Syntax.ExpandableConnector -> - resolve_class_specification - ctx - encap' - part - Types.ExpandableConnector - cl_spec - | Syntax.Connector -> - resolve_class_specification ctx encap' part Types.Connector cl_spec - | Syntax.Type when encap' -> - raise (CompilError - {err_msg = ["_EncapsulatedCannotBeAppliedTo"; "_TypeDef"]; - err_info = []; - err_ctx = ctx}) (*error*) - | Syntax.Type -> resolve_type_specification ctx cl_spec - | Syntax.Package -> - resolve_class_specification ctx encap' part Types.Package cl_spec - | Syntax.Function -> - resolve_class_specification ctx encap' part Types.Function cl_spec - -and resolve_type_specification ctx cl_spec = - let ctx = {ctx with location = cl_spec.Syntax.info} in - match cl_spec.Syntax.nature with - | Syntax.LongSpecifier _ -> - raise (CompilError - {err_msg = ["_InvalidTypeDef"]; - err_info = []; - err_ctx = ctx}) (*error*) - | Syntax.ExtensionSpecifier _ -> - raise (CompilError - {err_msg = ["_InvalidTypeDef"]; - err_info = []; - err_ctx = ctx}) (*error*) - | Syntax.ShortSpecifier (_, base_pref, cl_spec, subs, cl_modif, _) -> - let cpnt_type = - resolve_type_composition ctx base_pref cl_spec subs cl_modif in - ComponentType cpnt_type - | Syntax.EnumerationSpecifier (idt, enum_comp, _) -> - let enum_type = resolve_enumeration_composition ctx enum_comp in - PredefinedType enum_type - -and resolve_type_composition ctx base_pref cl_spec subs cl_modif = - let base_pref' = type_prefix base_pref - and base_type = lazy (resolve_expression ctx cl_spec) - and dims = lazy (resolve_dimensions ctx subs) in - let cpnt_type = lazy (component_type ctx base_pref' base_type dims) in - let cl_modif' = lazy (resolve_type_modification ctx cpnt_type cl_modif) in - { - described_type = lazy (modified_described_type ctx cpnt_type cl_modif'); - base_type = base_type; - type_dimensions = dims; - type_modification = cl_modif' - } - -and resolve_enumeration_composition ctx enum_comp = - let resolve_enumeration_literal enum_lit ids = - match enum_lit.Syntax.nature with - | Syntax.EnumerationLiteral (id, _) when List.mem id ids -> - raise (CompilError - {err_msg = ["_EnumTypeDefWithDuplicLit"; id]; - err_info = []; - err_ctx = {ctx with location = enum_lit.Syntax.info}}) (*error*) - | Syntax.EnumerationLiteral (id, _) -> id :: ids in - match enum_comp.Syntax.nature with - | Syntax.EnumList (Some enum_lits) -> - let elts = List.fold_right resolve_enumeration_literal enum_lits [] in - { - Types.base_type = Types.EnumerationType elts; - attributes = ["start", false] - } - | Syntax.EnumList None -> - raise (CompilError - {err_msg = ["_UnspecifiedEnumLits"]; - err_info = []; - err_ctx = {ctx with location = enum_comp.Syntax.info}}) (*error*) - | Syntax.EnumColon -> - raise (CompilError - {err_msg = ["_UnspecifiedEnumLits"]; - err_info = []; - err_ctx = {ctx with location = enum_comp.Syntax.info}}) (*error*) - -and resolve_class_specification ctx encap part kind cl_spec = - let ctx = {ctx with location = cl_spec.Syntax.info} in - let resolve_specifier encap' cl_def = - let ctx' = {ctx with context_nature = ClassContext cl_def} in - resolve_class_specifier ctx ctx' encap cl_spec in - let rec cl_def = - { - class_type = lazy (class_specifier_type ctx part kind cl_def cl_spec); - enclosing_class = enclosing_class ctx; - encapsulated = encap; - description = lazy (resolve_specifier encap cl_def) - } in - Class cl_def - -and enclosing_class ctx = match ctx.context_nature with - | ToplevelContext -> None - | ClassContext cl_def -> Some cl_def - | SubscriptContext (ctx, _, _, _) | - ForContext (ctx, _, _) -> enclosing_class ctx - -and bool_of_encapsulated = function - | None -> false - | Some Syntax.Encapsulated -> true - -and resolve_class_specifier ctx ctx' encap cl_spec = - let ctx = {ctx with location = cl_spec.Syntax.info} - and ctx' = {ctx' with location = cl_spec.Syntax.info} in - match cl_spec.Syntax.nature with - | Syntax.LongSpecifier (_, _, comp) -> - LongDescription (resolve_composition ctx ctx' comp) - | Syntax.ShortSpecifier _ when encap -> - raise (CompilError - {err_msg = ["_EncapsulatedCannotBeAppliedTo"; "_ShortClassDef"]; - err_info = []; - err_ctx = ctx}) (*error*) - | Syntax.ShortSpecifier (_, base_pref, cl_spec, subs, cl_modif, _) -> - let short_desc = - resolve_short_specifier ctx base_pref cl_spec subs cl_modif in - ShortDescription short_desc - | Syntax.ExtensionSpecifier _ when encap -> - raise (CompilError - {err_msg = ["_EncapsulatedCannotBeAppliedTo"; "_ClassDefByExtension"]; - err_info = []; - err_ctx = ctx}) (*error*) - | Syntax.ExtensionSpecifier (id , cl_modif, _, comp) -> - let long_desc = - resolve_extension_composition ctx ctx' id cl_modif comp in - LongDescription long_desc - | Syntax.EnumerationSpecifier _ -> - raise (CompilError - {err_msg = ["_InvalidUseOfEnumKeyword"]; - err_info = []; - err_ctx = ctx}) (*error*) - -and resolve_short_specifier ctx base_pref cl_spec subs cl_modif = - let ctx = {ctx with location = cl_spec.Syntax.info} in - match base_pref.Syntax.nature, subs with - | Syntax.TypePrefix (None, None, None), None -> - resolve_modified_class ctx ctx cl_spec cl_modif - | (Syntax.TypePrefix (Some _, _, _) | Syntax.TypePrefix (_, Some _, _) | - Syntax.TypePrefix (_, _, Some _)), _ -> - raise (CompilError - {err_msg = ["_UseOfTypePrefixInShortClassDef"]; - err_info = - [("_TypePrefix", Syntax.string_of_base_prefix base_pref)]; - err_ctx = {ctx with location = base_pref.Syntax.info}}) (*error*) - | Syntax.TypePrefix (None, None, None), Some subs -> - raise (CompilError - {err_msg = ["_UseOfSubsInShortClassDef"]; - err_info = []; - err_ctx = {ctx with location = subs.Syntax.info}}) (*error*) - -and resolve_extension_composition ctx ctx' id cl_modif comp = - raise (CompilError - {err_msg = ["_NotYetImplemented"; "_ClassExtendsDef"]; - err_info = []; - err_ctx = ctx}) - -and resolve_composition ctx ctx' comp = match comp.Syntax.nature with - | Syntax.Composition (elts, other_elts, extern) -> - { - class_annotations = lazy (resolve_class_annotations ctx' elts other_elts); - imports = resolve_imports ctx' elts other_elts; - extensions = resolve_extensions ctx ctx' elts other_elts; - named_elements = resolve_named_elements ctx' elts other_elts; - unnamed_elements = lazy (resolve_unnamed_elements ctx' other_elts); - external_call = lazy (resolve_external_call ctx' extern) - } - -and resolve_external_call ctx extern = - let resolve_external_call' extern' = match extern'.Syntax.nature with - | Syntax.External (Some id, None, _, _) -> - { nature = PrimitiveCall id; info = extern' } - | Syntax.External (Some lang, Some extern_call, _, _) -> - raise (CompilError - {err_msg = ["_NotYetImplemented"; "_ExternalProcedureCall"]; - err_info = []; - err_ctx = - {ctx with location = extern'.Syntax.info}}) (*error*) - | Syntax.External (None, _, _, _) -> - { nature = PrimitiveCall "C"; info = extern' } in - (*raise (CompilError - {err_msg = ["_UnspecifiedExtCallLang"]; - err_info = []; - err_ctx = - {ctx with location = extern'.Syntax.info}}) (*error*) in*) - match extern with - | None -> None - | Some extern' -> Some (resolve_external_call' extern') - -and resolve_class_annotations ctx elts other_elts = - let add_class_annotation vis elt anns = match vis, elt.Syntax.nature with - | _, Syntax.ClassAnnotation ann -> - begin match resolve_class_annotation ctx ann with - | [] -> anns - | anns' -> anns' @ anns - end - | _, (Syntax.ImportClause _ | Syntax.ExtendsClause _ | - Syntax.ElementDefinition _) -> anns in - resolve_elements add_class_annotation elts other_elts - -and resolve_imports ctx elts other_elts = - let add_import vis elt imps = match vis, elt.Syntax.nature with - | _, Syntax.ImportClause (imp_clause, _) -> - resolve_import_clause ctx imp_clause :: imps - | _, (Syntax.ClassAnnotation _ | Syntax.ExtendsClause _ | - Syntax.ElementDefinition _) -> imps in - resolve_elements add_import elts other_elts - -and resolve_extensions ctx ctx' elts other_elts = - let add_extension vis elt exts = match vis, elt.Syntax.nature with - | Public, Syntax.ExtendsClause (ext_clause, _) -> - (Public, resolve_extends_clause ctx ctx' ext_clause) :: exts - | Protected, Syntax.ExtendsClause (ext_clause, _) -> - (Protected, resolve_extends_clause ctx ctx' ext_clause) :: exts - | _, (Syntax.ClassAnnotation _ | Syntax.ImportClause _ | - Syntax.ElementDefinition _) -> exts in - resolve_elements add_extension elts other_elts - -and resolve_named_elements ctx elts other_elts = - let add_named_element (id, elt_desc) elts = - match List.mem_assoc id elts with - | true -> - raise (CompilError - {err_msg = ["_DuplicateDeclarationOfElement"; id]; - err_info = []; - err_ctx = ctx}) (*error*) - | false -> (id, elt_desc) :: elts in - let add_named_elements vis elt elts = match vis, elt.Syntax.nature with - | Public, - Syntax.ElementDefinition (redecl, final, dyn_scope, elt_def, _) -> - let elts' = - resolve_element_definition ctx false redecl final dyn_scope elt_def in - List.fold_right add_named_element elts' elts - | Protected, - Syntax.ElementDefinition (redecl, final, dyn_scope, elt_def, _) -> - let elts' = - resolve_element_definition ctx true redecl final dyn_scope elt_def in - List.fold_right add_named_element elts' elts - | _, (Syntax.ClassAnnotation _ | Syntax.ImportClause _ | - Syntax.ExtendsClause _) -> elts in - resolve_elements add_named_elements elts other_elts - -and resolve_class_annotation ctx ann = - let rec resolve_class_annotation' cl_modif = - let add_annotation_information arg acc = match arg.Syntax.nature with - | Syntax.ElementModification ( - None, - None, - { Syntax.nature = Syntax.Identifier "Imagine" }, - Some - { - Syntax.nature = - Syntax.Modification ( - { - Syntax.nature = - Syntax.ClassModification - [ - { - Syntax.nature = - Syntax.ElementModification ( - None, - None, - { - Syntax.nature = Syntax.Identifier "AMESim" - }, - Some - { - Syntax.nature = - Syntax.Modification (cl_modif, None) - }, - []) - } - ] - }, - None) - }, - []) -> add_amesim_annotations ctx cl_modif acc - | Syntax.ElementModification _ | Syntax.ElementRedeclaration _ -> - (UnknownAnnotation (lazy cl_modif)) :: acc in - match cl_modif.Syntax.nature with - | Syntax.ClassModification args -> - List.fold_right add_annotation_information args [] in - match ann.Syntax.nature with - | Syntax.Annotation cl_modif -> resolve_class_annotation' cl_modif - -and add_amesim_annotations ctx cl_modif acc = - let add_inverse_declarations cl_modif = - let add_inverse_declaration arg acc = - let add_inverse_declaration' expr modif = - match expr.Syntax.nature, modif.Syntax.nature with - | Syntax.IndexedAccess ( - { Syntax.nature = Syntax.Identifier "inverse" }, _), - Syntax.Eq - { - Syntax.nature = - Syntax.FunctionCall (expr, Some fun_args) - } -> (resolve_inverse_declaration ctx expr fun_args) :: acc - | _ -> - raise (CompilError - {err_msg = ["_InvalidAnnOfInvFunc"; "_InvalidModifExpr"]; - err_info = []; - err_ctx = - {ctx with location = expr.Syntax.info}}) (*error*) in - match arg.Syntax.nature with - | Syntax.ElementModification (Some _, _, _, _, _) -> - raise (CompilError - {err_msg = ["_InvalidAnnOfInvFunc"; "_UseOfEachKeywordNotAllowed"]; - err_info = []; - err_ctx = {ctx with location = arg.Syntax.info}}) (*error*) - | Syntax.ElementModification (None, Some _, _, _, _) -> - raise (CompilError - {err_msg = ["_InvalidAnnOfInvFunc"; "_UseOfFinalKeywordNotAllowed"]; - err_info = []; - err_ctx = {ctx with location = arg.Syntax.info}}) (*error*) - | Syntax.ElementModification (None, None, _, None, _) -> - raise (CompilError - {err_msg = ["_InvalidAnnOfInvFunc"; "_UnspecifiedModification"]; - err_info = []; - err_ctx = {ctx with location = arg.Syntax.info}}) (*error*) - | Syntax.ElementModification (None, None, expr, Some modif, _) -> - add_inverse_declaration' expr modif - | Syntax.ElementRedeclaration _ -> - raise (CompilError - {err_msg = ["_InvalidAnnOfInvFunc"; "_RedeclarationNotAllowed"]; - err_info = []; - err_ctx = {ctx with location = arg.Syntax.info}}) (*error*) in - match cl_modif.Syntax.nature with - | Syntax.ClassModification args -> - List.fold_right add_inverse_declaration args acc in - match cl_modif.Syntax.nature with - | Syntax.ClassModification - [ - { - Syntax.nature = - Syntax.ElementModification ( - None, - None, - { - Syntax.nature = Syntax.Identifier "InverseFunctions" - }, - Some - { - Syntax.nature = - Syntax.Modification (cl_modif, None) - }, - []) - } - ] -> add_inverse_declarations cl_modif - | Syntax.ClassModification _ -> acc - -and resolve_inverse_declaration ctx expr fun_args = - let inverse_function_arguments expr' fun_args = - let map_function_arguments named_args = - let map_function_argument arg = - match arg.Syntax.nature with - | Syntax.NamedArgument (id, expr) - when List.mem_assoc id named_args -> - let expr' = resolve_expression ctx expr in - begin match expr'.nature with - | LocalIdentifier (0, id') -> id, id' - | _ -> - raise (CompilError - {err_msg = ["_InvalidAnnOfInvFunc"; - "_InvalidFuncArgModif"]; - err_info = []; - err_ctx = - {ctx with - location = expr.Syntax.info}}) (*error*) - end - | Syntax.NamedArgument (id, expr) -> - raise (CompilError - {err_msg = ["_InvalidAnnOfInvFunc"; - "_UnknownArgName"; id]; - err_info = []; - err_ctx = - {ctx with location = arg.Syntax.info}}) (*error*) - | Syntax.Argument _ -> - raise (CompilError - {err_msg = ["_InvalidAnnOfInvFunc"; - "_CannotUseUnnamedFuncArg"]; - err_info = []; - err_ctx = - {ctx with location = arg.Syntax.info}}) (*error*) in - match fun_args.Syntax.nature with - | Syntax.ArgumentList args -> List.map map_function_argument args - | Syntax.Reduction _ -> - raise (CompilError - {err_msg = ["_InvalidAnnOfInvFunc"; - "_FuncArgReductionNotAllowed"]; - err_info = []; - err_ctx = - {ctx with location = fun_args.Syntax.info}}) (*error*) in - let inverse_function_arguments' cl_type = - match cl_type.Types.partial, evaluate cl_type.Types.kind with - | true, _ -> - raise (CompilError - {err_msg = ["_InvalidAnnOfInvFunc"; - "_UseOfPartialClassElement"]; - err_info = [("_ElementFound", - Syntax.string_of_expression expr)]; - err_ctx = - {ctx with location = expr.Syntax.info}}) (*error*) - | false, Types.Function -> - map_function_arguments cl_type.Types.named_elements - | _, kind -> - raise (CompilError - {err_msg = ["_InvalidAnnOfInvFunc"; - "_InvalidTypeOfFuncCallExpr"]; - err_info = [("_ExpectedType", "_Function"); - ("_TypeFound", Types.string_of_kind kind)]; - err_ctx = - {ctx with location = expr.Syntax.info}}) (*error*) in - let elt_nat = expr'.info.type_description in - match elt_nat with - | Types.ClassElement cl_spec -> - let cl_spec = evaluate cl_spec in - begin match cl_spec with - | Types.ClassType cl_type -> - inverse_function_arguments' cl_type - | _ -> - raise (CompilError - {err_msg = ["_InvalidAnnOfInvFunc"; - "_InvalidTypeOfFuncCallExpr"]; - err_info = - [("_ExpectedType", "_ClassType"); - ("_TypeFound", - Types.string_of_class_specifier cl_spec)]; - err_ctx = - {ctx with location = expr.Syntax.info}}) (*error*) - end - | Types.ComponentTypeElement _ -> - raise (CompilError - {err_msg = ["_InvalidAnnOfInvFunc"; - "_InvalidTypeOfFuncCallExpr"]; - err_info = [("_ExpectedType", "_ClassElement"); - ("_TypeFound", "_ComponentTypeElement")]; - err_ctx = - {ctx with location = expr.Syntax.info}}) (*error*) - | Types.PredefinedTypeElement _ -> - raise (CompilError - {err_msg = ["_InvalidAnnOfInvFunc"; - "_InvalidTypeOfFuncCallExpr"]; - err_info = [("_ExpectedType", "_ClassElement"); - ("_TypeFound", "_PredefinedTypeElement")]; - err_ctx = - {ctx with location = expr.Syntax.info}}) (*error*) - | Types.ComponentElement _ -> - raise (CompilError - {err_msg = ["_InvalidAnnOfInvFunc"; - "_InvalidTypeOfFuncCallExpr"]; - err_info = [("_ExpectedType", "_ClassElement"); - ("_TypeFound", "_ComponentElement")]; - err_ctx = - {ctx with location = expr.Syntax.info}}) (*error*) in - let expr' = resolve_expression ctx expr in - match expr'.nature with - | ToplevelIdentifier _ | LocalIdentifier _ -> - InverseFunction - (lazy - { - function_class = expr'; - arguments = inverse_function_arguments expr' fun_args - }) - | _ -> - raise (CompilError - {err_msg = ["_InvalidAnnOfInvFunc"; "_InvalidFuncCallExpr"]; - err_info = []; - err_ctx = - {ctx with location = expr.Syntax.info}}) (*error*) - -(*and resolve_inverse_function_annotation ctx ann = - let rec resolve_class_annotation' cl_modif = - let resolve_inverse_declaration expr fun_args = - let inverse_function_arguments expr' fun_args = - let map_function_arguments named_args = - let map_function_argument arg = - match arg.Syntax.nature with - | Syntax.NamedArgument (id, expr) - when List.mem_assoc id named_args -> - let expr' = resolve_expression ctx expr in - begin match expr'.nature with - | LocalIdentifier (0, id') -> id, id' - | _ -> - raise (CompilError - {err_msg = ["_InvalidAnnOfInvFunc"; - "_InvalidFuncArgModif"]; - err_info = []; - err_ctx = - {ctx with - location = expr.Syntax.info}}) (*error*) - end - | Syntax.NamedArgument (id, expr) -> - raise (CompilError - {err_msg = ["_InvalidAnnOfInvFunc"; - "_UnknownArgName"; id]; - err_info = []; - err_ctx = - {ctx with location = arg.Syntax.info}}) (*error*) - | Syntax.Argument _ -> - raise (CompilError - {err_msg = ["_InvalidAnnOfInvFunc"; - "_CannotUseUnnamedFuncArg"]; - err_info = []; - err_ctx = - {ctx with location = arg.Syntax.info}}) (*error*) in - match fun_args.Syntax.nature with - | Syntax.ArgumentList args -> List.map map_function_argument args - | Syntax.Reduction _ -> - raise (CompilError - {err_msg = ["_InvalidAnnOfInvFunc"; - "_FuncArgReductionNotAllowed"]; - err_info = []; - err_ctx = - {ctx with location = fun_args.Syntax.info}}) (*error*) in - let inverse_function_arguments' cl_type = - match cl_type.Types.partial, evaluate cl_type.Types.kind with - | true, _ -> - raise (CompilError - {err_msg = ["_InvalidAnnOfInvFunc"; - "_UseOfPartialClassElement"]; - err_info = [("_ElementFound", - Syntax.string_of_expression expr)]; - err_ctx = - {ctx with location = expr.Syntax.info}}) (*error*) - | false, Types.Function -> - map_function_arguments cl_type.Types.named_elements - | _, kind -> - raise (CompilError - {err_msg = ["_InvalidAnnOfInvFunc"; - "_InvalidTypeOfFuncCallExpr"]; - err_info = [("_ExpectedType", "_Function"); - ("_TypeFound", Types.string_of_kind kind)]; - err_ctx = - {ctx with location = expr.Syntax.info}}) (*error*) in - let elt_nat = expr'.info.type_description in - match elt_nat with - | Types.ClassElement cl_spec -> - let cl_spec = evaluate cl_spec in - begin match cl_spec with - | Types.ClassType cl_type -> - inverse_function_arguments' cl_type - | _ -> - raise (CompilError - {err_msg = ["_InvalidAnnOfInvFunc"; - "_InvalidTypeOfFuncCallExpr"]; - err_info = - [("_ExpectedType", "_ClassType"); - ("_TypeFound", - Types.string_of_class_specifier cl_spec)]; - err_ctx = - {ctx with location = expr.Syntax.info}}) (*error*) - end - | Types.ComponentTypeElement _ -> - raise (CompilError - {err_msg = ["_InvalidAnnOfInvFunc"; - "_InvalidTypeOfFuncCallExpr"]; - err_info = [("_ExpectedType", "_ClassElement"); - ("_TypeFound", "_ComponentTypeElement")]; - err_ctx = - {ctx with location = expr.Syntax.info}}) (*error*) - | Types.PredefinedTypeElement _ -> - raise (CompilError - {err_msg = ["_InvalidAnnOfInvFunc"; - "_InvalidTypeOfFuncCallExpr"]; - err_info = [("_ExpectedType", "_ClassElement"); - ("_TypeFound", "_PredefinedTypeElement")]; - err_ctx = - {ctx with location = expr.Syntax.info}}) (*error*) - | Types.ComponentElement _ -> - raise (CompilError - {err_msg = ["_InvalidAnnOfInvFunc"; - "_InvalidTypeOfFuncCallExpr"]; - err_info = [("_ExpectedType", "_ClassElement"); - ("_TypeFound", "_ComponentElement")]; - err_ctx = - {ctx with location = expr.Syntax.info}}) (*error*) in - let expr' = resolve_expression ctx expr in - match expr'.nature with - | ToplevelIdentifier _ | LocalIdentifier _ -> - { - function_class = expr'; - arguments = - inverse_function_arguments expr' fun_args - } - | _ -> - raise (CompilError - {err_msg = ["_InvalidAnnOfInvFunc"; "_InvalidFuncCallExpr"]; - err_info = []; - err_ctx = - {ctx with location = expr.Syntax.info}}) (*error*) in - let add_inverse_declaration arg acc = - let add_inverse_declaration' expr modif = - match expr.Syntax.nature, modif.Syntax.nature with - | Syntax.IndexedAccess ( - { Syntax.nature = Syntax.Identifier "inverse" }, _), - Syntax.Eq - { - Syntax.nature = - Syntax.FunctionCall (expr, Some fun_args) - } -> lazy (resolve_inverse_declaration expr fun_args) :: acc - | _ -> - raise (CompilError - {err_msg = ["_InvalidAnnOfInvFunc"; "_InvalidModifExpr"]; - err_info = []; - err_ctx = - {ctx with location = expr.Syntax.info}}) (*error*) in - match arg.Syntax.nature with - | Syntax.ElementModification (Some _, _, _, _, _) -> - raise (CompilError - {err_msg = ["_InvalidAnnOfInvFunc"; "_UseOfEachKeywordNotAllowed"]; - err_info = []; - err_ctx = {ctx with location = arg.Syntax.info}}) (*error*) - | Syntax.ElementModification (None, Some _, _, _, _) -> - raise (CompilError - {err_msg = ["_InvalidAnnOfInvFunc"; "_UseOfFinalKeywordNotAllowed"]; - err_info = []; - err_ctx = {ctx with location = arg.Syntax.info}}) (*error*) - | Syntax.ElementModification (None, None, _, None, _) -> - raise (CompilError - {err_msg = ["_InvalidAnnOfInvFunc"; "_UnspecifiedModification"]; - err_info = []; - err_ctx = {ctx with location = arg.Syntax.info}}) (*error*) - | Syntax.ElementModification (None, None, expr, Some modif, _) -> - add_inverse_declaration' expr modif - | Syntax.ElementRedeclaration _ -> - raise (CompilError - {err_msg = ["_InvalidAnnOfInvFunc"; "_RedeclarationNotAllowed"]; - err_info = []; - err_ctx = {ctx with location = arg.Syntax.info}}) (*error*) in - let add_inverse_declarations cl_modif acc = - let add_inverse_declarations' cl_modif = - match cl_modif.Syntax.nature with - | Syntax.ClassModification args -> - List.fold_right add_inverse_declaration args acc in - match cl_modif.Syntax.nature with - | Syntax.ClassModification - [ - { - Syntax.nature = - Syntax.ElementModification ( - None, - None, - { - Syntax.nature = Syntax.Identifier "InverseFunctions" - }, - Some - { - Syntax.nature = - Syntax.Modification (cl_modif, None) - }, - []) - } - ] -> add_inverse_declarations' cl_modif - | Syntax.ClassModification _ -> acc in - let add_annotation_information arg acc = match arg.Syntax.nature with - | Syntax.ElementModification ( - None, - None, - { Syntax.nature = Syntax.Identifier "Imagine" }, - Some - { - Syntax.nature = - Syntax.Modification ( - { - Syntax.nature = - Syntax.ClassModification - [ - { - Syntax.nature = - Syntax.ElementModification ( - None, - None, - { - Syntax.nature = Syntax.Identifier "AMESim" - }, - Some - { - Syntax.nature = - Syntax.Modification (cl_modif, None) - }, - []) - } - ] - }, - None) - }, - []) -> add_inverse_declarations cl_modif acc - | Syntax.ElementModification _ | Syntax.ElementRedeclaration _ -> acc in - match cl_modif.Syntax.nature with - | Syntax.ClassModification args -> - List.fold_right add_annotation_information args [] in - match ann.Syntax.nature with - | Syntax.Annotation cl_modif -> resolve_class_annotation' cl_modif*) - -and resolve_import_clause ctx imp_clause = - let ctx = {ctx with location = imp_clause.Syntax.info} in - raise (CompilError - {err_msg = ["_NotYetImplemented"; "_ImportClause"]; - err_info = [("_Expr", Syntax.string_of_import imp_clause)]; - err_ctx = ctx}) - -and resolve_extends_clause ctx ctx' ext_clause = - match ext_clause.Syntax.nature with - | Syntax.Extends (cl_spec, cl_modif, _) -> - resolve_extension ctx ctx' cl_spec cl_modif - -and resolve_extension ctx ctx' cl_spec cl_modif = - let ctx' = {ctx' with location = cl_spec.Syntax.info} in - let base_class = lazy (resolve_extension_expression ctx cl_spec) in - let cl_spec' = lazy (base_class_type ctx' cl_spec base_class) in - let cl_modif' = - lazy (resolve_class_modification_option ctx' cl_spec' cl_modif) in - { - modified_class_type = lazy (modified_class_type ctx' cl_spec' cl_modif'); - base_class = base_class; - class_modification = cl_modif' - } - -and resolve_extension_expression ctx cl_spec = - let rec modify_resolved_expression expr = match expr.nature with - | LocalIdentifier (level, id) -> - { expr with nature = LocalIdentifier (level + 1, id) } - | FieldAccess (expr', id) -> - { expr with - nature = FieldAccess (modify_resolved_expression expr', id) - } - | IndexedAccess (expr', exprs') -> - let exprs' = List.map modify_resolved_expression exprs' in - { expr with - nature = IndexedAccess (modify_resolved_expression expr', exprs') - } - | ToplevelIdentifier _ -> expr - | _ -> - raise (CompilError - {err_msg = ["_InvalidExtensionDef"]; - err_info = []; - err_ctx = ctx}) (*error*) in - match ctx.context_nature with - | ToplevelContext | ClassContext _ -> - let base_class = resolve_expression ctx cl_spec in - modify_resolved_expression base_class - | SubscriptContext _ | ForContext _ -> - raise (CompilError - {err_msg = ["_InvalidExtensionDef"]; - err_info = []; - err_ctx = ctx}) (*error*) - -and resolve_modified_class ctx ctx' cl_spec cl_modif = - let ctx' = {ctx' with location = cl_spec.Syntax.info} in - let base_class = lazy (resolve_expression ctx cl_spec) in - let cl_spec' = lazy (base_class_type ctx' cl_spec base_class) in - let cl_modif' = - lazy (resolve_class_modification_option ctx' cl_spec' cl_modif) in - { - modified_class_type = lazy (modified_class_type ctx' cl_spec' cl_modif'); - base_class = base_class; - class_modification = cl_modif' - } - -and resolve_element_definition ctx protect redecl final dyn_scope elt_def = - let repl = replaceable_attribute elt_def in - let element_description (id, elt_nat, elt_loc) = - let rec elt_desc = - { - element_type = - lazy (element_type ctx protect final repl dyn_scope elt_desc); - redeclare = bool_of_redeclare redecl; - element_nature = elt_nat; - element_location = elt_loc - } in - id, elt_desc in - List.map element_description (declared_elements ctx elt_def) - -and replaceable_attribute elt_def = match elt_def.Syntax.nature with - | Syntax.ClassDefinitionElement (repl, _, _) | - Syntax.ComponentClauseElement (repl, _, _) -> repl - -and bool_of_redeclare = function - | None -> false - | Some Syntax.Redeclare -> true - -and resolve_type_constraint ctx elt_def = match elt_def.Syntax.nature with - | Syntax.ClassDefinitionElement (_, _, []) | - Syntax.ComponentClauseElement (_, _, []) -> None - | Syntax.ClassDefinitionElement (_, _, _ :: _) | - Syntax.ComponentClauseElement (_, _, _ :: _) -> assert false - -and declared_elements ctx elt_def = match elt_def.Syntax.nature with - | Syntax.ClassDefinitionElement (_, def, _) -> - let s = class_definition_name def - and elt_nat = resolve_definition ctx def - and loc = match def.Syntax.nature with - | Syntax.Definition (encap, part, kind, cl_spec) -> - cl_spec.Syntax.info in - [s, elt_nat, loc] - | Syntax.ComponentClauseElement (_, cpnt_cl, _) -> - resolve_component_clause ctx cpnt_cl - -and resolve_component_clause ctx cpnt_cl = match cpnt_cl.Syntax.nature with - | Syntax.ComponentClause (type_pref, type_spec, subs, cpnt_decls) -> - let type_pref' = type_prefix type_pref - and type_spec' = lazy (resolve_expression ctx type_spec) - and dims = lazy (resolve_dimensions ctx subs) in - List.map - (resolve_component_declaration ctx type_pref' type_spec' dims type_spec) - cpnt_decls - -and type_prefix type_pref = - let bool_of_flow = function - | None -> false - | Some Syntax.Flow -> true - and variability_of_variability = function - | None -> None - | Some Syntax.Constant -> Some Types.Constant - | Some Syntax.Parameter -> Some Types.Parameter - | Some Syntax.Discrete -> Some Types.Discrete - and causality_of_inout = function - | None -> Types.Acausal - | Some Syntax.Input -> Types.Input - | Some Syntax.Output -> Types.Output in - match type_pref.Syntax.nature with - | Syntax.TypePrefix (flow, var, inout) -> - bool_of_flow flow, - variability_of_variability var, - causality_of_inout inout - -and resolve_component_declaration - ctx type_pref type_spec' dims type_spec cpnt_decl = - let build_comment_string cmt = match cmt.Syntax.nature with - | Syntax.Comment (ss, _) -> List.fold_right ( ^ ) ss "" in - match cpnt_decl.Syntax.nature with - | Syntax.ComponentDeclaration (decl, cmt) -> - let cmt' = build_comment_string cmt in - resolve_declaration ctx type_pref type_spec' dims decl cmt' type_spec - -and resolve_declaration ctx type_pref type_spec' dims decl cmt type_spec = - let ctx = {ctx with location = decl.Syntax.info} in - match decl.Syntax.nature with - | Syntax.Declaration (id, subs, modif) -> - let dims = lazy ((resolve_dimensions ctx subs) @ (evaluate dims)) in - let cpnt_type = lazy (component_type ctx type_pref type_spec' dims) in - let modif' = - lazy (resolve_component_modification ctx cpnt_type modif) in - let cpnt_desc = - { - component_type = - lazy (modified_component_type ctx (evaluate cpnt_type) modif'); - type_specifier = type_spec'; - dimensions = dims; - modification = modif'; - comment = cmt; - } in - (id, Component cpnt_desc, decl.Syntax.info) - -and resolve_dimensions ctx subs = - let resolve_dimension sub = match sub.Syntax.nature with - | Syntax.Colon -> Colon - | Syntax.Subscript expr -> - Expression (resolve_subscript_expression ctx expr) in - let resolve_dimensions' = function - | None -> [] - | Some { Syntax.nature = Syntax.Subscripts subs_elts } -> - List.map resolve_dimension subs_elts in - resolve_dimensions' subs - -and base_class_type ctx cl_spec base_class = - match (evaluate base_class).info.type_description with - | Types.ClassElement cl_spec -> evaluate cl_spec - | Types.ComponentTypeElement _ -> - raise (CompilError - {err_msg = ["_CannotInheritFrom"; "_ComponentTypeElement"]; - err_info = - [("_ElemFound", Syntax.string_of_expression cl_spec)]; - err_ctx = {ctx with location = cl_spec.Syntax.info}}) (*error*) - | Types.PredefinedTypeElement _ -> - raise (CompilError - {err_msg = ["_CannotInheritFrom"; "_PredefinedTypeElement"]; - err_info = - [("_ElemFound", Syntax.string_of_expression cl_spec)]; - err_ctx = {ctx with location = cl_spec.Syntax.info}}) (*error*) - | Types.ComponentElement _ -> - raise (CompilError - {err_msg = ["_CannotInheritFrom"; "_ComponentElement"]; - err_info = []; - err_ctx = {ctx with location = cl_spec.Syntax.info}}) (*error*) - -and component_type ctx (flow, var, inout) base_type dims = - let base_type = evaluate base_type in - let lower_variability var var' = match var, var' with - | Some Types.Constant, - (Types.Constant | Types.Parameter | Types.Discrete | Types.Continuous) -> - Types.Constant - | Some Types.Parameter, - (Types.Parameter | Types.Discrete | Types.Continuous) -> Types.Parameter - | Some Types.Discrete, (Types.Discrete | Types.Continuous) -> Types.Discrete - | Some Types.Continuous, Types.Continuous -> Types.Continuous - | None, _ -> var' - | Some var, (Types.Constant | Types.Parameter | Types.Discrete) -> - raise (CompilError - {err_msg = ["_VariablityConflictsInCompDef"]; - err_info = - [("_TypePrefix", Types.string_of_variability var); - ("_TypeSpecifierVariability", Types.string_of_variability var')]; - err_ctx = ctx}) (*error*) - and propagate_causality inout inout' = match inout, inout' with - | Types.Acausal, (Types.Acausal | Types.Input | Types.Output) -> inout' - | (Types.Input | Types.Output), Types.Acausal -> inout - | Types.Input, Types.Input | Types.Output, Types.Output -> inout - | Types.Input, Types.Output | Types.Output, Types.Input -> - raise (CompilError - {err_msg = ["_CausalityConflictsInCompDef"]; - err_info = [("_TypePrefix", Types.string_of_causality inout); - ("_TypeSpecifierCausality", - Types.string_of_causality inout')]; - err_ctx = ctx}) (*error*) in - let predefined_type_variability predef = match predef with - | { Types.base_type = Types.RealType } -> Types.Continuous - | _ -> Types.Discrete in - let rec class_specifier_variability cl_spec = match cl_spec with - | Types.PredefinedType predef -> predefined_type_variability predef - | Types.ClassType cl_type -> Types.Continuous - | Types.ComponentType cpnt_type -> evaluate cpnt_type.Types.variability - | Types.ArrayType (dim, cl_spec) -> class_specifier_variability cl_spec - | Types.TupleType cl_specs -> assert false in - match base_type.info.type_description with - | Types.ComponentElement _ -> - raise (CompilError - {err_msg = ["class"; "_ElemExpected"]; - err_info = [("TypeFound", "_ComponentElement")]; - err_ctx = ctx}) (*error*) - | Types.ClassElement cl_spec -> - let cl_spec = evaluate cl_spec in - let var' = class_specifier_variability cl_spec in - let var' = lazy (lower_variability var var') - and base_class = lazy (add_dimensions dims cl_spec) in - component_element (lazy flow) var' (lazy inout) base_class - | Types.ComponentTypeElement cpnt_type -> - let flow' = lazy (flow || evaluate cpnt_type.Types.flow) - and var' = - lazy (lower_variability var (evaluate cpnt_type.Types.variability)) - and inout' = - lazy (propagate_causality inout (evaluate cpnt_type.Types.causality)) - and base_class = - lazy (add_dimensions dims (Types.ComponentType cpnt_type)) in - component_element flow' var' inout' base_class - | Types.PredefinedTypeElement predef -> - let var' = predefined_type_variability predef in - let var' = lazy (lower_variability var var') - and base_class = - lazy (add_dimensions dims (Types.PredefinedType predef)) in - component_element (lazy flow) var' (lazy inout) base_class - -and add_dimensions dims cl_spec = - let add_dimension dim cl_spec = match dim with - | Expression { nature = Integer i } -> - Types.ArrayType (Types.ConstantDimension i, cl_spec) - | Expression _ -> Types.ArrayType (Types.ParameterDimension, cl_spec) - | Colon -> Types.ArrayType (Types.DiscreteDimension, cl_spec) in - List.fold_right add_dimension (evaluate dims) cl_spec - -and modified_described_type ctx cpnt_type cl_modif = - let cpnt_type' = evaluate cpnt_type in - let cl_spec = cpnt_type'.Types.base_class in - { cpnt_type' with - Types.base_class = - lazy (modify_class_specifier ctx (evaluate cl_modif) cl_spec) - } - -and modified_class_type ctx cl_spec cl_modif = - let cl_spec' = modify_class_specifier ctx (evaluate cl_modif) cl_spec in - match cl_spec' with - | Types.ClassType cl_type -> cl_type - | Types.PredefinedType _ | Types.ComponentType _ | Types.ArrayType _ | - Types.TupleType _ -> - raise (CompilError - {err_msg = ["class"; "_ElemExpected"]; - err_info = [("TypeFound", - Types.string_of_class_specifier cl_spec')]; - err_ctx = ctx}) (*error*) - -and modified_component_type ctx cpnt_type modif = - let modified_component_type' = function - | Modification (cl_modif, _) -> modify_component_type ctx cl_modif cpnt_type - | Assignment _ | Equality _ -> cpnt_type in - match evaluate modif with - | None -> cpnt_type - | Some modif' -> modified_component_type' modif' - -(* We can abstract dimensions away since they have been already checked at *) -(* modification resolution time. *) -and modify_class_specifier ctx cl_modif cl_spec = - let rec modify_class_specifier' cl_spec' = match cl_spec' with - | Types.PredefinedType predef -> - Types.PredefinedType (modify_predefined_type ctx cl_modif predef) - | Types.ClassType cl_type -> - Types.ClassType (modify_class_type ctx cl_modif cl_type) - | Types.ComponentType cpnt_type -> - Types.ComponentType (modify_component_type ctx cl_modif cpnt_type) - | Types.ArrayType (dim, cl_spec) -> - Types.ArrayType (dim, modify_class_specifier' cl_spec) - | Types.TupleType _ -> - raise (CompilError - {err_msg = ["_InvalidTypeOfClassSpec"]; - err_info = [("_TypeFound", - Types.string_of_class_specifier cl_spec')]; - err_ctx = ctx}) (*error*) in - modify_class_specifier' (evaluate cl_spec) - -and modify_predefined_type ctx cl_modif predef = - { predef with - Types.attributes = - modify_predefined_attributes ctx cl_modif predef.Types.attributes - } - -and modify_predefined_attributes ctx cl_modif attrs = - let apply_modifications ((id, final) as attr) = function - | [] -> attr - | [_] when final -> assert false (*error*) - | [final', (Assignment _ | Equality _)] -> id, final' - | _ :: _ -> assert false (*error*) in - let modify_attribute ((id, _) as attr) = - let modifs, elt_descs = partition_modifications cl_modif id in - match modifs, elt_descs with - | [], [] -> attr - | _ :: _, [] -> apply_modifications attr modifs - | [], _ :: _ - | _ :: _, _ :: _ -> - raise (CompilError - {err_msg = ["_RedeclarePredefTypeAttrib"; id]; - err_info = []; - err_ctx = ctx}) (*error*) in - List.map modify_attribute attrs - -and modify_class_type ctx cl_modif cl_type = - let modify_named_element (id, elt_type) = - id, lazy (modify_element ctx cl_modif id (evaluate elt_type)) in - { cl_type with - Types.named_elements = - List.map modify_named_element cl_type.Types.named_elements - } - -and modify_element ctx cl_modif id elt_type = - let modifs, elt_descs = partition_modifications cl_modif id in - match modifs, elt_descs with - | [], [] -> elt_type - | _ :: _, [] -> apply_element_modifications ctx modifs elt_type id - | [], [elt_desc] -> apply_element_redeclaration ctx elt_desc elt_type - | [], _ :: _ :: _ -> - raise (CompilError - {err_msg = ["_InvalidElemModifDef"]; - err_info = []; - err_ctx = ctx}) (*error*) - | _ :: _, _ :: _ -> - raise (CompilError - {err_msg = ["_InvalidElemModifDef"]; - err_info = []; - err_ctx = ctx}) (*error*) - -and partition_modifications cl_modif id = - let add_element_modification modif_arg modifs = match modif_arg.action with - | Some (ElementModification modif) -> (modif_arg.final, modif) :: modifs - | None | Some (ElementRedeclaration _) -> modifs - and add_element_redeclaration modif_arg elt_descs = - match modif_arg.action with - | None | Some (ElementModification _) -> elt_descs - | Some (ElementRedeclaration elt_desc) -> - (modif_arg.final, elt_desc) :: elt_descs in - let is_current_element_modification modif_arg = modif_arg.target = id in - let cl_modif' = List.filter is_current_element_modification cl_modif in - let modifs = List.fold_right add_element_modification cl_modif' [] - and elt_descs = List.fold_right add_element_redeclaration cl_modif' [] in - modifs, elt_descs - -and apply_element_redeclaration ctx elt_desc elt_type = - raise (CompilError - {err_msg = ["_NotYetImplemented"; "_ElementRedeclaration"]; - err_info = []; - err_ctx = ctx}) - -and apply_element_modifications ctx modifs elt_type id = - let add_modification_arguments (final, modif) cl_modifs = match modif with - | Modification (cl_modif, _) -> (final, cl_modif) :: cl_modifs - | Assignment _ | Equality _ -> cl_modifs - and add_value_modification (final, modif) val_modifs = match modif with - | Modification (_, Some _) | Assignment _ | Equality _ -> - final :: val_modifs - | Modification (_, None) -> val_modifs in - let cl_modifs = List.fold_right add_modification_arguments modifs [] - and val_modifs = List.fold_right add_value_modification modifs [] in - let elt_type' = modify_element_type ctx cl_modifs elt_type id in - modify_element_value ctx val_modifs elt_type' id - -and modify_element_type ctx cl_modifs elt_type id = - let propagate_final_attribute final modif_arg cl_modif = - { modif_arg with final = final } :: cl_modif in - let merge_modifications (final, cl_modif) cl_modif' = - List.fold_right (propagate_final_attribute final) cl_modif cl_modif' in - let cl_modif = List.fold_right merge_modifications cl_modifs [] in - { elt_type with - Types.element_nature = modify_element_nature ctx cl_modif elt_type id - } - -and modify_element_nature ctx cl_modif elt_type id = - match elt_type.Types.element_nature with - | _ when elt_type.Types.final -> - raise (CompilError - {err_msg = ["_FinalElemModifNotAllowed"; id]; - err_info = []; - err_ctx = ctx}) (*error*) - | Types.ComponentElement cpnt_type -> - Types.ComponentElement (modify_component_type ctx cl_modif cpnt_type) - | Types.ClassElement cl_spec -> - let cl_spec' = lazy (modify_class_specifier ctx cl_modif cl_spec) in - Types.ClassElement cl_spec' - | Types.ComponentTypeElement cpnt_type -> - let cpnt_type' = modify_component_type ctx cl_modif cpnt_type in - Types.ComponentTypeElement cpnt_type' - | Types.PredefinedTypeElement predef -> - Types.PredefinedTypeElement (modify_predefined_type ctx cl_modif predef) - -and modify_element_value ctx val_modifs elt_type id = - match val_modifs with - | [] -> elt_type - | [_] when elt_type.Types.final -> - raise (CompilError - {err_msg = ["_FinalElemModifNotAllowed"; id]; - err_info = []; - err_ctx = ctx}) (*error*) - | [final] -> { elt_type with Types.final = final } - | _ :: _ :: _ -> - raise (CompilError - {err_msg = ["_DuplicatedModifOfElem"; id]; - err_info = []; - err_ctx = ctx}) (*error*) - -and modify_component_type ctx cl_modif cpnt_type = - { cpnt_type with - Types.base_class = - lazy (modify_class_specifier ctx cl_modif cpnt_type.Types.base_class) - } - -and resolve_type_modification ctx cpnt_type cl_modif = - let cl_spec = (evaluate cpnt_type).Types.base_class in - resolve_class_modification_option ctx cl_spec cl_modif - -and resolve_component_modification ctx cpnt_type = function - | None -> None - | Some modif' -> - let elt_nat = Types.ComponentElement (evaluate cpnt_type) in - Some (resolve_modification ctx elt_nat modif') - -and resolve_class_modification_option ctx cl_spec = function - | None -> [] - | Some cl_modif -> resolve_class_modification ctx cl_spec cl_modif - -and resolve_modification ctx elt_nat modif = - let ctx = {ctx with location = modif.Syntax.info} in - match elt_nat, modif.Syntax.nature with - | Types.ComponentElement cpnt_type, Syntax.Modification (cl_modif, expr) | - Types.ComponentTypeElement cpnt_type, - Syntax.Modification (cl_modif, (None as expr)) -> - resolve_component_type_modification ctx cpnt_type cl_modif expr - | Types.ComponentTypeElement _, Syntax.Modification (_, Some _) -> - raise (CompilError - {err_msg = ["_InvalidClassElemModif"]; - err_info = []; - err_ctx = ctx}) (*error*) - | Types.ClassElement cl_spec, Syntax.Modification (cl_modif, None) -> - let cl_modif' = resolve_class_modification ctx cl_spec cl_modif in - Modification (cl_modif', None) - | Types.ClassElement _, Syntax.Modification (_, Some _) -> - raise (CompilError - {err_msg = ["_InvalidClassElemModif"]; - err_info = []; - err_ctx = ctx}) (*error*) - | (Types.PredefinedTypeElement _), - (Syntax.Modification _ | Syntax.Eq _ | Syntax.ColEq _) -> - raise (CompilError - {err_msg = ["_InvalidClassElemModif"]; - err_info = []; - err_ctx = ctx}) (*error*) - | Types.ComponentElement cpnt_type, Syntax.Eq expr -> - let expr' = lazy (resolve_modification_equation ctx cpnt_type expr) in - Equality expr' - | Types.ComponentElement cpnt_type, Syntax.ColEq expr -> - let expr' = lazy (resolve_modification_algorithm ctx cpnt_type expr) in - Assignment expr' - | (Types.ClassElement _ | Types.ComponentTypeElement _), - (Syntax.Eq _ | Syntax.ColEq _) -> - raise (CompilError - {err_msg = ["_InvalidClassElemModif"]; - err_info = []; - err_ctx = ctx}) (*error*) - -and resolve_component_type_modification ctx cpnt_type cl_modif expr = - let ctx = {ctx with location = cl_modif.Syntax.info} in - let cl_spec = cpnt_type.Types.base_class in - let cl_modif' = resolve_class_modification ctx cl_spec cl_modif in - let cpnt_type' = modify_component_type ctx cl_modif' cpnt_type in - let expr' = resolve_value_modification_option ctx cpnt_type' expr in - Modification (cl_modif', expr') - -and resolve_value_modification_option ctx cpnt_type = function - | None -> None - | Some expr -> Some (lazy (resolve_modification_equation ctx cpnt_type expr)) - -and resolve_modification_equation ctx cpnt_type expr = - let ctx = {ctx with location = expr.Syntax.info} in - let resolve_modification_equation' cpnt_type' expr' = - let var = evaluate cpnt_type.Types.variability - and var' = evaluate cpnt_type'.Types.variability in - match Types.compare_component_types cpnt_type cpnt_type' with - | Types.SameType - when Types.higher_variability var var' -> expr' - | Types.SameType -> - let var = Types.string_of_variability var - and var' = Types.string_of_variability var' in - raise (CompilError - {err_msg = ["_VariabilityConflicts"]; - err_info = [("_ExprKind", "A = B"); - ("_VariabilityOfA", var); - ("_VariabilityOfB", var')]; - err_ctx = ctx}) (*error*) - | _ -> - let type_A = Types.string_of_component_type cpnt_type - and type_B = Types.string_of_component_type cpnt_type' in - raise (CompilError - {err_msg = [ "_EquTermsNotOfTheSameType"]; - err_info = [("_ExprKind", "A = B"); - ("_TypeOfA", type_A); - ("_TypeOfB", type_B)]; - err_ctx = ctx}) (*error*) in - let expr' = resolve_expression ctx expr in - let expr' = apply_rhs_coercions cpnt_type expr' in - match expr'.info.type_description with - | Types.ComponentElement cpnt_type' -> - resolve_modification_equation' cpnt_type' expr' - | Types.ClassElement _ | Types.ComponentTypeElement _ | - Types.PredefinedTypeElement _ -> - raise (CompilError - {err_msg = ["_ClassElemFoundInExpr"]; - err_info = []; - err_ctx = ctx}) (*error*) - -and resolve_modification_algorithm ctx cpnt_type expr = - let ctx = {ctx with location = expr.Syntax.info} in - let resolve_modification_algorithm' cpnt_type' expr' = - let var = evaluate cpnt_type.Types.variability - and var' = evaluate cpnt_type'.Types.variability in - match Types.compare_component_types cpnt_type cpnt_type' with - | Types.SameType - when Types.higher_variability var var' -> expr' - | Types.SameType -> - let var = Types.string_of_variability var - and var' = Types.string_of_variability var' in - raise (CompilError - {err_msg = ["_VariabilityConflicts"]; - err_info = [("_ExprKind", "A := B"); - ("_VariabilityOfA", var); - ("_VariabilityOfB", var')]; - err_ctx = ctx}) (*error*) - | _ -> - let type_A = Types.string_of_component_type cpnt_type - and type_B = Types.string_of_component_type cpnt_type' in - raise (CompilError - {err_msg = [ "_TypeConflictsInAssign"]; - err_info = [("_ExprKind", "A := B"); - ("_TypeOfA", type_A); - ("_TypeOfB", type_B)]; - err_ctx = ctx}) (*error*) in - let expr' = resolve_expression ctx expr in - let expr' = apply_rhs_coercions cpnt_type expr' in - match expr'.info.type_description with - | Types.ComponentElement cpnt_type' -> - resolve_modification_algorithm' cpnt_type' expr' - | Types.ClassElement _ | Types.ComponentTypeElement _ | - Types.PredefinedTypeElement _ -> - raise (CompilError - {err_msg = ["_ClassElemFoundInExpr"]; - err_info = []; - err_ctx = ctx}) (*error*) - -and resolve_class_modification ctx cl_spec cl_modif = - match cl_modif.Syntax.nature with - | Syntax.ClassModification args -> - List.map (resolve_modification_argument ctx cl_spec) args - -and resolve_modification_argument ctx cl_spec arg = - let ctx = {ctx with location = arg.Syntax.info} in - let apply_each each = - let rec drop_dimensions cl_spec = match cl_spec with - | Types.ArrayType (_, cl_spec') -> drop_dimensions cl_spec' - | Types.PredefinedType _ | Types.ClassType _ | Types.ComponentType _ | - Types.TupleType _ -> cl_spec in - let cl_spec' = evaluate cl_spec in - match cl_spec' with - | Types.ArrayType _ when each -> drop_dimensions cl_spec' - | Types.PredefinedType _ - | Types.ClassType _ - | Types.ComponentType _ - | Types.TupleType _ when each -> - raise (CompilError - {err_msg = ["_EachAppliedToNonArrayElem"]; - err_info = []; - err_ctx = ctx}) (*error*) - | Types.ArrayType _ | Types.PredefinedType _ | Types.ClassType _ | - Types.ComponentType _ | Types.TupleType _ -> cl_spec' in - match arg.Syntax.nature with - | Syntax.ElementModification (each, final, expr, modif, _) -> - let each' = bool_of_each each - and final' = bool_of_final final in - let cl_spec' = apply_each each' in - resolve_element_modification ctx cl_spec' each' final' expr modif - | Syntax.ElementRedeclaration (each, final, elt_def) -> - let each' = bool_of_each each - and final' = bool_of_final final in - let cl_spec' = apply_each each' in - resolve_element_redeclaration ctx cl_spec' each' final' elt_def - -and bool_of_each = function - | None -> false - | Some Syntax.Each -> true - -and bool_of_final = function - | None -> false - | Some Syntax.Final -> true - -and resolve_element_modification ctx cl_spec each final expr modif = - let ctx = {ctx with location = expr.Syntax.info} in - let rec path_of_expression path expr = match expr.Syntax.nature with - | Syntax.Identifier id -> - modification_arguments_of_path cl_spec each final id (List.rev path) - | Syntax.FieldAccess (expr, id) -> path_of_expression (id :: path) expr - | _ -> - raise (CompilError - {err_msg = ["_InvalidExprInElemModif"]; - err_info = []; - err_ctx = ctx}) (*error*) - and modification_arguments_of_path cl_spec each final id path = - let flow = false - and var = Types.Continuous - and inout = Types.Acausal in - let elt_nat = element_field_type_nature ctx flow var inout cl_spec id in - { - each = each; - final = final; - target = id; - action = resolve_modification_action ctx modif elt_nat path - } - and resolve_modification_action ctx modif elt_nat = function - | [] -> resolve_modification_option ctx elt_nat modif - | id :: path -> - raise (CompilError - {err_msg = ["_NotYetImplemented"; "_FieldAccessInElemModifExpr"]; - err_info = []; - err_ctx = ctx}) - and resolve_modification_option ctx elt_nat = function - | None -> None - | Some modif -> - Some (ElementModification (resolve_modification ctx elt_nat modif)) in - path_of_expression [] expr - -and resolve_element_redeclaration ctx cl_spec each final elt_def = - let ctx = {ctx with location = elt_def.Syntax.info} in - raise (CompilError - {err_msg = ["_NotYetImplemented"; "_ElementRedeclaration"]; - err_info = []; - err_ctx = ctx}) - -and resolve_unnamed_elements ctx other_elts = - let class_kind = - let class_context' cl_spec = match cl_spec with - | Types.ClassType cl_type -> - Some (evaluate cl_type.Types.kind) - | _ -> None in - match ctx.context_nature with - | ClassContext cl_def -> - class_context' (evaluate cl_def.class_type) - | _ -> None in - let add_equation_or_algorithm_clause other_elt acc = - match other_elt.Syntax.nature, class_kind with - | (Syntax.EquationClause _), Some kind - when List.mem kind [Types.Function; Types.Record; Types.Connector] -> - raise (CompilError - {err_msg = ["_EquNotAllowedInTheDefOf"; Types.string_of_kind kind]; - err_info = []; - err_ctx = ctx}) (*error*) - | Syntax.EquationClause (init, equ_defs), _ -> - let init' = bool_of_initial init - and equ_defs' = resolve_equation_definitions ctx equ_defs in - EquationClause (init', equ_defs') :: acc - | Syntax.AlgorithmClause (init, algo_defs), _ -> - let init' = bool_of_initial init - and algo_defs' = resolve_algorithm_definitions ctx algo_defs in - AlgorithmClause (init', algo_defs') :: acc - | (Syntax.Public _ | Syntax.Protected _), _ -> acc in - List.fold_right add_equation_or_algorithm_clause other_elts [] - -and bool_of_initial = function - | None -> Permanent - | Some Syntax.Initial -> Initial - -and resolve_equation_definitions ctx equ_defs = - let resolve_equation_definition equ_def = match equ_def.Syntax.nature with - | Syntax.Equation (equ, _, _) -> resolve_equation ctx equ in - List.flatten (List.map resolve_equation_definition equ_defs) - -and resolve_algorithm_definitions ctx algo_defs = - let resolve_algorithm_definition algo_def = match algo_def.Syntax.nature with - | Syntax.Algorithm (algo, _, _) -> resolve_algorithm ctx algo in - List.map resolve_algorithm_definition algo_defs - -and resolve_equation ctx equ = - let ctx = {ctx with location = equ.Syntax.info} in - match equ.Syntax.nature with - | Syntax.Equal (expr, expr') -> resolve_equal ctx equ expr expr' - | Syntax.ConditionalEquationE (alts, default) -> - resolve_conditional_equation_e ctx equ alts default - | Syntax.ForClauseE (for_inds, equs) -> - resolve_for_clause_e ctx equ for_inds equs - | Syntax.ConnectClause (expr, expr') -> - resolve_connect_clause ctx equ expr expr' - | Syntax.WhenClauseE alts -> - resolve_when_clause_e ctx equ alts - | Syntax.FunctionCallE (expr, fun_args) -> - resolve_functional_call_e ctx equ expr fun_args - -and resolve_equal ctx equ expres expres' = - let resolve_equal' cpnt_type expr cpnt_type' expr' = - let resolved_equation syn expr expr' = - { - nature = Equal (expr, expr'); - info = syn - } in - let var = evaluate cpnt_type.Types.variability - and var' = evaluate cpnt_type'.Types.variability in - match var, var' with - | Types.Continuous, _ | _, Types.Continuous -> - equations ctx equ resolved_equation cpnt_type expr cpnt_type' expr' - | Types.Discrete, _ | _, Types.Discrete - when expression_of_variable expres -> - equations ctx equ resolved_equation cpnt_type expr cpnt_type' expr' - | Types.Discrete, _ | _, Types.Discrete -> - raise (CompilError - {err_msg = ["_LHSOfDiscreteEquMustBeAVar"]; - err_info = []; - err_ctx = {ctx with location = expres.Syntax.info}}) (*error*) - | _ -> - equations ctx equ resolved_equation cpnt_type expr cpnt_type' expr' in - let expr = resolve_expression ctx expres - and expr' = resolve_expression ctx expres' in - let exprs = apply_binary_coercions [ expr; expr' ] in - let expr = List.nth exprs 0 - and expr' = List.nth exprs 1 in - let elt_nat = expr.info.type_description - and elt_nat' = expr'.info.type_description in - match elt_nat, elt_nat' with - | Types.ComponentElement cpnt_type, Types.ComponentElement cpnt_type' -> - resolve_equal' cpnt_type expr cpnt_type' expr' - | (Types.ClassElement _ | Types.ComponentTypeElement _ | - Types.PredefinedTypeElement _), _ -> - let ctx = {ctx with location = expres.Syntax.info} in - raise (CompilError - {err_msg = ["_ClassElemFoundInExpr"]; - err_info = []; - err_ctx = ctx}) (*error*) - | _, (Types.ClassElement _ | Types.ComponentTypeElement _ | - Types.PredefinedTypeElement _) -> - let ctx = {ctx with location = expres'.Syntax.info} in - raise (CompilError - {err_msg = ["_ClassElemFoundInExpr"]; - err_info = []; - err_ctx = ctx}) (*error*) - -and resolve_conditional_equation_e ctx equ alts default = - let resolve_alternative (expr, equs) = - let ctx = {ctx with location = expr.Syntax.info} in - let expr' = resolve_expression ctx expr in - let resolve_alternative' cpnt_type = - let cl_spec = evaluate cpnt_type.Types.base_class in - match cl_spec with - | Types.PredefinedType { Types.base_type = Types.BooleanType } -> - let equs' = List.flatten (List.map (resolve_equation ctx) equs) in - expr', equs' - | Types.PredefinedType _ | Types.ClassType _ | Types.ComponentType _ | - Types.ArrayType _ | Types.TupleType _ -> - raise (CompilError - {err_msg = ["_NonBooleanIfCondExpr"]; - err_info = - [("_ExprKind", "...if A then..."); - ("_TypeOfA", Types.string_of_class_specifier cl_spec)]; - err_ctx = ctx}) (*error*) in - match expr'.info.type_description with - | Types.ComponentElement cpnt_type -> resolve_alternative' cpnt_type - | Types.ClassElement _ | Types.ComponentTypeElement _ | - Types.PredefinedTypeElement _ -> - raise (CompilError - {err_msg = ["_ClassElemFoundInExpr"]; - err_info = []; - err_ctx = ctx}) (*error*) in - let alts' = List.map resolve_alternative alts in - let default' = match default with - | None -> [] - | Some equs -> List.flatten (List.map (resolve_equation ctx) equs) in - [{ - nature = ConditionalEquationE (alts', default'); - info = Some equ - }] - -and resolve_for_clause_e ctx equ for_inds equs = - let range_element_type expr range = - let ctx = {ctx with location = expr.Syntax.info} in - let sub_dimension cl_spec = match cl_spec with - | Types.ArrayType (dim, cl_spec) -> cl_spec - | Types.PredefinedType _ | Types.ClassType _ | - Types.ComponentType _ | Types.TupleType _ -> - raise (CompilError - {err_msg = ["_InvalidTypeInRangeExpr"]; - err_info = - [("_ExpectedType", "Integer"); - ("_TypeFound", Types.string_of_class_specifier cl_spec)]; - err_ctx = ctx}) (*error*) in - match range.info.type_description with - | Types.ComponentElement cpnt_type -> - let cl_spec = evaluate cpnt_type.Types.base_class in - let cpnt_type' = - { cpnt_type with - Types.base_class = lazy (sub_dimension cl_spec) - } in - Types.ComponentElement cpnt_type' - | Types.ClassElement _ | Types.ComponentTypeElement _ | - Types.PredefinedTypeElement _ -> - raise (CompilError - {err_msg = ["_ClassElemFoundInExpr"]; - err_info = []; - err_ctx = ctx}) (*error*) in - let rec resolve_for_clause_e' acc ctx = function - | [] -> - let equs' = List.flatten (List.map (resolve_equation ctx) equs) in - [{ - nature = ForClauseE (List.rev acc, equs'); - info = Some equ - }] - | (_, None) :: _ -> - raise (CompilError - {err_msg = ["_NotYetImplemented"; "_ImplicitIterRange"]; - err_info = []; - err_ctx = ctx}) - | (id, Some expr) :: for_inds -> - let range = resolve_expression ctx expr in - let elt_nat = range_element_type expr range in - let ctx' = - { ctx with - context_nature = ForContext (ctx, id, elt_nat) - } in - resolve_for_clause_e' (range :: acc) ctx' for_inds in - resolve_for_clause_e' [] ctx for_inds - -and resolve_connect_clause ctx equ expres expres' = - let expr = resolve_expression ctx expres - and expr' = resolve_expression ctx expres' in - let resolve_connect_clause' cpnt_typ cpnt_typ' = - let rec class_type_of_class_specifier cl_spec = match cl_spec with - | Types.ClassType cl_type -> cl_type - | Types.ComponentType cpnt_type -> - let cl_spec = evaluate cpnt_type.Types.base_class in - class_type_of_class_specifier cl_spec - | Types.ArrayType (_, cl_spec) -> class_type_of_class_specifier cl_spec - | Types.PredefinedType _ | Types.TupleType _ -> - raise (CompilError - {err_msg = ["_InvalidTypeOfArgInConnectStat"]; - err_info = - [("_ExprKind", "connect(A, B)"); - ("_TypeOfA", Types.string_of_component_type cpnt_typ); - ("_TypeOfB", Types.string_of_component_type cpnt_typ')]; - err_ctx = ctx}) (*error*) in - let connector_sign expr = - let is_connector_type expr = - let is_connector_type' cpnt_type = - let cl_spec = evaluate cpnt_type.Types.base_class in - let cl_type = class_type_of_class_specifier cl_spec in - match evaluate cl_type.Types.kind with - | Types.Connector | Types.ExpandableConnector -> true - | Types.Class | Types.Model | Types.Block -> false - | Types.Record -> - raise (CompilError - {err_msg = - ["record"; "_InstanceUsedInConnection"]; - err_info = []; - err_ctx = ctx}) (*error*) - | Types.Package -> - raise (CompilError - {err_msg = - ["package"; "_InstanceUsedInConnection"]; - err_info = []; - err_ctx = ctx}) (*error*) - | Types.Function -> - raise (CompilError - {err_msg = - ["function"; "_InstanceUsedInConnection"]; - err_info = []; - err_ctx = ctx}) (*error*) in - match expr.info.type_description with - | Types.ComponentElement cpnt_type -> - is_connector_type' cpnt_type - | _ -> - raise (CompilError - {err_msg = ["_ClassElemFoundInExpr"]; - err_info = []; - err_ctx = ctx}) (*error*) in - let is_connectable expr = - let is_connectable' cpnt_type = - let cl_spec = evaluate cpnt_type.Types.base_class in - let cl_type = class_type_of_class_specifier cl_spec in - match evaluate cl_type.Types.kind with - | Types.Class | Types.Model | Types.Block -> true - | Types.Connector | Types.ExpandableConnector -> false - | Types.Record -> - raise (CompilError - {err_msg = - ["record"; "_InstanceUsedInConnection"]; - err_info = []; - err_ctx = ctx}) (*error*) - | Types.Package -> - raise (CompilError - {err_msg = - ["package"; "_InstanceUsedInConnection"]; - err_info = []; - err_ctx = ctx}) (*error*) - | Types.Function -> - raise (CompilError - {err_msg = - ["function"; "_InstanceUsedInConnection"]; - err_info = []; - err_ctx = ctx}) (*error*) in - match expr.info.type_description with - | Types.ComponentElement cpnt_type -> - is_connectable' cpnt_type - | _ -> - raise (CompilError - {err_msg = ["_ClassElemFoundInExpr"]; - err_info = []; - err_ctx = ctx}) (*error*) in - let rec connector_sign' expr = match expr.nature with - | LocalIdentifier (0, _) when is_connector_type expr -> Some Negative - | LocalIdentifier (0, _) when is_connectable expr -> Some Positive - | (FieldAccess (expr', _) | IndexedAccess (expr', _)) - when is_connector_type expr -> connector_sign' expr' - | (FieldAccess (expr', _) | IndexedAccess (expr', _)) - when is_connectable expr' -> connector_sign' expr' - | _ -> - raise (CompilError - {err_msg = ["_InvalidTypeOfArgInConnectStat"]; - err_info = - [("_ExprKind", "connect(A, B)"); - ("_TypeOfA", Types.string_of_component_type cpnt_typ); - ("_TypeOfB", Types.string_of_component_type cpnt_typ')]; - err_ctx = ctx}) (*error*) in - match expr.nature with - | _ when not (is_connector_type expr) -> - raise (CompilError - {err_msg = ["_InvalidTypeOfArgInConnectStat"]; - err_info = - [("_ExprKind", "connect(A, B)"); - ("_TypeOfA", Types.string_of_component_type cpnt_typ); - ("_TypeOfB", Types.string_of_component_type cpnt_typ')]; - err_ctx = ctx}) (*error*) - | LocalIdentifier (0, _) -> Some Negative - | _ -> connector_sign' expr in - let connect sign cpnt_type sign' cpnt_type' = - let resolved_equation syn expr expr' = - let elt_nat = expr.info.type_description - and elt_nat' = expr'.info.type_description in - let flow, _, _ = type_prefixes_of_element_nature elt_nat - and flow', _, _ = type_prefixes_of_element_nature elt_nat' in - match flow, flow' with - | false, false -> - { - nature = Equal (expr, expr'); - info = syn - } - | true, true -> - { - nature = ConnectFlows (sign, expr, sign', expr'); - info = syn - } - | false, true -> - raise (CompilError - {err_msg = ["_CannotConnectFlowAndNonFlowComp"]; - err_info = - [("_ExprKind", "connect(A, B)"); - ("_TypeOfA", "non-flow connector"); - ("_TypeOfB", "flow connector")]; - err_ctx = ctx}) (*error*) - | true, false -> - raise (CompilError - {err_msg = ["_CannotConnectFlowAndNonFlowComp"]; - err_info = - [("_ExprKind", "connect(A, B)"); - ("_TypeOfA", "flow connector"); - ("_TypeOfB", "non-flow connector")]; - err_ctx = ctx}) (*error*) in - equations ctx equ resolved_equation cpnt_type expr cpnt_type' expr' in - match connector_sign expr, connector_sign expr' with - | Some sign, Some sign' -> connect sign cpnt_typ sign' cpnt_typ' - | None, Some _ -> assert false - | Some _, None -> assert false - | None, None -> assert false in - let elt_nat = expr.info.type_description - and elt_nat' = expr'.info.type_description in - match elt_nat, elt_nat' with - | Types.ComponentElement cpnt_typ, Types.ComponentElement cpnt_typ' -> - resolve_connect_clause' cpnt_typ cpnt_typ' - | _, _ -> - raise (CompilError - {err_msg = ["_InvalidTypeOfArgInConnectStat"]; - err_info = - [("_ExprKind", "connect(A, B)"); - ("_TypeOfA", Types.string_of_element_nature elt_nat); - ("_TypeOfB", Types.string_of_element_nature elt_nat')]; - err_ctx = ctx}) (*error*) - -and resolve_when_clause_e ctx equ alts = - let resolve_alternative (expr, equs) = - let expr' = resolve_expression ctx expr in - let rec check_equation equ = - let check_equal expr expr' = - match expr.Syntax.nature, expr'.Syntax.nature with - | _, _ when expression_of_variable expr -> true - | Syntax.Tuple exprs, Syntax.FunctionCall _ - when List.for_all expression_of_variable exprs -> true - | _, _ -> raise (CompilError - {err_msg = ["_InvalidWhenEquation"]; - err_info = []; - err_ctx = {ctx with location = expr.Syntax.info}}) (*error*) in - let check_alternative (expr, equs) = - List.for_all check_equation equs in - let check_function_call_e expr fun_args = - match expr.Syntax.nature with - | Syntax.Identifier "assert" | - Syntax.Identifier "terminate" | - Syntax.Identifier "reinit" -> true - | _ -> - raise (CompilError - {err_msg = ["_InvalidWhenEquation"]; - err_info = []; - err_ctx = {ctx with location = expr.Syntax.info}}) in - match equ.Syntax.nature with - | Syntax.Equal (expr, expr') -> check_equal expr expr' - | Syntax.ConditionalEquationE (alts, None) -> - List.for_all check_alternative alts - | Syntax.ConditionalEquationE (alts, Some equs) -> - (List.for_all check_alternative alts) && - (List.for_all check_equation equs) - | Syntax.ForClauseE (for_inds, equs) -> - List.for_all check_equation equs - | Syntax.ConnectClause (expr, expr') -> - raise (CompilError - {err_msg = ["_InvalidWhenEquation"]; - err_info = []; - err_ctx = {ctx with location = equ.Syntax.info}}) (*error*) - | Syntax.WhenClauseE alts -> - raise (CompilError - {err_msg = ["_WhenClausesCannotBeNested"]; - err_info = []; - err_ctx = {ctx with location = equ.Syntax.info}}) (*error*) - | Syntax.FunctionCallE (expr, fun_args) -> - check_function_call_e expr fun_args in - let resolve_alternative' cpnt_type = - let cl_spec = evaluate cpnt_type.Types.base_class in - match cl_spec with - | Types.ArrayType (Types.DiscreteDimension, _) -> - raise (CompilError - {err_msg = ["_InvalidTypeOfWhenCond"]; - err_info = - [("_ExprKind", "...when A then..."); - ("_TypeOfA", Types.string_of_class_specifier cl_spec)]; - err_ctx = {ctx with location = expr.Syntax.info}}) (*error*) - | Types.PredefinedType { Types.base_type = Types.BooleanType } | - Types.ArrayType - (_, Types.PredefinedType { Types.base_type = Types.BooleanType }) - when List.for_all check_equation equs -> - let equs' = List.flatten (List.map (resolve_equation ctx) equs) in - expr', equs' - | Types.PredefinedType _ | Types.ClassType _ | Types.ComponentType _ | - Types.ArrayType _ | Types.TupleType _ -> - raise (CompilError - {err_msg = ["_InvalidTypeOfWhenCond"]; - err_info = - [("_ExprKind", "...when A then..."); - ("_TypeOfA", Types.string_of_class_specifier cl_spec)]; - err_ctx = {ctx with location = expr.Syntax.info}}) (*error*) in - match expr'.info.type_description with - | Types.ComponentElement cpnt_type - when (evaluate cpnt_type.Types.variability) <> Types.Continuous -> - resolve_alternative' cpnt_type - | Types.ComponentElement cpnt_type -> - raise (CompilError - {err_msg = ["_WhenConditionMustBeDiscrete"]; - err_info = []; - err_ctx = {ctx with location = expr.Syntax.info}}) (*error*) - | Types.ClassElement _ | Types.ComponentTypeElement _ | - Types.PredefinedTypeElement _ -> - raise (CompilError - {err_msg = ["_ClassElemFoundInExpr"]; - err_info = []; - err_ctx = {ctx with location = expr.Syntax.info}}) (*error*) in - let alts' = List.map resolve_alternative alts in - [{ - nature = WhenClauseE alts'; - info = Some equ - }] - -and resolve_functional_call_e ctx equ expr fun_args = - let ctx = {ctx with location = equ.Syntax.info} in - let res = - let nat = Tuple [] - and elt_nat = Types.empty_tuple_type Types.Constant in - resolved_expression None nat elt_nat in - let fun_call = resolve_function_call ctx None expr fun_args in - let resolve_functional_call_e cpnt_type = - let cl_spec = evaluate cpnt_type.Types.base_class in - match cl_spec with - | Types.TupleType [] -> - [{ - nature = Equal (res, fun_call); - info = Some equ - }] - | _ -> - raise (CompilError - {err_msg = ["_NonEmptyFuncCallUsedAsAnEqu"]; - err_info = - [("_TypeOfFuncValue", Types.string_of_class_specifier cl_spec)]; - err_ctx = ctx}) (*error*) in - match fun_call.info.type_description with - | Types.ComponentElement cpnt_type -> resolve_functional_call_e cpnt_type - | Types.ClassElement _ | Types.ComponentTypeElement _ | - Types.PredefinedTypeElement _ -> - raise (CompilError - {err_msg = ["_ClassElemFoundInExpr"]; - err_info = []; - err_ctx = ctx}) (*error*) - -and equations ctx equ resolved_equation cpnt_type expr cpnt_type' expr' = - let equivalent_types predef predef' = - match Types.compare_predefined_types predef predef', - Types.compare_predefined_types predef' predef with - | _, Types.NotRelated | Types.NotRelated, _ -> false - | _ -> true in - let rec equations' i subs cl_spec expr cl_spec' expr' = - match cl_spec, cl_spec' with - | Types.PredefinedType predef, Types.PredefinedType predef' - when equivalent_types predef predef' -> - [equation subs expr expr'] - | Types.ComponentType cpnt_type, Types.ComponentType cpnt_type' -> - raise (CompilError - {err_msg = ["_NotYetImplemented"; "_ComponentTypeEqu"]; - err_info = []; - err_ctx = ctx}) - | Types.ClassType cl_type, Types.ClassType cl_type' -> - record_equations subs cl_type expr cl_type' expr' - | Types.ArrayType (dim, cl_spec), Types.ArrayType (dim', cl_spec') -> - [for_equation i subs dim cl_spec expr dim' cl_spec' expr'] - | Types.TupleType cl_specs, Types.TupleType cl_specs' -> - [{ - nature = Equal (expr, expr'); - info = Some equ - }] - | (Types.PredefinedType _ | Types.ComponentType _ | Types.ArrayType _ | - Types.TupleType _ | Types.ClassType _), - (Types.PredefinedType _ | Types.ComponentType _ | Types.ArrayType _ | - Types.TupleType _ | Types.ClassType _) -> - raise (CompilError - {err_msg = ["_EquTermsNotOfTheSameType"]; - err_info = - [("_ExprKind", "A = B"); - ("_TypeOfA", Types.string_of_class_specifier cl_spec); - ("_TypeOfB", Types.string_of_class_specifier cl_spec')]; - err_ctx = {ctx with location = equ.Syntax.info}}) (*error*) - and for_equation i subs dim cl_spec expr dim' cl_spec' expr' = - match dim, dim' with - | Types.ConstantDimension n, Types.ConstantDimension n' when n <> n' -> - let type_A = Types.string_of_component_type cpnt_type - and type_B = Types.string_of_component_type cpnt_type' in - raise (CompilError - {err_msg = ["_ArrayDimMismatchInEqu"]; - err_info = [("_ExprKind", "A = B"); - ("_TypeOfA", type_A); - ("_TypeOfB", type_B)]; - err_ctx = ctx}) (*error*) - | (Types.ConstantDimension _ | Types.ParameterDimension), - (Types.ConstantDimension _ | Types.ParameterDimension) -> - let range = resolve_colon ctx expr (Int32.of_int i) dim in - let subs = - let nat = LoopVariable (i - 1) - and elt_nat = Types.integer_type Types.Constant in - resolved_expression None nat elt_nat :: subs in - let equs = equations' (i + 1) subs cl_spec expr cl_spec' expr' in - { - nature = ForClauseE ([range], equs); - info = Some equ - } - | (Types.ConstantDimension _ | Types.ParameterDimension | - Types.DiscreteDimension), - (Types.ConstantDimension _ | Types.ParameterDimension | - Types.DiscreteDimension) -> - let type_A = Types.string_of_component_type cpnt_type - and type_B = Types.string_of_component_type cpnt_type' in - raise (CompilError - {err_msg = ["_ArrayDimMismatchInEqu"]; - err_info = [("_ExprKind", "A = B"); - ("_TypeOfA", type_A); - ("_TypeOfB", type_B)]; - err_ctx = ctx}) (*error*) - and record_equations subs cl_type expr cl_type' expr' = - let named_elts = cl_type.Types.named_elements - and named_elts' = cl_type'.Types.named_elements in - let record_equations' expr expr' = - let class_spec_of_element_type elt_type = - let elt_type' = evaluate elt_type in - element_nature_class ctx elt_type'.Types.element_nature in - let record_equation (id, elt_type) = - let elt_type' = - try - List.assoc id named_elts' - with _ -> - raise (CompilError - {err_msg = ["_EquTermsNotOfTheSameType"]; - err_info = - [("_ExprKind", "A = B"); - ("_TypeOfA", Types.string_of_component_type cpnt_type); - ("_TypeOfB", Types.string_of_component_type cpnt_type')]; - err_ctx = {ctx with location = equ.Syntax.info}}) (*error*) in - let cl_spec = class_spec_of_element_type elt_type - and cl_spec' = class_spec_of_element_type elt_type' in - let expr = - let nat = FieldAccess (expr, id) - and flow, var, inout = - type_prefixes_of_element_nature expr.info.type_description - and cl_spec = element_nature_class ctx expr.info.type_description in - let elt_nat = - element_field_type_nature ctx flow var inout cl_spec id in - resolved_expression None nat elt_nat - and expr' = - let nat = FieldAccess (expr', id) - and flow, var, inout = - type_prefixes_of_element_nature expr'.info.type_description - and cl_spec = element_nature_class ctx expr'.info.type_description in - let elt_nat = - element_field_type_nature ctx flow var inout cl_spec id in - resolved_expression None nat elt_nat in - equations' 1 [] cl_spec expr cl_spec' expr' in - List.flatten (List.map record_equation named_elts) in - match subs with - | [] -> record_equations' expr expr' - | subs -> - let expr = - let elt_nat = expr.info.type_description in - let nat = IndexedAccess (expr, subs) - and elt_nat' = scalar_element_nature elt_nat in - resolved_expression None nat elt_nat' - and expr' = - let elt_nat = expr'.info.type_description in - let nat = IndexedAccess (expr', subs) - and elt_nat' = scalar_element_nature elt_nat in - resolved_expression None nat elt_nat' in - record_equations' expr expr' - and equation subs expr expr' = match subs with - | [] -> resolved_equation (Some equ) expr expr' - | subs -> - let expr = - let elt_nat = expr.info.type_description in - let nat = IndexedAccess (expr, subs) - and elt_nat' = scalar_element_nature elt_nat in - resolved_expression None nat elt_nat' - and expr' = - let elt_nat = expr'.info.type_description in - let nat = IndexedAccess (expr', subs) - and elt_nat' = scalar_element_nature elt_nat in - resolved_expression None nat elt_nat' in - resolved_equation None expr expr' in - let cl_spec = evaluate cpnt_type.Types.base_class - and cl_spec' = evaluate cpnt_type'.Types.base_class in - equations' 1 [] cl_spec expr cl_spec' expr' - -and resolve_algorithm ctx algo = - let ctx = {ctx with location = algo.Syntax.info} in - match algo.Syntax.nature with - | Syntax.Assign _ | - Syntax.FunctionCallA _ | - Syntax.MultipleAssign _ | - Syntax.Break | - Syntax.Return | - Syntax.ConditionalEquationA _ | - Syntax.ForClauseA _ | - Syntax.WhileClause _ | - Syntax.WhenClauseA _ -> - raise (CompilError - {err_msg = ["_NotYetImplemented"; "_AlgoClause"]; - err_info = []; - err_ctx = ctx}) - -and resolve_expression ctx expr = - let ctx = {ctx with location = expr.Syntax.info} in - match expr.Syntax.nature with - | Syntax.BinaryOperation (kind, arg1, arg2) -> - resolve_binary_operation ctx expr kind arg1 arg2 - | Syntax.End -> resolve_end ctx expr - | Syntax.False -> resolve_false ctx expr - | Syntax.FieldAccess (expr', id) -> resolve_field_access ctx expr expr' id - | Syntax.FunctionCall (expr', fun_args) -> - resolve_function_call ctx (Some expr) expr' fun_args - | Syntax.Identifier id -> resolve_identifier ctx expr id - | Syntax.If (alts, expr') -> resolve_if ctx expr alts expr' - | Syntax.IndexedAccess (expr', subs) -> - resolve_indexed_access ctx expr expr' subs - | Syntax.Integer s -> resolve_integer ctx expr s - | Syntax.MatrixConstruction exprss -> - resolve_matrix_construction ctx expr exprss - | Syntax.NoEvent expr' -> - resolve_no_event ctx expr expr' - | Syntax.Range (start, step, stop) -> - resolve_range ctx expr start step stop - | Syntax.Real s -> resolve_real ctx expr s - | Syntax.String s -> resolve_string ctx expr s - | Syntax.True -> resolve_true ctx expr - | Syntax.Tuple exprs -> resolve_tuple ctx expr exprs - | Syntax.UnaryOperation (kind, arg) -> - resolve_unuary_operation ctx expr kind arg - | Syntax.Vector vec_elts -> resolve_vector ctx expr vec_elts - -and resolve_binary_operation ctx expr kind arg1 arg2 = - let arg1' = resolve_expression ctx arg1 - and arg2' = resolve_expression ctx arg2 in - let args' = apply_binary_coercions [ arg1'; arg2' ] in - let arg1' = List.nth args' 0 - and arg2' = List.nth args' 1 in - match kind.Syntax.nature with - | Syntax.Plus -> resolve_addition ctx expr arg1' arg2' - | Syntax.And -> resolve_and ctx expr arg1' arg2' - | Syntax.Divide -> resolve_division ctx expr arg1' arg2' - | Syntax.EqualEqual -> raise (CompilError - {err_msg = ["_NotYetImplemented"; "_BinaryOperEQUEQU"]; - err_info = []; - err_ctx = ctx}) - | Syntax.GreaterEqual -> - resolve_comparison ctx expr GreaterEqual arg1' arg2' - | Syntax.Greater -> resolve_comparison ctx expr Greater arg1' arg2' - | Syntax.LessEqual -> resolve_comparison ctx expr LessEqual arg1' arg2' - | Syntax.Less -> resolve_comparison ctx expr Less arg1' arg2' - | Syntax.Times -> resolve_multiplication ctx expr arg1' arg2' - | Syntax.NotEqual -> raise (CompilError - {err_msg = ["_NotYetImplemented"; "_BinaryOperDIFF"]; - err_info = []; - err_ctx = ctx}) - | Syntax.Or -> resolve_or ctx expr arg1' arg2' - | Syntax.Power -> resolve_power ctx expr arg1' arg2' - | Syntax.Minus -> resolve_subtraction ctx expr arg1' arg2' - -and resolve_end ctx expr = - let ctx = {ctx with location = expr.Syntax.info} in - match ctx.context_nature with - | SubscriptContext (_, _, _, Types.ConstantDimension n) -> - let nat = Integer n - and elt_nat = Types.integer_type Types.Constant in - resolved_expression (Some expr) nat elt_nat - | SubscriptContext (_, expr', n, Types.ParameterDimension) -> - size_function_call ctx (Some expr) expr' n - | SubscriptContext (_, expr', n, Types.DiscreteDimension) -> - size_function_call ctx (Some expr) expr' n - | ForContext (ctx', _, _) -> resolve_end ctx' expr - | ToplevelContext | ClassContext _ -> - raise (CompilError - {err_msg = ["_InvalidKeyWordEndInExpr"]; - err_info = []; - err_ctx = ctx}) (*error*) - -and resolve_false ctx expr = - resolved_expression (Some expr) False (Types.boolean_type Types.Constant) - -and resolve_field_access ctx expr expr' id = - let expr' = resolve_expression ctx expr' in - let resolve_field_access' expr' id = - let nat = FieldAccess (expr', id) - and flow, var, inout = - type_prefixes_of_element_nature expr'.info.type_description - and cl_spec = element_nature_class ctx expr'.info.type_description in - let elt_nat = element_field_type_nature ctx flow var inout cl_spec id in - resolved_expression (Some expr) nat elt_nat in - let is_package cl_spec = match evaluate cl_spec with - | Types.ClassType cl_type - when evaluate cl_type.Types.kind = Types.Package -> true - | _ -> false in - match expr'.info.type_description with - | Types.ComponentElement _ -> - resolve_field_access' expr' id - | Types.ClassElement cl_spec when is_package cl_spec -> - resolve_field_access' expr' id - | _ -> - raise (CompilError - {err_msg = ["component or package"; "_ElemExpected"]; - err_info = []; - err_ctx = { ctx with location = expr.Syntax.info }}) (*error*) - -and type_prefixes_of_element_nature = function - | Types.ComponentElement cpnt_type -> - evaluate cpnt_type.Types.flow, - evaluate cpnt_type.Types.variability, - evaluate cpnt_type.Types.causality - | Types.ClassElement _ | Types.ComponentTypeElement _ | - Types.PredefinedTypeElement _ -> - false, Types.Constant, Types.Acausal - -and resolve_function_call ctx syn expr fun_args = - let ctx = {ctx with location = expr.Syntax.info} in - let expr' = resolve_expression ctx expr in - let resolve_function_arguments named_elts = - let reversed_additional_dimensions input_types args = - let additional_named_element_dimensions id arg = - let rec subtract_dimensions fun_dims arg_dims = - match fun_dims, arg_dims with - | [], _ -> arg_dims - | _, [] -> - raise (CompilError - {err_msg = ["_ArgDimMismatch"]; - err_info = []; - err_ctx = ctx}) (*error*) - | Types.ConstantDimension i :: _, Types.ConstantDimension i' :: _ - when i <> i' -> - raise (CompilError - {err_msg = ["_ArgDimMismatch"]; - err_info = []; - err_ctx = ctx}) (*error*) - | _ :: fun_dims, _ :: arg_dims -> - subtract_dimensions fun_dims arg_dims in - let elt_type = List.assoc id input_types in - let elt_type' = evaluate elt_type in - let fun_dims = - Types.reversed_element_dimensions elt_type'.Types.element_nature - and arg_dims = - Types.reversed_element_dimensions arg.info.type_description in - subtract_dimensions fun_dims arg_dims in - let rec reversed_additional_dimensions' ids dims args = - match args with - | [] -> ids, dims - | (id, arg) :: args -> - let dims' = additional_named_element_dimensions id arg in - update_additional_dimensions ids dims id dims' args - and update_additional_dimensions ids dims id dims' args = - match dims, dims' with - | _, [] -> reversed_additional_dimensions' ids dims args - | [], _ :: _ -> - let ids' = id :: ids in - reversed_additional_dimensions' ids' dims' args - | _ :: _, _ :: _ when dims <> dims' -> - raise (CompilError - {err_msg = ["_ArgDimMismatchInVectCall"]; - err_info = []; - err_ctx = ctx}) (*error*) - | _ :: _, _ :: _ -> - let ids' = id :: ids in - reversed_additional_dimensions' ids' dims args in - reversed_additional_dimensions' [] [] args in - let function_call ids rev_dims input_types output_types args = - let ndims = List.length rev_dims in - let rec expressions_of_named_arguments pos input_types = - let expression_of_default_argument id elt_type = - let elt_type' = evaluate elt_type in - let func = - let nat = FunctionArgument 0 - and elt_nat = expr'.info.type_description in - resolved_expression None nat elt_nat in - let nat = FieldAccess (func, id) - and elt_nat = elt_type'.Types.element_nature in - resolved_expression None nat elt_nat - and expression_of_named_argument pos id elt_type = - let rec loop_variables = function - | 0 -> [] - | ndims -> - let nat = LoopVariable (ndims - 1) - and elt_nat = (Types.integer_type Types.Constant) in - let loop_var = resolved_expression None nat elt_nat in - loop_var :: loop_variables (ndims - 1) in - let elt_type' = evaluate elt_type in - let elt_nat = elt_type'.Types.element_nature in - let nat = match List.mem id ids with - | false -> FunctionArgument pos - | true -> - let arg = List.assoc id args in - let nat = FunctionArgument pos - and elt_nat = arg.info.type_description in - let expr = resolved_expression None nat elt_nat in - IndexedAccess (expr, loop_variables ndims) in - resolved_expression None nat elt_nat in - match input_types with - | [] -> [] - | (id, elt_type) :: input_types when not (List.mem_assoc id args) -> - let arg = expression_of_default_argument id elt_type in - arg :: expressions_of_named_arguments pos input_types - | (id, elt_type) :: input_types -> - let arg = expression_of_named_argument pos id elt_type in - arg :: expressions_of_named_arguments (pos + 1) input_types in - let ranges arg rev_dims = - let rec ranges' acc n rev_dims = - let range_of_dimension dim = - let range_to stop = - let nat = Range (one, one, stop) - and elt_nat = Types.integer_array_type Types.Constant dim in - resolved_expression None nat elt_nat in - match dim with - | Types.ConstantDimension i -> - let stop = - let nat = Integer i - and elt_nat = (Types.integer_type Types.Constant) in - resolved_expression None nat elt_nat in - range_to stop - | Types.ParameterDimension -> - let stop = size_function_call ctx None arg n in - range_to stop - | Types.DiscreteDimension -> - let stop = size_function_call ctx None arg n in - range_to stop in - match rev_dims with - | [] -> acc - | dim :: rev_dims -> - let range = range_of_dimension dim in - ranges' (range :: acc) (Int32.succ n) rev_dims in - ranges' [] 1l rev_dims in - let rec sorted_arguments_of_named_arguments = function - | [] -> [] - | (id, _) :: input_types when not (List.mem_assoc id args) -> - sorted_arguments_of_named_arguments input_types - | (id, _) :: input_types -> - let arg = List.assoc id args in - arg :: sorted_arguments_of_named_arguments input_types in - let wrap_function_invocation cpnt_type = - let add_dimensions cpnt_type = - let rec add_dimensions cl_spec = function - | [] -> cl_spec - | dim :: rev_dims -> - let cl_spec' = Types.ArrayType (dim, cl_spec) in - add_dimensions cl_spec' rev_dims in - let base_class = cpnt_type.Types.base_class in - { cpnt_type with - Types.base_class = - lazy (add_dimensions (evaluate base_class) rev_dims) - } in - let wrap_function_invocation' cpnt_type rev_dims = - let nat = - let exprs = expressions_of_named_arguments 1 input_types in - FunctionInvocation exprs - and elt_nat = Types.ComponentElement cpnt_type in - match ids with - | [] -> - resolved_expression syn nat elt_nat - | id :: _ -> - let cpnt_type' = add_dimensions cpnt_type in - let nat = - let ranges = - let arg = List.assoc id args in - ranges arg rev_dims - and expr = resolved_expression None nat elt_nat in - VectorReduction (ranges, expr) - and elt_nat = Types.ComponentElement cpnt_type' in - resolved_expression None nat elt_nat in - wrap_function_invocation' cpnt_type rev_dims in - let component_type_of_output_types output_types = - let component_type_of_output_type cpnt_type (_, elt_type) = - let add_class_specifier cl_spec cl_spec' = - match cl_spec, cl_spec' with - | Types.TupleType [], _ -> cl_spec' - | (Types.TupleType cl_specs), _ -> - Types.TupleType (cl_spec' :: cl_specs) - | _, _ -> Types.TupleType [cl_spec'; cl_spec] in - let var = evaluate cpnt_type.Types.variability - and cl_spec = evaluate cpnt_type.Types.base_class in - let elt_type' = evaluate elt_type in - match elt_type'.Types.element_nature with - | Types.ComponentElement cpnt_type' -> - let var' = evaluate cpnt_type'.Types.variability - and cl_spec' = evaluate cpnt_type'.Types.base_class in - { - Types.flow = lazy false; - Types.variability = lazy (Types.max_variability var var'); - Types.causality = lazy Types.Acausal; - Types.base_class = lazy (add_class_specifier cl_spec cl_spec') - } - | Types.ClassElement _ | Types.ComponentTypeElement _ | - Types.PredefinedTypeElement _ -> - raise (CompilError - {err_msg = ["_ClassElemFoundInExpr"]; - err_info = []; - err_ctx = ctx}) (*error*) in - let cpnt_type = - { - Types.flow = lazy false; - Types.variability = lazy Types.Constant; - Types.causality = lazy Types.Acausal; - Types.base_class = lazy (Types.TupleType []) - } in - List.fold_left component_type_of_output_type cpnt_type output_types in - let args' = sorted_arguments_of_named_arguments input_types - and cpnt_type = component_type_of_output_types output_types in - let func_invoc = wrap_function_invocation cpnt_type in - let nat = FunctionCall (expr', args', func_invoc) - and elt_nat = func_invoc.info.type_description in - resolved_expression syn nat elt_nat in - let resolve_function_arguments' fun_args = - match fun_args.Syntax.nature with - | Syntax.Reduction _ -> - raise (CompilError - {err_msg = ["_NotYetImplemented"; "_FuncArgumentReduction"]; - err_info = []; - err_ctx = ctx}) - | Syntax.ArgumentList args -> - let input_types, output_types, named_args = - resolve_function_argument_list ctx expr' named_elts args in - let ids, rev_dims = - reversed_additional_dimensions input_types named_args in - function_call ids rev_dims input_types output_types named_args in - match fun_args with - | None -> - let fun_args = { Syntax.nature = Syntax.ArgumentList []; - Syntax.info = ctx.location } in - resolve_function_arguments' fun_args - | Some fun_args -> resolve_function_arguments' fun_args in - let resolve_class_function_call cl_type = - match evaluate cl_type.Types.kind with - | Types.Function -> - resolve_function_arguments cl_type.Types.named_elements - | Types.Class | Types.Model | Types.Block | Types.Record | - Types.ExpandableConnector | Types.Connector | Types.Package -> - raise (CompilError - {err_msg = ["function"; "_ElemExpected"]; - err_info = []; - err_ctx = ctx}) (*error*) in - let resolve_function_call' cl_spec = - match evaluate cl_spec with - | Types.ClassType cl_type -> - resolve_class_function_call cl_type - | _ -> - raise (CompilError - {err_msg = ["function"; "_ElemExpected"]; - err_info = []; - err_ctx = ctx}) (*error*) in - match expr'.info.type_description with - | Types.ClassElement cl_spec -> resolve_function_call' cl_spec - | Types.ComponentElement cpnt_type -> - let cl_spec = cpnt_type.Types.base_class in - resolve_function_call' cl_spec - | Types.ComponentTypeElement _ | Types.PredefinedTypeElement _ -> - raise (CompilError - {err_msg = ["function"; "_ElemExpected"]; - err_info = []; - err_ctx = ctx}) (*error*) - -and resolve_function_argument_list ctx expr' named_elts args = - let rec class_kind ctx = - let class_context' cl_spec = match cl_spec with - | Types.ClassType cl_type -> - Some (evaluate cl_type.Types.kind) - | _ -> None in - match ctx.context_nature with - | ClassContext cl_def -> - class_context' (evaluate cl_def.class_type) - | SubscriptContext (ctx, _, _, _) | ForContext (ctx, _, _) -> - class_kind ctx - | _ -> None in - let add_function_inout_argument ((id, elt_type) as named_elt) inouts = - let add_function_inout_argument' cpnt_type = - match inouts, evaluate cpnt_type.Types.causality with - | (ins, outs), Types.Input -> named_elt :: ins, outs - | (ins, outs), Types.Output -> ins, named_elt :: outs - | _, Types.Acausal -> inouts in - let elt_type' = evaluate elt_type in - match elt_type'.Types.element_nature with - | Types.ComponentElement cpnt_type when not elt_type'.Types.protected -> - add_function_inout_argument' cpnt_type - | _ -> inouts in - let add_argument id arg arg' elt_type acc = - let matchable_types cpnt_type cpnt_type' = - let cl_spec = evaluate cpnt_type.Types.base_class - and cl_spec' = evaluate cpnt_type'.Types.base_class in - let rec matchable_types' cl_spec cl_spec' = match cl_spec, cl_spec' with - | Types.ArrayType (dim, cl_spec), _ -> - matchable_types' cl_spec cl_spec' - | _, Types.ArrayType (dim', cl_spec') -> - matchable_types' cl_spec cl_spec' - | _, _ -> - let type_compare = Types.compare_specifiers cl_spec cl_spec' in - (type_compare = Types.SameType) || - (type_compare = Types.Supertype) in - matchable_types' cl_spec cl_spec' in - let matchable_variabilities cpnt_type cpnt_type' = - let var = evaluate cpnt_type.Types.variability - and var' = evaluate cpnt_type'.Types.variability in - Types.higher_variability var var' in - let elt_type = evaluate elt_type in - let cpnt_type = match elt_type.Types.element_nature with - | Types.ComponentElement cpnt_type -> cpnt_type - | _ -> assert false in - let arg' = apply_rhs_coercions cpnt_type arg' in - match arg'.info.type_description with - | Types.ComponentElement cpnt_type' - when not (matchable_types cpnt_type cpnt_type') -> - raise (CompilError - {err_msg = ["_ArgTypeMismatch"]; - err_info = - [("_ExpectedType", Types.string_of_component_type cpnt_type); - ("_TypeFound", Types.string_of_component_type cpnt_type')]; - err_ctx = {ctx with location = arg.Syntax.info}}) (*error*) - | Types.ComponentElement cpnt_type' - when not (matchable_variabilities cpnt_type cpnt_type') -> - let var = evaluate cpnt_type.Types.variability - and var' = evaluate cpnt_type'.Types.variability in - let var = Types.string_of_variability var - and var' = Types.string_of_variability var' in - raise (CompilError - {err_msg = ["_ArgVariabilityMismatch"]; - err_info = [("_ExpectedVariability", var); - ("_VariabilityFound", var')]; - err_ctx = {ctx with location = arg.Syntax.info}}) (*error*) - | Types.ComponentElement cpnt_type' -> (id, arg') :: acc - | _ -> raise (CompilError - {err_msg = ["_ClassElemFoundInExpr"]; - err_info = []; - err_ctx = {ctx with location = arg.Syntax.info}}) (*error*) in - let named_arguments_of_arguments input_types args = - let rec add_positional_arguments acc input_types args = - match input_types, args with - | [], [] -> acc - | [], _ -> - raise (CompilError - {err_msg = ["_TooManyArgsInFuncCall"]; - err_info = []; - err_ctx = ctx}) (*error*) - | _, [] -> - raise (CompilError - {err_msg = ["_TooFewArgsInFuncCall"]; - err_info = []; - err_ctx = ctx}) (*error*) - | (id, elt_type) :: input_types, - { Syntax.nature = Syntax.Argument arg } :: args -> - let arg' = resolve_expression ctx arg in - let acc = add_argument id arg arg' elt_type acc in - add_positional_arguments acc input_types args - | _, { Syntax.nature = Syntax.NamedArgument _ } :: _ -> - add_named_arguments acc input_types args - and add_named_arguments acc input_types args = - match input_types, args with - | [], [] -> acc - | [], _ -> - raise (CompilError - {err_msg = ["_TooManyArgsInFuncCall"]; - err_info = []; - err_ctx = ctx}) (*error*) - | _, [] -> - raise (CompilError - {err_msg = ["_TooFewArgsInFuncCall"]; - err_info = []; - err_ctx = ctx}) (*error*) - | _, { Syntax.nature = Syntax.Argument _ } :: _ -> - raise (CompilError - {err_msg = ["_MixedPositAndNamedFuncArgPass"]; - err_info = []; - err_ctx = ctx}) (*error*) - | _, { Syntax.nature = Syntax.NamedArgument (id, _) } :: _ - when List.mem_assoc id acc -> - raise (CompilError - {err_msg = ["_FuncCallWithDuplicateArg"; id]; - err_info = []; - err_ctx = ctx}) (*error*) - | _, { Syntax.nature = Syntax.NamedArgument (id, _) } :: _ - when not (List.mem_assoc id input_types) -> - raise (CompilError - {err_msg = ["_NonInputFuncArgElem"; id]; - err_info = []; - err_ctx = ctx}) (*error*) - | _, { Syntax.nature = Syntax.NamedArgument (id, arg) } :: args -> - let arg' = resolve_expression ctx arg - and elt_type = List.assoc id input_types in - let acc = add_argument id arg arg' elt_type acc in - add_named_arguments acc input_types args in - add_positional_arguments [] input_types args in - let resolve_built_in_function_argument arg = match arg with - | { Syntax.nature = Syntax.Argument arg } -> - arg, (resolve_expression ctx arg) - | { Syntax.nature = Syntax.NamedArgument _; Syntax.info = info } -> - raise (CompilError - {err_msg = ["_CannotUseNamedArgWithBuiltInOper"]; - err_info = []; - err_ctx = {ctx with location = info}}) (*error*) in - let rec built_in_function_named_arguments acc input_types args' = - match input_types, args' with - | [], [] -> acc - | [], _ -> - raise (CompilError - {err_msg = ["_TooManyArgsInFuncCall"]; - err_info = []; - err_ctx = ctx}) (*error*) - | _, [] -> - raise (CompilError - {err_msg = ["_TooFewArgsInFuncCall"]; - err_info = []; - err_ctx = ctx}) (*error*) - | (id, elt_type) :: input_types, (arg, arg') :: args' -> - let acc = add_argument id arg arg' elt_type acc in - built_in_function_named_arguments acc input_types args' in - let built_in_function_inout_types ctx id (in_types, out_types) args' = - let argument_component_type (arg, arg') = - match arg'.info.type_description with - | Types.ComponentElement cpnt_type -> - cpnt_type - | _ -> raise (CompilError - {err_msg = ["_ClassElemFoundInExpr"]; - err_info = []; - err_ctx = {ctx with location = arg.Syntax.info}}) (*error*) in - let scalar_base_class_specifier (arg, arg') = - let rec scalar_base_class_specifier' cl_spec = match cl_spec with - | Types.ArrayType (dim, cl_spec) -> scalar_base_class_specifier' cl_spec - | _ -> cl_spec in - let cpnt_type = argument_component_type (arg, arg') in - let cl_spec = evaluate cpnt_type.Types.base_class in - scalar_base_class_specifier' cl_spec in - let argument_base_type bt (arg, arg') = - let cl_spec = scalar_base_class_specifier (arg, arg') in - match cl_spec with - | Types.PredefinedType predef when predef.Types.base_type = bt -> true - | _ -> false in - let argument_base_types bt args = - List.for_all (argument_base_type bt) args in - let argument_variability var (arg, arg') = - let cpnt_type = argument_component_type (arg, arg') in - let var' = evaluate cpnt_type.Types.variability in - var = var' in - let neg f = function x -> not (f x) in - let ndims arg' = - let cpnt_type = component_type_of_expression ctx arg' in - let rec ndims' cl_spec = - match cl_spec with - | Types.ArrayType (dim, cl_spec) -> ndims' cl_spec + 1 - | _ -> 0 in - ndims' (evaluate cpnt_type.Types.base_class) in - let numeric_base_type arg' = - let cl_spec = scalar_class_specifier ctx arg' in - (Types.compare_specifiers Types.integer_class_type cl_spec = - Types.SameType) || - (Types.compare_specifiers Types.real_class_type cl_spec = - Types.SameType) in - let rec argument_types i args = match args with - | [] -> [] - | (arg, arg') :: args -> - let cpnt_type = component_type_of_expression ctx arg' - and name = Printf.sprintf "@%d" i in - (name, cpnt_type) :: (argument_types (i + 1) args) in - let element_types input_types output_types = - let element_type inout (id, cpnt_type) = - (id, - lazy - { - Types.protected = false; - Types.final = true; - Types.replaceable = false; - Types.dynamic_scope = None; - Types.element_nature = - Types.ComponentElement - { cpnt_type with Types.causality = lazy inout } - }) in - (List.map (element_type Types.Input) input_types), - (List.map (element_type Types.Output) output_types) in - match id, args' with - | ("der" | "initial" | "terminal" | "sample" | "pre" | "edge" | "change" | - "reinit" | "delay"), _ when (class_kind ctx) = Some Types.Function -> - raise (CompilError - {err_msg = [id; "_OperCannotBeUsedWithinFuncDef"]; - err_info = []; - err_ctx = ctx}) (*error*) - | ("pre" | "edge" | "change"), [arg, arg'] | "reinit", [(arg, arg'); _] - when not (expression_of_variable arg) -> - raise (CompilError - {err_msg = [id; "_OperArgMustBeAVar"]; - err_info = []; - err_ctx = {ctx with location = arg.Syntax.info}}) (*error*) - | ("ceil" | "floor" | "integer" | "der"), [arg, arg'] | - "reinit", [(arg, arg'); _] | - "smooth", [_; (arg, arg')] - when not (argument_base_type Types.RealType (arg, arg')) -> - let cl_spec = scalar_base_class_specifier (arg, arg') in - raise (CompilError - {err_msg = ["_ArgTypeMismatch"]; - err_info = - [("_ExpectedType", "Real"); - ("_TypeFound", Types.string_of_class_specifier cl_spec)]; - err_ctx = {ctx with location = arg.Syntax.info}}) (*error*) - | "delay", _ - when not (List.for_all (argument_base_type Types.RealType) args') -> - let (arg, arg') = - List.find (neg (argument_base_type Types.RealType)) args' in - let cl_spec = scalar_base_class_specifier (arg, arg') in - raise (CompilError - {err_msg = ["_ArgTypeMismatch"]; - err_info = - [("_ExpectedType", "Real"); - ("_TypeFound", Types.string_of_class_specifier cl_spec)]; - err_ctx = {ctx with location = arg.Syntax.info}}) (*error*) - | "der", [arg, arg'] - when not (argument_variability Types.Continuous (arg, arg')) -> - let cpnt_type = argument_component_type (arg, arg') in - let var = evaluate cpnt_type.Types.variability in - let var = Types.string_of_variability var in - raise (CompilError - {err_msg = ["_ArgVariabilityMismatch"]; - err_info = [("_ExpectedVariability", "Continuous"); - ("_VariabilityFound", var)]; - err_ctx = {ctx with location = arg.Syntax.info}}) (*error*) - | "delay", _ when List.length args' = 3 -> - let input_types = - [("@1", Types.real_component_type Types.Continuous); - ("@2", Types.real_component_type Types.Continuous); - ("@3", Types.real_component_type Types.Parameter)] - and output_types = - ["@4", Types.real_component_type Types.Continuous] in - element_types input_types output_types - | "abs", [arg, arg'] - when argument_base_type Types.IntegerType (arg, arg') -> - let input_types = ["@1", Types.integer_component_type Types.Discrete] - and output_types = - ["@2", Types.integer_component_type Types.Discrete] in - element_types input_types output_types - | ("ones" | "zeros"), _ - when not (argument_base_types Types.IntegerType args') -> - let (arg, arg') = - List.find (neg (argument_base_type Types.IntegerType)) args' in - raise (CompilError - {err_msg = ["_ArgTypeMismatch"]; - err_info = []; - err_ctx = {ctx with location = arg.Syntax.info}}) (*error*) - | "fill", _ :: args' - when not (argument_base_types Types.IntegerType args') -> - let (arg, arg') = - List.find (neg (argument_base_type Types.IntegerType)) args' in - raise (CompilError - {err_msg = ["_ArgTypeMismatch"]; - err_info = []; - err_ctx = {ctx with location = arg.Syntax.info}}) (*error*) - | ("sum" | "product" | "max" | "min" | "scalar"), [arg, arg'] - when ndims arg' = 0 -> - raise (CompilError - {err_msg = ["_ArgTypeMismatch"]; - err_info = []; - err_ctx = {ctx with location = arg.Syntax.info}}) (*error*) - | "diagonal", [arg, arg'] - when ndims arg' <> 1 -> - raise (CompilError - {err_msg = ["_ArgTypeMismatch"]; - err_info = []; - err_ctx = {ctx with location = arg.Syntax.info}}) (*error*) - | ("scalar"), [arg, arg'] -> - let cpnt_type = component_type_of_expression ctx arg' in - let input_types = ["@1", cpnt_type] - and output_types = - ["@2", Types.scalar_component_type cpnt_type ] in - element_types input_types output_types - | ("sum" | "product" | "max" | "min" | "diagonal"), [arg, arg'] - when not (numeric_base_type arg') -> - raise (CompilError - {err_msg = ["_ArgTypeMismatch"]; - err_info = []; - err_ctx = {ctx with location = arg.Syntax.info}}) (*error*) - | ("sum" | "product" | "max" | "min"), [arg, arg'] -> - let cpnt_type = component_type_of_expression ctx arg' in - let input_types = ["@1", cpnt_type] - and output_types = - ["@2", Types.scalar_component_type cpnt_type ] in - element_types input_types output_types - | ("ones" | "zeros"), _ :: _ -> - let input_types = argument_types 1 args' - and output_types = - let n = List.length args' - and dims = - List.map (function _ -> Types.ParameterDimension) args' in - let cpnt_type = - { - Types.flow = lazy false; - variability = lazy Types.Parameter; - Types.causality = lazy Types.Acausal; - base_class = - lazy(Types.add_dimensions dims Types.integer_class_type) - } in - [ Printf.sprintf "@%d" (n + 1), cpnt_type ] in - element_types input_types output_types - | "fill", (arg, arg') :: (_ :: _ as args) -> - let input_types = argument_types 1 args' - and output_types = - let n = List.length args - and dims = - List.map (function _ -> Types.ParameterDimension) args in - let cpnt_type = component_type_of_expression ctx arg' in - let lcl_spec = lazy - (Types.add_dimensions - dims - (evaluate cpnt_type.Types.base_class)) in - [ - Printf.sprintf "@%d" (n + 1), - { cpnt_type with Types.base_class = lcl_spec } - ] in - element_types input_types output_types - | "diagonal", [ arg, arg' ] -> - let cpnt_type = component_type_of_expression ctx arg' in - let input_types = [ "@1", cpnt_type ] - and output_types = - let dims = [ Types.ParameterDimension ] in - let lcl_spec = lazy - (Types.add_dimensions - dims - (evaluate cpnt_type.Types.base_class)) in - [ "@2", { cpnt_type with Types.base_class = lcl_spec } ] in - element_types input_types output_types - | ("div" | "mod" | "rem" | "max" | "min"), _ - when List.for_all (argument_base_type Types.IntegerType) args' -> - let input_types = - [ - "@1", Types.integer_component_type Types.Discrete; - "@2", Types.integer_component_type Types.Discrete - ] - and output_types = - ["@3", Types.integer_component_type Types.Discrete] in - element_types input_types output_types - | ("pre" | "change"), [arg, arg'] -> - let cpnt_type = argument_component_type (arg, arg') in - let input_types = - ["@1", { cpnt_type with Types.variability = lazy Types.Continuous }] - and output_types = - ["@2", { cpnt_type with Types.variability = lazy Types.Discrete }] in - element_types input_types output_types - | _, _ -> in_types, out_types in - match expr'.nature with - | PredefinedIdentifier id -> - let args' = List.map resolve_built_in_function_argument args in - let input_types, output_types = - let inout_types = - List.fold_right add_function_inout_argument named_elts ([], []) in - built_in_function_inout_types ctx id inout_types args' in - let named_args = - built_in_function_named_arguments [] input_types args' in - input_types, output_types, named_args - | _ -> - let input_types, output_types = - List.fold_right add_function_inout_argument named_elts ([], []) in - let named_args = named_arguments_of_arguments input_types args in - input_types, output_types, named_args - -and resolve_identifier ctx expr id = - let rec resolve_predefined_identifier ctx expr id = match id with - | "Boolean" -> - let nat = PredefinedIdentifier "Boolean" - and elt_nat = Types.ClassElement (lazy (Types.boolean_class_type)) in - resolved_expression (Some expr) nat elt_nat - | "Integer" -> - let nat = PredefinedIdentifier "Integer" - and elt_nat = Types.ClassElement (lazy (Types.integer_class_type)) in - resolved_expression (Some expr) nat elt_nat - | "Real" -> - let nat = PredefinedIdentifier "Real" - and elt_nat = Types.ClassElement (lazy (Types.real_class_type)) in - resolved_expression (Some expr) nat elt_nat - | "String" -> - let nat = PredefinedIdentifier "String" - and elt_nat = Types.ClassElement (lazy (Types.string_class_type)) in - resolved_expression (Some expr) nat elt_nat - | "reinit" -> - let nat = PredefinedIdentifier "reinit" - and elt_nat = - let inputs = - ["@1", Types.real_component_type Types.Continuous; - "@2", Types.real_component_type Types.Continuous] - and outputs = [] in - Types.function_type inputs outputs in - resolved_expression (Some expr) nat elt_nat - | "time" -> - let nat = PredefinedIdentifier "time" - and elt_nat = Types.real_type Types.Continuous in - resolved_expression (Some expr) nat elt_nat - | "pre" | "change" -> - let nat = PredefinedIdentifier "pre" - and elt_nat = - let inputs = ["@1", Types.real_component_type Types.Continuous] - and outputs = ["@2", Types.real_component_type Types.Discrete] in - Types.function_type inputs outputs in - resolved_expression (Some expr) nat elt_nat - | "edge" -> - let nat = PredefinedIdentifier "edge" - and elt_nat = - let inputs = ["@1", Types.boolean_component_type Types.Discrete] - and outputs = ["@2", Types.boolean_component_type Types.Discrete] in - Types.function_type inputs outputs in - resolved_expression (Some expr) nat elt_nat - | "initial" -> - let nat = PredefinedIdentifier "initial" - and elt_nat = - let inputs = [] - and outputs = [] in - Types.function_type inputs outputs in - resolved_expression (Some expr) nat elt_nat - | "terminal" -> - let nat = PredefinedIdentifier "terminal" - and elt_nat = - let inputs = [] - and outputs = [] in - Types.function_type inputs outputs in - resolved_expression (Some expr) nat elt_nat - | "sample" -> - let nat = PredefinedIdentifier "sample" - and elt_nat = - let inputs = [("@1", Types.real_component_type Types.Parameter); - ("@2", Types.real_component_type Types.Parameter)] - and outputs = ["@3", Types.boolean_component_type Types.Parameter] in - Types.function_type inputs outputs in - resolved_expression (Some expr) nat elt_nat - | "delay" -> - let nat = PredefinedIdentifier "delay" - and elt_nat = - let inputs = [("@1", Types.real_component_type Types.Continuous); - ("@2", Types.real_component_type Types.Parameter)] - and outputs = ["@3", Types.real_component_type Types.Continuous] in - Types.function_type inputs outputs in - resolved_expression (Some expr) nat elt_nat - | "assert" -> - let nat = PredefinedIdentifier "assert" - and elt_nat = - let inputs = [("@1", Types.boolean_component_type Types.Discrete); - ("@2", Types.string_component_type Types.Discrete)] - and outputs = [] in - Types.function_type inputs outputs in - resolved_expression (Some expr) nat elt_nat - | "terminate" -> - let nat = PredefinedIdentifier "terminate" - and elt_nat = - let inputs = [("@1", Types.string_component_type Types.Discrete)] - and outputs = [] in - Types.function_type inputs outputs in - resolved_expression (Some expr) nat elt_nat - | "abs" | "cos" | "sin" | "tan" | "exp" | "log" | "sqrt" | - "asin" | "acos" | "atan" | "sinh" | "cosh" | "tanh" | "asinh" | - "acosh" | "atanh" | "log10" | "ceil" | "floor" | "der" -> - let nat = PredefinedIdentifier id - and elt_nat = - let inputs = ["@1", Types.real_component_type Types.Continuous] - and outputs = ["@2", Types.real_component_type Types.Continuous] in - Types.function_type inputs outputs in - resolved_expression (Some expr) nat elt_nat - | "sign" | "integer" | "ones" | "zeros" -> - let nat = PredefinedIdentifier id - and elt_nat = - let inputs = ["@1", Types.real_component_type Types.Continuous] - and outputs = ["@2", Types.integer_component_type Types.Discrete] in - Types.function_type inputs outputs in - resolved_expression (Some expr) nat elt_nat - | "max" | "min" | "div" | "mod" | "rem" | "fill" -> - let nat = PredefinedIdentifier id - and elt_nat = - let inputs = - [ - "@1", Types.real_component_type Types.Continuous; - "@2", Types.real_component_type Types.Continuous - ] - and outputs = ["@3", Types.real_component_type Types.Continuous] in - Types.function_type inputs outputs in - resolved_expression (Some expr) nat elt_nat - | "smooth" -> - let nat = PredefinedIdentifier id - and elt_nat = - let inputs = - [ - "@1", Types.integer_component_type Types.Discrete; - "@2", Types.real_component_type Types.Continuous - ] - and outputs = ["@3", Types.real_component_type Types.Continuous] in - Types.function_type inputs outputs in - resolved_expression (Some expr) nat elt_nat - | "identity" -> - let nat = PredefinedIdentifier id - and elt_nat = - let inputs = [ "@1", Types.integer_component_type Types.Parameter ] - and outputs = - let dims = - [Types.ParameterDimension; Types.ParameterDimension] in - [ - "@2", - Types.integer_array_component_type Types.Parameter dims - ] in - Types.function_type inputs outputs in - resolved_expression (Some expr) nat elt_nat - | "diagonal" -> - let nat = PredefinedIdentifier id - and elt_nat = - let inputs = - let dim = [ Types.ParameterDimension ] in - [ "@1", Types.integer_array_component_type Types.Parameter dim ] - and outputs = - let dims = - [Types.ParameterDimension; Types.ParameterDimension] in - [ - "@2", - Types.integer_array_component_type Types.Parameter dims - ] in - Types.function_type inputs outputs in - resolved_expression (Some expr) nat elt_nat - | "sum" | "product" | "scalar" -> - let nat = PredefinedIdentifier id - and elt_nat = - let inputs = - let dim = [ Types.DiscreteDimension ] in - [ "@1", Types.integer_array_component_type Types.Discrete dim ] - and outputs = ["@2", Types.integer_component_type Types.Discrete] in - Types.function_type inputs outputs in - resolved_expression (Some expr) nat elt_nat - | _ -> raise (CompilError - {err_msg = ["_UnknownIdentifier"; id]; - err_info = []; - err_ctx = ctx}) - and search_in_toplevel dic = - try - let elt_desc = List.assoc id (evaluate dic) in - let elt_type = evaluate elt_desc.element_type in - match elt_type.Types.dynamic_scope with - | None | Some Types.Inner -> - let nat = ToplevelIdentifier id in - resolved_expression (Some expr) nat elt_type.Types.element_nature - | Some Types.Outer | Some Types.InnerOuter -> - raise (CompilError - {err_msg = ["_NoInnerDeclForOuterElem"; id]; - err_info = []; - err_ctx = ctx}) (*error*) - with Not_found -> resolve_predefined_identifier ctx expr id - and search_in_class level cl_def = match evaluate cl_def.class_type with - | Types.ClassType cl_type -> search_in_class_type level cl_def cl_type - | Types.PredefinedType _ | Types.ComponentType _ | Types.ArrayType _ | - Types.TupleType _ -> - raise (CompilError - {err_msg = ["_NoInnerDeclForOuterElem"; id]; - err_info = []; - err_ctx = ctx}) (*error*) - and search_in_class_type level cl_def cl_type = - try - let elt_type = evaluate (List.assoc id cl_type.Types.named_elements) in - match elt_type.Types.dynamic_scope with - | None | Some Types.Inner -> - let nat = LocalIdentifier (level, id) in - resolved_expression (Some expr) nat elt_type.Types.element_nature - | Some Types.Outer | Some Types.InnerOuter -> - let nat = DynamicIdentifier (level, id) in - resolved_expression (Some expr) nat elt_type.Types.element_nature - with Not_found -> search_in_parent level cl_def - and search_in_parent level cl_def = match cl_def.enclosing_class with - | _ when cl_def.encapsulated -> search_in_toplevel ctx.toplevel - | Some cl_def -> search_in_class (level + 1) cl_def - | None -> search_in_toplevel ctx.toplevel - and search_in_for_loop_variables level ctx = match ctx.context_nature with - | ToplevelContext -> search_in_toplevel ctx.toplevel - | ClassContext cl_def -> search_in_class 0 cl_def - | SubscriptContext (ctx', _, _, _) -> - search_in_for_loop_variables level ctx' - | ForContext (_, id', elt_nat) when id' = id -> - let nat = LoopVariable level in - resolved_expression (Some expr) nat elt_nat - | ForContext (ctx', _, _) -> - search_in_for_loop_variables (level + 1) ctx' in - search_in_for_loop_variables 0 ctx - -(*and resolve_if ctx expr alts expr' = - let expres' = resolve_expression ctx expr' in - let elt_nat' = expres'.info.type_description in - let rec resolve_alternative (cond, expr) = - resolve_condition cond, - resolve_alternative_expression expr - and resolve_condition cond = - let ctx = {ctx with location = cond.Syntax.info} in - let cond' = resolve_expression ctx cond in - let condition cpnt_type = - let cl_spec = evaluate cpnt_type.Types.base_class in - match cl_spec with - | Types.PredefinedType { Types.base_type = Types.BooleanType } -> cond' - | Types.PredefinedType _ | Types.ClassType _ | Types.ComponentType _ | - Types.ArrayType _ | Types.TupleType _ -> - raise (CompilError - {err_msg = ["_NonBooleanIfCondExpr"]; - err_info = - [("_ExprKind", "...if A then..."); - ("_TypeOfA", Types.string_of_class_specifier cl_spec)]; - err_ctx = ctx}) (*error*) in - match cond'.info.type_description with - | Types.ComponentElement cpnt_type -> condition cpnt_type - | _ -> raise (CompilError - {err_msg = ["_ClassElemFoundInExpr"]; - err_info = []; - err_ctx = {ctx with location = cond.Syntax.info}}) (*error*) - and resolve_alternative_expression expr = - let ctx = {ctx with location = expr.Syntax.info} in - let expres = resolve_expression ctx expr in - let elt_nat = expres.info.type_description in - let display_error elt_nat elt_nat' = match elt_nat, elt_nat' with - | Types.ComponentElement cpnt_type, Types.ComponentElement cpnt_type' -> - raise (CompilError - {err_msg = ["_TypeConflictsInIfAlternExprs"]; - err_info = - [("_TypeOfThenBranche", - Types.string_of_component_type cpnt_type); - ("_TypeOfElseBranche", - Types.string_of_component_type cpnt_type')]; - err_ctx = ctx}) (*error*) - | Types.ComponentElement cpnt_type, _ -> - raise (CompilError - {err_msg = ["_ClassElemFoundInExpr"]; - err_info = - [("_TypeOfThenBranche", - Types.string_of_component_type cpnt_type); - ("_TypeOfElseBranche", "_ClassElement")]; - err_ctx = ctx}) (*error*) - | _, Types.ComponentElement cpnt_type' -> - raise (CompilError - {err_msg = ["_ClassElemFoundInExpr"]; - err_info = - [("_TypeOfThenBranche", "_ClassElement"); - ("_TypeOfElseBranche", - Types.string_of_component_type cpnt_type')]; - err_ctx = ctx}) (*error*) - | _, _ -> - raise (CompilError - {err_msg = ["_ClassElemFoundInExpr"]; - err_info = - [("_TypeOfThenBranche", "_ClassElement"); - ("_TypeOfElseBranche", "_ClassElement")]; - err_ctx = ctx}) (*error*) in - match Types.compare_element_natures elt_nat elt_nat' with - | Types.NotRelated -> display_error elt_nat elt_nat' - | _ -> expres in - let alts = List.map resolve_alternative alts in - let nat = If (alts, expres') in - resolved_expression (Some expr) nat elt_nat'*) - -and resolve_if ctx expr alts expr' = - let resolve_data_expression ctx expr = - let expr' = resolve_expression ctx expr in - match expr'.info.type_description with - | Types.ComponentElement cpnt_type -> expr' - | _ -> - raise (CompilError - {err_msg = ["_ClassElemFoundInExpr"]; - err_info = []; - err_ctx = {ctx with location = expr.Syntax.info}}) (*error*) in - let resolve_condition cond = - let ctx = {ctx with location = cond.Syntax.info} in - let cond' = resolve_data_expression ctx cond in - let condition cpnt_type = - match evaluate cpnt_type.Types.base_class with - | Types.PredefinedType { Types.base_type = Types.BooleanType } -> cond' - | cl_spec -> - raise (CompilError - {err_msg = ["_NonBooleanIfCondExpr"]; - err_info = - [("_ExprKind", "...if A then..."); - ("_TypeOfA", Types.string_of_class_specifier cl_spec)]; - err_ctx = ctx}) (*error*) in - match cond'.info.type_description with - | Types.ComponentElement cpnt_type -> condition cpnt_type - | _ -> - raise (CompilError - {err_msg = ["_DataElemExpected"]; - err_info = []; - err_ctx = ctx}) (*error*) in - let resolve_alternatives (alts, expr') (cond, expr) = - let ctx = {ctx with location = expr.Syntax.info} in - let cond' = resolve_condition cond - and expr = resolve_data_expression ctx expr in - let exprs = apply_binary_coercions [ expr'; expr] in - let expr' = List.nth exprs 0 - and expr = List.nth exprs 1 in - let elt_nat = expr.info.type_description - and elt_nat' = expr'.info.type_description in - match Types.compare_element_natures elt_nat elt_nat' with - | Types.SameType -> - (alts @ [cond', expr]), expr' - | _ -> - raise (CompilError - {err_msg = ["_TypeConflictsInIfAlternExprs"]; - err_info = - [("_TypeOfThenBranche", - Types.string_of_element_nature elt_nat); - ("_TypeOfElseBranche", - Types.string_of_element_nature elt_nat')]; - err_ctx = ctx}) (*error*) in - let expr' = resolve_data_expression ctx expr' in - let alts, expr' = List.fold_left resolve_alternatives ([], expr') alts in - let nat = If (alts, expr') in - resolved_expression (Some expr) nat expr'.info.type_description - -and resolve_indexed_access ctx expr expr' subs = - let expres' = resolve_expression ctx expr' in - let rec resolve_component_indexed_access cl_spec subs = - match cl_spec, subs with - | (Types.PredefinedType _ | Types.ClassType _ | Types.ComponentType _ | - Types.ArrayType _ | Types.TupleType _), [] -> cl_spec - | (Types.PredefinedType _ | Types.ClassType _ | Types.ComponentType _ | - Types.TupleType _), _ :: _ -> - raise (CompilError - {err_msg = ["_CannotSubscriptANonArrayTypeElem"]; - err_info = - [("_ExpectedType", "_ArrayType"); - ("_TypeFound", Types.string_of_class_specifier cl_spec)]; - err_ctx = ctx}) (*error*) - | Types.ArrayType (_, cl_spec'), sub :: subs' -> - let cl_spec' = resolve_component_indexed_access cl_spec' subs' in - subarray_access sub cl_spec' - and subarray_access sub cl_spec = - let subarray_access' = function - | Types.PredefinedType { Types.base_type = Types.IntegerType } -> cl_spec - | Types.ArrayType - (dim, Types.PredefinedType { Types.base_type = Types.IntegerType }) -> - Types.ArrayType (dim, cl_spec) - | Types.PredefinedType _ | Types.ClassType _ | Types.ComponentType _ | - Types.ArrayType _ | Types.TupleType _ -> assert false (*error*) in - match sub.info.type_description with - | Types.ComponentElement cpnt_type -> - let cl_spec' = evaluate cpnt_type.Types.base_class in - subarray_access' cl_spec' - | Types.ClassElement _ | Types.ComponentTypeElement _ | - Types.PredefinedTypeElement _ -> assert false (*error*) in - match expres'.info.type_description with - | Types.ComponentElement cpnt_type -> - let cl_spec = evaluate cpnt_type.Types.base_class in - let subs' = resolve_subscripts ctx expres' cl_spec subs in - let cpnt_type' = - { cpnt_type with - Types.base_class = - lazy (resolve_component_indexed_access cl_spec subs') - } in - let info = - { - syntax = Some expr; - type_description = Types.ComponentElement cpnt_type' - } in - { nature = IndexedAccess (expres', subs'); info = info } - | Types.ClassElement _ | Types.ComponentTypeElement _ | - Types.PredefinedTypeElement _ -> - raise (CompilError - {err_msg = ["_ClassElemFoundInExpr"]; - err_info = []; - err_ctx = ctx}) (*error*) - -and resolve_integer ctx expr s = - let nat = - try - Integer (Int32.of_string s) - with - | _ -> - raise (CompilError - {err_msg = ["_InvalidInteger"; s]; - err_info = []; - err_ctx = ctx}) in - resolved_expression (Some expr) nat (Types.integer_type Types.Constant) - -and resolve_matrix_construction ctx expr exprss = - raise (CompilError - {err_msg = ["_NotYetImplemented"; "_MatrixExpr"]; - err_info = []; - err_ctx = ctx}) - -and resolve_no_event ctx expr expr' = - let expr' = resolve_expression ctx expr' in - match expr'.info.type_description with - | Types.ComponentElement cpnt_type -> - let nat = NoEvent expr' - and flow = lazy (evaluate cpnt_type.Types.flow) - and var = lazy Types.Continuous - and inout = cpnt_type.Types.causality - and cl_spec = cpnt_type.Types.base_class in - let cpnt_type = - component_element flow var inout cl_spec in - let elt_nat = Types.ComponentElement cpnt_type in - resolved_expression (Some expr) nat elt_nat - | _ -> - raise (CompilError - {err_msg = ["_ClassElemFoundInExpr"]; - err_info = []; - err_ctx = ctx}) (*error*) - -and resolve_range ctx expr start step stop = - let integer_range var start' step' stop' = - let integer_range' = - match start'.nature, step'.nature, stop'.nature with - | _, _, _ when Types.higher_variability var Types.Discrete -> - let var = Types.string_of_variability var in - raise (CompilError - {err_msg = ["_InvalidVarOfRangeExpr"]; - err_info = [("_Expr", Syntax.string_of_range start step stop); - ("_ExpectedVariability", "parameter"); - ("_VariabilityFound", var)]; - err_ctx = ctx}) - | Integer i, Integer p, Integer j when p = Int32.zero -> - raise (CompilError - {err_msg = ["_RangeStepValueCannotBeNull"]; - err_info = [("_Expr", Syntax.string_of_range start step stop)]; - err_ctx = ctx}) - | Integer i, Integer p, Integer j -> - let dim = Int32.div (Int32.succ (Int32.sub j i)) p in - Types.integer_array_type var (Types.ConstantDimension dim) - | (Integer _ | DynamicIdentifier _ | LocalIdentifier _ | - LoopVariable _ | PredefinedIdentifier _ | ToplevelIdentifier _), - (Integer _ | DynamicIdentifier _ | LocalIdentifier _ | - LoopVariable _ | PredefinedIdentifier _ | ToplevelIdentifier _), - (Integer _ | DynamicIdentifier _ | LocalIdentifier _ | - LoopVariable _ | PredefinedIdentifier _ | ToplevelIdentifier _) -> - Types.integer_array_type var Types.ParameterDimension - | _, _, _ -> - raise (CompilError - {err_msg = ["_NotYetImplemented"; "_NonIntegerRangeExpr"]; - err_info = [("_Expr", Syntax.string_of_range start step stop)]; - err_ctx = ctx}) in - let nat = Range (start', step', stop') in - let elt_nat = integer_range' in - resolved_expression (Some expr) nat elt_nat in - let start' = resolve_expression ctx start - and step' = match step with - | None -> one - | Some expr -> resolve_expression ctx expr - and stop' = resolve_expression ctx stop in - let resolve_range' var start_cl_spec step_cl_spec stop_cl_spec = - match start_cl_spec, step_cl_spec, stop_cl_spec with - | Types.PredefinedType { Types.base_type = Types.IntegerType }, - Types.PredefinedType { Types.base_type = Types.IntegerType }, - Types.PredefinedType { Types.base_type = Types.IntegerType } -> - integer_range var start' step' stop' - (*| Types.PredefinedType { Types.base_type = Types.IntegerType }, - Types.PredefinedType { Types.base_type = Types.IntegerType }, - _ -> assert false*) - | _ -> raise (CompilError - {err_msg = ["_NotYetImplemented"; "_NonIntegerRangeExpr"]; - err_info = [("_Expr", Syntax.string_of_range start step stop)]; - err_ctx = ctx}) in - let start_elt_nat = start'.info.type_description - and step_elt_nat = step'.info.type_description - and stop_elt_nat = stop'.info.type_description in - match start_elt_nat, step_elt_nat, stop_elt_nat with - | Types.ComponentElement start_cpnt_type, - Types.ComponentElement step_cpnt_type, - Types.ComponentElement stop_cpnt_type -> - let start_cl_spec = evaluate start_cpnt_type.Types.base_class - and step_cl_spec = evaluate step_cpnt_type.Types.base_class - and stop_cl_spec = evaluate stop_cpnt_type.Types.base_class - and start_var = evaluate start_cpnt_type.Types.variability - and step_var = evaluate step_cpnt_type.Types.variability - and stop_var = evaluate stop_cpnt_type.Types.variability in - let var = - let var' = Types.max_variability step_var stop_var in - Types.max_variability start_var var' in - resolve_range' var start_cl_spec step_cl_spec stop_cl_spec - | _ -> raise (CompilError - {err_msg = ["_InvalidTypeInRangeExpr"]; - err_info = [("_Expr", Syntax.string_of_range start step stop)]; - err_ctx = ctx}) (*error*) - -and resolve_real ctx expr s = - let nat = Real (float_of_string s) in - resolved_expression (Some expr) nat (Types.real_type Types.Constant) - -and resolve_string ctx expr s = - resolved_expression (Some expr) (String s) (Types.string_type Types.Constant) - -and resolve_true ctx expr = - resolved_expression (Some expr) True (Types.boolean_type Types.Constant) - -and resolve_tuple ctx expr exprs = - let max_element_variability var expr expr' = - match expr'.info.type_description with - | Types.ComponentElement cpnt_type -> - let var' = evaluate cpnt_type.Types.variability in - Types.max_variability var var' - | Types.ClassElement _ | Types.ComponentTypeElement _ | - Types.PredefinedTypeElement _ -> - raise (CompilError - {err_msg = ["_ClassElemFoundInExpr"]; - err_info = []; - err_ctx = ctx}) (*error*) - and class_specifier expr expr' = - match expr'.info.type_description with - | Types.ComponentElement cpnt_type -> evaluate cpnt_type.Types.base_class - | Types.ClassElement _ | Types.ComponentTypeElement _ | - Types.PredefinedTypeElement _ -> - raise (CompilError - {err_msg = ["_ClassElemFoundInExpr"]; - err_info = []; - err_ctx = ctx}) (*error*) in - let exprs' = List.map (resolve_expression ctx) exprs in - let flow = lazy false - and var = - lazy (List.fold_left2 max_element_variability Types.Constant exprs exprs') - and inout = lazy Types.Acausal - and cl_spec = lazy (Types.TupleType (List.map2 class_specifier exprs exprs')) in - { - nature = Tuple exprs'; - info = - { - syntax = Some expr; - type_description = - Types.ComponentElement (component_element flow var inout cl_spec) - } - } - -and resolve_unuary_operation ctx expr kind arg = - let arg' = resolve_expression ctx arg in - match kind.Syntax.nature with - | Syntax.UnaryMinus -> resolve_unary_minus ctx expr arg' - | Syntax.Not -> resolve_not ctx expr arg' - | Syntax.UnaryPlus -> - raise (CompilError - {err_msg = ["_NotYetImplemented"; "_UnaryOperPLUS"]; - err_info = []; - err_ctx = ctx}) - -and resolve_vector ctx expr vec_elts = match vec_elts.Syntax.nature with - | Syntax.VectorReduction (expr', for_inds) -> - resolve_vector_reduction ctx expr expr' for_inds - | Syntax.VectorElements exprs -> resolve_vector_elements ctx expr exprs - -and resolve_vector_reduction ctx expr expr' for_inds = - let vector_reduction_type acc expr expr' = - let add_dimension elt_nat cl_spec = - let add_dimension' cl_spec' = match cl_spec' with - | Types.ArrayType (dim, _) -> Types.ArrayType (dim, cl_spec) - | Types.PredefinedType _ | Types.ClassType _ | - Types.ComponentType _ | Types.TupleType _ -> - raise (CompilError - {err_msg = ["_InvalidTypeInRangeExpr"]; - err_info = - [("_ExpectedType", "_ArrayType"); - ("_TypeFound", - Types.string_of_class_specifier cl_spec')]; - err_ctx = ctx}) (*error*) in - match elt_nat with - | Types.ComponentElement cpnt_type -> - let cl_spec' = evaluate cpnt_type.Types.base_class in - add_dimension' cl_spec' - | Types.ClassElement _ | Types.ComponentTypeElement _ | - Types.PredefinedTypeElement _ -> - raise (CompilError - {err_msg = ["_ClassElemFoundInExpr"]; - err_info = []; - err_ctx = ctx}) (*error*) in - let rec vector_reduction_type' acc cl_spec = match acc with - | [] -> cl_spec - | range :: acc -> - let elt_nat = range.info.type_description in - let cl_spec' = add_dimension elt_nat cl_spec in - vector_reduction_type' acc cl_spec' in - match expr'.info.type_description with - | Types.ComponentElement cpnt_type -> - let cl_spec = evaluate cpnt_type.Types.base_class in - let cpnt_type' = - { cpnt_type with - Types.base_class = lazy (vector_reduction_type' acc cl_spec) - } in - Types.ComponentElement cpnt_type' - | Types.ClassElement _ | Types.ComponentTypeElement _ | - Types.PredefinedTypeElement _ -> - raise (CompilError - {err_msg = ["_ClassElemFoundInExpr"]; - err_info = []; - err_ctx = ctx}) (*error*) - and range_element_type range range' = - let sub_dimension cl_spec = match cl_spec with - | Types.ArrayType (dim, cl_spec) -> cl_spec - | Types.PredefinedType _ | Types.ClassType _ | - Types.ComponentType _ | Types.TupleType _ -> - raise (CompilError - {err_msg = ["_InvalidTypeInRangeExpr"]; - err_info = - [("_ExpectedType", "_ArrayType"); - ("_TypeFound", Types.string_of_class_specifier cl_spec)]; - err_ctx = ctx}) (*error*) in - match range'.info.type_description with - | Types.ComponentElement cpnt_type -> - let cl_spec = evaluate cpnt_type.Types.base_class in - let cpnt_type' = - { cpnt_type with - Types.base_class = lazy (sub_dimension cl_spec) - } in - Types.ComponentElement cpnt_type' - | Types.ClassElement _ | Types.ComponentTypeElement _ | - Types.PredefinedTypeElement _ -> - raise (CompilError - {err_msg = ["_ClassElemFoundInExpr"]; - err_info = []; - err_ctx = ctx}) (*error*) in - let rec resolve_vector_reduction' acc ctx = function - | [] -> - let expres' = resolve_expression ctx expr' in - let nat = VectorReduction (List.rev acc, expres') - and elt_nat = vector_reduction_type acc expr' expres' in - resolved_expression (Some expr) nat elt_nat - | (_, None) :: _ -> - raise (CompilError - {err_msg = ["_NotYetImplemented"; "_ImplicitIterRange"]; - err_info = [("_Expr", Syntax.string_of_for_inds for_inds)]; - err_ctx = ctx}) - | (id, Some range) :: for_inds -> - let range' = resolve_expression ctx range in - let elt_nat = range_element_type range range' in - let ctx' = - { ctx with - context_nature = ForContext (ctx, id, elt_nat) - } in - resolve_vector_reduction' (range' :: acc) ctx' for_inds in - resolve_vector_reduction' [] ctx for_inds - -and resolve_vector_elements ctx expr exprs = - let max_variability var cpnt_type = - let var' = evaluate cpnt_type.Types.variability in - Types.max_variability var var' in - let type_of_elements cpnt_types = - let rec type_of_elements' cl_spec = function - | [] -> cl_spec - | cpnt_type :: cpnt_types -> - let cl_spec' = evaluate cpnt_type.Types.base_class in - type_of_elements' (update cl_spec cl_spec') cpnt_types - and update cl_spec cl_spec' = - match Types.compare_specifiers cl_spec cl_spec' with - | Types.SameType | Types.Supertype -> cl_spec - | Types.Subtype -> cl_spec' - | _ -> - raise (CompilError - {err_msg = ["_TypeConflictsInVectorExpr"]; - err_info = - [("_MismatchingTypes", - Types.string_of_class_specifier cl_spec ^ ", " ^ - Types.string_of_class_specifier cl_spec')]; - err_ctx = ctx}) in - match cpnt_types with - | [] -> assert false (*error*) - | cpnt_type :: cpnt_types -> - let cl_spec' = evaluate cpnt_type.Types.base_class in - type_of_elements' cl_spec' cpnt_types in - let exprs' = List.map (resolve_expression ctx) exprs in - let exprs' = apply_binary_coercions exprs' in - let cpnt_types = List.map (component_type_of_expression ctx) exprs' in - let var = lazy (List.fold_left max_variability Types.Constant cpnt_types) in - let cl_spec = type_of_elements cpnt_types in - let dim = Types.ConstantDimension (Int32.of_int (List.length exprs')) in - let cl_spec' = lazy (Types.ArrayType (dim, cl_spec)) in - let cpnt_type = - { - Types.flow = lazy false; - variability = var; - causality = lazy Types.Acausal; - base_class = cl_spec' - } in - let nat = Vector exprs' - and elt_nat = Types.ComponentElement cpnt_type in - resolved_expression (Some expr) nat elt_nat - -and resolve_and ctx expr arg arg' = - let resolve_and' cpnt_type cpnt_type' = - let rec and_type cl_spec cl_spec' = match cl_spec, cl_spec' with - | Types.PredefinedType { Types.base_type = Types.BooleanType }, - Types.PredefinedType { Types.base_type = Types.BooleanType } -> - Types.PredefinedType - { Types.base_type = Types.BooleanType; attributes = [] } - | Types.PredefinedType { Types.base_type = Types.BooleanType }, - (Types.PredefinedType _ | Types.ClassType _ | Types.ComponentType _ | - Types.ArrayType _ | Types.TupleType _) -> - raise (CompilError - {err_msg = ["and"; "_OperAppliedToNonBoolExpr"]; - err_info = - [("_ExpectedType", "Boolean"); - ("_TypeFound", Types.string_of_class_specifier cl_spec')]; - err_ctx = ctx}) (*error*) - | (Types.PredefinedType _ | Types.ClassType _ | Types.ComponentType _ | - Types.ArrayType _ | Types.TupleType _), - (Types.PredefinedType _ | Types.ClassType _ | Types.ComponentType _ | - Types.ArrayType _ | Types.TupleType _) -> - raise (CompilError - {err_msg = ["and"; "_OperAppliedToNonBoolExpr"]; - err_info = - [("_ExpectedType", "Boolean"); - ("_TypeFound", Types.string_of_class_specifier cl_spec)]; - err_ctx = ctx}) (*error*) in - let var = - lazy ( - let var = evaluate cpnt_type.Types.variability - and var' = evaluate cpnt_type'.Types.variability in - Types.max_variability var var') - and inout = Types.Acausal - and cl_spec = - lazy ( - let cl_spec = evaluate cpnt_type.Types.base_class - and cl_spec' = evaluate cpnt_type'.Types.base_class in - and_type cl_spec cl_spec') in - let nat = BinaryOperation (And, arg, arg') in - let elt_nat = - let cpnt_type = - component_element (lazy false) var (lazy inout) cl_spec in - Types.ComponentElement cpnt_type in - resolved_expression (Some expr) nat elt_nat in - match arg.info.type_description, arg'.info.type_description with - | Types.ComponentElement cpnt_type, Types.ComponentElement cpnt_type' -> - resolve_and' cpnt_type cpnt_type' - | Types.ComponentElement _, - (Types.ClassElement _ | Types.ComponentTypeElement _ | - Types.PredefinedTypeElement _) -> - raise (CompilError - {err_msg = ["_ClassElemFoundInExpr"]; - err_info = []; - err_ctx = ctx}) (*error*) - | (Types.ClassElement _ | Types.ComponentTypeElement _ | - Types.PredefinedTypeElement _), - (Types.ComponentElement _ | Types.ClassElement _ | - Types.ComponentTypeElement _ | Types.PredefinedTypeElement _) -> - raise (CompilError - {err_msg = ["_ClassElemFoundInExpr"]; - err_info = []; - err_ctx = ctx}) (*error*) - -and resolve_or ctx expr arg arg' = - let resolve_or' cpnt_type cpnt_type' = - let rec or_type cl_spec cl_spec' = match cl_spec, cl_spec' with - | Types.PredefinedType { Types.base_type = Types.BooleanType }, - Types.PredefinedType { Types.base_type = Types.BooleanType } -> - Types.PredefinedType - { Types.base_type = Types.BooleanType; attributes = [] } - | Types.PredefinedType { Types.base_type = Types.BooleanType }, - (Types.PredefinedType _ | Types.ClassType _ | Types.ComponentType _ | - Types.ArrayType _ | Types.TupleType _) -> - raise (CompilError - {err_msg = ["or"; "_OperAppliedToNonBoolExpr"]; - err_info = - [("_ExpectedType", "Boolean"); - ("_TypeFound", Types.string_of_class_specifier cl_spec')]; - err_ctx = ctx}) (*error*) - | (Types.PredefinedType _ | Types.ClassType _ | Types.ComponentType _ | - Types.ArrayType _ | Types.TupleType _), - (Types.PredefinedType _ | Types.ClassType _ | Types.ComponentType _ | - Types.ArrayType _ | Types.TupleType _) -> - raise (CompilError - {err_msg = ["or"; "_OperAppliedToNonBoolExpr"]; - err_info = - [("_ExpectedType", "Boolean"); - ("_TypeFound", Types.string_of_class_specifier cl_spec)]; - err_ctx = ctx}) (*error*) in - let var = - lazy (let var = evaluate cpnt_type.Types.variability - and var' = evaluate cpnt_type'.Types.variability in - Types.max_variability var var') - and inout = Types.Acausal - and cl_spec = - lazy (let cl_spec = evaluate cpnt_type.Types.base_class - and cl_spec' = evaluate cpnt_type'.Types.base_class in - or_type cl_spec cl_spec') in - let nat = BinaryOperation (Or, arg, arg') in - let elt_nat = - let cpnt_type = - component_element (lazy false) var (lazy inout) cl_spec in - Types.ComponentElement cpnt_type in - resolved_expression (Some expr) nat elt_nat in - match arg.info.type_description, arg'.info.type_description with - | Types.ComponentElement cpnt_type, Types.ComponentElement cpnt_type' -> - resolve_or' cpnt_type cpnt_type' - | (Types.ComponentElement _ | Types.ClassElement _ | - Types.ComponentTypeElement _ | Types.PredefinedTypeElement _), - (Types.ComponentElement _ | Types.ClassElement _ | - Types.ComponentTypeElement _ | Types.PredefinedTypeElement _) -> - raise (CompilError - {err_msg = ["_ClassElemFoundInExpr"]; - err_info = []; - err_ctx = ctx}) (*error*) - -and resolve_addition ctx expr arg arg' = - let resolve_addition' cpnt_type cpnt_type' = - let rec addition_type cl_spec cl_spec' = match cl_spec, cl_spec' with - | Types.ArrayType (Types.ConstantDimension n, _), - Types.ArrayType (Types.ConstantDimension n', _) when n <> n' -> - raise (CompilError - {err_msg = ["_ArrayDimMustAgreeToPerform"; "_Addition"]; - err_info = - [("_ExprKind", "A + B"); - ("_TypeOfA", Types.string_of_class_specifier cl_spec); - ("_TypeOfB", Types.string_of_class_specifier cl_spec')]; - err_ctx = ctx}) (*error*) - | Types.ArrayType (Types.ConstantDimension _, cl_spec), - Types.ArrayType (dim, cl_spec') | - Types.ArrayType (dim, cl_spec), - Types.ArrayType (Types.ConstantDimension _, cl_spec') -> - Types.ArrayType (dim, addition_type cl_spec cl_spec') - | Types.ArrayType (Types.ParameterDimension, cl_spec), - Types.ArrayType (dim, cl_spec') | - Types.ArrayType (dim, cl_spec), - Types.ArrayType (Types.ParameterDimension, cl_spec') -> - Types.ArrayType (dim, addition_type cl_spec cl_spec') - | Types.ArrayType (Types.DiscreteDimension, cl_spec), - Types.ArrayType (Types.DiscreteDimension, cl_spec') -> - Types.ArrayType - (Types.DiscreteDimension, addition_type cl_spec cl_spec') - | Types.PredefinedType { Types.base_type = Types.IntegerType }, - Types.PredefinedType { Types.base_type = Types.IntegerType } -> - Types.PredefinedType - { Types.base_type = Types.IntegerType; attributes = [] } - | Types.PredefinedType - { Types.base_type = Types.RealType | Types.IntegerType }, - Types.PredefinedType - { Types.base_type = Types.RealType | Types.IntegerType } -> - Types.PredefinedType - { Types.base_type = Types.RealType; attributes = [] } - | Types.PredefinedType _, Types.ArrayType _ - | Types.ArrayType _, Types.PredefinedType _ -> - raise (CompilError - {err_msg = ["+"; "_OperBetweenScalarAndArray"]; - err_info = - [("_ExprKind", "A + B"); - ("_TypeOfA", Types.string_of_class_specifier cl_spec); - ("_TypeOfB", Types.string_of_class_specifier cl_spec')]; - err_ctx = ctx}) (*error*) - | _, _ -> - raise (CompilError - {err_msg = ["+"; "_OperAppliedToNonNumericExpr"]; - err_info = - [("_ExprKind", "A + B"); - ("_TypeOfA", Types.string_of_class_specifier cl_spec); - ("_TypeOfB", Types.string_of_class_specifier cl_spec')]; - err_ctx = ctx}) (*error*) in - let var = - lazy (let var = evaluate cpnt_type.Types.variability - and var' = evaluate cpnt_type'.Types.variability in - Types.max_variability var var') - and inout = Types.Acausal - and cl_spec = - lazy (let cl_spec = evaluate cpnt_type.Types.base_class - and cl_spec' = evaluate cpnt_type'.Types.base_class in - addition_type cl_spec cl_spec') in - let nat = BinaryOperation (Plus, arg, arg') in - let elt_nat = - let cpnt_type = - component_element (lazy false) var (lazy inout) cl_spec in - Types.ComponentElement cpnt_type in - resolved_expression (Some expr) nat elt_nat in - match arg.info.type_description, arg'.info.type_description with - | Types.ComponentElement cpnt_type, Types.ComponentElement cpnt_type' -> - resolve_addition' cpnt_type cpnt_type' - | (Types.ComponentElement _ | Types.ClassElement _ | - Types.ComponentTypeElement _ | Types.PredefinedTypeElement _), - (Types.ComponentElement _ | Types.ClassElement _ | - Types.ComponentTypeElement _ | Types.PredefinedTypeElement _) -> - raise (CompilError - {err_msg = ["_ClassElemFoundInExpr"]; - err_info = []; - err_ctx = ctx}) (*error*) - -and resolve_comparison ctx expr kind arg arg' = - let resolve_comparison' cpnt_type cpnt_type' = - let rec comparison_type cl_spec cl_spec' = match cl_spec, cl_spec' with - | Types.PredefinedType - { Types.base_type = Types.IntegerType | Types.RealType }, - Types.PredefinedType - { Types.base_type = Types.IntegerType | Types.RealType } -> - Types.PredefinedType - { Types.base_type = Types.BooleanType; attributes = [] } - | (Types.PredefinedType _ | Types.ClassType _ | Types.ComponentType _ | - Types.ArrayType _ | Types.TupleType _), - (Types.PredefinedType _ | Types.ClassType _ | Types.ComponentType _ | - Types.ArrayType _ | Types.TupleType _) -> - raise (CompilError - {err_msg = ["_TypeInconsistWithComparOper"]; - err_info = - [("_ExprKind", "A" ^ (string_of_bin_oper_kind kind) ^ "B"); - ("_TypeOfA", Types.string_of_class_specifier cl_spec); - ("_TypeOfB", Types.string_of_class_specifier cl_spec')]; - err_ctx = ctx}) (*error*) in - (*let var = - let var = evaluate cpnt_type.Types.variability - and var' = evaluate cpnt_type'.Types.variability in - Types.max_variability var var'*) - let var = Types.Discrete - and inout = Types.Acausal - and cl_spec = - lazy (let cl_spec = evaluate cpnt_type.Types.base_class - and cl_spec' = evaluate cpnt_type'.Types.base_class in - comparison_type cl_spec cl_spec') in - let nat = BinaryOperation (kind, arg, arg') in - let elt_nat = - let cpnt_type = - component_element (lazy false) (lazy var) (lazy inout) cl_spec in - Types.ComponentElement cpnt_type in - resolved_expression (Some expr) nat elt_nat in - match arg.info.type_description, arg'.info.type_description with - | Types.ComponentElement cpnt_type, Types.ComponentElement cpnt_type' -> - resolve_comparison' cpnt_type cpnt_type' - | (Types.ComponentElement _ | Types.ClassElement _ | - Types.ComponentTypeElement _ | Types.PredefinedTypeElement _), - (Types.ComponentElement _ | Types.ClassElement _ | - Types.ComponentTypeElement _ | Types.PredefinedTypeElement _) -> - raise (CompilError - {err_msg = ["_ClassElemFoundInExpr"]; - err_info = []; - err_ctx = ctx}) (*error*) - -and resolve_division ctx expr arg arg' = - let resolve_division' cpnt_type cpnt_type' = - let rec division_type cl_spec cl_spec' = match cl_spec, cl_spec' with - | Types.ArrayType (dim, cl_spec), - Types.PredefinedType - { Types.base_type = Types.IntegerType | Types.RealType } -> - Types.ArrayType (dim, division_type cl_spec cl_spec') - | Types.PredefinedType - { Types.base_type = Types.RealType | Types.IntegerType }, - Types.PredefinedType - { Types.base_type = Types.RealType | Types.IntegerType } -> - Types.PredefinedType - { Types.base_type = Types.RealType; attributes = [] } - | (Types.PredefinedType _ | Types.ClassType _ | Types.ComponentType _ | - Types.ArrayType _ | Types.TupleType _), - (Types.PredefinedType _ | Types.ClassType _ | Types.ComponentType _ | - Types.ArrayType _ | Types.TupleType _) -> - raise (CompilError - {err_msg = ["_TypeInconsistentWithDivOper"]; - err_info = - [("_ExprKind", "A / B"); - ("_TypeOfA", Types.string_of_class_specifier cl_spec); - ("_TypeOfB", Types.string_of_class_specifier cl_spec')]; - err_ctx = ctx}) (*error*) in - let var = - lazy (let var = evaluate cpnt_type.Types.variability - and var' = evaluate cpnt_type'.Types.variability in - Types.max_variability var var') - and inout = Types.Acausal - and cl_spec = - lazy (let cl_spec = evaluate cpnt_type.Types.base_class - and cl_spec' = evaluate cpnt_type'.Types.base_class in - division_type cl_spec cl_spec') in - let nat = BinaryOperation (Divide, arg, arg') in - let elt_nat = - let cpnt_type = - component_element (lazy false) var (lazy inout) cl_spec in - Types.ComponentElement cpnt_type in - resolved_expression (Some expr) nat elt_nat in - match arg.info.type_description, arg'.info.type_description with - | Types.ComponentElement cpnt_type, Types.ComponentElement cpnt_type' -> - resolve_division' cpnt_type cpnt_type' - | (Types.ComponentElement _ | Types.ClassElement _ | - Types.ComponentTypeElement _ | Types.PredefinedTypeElement _), - (Types.ComponentElement _ | Types.ClassElement _ | - Types.ComponentTypeElement _ | Types.PredefinedTypeElement _) -> - raise (CompilError - {err_msg = ["_ClassElemFoundInExpr"]; - err_info = []; - err_ctx = ctx}) (*error*) - -and resolve_multiplication ctx expr arg arg' = - let resolve_multiplication' cpnt_type cpnt_type' = - let rec multiplication_type cl_spec cl_spec' = match cl_spec, cl_spec' with - | Types.ArrayType (_, Types.ArrayType (Types.ConstantDimension n, _)), - Types.ArrayType (Types.ConstantDimension n', Types.ArrayType _) - when n <> n' -> - raise (CompilError - {err_msg = ["_ArrayDimsNonCompatibleWithMult"]; - err_info = - [("_ExprKind", "A * B"); - ("_TypeOfA", Types.string_of_component_type cpnt_type); - ("_TypeOfB", Types.string_of_component_type cpnt_type')]; - err_ctx = ctx}) (*error*) - | Types.ArrayType - (dim, Types.ArrayType - (_, Types.PredefinedType - { Types.base_type = Types.IntegerType })), - Types.ArrayType - (_, Types.ArrayType - (dim', Types.PredefinedType - { Types.base_type = Types.IntegerType })) -> - Types.ArrayType - (dim, Types.ArrayType - (dim', Types.PredefinedType - { Types.base_type = Types.IntegerType; attributes = [] })) - | Types.ArrayType - (dim, Types.ArrayType - (_, Types.PredefinedType - { Types.base_type = Types.IntegerType | Types.RealType })), - Types.ArrayType - (_, Types.ArrayType - (dim', Types.PredefinedType - { Types.base_type = Types.IntegerType | Types.RealType })) -> - Types.ArrayType - (dim, Types.ArrayType - (dim', Types.PredefinedType - { Types.base_type = Types.RealType; attributes = [] })) - | Types.ArrayType (_, Types.ArrayType (Types.ConstantDimension n, _)), - Types.ArrayType (Types.ConstantDimension n', _) - when n <> n' -> - raise (CompilError - {err_msg = ["_ArrayDimsNonCompatibleWithMult"]; - err_info = - [("_ExprKind", "A * B"); - ("_TypeOfA", Types.string_of_class_specifier cl_spec); - ("_TypeOfB", Types.string_of_class_specifier cl_spec')]; - err_ctx = ctx}) (*error*) - | Types.ArrayType - (dim, Types.ArrayType - (_, Types.PredefinedType - { Types.base_type = Types.IntegerType })), - Types.ArrayType - (_, Types.PredefinedType - { Types.base_type = Types.IntegerType }) -> - Types.ArrayType - (dim, Types.PredefinedType - { Types.base_type = Types.IntegerType; attributes = [] }) - | Types.ArrayType - (dim, Types.ArrayType - (_, Types.PredefinedType - { Types.base_type = Types.IntegerType | Types.RealType })), - Types.ArrayType - (_, Types.PredefinedType - { Types.base_type = Types.IntegerType | Types.RealType }) -> - Types.ArrayType - (dim, Types.PredefinedType - { Types.base_type = Types.RealType; attributes = [] }) - | Types.ArrayType (Types.ConstantDimension n, _), - Types.ArrayType (Types.ConstantDimension n', Types.ArrayType _) - when n <> n' -> - raise (CompilError - {err_msg = ["_ArrayDimsNonCompatibleWithMult"]; - err_info = - [("_ExprKind", "A * B"); - ("_TypeOfA", Types.string_of_class_specifier cl_spec); - ("_TypeOfB", Types.string_of_class_specifier cl_spec')]; - err_ctx = ctx}) (*error*) - | Types.ArrayType - (_, Types.PredefinedType - { Types.base_type = Types.IntegerType }), - Types.ArrayType - (_, Types.ArrayType - (dim, Types.PredefinedType - { Types.base_type = Types.IntegerType })) -> - Types.ArrayType - (dim, Types.PredefinedType - { Types.base_type = Types.IntegerType; attributes = [] }) - | Types.ArrayType - (_, Types.PredefinedType - { Types.base_type = Types.IntegerType | Types.RealType }), - Types.ArrayType - (_, Types.ArrayType - (dim, Types.PredefinedType - { Types.base_type = Types.IntegerType | Types.RealType })) -> - Types.ArrayType - (dim, Types.PredefinedType - { Types.base_type = Types.RealType; attributes = [] }) - | Types.ArrayType (Types.ConstantDimension n, _), - Types.ArrayType (Types.ConstantDimension n', _) - when n <> n' -> - raise (CompilError - {err_msg = ["_ArrayDimsNonCompatibleWithMult"]; - err_info = - [("_ExprKind", "A * B"); - ("_TypeOfA", Types.string_of_class_specifier cl_spec); - ("_TypeOfB", Types.string_of_class_specifier cl_spec')]; - err_ctx = ctx}) (*error*) - | Types.ArrayType - (_, Types.PredefinedType - { Types.base_type = Types.IntegerType }), - Types.ArrayType - (_, Types.PredefinedType - { Types.base_type = Types.IntegerType }) -> - Types.PredefinedType - { Types.base_type = Types.IntegerType; attributes = [] } - | Types.ArrayType - (_, Types.PredefinedType - { Types.base_type = Types.IntegerType | Types.RealType }), - Types.ArrayType - (_, Types.PredefinedType - { Types.base_type = Types.IntegerType | Types.RealType }) -> - Types.PredefinedType - { Types.base_type = Types.RealType; attributes = [] } - | Types.PredefinedType - { Types.base_type = Types.IntegerType | Types.RealType }, - Types.ArrayType (dim, cl_spec') -> - Types.ArrayType (dim, multiplication_type cl_spec cl_spec') - | Types.ArrayType (dim, cl_spec), - Types.PredefinedType - { Types.base_type = Types.IntegerType | Types.RealType } -> - Types.ArrayType (dim, multiplication_type cl_spec cl_spec') - | Types.PredefinedType { Types.base_type = Types.IntegerType }, - Types.PredefinedType { Types.base_type = Types.IntegerType } -> - Types.PredefinedType - { Types.base_type = Types.IntegerType; attributes = [] } - | Types.PredefinedType - { Types.base_type = Types.RealType | Types.IntegerType }, - Types.PredefinedType - { Types.base_type = Types.RealType | Types.IntegerType } -> - Types.PredefinedType - { Types.base_type = Types.RealType; attributes = [] } - | (Types.PredefinedType _ | Types.ClassType _ | Types.ComponentType _ | - Types.ArrayType _ | Types.TupleType _), - (Types.PredefinedType _ | Types.ClassType _ | Types.ComponentType _ | - Types.ArrayType _ | Types.TupleType _) -> - raise (CompilError - {err_msg = ["*"; "_OperAppliedToNonNumericExpr"]; - err_info = - [("_ExprKind", "A * B"); - ("_TypeOfA", Types.string_of_class_specifier cl_spec); - ("_TypeOfB", Types.string_of_class_specifier cl_spec')]; - err_ctx = ctx}) (*error*) in - let var = - lazy (let var = evaluate cpnt_type.Types.variability - and var' = evaluate cpnt_type'.Types.variability in - Types.max_variability var var') - and inout = Types.Acausal - and cl_spec = - lazy (let cl_spec = evaluate cpnt_type.Types.base_class - and cl_spec' = evaluate cpnt_type'.Types.base_class in - multiplication_type cl_spec cl_spec') in - let nat = BinaryOperation (Times, arg, arg') in - let elt_nat = - let cpnt_type = - component_element (lazy false) var (lazy inout) cl_spec in - Types.ComponentElement cpnt_type in - resolved_expression (Some expr) nat elt_nat in - match arg.info.type_description, arg'.info.type_description with - | Types.ComponentElement cpnt_type, Types.ComponentElement cpnt_type' -> - resolve_multiplication' cpnt_type cpnt_type' - | (Types.ComponentElement _ | Types.ClassElement _ | - Types.ComponentTypeElement _ | Types.PredefinedTypeElement _), - (Types.ComponentElement _ | Types.ClassElement _ | - Types.ComponentTypeElement _ | Types.PredefinedTypeElement _) -> - raise (CompilError - {err_msg = ["_ClassElemFoundInExpr"]; - err_info = []; - err_ctx = ctx}) (*error*) - -and resolve_power ctx expr arg arg' = - let resolve_power' cpnt_type cpnt_type' = - let rec power_type cl_spec cl_spec' = match cl_spec, cl_spec' with - | Types.ArrayType - (Types.ConstantDimension n, Types.ArrayType - (Types.ConstantDimension n', _)), - Types.PredefinedType { Types.base_type = Types.IntegerType } - when n <> n' -> - raise (CompilError - {err_msg = ["_PowerOperOnNonSquareArray"]; - err_info = - [("_ExprKind", "A ^ B"); - ("_TypeOfA", Types.string_of_class_specifier cl_spec); - ("_TypeOfB", Types.string_of_class_specifier cl_spec')]; - err_ctx = ctx}) (*error*) - | Types.ArrayType - (dim, Types.ArrayType - (dim', Types.PredefinedType - { Types.base_type = Types.IntegerType })), - Types.PredefinedType { Types.base_type = Types.IntegerType } -> - Types.ArrayType - (dim, Types.ArrayType - (dim', Types.PredefinedType - { Types.base_type = Types.RealType; attributes = [] })) - | Types.ArrayType - (dim, Types.ArrayType - (dim', Types.PredefinedType { Types.base_type = Types.RealType })), - Types.PredefinedType { Types.base_type = Types.IntegerType } -> - Types.ArrayType - (dim, Types.ArrayType - (dim', Types.PredefinedType - { Types.base_type = Types.RealType; attributes = [] })) - | Types.PredefinedType { Types.base_type = Types.IntegerType }, - Types.PredefinedType { Types.base_type = Types.IntegerType } -> - Types.PredefinedType - { Types.base_type = Types.RealType; attributes = [] } - | Types.PredefinedType - { Types.base_type = Types.RealType | Types.IntegerType }, - Types.PredefinedType - { Types.base_type = Types.RealType | Types.IntegerType } -> - Types.PredefinedType - { Types.base_type = Types.RealType; attributes = [] } - | (Types.PredefinedType _ | Types.ClassType _ | Types.ComponentType _ | - Types.ArrayType _ | Types.TupleType _), - (Types.PredefinedType _ | Types.ClassType _ | Types.ComponentType _ | - Types.ArrayType _ | Types.TupleType _) -> - raise (CompilError - {err_msg = ["^"; "_OperAppliedToNonNumericExpr"]; - err_info = - [("_ExprKind", "A ^ B"); - ("_TypeOfA", Types.string_of_class_specifier cl_spec); - ("_TypeOfB", Types.string_of_class_specifier cl_spec')]; - err_ctx = ctx}) (*error*) in - let var = - lazy (let var = evaluate cpnt_type.Types.variability - and var' = evaluate cpnt_type'.Types.variability in - Types.max_variability var var') - and inout = Types.Acausal - and cl_spec = - lazy (let cl_spec = evaluate cpnt_type.Types.base_class - and cl_spec' = evaluate cpnt_type'.Types.base_class in - power_type cl_spec cl_spec') in - let nat = BinaryOperation (Power, arg, arg') in - let elt_nat = - let cpnt_type = - component_element (lazy false) var (lazy inout) cl_spec in - Types.ComponentElement cpnt_type in - resolved_expression (Some expr) nat elt_nat in - match arg.info.type_description, arg'.info.type_description with - | Types.ComponentElement cpnt_type, Types.ComponentElement cpnt_type' -> - resolve_power' cpnt_type cpnt_type' - | (Types.ComponentElement _ | Types.ClassElement _ | - Types.ComponentTypeElement _ | Types.PredefinedTypeElement _), - (Types.ComponentElement _ | Types.ClassElement _ | - Types.ComponentTypeElement _ | Types.PredefinedTypeElement _) -> - raise (CompilError - {err_msg = ["_ClassElemFoundInExpr"]; - err_info = []; - err_ctx = ctx}) (*error*) - -and resolve_subtraction ctx expr arg arg' = - let resolve_subtraction' cpnt_type cpnt_type' = - let rec subtraction_type cl_spec cl_spec' = match cl_spec, cl_spec' with - | Types.ArrayType (Types.ConstantDimension n, _), - Types.ArrayType (Types.ConstantDimension n', _) when n <> n' -> - raise (CompilError - {err_msg = ["_ArrayDimMustAgreeToPerform"; "_Subtraction"]; - err_info = - [("_ExprKind", "A - B"); - ("_TypeOfA", Types.string_of_class_specifier cl_spec); - ("_TypeOfB", Types.string_of_class_specifier cl_spec')]; - err_ctx = ctx}) (*error*) - | Types.ArrayType (Types.ConstantDimension _, cl_spec), - Types.ArrayType (dim, cl_spec') | - Types.ArrayType (dim, cl_spec), - Types.ArrayType (Types.ConstantDimension _, cl_spec') -> - Types.ArrayType (dim, subtraction_type cl_spec cl_spec') - | Types.ArrayType (Types.ParameterDimension, cl_spec), - Types.ArrayType (dim, cl_spec') | - Types.ArrayType (dim, cl_spec), - Types.ArrayType (Types.ParameterDimension, cl_spec') -> - Types.ArrayType (dim, subtraction_type cl_spec cl_spec') - | Types.ArrayType (Types.DiscreteDimension, cl_spec), - Types.ArrayType (Types.DiscreteDimension, cl_spec') -> - Types.ArrayType - (Types.DiscreteDimension, subtraction_type cl_spec cl_spec') - | Types.PredefinedType { Types.base_type = Types.IntegerType }, - Types.PredefinedType { Types.base_type = Types.IntegerType } -> - Types.PredefinedType - { Types.base_type = Types.IntegerType; attributes = [] } - | Types.PredefinedType - { Types.base_type = Types.RealType | Types.IntegerType }, - Types.PredefinedType - { Types.base_type = Types.RealType | Types.IntegerType } -> - Types.PredefinedType - { Types.base_type = Types.RealType; attributes = [] } - | (Types.PredefinedType _ | Types.ClassType _ | Types.ComponentType _ | - Types.ArrayType _ | Types.TupleType _), - (Types.PredefinedType _ | Types.ClassType _ | Types.ComponentType _ | - Types.ArrayType _ | Types.TupleType _) -> - raise (CompilError - {err_msg = ["-"; "_OperAppliedToNonNumericExpr"]; - err_info = - [("_ExprKind", "A - B"); - ("_TypeOfA", Types.string_of_class_specifier cl_spec); - ("_TypeOfB", Types.string_of_class_specifier cl_spec')]; - err_ctx = ctx}) (*error*) in - let var = - lazy (let var = evaluate cpnt_type.Types.variability - and var' = evaluate cpnt_type'.Types.variability in - Types.max_variability var var') - and inout = Types.Acausal - and cl_spec = - lazy (let cl_spec = evaluate cpnt_type.Types.base_class - and cl_spec' = evaluate cpnt_type'.Types.base_class in - subtraction_type cl_spec cl_spec') in - let nat = BinaryOperation (Minus, arg, arg') in - let elt_nat = - let cpnt_type = - component_element (lazy false) var (lazy inout) cl_spec in - Types.ComponentElement cpnt_type in - resolved_expression (Some expr) nat elt_nat in - match arg.info.type_description, arg'.info.type_description with - | Types.ComponentElement cpnt_type, Types.ComponentElement cpnt_type' -> - resolve_subtraction' cpnt_type cpnt_type' - | (Types.ComponentElement _ | Types.ClassElement _ | - Types.ComponentTypeElement _ | Types.PredefinedTypeElement _), - (Types.ComponentElement _ | Types.ClassElement _ | - Types.ComponentTypeElement _ | Types.PredefinedTypeElement _) -> - raise (CompilError - {err_msg = ["_ClassElemFoundInExpr"]; - err_info = []; - err_ctx = ctx}) (*error*) - -and resolve_unary_minus ctx expr arg = - let resolve_unary_minus' cpnt_type = - let rec unary_minus_type cl_spec = match cl_spec with - | Types.ArrayType (dim, cl_spec) -> - Types.ArrayType (dim, unary_minus_type cl_spec) - | Types.PredefinedType - { Types.base_type = Types.RealType | Types.IntegerType } -> cl_spec - | (Types.PredefinedType _ | Types.ClassType _ | Types.ComponentType _ | - Types.TupleType _) -> - raise (CompilError - {err_msg = ["-"; "_OperAppliedToNonNumericExpr"]; - err_info = - [("_ExprKind", "- A"); - ("_TypeOfA", Types.string_of_class_specifier cl_spec)]; - err_ctx = ctx}) (*error*) in - let var = cpnt_type.Types.variability - and inout = Types.Acausal - and cl_spec = - lazy (let cl_spec = evaluate cpnt_type.Types.base_class in - unary_minus_type cl_spec) in - let nat = UnaryOperation (UnaryMinus, arg) in - let elt_nat = - let cpnt_type = - component_element (lazy false) var (lazy inout) cl_spec in - Types.ComponentElement cpnt_type in - resolved_expression (Some expr) nat elt_nat in - match arg.info.type_description with - | Types.ComponentElement cpnt_type -> resolve_unary_minus' cpnt_type - | Types.ClassElement _ | - Types.ComponentTypeElement _ | Types.PredefinedTypeElement _ -> - raise (CompilError - {err_msg = ["_ClassElemFoundInExpr"]; - err_info = []; - err_ctx = ctx}) (*error*) - -and resolve_not ctx expr arg = - let resolve_not' cpnt_type = - let rec not_type cl_spec = match cl_spec with - | Types.PredefinedType { Types.base_type = Types.BooleanType } -> cl_spec - | (Types.PredefinedType _ | Types.ArrayType _ | Types.ClassType _ | - Types.ComponentType _ | Types.TupleType _) -> - raise (CompilError - {err_msg = ["not"; "_OperAppliedToNonBoolExpr"]; - err_info = - [("_ExprKind", "not A"); - ("_TypeOfA", Types.string_of_class_specifier cl_spec)]; - err_ctx = ctx}) (*error*) in - let var = cpnt_type.Types.variability - and inout = Types.Acausal - and cl_spec = - lazy (let cl_spec = evaluate cpnt_type.Types.base_class in - not_type cl_spec) in - let nat = UnaryOperation (Not, arg) in - let elt_nat = - let cpnt_type = - component_element (lazy false) var (lazy inout) cl_spec in - Types.ComponentElement cpnt_type in - resolved_expression (Some expr) nat elt_nat in - match arg.info.type_description with - | Types.ComponentElement cpnt_type -> resolve_not' cpnt_type - | Types.ClassElement _ | - Types.ComponentTypeElement _ | Types.PredefinedTypeElement _ -> - raise (CompilError - {err_msg = ["_ClassElemFoundInExpr"]; - err_info = []; - err_ctx = ctx}) (*error*) - -and component_element flow var inout cl_spec = - { - Types.flow = flow; - variability = var; - causality = inout; - base_class = cl_spec - } - -and element_nature_class ctx = function - | Types.ClassElement cl_spec -> evaluate cl_spec - | Types.ComponentElement cpnt_type -> evaluate cpnt_type.Types.base_class - | Types.PredefinedTypeElement predef -> Types.PredefinedType predef - | Types.ComponentTypeElement _ -> assert false (*error*) - -and element_field_type_nature ctx flow var inout cl_spec id = - let add_dimension dim = function - | Types.ComponentElement cpnt_type -> - let cpnt_type' = - { cpnt_type with - Types.base_class = - lazy (Types.ArrayType (dim, evaluate cpnt_type.Types.base_class)) - } in - Types.ComponentElement cpnt_type' - | Types.ClassElement _ - | Types.ComponentTypeElement _ - | Types.PredefinedTypeElement _ -> - raise (CompilError - {err_msg = ["_InvalidClassElemModif"]; - err_info = []; - err_ctx = ctx}) (*error*) in - let find_predefined_local_identifier predef id = - match predef.Types.base_type with - | Types.BooleanType when id = "start" -> Types.boolean_type Types.Parameter - | Types.IntegerType when id = "start" -> - Types.integer_type Types.Parameter - | Types.RealType when id = "start" -> - Types.real_type Types.Parameter - | Types.StringType when id = "start" -> Types.string_type Types.Parameter - | Types.EnumerationType enum_lits when id = "start" -> - Types.enumeration_type Types.Parameter enum_lits - | _ when id = "fixed" -> Types.boolean_type Types.Constant - | Types.IntegerType when id = "nominal" -> - Types.integer_type Types.Constant - | Types.RealType when id = "nominal" -> - Types.real_type Types.Constant - | _ -> - raise (CompilError - {err_msg = ["_NotYetImplemented"; "_PredefinedTypeAttribModif"; id]; - err_info = []; - err_ctx = ctx}) - and find_class_local_identifier flow var inout cl_type id = - let apply_prefixes elt_nat = match elt_nat with - | Types.ComponentElement cpnt_type -> - let flow' = lazy (flow || evaluate cpnt_type.Types.flow) in - Types.ComponentElement { cpnt_type with Types.flow = flow' } - | Types.ClassElement _ | Types.ComponentTypeElement _ | - Types.PredefinedTypeElement _ -> elt_nat in - try - let elt_type = - evaluate (List.assoc id cl_type.Types.named_elements) in - match elt_type.Types.dynamic_scope with - | None | Some Types.Inner | Some Types.InnerOuter - when not elt_type.Types.protected -> - apply_prefixes elt_type.Types.element_nature - | None | Some Types.Inner | Some Types.InnerOuter -> - raise (CompilError - {err_msg = ["_CannotAccessProtectElem"; id]; - err_info = []; - err_ctx = ctx}) (*error*) - | Some Types.Outer -> - raise (CompilError - {err_msg = ["_CannotAccessOuterElem"; id]; - err_info = []; - err_ctx = ctx}) (*error*) - with Not_found -> - raise (CompilError - {err_msg = ["_UnknownIdentifier"; id]; - err_info = []; - err_ctx = ctx }) (*error*) in - let rec find_local_identifier flow var inout = function - | Types.PredefinedType predef_type -> - find_predefined_local_identifier predef_type id - | Types.ClassType cl_type -> - find_class_local_identifier flow var inout cl_type id - | Types.ComponentType cpnt_type -> - let flow = flow || evaluate cpnt_type.Types.flow - and var = - Types.max_variability var (evaluate cpnt_type.Types.variability) - and inout = evaluate cpnt_type.Types.causality - and base_class = evaluate cpnt_type.Types.base_class in - find_local_identifier flow var inout base_class - | Types.ArrayType (dim, cl_spec) -> - add_dimension dim (find_local_identifier flow var inout cl_spec) - | Types.TupleType _ -> assert false (*error*) in - find_local_identifier flow var inout cl_spec - -and scalar_element_nature elt_nat = - let rec scalar_element_nature' cl_spec = match cl_spec with - | Types.PredefinedType _ | Types.ClassType _ | Types.ComponentType _ | - Types.TupleType _ -> cl_spec - | Types.ArrayType (_, cl_spec) -> scalar_element_nature' cl_spec in - match elt_nat with - | Types.ComponentElement cpnt_type -> - let base_class' = - lazy (scalar_element_nature' (evaluate cpnt_type.Types.base_class)) in - Types.ComponentElement { cpnt_type with Types.base_class = base_class' } - | Types.ClassElement _ | Types.ComponentTypeElement _ | - Types.PredefinedTypeElement _ -> elt_nat - -and resolve_lhs_expression ctx expr = - raise (CompilError - {err_msg = ["_NotYetImplemented"; - "_ExternalCallWithLeftHandSideExpr"]; - err_info = []; - err_ctx = ctx}) - -and resolve_subscripts ctx expr cl_spec subs = - let rec resolve_subscripts' n cl_spec subs = match cl_spec, subs with - | _, [] -> [] - | Types.ArrayType (dim, cl_spec'), sub :: subs' -> - let sub' = resolve_subscript ctx expr n dim sub in - sub' :: resolve_subscripts' (Int32.add n 1l) cl_spec' subs' - | (Types.PredefinedType _ | Types.ClassType _ | Types.ComponentType _ | - Types.TupleType _), _ :: _ -> - raise (CompilError - {err_msg = ["_CannotSubscriptANonArrayTypeElem"]; - err_info = - [("_ExpectedType", "_ArrayType"); - ("_TypeFound", Types.string_of_class_specifier cl_spec)]; - err_ctx = ctx}) (*error*) in - match subs.Syntax.nature with - | Syntax.Subscripts subs' -> resolve_subscripts' 1l cl_spec subs' - -and resolve_subscript ctx expr n dim sub = match sub.Syntax.nature with - | Syntax.Colon -> resolve_colon ctx expr n dim - | Syntax.Subscript expr' -> - let ctx' = - { ctx with - context_nature = SubscriptContext (ctx, expr, n, dim); - location = expr'.Syntax.info } in - resolve_subscript_expression ctx' expr' - -and resolve_colon ctx expr n dim = - let range var stop = - let nat = Range (one, one, stop) - and elt_nat = Types.integer_array_type var dim in - resolved_expression None nat elt_nat in - match dim with - | Types.ConstantDimension n -> - let stop = - let nat = Integer n - and elt_nat = Types.integer_type Types.Constant in - resolved_expression None nat elt_nat in - range Types.Constant stop - | Types.ParameterDimension -> - let stop = size_function_call ctx None expr n in - range Types.Parameter stop - | Types.DiscreteDimension -> - let stop = size_function_call ctx None expr n in - range Types.Discrete stop - -and resolve_subscript_expression ctx expr = - let expr' = resolve_expression ctx expr in - let resolve_subscript_expression' cpnt_type = - let cl_spec = evaluate cpnt_type.Types.base_class in - match cl_spec with - | Types.PredefinedType { Types.base_type = Types.IntegerType } | - Types.ArrayType - (_, Types.PredefinedType { Types.base_type = Types.IntegerType }) -> - expr' - | Types.PredefinedType _ | Types.ClassType _ | Types.ComponentType _ | - Types.ArrayType _ | Types.TupleType _ -> - raise (CompilError - {err_msg = ["_NonIntegerArraySubscript"]; - err_info = - [("_ExpectedType", "Integer"); - ("_TypeFound", Types.string_of_class_specifier cl_spec)]; - err_ctx = ctx}) (*error*) in - match expr'.info.type_description with - | Types.ComponentElement cpnt_type -> - resolve_subscript_expression' cpnt_type - | Types.ClassElement _ | Types.ComponentTypeElement _ | - Types.PredefinedTypeElement _ -> - raise (CompilError - {err_msg = ["_ClassElemFoundInExpr"]; - err_info = []; - err_ctx = ctx}) (*error*) - -and size_function_call ctx syn arg n = - let size_function_call' cpnt_type = - let cpnt_type' = - { cpnt_type with - Types.base_class = lazy (Types.integer_class_type) - } in - let size = - let nat = PredefinedIdentifier "size" - and elt_nat = - Types.function_type - [("@1", cpnt_type); - ("@2", Types.integer_component_type Types.Constant)] - ["@3", cpnt_type'] in - resolved_expression None nat elt_nat in - let elt_nat = Types.ComponentElement cpnt_type' in - let num = - let nat = Integer n - and elt_nat = Types.integer_type Types.Constant in - resolved_expression None nat elt_nat - and expr = - let args = - let arg1 = - let nat = FunctionArgument 1 - and elt_nat = arg.info.type_description in - resolved_expression None nat elt_nat - and arg2 = - let nat = FunctionArgument 2 - and elt_nat = Types.integer_type Types.Constant in - resolved_expression None nat elt_nat in - [arg1; arg2] in - let nat = FunctionInvocation args in - resolved_expression None nat elt_nat in - let nat = FunctionCall (size, [arg; num], expr) in - resolved_expression syn nat elt_nat in - match arg.info.type_description with - | Types.ComponentElement cpnt_type -> size_function_call' cpnt_type - | Types.ClassElement _ | Types.ComponentTypeElement _ | - Types.PredefinedTypeElement _ -> - raise (CompilError - {err_msg = ["_ClassElemFoundInExpr"]; - err_info = []; - err_ctx = ctx}) (*error*) - -and element_type ctx protect final repl dyn_scope elt_desc = - { - Types.protected = protect; - final = bool_of_final final; - replaceable = bool_of_replaceable repl; - dynamic_scope = dynamic_scope_of_dynamic_scope dyn_scope; - element_nature = element_nature_type ctx elt_desc - } - -and bool_of_replaceable = function - | None -> false - | Some Syntax.Replaceable -> true - -and dynamic_scope_of_dynamic_scope = function - | None -> None - | Some Syntax.Inner -> Some Types.Inner - | Some Syntax.Outer -> Some Types.Outer - | Some Syntax.InnerOuter -> Some Types.InnerOuter - -and element_nature_type ctx elt_desc = - let elt_nat = match elt_desc.element_nature with - | Component cpnt_desc -> Types.ComponentElement (evaluate cpnt_desc.component_type) - | Class cl_def -> Types.ClassElement cl_def.class_type - | ComponentType cpnt_type_desc -> - Types.ComponentTypeElement (evaluate cpnt_type_desc.described_type) - | PredefinedType predef -> Types.PredefinedTypeElement predef in - elt_nat - -and class_specifier_type ctx part kind cl_def cl_spec = - let class_kind kind cl_type = - let check_class () = - if has_inouts cl_type then - raise (CompilError - {err_msg = ["_CannotUseCausPrefixInGenClass"; - class_specifier_name cl_spec]; - err_info = []; - err_ctx = ctx}) (*error*) - else kind - and check_model () = kind - and check_block () = - raise (CompilError - {err_msg = ["_NotYetImplemented"; "_BlockElem"]; - err_info = []; - err_ctx = ctx}) - and check_record () = kind - and check_expandable_connector () = - raise (CompilError - {err_msg = ["_NotYetImplemented"; "_ExpandableConnector"]; - err_info = []; - err_ctx = ctx}) - and check_connector () = kind - and check_package () = kind - and check_function () = kind in - match kind with - | Types.Class -> check_class () - | Types.Model -> check_model () - | Types.Block -> check_block () - | Types.Record -> check_record () - | Types.ExpandableConnector -> check_expandable_connector () - | Types.Connector -> check_connector () - | Types.Package -> check_package () - | Types.Function -> check_function () in - let rec cl_type = - { - Types.partial = bool_of_partial part; - kind = lazy (class_kind kind cl_type); - named_elements = class_type_elements ctx kind cl_def - } in - Types.ClassType cl_type - -and bool_of_partial = function - | None -> false - | Some Syntax.Partial -> true - -and class_type_elements ctx kind cl_def = match evaluate cl_def.description with - | LongDescription long_desc -> long_description_type_elements ctx kind long_desc - | ShortDescription short_desc -> short_description_type_elements ctx kind short_desc - -and short_description_type_elements ctx kind short_desc = - let cl_type = evaluate short_desc.modified_class_type in - let kind' = evaluate cl_type.Types.kind in - match kind, kind' with - | Types.Class, Types.Class | - Types.Model, Types.Model | - Types.Block, Types.Block | - Types.Record, Types.Record | - Types.ExpandableConnector, Types.ExpandableConnector | - Types.Connector, Types.Connector | - Types.Package, Types.Package | - Types.Function, Types.Function -> cl_type.Types.named_elements - | (Types.Class | Types.Model | Types.Block | Types.Record | - Types.ExpandableConnector | Types.Connector | Types.Package | Types.Function), - (Types.Class | Types.Model | Types.Block | Types.Record | - Types.ExpandableConnector | Types.Connector | Types.Package | Types.Function) -> - raise (CompilError - {err_msg = ["_InheritFromDiffClassKindsNotAllowed"]; - err_info = []; - err_ctx = ctx}) (*error*) - -and long_description_type_elements ctx kind long_desc = - let type_element (id, elt_desc) = id, elt_desc.element_type in - let local_elts = List.map type_element long_desc.named_elements in - let add_extensions kinds exts = - let add_named_element protected named_elt named_elts = - let element_type elt_type = - let elt_type' = evaluate elt_type in - { elt_type' with Types.protected = - elt_type'.Types.protected || protected } in - match named_elt with - | id, _ when List.mem_assoc id named_elts -> - raise (CompilError - {err_msg = [id; "_AlreadyDeclaredInParentClass"]; - err_info = []; - err_ctx = ctx}) (*error*) - | id, elt_type -> (id, lazy (element_type elt_type)) :: named_elts in - let add_extension_contribution (visibility, modif_cl) named_elts = - let protected = bool_of_visibility visibility - and cl_type = evaluate modif_cl.modified_class_type in - let named_elts' = cl_type.Types.named_elements in - if List.mem (evaluate cl_type.Types.kind) kinds then - List.fold_right (add_named_element protected) named_elts' named_elts - else - raise (CompilError - {err_msg = ["_InheritFromDiffClassKindsNotAllowed"]; - err_info = []; - err_ctx = ctx}) (*error*) in - List.fold_right add_extension_contribution exts local_elts in - match kind, long_desc.extensions with - | Types.Function, [] -> local_elts - | Types.Function, _ :: _ -> - raise (CompilError - {err_msg = ["_InheritFromFunctionNotAllowed"]; - err_info = []; - err_ctx = ctx}) (*error*) - | (Types.Class | Types.Model | Types.Block | Types.Record | Types.Connector | Types.Package), - exts -> add_extensions [kind] exts - | Types.ExpandableConnector, exts -> - add_extensions [kind; Types.Connector] exts - -and bool_of_visibility = function - | Public -> false - | Protected -> true - -and has_inouts cl_type = - let is_inout_component cpnt_type = - match evaluate cpnt_type.Types.causality with - | Types.Input | Types.Output -> true - | Types.Acausal -> false in - let is_inout = function - | Types.ComponentElement cpnt_type -> is_inout_component cpnt_type - | Types.ClassElement _ | Types.ComponentTypeElement _ | - Types.PredefinedTypeElement _ -> false - and element_nature (_, elt_type) = (evaluate elt_type).Types.element_nature in - List.exists - (function named_elt -> is_inout (element_nature named_elt)) - cl_type.Types.named_elements - -and component_type_of_expression ctx expr = - match expr.info.type_description with - | Types.ComponentElement cpnt_type -> cpnt_type - | Types.ClassElement _ | Types.ComponentTypeElement _ | - Types.PredefinedTypeElement _ -> - raise (CompilError - {err_msg = ["_ClassElemFoundInExpr"]; - err_info = []; - err_ctx = ctx}) (*error*) - -and scalar_class_specifier ctx expr = - let rec scalar_class_specifier' cl_spec = match cl_spec with - | Types.ArrayType (dim, cl_spec) -> - scalar_class_specifier' cl_spec - | _ -> cl_spec in - let cpnt_type = component_type_of_expression ctx expr in - let cl_spec = evaluate cpnt_type.Types.base_class in - scalar_class_specifier' cl_spec - -and expression_of_variable expr = - let vector_variables vec_elts = match vec_elts.Syntax.nature with - | Syntax.VectorReduction _ -> false - | Syntax.VectorElements exprs -> - List.for_all expression_of_variable exprs in - match expr.Syntax.nature with - | Syntax.Identifier _ -> true - | Syntax.FieldAccess (expr', _) -> expression_of_variable expr' - | Syntax.IndexedAccess (expr', subs) -> - expression_of_variable expr' - | Syntax.MatrixConstruction exprss -> - List.for_all (List.for_all expression_of_variable) exprss - | Syntax.Tuple exprs -> - List.for_all expression_of_variable exprs - | Syntax.Vector vec_elts -> vector_variables vec_elts - | _ -> false - -and string_of_bin_oper_kind kind = match kind with - | And -> " and " - | Divide -> " / " - | EqualEqual -> " == " - | GreaterEqual -> " >= " - | Greater -> " > " - | LessEqual -> " <= " - | Less -> " < " - | Times -> " * " - | NotEqual -> " <> " - | Or -> " or " - | Plus -> " + " - | Power -> " ^ " - | Minus -> " - " - -and string_of_un_oper_kind kind = match kind with - | Not -> " not " - | UnaryMinus -> "- " - | UnaryPlus -> "+ " - -and apply_binary_coercions exprs = - let base_type expr = - let rec base_type' cl_spec = match cl_spec with - | Types.ArrayType (_, cl_spec) -> base_type' cl_spec - | Types.PredefinedType pt -> Some pt.Types.base_type - | _ -> None in - match expr.info.type_description with - | Types.ComponentElement cpnt_type -> - let cl_spec = evaluate cpnt_type.Types.base_class in - base_type' cl_spec - | _ -> None - and real_type bt = match bt with - | Some Types.RealType -> true - | _ -> false - and integer_type bt = match bt with - | Some Types.IntegerType -> true - | _ -> false in - match List.map base_type exprs with - | [] | [ _ ] -> exprs - | bts when (List.exists real_type bts) && - (List.exists integer_type bts) -> - let cpnt_type = Types.real_component_type Types.Continuous in - List.map (apply_rhs_coercions cpnt_type) exprs - | _ -> exprs - -and apply_rhs_coercions cpnt_type expr = - let apply_real_of_integer cpnt_type cpnt_type' = - let rec apply_real_of_integer' cl_spec cl_spec' = - match cl_spec, cl_spec' with - | Types.ArrayType (dim, cl_spec), _ -> - apply_real_of_integer' cl_spec cl_spec' - | _, Types.ArrayType (dim', cl_spec') -> - let coer, cl_spec' = apply_real_of_integer' cl_spec cl_spec' in - coer, Types.ArrayType (dim', cl_spec') - | Types.PredefinedType { Types.base_type = Types.RealType }, - Types.PredefinedType { Types.base_type = Types.IntegerType } -> - Some RealOfInteger, Types.real_class_type - | _, _ -> None, cl_spec' in - let cl_spec = evaluate cpnt_type.Types.base_class - and cl_spec' = evaluate cpnt_type'.Types.base_class in - match apply_real_of_integer' cl_spec cl_spec' with - | Some RealOfInteger, cl_spec' -> - let cpnt_type' = - { - cpnt_type' with - Types.base_class = lazy cl_spec' - } - and nat' = Coercion (RealOfInteger, expr) in - let elt_nat' = Types.ComponentElement cpnt_type' in - resolved_expression expr.info.syntax nat' elt_nat' - | _ -> expr in - match expr.info.type_description with - | Types.ComponentElement cpnt_type' -> - apply_real_of_integer cpnt_type cpnt_type' - | _ -> expr - -(* for debug *) -and string_of_expression expr = match expr.nature with - | BinaryOperation (bin_oper_kind, expr, expr') -> - Printf.sprintf "BinaryOperation(_, %s, %s)" - (string_of_expression expr) - (string_of_expression expr') - | DynamicIdentifier (i, s) -> "DynamicIdentifier" - | False -> "False" - | FieldAccess (expr, s) -> "FieldAccess" - | FunctionArgument i -> "FunctionArgument" - | FunctionCall (expr, exprs, expr') -> - Printf.sprintf "FunctionCall(%s, {%s}, %s)" - (string_of_expression expr) - (String.concat "," (List.map string_of_expression exprs)) - (string_of_expression expr') - | FunctionInvocation exprs -> "FunctionInvocation" - | If (alts, expr) -> "If" - | IndexedAccess (expr, exprs) -> "IndexedAccess" - | Integer i -> - Printf.sprintf "Integer(%d)" (Int32.to_int i) - | LocalIdentifier (i, s) -> - Printf.sprintf "LocalIdentifier(%d, %s)" i s - | LoopVariable i -> "LoopVariable" - | NoEvent expr -> "NoEvent" - | PredefinedIdentifier s -> - Printf.sprintf "PredefinedIdentifier(%s)" s - | Range (start, step, stop) -> - Printf.sprintf "Range(%s, %s, %s)" - (string_of_expression start) - (string_of_expression step) - (string_of_expression stop) - | Real f -> "Real" - | String s -> "String" - | ToplevelIdentifier s -> "ToplevelIdentifier" - | True -> "True" - | Tuple exprs -> "Tuple" - | UnaryOperation (un_oper_kind, expr) -> "UnaryOperation" - | Vector exprs -> "Vector" - | VectorReduction (exprs, expr) -> "VectorReduction" - | Coercion _ -> "Coercion" +(* + * Translator from Modelica 2.x to flat Modelica + * + * Copyright (C) 2005 - 2007 Imagine S.A. + * For more information or commercial use please contact us at www.amesim.com + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. + * + *) + +(** Resolution of types for Modelica elements from the abstract syntax tree. +The main functions are: +{ul +{- [ resolve_toplevel ]: Main function. Resolve a list of top level syntax element} +{- [ resolve_variable_definition ]: Resolution of a variable definition} +{- [ resolve_class_definition ]: Resolution of a class definition} +{- [ resolve_modification ]: Resolution of modifications} +{- [ resolve_expression ]: Resolution of syntax expressions + {ul + {- [ resolve_binary_operation ]: Resolve binary operation expression } + {- [ resolve_unuary_operation ]: Resolve unary operation } + {- [ resolve_identifier ]: scoping algorithm and resolution of identifiers} + {- [ apply_binary_coercions, apply_rhs_coercions ]: Adding of Real to Integer implicit coercions} + {- [ resolve_function_call ]: Resolution of a function call expression } + {- [ resolve_field_access ]: Resolve field access } + {- [ resolve_if ]: Resolve [ if ] expression } + {- [ resolve_indexed_access ]: Resolve indexed access } + {- [ resolve_vector ]: Resolve vector expression } + {- [ resolve_range ]: resolve range expression } + } +} +{- [ resolve_equation ]: Resolution of an equation + {ul + {- [ resolve_equal ]: Resolution of a simple equation of the form [ expr1 = expr2 ] } + {- [ resolve_conditional_equation_e ]: Resolution of conditional equations } + {- [ resolve_for_clause_e ]: Resolution of for equations } + {- [ resolve_connect_clause ]: resolution of connect equations } + {- [ resolve_when_clause_e ]: resolution of when equations} + {- [ equations ]: resolution of array, record and for equations + } +} +} +*) + +(* The type [ node ] is used to attach syntax information to resolved elements *) +type ('a, 'b) node = + { + nature: 'a; + info: 'b + } + +(* Type of resolved elements *) + +and element_description = + { + element_type: Types.element_type Lazy.t; + redeclare: bool; + element_nature: element_nature; + element_location: Parser.location + } + +and element_nature = + | Component of component_description + | Class of class_definition + | ComponentType of component_type_description + | PredefinedType of Types.predefined_type + +and component_description = + { + component_type: Types.component_type Lazy.t; + type_specifier: expression Lazy.t; + dimensions: dimension list Lazy.t; + modification: modification option Lazy.t; + comment: string + } + +and dimension = + | Colon + | Expression of expression + +and class_definition = + { + class_type: Types.class_specifier Lazy.t; + enclosing_class: class_definition option; + encapsulated: bool; + description: class_description Lazy.t; + } + +and class_description = + | LongDescription of long_description + | ShortDescription of modified_class + +and long_description = + { + class_annotations: (annotation list) Lazy.t; + imports: import_description list; + extensions: (visibility * modified_class) list; + named_elements: named_element list; + unnamed_elements: equation_or_algorithm_clause list Lazy.t; + external_call: external_call option Lazy.t + } + +and annotation = + | InverseFunction of inverse_function Lazy.t + | UnknownAnnotation of (Parser.location Syntax.class_modification) Lazy.t + +and inverse_function = + { + function_class: expression; + arguments: (string * string) list + } + +and import_description = unit + +and visibility = Public | Protected + +and named_element = string * element_description + +and modified_class = + { + modified_class_type: Types.class_type Lazy.t; + base_class: expression Lazy.t; + class_modification: class_modification Lazy.t + } + +and component_type_description = + { + described_type: Types.component_type Lazy.t; + base_type: expression Lazy.t; + type_dimensions: dimension list Lazy.t; + type_modification: class_modification Lazy.t + } + +and external_call = (external_call_desc, Parser.location Syntax.externalll) node + +and external_call_desc = + | PrimitiveCall of string + | ExternalProcedureCall of language * + expression option (* rhs *) * string * expression list + +and language = C | FORTRAN + +and modification = + | Modification of class_modification * expression Lazy.t option + | Assignment of expression Lazy.t + | Equality of expression Lazy.t + +and class_modification = modification_argument list + +and modification_argument = + { + each: bool; + final: bool; + target: string; + action: modification_action option + } + +and modification_action = + | ElementModification of modification + | ElementRedeclaration of element_description + +(* Type of equations and algorithms *) + +and equation_or_algorithm_clause = + | EquationClause of validity * equation list + | AlgorithmClause of validity * algorithm list + +and validity = Initial | Permanent + +and equation = (equation_desc, Parser.location Syntax.equation option) node + +and equation_desc = + | Equal of expression * expression + | ConditionalEquationE of (expression * equation list) list * equation list + | ForClauseE of expression list (* ranges *) * equation list + | ConnectFlows of sign * expression * sign * expression + | WhenClauseE of (expression * equation list) list + +and sign = Positive | Negative + +and algorithm = (algorithm_desc, Parser.location Syntax.algorithm option) node + +and algorithm_desc = + | Assign of expression * expression + | FunctionCallA of expression * expression list + | MultipleAssign of expression list * expression * expression list + | Break + | Return + | ConditionalEquationA of (expression * algorithm list) list * + algorithm list + | ForClauseA of expression list (* ranges *) * algorithm list + | WhileClause of expression * algorithm list + | WhenClauseA of (expression * algorithm list) list + +(* Type of expressions *) + +and expression = (expression_desc, expression_information) node + +(* Type of a resolved expression: +- [ syntax ]: expression syntax (this information is optional, some expressions + are dynamicaly created during typing analysis) +- [ type_description ]: expression type *) +and expression_information = + { + syntax: Parser.location Syntax.expression option; + type_description: Types.element_nature + } + +and expression_desc = + | BinaryOperation of binary_operator_kind * expression * expression + | DynamicIdentifier of int (** number of nested classes to skip *) * + string (** name to be searched for at instanciation time *) + | False + | FieldAccess of expression * string + | FunctionArgument of int (** the position of the argument in the call *) + | FunctionCall of expression (** function *) * + expression list (** arguments *) * + expression (** the expression involving the function call *) + (** creation of a dynamic function context *) + | FunctionInvocation of expression list + (** invocation of the current function in context *) + | If of (expression (** condition *) * expression) list * + expression (** default *) + | IndexedAccess of expression * expression list (* subscripts *) + | Integer of int32 + | LocalIdentifier of int (** number of nested classes to skip *) * + string (** key in the dictionary of the defining class *) + | LoopVariable of int (** number of nested for loops to skip *) + | NoEvent of expression + | PredefinedIdentifier of string (** predefined identifier *) + | Range of expression * expression * expression + | Real of float + | String of string + | ToplevelIdentifier of string (** key in the toplevel dictionary *) + | True + | Tuple of expression list + | UnaryOperation of unary_operator_kind * expression + | Vector of expression list + | VectorReduction of expression list (** nested ranges *) * expression + | Coercion of coercion_kind * expression + +and coercion_kind = + | RealOfInteger (** Implicit conversion of Integer to Real *) + +and unary_operator_kind = + | Not + | UnaryMinus + | UnaryPlus + +and binary_operator_kind = + | And + | Divide + | EqualEqual + | GreaterEqual + | Greater + | LessEqual + | Less + | Times + | NotEqual + | Or + | Plus + | Power + | Minus + +(* Context types. Contexts are used to resolve identifiers in expressions *) + +type context = + { + toplevel: (string * element_description) list Lazy.t; + context_nature: context_nature; + location: Parser.location + } + +and context_nature = + | ToplevelContext + | ClassContext of class_definition + | SubscriptContext of + context * expression (* evaluating to an array *) * + int32 (* dimension index *) * Types.dimension + | ForContext of context * string * Types.element_nature + +(* Type Errors detected during compilation *) + +type error_description = + { + err_msg: string list; + err_info: (string * string) list; + err_ctx: context + } + +exception CompilError of error_description + +(* Utilities *) + +let evaluate x = Lazy.force x + +let resolve_elements add_element elts other_elts = + let resolve_other_elements other_elt acc = match other_elt.Syntax.nature with + | Syntax.Public elts -> List.fold_right (add_element Public) elts acc + | Syntax.Protected elts -> List.fold_right (add_element Protected) elts acc + | Syntax.EquationClause _ | Syntax.AlgorithmClause _ -> acc in + List.fold_right + (add_element Public) + elts + (List.fold_right resolve_other_elements other_elts []) + +let resolved_expression syntax nat elt_nat = + { + nature = nat; + info = { syntax = syntax; type_description = elt_nat } + } + +let one = + let nat = Integer 1l + and elt_nat = Types.integer_type Types.Constant in + resolved_expression None nat elt_nat + + +(* Name resolution functions *) + +let rec resolve_toplevel dic nodes = + let add_element ctx acc (id, elt_desc) = + match List.mem_assoc id acc with + | true -> + let ctx = { ctx with location = elt_desc.element_location } in + raise (CompilError + {err_msg = ["_DuplicateDeclarationOfElement"; id]; + err_info = []; + err_ctx = ctx}) (*error*) + | false -> acc @ [ (id, elt_desc) ] in + let rec ctx = + { + toplevel = + lazy (List.fold_left (add_element ctx) dic (evaluate elt_descs)); + context_nature = ToplevelContext; + location = + { + Parser.start = 0; + Parser.enddd = 0; + Parser.filename = Parser.CommandLine + } + } + and elt_descs = lazy (resolve_toplevel_nodes ctx nodes) in + evaluate ctx.toplevel + +and resolve_toplevel_nodes ctx nodes = + let rec resolve_toplevel_nodes' nodes' = + match nodes' with + | [] -> [] + | node :: nodes' -> + (resolve_toplevel_statements ctx node) @ + (resolve_toplevel_nodes' nodes') in + let collect_toplevel_defs (cl_defs, nodes) node = + match node.Syntax.nature with + | Syntax.ClassDefinitions cl_defs' -> cl_defs' @ cl_defs, nodes + | _ -> cl_defs, [node] @ nodes in + let cl_defs, nodes = List.fold_left collect_toplevel_defs ([], []) nodes in + let node = {Syntax.nature = Syntax.ClassDefinitions cl_defs; + Syntax.info = ctx.location} in + (resolve_toplevel_statements ctx node) @ + resolve_toplevel_nodes' nodes + +and resolve_toplevel_statements ctx node = match node.Syntax.nature with + | Syntax.ClassDefinitions cl_defs -> resolve_class_definitions ctx cl_defs + | Syntax.Expression expr -> raise (CompilError + {err_msg = ["_NotYetImplemented"; "_TopLevelExpr"]; + err_info = []; + err_ctx = {ctx with location = expr.Syntax.info}}) + | Syntax.VariablesDefinitions (expr, subs, cpnt_decls) -> + resole_variables_definitions ctx expr subs cpnt_decls + | Syntax.Command algo -> raise (CompilError + {err_msg = ["_NotYetImplemented"; "_TopLevelAlgorithm"]; + err_info = []; + err_ctx = {ctx with location = algo.Syntax.info}}) + | Syntax.Within path -> raise (CompilError + {err_msg = ["_NotYetImplemented"; "_WithinClause"]; + err_info = [("_Expr", Syntax.string_of_toplevel_element node)]; + err_ctx = {ctx with location = node.Syntax.info}}) + | Syntax.Import imprt -> raise (CompilError + {err_msg = ["_NotYetImplemented"; "_ImportClause"]; + err_info = [("_Expr", Syntax.string_of_toplevel_element node)]; + err_ctx = {ctx with location = imprt.Syntax.info}}) + +and resole_variables_definitions ctx expr subs cpnt_decls = + let type_spec = lazy (resolve_expression ctx expr) + and dims = lazy (resolve_dimensions ctx subs) in + List.map (resolve_variable_definition ctx type_spec dims expr) cpnt_decls + +and resolve_variable_definition ctx type_spec dims expr cpnt_decl = + let type_pref = false, None, Types.Acausal in + let id, elt_nat, elt_loc = + resolve_component_declaration ctx type_pref type_spec dims expr cpnt_decl in + let rec elt_desc = + { + element_type = + lazy (element_type ctx false None None None elt_desc); + redeclare = false; + element_nature = elt_nat; + element_location = elt_loc + } in + id, elt_desc + +and resolve_class_definitions ctx cl_defs = + List.map (resolve_class_definition ctx) cl_defs + +and resolve_class_definition ctx cl_def = match cl_def.Syntax.nature with + | Syntax.ClassDefinition (final, def) -> + let loc = (match def.Syntax.nature with + | Syntax.Definition (_, _, _, cl_spec) -> cl_spec.Syntax.info) in + let rec elt_desc = + { + element_type = lazy (element_type ctx false final None None elt_desc); + redeclare = false; + element_nature = resolve_definition ctx def; + element_location = loc + } in + let s = class_definition_name def in + s, elt_desc + +and class_definition_name def = match def.Syntax.nature with + | Syntax.Definition (_, _, _, cl_spec) -> class_specifier_name cl_spec + +and class_specifier_name cl_spec = match cl_spec.Syntax.nature with + | Syntax.LongSpecifier (id, _, _) | + Syntax.ShortSpecifier (id, _, _, _, _, _) | + Syntax.EnumerationSpecifier (id, _, _) | + Syntax.ExtensionSpecifier (id, _, _, _) -> id + +and resolve_definition ctx def = + let ctx = {ctx with location = def.Syntax.info} in + match def.Syntax.nature with + | Syntax.Definition (encap, part, kind, cl_spec) -> + resolve_specification ctx encap part kind cl_spec + +and resolve_specification ctx encap part kind cl_spec = + let encap' = bool_of_encapsulated encap in + match kind with + | Syntax.Class -> + resolve_class_specification ctx encap' part Types.Class cl_spec + | Syntax.Model -> + resolve_class_specification ctx encap' part Types.Model cl_spec + | Syntax.Block -> + resolve_class_specification ctx encap' part Types.Block cl_spec + | Syntax.Record -> + resolve_class_specification ctx encap' part Types.Record cl_spec + | Syntax.ExpandableConnector -> + resolve_class_specification + ctx + encap' + part + Types.ExpandableConnector + cl_spec + | Syntax.Connector -> + resolve_class_specification ctx encap' part Types.Connector cl_spec + | Syntax.Type when encap' -> + raise (CompilError + {err_msg = ["_EncapsulatedCannotBeAppliedTo"; "_TypeDef"]; + err_info = []; + err_ctx = ctx}) (*error*) + | Syntax.Type -> resolve_type_specification ctx cl_spec + | Syntax.Package -> + resolve_class_specification ctx encap' part Types.Package cl_spec + | Syntax.Function -> + resolve_class_specification ctx encap' part Types.Function cl_spec + +and resolve_type_specification ctx cl_spec = + let ctx = {ctx with location = cl_spec.Syntax.info} in + match cl_spec.Syntax.nature with + | Syntax.LongSpecifier _ -> + raise (CompilError + {err_msg = ["_InvalidTypeDef"]; + err_info = []; + err_ctx = ctx}) (*error*) + | Syntax.ExtensionSpecifier _ -> + raise (CompilError + {err_msg = ["_InvalidTypeDef"]; + err_info = []; + err_ctx = ctx}) (*error*) + | Syntax.ShortSpecifier (_, base_pref, cl_spec, subs, cl_modif, _) -> + let cpnt_type = + resolve_type_composition ctx base_pref cl_spec subs cl_modif in + ComponentType cpnt_type + | Syntax.EnumerationSpecifier (idt, enum_comp, _) -> + let enum_type = resolve_enumeration_composition ctx enum_comp in + PredefinedType enum_type + +and resolve_type_composition ctx base_pref cl_spec subs cl_modif = + let base_pref' = type_prefix base_pref + and base_type = lazy (resolve_expression ctx cl_spec) + and dims = lazy (resolve_dimensions ctx subs) in + let cpnt_type = lazy (component_type ctx base_pref' base_type dims) in + let cl_modif' = lazy (resolve_type_modification ctx cpnt_type cl_modif) in + { + described_type = lazy (modified_described_type ctx cpnt_type cl_modif'); + base_type = base_type; + type_dimensions = dims; + type_modification = cl_modif' + } + +and resolve_enumeration_composition ctx enum_comp = + let resolve_enumeration_literal enum_lit ids = + match enum_lit.Syntax.nature with + | Syntax.EnumerationLiteral (id, _) when List.mem id ids -> + raise (CompilError + {err_msg = ["_EnumTypeDefWithDuplicLit"; id]; + err_info = []; + err_ctx = {ctx with location = enum_lit.Syntax.info}}) (*error*) + | Syntax.EnumerationLiteral (id, _) -> id :: ids in + match enum_comp.Syntax.nature with + | Syntax.EnumList (Some enum_lits) -> + let elts = List.fold_right resolve_enumeration_literal enum_lits [] in + { + Types.base_type = Types.EnumerationType elts; + attributes = ["start", false] + } + | Syntax.EnumList None -> + raise (CompilError + {err_msg = ["_UnspecifiedEnumLits"]; + err_info = []; + err_ctx = {ctx with location = enum_comp.Syntax.info}}) (*error*) + | Syntax.EnumColon -> + raise (CompilError + {err_msg = ["_UnspecifiedEnumLits"]; + err_info = []; + err_ctx = {ctx with location = enum_comp.Syntax.info}}) (*error*) + +and resolve_class_specification ctx encap part kind cl_spec = + let ctx = {ctx with location = cl_spec.Syntax.info} in + let resolve_specifier encap' cl_def = + let ctx' = {ctx with context_nature = ClassContext cl_def} in + resolve_class_specifier ctx ctx' encap cl_spec in + let rec cl_def = + { + class_type = lazy (class_specifier_type ctx part kind cl_def cl_spec); + enclosing_class = enclosing_class ctx; + encapsulated = encap; + description = lazy (resolve_specifier encap cl_def) + } in + Class cl_def + +and enclosing_class ctx = match ctx.context_nature with + | ToplevelContext -> None + | ClassContext cl_def -> Some cl_def + | SubscriptContext (ctx, _, _, _) | + ForContext (ctx, _, _) -> enclosing_class ctx + +and bool_of_encapsulated = function + | None -> false + | Some Syntax.Encapsulated -> true + +and resolve_class_specifier ctx ctx' encap cl_spec = + let ctx = {ctx with location = cl_spec.Syntax.info} + and ctx' = {ctx' with location = cl_spec.Syntax.info} in + match cl_spec.Syntax.nature with + | Syntax.LongSpecifier (_, _, comp) -> + LongDescription (resolve_composition ctx ctx' comp) + | Syntax.ShortSpecifier _ when encap -> + raise (CompilError + {err_msg = ["_EncapsulatedCannotBeAppliedTo"; "_ShortClassDef"]; + err_info = []; + err_ctx = ctx}) (*error*) + | Syntax.ShortSpecifier (_, base_pref, cl_spec, subs, cl_modif, _) -> + let short_desc = + resolve_short_specifier ctx base_pref cl_spec subs cl_modif in + ShortDescription short_desc + | Syntax.ExtensionSpecifier _ when encap -> + raise (CompilError + {err_msg = ["_EncapsulatedCannotBeAppliedTo"; "_ClassDefByExtension"]; + err_info = []; + err_ctx = ctx}) (*error*) + | Syntax.ExtensionSpecifier (id , cl_modif, _, comp) -> + let long_desc = + resolve_extension_composition ctx ctx' id cl_modif comp in + LongDescription long_desc + | Syntax.EnumerationSpecifier _ -> + raise (CompilError + {err_msg = ["_InvalidUseOfEnumKeyword"]; + err_info = []; + err_ctx = ctx}) (*error*) + +and resolve_short_specifier ctx base_pref cl_spec subs cl_modif = + let ctx = {ctx with location = cl_spec.Syntax.info} in + match base_pref.Syntax.nature, subs with + | Syntax.TypePrefix (None, None, None), None -> + resolve_modified_class ctx ctx cl_spec cl_modif + | (Syntax.TypePrefix (Some _, _, _) | Syntax.TypePrefix (_, Some _, _) | + Syntax.TypePrefix (_, _, Some _)), _ -> + raise (CompilError + {err_msg = ["_UseOfTypePrefixInShortClassDef"]; + err_info = + [("_TypePrefix", Syntax.string_of_base_prefix base_pref)]; + err_ctx = {ctx with location = base_pref.Syntax.info}}) (*error*) + | Syntax.TypePrefix (None, None, None), Some subs -> + raise (CompilError + {err_msg = ["_UseOfSubsInShortClassDef"]; + err_info = []; + err_ctx = {ctx with location = subs.Syntax.info}}) (*error*) + +and resolve_extension_composition ctx ctx' id cl_modif comp = + raise (CompilError + {err_msg = ["_NotYetImplemented"; "_ClassExtendsDef"]; + err_info = []; + err_ctx = ctx}) + +and resolve_composition ctx ctx' comp = match comp.Syntax.nature with + | Syntax.Composition (elts, other_elts, extern) -> + { + class_annotations = lazy (resolve_class_annotations ctx' elts other_elts); + imports = resolve_imports ctx' elts other_elts; + extensions = resolve_extensions ctx ctx' elts other_elts; + named_elements = resolve_named_elements ctx' elts other_elts; + unnamed_elements = lazy (resolve_unnamed_elements ctx' other_elts); + external_call = lazy (resolve_external_call ctx' extern) + } + +and resolve_external_call ctx extern = + let resolve_external_call' extern' = match extern'.Syntax.nature with + | Syntax.External (Some id, None, _, _) -> + { nature = PrimitiveCall id; info = extern' } + | Syntax.External (Some lang, Some extern_call, _, _) -> + raise (CompilError + {err_msg = ["_NotYetImplemented"; "_ExternalProcedureCall"]; + err_info = []; + err_ctx = + {ctx with location = extern'.Syntax.info}}) (*error*) + | Syntax.External (None, _, _, _) -> + { nature = PrimitiveCall "C"; info = extern' } in + (*raise (CompilError + {err_msg = ["_UnspecifiedExtCallLang"]; + err_info = []; + err_ctx = + {ctx with location = extern'.Syntax.info}}) (*error*) in*) + match extern with + | None -> None + | Some extern' -> Some (resolve_external_call' extern') + +and resolve_class_annotations ctx elts other_elts = + let add_class_annotation vis elt anns = match vis, elt.Syntax.nature with + | _, Syntax.ClassAnnotation ann -> + begin match resolve_class_annotation ctx ann with + | [] -> anns + | anns' -> anns' @ anns + end + | _, (Syntax.ImportClause _ | Syntax.ExtendsClause _ | + Syntax.ElementDefinition _) -> anns in + resolve_elements add_class_annotation elts other_elts + +and resolve_imports ctx elts other_elts = + let add_import vis elt imps = match vis, elt.Syntax.nature with + | _, Syntax.ImportClause (imp_clause, _) -> + resolve_import_clause ctx imp_clause :: imps + | _, (Syntax.ClassAnnotation _ | Syntax.ExtendsClause _ | + Syntax.ElementDefinition _) -> imps in + resolve_elements add_import elts other_elts + +and resolve_extensions ctx ctx' elts other_elts = + let add_extension vis elt exts = match vis, elt.Syntax.nature with + | Public, Syntax.ExtendsClause (ext_clause, _) -> + (Public, resolve_extends_clause ctx ctx' ext_clause) :: exts + | Protected, Syntax.ExtendsClause (ext_clause, _) -> + (Protected, resolve_extends_clause ctx ctx' ext_clause) :: exts + | _, (Syntax.ClassAnnotation _ | Syntax.ImportClause _ | + Syntax.ElementDefinition _) -> exts in + resolve_elements add_extension elts other_elts + +and resolve_named_elements ctx elts other_elts = + let add_named_element (id, elt_desc) elts = + match List.mem_assoc id elts with + | true -> + raise (CompilError + {err_msg = ["_DuplicateDeclarationOfElement"; id]; + err_info = []; + err_ctx = ctx}) (*error*) + | false -> (id, elt_desc) :: elts in + let add_named_elements vis elt elts = match vis, elt.Syntax.nature with + | Public, + Syntax.ElementDefinition (redecl, final, dyn_scope, elt_def, _) -> + let elts' = + resolve_element_definition ctx false redecl final dyn_scope elt_def in + List.fold_right add_named_element elts' elts + | Protected, + Syntax.ElementDefinition (redecl, final, dyn_scope, elt_def, _) -> + let elts' = + resolve_element_definition ctx true redecl final dyn_scope elt_def in + List.fold_right add_named_element elts' elts + | _, (Syntax.ClassAnnotation _ | Syntax.ImportClause _ | + Syntax.ExtendsClause _) -> elts in + resolve_elements add_named_elements elts other_elts + +and resolve_class_annotation ctx ann = + let rec resolve_class_annotation' cl_modif = + let add_annotation_information arg acc = match arg.Syntax.nature with + | Syntax.ElementModification ( + None, + None, + { Syntax.nature = Syntax.Identifier "Imagine" }, + Some + { + Syntax.nature = + Syntax.Modification ( + { + Syntax.nature = + Syntax.ClassModification + [ + { + Syntax.nature = + Syntax.ElementModification ( + None, + None, + { + Syntax.nature = Syntax.Identifier "AMESim" + }, + Some + { + Syntax.nature = + Syntax.Modification (cl_modif, None) + }, + []) + } + ] + }, + None) + }, + []) -> add_amesim_annotations ctx cl_modif acc + | Syntax.ElementModification _ | Syntax.ElementRedeclaration _ -> + (UnknownAnnotation (lazy cl_modif)) :: acc in + match cl_modif.Syntax.nature with + | Syntax.ClassModification args -> + List.fold_right add_annotation_information args [] in + match ann.Syntax.nature with + | Syntax.Annotation cl_modif -> resolve_class_annotation' cl_modif + +and add_amesim_annotations ctx cl_modif acc = + let add_inverse_declarations cl_modif = + let add_inverse_declaration arg acc = + let add_inverse_declaration' expr modif = + match expr.Syntax.nature, modif.Syntax.nature with + | Syntax.IndexedAccess ( + { Syntax.nature = Syntax.Identifier "inverse" }, _), + Syntax.Eq + { + Syntax.nature = + Syntax.FunctionCall (expr, Some fun_args) + } -> (resolve_inverse_declaration ctx expr fun_args) :: acc + | _ -> + raise (CompilError + {err_msg = ["_InvalidAnnOfInvFunc"; "_InvalidModifExpr"]; + err_info = []; + err_ctx = + {ctx with location = expr.Syntax.info}}) (*error*) in + match arg.Syntax.nature with + | Syntax.ElementModification (Some _, _, _, _, _) -> + raise (CompilError + {err_msg = ["_InvalidAnnOfInvFunc"; "_UseOfEachKeywordNotAllowed"]; + err_info = []; + err_ctx = {ctx with location = arg.Syntax.info}}) (*error*) + | Syntax.ElementModification (None, Some _, _, _, _) -> + raise (CompilError + {err_msg = ["_InvalidAnnOfInvFunc"; "_UseOfFinalKeywordNotAllowed"]; + err_info = []; + err_ctx = {ctx with location = arg.Syntax.info}}) (*error*) + | Syntax.ElementModification (None, None, _, None, _) -> + raise (CompilError + {err_msg = ["_InvalidAnnOfInvFunc"; "_UnspecifiedModification"]; + err_info = []; + err_ctx = {ctx with location = arg.Syntax.info}}) (*error*) + | Syntax.ElementModification (None, None, expr, Some modif, _) -> + add_inverse_declaration' expr modif + | Syntax.ElementRedeclaration _ -> + raise (CompilError + {err_msg = ["_InvalidAnnOfInvFunc"; "_RedeclarationNotAllowed"]; + err_info = []; + err_ctx = {ctx with location = arg.Syntax.info}}) (*error*) in + match cl_modif.Syntax.nature with + | Syntax.ClassModification args -> + List.fold_right add_inverse_declaration args acc in + match cl_modif.Syntax.nature with + | Syntax.ClassModification + [ + { + Syntax.nature = + Syntax.ElementModification ( + None, + None, + { + Syntax.nature = Syntax.Identifier "InverseFunctions" + }, + Some + { + Syntax.nature = + Syntax.Modification (cl_modif, None) + }, + []) + } + ] -> add_inverse_declarations cl_modif + | Syntax.ClassModification _ -> acc + +and resolve_inverse_declaration ctx expr fun_args = + let inverse_function_arguments expr' fun_args = + let map_function_arguments named_args = + let map_function_argument arg = + match arg.Syntax.nature with + | Syntax.NamedArgument (id, expr) + when List.mem_assoc id named_args -> + let expr' = resolve_expression ctx expr in + begin match expr'.nature with + | LocalIdentifier (0, id') -> id, id' + | _ -> + raise (CompilError + {err_msg = ["_InvalidAnnOfInvFunc"; + "_InvalidFuncArgModif"]; + err_info = []; + err_ctx = + {ctx with + location = expr.Syntax.info}}) (*error*) + end + | Syntax.NamedArgument (id, expr) -> + raise (CompilError + {err_msg = ["_InvalidAnnOfInvFunc"; + "_UnknownArgName"; id]; + err_info = []; + err_ctx = + {ctx with location = arg.Syntax.info}}) (*error*) + | Syntax.Argument _ -> + raise (CompilError + {err_msg = ["_InvalidAnnOfInvFunc"; + "_CannotUseUnnamedFuncArg"]; + err_info = []; + err_ctx = + {ctx with location = arg.Syntax.info}}) (*error*) in + match fun_args.Syntax.nature with + | Syntax.ArgumentList args -> List.map map_function_argument args + | Syntax.Reduction _ -> + raise (CompilError + {err_msg = ["_InvalidAnnOfInvFunc"; + "_FuncArgReductionNotAllowed"]; + err_info = []; + err_ctx = + {ctx with location = fun_args.Syntax.info}}) (*error*) in + let inverse_function_arguments' cl_type = + match cl_type.Types.partial, evaluate cl_type.Types.kind with + | true, _ -> + raise (CompilError + {err_msg = ["_InvalidAnnOfInvFunc"; + "_UseOfPartialClassElement"]; + err_info = [("_ElementFound", + Syntax.string_of_expression expr)]; + err_ctx = + {ctx with location = expr.Syntax.info}}) (*error*) + | false, Types.Function -> + map_function_arguments cl_type.Types.named_elements + | _, kind -> + raise (CompilError + {err_msg = ["_InvalidAnnOfInvFunc"; + "_InvalidTypeOfFuncCallExpr"]; + err_info = [("_ExpectedType", "_Function"); + ("_TypeFound", Types.string_of_kind kind)]; + err_ctx = + {ctx with location = expr.Syntax.info}}) (*error*) in + let elt_nat = expr'.info.type_description in + match elt_nat with + | Types.ClassElement cl_spec -> + let cl_spec = evaluate cl_spec in + begin match cl_spec with + | Types.ClassType cl_type -> + inverse_function_arguments' cl_type + | _ -> + raise (CompilError + {err_msg = ["_InvalidAnnOfInvFunc"; + "_InvalidTypeOfFuncCallExpr"]; + err_info = + [("_ExpectedType", "_ClassType"); + ("_TypeFound", + Types.string_of_class_specifier cl_spec)]; + err_ctx = + {ctx with location = expr.Syntax.info}}) (*error*) + end + | Types.ComponentTypeElement _ -> + raise (CompilError + {err_msg = ["_InvalidAnnOfInvFunc"; + "_InvalidTypeOfFuncCallExpr"]; + err_info = [("_ExpectedType", "_ClassElement"); + ("_TypeFound", "_ComponentTypeElement")]; + err_ctx = + {ctx with location = expr.Syntax.info}}) (*error*) + | Types.PredefinedTypeElement _ -> + raise (CompilError + {err_msg = ["_InvalidAnnOfInvFunc"; + "_InvalidTypeOfFuncCallExpr"]; + err_info = [("_ExpectedType", "_ClassElement"); + ("_TypeFound", "_PredefinedTypeElement")]; + err_ctx = + {ctx with location = expr.Syntax.info}}) (*error*) + | Types.ComponentElement _ -> + raise (CompilError + {err_msg = ["_InvalidAnnOfInvFunc"; + "_InvalidTypeOfFuncCallExpr"]; + err_info = [("_ExpectedType", "_ClassElement"); + ("_TypeFound", "_ComponentElement")]; + err_ctx = + {ctx with location = expr.Syntax.info}}) (*error*) in + let expr' = resolve_expression ctx expr in + match expr'.nature with + | ToplevelIdentifier _ | LocalIdentifier _ -> + InverseFunction + (lazy + { + function_class = expr'; + arguments = inverse_function_arguments expr' fun_args + }) + | _ -> + raise (CompilError + {err_msg = ["_InvalidAnnOfInvFunc"; "_InvalidFuncCallExpr"]; + err_info = []; + err_ctx = + {ctx with location = expr.Syntax.info}}) (*error*) + +(*and resolve_inverse_function_annotation ctx ann = + let rec resolve_class_annotation' cl_modif = + let resolve_inverse_declaration expr fun_args = + let inverse_function_arguments expr' fun_args = + let map_function_arguments named_args = + let map_function_argument arg = + match arg.Syntax.nature with + | Syntax.NamedArgument (id, expr) + when List.mem_assoc id named_args -> + let expr' = resolve_expression ctx expr in + begin match expr'.nature with + | LocalIdentifier (0, id') -> id, id' + | _ -> + raise (CompilError + {err_msg = ["_InvalidAnnOfInvFunc"; + "_InvalidFuncArgModif"]; + err_info = []; + err_ctx = + {ctx with + location = expr.Syntax.info}}) (*error*) + end + | Syntax.NamedArgument (id, expr) -> + raise (CompilError + {err_msg = ["_InvalidAnnOfInvFunc"; + "_UnknownArgName"; id]; + err_info = []; + err_ctx = + {ctx with location = arg.Syntax.info}}) (*error*) + | Syntax.Argument _ -> + raise (CompilError + {err_msg = ["_InvalidAnnOfInvFunc"; + "_CannotUseUnnamedFuncArg"]; + err_info = []; + err_ctx = + {ctx with location = arg.Syntax.info}}) (*error*) in + match fun_args.Syntax.nature with + | Syntax.ArgumentList args -> List.map map_function_argument args + | Syntax.Reduction _ -> + raise (CompilError + {err_msg = ["_InvalidAnnOfInvFunc"; + "_FuncArgReductionNotAllowed"]; + err_info = []; + err_ctx = + {ctx with location = fun_args.Syntax.info}}) (*error*) in + let inverse_function_arguments' cl_type = + match cl_type.Types.partial, evaluate cl_type.Types.kind with + | true, _ -> + raise (CompilError + {err_msg = ["_InvalidAnnOfInvFunc"; + "_UseOfPartialClassElement"]; + err_info = [("_ElementFound", + Syntax.string_of_expression expr)]; + err_ctx = + {ctx with location = expr.Syntax.info}}) (*error*) + | false, Types.Function -> + map_function_arguments cl_type.Types.named_elements + | _, kind -> + raise (CompilError + {err_msg = ["_InvalidAnnOfInvFunc"; + "_InvalidTypeOfFuncCallExpr"]; + err_info = [("_ExpectedType", "_Function"); + ("_TypeFound", Types.string_of_kind kind)]; + err_ctx = + {ctx with location = expr.Syntax.info}}) (*error*) in + let elt_nat = expr'.info.type_description in + match elt_nat with + | Types.ClassElement cl_spec -> + let cl_spec = evaluate cl_spec in + begin match cl_spec with + | Types.ClassType cl_type -> + inverse_function_arguments' cl_type + | _ -> + raise (CompilError + {err_msg = ["_InvalidAnnOfInvFunc"; + "_InvalidTypeOfFuncCallExpr"]; + err_info = + [("_ExpectedType", "_ClassType"); + ("_TypeFound", + Types.string_of_class_specifier cl_spec)]; + err_ctx = + {ctx with location = expr.Syntax.info}}) (*error*) + end + | Types.ComponentTypeElement _ -> + raise (CompilError + {err_msg = ["_InvalidAnnOfInvFunc"; + "_InvalidTypeOfFuncCallExpr"]; + err_info = [("_ExpectedType", "_ClassElement"); + ("_TypeFound", "_ComponentTypeElement")]; + err_ctx = + {ctx with location = expr.Syntax.info}}) (*error*) + | Types.PredefinedTypeElement _ -> + raise (CompilError + {err_msg = ["_InvalidAnnOfInvFunc"; + "_InvalidTypeOfFuncCallExpr"]; + err_info = [("_ExpectedType", "_ClassElement"); + ("_TypeFound", "_PredefinedTypeElement")]; + err_ctx = + {ctx with location = expr.Syntax.info}}) (*error*) + | Types.ComponentElement _ -> + raise (CompilError + {err_msg = ["_InvalidAnnOfInvFunc"; + "_InvalidTypeOfFuncCallExpr"]; + err_info = [("_ExpectedType", "_ClassElement"); + ("_TypeFound", "_ComponentElement")]; + err_ctx = + {ctx with location = expr.Syntax.info}}) (*error*) in + let expr' = resolve_expression ctx expr in + match expr'.nature with + | ToplevelIdentifier _ | LocalIdentifier _ -> + { + function_class = expr'; + arguments = + inverse_function_arguments expr' fun_args + } + | _ -> + raise (CompilError + {err_msg = ["_InvalidAnnOfInvFunc"; "_InvalidFuncCallExpr"]; + err_info = []; + err_ctx = + {ctx with location = expr.Syntax.info}}) (*error*) in + let add_inverse_declaration arg acc = + let add_inverse_declaration' expr modif = + match expr.Syntax.nature, modif.Syntax.nature with + | Syntax.IndexedAccess ( + { Syntax.nature = Syntax.Identifier "inverse" }, _), + Syntax.Eq + { + Syntax.nature = + Syntax.FunctionCall (expr, Some fun_args) + } -> lazy (resolve_inverse_declaration expr fun_args) :: acc + | _ -> + raise (CompilError + {err_msg = ["_InvalidAnnOfInvFunc"; "_InvalidModifExpr"]; + err_info = []; + err_ctx = + {ctx with location = expr.Syntax.info}}) (*error*) in + match arg.Syntax.nature with + | Syntax.ElementModification (Some _, _, _, _, _) -> + raise (CompilError + {err_msg = ["_InvalidAnnOfInvFunc"; "_UseOfEachKeywordNotAllowed"]; + err_info = []; + err_ctx = {ctx with location = arg.Syntax.info}}) (*error*) + | Syntax.ElementModification (None, Some _, _, _, _) -> + raise (CompilError + {err_msg = ["_InvalidAnnOfInvFunc"; "_UseOfFinalKeywordNotAllowed"]; + err_info = []; + err_ctx = {ctx with location = arg.Syntax.info}}) (*error*) + | Syntax.ElementModification (None, None, _, None, _) -> + raise (CompilError + {err_msg = ["_InvalidAnnOfInvFunc"; "_UnspecifiedModification"]; + err_info = []; + err_ctx = {ctx with location = arg.Syntax.info}}) (*error*) + | Syntax.ElementModification (None, None, expr, Some modif, _) -> + add_inverse_declaration' expr modif + | Syntax.ElementRedeclaration _ -> + raise (CompilError + {err_msg = ["_InvalidAnnOfInvFunc"; "_RedeclarationNotAllowed"]; + err_info = []; + err_ctx = {ctx with location = arg.Syntax.info}}) (*error*) in + let add_inverse_declarations cl_modif acc = + let add_inverse_declarations' cl_modif = + match cl_modif.Syntax.nature with + | Syntax.ClassModification args -> + List.fold_right add_inverse_declaration args acc in + match cl_modif.Syntax.nature with + | Syntax.ClassModification + [ + { + Syntax.nature = + Syntax.ElementModification ( + None, + None, + { + Syntax.nature = Syntax.Identifier "InverseFunctions" + }, + Some + { + Syntax.nature = + Syntax.Modification (cl_modif, None) + }, + []) + } + ] -> add_inverse_declarations' cl_modif + | Syntax.ClassModification _ -> acc in + let add_annotation_information arg acc = match arg.Syntax.nature with + | Syntax.ElementModification ( + None, + None, + { Syntax.nature = Syntax.Identifier "Imagine" }, + Some + { + Syntax.nature = + Syntax.Modification ( + { + Syntax.nature = + Syntax.ClassModification + [ + { + Syntax.nature = + Syntax.ElementModification ( + None, + None, + { + Syntax.nature = Syntax.Identifier "AMESim" + }, + Some + { + Syntax.nature = + Syntax.Modification (cl_modif, None) + }, + []) + } + ] + }, + None) + }, + []) -> add_inverse_declarations cl_modif acc + | Syntax.ElementModification _ | Syntax.ElementRedeclaration _ -> acc in + match cl_modif.Syntax.nature with + | Syntax.ClassModification args -> + List.fold_right add_annotation_information args [] in + match ann.Syntax.nature with + | Syntax.Annotation cl_modif -> resolve_class_annotation' cl_modif*) + +and resolve_import_clause ctx imp_clause = + let ctx = {ctx with location = imp_clause.Syntax.info} in + raise (CompilError + {err_msg = ["_NotYetImplemented"; "_ImportClause"]; + err_info = [("_Expr", Syntax.string_of_import imp_clause)]; + err_ctx = ctx}) + +and resolve_extends_clause ctx ctx' ext_clause = + match ext_clause.Syntax.nature with + | Syntax.Extends (cl_spec, cl_modif, _) -> + resolve_extension ctx ctx' cl_spec cl_modif + +and resolve_extension ctx ctx' cl_spec cl_modif = + let ctx' = {ctx' with location = cl_spec.Syntax.info} in + let base_class = lazy (resolve_extension_expression ctx cl_spec) in + let cl_spec' = lazy (base_class_type ctx' cl_spec base_class) in + let cl_modif' = + lazy (resolve_class_modification_option ctx' cl_spec' cl_modif) in + { + modified_class_type = lazy (modified_class_type ctx' cl_spec' cl_modif'); + base_class = base_class; + class_modification = cl_modif' + } + +and resolve_extension_expression ctx cl_spec = + let rec modify_resolved_expression expr = match expr.nature with + | LocalIdentifier (level, id) -> + { expr with nature = LocalIdentifier (level + 1, id) } + | FieldAccess (expr', id) -> + { expr with + nature = FieldAccess (modify_resolved_expression expr', id) + } + | IndexedAccess (expr', exprs') -> + let exprs' = List.map modify_resolved_expression exprs' in + { expr with + nature = IndexedAccess (modify_resolved_expression expr', exprs') + } + | ToplevelIdentifier _ -> expr + | _ -> + raise (CompilError + {err_msg = ["_InvalidExtensionDef"]; + err_info = []; + err_ctx = ctx}) (*error*) in + match ctx.context_nature with + | ToplevelContext | ClassContext _ -> + let base_class = resolve_expression ctx cl_spec in + modify_resolved_expression base_class + | SubscriptContext _ | ForContext _ -> + raise (CompilError + {err_msg = ["_InvalidExtensionDef"]; + err_info = []; + err_ctx = ctx}) (*error*) + +and resolve_modified_class ctx ctx' cl_spec cl_modif = + let ctx' = {ctx' with location = cl_spec.Syntax.info} in + let base_class = lazy (resolve_expression ctx cl_spec) in + let cl_spec' = lazy (base_class_type ctx' cl_spec base_class) in + let cl_modif' = + lazy (resolve_class_modification_option ctx' cl_spec' cl_modif) in + { + modified_class_type = lazy (modified_class_type ctx' cl_spec' cl_modif'); + base_class = base_class; + class_modification = cl_modif' + } + +and resolve_element_definition ctx protect redecl final dyn_scope elt_def = + let repl = replaceable_attribute elt_def in + let element_description (id, elt_nat, elt_loc) = + let rec elt_desc = + { + element_type = + lazy (element_type ctx protect final repl dyn_scope elt_desc); + redeclare = bool_of_redeclare redecl; + element_nature = elt_nat; + element_location = elt_loc + } in + id, elt_desc in + List.map element_description (declared_elements ctx elt_def) + +and replaceable_attribute elt_def = match elt_def.Syntax.nature with + | Syntax.ClassDefinitionElement (repl, _, _) | + Syntax.ComponentClauseElement (repl, _, _) -> repl + +and bool_of_redeclare = function + | None -> false + | Some Syntax.Redeclare -> true + +and resolve_type_constraint ctx elt_def = match elt_def.Syntax.nature with + | Syntax.ClassDefinitionElement (_, _, []) | + Syntax.ComponentClauseElement (_, _, []) -> None + | Syntax.ClassDefinitionElement (_, _, _ :: _) | + Syntax.ComponentClauseElement (_, _, _ :: _) -> assert false + +and declared_elements ctx elt_def = match elt_def.Syntax.nature with + | Syntax.ClassDefinitionElement (_, def, _) -> + let s = class_definition_name def + and elt_nat = resolve_definition ctx def + and loc = match def.Syntax.nature with + | Syntax.Definition (encap, part, kind, cl_spec) -> + cl_spec.Syntax.info in + [s, elt_nat, loc] + | Syntax.ComponentClauseElement (_, cpnt_cl, _) -> + resolve_component_clause ctx cpnt_cl + +and resolve_component_clause ctx cpnt_cl = match cpnt_cl.Syntax.nature with + | Syntax.ComponentClause (type_pref, type_spec, subs, cpnt_decls) -> + let type_pref' = type_prefix type_pref + and type_spec' = lazy (resolve_expression ctx type_spec) + and dims = lazy (resolve_dimensions ctx subs) in + List.map + (resolve_component_declaration ctx type_pref' type_spec' dims type_spec) + cpnt_decls + +and type_prefix type_pref = + let bool_of_flow = function + | None -> false + | Some Syntax.Flow -> true + and variability_of_variability = function + | None -> None + | Some Syntax.Constant -> Some Types.Constant + | Some Syntax.Parameter -> Some Types.Parameter + | Some Syntax.Discrete -> Some Types.Discrete + and causality_of_inout = function + | None -> Types.Acausal + | Some Syntax.Input -> Types.Input + | Some Syntax.Output -> Types.Output in + match type_pref.Syntax.nature with + | Syntax.TypePrefix (flow, var, inout) -> + bool_of_flow flow, + variability_of_variability var, + causality_of_inout inout + +and resolve_component_declaration + ctx type_pref type_spec' dims type_spec cpnt_decl = + let build_comment_string cmt = match cmt.Syntax.nature with + | Syntax.Comment (ss, _) -> List.fold_right ( ^ ) ss "" in + match cpnt_decl.Syntax.nature with + | Syntax.ComponentDeclaration (decl, cmt) -> + let cmt' = build_comment_string cmt in + resolve_declaration ctx type_pref type_spec' dims decl cmt' type_spec + +and resolve_declaration ctx type_pref type_spec' dims decl cmt type_spec = + let ctx = {ctx with location = decl.Syntax.info} in + match decl.Syntax.nature with + | Syntax.Declaration (id, subs, modif) -> + let dims = lazy ((resolve_dimensions ctx subs) @ (evaluate dims)) in + let cpnt_type = lazy (component_type ctx type_pref type_spec' dims) in + let modif' = + lazy (resolve_component_modification ctx cpnt_type modif) in + let cpnt_desc = + { + component_type = + lazy (modified_component_type ctx (evaluate cpnt_type) modif'); + type_specifier = type_spec'; + dimensions = dims; + modification = modif'; + comment = cmt; + } in + (id, Component cpnt_desc, decl.Syntax.info) + +and resolve_dimensions ctx subs = + let resolve_dimension sub = match sub.Syntax.nature with + | Syntax.Colon -> Colon + | Syntax.Subscript expr -> + Expression (resolve_subscript_expression ctx expr) in + let resolve_dimensions' = function + | None -> [] + | Some { Syntax.nature = Syntax.Subscripts subs_elts } -> + List.map resolve_dimension subs_elts in + resolve_dimensions' subs + +and base_class_type ctx cl_spec base_class = + match (evaluate base_class).info.type_description with + | Types.ClassElement cl_spec -> evaluate cl_spec + | Types.ComponentTypeElement _ -> + raise (CompilError + {err_msg = ["_CannotInheritFrom"; "_ComponentTypeElement"]; + err_info = + [("_ElemFound", Syntax.string_of_expression cl_spec)]; + err_ctx = {ctx with location = cl_spec.Syntax.info}}) (*error*) + | Types.PredefinedTypeElement _ -> + raise (CompilError + {err_msg = ["_CannotInheritFrom"; "_PredefinedTypeElement"]; + err_info = + [("_ElemFound", Syntax.string_of_expression cl_spec)]; + err_ctx = {ctx with location = cl_spec.Syntax.info}}) (*error*) + | Types.ComponentElement _ -> + raise (CompilError + {err_msg = ["_CannotInheritFrom"; "_ComponentElement"]; + err_info = []; + err_ctx = {ctx with location = cl_spec.Syntax.info}}) (*error*) + +and component_type ctx (flow, var, inout) base_type dims = + let base_type = evaluate base_type in + let lower_variability var var' = match var, var' with + | Some Types.Constant, + (Types.Constant | Types.Parameter | Types.Discrete | Types.Continuous) -> + Types.Constant + | Some Types.Parameter, + (Types.Parameter | Types.Discrete | Types.Continuous) -> Types.Parameter + | Some Types.Discrete, (Types.Discrete | Types.Continuous) -> Types.Discrete + | Some Types.Continuous, Types.Continuous -> Types.Continuous + | None, _ -> var' + | Some var, (Types.Constant | Types.Parameter | Types.Discrete) -> + raise (CompilError + {err_msg = ["_VariablityConflictsInCompDef"]; + err_info = + [("_TypePrefix", Types.string_of_variability var); + ("_TypeSpecifierVariability", Types.string_of_variability var')]; + err_ctx = ctx}) (*error*) + and propagate_causality inout inout' = match inout, inout' with + | Types.Acausal, (Types.Acausal | Types.Input | Types.Output) -> inout' + | (Types.Input | Types.Output), Types.Acausal -> inout + | Types.Input, Types.Input | Types.Output, Types.Output -> inout + | Types.Input, Types.Output | Types.Output, Types.Input -> + raise (CompilError + {err_msg = ["_CausalityConflictsInCompDef"]; + err_info = [("_TypePrefix", Types.string_of_causality inout); + ("_TypeSpecifierCausality", + Types.string_of_causality inout')]; + err_ctx = ctx}) (*error*) in + let predefined_type_variability predef = match predef with + | { Types.base_type = Types.RealType } -> Types.Continuous + | _ -> Types.Discrete in + let rec class_specifier_variability cl_spec = match cl_spec with + | Types.PredefinedType predef -> predefined_type_variability predef + | Types.ClassType cl_type -> Types.Continuous + | Types.ComponentType cpnt_type -> evaluate cpnt_type.Types.variability + | Types.ArrayType (dim, cl_spec) -> class_specifier_variability cl_spec + | Types.TupleType cl_specs -> assert false in + match base_type.info.type_description with + | Types.ComponentElement _ -> + raise (CompilError + {err_msg = ["class"; "_ElemExpected"]; + err_info = [("TypeFound", "_ComponentElement")]; + err_ctx = ctx}) (*error*) + | Types.ClassElement cl_spec -> + let cl_spec = evaluate cl_spec in + let var' = class_specifier_variability cl_spec in + let var' = lazy (lower_variability var var') + and base_class = lazy (add_dimensions dims cl_spec) in + component_element (lazy flow) var' (lazy inout) base_class + | Types.ComponentTypeElement cpnt_type -> + let flow' = lazy (flow || evaluate cpnt_type.Types.flow) + and var' = + lazy (lower_variability var (evaluate cpnt_type.Types.variability)) + and inout' = + lazy (propagate_causality inout (evaluate cpnt_type.Types.causality)) + and base_class = + lazy (add_dimensions dims (Types.ComponentType cpnt_type)) in + component_element flow' var' inout' base_class + | Types.PredefinedTypeElement predef -> + let var' = predefined_type_variability predef in + let var' = lazy (lower_variability var var') + and base_class = + lazy (add_dimensions dims (Types.PredefinedType predef)) in + component_element (lazy flow) var' (lazy inout) base_class + +and add_dimensions dims cl_spec = + let add_dimension dim cl_spec = match dim with + | Expression { nature = Integer i } -> + Types.ArrayType (Types.ConstantDimension i, cl_spec) + | Expression _ -> Types.ArrayType (Types.ParameterDimension, cl_spec) + | Colon -> Types.ArrayType (Types.DiscreteDimension, cl_spec) in + List.fold_right add_dimension (evaluate dims) cl_spec + +and modified_described_type ctx cpnt_type cl_modif = + let cpnt_type' = evaluate cpnt_type in + let cl_spec = cpnt_type'.Types.base_class in + { cpnt_type' with + Types.base_class = + lazy (modify_class_specifier ctx (evaluate cl_modif) cl_spec) + } + +and modified_class_type ctx cl_spec cl_modif = + let cl_spec' = modify_class_specifier ctx (evaluate cl_modif) cl_spec in + match cl_spec' with + | Types.ClassType cl_type -> cl_type + | Types.PredefinedType _ | Types.ComponentType _ | Types.ArrayType _ | + Types.TupleType _ -> + raise (CompilError + {err_msg = ["class"; "_ElemExpected"]; + err_info = [("TypeFound", + Types.string_of_class_specifier cl_spec')]; + err_ctx = ctx}) (*error*) + +and modified_component_type ctx cpnt_type modif = + let modified_component_type' = function + | Modification (cl_modif, _) -> modify_component_type ctx cl_modif cpnt_type + | Assignment _ | Equality _ -> cpnt_type in + match evaluate modif with + | None -> cpnt_type + | Some modif' -> modified_component_type' modif' + +(* We can abstract dimensions away since they have been already checked at *) +(* modification resolution time. *) +and modify_class_specifier ctx cl_modif cl_spec = + let rec modify_class_specifier' cl_spec' = match cl_spec' with + | Types.PredefinedType predef -> + Types.PredefinedType (modify_predefined_type ctx cl_modif predef) + | Types.ClassType cl_type -> + Types.ClassType (modify_class_type ctx cl_modif cl_type) + | Types.ComponentType cpnt_type -> + Types.ComponentType (modify_component_type ctx cl_modif cpnt_type) + | Types.ArrayType (dim, cl_spec) -> + Types.ArrayType (dim, modify_class_specifier' cl_spec) + | Types.TupleType _ -> + raise (CompilError + {err_msg = ["_InvalidTypeOfClassSpec"]; + err_info = [("_TypeFound", + Types.string_of_class_specifier cl_spec')]; + err_ctx = ctx}) (*error*) in + modify_class_specifier' (evaluate cl_spec) + +and modify_predefined_type ctx cl_modif predef = + { predef with + Types.attributes = + modify_predefined_attributes ctx cl_modif predef.Types.attributes + } + +and modify_predefined_attributes ctx cl_modif attrs = + let apply_modifications ((id, final) as attr) = function + | [] -> attr + | [_] when final -> assert false (*error*) + | [final', (Assignment _ | Equality _)] -> id, final' + | _ :: _ -> assert false (*error*) in + let modify_attribute ((id, _) as attr) = + let modifs, elt_descs = partition_modifications cl_modif id in + match modifs, elt_descs with + | [], [] -> attr + | _ :: _, [] -> apply_modifications attr modifs + | [], _ :: _ + | _ :: _, _ :: _ -> + raise (CompilError + {err_msg = ["_RedeclarePredefTypeAttrib"; id]; + err_info = []; + err_ctx = ctx}) (*error*) in + List.map modify_attribute attrs + +and modify_class_type ctx cl_modif cl_type = + let modify_named_element (id, elt_type) = + id, lazy (modify_element ctx cl_modif id (evaluate elt_type)) in + { cl_type with + Types.named_elements = + List.map modify_named_element cl_type.Types.named_elements + } + +and modify_element ctx cl_modif id elt_type = + let modifs, elt_descs = partition_modifications cl_modif id in + match modifs, elt_descs with + | [], [] -> elt_type + | _ :: _, [] -> apply_element_modifications ctx modifs elt_type id + | [], [elt_desc] -> apply_element_redeclaration ctx elt_desc elt_type + | [], _ :: _ :: _ -> + raise (CompilError + {err_msg = ["_InvalidElemModifDef"]; + err_info = []; + err_ctx = ctx}) (*error*) + | _ :: _, _ :: _ -> + raise (CompilError + {err_msg = ["_InvalidElemModifDef"]; + err_info = []; + err_ctx = ctx}) (*error*) + +and partition_modifications cl_modif id = + let add_element_modification modif_arg modifs = match modif_arg.action with + | Some (ElementModification modif) -> (modif_arg.final, modif) :: modifs + | None | Some (ElementRedeclaration _) -> modifs + and add_element_redeclaration modif_arg elt_descs = + match modif_arg.action with + | None | Some (ElementModification _) -> elt_descs + | Some (ElementRedeclaration elt_desc) -> + (modif_arg.final, elt_desc) :: elt_descs in + let is_current_element_modification modif_arg = modif_arg.target = id in + let cl_modif' = List.filter is_current_element_modification cl_modif in + let modifs = List.fold_right add_element_modification cl_modif' [] + and elt_descs = List.fold_right add_element_redeclaration cl_modif' [] in + modifs, elt_descs + +and apply_element_redeclaration ctx elt_desc elt_type = + raise (CompilError + {err_msg = ["_NotYetImplemented"; "_ElementRedeclaration"]; + err_info = []; + err_ctx = ctx}) + +and apply_element_modifications ctx modifs elt_type id = + let add_modification_arguments (final, modif) cl_modifs = match modif with + | Modification (cl_modif, _) -> (final, cl_modif) :: cl_modifs + | Assignment _ | Equality _ -> cl_modifs + and add_value_modification (final, modif) val_modifs = match modif with + | Modification (_, Some _) | Assignment _ | Equality _ -> + final :: val_modifs + | Modification (_, None) -> val_modifs in + let cl_modifs = List.fold_right add_modification_arguments modifs [] + and val_modifs = List.fold_right add_value_modification modifs [] in + let elt_type' = modify_element_type ctx cl_modifs elt_type id in + modify_element_value ctx val_modifs elt_type' id + +and modify_element_type ctx cl_modifs elt_type id = + let propagate_final_attribute final modif_arg cl_modif = + { modif_arg with final = final } :: cl_modif in + let merge_modifications (final, cl_modif) cl_modif' = + List.fold_right (propagate_final_attribute final) cl_modif cl_modif' in + let cl_modif = List.fold_right merge_modifications cl_modifs [] in + { elt_type with + Types.element_nature = modify_element_nature ctx cl_modif elt_type id + } + +and modify_element_nature ctx cl_modif elt_type id = + match elt_type.Types.element_nature with + | _ when elt_type.Types.final -> + raise (CompilError + {err_msg = ["_FinalElemModifNotAllowed"; id]; + err_info = []; + err_ctx = ctx}) (*error*) + | Types.ComponentElement cpnt_type -> + Types.ComponentElement (modify_component_type ctx cl_modif cpnt_type) + | Types.ClassElement cl_spec -> + let cl_spec' = lazy (modify_class_specifier ctx cl_modif cl_spec) in + Types.ClassElement cl_spec' + | Types.ComponentTypeElement cpnt_type -> + let cpnt_type' = modify_component_type ctx cl_modif cpnt_type in + Types.ComponentTypeElement cpnt_type' + | Types.PredefinedTypeElement predef -> + Types.PredefinedTypeElement (modify_predefined_type ctx cl_modif predef) + +and modify_element_value ctx val_modifs elt_type id = + match val_modifs with + | [] -> elt_type + | [_] when elt_type.Types.final -> + raise (CompilError + {err_msg = ["_FinalElemModifNotAllowed"; id]; + err_info = []; + err_ctx = ctx}) (*error*) + | [final] -> { elt_type with Types.final = final } + | _ :: _ :: _ -> + raise (CompilError + {err_msg = ["_DuplicatedModifOfElem"; id]; + err_info = []; + err_ctx = ctx}) (*error*) + +and modify_component_type ctx cl_modif cpnt_type = + { cpnt_type with + Types.base_class = + lazy (modify_class_specifier ctx cl_modif cpnt_type.Types.base_class) + } + +and resolve_type_modification ctx cpnt_type cl_modif = + let cl_spec = (evaluate cpnt_type).Types.base_class in + resolve_class_modification_option ctx cl_spec cl_modif + +and resolve_component_modification ctx cpnt_type = function + | None -> None + | Some modif' -> + let elt_nat = Types.ComponentElement (evaluate cpnt_type) in + Some (resolve_modification ctx elt_nat modif') + +and resolve_class_modification_option ctx cl_spec = function + | None -> [] + | Some cl_modif -> resolve_class_modification ctx cl_spec cl_modif + +and resolve_modification ctx elt_nat modif = + let ctx = {ctx with location = modif.Syntax.info} in + match elt_nat, modif.Syntax.nature with + | Types.ComponentElement cpnt_type, Syntax.Modification (cl_modif, expr) | + Types.ComponentTypeElement cpnt_type, + Syntax.Modification (cl_modif, (None as expr)) -> + resolve_component_type_modification ctx cpnt_type cl_modif expr + | Types.ComponentTypeElement _, Syntax.Modification (_, Some _) -> + raise (CompilError + {err_msg = ["_InvalidClassElemModif"]; + err_info = []; + err_ctx = ctx}) (*error*) + | Types.ClassElement cl_spec, Syntax.Modification (cl_modif, None) -> + let cl_modif' = resolve_class_modification ctx cl_spec cl_modif in + Modification (cl_modif', None) + | Types.ClassElement _, Syntax.Modification (_, Some _) -> + raise (CompilError + {err_msg = ["_InvalidClassElemModif"]; + err_info = []; + err_ctx = ctx}) (*error*) + | (Types.PredefinedTypeElement _), + (Syntax.Modification _ | Syntax.Eq _ | Syntax.ColEq _) -> + raise (CompilError + {err_msg = ["_InvalidClassElemModif"]; + err_info = []; + err_ctx = ctx}) (*error*) + | Types.ComponentElement cpnt_type, Syntax.Eq expr -> + let expr' = lazy (resolve_modification_equation ctx cpnt_type expr) in + Equality expr' + | Types.ComponentElement cpnt_type, Syntax.ColEq expr -> + let expr' = lazy (resolve_modification_algorithm ctx cpnt_type expr) in + Assignment expr' + | (Types.ClassElement _ | Types.ComponentTypeElement _), + (Syntax.Eq _ | Syntax.ColEq _) -> + raise (CompilError + {err_msg = ["_InvalidClassElemModif"]; + err_info = []; + err_ctx = ctx}) (*error*) + +and resolve_component_type_modification ctx cpnt_type cl_modif expr = + let ctx = {ctx with location = cl_modif.Syntax.info} in + let cl_spec = cpnt_type.Types.base_class in + let cl_modif' = resolve_class_modification ctx cl_spec cl_modif in + let cpnt_type' = modify_component_type ctx cl_modif' cpnt_type in + let expr' = resolve_value_modification_option ctx cpnt_type' expr in + Modification (cl_modif', expr') + +and resolve_value_modification_option ctx cpnt_type = function + | None -> None + | Some expr -> Some (lazy (resolve_modification_equation ctx cpnt_type expr)) + +and resolve_modification_equation ctx cpnt_type expr = + let ctx = {ctx with location = expr.Syntax.info} in + let resolve_modification_equation' cpnt_type' expr' = + let var = evaluate cpnt_type.Types.variability + and var' = evaluate cpnt_type'.Types.variability in + match Types.compare_component_types cpnt_type cpnt_type' with + | Types.SameType + when Types.higher_variability var var' -> expr' + | Types.SameType -> + let var = Types.string_of_variability var + and var' = Types.string_of_variability var' in + raise (CompilError + {err_msg = ["_VariabilityConflicts"]; + err_info = [("_ExprKind", "A = B"); + ("_VariabilityOfA", var); + ("_VariabilityOfB", var')]; + err_ctx = ctx}) (*error*) + | _ -> + let type_A = Types.string_of_component_type cpnt_type + and type_B = Types.string_of_component_type cpnt_type' in + raise (CompilError + {err_msg = [ "_EquTermsNotOfTheSameType"]; + err_info = [("_ExprKind", "A = B"); + ("_TypeOfA", type_A); + ("_TypeOfB", type_B)]; + err_ctx = ctx}) (*error*) in + let expr' = resolve_expression ctx expr in + let expr' = apply_rhs_coercions cpnt_type expr' in + match expr'.info.type_description with + | Types.ComponentElement cpnt_type' -> + resolve_modification_equation' cpnt_type' expr' + | Types.ClassElement _ | Types.ComponentTypeElement _ | + Types.PredefinedTypeElement _ -> + raise (CompilError + {err_msg = ["_ClassElemFoundInExpr"]; + err_info = []; + err_ctx = ctx}) (*error*) + +and resolve_modification_algorithm ctx cpnt_type expr = + let ctx = {ctx with location = expr.Syntax.info} in + let resolve_modification_algorithm' cpnt_type' expr' = + let var = evaluate cpnt_type.Types.variability + and var' = evaluate cpnt_type'.Types.variability in + match Types.compare_component_types cpnt_type cpnt_type' with + | Types.SameType + when Types.higher_variability var var' -> expr' + | Types.SameType -> + let var = Types.string_of_variability var + and var' = Types.string_of_variability var' in + raise (CompilError + {err_msg = ["_VariabilityConflicts"]; + err_info = [("_ExprKind", "A := B"); + ("_VariabilityOfA", var); + ("_VariabilityOfB", var')]; + err_ctx = ctx}) (*error*) + | _ -> + let type_A = Types.string_of_component_type cpnt_type + and type_B = Types.string_of_component_type cpnt_type' in + raise (CompilError + {err_msg = [ "_TypeConflictsInAssign"]; + err_info = [("_ExprKind", "A := B"); + ("_TypeOfA", type_A); + ("_TypeOfB", type_B)]; + err_ctx = ctx}) (*error*) in + let expr' = resolve_expression ctx expr in + let expr' = apply_rhs_coercions cpnt_type expr' in + match expr'.info.type_description with + | Types.ComponentElement cpnt_type' -> + resolve_modification_algorithm' cpnt_type' expr' + | Types.ClassElement _ | Types.ComponentTypeElement _ | + Types.PredefinedTypeElement _ -> + raise (CompilError + {err_msg = ["_ClassElemFoundInExpr"]; + err_info = []; + err_ctx = ctx}) (*error*) + +and resolve_class_modification ctx cl_spec cl_modif = + match cl_modif.Syntax.nature with + | Syntax.ClassModification args -> + List.map (resolve_modification_argument ctx cl_spec) args + +and resolve_modification_argument ctx cl_spec arg = + let ctx = {ctx with location = arg.Syntax.info} in + let apply_each each = + let rec drop_dimensions cl_spec = match cl_spec with + | Types.ArrayType (_, cl_spec') -> drop_dimensions cl_spec' + | Types.PredefinedType _ | Types.ClassType _ | Types.ComponentType _ | + Types.TupleType _ -> cl_spec in + let cl_spec' = evaluate cl_spec in + match cl_spec' with + | Types.ArrayType _ when each -> drop_dimensions cl_spec' + | Types.PredefinedType _ + | Types.ClassType _ + | Types.ComponentType _ + | Types.TupleType _ when each -> + raise (CompilError + {err_msg = ["_EachAppliedToNonArrayElem"]; + err_info = []; + err_ctx = ctx}) (*error*) + | Types.ArrayType _ | Types.PredefinedType _ | Types.ClassType _ | + Types.ComponentType _ | Types.TupleType _ -> cl_spec' in + match arg.Syntax.nature with + | Syntax.ElementModification (each, final, expr, modif, _) -> + let each' = bool_of_each each + and final' = bool_of_final final in + let cl_spec' = apply_each each' in + resolve_element_modification ctx cl_spec' each' final' expr modif + | Syntax.ElementRedeclaration (each, final, elt_def) -> + let each' = bool_of_each each + and final' = bool_of_final final in + let cl_spec' = apply_each each' in + resolve_element_redeclaration ctx cl_spec' each' final' elt_def + +and bool_of_each = function + | None -> false + | Some Syntax.Each -> true + +and bool_of_final = function + | None -> false + | Some Syntax.Final -> true + +and resolve_element_modification ctx cl_spec each final expr modif = + let ctx = {ctx with location = expr.Syntax.info} in + let rec path_of_expression path expr = match expr.Syntax.nature with + | Syntax.Identifier id -> + modification_arguments_of_path cl_spec each final id (List.rev path) + | Syntax.FieldAccess (expr, id) -> path_of_expression (id :: path) expr + | _ -> + raise (CompilError + {err_msg = ["_InvalidExprInElemModif"]; + err_info = []; + err_ctx = ctx}) (*error*) + and modification_arguments_of_path cl_spec each final id path = + let flow = false + and var = Types.Continuous + and inout = Types.Acausal in + let elt_nat = element_field_type_nature ctx flow var inout cl_spec id in + { + each = each; + final = final; + target = id; + action = resolve_modification_action ctx modif elt_nat path + } + and resolve_modification_action ctx modif elt_nat = function + | [] -> resolve_modification_option ctx elt_nat modif + | id :: path -> + raise (CompilError + {err_msg = ["_NotYetImplemented"; "_FieldAccessInElemModifExpr"]; + err_info = []; + err_ctx = ctx}) + and resolve_modification_option ctx elt_nat = function + | None -> None + | Some modif -> + Some (ElementModification (resolve_modification ctx elt_nat modif)) in + path_of_expression [] expr + +and resolve_element_redeclaration ctx cl_spec each final elt_def = + let ctx = {ctx with location = elt_def.Syntax.info} in + raise (CompilError + {err_msg = ["_NotYetImplemented"; "_ElementRedeclaration"]; + err_info = []; + err_ctx = ctx}) + +and resolve_unnamed_elements ctx other_elts = + let class_kind = + let class_context' cl_spec = match cl_spec with + | Types.ClassType cl_type -> + Some (evaluate cl_type.Types.kind) + | _ -> None in + match ctx.context_nature with + | ClassContext cl_def -> + class_context' (evaluate cl_def.class_type) + | _ -> None in + let add_equation_or_algorithm_clause other_elt acc = + match other_elt.Syntax.nature, class_kind with + | (Syntax.EquationClause _), Some kind + when List.mem kind [Types.Function; Types.Record; Types.Connector] -> + raise (CompilError + {err_msg = ["_EquNotAllowedInTheDefOf"; Types.string_of_kind kind]; + err_info = []; + err_ctx = ctx}) (*error*) + | Syntax.EquationClause (init, equ_defs), _ -> + let init' = bool_of_initial init + and equ_defs' = resolve_equation_definitions ctx equ_defs in + EquationClause (init', equ_defs') :: acc + | Syntax.AlgorithmClause (init, algo_defs), _ -> + let init' = bool_of_initial init + and algo_defs' = resolve_algorithm_definitions ctx algo_defs in + AlgorithmClause (init', algo_defs') :: acc + | (Syntax.Public _ | Syntax.Protected _), _ -> acc in + List.fold_right add_equation_or_algorithm_clause other_elts [] + +and bool_of_initial = function + | None -> Permanent + | Some Syntax.Initial -> Initial + +and resolve_equation_definitions ctx equ_defs = + let resolve_equation_definition equ_def = match equ_def.Syntax.nature with + | Syntax.Equation (equ, _, _) -> resolve_equation ctx equ in + List.flatten (List.map resolve_equation_definition equ_defs) + +and resolve_algorithm_definitions ctx algo_defs = + let resolve_algorithm_definition algo_def = match algo_def.Syntax.nature with + | Syntax.Algorithm (algo, _, _) -> resolve_algorithm ctx algo in + List.map resolve_algorithm_definition algo_defs + +and resolve_equation ctx equ = + let ctx = {ctx with location = equ.Syntax.info} in + match equ.Syntax.nature with + | Syntax.Equal (expr, expr') -> resolve_equal ctx equ expr expr' + | Syntax.ConditionalEquationE (alts, default) -> + resolve_conditional_equation_e ctx equ alts default + | Syntax.ForClauseE (for_inds, equs) -> + resolve_for_clause_e ctx equ for_inds equs + | Syntax.ConnectClause (expr, expr') -> + resolve_connect_clause ctx equ expr expr' + | Syntax.WhenClauseE alts -> + resolve_when_clause_e ctx equ alts + | Syntax.FunctionCallE (expr, fun_args) -> + resolve_functional_call_e ctx equ expr fun_args + +and resolve_equal ctx equ expres expres' = + let resolve_equal' cpnt_type expr cpnt_type' expr' = + let resolved_equation syn expr expr' = + { + nature = Equal (expr, expr'); + info = syn + } in + let var = evaluate cpnt_type.Types.variability + and var' = evaluate cpnt_type'.Types.variability in + match var, var' with + | Types.Continuous, _ | _, Types.Continuous -> + equations ctx equ resolved_equation cpnt_type expr cpnt_type' expr' + | Types.Discrete, _ | _, Types.Discrete + when expression_of_variable expres -> + equations ctx equ resolved_equation cpnt_type expr cpnt_type' expr' + | Types.Discrete, _ | _, Types.Discrete -> + raise (CompilError + {err_msg = ["_LHSOfDiscreteEquMustBeAVar"]; + err_info = []; + err_ctx = {ctx with location = expres.Syntax.info}}) (*error*) + | _ -> + equations ctx equ resolved_equation cpnt_type expr cpnt_type' expr' in + let expr = resolve_expression ctx expres + and expr' = resolve_expression ctx expres' in + let exprs = apply_binary_coercions [ expr; expr' ] in + let expr = List.nth exprs 0 + and expr' = List.nth exprs 1 in + let elt_nat = expr.info.type_description + and elt_nat' = expr'.info.type_description in + match elt_nat, elt_nat' with + | Types.ComponentElement cpnt_type, Types.ComponentElement cpnt_type' -> + resolve_equal' cpnt_type expr cpnt_type' expr' + | (Types.ClassElement _ | Types.ComponentTypeElement _ | + Types.PredefinedTypeElement _), _ -> + let ctx = {ctx with location = expres.Syntax.info} in + raise (CompilError + {err_msg = ["_ClassElemFoundInExpr"]; + err_info = []; + err_ctx = ctx}) (*error*) + | _, (Types.ClassElement _ | Types.ComponentTypeElement _ | + Types.PredefinedTypeElement _) -> + let ctx = {ctx with location = expres'.Syntax.info} in + raise (CompilError + {err_msg = ["_ClassElemFoundInExpr"]; + err_info = []; + err_ctx = ctx}) (*error*) + +and resolve_conditional_equation_e ctx equ alts default = + let resolve_alternative (expr, equs) = + let ctx = {ctx with location = expr.Syntax.info} in + let expr' = resolve_expression ctx expr in + let resolve_alternative' cpnt_type = + let cl_spec = evaluate cpnt_type.Types.base_class in + match cl_spec with + | Types.PredefinedType { Types.base_type = Types.BooleanType } -> + let equs' = List.flatten (List.map (resolve_equation ctx) equs) in + expr', equs' + | Types.PredefinedType _ | Types.ClassType _ | Types.ComponentType _ | + Types.ArrayType _ | Types.TupleType _ -> + raise (CompilError + {err_msg = ["_NonBooleanIfCondExpr"]; + err_info = + [("_ExprKind", "...if A then..."); + ("_TypeOfA", Types.string_of_class_specifier cl_spec)]; + err_ctx = ctx}) (*error*) in + match expr'.info.type_description with + | Types.ComponentElement cpnt_type -> resolve_alternative' cpnt_type + | Types.ClassElement _ | Types.ComponentTypeElement _ | + Types.PredefinedTypeElement _ -> + raise (CompilError + {err_msg = ["_ClassElemFoundInExpr"]; + err_info = []; + err_ctx = ctx}) (*error*) in + let alts' = List.map resolve_alternative alts in + let default' = match default with + | None -> [] + | Some equs -> List.flatten (List.map (resolve_equation ctx) equs) in + [{ + nature = ConditionalEquationE (alts', default'); + info = Some equ + }] + +and resolve_for_clause_e ctx equ for_inds equs = + let range_element_type expr range = + let ctx = {ctx with location = expr.Syntax.info} in + let sub_dimension cl_spec = match cl_spec with + | Types.ArrayType (dim, cl_spec) -> cl_spec + | Types.PredefinedType _ | Types.ClassType _ | + Types.ComponentType _ | Types.TupleType _ -> + raise (CompilError + {err_msg = ["_InvalidTypeInRangeExpr"]; + err_info = + [("_ExpectedType", "Integer"); + ("_TypeFound", Types.string_of_class_specifier cl_spec)]; + err_ctx = ctx}) (*error*) in + match range.info.type_description with + | Types.ComponentElement cpnt_type -> + let cl_spec = evaluate cpnt_type.Types.base_class in + let cpnt_type' = + { cpnt_type with + Types.base_class = lazy (sub_dimension cl_spec) + } in + Types.ComponentElement cpnt_type' + | Types.ClassElement _ | Types.ComponentTypeElement _ | + Types.PredefinedTypeElement _ -> + raise (CompilError + {err_msg = ["_ClassElemFoundInExpr"]; + err_info = []; + err_ctx = ctx}) (*error*) in + let rec resolve_for_clause_e' acc ctx = function + | [] -> + let equs' = List.flatten (List.map (resolve_equation ctx) equs) in + [{ + nature = ForClauseE (List.rev acc, equs'); + info = Some equ + }] + | (_, None) :: _ -> + raise (CompilError + {err_msg = ["_NotYetImplemented"; "_ImplicitIterRange"]; + err_info = []; + err_ctx = ctx}) + | (id, Some expr) :: for_inds -> + let range = resolve_expression ctx expr in + let elt_nat = range_element_type expr range in + let ctx' = + { ctx with + context_nature = ForContext (ctx, id, elt_nat) + } in + resolve_for_clause_e' (range :: acc) ctx' for_inds in + resolve_for_clause_e' [] ctx for_inds + +and resolve_connect_clause ctx equ expres expres' = + let expr = resolve_expression ctx expres + and expr' = resolve_expression ctx expres' in + let resolve_connect_clause' cpnt_typ cpnt_typ' = + let rec class_type_of_class_specifier cl_spec = match cl_spec with + | Types.ClassType cl_type -> cl_type + | Types.ComponentType cpnt_type -> + let cl_spec = evaluate cpnt_type.Types.base_class in + class_type_of_class_specifier cl_spec + | Types.ArrayType (_, cl_spec) -> class_type_of_class_specifier cl_spec + | Types.PredefinedType _ | Types.TupleType _ -> + raise (CompilError + {err_msg = ["_InvalidTypeOfArgInConnectStat"]; + err_info = + [("_ExprKind", "connect(A, B)"); + ("_TypeOfA", Types.string_of_component_type cpnt_typ); + ("_TypeOfB", Types.string_of_component_type cpnt_typ')]; + err_ctx = ctx}) (*error*) in + let connector_sign expr = + let is_connector_type expr = + let is_connector_type' cpnt_type = + let cl_spec = evaluate cpnt_type.Types.base_class in + let cl_type = class_type_of_class_specifier cl_spec in + match evaluate cl_type.Types.kind with + | Types.Connector | Types.ExpandableConnector -> true + | Types.Class | Types.Model | Types.Block -> false + | Types.Record -> + raise (CompilError + {err_msg = + ["record"; "_InstanceUsedInConnection"]; + err_info = []; + err_ctx = ctx}) (*error*) + | Types.Package -> + raise (CompilError + {err_msg = + ["package"; "_InstanceUsedInConnection"]; + err_info = []; + err_ctx = ctx}) (*error*) + | Types.Function -> + raise (CompilError + {err_msg = + ["function"; "_InstanceUsedInConnection"]; + err_info = []; + err_ctx = ctx}) (*error*) in + match expr.info.type_description with + | Types.ComponentElement cpnt_type -> + is_connector_type' cpnt_type + | _ -> + raise (CompilError + {err_msg = ["_ClassElemFoundInExpr"]; + err_info = []; + err_ctx = ctx}) (*error*) in + let is_connectable expr = + let is_connectable' cpnt_type = + let cl_spec = evaluate cpnt_type.Types.base_class in + let cl_type = class_type_of_class_specifier cl_spec in + match evaluate cl_type.Types.kind with + | Types.Class | Types.Model | Types.Block -> true + | Types.Connector | Types.ExpandableConnector -> false + | Types.Record -> + raise (CompilError + {err_msg = + ["record"; "_InstanceUsedInConnection"]; + err_info = []; + err_ctx = ctx}) (*error*) + | Types.Package -> + raise (CompilError + {err_msg = + ["package"; "_InstanceUsedInConnection"]; + err_info = []; + err_ctx = ctx}) (*error*) + | Types.Function -> + raise (CompilError + {err_msg = + ["function"; "_InstanceUsedInConnection"]; + err_info = []; + err_ctx = ctx}) (*error*) in + match expr.info.type_description with + | Types.ComponentElement cpnt_type -> + is_connectable' cpnt_type + | _ -> + raise (CompilError + {err_msg = ["_ClassElemFoundInExpr"]; + err_info = []; + err_ctx = ctx}) (*error*) in + let rec connector_sign' expr = match expr.nature with + | LocalIdentifier (0, _) when is_connector_type expr -> Some Negative + | LocalIdentifier (0, _) when is_connectable expr -> Some Positive + | (FieldAccess (expr', _) | IndexedAccess (expr', _)) + when is_connector_type expr -> connector_sign' expr' + | (FieldAccess (expr', _) | IndexedAccess (expr', _)) + when is_connectable expr' -> connector_sign' expr' + | _ -> + raise (CompilError + {err_msg = ["_InvalidTypeOfArgInConnectStat"]; + err_info = + [("_ExprKind", "connect(A, B)"); + ("_TypeOfA", Types.string_of_component_type cpnt_typ); + ("_TypeOfB", Types.string_of_component_type cpnt_typ')]; + err_ctx = ctx}) (*error*) in + match expr.nature with + | _ when not (is_connector_type expr) -> + raise (CompilError + {err_msg = ["_InvalidTypeOfArgInConnectStat"]; + err_info = + [("_ExprKind", "connect(A, B)"); + ("_TypeOfA", Types.string_of_component_type cpnt_typ); + ("_TypeOfB", Types.string_of_component_type cpnt_typ')]; + err_ctx = ctx}) (*error*) + | LocalIdentifier (0, _) -> Some Negative + | _ -> connector_sign' expr in + let connect sign cpnt_type sign' cpnt_type' = + let resolved_equation syn expr expr' = + let elt_nat = expr.info.type_description + and elt_nat' = expr'.info.type_description in + let flow, _, _ = type_prefixes_of_element_nature elt_nat + and flow', _, _ = type_prefixes_of_element_nature elt_nat' in + match flow, flow' with + | false, false -> + { + nature = Equal (expr, expr'); + info = syn + } + | true, true -> + { + nature = ConnectFlows (sign, expr, sign', expr'); + info = syn + } + | false, true -> + raise (CompilError + {err_msg = ["_CannotConnectFlowAndNonFlowComp"]; + err_info = + [("_ExprKind", "connect(A, B)"); + ("_TypeOfA", "non-flow connector"); + ("_TypeOfB", "flow connector")]; + err_ctx = ctx}) (*error*) + | true, false -> + raise (CompilError + {err_msg = ["_CannotConnectFlowAndNonFlowComp"]; + err_info = + [("_ExprKind", "connect(A, B)"); + ("_TypeOfA", "flow connector"); + ("_TypeOfB", "non-flow connector")]; + err_ctx = ctx}) (*error*) in + equations ctx equ resolved_equation cpnt_type expr cpnt_type' expr' in + match connector_sign expr, connector_sign expr' with + | Some sign, Some sign' -> connect sign cpnt_typ sign' cpnt_typ' + | None, Some _ -> assert false + | Some _, None -> assert false + | None, None -> assert false in + let elt_nat = expr.info.type_description + and elt_nat' = expr'.info.type_description in + match elt_nat, elt_nat' with + | Types.ComponentElement cpnt_typ, Types.ComponentElement cpnt_typ' -> + resolve_connect_clause' cpnt_typ cpnt_typ' + | _, _ -> + raise (CompilError + {err_msg = ["_InvalidTypeOfArgInConnectStat"]; + err_info = + [("_ExprKind", "connect(A, B)"); + ("_TypeOfA", Types.string_of_element_nature elt_nat); + ("_TypeOfB", Types.string_of_element_nature elt_nat')]; + err_ctx = ctx}) (*error*) + +and resolve_when_clause_e ctx equ alts = + let resolve_alternative (expr, equs) = + let expr' = resolve_expression ctx expr in + let rec check_equation equ = + let check_equal expr expr' = + match expr.Syntax.nature, expr'.Syntax.nature with + | _, _ when expression_of_variable expr -> true + | Syntax.Tuple exprs, Syntax.FunctionCall _ + when List.for_all expression_of_variable exprs -> true + | _, _ -> raise (CompilError + {err_msg = ["_InvalidWhenEquation"]; + err_info = []; + err_ctx = {ctx with location = expr.Syntax.info}}) (*error*) in + let check_alternative (expr, equs) = + List.for_all check_equation equs in + let check_function_call_e expr fun_args = + match expr.Syntax.nature with + | Syntax.Identifier "assert" | + Syntax.Identifier "terminate" | + Syntax.Identifier "reinit" -> true + | _ -> + raise (CompilError + {err_msg = ["_InvalidWhenEquation"]; + err_info = []; + err_ctx = {ctx with location = expr.Syntax.info}}) in + match equ.Syntax.nature with + | Syntax.Equal (expr, expr') -> check_equal expr expr' + | Syntax.ConditionalEquationE (alts, None) -> + List.for_all check_alternative alts + | Syntax.ConditionalEquationE (alts, Some equs) -> + (List.for_all check_alternative alts) && + (List.for_all check_equation equs) + | Syntax.ForClauseE (for_inds, equs) -> + List.for_all check_equation equs + | Syntax.ConnectClause (expr, expr') -> + raise (CompilError + {err_msg = ["_InvalidWhenEquation"]; + err_info = []; + err_ctx = {ctx with location = equ.Syntax.info}}) (*error*) + | Syntax.WhenClauseE alts -> + raise (CompilError + {err_msg = ["_WhenClausesCannotBeNested"]; + err_info = []; + err_ctx = {ctx with location = equ.Syntax.info}}) (*error*) + | Syntax.FunctionCallE (expr, fun_args) -> + check_function_call_e expr fun_args in + let resolve_alternative' cpnt_type = + let cl_spec = evaluate cpnt_type.Types.base_class in + match cl_spec with + | Types.ArrayType (Types.DiscreteDimension, _) -> + raise (CompilError + {err_msg = ["_InvalidTypeOfWhenCond"]; + err_info = + [("_ExprKind", "...when A then..."); + ("_TypeOfA", Types.string_of_class_specifier cl_spec)]; + err_ctx = {ctx with location = expr.Syntax.info}}) (*error*) + | Types.PredefinedType { Types.base_type = Types.BooleanType } | + Types.ArrayType + (_, Types.PredefinedType { Types.base_type = Types.BooleanType }) + when List.for_all check_equation equs -> + let equs' = List.flatten (List.map (resolve_equation ctx) equs) in + expr', equs' + | Types.PredefinedType _ | Types.ClassType _ | Types.ComponentType _ | + Types.ArrayType _ | Types.TupleType _ -> + raise (CompilError + {err_msg = ["_InvalidTypeOfWhenCond"]; + err_info = + [("_ExprKind", "...when A then..."); + ("_TypeOfA", Types.string_of_class_specifier cl_spec)]; + err_ctx = {ctx with location = expr.Syntax.info}}) (*error*) in + match expr'.info.type_description with + | Types.ComponentElement cpnt_type + when (evaluate cpnt_type.Types.variability) <> Types.Continuous -> + resolve_alternative' cpnt_type + | Types.ComponentElement cpnt_type -> + raise (CompilError + {err_msg = ["_WhenConditionMustBeDiscrete"]; + err_info = []; + err_ctx = {ctx with location = expr.Syntax.info}}) (*error*) + | Types.ClassElement _ | Types.ComponentTypeElement _ | + Types.PredefinedTypeElement _ -> + raise (CompilError + {err_msg = ["_ClassElemFoundInExpr"]; + err_info = []; + err_ctx = {ctx with location = expr.Syntax.info}}) (*error*) in + let alts' = List.map resolve_alternative alts in + [{ + nature = WhenClauseE alts'; + info = Some equ + }] + +and resolve_functional_call_e ctx equ expr fun_args = + let ctx = {ctx with location = equ.Syntax.info} in + let res = + let nat = Tuple [] + and elt_nat = Types.empty_tuple_type Types.Constant in + resolved_expression None nat elt_nat in + let fun_call = resolve_function_call ctx None expr fun_args in + let resolve_functional_call_e cpnt_type = + let cl_spec = evaluate cpnt_type.Types.base_class in + match cl_spec with + | Types.TupleType [] -> + [{ + nature = Equal (res, fun_call); + info = Some equ + }] + | _ -> + raise (CompilError + {err_msg = ["_NonEmptyFuncCallUsedAsAnEqu"]; + err_info = + [("_TypeOfFuncValue", Types.string_of_class_specifier cl_spec)]; + err_ctx = ctx}) (*error*) in + match fun_call.info.type_description with + | Types.ComponentElement cpnt_type -> resolve_functional_call_e cpnt_type + | Types.ClassElement _ | Types.ComponentTypeElement _ | + Types.PredefinedTypeElement _ -> + raise (CompilError + {err_msg = ["_ClassElemFoundInExpr"]; + err_info = []; + err_ctx = ctx}) (*error*) + +and equations ctx equ resolved_equation cpnt_type expr cpnt_type' expr' = + let equivalent_types predef predef' = + match Types.compare_predefined_types predef predef', + Types.compare_predefined_types predef' predef with + | _, Types.NotRelated | Types.NotRelated, _ -> false + | _ -> true in + let rec equations' i subs cl_spec expr cl_spec' expr' = + match cl_spec, cl_spec' with + | Types.PredefinedType predef, Types.PredefinedType predef' + when equivalent_types predef predef' -> + [equation subs expr expr'] + | Types.ComponentType cpnt_type, Types.ComponentType cpnt_type' -> + raise (CompilError + {err_msg = ["_NotYetImplemented"; "_ComponentTypeEqu"]; + err_info = []; + err_ctx = ctx}) + | Types.ClassType cl_type, Types.ClassType cl_type' -> + record_equations subs cl_type expr cl_type' expr' + | Types.ArrayType (dim, cl_spec), Types.ArrayType (dim', cl_spec') -> + [for_equation i subs dim cl_spec expr dim' cl_spec' expr'] + | Types.TupleType cl_specs, Types.TupleType cl_specs' -> + [{ + nature = Equal (expr, expr'); + info = Some equ + }] + | (Types.PredefinedType _ | Types.ComponentType _ | Types.ArrayType _ | + Types.TupleType _ | Types.ClassType _), + (Types.PredefinedType _ | Types.ComponentType _ | Types.ArrayType _ | + Types.TupleType _ | Types.ClassType _) -> + raise (CompilError + {err_msg = ["_EquTermsNotOfTheSameType"]; + err_info = + [("_ExprKind", "A = B"); + ("_TypeOfA", Types.string_of_class_specifier cl_spec); + ("_TypeOfB", Types.string_of_class_specifier cl_spec')]; + err_ctx = {ctx with location = equ.Syntax.info}}) (*error*) + and for_equation i subs dim cl_spec expr dim' cl_spec' expr' = + match dim, dim' with + | Types.ConstantDimension n, Types.ConstantDimension n' when n <> n' -> + let type_A = Types.string_of_component_type cpnt_type + and type_B = Types.string_of_component_type cpnt_type' in + raise (CompilError + {err_msg = ["_ArrayDimMismatchInEqu"]; + err_info = [("_ExprKind", "A = B"); + ("_TypeOfA", type_A); + ("_TypeOfB", type_B)]; + err_ctx = ctx}) (*error*) + | (Types.ConstantDimension _ | Types.ParameterDimension), + (Types.ConstantDimension _ | Types.ParameterDimension) -> + let range = resolve_colon ctx expr (Int32.of_int i) dim in + let subs = + let nat = LoopVariable (i - 1) + and elt_nat = Types.integer_type Types.Constant in + resolved_expression None nat elt_nat :: subs in + let equs = equations' (i + 1) subs cl_spec expr cl_spec' expr' in + { + nature = ForClauseE ([range], equs); + info = Some equ + } + | (Types.ConstantDimension _ | Types.ParameterDimension | + Types.DiscreteDimension), + (Types.ConstantDimension _ | Types.ParameterDimension | + Types.DiscreteDimension) -> + let type_A = Types.string_of_component_type cpnt_type + and type_B = Types.string_of_component_type cpnt_type' in + raise (CompilError + {err_msg = ["_ArrayDimMismatchInEqu"]; + err_info = [("_ExprKind", "A = B"); + ("_TypeOfA", type_A); + ("_TypeOfB", type_B)]; + err_ctx = ctx}) (*error*) + and record_equations subs cl_type expr cl_type' expr' = + let named_elts = cl_type.Types.named_elements + and named_elts' = cl_type'.Types.named_elements in + let record_equations' expr expr' = + let class_spec_of_element_type elt_type = + let elt_type' = evaluate elt_type in + element_nature_class ctx elt_type'.Types.element_nature in + let record_equation (id, elt_type) = + let elt_type' = + try + List.assoc id named_elts' + with _ -> + raise (CompilError + {err_msg = ["_EquTermsNotOfTheSameType"]; + err_info = + [("_ExprKind", "A = B"); + ("_TypeOfA", Types.string_of_component_type cpnt_type); + ("_TypeOfB", Types.string_of_component_type cpnt_type')]; + err_ctx = {ctx with location = equ.Syntax.info}}) (*error*) in + let cl_spec = class_spec_of_element_type elt_type + and cl_spec' = class_spec_of_element_type elt_type' in + let expr = + let nat = FieldAccess (expr, id) + and flow, var, inout = + type_prefixes_of_element_nature expr.info.type_description + and cl_spec = element_nature_class ctx expr.info.type_description in + let elt_nat = + element_field_type_nature ctx flow var inout cl_spec id in + resolved_expression None nat elt_nat + and expr' = + let nat = FieldAccess (expr', id) + and flow, var, inout = + type_prefixes_of_element_nature expr'.info.type_description + and cl_spec = element_nature_class ctx expr'.info.type_description in + let elt_nat = + element_field_type_nature ctx flow var inout cl_spec id in + resolved_expression None nat elt_nat in + equations' 1 [] cl_spec expr cl_spec' expr' in + List.flatten (List.map record_equation named_elts) in + match subs with + | [] -> record_equations' expr expr' + | subs -> + let expr = + let elt_nat = expr.info.type_description in + let nat = IndexedAccess (expr, subs) + and elt_nat' = scalar_element_nature elt_nat in + resolved_expression None nat elt_nat' + and expr' = + let elt_nat = expr'.info.type_description in + let nat = IndexedAccess (expr', subs) + and elt_nat' = scalar_element_nature elt_nat in + resolved_expression None nat elt_nat' in + record_equations' expr expr' + and equation subs expr expr' = match subs with + | [] -> resolved_equation (Some equ) expr expr' + | subs -> + let expr = + let elt_nat = expr.info.type_description in + let nat = IndexedAccess (expr, subs) + and elt_nat' = scalar_element_nature elt_nat in + resolved_expression None nat elt_nat' + and expr' = + let elt_nat = expr'.info.type_description in + let nat = IndexedAccess (expr', subs) + and elt_nat' = scalar_element_nature elt_nat in + resolved_expression None nat elt_nat' in + resolved_equation None expr expr' in + let cl_spec = evaluate cpnt_type.Types.base_class + and cl_spec' = evaluate cpnt_type'.Types.base_class in + equations' 1 [] cl_spec expr cl_spec' expr' + +and resolve_algorithm ctx algo = + let ctx = {ctx with location = algo.Syntax.info} in + match algo.Syntax.nature with + | Syntax.Assign _ | + Syntax.FunctionCallA _ | + Syntax.MultipleAssign _ | + Syntax.Break | + Syntax.Return | + Syntax.ConditionalEquationA _ | + Syntax.ForClauseA _ | + Syntax.WhileClause _ | + Syntax.WhenClauseA _ -> + raise (CompilError + {err_msg = ["_NotYetImplemented"; "_AlgoClause"]; + err_info = []; + err_ctx = ctx}) + +and resolve_expression ctx expr = + let ctx = {ctx with location = expr.Syntax.info} in + match expr.Syntax.nature with + | Syntax.BinaryOperation (kind, arg1, arg2) -> + resolve_binary_operation ctx expr kind arg1 arg2 + | Syntax.End -> resolve_end ctx expr + | Syntax.False -> resolve_false ctx expr + | Syntax.FieldAccess (expr', id) -> resolve_field_access ctx expr expr' id + | Syntax.FunctionCall (expr', fun_args) -> + resolve_function_call ctx (Some expr) expr' fun_args + | Syntax.Identifier id -> resolve_identifier ctx expr id + | Syntax.If (alts, expr') -> resolve_if ctx expr alts expr' + | Syntax.IndexedAccess (expr', subs) -> + resolve_indexed_access ctx expr expr' subs + | Syntax.Integer s -> resolve_integer ctx expr s + | Syntax.MatrixConstruction exprss -> + resolve_matrix_construction ctx expr exprss + | Syntax.NoEvent expr' -> + resolve_no_event ctx expr expr' + | Syntax.Range (start, step, stop) -> + resolve_range ctx expr start step stop + | Syntax.Real s -> resolve_real ctx expr s + | Syntax.String s -> resolve_string ctx expr s + | Syntax.True -> resolve_true ctx expr + | Syntax.Tuple exprs -> resolve_tuple ctx expr exprs + | Syntax.UnaryOperation (kind, arg) -> + resolve_unuary_operation ctx expr kind arg + | Syntax.Vector vec_elts -> resolve_vector ctx expr vec_elts + +and resolve_binary_operation ctx expr kind arg1 arg2 = + let arg1' = resolve_expression ctx arg1 + and arg2' = resolve_expression ctx arg2 in + let args' = apply_binary_coercions [ arg1'; arg2' ] in + let arg1' = List.nth args' 0 + and arg2' = List.nth args' 1 in + match kind.Syntax.nature with + | Syntax.Plus -> resolve_addition ctx expr arg1' arg2' + | Syntax.And -> resolve_and ctx expr arg1' arg2' + | Syntax.Divide -> resolve_division ctx expr arg1' arg2' + | Syntax.EqualEqual -> raise (CompilError + {err_msg = ["_NotYetImplemented"; "_BinaryOperEQUEQU"]; + err_info = []; + err_ctx = ctx}) + | Syntax.GreaterEqual -> + resolve_comparison ctx expr GreaterEqual arg1' arg2' + | Syntax.Greater -> resolve_comparison ctx expr Greater arg1' arg2' + | Syntax.LessEqual -> resolve_comparison ctx expr LessEqual arg1' arg2' + | Syntax.Less -> resolve_comparison ctx expr Less arg1' arg2' + | Syntax.Times -> resolve_multiplication ctx expr arg1' arg2' + | Syntax.NotEqual -> raise (CompilError + {err_msg = ["_NotYetImplemented"; "_BinaryOperDIFF"]; + err_info = []; + err_ctx = ctx}) + | Syntax.Or -> resolve_or ctx expr arg1' arg2' + | Syntax.Power -> resolve_power ctx expr arg1' arg2' + | Syntax.Minus -> resolve_subtraction ctx expr arg1' arg2' + +and resolve_end ctx expr = + let ctx = {ctx with location = expr.Syntax.info} in + match ctx.context_nature with + | SubscriptContext (_, _, _, Types.ConstantDimension n) -> + let nat = Integer n + and elt_nat = Types.integer_type Types.Constant in + resolved_expression (Some expr) nat elt_nat + | SubscriptContext (_, expr', n, Types.ParameterDimension) -> + size_function_call ctx (Some expr) expr' n + | SubscriptContext (_, expr', n, Types.DiscreteDimension) -> + size_function_call ctx (Some expr) expr' n + | ForContext (ctx', _, _) -> resolve_end ctx' expr + | ToplevelContext | ClassContext _ -> + raise (CompilError + {err_msg = ["_InvalidKeyWordEndInExpr"]; + err_info = []; + err_ctx = ctx}) (*error*) + +and resolve_false ctx expr = + resolved_expression (Some expr) False (Types.boolean_type Types.Constant) + +and resolve_field_access ctx expr expr' id = + let expr' = resolve_expression ctx expr' in + let resolve_field_access' expr' id = + let nat = FieldAccess (expr', id) + and flow, var, inout = + type_prefixes_of_element_nature expr'.info.type_description + and cl_spec = element_nature_class ctx expr'.info.type_description in + let elt_nat = element_field_type_nature ctx flow var inout cl_spec id in + resolved_expression (Some expr) nat elt_nat in + let is_package cl_spec = match evaluate cl_spec with + | Types.ClassType cl_type + when evaluate cl_type.Types.kind = Types.Package -> true + | _ -> false in + match expr'.info.type_description with + | Types.ComponentElement _ -> + resolve_field_access' expr' id + | Types.ClassElement cl_spec when is_package cl_spec -> + resolve_field_access' expr' id + | _ -> + raise (CompilError + {err_msg = ["component or package"; "_ElemExpected"]; + err_info = []; + err_ctx = { ctx with location = expr.Syntax.info }}) (*error*) + +and type_prefixes_of_element_nature = function + | Types.ComponentElement cpnt_type -> + evaluate cpnt_type.Types.flow, + evaluate cpnt_type.Types.variability, + evaluate cpnt_type.Types.causality + | Types.ClassElement _ | Types.ComponentTypeElement _ | + Types.PredefinedTypeElement _ -> + false, Types.Constant, Types.Acausal + +and resolve_function_call ctx syn expr fun_args = + let ctx = {ctx with location = expr.Syntax.info} in + let expr' = resolve_expression ctx expr in + let resolve_function_arguments named_elts = + let reversed_additional_dimensions input_types args = + let additional_named_element_dimensions id arg = + let rec subtract_dimensions fun_dims arg_dims = + match fun_dims, arg_dims with + | [], _ -> arg_dims + | _, [] -> + raise (CompilError + {err_msg = ["_ArgDimMismatch"]; + err_info = []; + err_ctx = ctx}) (*error*) + | Types.ConstantDimension i :: _, Types.ConstantDimension i' :: _ + when i <> i' -> + raise (CompilError + {err_msg = ["_ArgDimMismatch"]; + err_info = []; + err_ctx = ctx}) (*error*) + | _ :: fun_dims, _ :: arg_dims -> + subtract_dimensions fun_dims arg_dims in + let elt_type = List.assoc id input_types in + let elt_type' = evaluate elt_type in + let fun_dims = + Types.reversed_element_dimensions elt_type'.Types.element_nature + and arg_dims = + Types.reversed_element_dimensions arg.info.type_description in + subtract_dimensions fun_dims arg_dims in + let rec reversed_additional_dimensions' ids dims args = + match args with + | [] -> ids, dims + | (id, arg) :: args -> + let dims' = additional_named_element_dimensions id arg in + update_additional_dimensions ids dims id dims' args + and update_additional_dimensions ids dims id dims' args = + match dims, dims' with + | _, [] -> reversed_additional_dimensions' ids dims args + | [], _ :: _ -> + let ids' = id :: ids in + reversed_additional_dimensions' ids' dims' args + | _ :: _, _ :: _ when dims <> dims' -> + raise (CompilError + {err_msg = ["_ArgDimMismatchInVectCall"]; + err_info = []; + err_ctx = ctx}) (*error*) + | _ :: _, _ :: _ -> + let ids' = id :: ids in + reversed_additional_dimensions' ids' dims args in + reversed_additional_dimensions' [] [] args in + let function_call ids rev_dims input_types output_types args = + let ndims = List.length rev_dims in + let rec expressions_of_named_arguments pos input_types = + let expression_of_default_argument id elt_type = + let elt_type' = evaluate elt_type in + let func = + let nat = FunctionArgument 0 + and elt_nat = expr'.info.type_description in + resolved_expression None nat elt_nat in + let nat = FieldAccess (func, id) + and elt_nat = elt_type'.Types.element_nature in + resolved_expression None nat elt_nat + and expression_of_named_argument pos id elt_type = + let rec loop_variables = function + | 0 -> [] + | ndims -> + let nat = LoopVariable (ndims - 1) + and elt_nat = (Types.integer_type Types.Constant) in + let loop_var = resolved_expression None nat elt_nat in + loop_var :: loop_variables (ndims - 1) in + let elt_type' = evaluate elt_type in + let elt_nat = elt_type'.Types.element_nature in + let nat = match List.mem id ids with + | false -> FunctionArgument pos + | true -> + let arg = List.assoc id args in + let nat = FunctionArgument pos + and elt_nat = arg.info.type_description in + let expr = resolved_expression None nat elt_nat in + IndexedAccess (expr, loop_variables ndims) in + resolved_expression None nat elt_nat in + match input_types with + | [] -> [] + | (id, elt_type) :: input_types when not (List.mem_assoc id args) -> + let arg = expression_of_default_argument id elt_type in + arg :: expressions_of_named_arguments pos input_types + | (id, elt_type) :: input_types -> + let arg = expression_of_named_argument pos id elt_type in + arg :: expressions_of_named_arguments (pos + 1) input_types in + let ranges arg rev_dims = + let rec ranges' acc n rev_dims = + let range_of_dimension dim = + let range_to stop = + let nat = Range (one, one, stop) + and elt_nat = Types.integer_array_type Types.Constant dim in + resolved_expression None nat elt_nat in + match dim with + | Types.ConstantDimension i -> + let stop = + let nat = Integer i + and elt_nat = (Types.integer_type Types.Constant) in + resolved_expression None nat elt_nat in + range_to stop + | Types.ParameterDimension -> + let stop = size_function_call ctx None arg n in + range_to stop + | Types.DiscreteDimension -> + let stop = size_function_call ctx None arg n in + range_to stop in + match rev_dims with + | [] -> acc + | dim :: rev_dims -> + let range = range_of_dimension dim in + ranges' (range :: acc) (Int32.succ n) rev_dims in + ranges' [] 1l rev_dims in + let rec sorted_arguments_of_named_arguments = function + | [] -> [] + | (id, _) :: input_types when not (List.mem_assoc id args) -> + sorted_arguments_of_named_arguments input_types + | (id, _) :: input_types -> + let arg = List.assoc id args in + arg :: sorted_arguments_of_named_arguments input_types in + let wrap_function_invocation cpnt_type = + let add_dimensions cpnt_type = + let rec add_dimensions cl_spec = function + | [] -> cl_spec + | dim :: rev_dims -> + let cl_spec' = Types.ArrayType (dim, cl_spec) in + add_dimensions cl_spec' rev_dims in + let base_class = cpnt_type.Types.base_class in + { cpnt_type with + Types.base_class = + lazy (add_dimensions (evaluate base_class) rev_dims) + } in + let wrap_function_invocation' cpnt_type rev_dims = + let nat = + let exprs = expressions_of_named_arguments 1 input_types in + FunctionInvocation exprs + and elt_nat = Types.ComponentElement cpnt_type in + match ids with + | [] -> + resolved_expression syn nat elt_nat + | id :: _ -> + let cpnt_type' = add_dimensions cpnt_type in + let nat = + let ranges = + let arg = List.assoc id args in + ranges arg rev_dims + and expr = resolved_expression None nat elt_nat in + VectorReduction (ranges, expr) + and elt_nat = Types.ComponentElement cpnt_type' in + resolved_expression None nat elt_nat in + wrap_function_invocation' cpnt_type rev_dims in + let component_type_of_output_types output_types = + let component_type_of_output_type cpnt_type (_, elt_type) = + let add_class_specifier cl_spec cl_spec' = + match cl_spec, cl_spec' with + | Types.TupleType [], _ -> cl_spec' + | (Types.TupleType cl_specs), _ -> + Types.TupleType (cl_spec' :: cl_specs) + | _, _ -> Types.TupleType [cl_spec'; cl_spec] in + let var = evaluate cpnt_type.Types.variability + and cl_spec = evaluate cpnt_type.Types.base_class in + let elt_type' = evaluate elt_type in + match elt_type'.Types.element_nature with + | Types.ComponentElement cpnt_type' -> + let var' = evaluate cpnt_type'.Types.variability + and cl_spec' = evaluate cpnt_type'.Types.base_class in + { + Types.flow = lazy false; + Types.variability = lazy (Types.max_variability var var'); + Types.causality = lazy Types.Acausal; + Types.base_class = lazy (add_class_specifier cl_spec cl_spec') + } + | Types.ClassElement _ | Types.ComponentTypeElement _ | + Types.PredefinedTypeElement _ -> + raise (CompilError + {err_msg = ["_ClassElemFoundInExpr"]; + err_info = []; + err_ctx = ctx}) (*error*) in + let cpnt_type = + { + Types.flow = lazy false; + Types.variability = lazy Types.Constant; + Types.causality = lazy Types.Acausal; + Types.base_class = lazy (Types.TupleType []) + } in + List.fold_left component_type_of_output_type cpnt_type output_types in + let args' = sorted_arguments_of_named_arguments input_types + and cpnt_type = component_type_of_output_types output_types in + let func_invoc = wrap_function_invocation cpnt_type in + let nat = FunctionCall (expr', args', func_invoc) + and elt_nat = func_invoc.info.type_description in + resolved_expression syn nat elt_nat in + let resolve_function_arguments' fun_args = + match fun_args.Syntax.nature with + | Syntax.Reduction _ -> + raise (CompilError + {err_msg = ["_NotYetImplemented"; "_FuncArgumentReduction"]; + err_info = []; + err_ctx = ctx}) + | Syntax.ArgumentList args -> + let input_types, output_types, named_args = + resolve_function_argument_list ctx expr' named_elts args in + let ids, rev_dims = + reversed_additional_dimensions input_types named_args in + function_call ids rev_dims input_types output_types named_args in + match fun_args with + | None -> + let fun_args = { Syntax.nature = Syntax.ArgumentList []; + Syntax.info = ctx.location } in + resolve_function_arguments' fun_args + | Some fun_args -> resolve_function_arguments' fun_args in + let resolve_class_function_call cl_type = + match evaluate cl_type.Types.kind with + | Types.Function -> + resolve_function_arguments cl_type.Types.named_elements + | Types.Class | Types.Model | Types.Block | Types.Record | + Types.ExpandableConnector | Types.Connector | Types.Package -> + raise (CompilError + {err_msg = ["function"; "_ElemExpected"]; + err_info = []; + err_ctx = ctx}) (*error*) in + let resolve_function_call' cl_spec = + match evaluate cl_spec with + | Types.ClassType cl_type -> + resolve_class_function_call cl_type + | _ -> + raise (CompilError + {err_msg = ["function"; "_ElemExpected"]; + err_info = []; + err_ctx = ctx}) (*error*) in + match expr'.info.type_description with + | Types.ClassElement cl_spec -> resolve_function_call' cl_spec + | Types.ComponentElement cpnt_type -> + let cl_spec = cpnt_type.Types.base_class in + resolve_function_call' cl_spec + | Types.ComponentTypeElement _ | Types.PredefinedTypeElement _ -> + raise (CompilError + {err_msg = ["function"; "_ElemExpected"]; + err_info = []; + err_ctx = ctx}) (*error*) + +and resolve_function_argument_list ctx expr' named_elts args = + let rec class_kind ctx = + let class_context' cl_spec = match cl_spec with + | Types.ClassType cl_type -> + Some (evaluate cl_type.Types.kind) + | _ -> None in + match ctx.context_nature with + | ClassContext cl_def -> + class_context' (evaluate cl_def.class_type) + | SubscriptContext (ctx, _, _, _) | ForContext (ctx, _, _) -> + class_kind ctx + | _ -> None in + let add_function_inout_argument ((id, elt_type) as named_elt) inouts = + let add_function_inout_argument' cpnt_type = + match inouts, evaluate cpnt_type.Types.causality with + | (ins, outs), Types.Input -> named_elt :: ins, outs + | (ins, outs), Types.Output -> ins, named_elt :: outs + | _, Types.Acausal -> inouts in + let elt_type' = evaluate elt_type in + match elt_type'.Types.element_nature with + | Types.ComponentElement cpnt_type when not elt_type'.Types.protected -> + add_function_inout_argument' cpnt_type + | _ -> inouts in + let add_argument id arg arg' elt_type acc = + let matchable_types cpnt_type cpnt_type' = + let cl_spec = evaluate cpnt_type.Types.base_class + and cl_spec' = evaluate cpnt_type'.Types.base_class in + let rec matchable_types' cl_spec cl_spec' = match cl_spec, cl_spec' with + | Types.ArrayType (dim, cl_spec), _ -> + matchable_types' cl_spec cl_spec' + | _, Types.ArrayType (dim', cl_spec') -> + matchable_types' cl_spec cl_spec' + | _, _ -> + let type_compare = Types.compare_specifiers cl_spec cl_spec' in + (type_compare = Types.SameType) || + (type_compare = Types.Supertype) in + matchable_types' cl_spec cl_spec' in + let matchable_variabilities cpnt_type cpnt_type' = + let var = evaluate cpnt_type.Types.variability + and var' = evaluate cpnt_type'.Types.variability in + Types.higher_variability var var' in + let elt_type = evaluate elt_type in + let cpnt_type = match elt_type.Types.element_nature with + | Types.ComponentElement cpnt_type -> cpnt_type + | _ -> assert false in + let arg' = apply_rhs_coercions cpnt_type arg' in + match arg'.info.type_description with + | Types.ComponentElement cpnt_type' + when not (matchable_types cpnt_type cpnt_type') -> + raise (CompilError + {err_msg = ["_ArgTypeMismatch"]; + err_info = + [("_ExpectedType", Types.string_of_component_type cpnt_type); + ("_TypeFound", Types.string_of_component_type cpnt_type')]; + err_ctx = {ctx with location = arg.Syntax.info}}) (*error*) + | Types.ComponentElement cpnt_type' + when not (matchable_variabilities cpnt_type cpnt_type') -> + let var = evaluate cpnt_type.Types.variability + and var' = evaluate cpnt_type'.Types.variability in + let var = Types.string_of_variability var + and var' = Types.string_of_variability var' in + raise (CompilError + {err_msg = ["_ArgVariabilityMismatch"]; + err_info = [("_ExpectedVariability", var); + ("_VariabilityFound", var')]; + err_ctx = {ctx with location = arg.Syntax.info}}) (*error*) + | Types.ComponentElement cpnt_type' -> (id, arg') :: acc + | _ -> raise (CompilError + {err_msg = ["_ClassElemFoundInExpr"]; + err_info = []; + err_ctx = {ctx with location = arg.Syntax.info}}) (*error*) in + let named_arguments_of_arguments input_types args = + let rec add_positional_arguments acc input_types args = + match input_types, args with + | [], [] -> acc + | [], _ -> + raise (CompilError + {err_msg = ["_TooManyArgsInFuncCall"]; + err_info = []; + err_ctx = ctx}) (*error*) + | _, [] -> + raise (CompilError + {err_msg = ["_TooFewArgsInFuncCall"]; + err_info = []; + err_ctx = ctx}) (*error*) + | (id, elt_type) :: input_types, + { Syntax.nature = Syntax.Argument arg } :: args -> + let arg' = resolve_expression ctx arg in + let acc = add_argument id arg arg' elt_type acc in + add_positional_arguments acc input_types args + | _, { Syntax.nature = Syntax.NamedArgument _ } :: _ -> + add_named_arguments acc input_types args + and add_named_arguments acc input_types args = + match input_types, args with + | [], [] -> acc + | [], _ -> + raise (CompilError + {err_msg = ["_TooManyArgsInFuncCall"]; + err_info = []; + err_ctx = ctx}) (*error*) + | _, [] -> + raise (CompilError + {err_msg = ["_TooFewArgsInFuncCall"]; + err_info = []; + err_ctx = ctx}) (*error*) + | _, { Syntax.nature = Syntax.Argument _ } :: _ -> + raise (CompilError + {err_msg = ["_MixedPositAndNamedFuncArgPass"]; + err_info = []; + err_ctx = ctx}) (*error*) + | _, { Syntax.nature = Syntax.NamedArgument (id, _) } :: _ + when List.mem_assoc id acc -> + raise (CompilError + {err_msg = ["_FuncCallWithDuplicateArg"; id]; + err_info = []; + err_ctx = ctx}) (*error*) + | _, { Syntax.nature = Syntax.NamedArgument (id, _) } :: _ + when not (List.mem_assoc id input_types) -> + raise (CompilError + {err_msg = ["_NonInputFuncArgElem"; id]; + err_info = []; + err_ctx = ctx}) (*error*) + | _, { Syntax.nature = Syntax.NamedArgument (id, arg) } :: args -> + let arg' = resolve_expression ctx arg + and elt_type = List.assoc id input_types in + let acc = add_argument id arg arg' elt_type acc in + add_named_arguments acc input_types args in + add_positional_arguments [] input_types args in + let resolve_built_in_function_argument arg = match arg with + | { Syntax.nature = Syntax.Argument arg } -> + arg, (resolve_expression ctx arg) + | { Syntax.nature = Syntax.NamedArgument _; Syntax.info = info } -> + raise (CompilError + {err_msg = ["_CannotUseNamedArgWithBuiltInOper"]; + err_info = []; + err_ctx = {ctx with location = info}}) (*error*) in + let rec built_in_function_named_arguments acc input_types args' = + match input_types, args' with + | [], [] -> acc + | [], _ -> + raise (CompilError + {err_msg = ["_TooManyArgsInFuncCall"]; + err_info = []; + err_ctx = ctx}) (*error*) + | _, [] -> + raise (CompilError + {err_msg = ["_TooFewArgsInFuncCall"]; + err_info = []; + err_ctx = ctx}) (*error*) + | (id, elt_type) :: input_types, (arg, arg') :: args' -> + let acc = add_argument id arg arg' elt_type acc in + built_in_function_named_arguments acc input_types args' in + let built_in_function_inout_types ctx id (in_types, out_types) args' = + let argument_component_type (arg, arg') = + match arg'.info.type_description with + | Types.ComponentElement cpnt_type -> + cpnt_type + | _ -> raise (CompilError + {err_msg = ["_ClassElemFoundInExpr"]; + err_info = []; + err_ctx = {ctx with location = arg.Syntax.info}}) (*error*) in + let scalar_base_class_specifier (arg, arg') = + let rec scalar_base_class_specifier' cl_spec = match cl_spec with + | Types.ArrayType (dim, cl_spec) -> scalar_base_class_specifier' cl_spec + | _ -> cl_spec in + let cpnt_type = argument_component_type (arg, arg') in + let cl_spec = evaluate cpnt_type.Types.base_class in + scalar_base_class_specifier' cl_spec in + let argument_base_type bt (arg, arg') = + let cl_spec = scalar_base_class_specifier (arg, arg') in + match cl_spec with + | Types.PredefinedType predef when predef.Types.base_type = bt -> true + | _ -> false in + let argument_base_types bt args = + List.for_all (argument_base_type bt) args in + let argument_variability var (arg, arg') = + let cpnt_type = argument_component_type (arg, arg') in + let var' = evaluate cpnt_type.Types.variability in + var = var' in + let neg f = function x -> not (f x) in + let ndims arg' = + let cpnt_type = component_type_of_expression ctx arg' in + let rec ndims' cl_spec = + match cl_spec with + | Types.ArrayType (dim, cl_spec) -> ndims' cl_spec + 1 + | _ -> 0 in + ndims' (evaluate cpnt_type.Types.base_class) in + let numeric_base_type arg' = + let cl_spec = scalar_class_specifier ctx arg' in + (Types.compare_specifiers Types.integer_class_type cl_spec = + Types.SameType) || + (Types.compare_specifiers Types.real_class_type cl_spec = + Types.SameType) in + let rec argument_types i args = match args with + | [] -> [] + | (arg, arg') :: args -> + let cpnt_type = component_type_of_expression ctx arg' + and name = Printf.sprintf "@%d" i in + (name, cpnt_type) :: (argument_types (i + 1) args) in + let element_types input_types output_types = + let element_type inout (id, cpnt_type) = + (id, + lazy + { + Types.protected = false; + Types.final = true; + Types.replaceable = false; + Types.dynamic_scope = None; + Types.element_nature = + Types.ComponentElement + { cpnt_type with Types.causality = lazy inout } + }) in + (List.map (element_type Types.Input) input_types), + (List.map (element_type Types.Output) output_types) in + match id, args' with + | ("der" | "initial" | "terminal" | "sample" | "pre" | "edge" | "change" | + "reinit" | "delay"), _ when (class_kind ctx) = Some Types.Function -> + raise (CompilError + {err_msg = [id; "_OperCannotBeUsedWithinFuncDef"]; + err_info = []; + err_ctx = ctx}) (*error*) + | ("pre" | "edge" | "change"), [arg, arg'] | "reinit", [(arg, arg'); _] + when not (expression_of_variable arg) -> + raise (CompilError + {err_msg = [id; "_OperArgMustBeAVar"]; + err_info = []; + err_ctx = {ctx with location = arg.Syntax.info}}) (*error*) + | ("ceil" | "floor" | "integer" | "der"), [arg, arg'] | + "reinit", [(arg, arg'); _] | + "smooth", [_; (arg, arg')] + when not (argument_base_type Types.RealType (arg, arg')) -> + let cl_spec = scalar_base_class_specifier (arg, arg') in + raise (CompilError + {err_msg = ["_ArgTypeMismatch"]; + err_info = + [("_ExpectedType", "Real"); + ("_TypeFound", Types.string_of_class_specifier cl_spec)]; + err_ctx = {ctx with location = arg.Syntax.info}}) (*error*) + | "delay", _ + when not (List.for_all (argument_base_type Types.RealType) args') -> + let (arg, arg') = + List.find (neg (argument_base_type Types.RealType)) args' in + let cl_spec = scalar_base_class_specifier (arg, arg') in + raise (CompilError + {err_msg = ["_ArgTypeMismatch"]; + err_info = + [("_ExpectedType", "Real"); + ("_TypeFound", Types.string_of_class_specifier cl_spec)]; + err_ctx = {ctx with location = arg.Syntax.info}}) (*error*) + | "der", [arg, arg'] + when not (argument_variability Types.Continuous (arg, arg')) -> + let cpnt_type = argument_component_type (arg, arg') in + let var = evaluate cpnt_type.Types.variability in + let var = Types.string_of_variability var in + raise (CompilError + {err_msg = ["_ArgVariabilityMismatch"]; + err_info = [("_ExpectedVariability", "Continuous"); + ("_VariabilityFound", var)]; + err_ctx = {ctx with location = arg.Syntax.info}}) (*error*) + | "delay", _ when List.length args' = 3 -> + let input_types = + [("@1", Types.real_component_type Types.Continuous); + ("@2", Types.real_component_type Types.Continuous); + ("@3", Types.real_component_type Types.Parameter)] + and output_types = + ["@4", Types.real_component_type Types.Continuous] in + element_types input_types output_types + | "abs", [arg, arg'] + when argument_base_type Types.IntegerType (arg, arg') -> + let input_types = ["@1", Types.integer_component_type Types.Discrete] + and output_types = + ["@2", Types.integer_component_type Types.Discrete] in + element_types input_types output_types + | ("ones" | "zeros"), _ + when not (argument_base_types Types.IntegerType args') -> + let (arg, arg') = + List.find (neg (argument_base_type Types.IntegerType)) args' in + raise (CompilError + {err_msg = ["_ArgTypeMismatch"]; + err_info = []; + err_ctx = {ctx with location = arg.Syntax.info}}) (*error*) + | "fill", _ :: args' + when not (argument_base_types Types.IntegerType args') -> + let (arg, arg') = + List.find (neg (argument_base_type Types.IntegerType)) args' in + raise (CompilError + {err_msg = ["_ArgTypeMismatch"]; + err_info = []; + err_ctx = {ctx with location = arg.Syntax.info}}) (*error*) + | ("sum" | "product" | "max" | "min" | "scalar"), [arg, arg'] + when ndims arg' = 0 -> + raise (CompilError + {err_msg = ["_ArgTypeMismatch"]; + err_info = []; + err_ctx = {ctx with location = arg.Syntax.info}}) (*error*) + | "diagonal", [arg, arg'] + when ndims arg' <> 1 -> + raise (CompilError + {err_msg = ["_ArgTypeMismatch"]; + err_info = []; + err_ctx = {ctx with location = arg.Syntax.info}}) (*error*) + | ("scalar"), [arg, arg'] -> + let cpnt_type = component_type_of_expression ctx arg' in + let input_types = ["@1", cpnt_type] + and output_types = + ["@2", Types.scalar_component_type cpnt_type ] in + element_types input_types output_types + | ("sum" | "product" | "max" | "min" | "diagonal"), [arg, arg'] + when not (numeric_base_type arg') -> + raise (CompilError + {err_msg = ["_ArgTypeMismatch"]; + err_info = []; + err_ctx = {ctx with location = arg.Syntax.info}}) (*error*) + | ("sum" | "product" | "max" | "min"), [arg, arg'] -> + let cpnt_type = component_type_of_expression ctx arg' in + let input_types = ["@1", cpnt_type] + and output_types = + ["@2", Types.scalar_component_type cpnt_type ] in + element_types input_types output_types + | ("ones" | "zeros"), _ :: _ -> + let input_types = argument_types 1 args' + and output_types = + let n = List.length args' + and dims = + List.map (function _ -> Types.ParameterDimension) args' in + let cpnt_type = + { + Types.flow = lazy false; + variability = lazy Types.Parameter; + Types.causality = lazy Types.Acausal; + base_class = + lazy(Types.add_dimensions dims Types.integer_class_type) + } in + [ Printf.sprintf "@%d" (n + 1), cpnt_type ] in + element_types input_types output_types + | "fill", (arg, arg') :: (_ :: _ as args) -> + let input_types = argument_types 1 args' + and output_types = + let n = List.length args + and dims = + List.map (function _ -> Types.ParameterDimension) args in + let cpnt_type = component_type_of_expression ctx arg' in + let lcl_spec = lazy + (Types.add_dimensions + dims + (evaluate cpnt_type.Types.base_class)) in + [ + Printf.sprintf "@%d" (n + 1), + { cpnt_type with Types.base_class = lcl_spec } + ] in + element_types input_types output_types + | "diagonal", [ arg, arg' ] -> + let cpnt_type = component_type_of_expression ctx arg' in + let input_types = [ "@1", cpnt_type ] + and output_types = + let dims = [ Types.ParameterDimension ] in + let lcl_spec = lazy + (Types.add_dimensions + dims + (evaluate cpnt_type.Types.base_class)) in + [ "@2", { cpnt_type with Types.base_class = lcl_spec } ] in + element_types input_types output_types + | ("div" | "mod" | "rem" | "max" | "min"), _ + when List.for_all (argument_base_type Types.IntegerType) args' -> + let input_types = + [ + "@1", Types.integer_component_type Types.Discrete; + "@2", Types.integer_component_type Types.Discrete + ] + and output_types = + ["@3", Types.integer_component_type Types.Discrete] in + element_types input_types output_types + | ("pre" | "change"), [arg, arg'] -> + let cpnt_type = argument_component_type (arg, arg') in + let input_types = + ["@1", { cpnt_type with Types.variability = lazy Types.Continuous }] + and output_types = + ["@2", { cpnt_type with Types.variability = lazy Types.Discrete }] in + element_types input_types output_types + | _, _ -> in_types, out_types in + match expr'.nature with + | PredefinedIdentifier id -> + let args' = List.map resolve_built_in_function_argument args in + let input_types, output_types = + let inout_types = + List.fold_right add_function_inout_argument named_elts ([], []) in + built_in_function_inout_types ctx id inout_types args' in + let named_args = + built_in_function_named_arguments [] input_types args' in + input_types, output_types, named_args + | _ -> + let input_types, output_types = + List.fold_right add_function_inout_argument named_elts ([], []) in + let named_args = named_arguments_of_arguments input_types args in + input_types, output_types, named_args + +and resolve_identifier ctx expr id = + let rec resolve_predefined_identifier ctx expr id = match id with + | "Boolean" -> + let nat = PredefinedIdentifier "Boolean" + and elt_nat = Types.ClassElement (lazy (Types.boolean_class_type)) in + resolved_expression (Some expr) nat elt_nat + | "Integer" -> + let nat = PredefinedIdentifier "Integer" + and elt_nat = Types.ClassElement (lazy (Types.integer_class_type)) in + resolved_expression (Some expr) nat elt_nat + | "Real" -> + let nat = PredefinedIdentifier "Real" + and elt_nat = Types.ClassElement (lazy (Types.real_class_type)) in + resolved_expression (Some expr) nat elt_nat + | "String" -> + let nat = PredefinedIdentifier "String" + and elt_nat = Types.ClassElement (lazy (Types.string_class_type)) in + resolved_expression (Some expr) nat elt_nat + | "reinit" -> + let nat = PredefinedIdentifier "reinit" + and elt_nat = + let inputs = + ["@1", Types.real_component_type Types.Continuous; + "@2", Types.real_component_type Types.Continuous] + and outputs = [] in + Types.function_type inputs outputs in + resolved_expression (Some expr) nat elt_nat + | "time" -> + let nat = PredefinedIdentifier "time" + and elt_nat = Types.real_type Types.Continuous in + resolved_expression (Some expr) nat elt_nat + | "pre" | "change" -> + let nat = PredefinedIdentifier "pre" + and elt_nat = + let inputs = ["@1", Types.real_component_type Types.Continuous] + and outputs = ["@2", Types.real_component_type Types.Discrete] in + Types.function_type inputs outputs in + resolved_expression (Some expr) nat elt_nat + | "edge" -> + let nat = PredefinedIdentifier "edge" + and elt_nat = + let inputs = ["@1", Types.boolean_component_type Types.Discrete] + and outputs = ["@2", Types.boolean_component_type Types.Discrete] in + Types.function_type inputs outputs in + resolved_expression (Some expr) nat elt_nat + | "initial" -> + let nat = PredefinedIdentifier "initial" + and elt_nat = + let inputs = [] + and outputs = [] in + Types.function_type inputs outputs in + resolved_expression (Some expr) nat elt_nat + | "terminal" -> + let nat = PredefinedIdentifier "terminal" + and elt_nat = + let inputs = [] + and outputs = [] in + Types.function_type inputs outputs in + resolved_expression (Some expr) nat elt_nat + | "sample" -> + let nat = PredefinedIdentifier "sample" + and elt_nat = + let inputs = [("@1", Types.real_component_type Types.Parameter); + ("@2", Types.real_component_type Types.Parameter)] + and outputs = ["@3", Types.boolean_component_type Types.Parameter] in + Types.function_type inputs outputs in + resolved_expression (Some expr) nat elt_nat + | "delay" -> + let nat = PredefinedIdentifier "delay" + and elt_nat = + let inputs = [("@1", Types.real_component_type Types.Continuous); + ("@2", Types.real_component_type Types.Parameter)] + and outputs = ["@3", Types.real_component_type Types.Continuous] in + Types.function_type inputs outputs in + resolved_expression (Some expr) nat elt_nat + | "assert" -> + let nat = PredefinedIdentifier "assert" + and elt_nat = + let inputs = [("@1", Types.boolean_component_type Types.Discrete); + ("@2", Types.string_component_type Types.Discrete)] + and outputs = [] in + Types.function_type inputs outputs in + resolved_expression (Some expr) nat elt_nat + | "terminate" -> + let nat = PredefinedIdentifier "terminate" + and elt_nat = + let inputs = [("@1", Types.string_component_type Types.Discrete)] + and outputs = [] in + Types.function_type inputs outputs in + resolved_expression (Some expr) nat elt_nat + | "abs" | "cos" | "sin" | "tan" | "exp" | "log" | "sqrt" | + "asin" | "acos" | "atan" | "sinh" | "cosh" | "tanh" | "asinh" | + "acosh" | "atanh" | "log10" | "ceil" | "floor" | "der" -> + let nat = PredefinedIdentifier id + and elt_nat = + let inputs = ["@1", Types.real_component_type Types.Continuous] + and outputs = ["@2", Types.real_component_type Types.Continuous] in + Types.function_type inputs outputs in + resolved_expression (Some expr) nat elt_nat + | "sign" | "integer" | "ones" | "zeros" -> + let nat = PredefinedIdentifier id + and elt_nat = + let inputs = ["@1", Types.real_component_type Types.Continuous] + and outputs = ["@2", Types.integer_component_type Types.Discrete] in + Types.function_type inputs outputs in + resolved_expression (Some expr) nat elt_nat + | "max" | "min" | "div" | "mod" | "rem" | "fill" -> + let nat = PredefinedIdentifier id + and elt_nat = + let inputs = + [ + "@1", Types.real_component_type Types.Continuous; + "@2", Types.real_component_type Types.Continuous + ] + and outputs = ["@3", Types.real_component_type Types.Continuous] in + Types.function_type inputs outputs in + resolved_expression (Some expr) nat elt_nat + | "smooth" -> + let nat = PredefinedIdentifier id + and elt_nat = + let inputs = + [ + "@1", Types.integer_component_type Types.Discrete; + "@2", Types.real_component_type Types.Continuous + ] + and outputs = ["@3", Types.real_component_type Types.Continuous] in + Types.function_type inputs outputs in + resolved_expression (Some expr) nat elt_nat + | "identity" -> + let nat = PredefinedIdentifier id + and elt_nat = + let inputs = [ "@1", Types.integer_component_type Types.Parameter ] + and outputs = + let dims = + [Types.ParameterDimension; Types.ParameterDimension] in + [ + "@2", + Types.integer_array_component_type Types.Parameter dims + ] in + Types.function_type inputs outputs in + resolved_expression (Some expr) nat elt_nat + | "diagonal" -> + let nat = PredefinedIdentifier id + and elt_nat = + let inputs = + let dim = [ Types.ParameterDimension ] in + [ "@1", Types.integer_array_component_type Types.Parameter dim ] + and outputs = + let dims = + [Types.ParameterDimension; Types.ParameterDimension] in + [ + "@2", + Types.integer_array_component_type Types.Parameter dims + ] in + Types.function_type inputs outputs in + resolved_expression (Some expr) nat elt_nat + | "sum" | "product" | "scalar" -> + let nat = PredefinedIdentifier id + and elt_nat = + let inputs = + let dim = [ Types.DiscreteDimension ] in + [ "@1", Types.integer_array_component_type Types.Discrete dim ] + and outputs = ["@2", Types.integer_component_type Types.Discrete] in + Types.function_type inputs outputs in + resolved_expression (Some expr) nat elt_nat + | _ -> raise (CompilError + {err_msg = ["_UnknownIdentifier"; id]; + err_info = []; + err_ctx = ctx}) + and search_in_toplevel dic = + try + let elt_desc = List.assoc id (evaluate dic) in + let elt_type = evaluate elt_desc.element_type in + match elt_type.Types.dynamic_scope with + | None | Some Types.Inner -> + let nat = ToplevelIdentifier id in + resolved_expression (Some expr) nat elt_type.Types.element_nature + | Some Types.Outer | Some Types.InnerOuter -> + raise (CompilError + {err_msg = ["_NoInnerDeclForOuterElem"; id]; + err_info = []; + err_ctx = ctx}) (*error*) + with Not_found -> resolve_predefined_identifier ctx expr id + and search_in_class level cl_def = match evaluate cl_def.class_type with + | Types.ClassType cl_type -> search_in_class_type level cl_def cl_type + | Types.PredefinedType _ | Types.ComponentType _ | Types.ArrayType _ | + Types.TupleType _ -> + raise (CompilError + {err_msg = ["_NoInnerDeclForOuterElem"; id]; + err_info = []; + err_ctx = ctx}) (*error*) + and search_in_class_type level cl_def cl_type = + try + let elt_type = evaluate (List.assoc id cl_type.Types.named_elements) in + match elt_type.Types.dynamic_scope with + | None | Some Types.Inner -> + let nat = LocalIdentifier (level, id) in + resolved_expression (Some expr) nat elt_type.Types.element_nature + | Some Types.Outer | Some Types.InnerOuter -> + let nat = DynamicIdentifier (level, id) in + resolved_expression (Some expr) nat elt_type.Types.element_nature + with Not_found -> search_in_parent level cl_def + and search_in_parent level cl_def = match cl_def.enclosing_class with + | _ when cl_def.encapsulated -> search_in_toplevel ctx.toplevel + | Some cl_def -> search_in_class (level + 1) cl_def + | None -> search_in_toplevel ctx.toplevel + and search_in_for_loop_variables level ctx = match ctx.context_nature with + | ToplevelContext -> search_in_toplevel ctx.toplevel + | ClassContext cl_def -> search_in_class 0 cl_def + | SubscriptContext (ctx', _, _, _) -> + search_in_for_loop_variables level ctx' + | ForContext (_, id', elt_nat) when id' = id -> + let nat = LoopVariable level in + resolved_expression (Some expr) nat elt_nat + | ForContext (ctx', _, _) -> + search_in_for_loop_variables (level + 1) ctx' in + search_in_for_loop_variables 0 ctx + +(*and resolve_if ctx expr alts expr' = + let expres' = resolve_expression ctx expr' in + let elt_nat' = expres'.info.type_description in + let rec resolve_alternative (cond, expr) = + resolve_condition cond, + resolve_alternative_expression expr + and resolve_condition cond = + let ctx = {ctx with location = cond.Syntax.info} in + let cond' = resolve_expression ctx cond in + let condition cpnt_type = + let cl_spec = evaluate cpnt_type.Types.base_class in + match cl_spec with + | Types.PredefinedType { Types.base_type = Types.BooleanType } -> cond' + | Types.PredefinedType _ | Types.ClassType _ | Types.ComponentType _ | + Types.ArrayType _ | Types.TupleType _ -> + raise (CompilError + {err_msg = ["_NonBooleanIfCondExpr"]; + err_info = + [("_ExprKind", "...if A then..."); + ("_TypeOfA", Types.string_of_class_specifier cl_spec)]; + err_ctx = ctx}) (*error*) in + match cond'.info.type_description with + | Types.ComponentElement cpnt_type -> condition cpnt_type + | _ -> raise (CompilError + {err_msg = ["_ClassElemFoundInExpr"]; + err_info = []; + err_ctx = {ctx with location = cond.Syntax.info}}) (*error*) + and resolve_alternative_expression expr = + let ctx = {ctx with location = expr.Syntax.info} in + let expres = resolve_expression ctx expr in + let elt_nat = expres.info.type_description in + let display_error elt_nat elt_nat' = match elt_nat, elt_nat' with + | Types.ComponentElement cpnt_type, Types.ComponentElement cpnt_type' -> + raise (CompilError + {err_msg = ["_TypeConflictsInIfAlternExprs"]; + err_info = + [("_TypeOfThenBranche", + Types.string_of_component_type cpnt_type); + ("_TypeOfElseBranche", + Types.string_of_component_type cpnt_type')]; + err_ctx = ctx}) (*error*) + | Types.ComponentElement cpnt_type, _ -> + raise (CompilError + {err_msg = ["_ClassElemFoundInExpr"]; + err_info = + [("_TypeOfThenBranche", + Types.string_of_component_type cpnt_type); + ("_TypeOfElseBranche", "_ClassElement")]; + err_ctx = ctx}) (*error*) + | _, Types.ComponentElement cpnt_type' -> + raise (CompilError + {err_msg = ["_ClassElemFoundInExpr"]; + err_info = + [("_TypeOfThenBranche", "_ClassElement"); + ("_TypeOfElseBranche", + Types.string_of_component_type cpnt_type')]; + err_ctx = ctx}) (*error*) + | _, _ -> + raise (CompilError + {err_msg = ["_ClassElemFoundInExpr"]; + err_info = + [("_TypeOfThenBranche", "_ClassElement"); + ("_TypeOfElseBranche", "_ClassElement")]; + err_ctx = ctx}) (*error*) in + match Types.compare_element_natures elt_nat elt_nat' with + | Types.NotRelated -> display_error elt_nat elt_nat' + | _ -> expres in + let alts = List.map resolve_alternative alts in + let nat = If (alts, expres') in + resolved_expression (Some expr) nat elt_nat'*) + +and resolve_if ctx expr alts expr' = + let resolve_data_expression ctx expr = + let expr' = resolve_expression ctx expr in + match expr'.info.type_description with + | Types.ComponentElement cpnt_type -> expr' + | _ -> + raise (CompilError + {err_msg = ["_ClassElemFoundInExpr"]; + err_info = []; + err_ctx = {ctx with location = expr.Syntax.info}}) (*error*) in + let resolve_condition cond = + let ctx = {ctx with location = cond.Syntax.info} in + let cond' = resolve_data_expression ctx cond in + let condition cpnt_type = + match evaluate cpnt_type.Types.base_class with + | Types.PredefinedType { Types.base_type = Types.BooleanType } -> cond' + | cl_spec -> + raise (CompilError + {err_msg = ["_NonBooleanIfCondExpr"]; + err_info = + [("_ExprKind", "...if A then..."); + ("_TypeOfA", Types.string_of_class_specifier cl_spec)]; + err_ctx = ctx}) (*error*) in + match cond'.info.type_description with + | Types.ComponentElement cpnt_type -> condition cpnt_type + | _ -> + raise (CompilError + {err_msg = ["_DataElemExpected"]; + err_info = []; + err_ctx = ctx}) (*error*) in + let resolve_alternatives (alts, expr') (cond, expr) = + let ctx = {ctx with location = expr.Syntax.info} in + let cond' = resolve_condition cond + and expr = resolve_data_expression ctx expr in + let exprs = apply_binary_coercions [ expr'; expr] in + let expr' = List.nth exprs 0 + and expr = List.nth exprs 1 in + let elt_nat = expr.info.type_description + and elt_nat' = expr'.info.type_description in + match Types.compare_element_natures elt_nat elt_nat' with + | Types.SameType -> + (alts @ [cond', expr]), expr' + | _ -> + raise (CompilError + {err_msg = ["_TypeConflictsInIfAlternExprs"]; + err_info = + [("_TypeOfThenBranche", + Types.string_of_element_nature elt_nat); + ("_TypeOfElseBranche", + Types.string_of_element_nature elt_nat')]; + err_ctx = ctx}) (*error*) in + let expr' = resolve_data_expression ctx expr' in + let alts, expr' = List.fold_left resolve_alternatives ([], expr') alts in + let nat = If (alts, expr') in + resolved_expression (Some expr) nat expr'.info.type_description + +and resolve_indexed_access ctx expr expr' subs = + let expres' = resolve_expression ctx expr' in + let rec resolve_component_indexed_access cl_spec subs = + match cl_spec, subs with + | (Types.PredefinedType _ | Types.ClassType _ | Types.ComponentType _ | + Types.ArrayType _ | Types.TupleType _), [] -> cl_spec + | (Types.PredefinedType _ | Types.ClassType _ | Types.ComponentType _ | + Types.TupleType _), _ :: _ -> + raise (CompilError + {err_msg = ["_CannotSubscriptANonArrayTypeElem"]; + err_info = + [("_ExpectedType", "_ArrayType"); + ("_TypeFound", Types.string_of_class_specifier cl_spec)]; + err_ctx = ctx}) (*error*) + | Types.ArrayType (_, cl_spec'), sub :: subs' -> + let cl_spec' = resolve_component_indexed_access cl_spec' subs' in + subarray_access sub cl_spec' + and subarray_access sub cl_spec = + let subarray_access' = function + | Types.PredefinedType { Types.base_type = Types.IntegerType } -> cl_spec + | Types.ArrayType + (dim, Types.PredefinedType { Types.base_type = Types.IntegerType }) -> + Types.ArrayType (dim, cl_spec) + | Types.PredefinedType _ | Types.ClassType _ | Types.ComponentType _ | + Types.ArrayType _ | Types.TupleType _ -> assert false (*error*) in + match sub.info.type_description with + | Types.ComponentElement cpnt_type -> + let cl_spec' = evaluate cpnt_type.Types.base_class in + subarray_access' cl_spec' + | Types.ClassElement _ | Types.ComponentTypeElement _ | + Types.PredefinedTypeElement _ -> assert false (*error*) in + match expres'.info.type_description with + | Types.ComponentElement cpnt_type -> + let cl_spec = evaluate cpnt_type.Types.base_class in + let subs' = resolve_subscripts ctx expres' cl_spec subs in + let cpnt_type' = + { cpnt_type with + Types.base_class = + lazy (resolve_component_indexed_access cl_spec subs') + } in + let info = + { + syntax = Some expr; + type_description = Types.ComponentElement cpnt_type' + } in + { nature = IndexedAccess (expres', subs'); info = info } + | Types.ClassElement _ | Types.ComponentTypeElement _ | + Types.PredefinedTypeElement _ -> + raise (CompilError + {err_msg = ["_ClassElemFoundInExpr"]; + err_info = []; + err_ctx = ctx}) (*error*) + +and resolve_integer ctx expr s = + let nat = + try + Integer (Int32.of_string s) + with + | _ -> + raise (CompilError + {err_msg = ["_InvalidInteger"; s]; + err_info = []; + err_ctx = ctx}) in + resolved_expression (Some expr) nat (Types.integer_type Types.Constant) + +and resolve_matrix_construction ctx expr exprss = + raise (CompilError + {err_msg = ["_NotYetImplemented"; "_MatrixExpr"]; + err_info = []; + err_ctx = ctx}) + +and resolve_no_event ctx expr expr' = + let expr' = resolve_expression ctx expr' in + match expr'.info.type_description with + | Types.ComponentElement cpnt_type -> + let nat = NoEvent expr' + and flow = lazy (evaluate cpnt_type.Types.flow) + and var = lazy Types.Continuous + and inout = cpnt_type.Types.causality + and cl_spec = cpnt_type.Types.base_class in + let cpnt_type = + component_element flow var inout cl_spec in + let elt_nat = Types.ComponentElement cpnt_type in + resolved_expression (Some expr) nat elt_nat + | _ -> + raise (CompilError + {err_msg = ["_ClassElemFoundInExpr"]; + err_info = []; + err_ctx = ctx}) (*error*) + +and resolve_range ctx expr start step stop = + let integer_range var start' step' stop' = + let integer_range' = + match start'.nature, step'.nature, stop'.nature with + | _, _, _ when Types.higher_variability var Types.Discrete -> + let var = Types.string_of_variability var in + raise (CompilError + {err_msg = ["_InvalidVarOfRangeExpr"]; + err_info = [("_Expr", Syntax.string_of_range start step stop); + ("_ExpectedVariability", "parameter"); + ("_VariabilityFound", var)]; + err_ctx = ctx}) + | Integer i, Integer p, Integer j when p = Int32.zero -> + raise (CompilError + {err_msg = ["_RangeStepValueCannotBeNull"]; + err_info = [("_Expr", Syntax.string_of_range start step stop)]; + err_ctx = ctx}) + | Integer i, Integer p, Integer j -> + let dim = Int32.div (Int32.succ (Int32.sub j i)) p in + Types.integer_array_type var (Types.ConstantDimension dim) + | (Integer _ | DynamicIdentifier _ | LocalIdentifier _ | + LoopVariable _ | PredefinedIdentifier _ | ToplevelIdentifier _), + (Integer _ | DynamicIdentifier _ | LocalIdentifier _ | + LoopVariable _ | PredefinedIdentifier _ | ToplevelIdentifier _), + (Integer _ | DynamicIdentifier _ | LocalIdentifier _ | + LoopVariable _ | PredefinedIdentifier _ | ToplevelIdentifier _) -> + Types.integer_array_type var Types.ParameterDimension + | _, _, _ -> + raise (CompilError + {err_msg = ["_NotYetImplemented"; "_NonIntegerRangeExpr"]; + err_info = [("_Expr", Syntax.string_of_range start step stop)]; + err_ctx = ctx}) in + let nat = Range (start', step', stop') in + let elt_nat = integer_range' in + resolved_expression (Some expr) nat elt_nat in + let start' = resolve_expression ctx start + and step' = match step with + | None -> one + | Some expr -> resolve_expression ctx expr + and stop' = resolve_expression ctx stop in + let resolve_range' var start_cl_spec step_cl_spec stop_cl_spec = + match start_cl_spec, step_cl_spec, stop_cl_spec with + | Types.PredefinedType { Types.base_type = Types.IntegerType }, + Types.PredefinedType { Types.base_type = Types.IntegerType }, + Types.PredefinedType { Types.base_type = Types.IntegerType } -> + integer_range var start' step' stop' + (*| Types.PredefinedType { Types.base_type = Types.IntegerType }, + Types.PredefinedType { Types.base_type = Types.IntegerType }, + _ -> assert false*) + | _ -> raise (CompilError + {err_msg = ["_NotYetImplemented"; "_NonIntegerRangeExpr"]; + err_info = [("_Expr", Syntax.string_of_range start step stop)]; + err_ctx = ctx}) in + let start_elt_nat = start'.info.type_description + and step_elt_nat = step'.info.type_description + and stop_elt_nat = stop'.info.type_description in + match start_elt_nat, step_elt_nat, stop_elt_nat with + | Types.ComponentElement start_cpnt_type, + Types.ComponentElement step_cpnt_type, + Types.ComponentElement stop_cpnt_type -> + let start_cl_spec = evaluate start_cpnt_type.Types.base_class + and step_cl_spec = evaluate step_cpnt_type.Types.base_class + and stop_cl_spec = evaluate stop_cpnt_type.Types.base_class + and start_var = evaluate start_cpnt_type.Types.variability + and step_var = evaluate step_cpnt_type.Types.variability + and stop_var = evaluate stop_cpnt_type.Types.variability in + let var = + let var' = Types.max_variability step_var stop_var in + Types.max_variability start_var var' in + resolve_range' var start_cl_spec step_cl_spec stop_cl_spec + | _ -> raise (CompilError + {err_msg = ["_InvalidTypeInRangeExpr"]; + err_info = [("_Expr", Syntax.string_of_range start step stop)]; + err_ctx = ctx}) (*error*) + +and resolve_real ctx expr s = + let nat = Real (float_of_string s) in + resolved_expression (Some expr) nat (Types.real_type Types.Constant) + +and resolve_string ctx expr s = + resolved_expression (Some expr) (String s) (Types.string_type Types.Constant) + +and resolve_true ctx expr = + resolved_expression (Some expr) True (Types.boolean_type Types.Constant) + +and resolve_tuple ctx expr exprs = + let max_element_variability var expr expr' = + match expr'.info.type_description with + | Types.ComponentElement cpnt_type -> + let var' = evaluate cpnt_type.Types.variability in + Types.max_variability var var' + | Types.ClassElement _ | Types.ComponentTypeElement _ | + Types.PredefinedTypeElement _ -> + raise (CompilError + {err_msg = ["_ClassElemFoundInExpr"]; + err_info = []; + err_ctx = ctx}) (*error*) + and class_specifier expr expr' = + match expr'.info.type_description with + | Types.ComponentElement cpnt_type -> evaluate cpnt_type.Types.base_class + | Types.ClassElement _ | Types.ComponentTypeElement _ | + Types.PredefinedTypeElement _ -> + raise (CompilError + {err_msg = ["_ClassElemFoundInExpr"]; + err_info = []; + err_ctx = ctx}) (*error*) in + let exprs' = List.map (resolve_expression ctx) exprs in + let flow = lazy false + and var = + lazy (List.fold_left2 max_element_variability Types.Constant exprs exprs') + and inout = lazy Types.Acausal + and cl_spec = lazy (Types.TupleType (List.map2 class_specifier exprs exprs')) in + { + nature = Tuple exprs'; + info = + { + syntax = Some expr; + type_description = + Types.ComponentElement (component_element flow var inout cl_spec) + } + } + +and resolve_unuary_operation ctx expr kind arg = + let arg' = resolve_expression ctx arg in + match kind.Syntax.nature with + | Syntax.UnaryMinus -> resolve_unary_minus ctx expr arg' + | Syntax.Not -> resolve_not ctx expr arg' + | Syntax.UnaryPlus -> + raise (CompilError + {err_msg = ["_NotYetImplemented"; "_UnaryOperPLUS"]; + err_info = []; + err_ctx = ctx}) + +and resolve_vector ctx expr vec_elts = match vec_elts.Syntax.nature with + | Syntax.VectorReduction (expr', for_inds) -> + resolve_vector_reduction ctx expr expr' for_inds + | Syntax.VectorElements exprs -> resolve_vector_elements ctx expr exprs + +and resolve_vector_reduction ctx expr expr' for_inds = + let vector_reduction_type acc expr expr' = + let add_dimension elt_nat cl_spec = + let add_dimension' cl_spec' = match cl_spec' with + | Types.ArrayType (dim, _) -> Types.ArrayType (dim, cl_spec) + | Types.PredefinedType _ | Types.ClassType _ | + Types.ComponentType _ | Types.TupleType _ -> + raise (CompilError + {err_msg = ["_InvalidTypeInRangeExpr"]; + err_info = + [("_ExpectedType", "_ArrayType"); + ("_TypeFound", + Types.string_of_class_specifier cl_spec')]; + err_ctx = ctx}) (*error*) in + match elt_nat with + | Types.ComponentElement cpnt_type -> + let cl_spec' = evaluate cpnt_type.Types.base_class in + add_dimension' cl_spec' + | Types.ClassElement _ | Types.ComponentTypeElement _ | + Types.PredefinedTypeElement _ -> + raise (CompilError + {err_msg = ["_ClassElemFoundInExpr"]; + err_info = []; + err_ctx = ctx}) (*error*) in + let rec vector_reduction_type' acc cl_spec = match acc with + | [] -> cl_spec + | range :: acc -> + let elt_nat = range.info.type_description in + let cl_spec' = add_dimension elt_nat cl_spec in + vector_reduction_type' acc cl_spec' in + match expr'.info.type_description with + | Types.ComponentElement cpnt_type -> + let cl_spec = evaluate cpnt_type.Types.base_class in + let cpnt_type' = + { cpnt_type with + Types.base_class = lazy (vector_reduction_type' acc cl_spec) + } in + Types.ComponentElement cpnt_type' + | Types.ClassElement _ | Types.ComponentTypeElement _ | + Types.PredefinedTypeElement _ -> + raise (CompilError + {err_msg = ["_ClassElemFoundInExpr"]; + err_info = []; + err_ctx = ctx}) (*error*) + and range_element_type range range' = + let sub_dimension cl_spec = match cl_spec with + | Types.ArrayType (dim, cl_spec) -> cl_spec + | Types.PredefinedType _ | Types.ClassType _ | + Types.ComponentType _ | Types.TupleType _ -> + raise (CompilError + {err_msg = ["_InvalidTypeInRangeExpr"]; + err_info = + [("_ExpectedType", "_ArrayType"); + ("_TypeFound", Types.string_of_class_specifier cl_spec)]; + err_ctx = ctx}) (*error*) in + match range'.info.type_description with + | Types.ComponentElement cpnt_type -> + let cl_spec = evaluate cpnt_type.Types.base_class in + let cpnt_type' = + { cpnt_type with + Types.base_class = lazy (sub_dimension cl_spec) + } in + Types.ComponentElement cpnt_type' + | Types.ClassElement _ | Types.ComponentTypeElement _ | + Types.PredefinedTypeElement _ -> + raise (CompilError + {err_msg = ["_ClassElemFoundInExpr"]; + err_info = []; + err_ctx = ctx}) (*error*) in + let rec resolve_vector_reduction' acc ctx = function + | [] -> + let expres' = resolve_expression ctx expr' in + let nat = VectorReduction (List.rev acc, expres') + and elt_nat = vector_reduction_type acc expr' expres' in + resolved_expression (Some expr) nat elt_nat + | (_, None) :: _ -> + raise (CompilError + {err_msg = ["_NotYetImplemented"; "_ImplicitIterRange"]; + err_info = [("_Expr", Syntax.string_of_for_inds for_inds)]; + err_ctx = ctx}) + | (id, Some range) :: for_inds -> + let range' = resolve_expression ctx range in + let elt_nat = range_element_type range range' in + let ctx' = + { ctx with + context_nature = ForContext (ctx, id, elt_nat) + } in + resolve_vector_reduction' (range' :: acc) ctx' for_inds in + resolve_vector_reduction' [] ctx for_inds + +and resolve_vector_elements ctx expr exprs = + let max_variability var cpnt_type = + let var' = evaluate cpnt_type.Types.variability in + Types.max_variability var var' in + let type_of_elements cpnt_types = + let rec type_of_elements' cl_spec = function + | [] -> cl_spec + | cpnt_type :: cpnt_types -> + let cl_spec' = evaluate cpnt_type.Types.base_class in + type_of_elements' (update cl_spec cl_spec') cpnt_types + and update cl_spec cl_spec' = + match Types.compare_specifiers cl_spec cl_spec' with + | Types.SameType | Types.Supertype -> cl_spec + | Types.Subtype -> cl_spec' + | _ -> + raise (CompilError + {err_msg = ["_TypeConflictsInVectorExpr"]; + err_info = + [("_MismatchingTypes", + Types.string_of_class_specifier cl_spec ^ ", " ^ + Types.string_of_class_specifier cl_spec')]; + err_ctx = ctx}) in + match cpnt_types with + | [] -> assert false (*error*) + | cpnt_type :: cpnt_types -> + let cl_spec' = evaluate cpnt_type.Types.base_class in + type_of_elements' cl_spec' cpnt_types in + let exprs' = List.map (resolve_expression ctx) exprs in + let exprs' = apply_binary_coercions exprs' in + let cpnt_types = List.map (component_type_of_expression ctx) exprs' in + let var = lazy (List.fold_left max_variability Types.Constant cpnt_types) in + let cl_spec = type_of_elements cpnt_types in + let dim = Types.ConstantDimension (Int32.of_int (List.length exprs')) in + let cl_spec' = lazy (Types.ArrayType (dim, cl_spec)) in + let cpnt_type = + { + Types.flow = lazy false; + variability = var; + causality = lazy Types.Acausal; + base_class = cl_spec' + } in + let nat = Vector exprs' + and elt_nat = Types.ComponentElement cpnt_type in + resolved_expression (Some expr) nat elt_nat + +and resolve_and ctx expr arg arg' = + let resolve_and' cpnt_type cpnt_type' = + let rec and_type cl_spec cl_spec' = match cl_spec, cl_spec' with + | Types.PredefinedType { Types.base_type = Types.BooleanType }, + Types.PredefinedType { Types.base_type = Types.BooleanType } -> + Types.PredefinedType + { Types.base_type = Types.BooleanType; attributes = [] } + | Types.PredefinedType { Types.base_type = Types.BooleanType }, + (Types.PredefinedType _ | Types.ClassType _ | Types.ComponentType _ | + Types.ArrayType _ | Types.TupleType _) -> + raise (CompilError + {err_msg = ["and"; "_OperAppliedToNonBoolExpr"]; + err_info = + [("_ExpectedType", "Boolean"); + ("_TypeFound", Types.string_of_class_specifier cl_spec')]; + err_ctx = ctx}) (*error*) + | (Types.PredefinedType _ | Types.ClassType _ | Types.ComponentType _ | + Types.ArrayType _ | Types.TupleType _), + (Types.PredefinedType _ | Types.ClassType _ | Types.ComponentType _ | + Types.ArrayType _ | Types.TupleType _) -> + raise (CompilError + {err_msg = ["and"; "_OperAppliedToNonBoolExpr"]; + err_info = + [("_ExpectedType", "Boolean"); + ("_TypeFound", Types.string_of_class_specifier cl_spec)]; + err_ctx = ctx}) (*error*) in + let var = + lazy ( + let var = evaluate cpnt_type.Types.variability + and var' = evaluate cpnt_type'.Types.variability in + Types.max_variability var var') + and inout = Types.Acausal + and cl_spec = + lazy ( + let cl_spec = evaluate cpnt_type.Types.base_class + and cl_spec' = evaluate cpnt_type'.Types.base_class in + and_type cl_spec cl_spec') in + let nat = BinaryOperation (And, arg, arg') in + let elt_nat = + let cpnt_type = + component_element (lazy false) var (lazy inout) cl_spec in + Types.ComponentElement cpnt_type in + resolved_expression (Some expr) nat elt_nat in + match arg.info.type_description, arg'.info.type_description with + | Types.ComponentElement cpnt_type, Types.ComponentElement cpnt_type' -> + resolve_and' cpnt_type cpnt_type' + | Types.ComponentElement _, + (Types.ClassElement _ | Types.ComponentTypeElement _ | + Types.PredefinedTypeElement _) -> + raise (CompilError + {err_msg = ["_ClassElemFoundInExpr"]; + err_info = []; + err_ctx = ctx}) (*error*) + | (Types.ClassElement _ | Types.ComponentTypeElement _ | + Types.PredefinedTypeElement _), + (Types.ComponentElement _ | Types.ClassElement _ | + Types.ComponentTypeElement _ | Types.PredefinedTypeElement _) -> + raise (CompilError + {err_msg = ["_ClassElemFoundInExpr"]; + err_info = []; + err_ctx = ctx}) (*error*) + +and resolve_or ctx expr arg arg' = + let resolve_or' cpnt_type cpnt_type' = + let rec or_type cl_spec cl_spec' = match cl_spec, cl_spec' with + | Types.PredefinedType { Types.base_type = Types.BooleanType }, + Types.PredefinedType { Types.base_type = Types.BooleanType } -> + Types.PredefinedType + { Types.base_type = Types.BooleanType; attributes = [] } + | Types.PredefinedType { Types.base_type = Types.BooleanType }, + (Types.PredefinedType _ | Types.ClassType _ | Types.ComponentType _ | + Types.ArrayType _ | Types.TupleType _) -> + raise (CompilError + {err_msg = ["or"; "_OperAppliedToNonBoolExpr"]; + err_info = + [("_ExpectedType", "Boolean"); + ("_TypeFound", Types.string_of_class_specifier cl_spec')]; + err_ctx = ctx}) (*error*) + | (Types.PredefinedType _ | Types.ClassType _ | Types.ComponentType _ | + Types.ArrayType _ | Types.TupleType _), + (Types.PredefinedType _ | Types.ClassType _ | Types.ComponentType _ | + Types.ArrayType _ | Types.TupleType _) -> + raise (CompilError + {err_msg = ["or"; "_OperAppliedToNonBoolExpr"]; + err_info = + [("_ExpectedType", "Boolean"); + ("_TypeFound", Types.string_of_class_specifier cl_spec)]; + err_ctx = ctx}) (*error*) in + let var = + lazy (let var = evaluate cpnt_type.Types.variability + and var' = evaluate cpnt_type'.Types.variability in + Types.max_variability var var') + and inout = Types.Acausal + and cl_spec = + lazy (let cl_spec = evaluate cpnt_type.Types.base_class + and cl_spec' = evaluate cpnt_type'.Types.base_class in + or_type cl_spec cl_spec') in + let nat = BinaryOperation (Or, arg, arg') in + let elt_nat = + let cpnt_type = + component_element (lazy false) var (lazy inout) cl_spec in + Types.ComponentElement cpnt_type in + resolved_expression (Some expr) nat elt_nat in + match arg.info.type_description, arg'.info.type_description with + | Types.ComponentElement cpnt_type, Types.ComponentElement cpnt_type' -> + resolve_or' cpnt_type cpnt_type' + | (Types.ComponentElement _ | Types.ClassElement _ | + Types.ComponentTypeElement _ | Types.PredefinedTypeElement _), + (Types.ComponentElement _ | Types.ClassElement _ | + Types.ComponentTypeElement _ | Types.PredefinedTypeElement _) -> + raise (CompilError + {err_msg = ["_ClassElemFoundInExpr"]; + err_info = []; + err_ctx = ctx}) (*error*) + +and resolve_addition ctx expr arg arg' = + let resolve_addition' cpnt_type cpnt_type' = + let rec addition_type cl_spec cl_spec' = match cl_spec, cl_spec' with + | Types.ArrayType (Types.ConstantDimension n, _), + Types.ArrayType (Types.ConstantDimension n', _) when n <> n' -> + raise (CompilError + {err_msg = ["_ArrayDimMustAgreeToPerform"; "_Addition"]; + err_info = + [("_ExprKind", "A + B"); + ("_TypeOfA", Types.string_of_class_specifier cl_spec); + ("_TypeOfB", Types.string_of_class_specifier cl_spec')]; + err_ctx = ctx}) (*error*) + | Types.ArrayType (Types.ConstantDimension _, cl_spec), + Types.ArrayType (dim, cl_spec') | + Types.ArrayType (dim, cl_spec), + Types.ArrayType (Types.ConstantDimension _, cl_spec') -> + Types.ArrayType (dim, addition_type cl_spec cl_spec') + | Types.ArrayType (Types.ParameterDimension, cl_spec), + Types.ArrayType (dim, cl_spec') | + Types.ArrayType (dim, cl_spec), + Types.ArrayType (Types.ParameterDimension, cl_spec') -> + Types.ArrayType (dim, addition_type cl_spec cl_spec') + | Types.ArrayType (Types.DiscreteDimension, cl_spec), + Types.ArrayType (Types.DiscreteDimension, cl_spec') -> + Types.ArrayType + (Types.DiscreteDimension, addition_type cl_spec cl_spec') + | Types.PredefinedType { Types.base_type = Types.IntegerType }, + Types.PredefinedType { Types.base_type = Types.IntegerType } -> + Types.PredefinedType + { Types.base_type = Types.IntegerType; attributes = [] } + | Types.PredefinedType + { Types.base_type = Types.RealType | Types.IntegerType }, + Types.PredefinedType + { Types.base_type = Types.RealType | Types.IntegerType } -> + Types.PredefinedType + { Types.base_type = Types.RealType; attributes = [] } + | Types.PredefinedType _, Types.ArrayType _ + | Types.ArrayType _, Types.PredefinedType _ -> + raise (CompilError + {err_msg = ["+"; "_OperBetweenScalarAndArray"]; + err_info = + [("_ExprKind", "A + B"); + ("_TypeOfA", Types.string_of_class_specifier cl_spec); + ("_TypeOfB", Types.string_of_class_specifier cl_spec')]; + err_ctx = ctx}) (*error*) + | _, _ -> + raise (CompilError + {err_msg = ["+"; "_OperAppliedToNonNumericExpr"]; + err_info = + [("_ExprKind", "A + B"); + ("_TypeOfA", Types.string_of_class_specifier cl_spec); + ("_TypeOfB", Types.string_of_class_specifier cl_spec')]; + err_ctx = ctx}) (*error*) in + let var = + lazy (let var = evaluate cpnt_type.Types.variability + and var' = evaluate cpnt_type'.Types.variability in + Types.max_variability var var') + and inout = Types.Acausal + and cl_spec = + lazy (let cl_spec = evaluate cpnt_type.Types.base_class + and cl_spec' = evaluate cpnt_type'.Types.base_class in + addition_type cl_spec cl_spec') in + let nat = BinaryOperation (Plus, arg, arg') in + let elt_nat = + let cpnt_type = + component_element (lazy false) var (lazy inout) cl_spec in + Types.ComponentElement cpnt_type in + resolved_expression (Some expr) nat elt_nat in + match arg.info.type_description, arg'.info.type_description with + | Types.ComponentElement cpnt_type, Types.ComponentElement cpnt_type' -> + resolve_addition' cpnt_type cpnt_type' + | (Types.ComponentElement _ | Types.ClassElement _ | + Types.ComponentTypeElement _ | Types.PredefinedTypeElement _), + (Types.ComponentElement _ | Types.ClassElement _ | + Types.ComponentTypeElement _ | Types.PredefinedTypeElement _) -> + raise (CompilError + {err_msg = ["_ClassElemFoundInExpr"]; + err_info = []; + err_ctx = ctx}) (*error*) + +and resolve_comparison ctx expr kind arg arg' = + let resolve_comparison' cpnt_type cpnt_type' = + let rec comparison_type cl_spec cl_spec' = match cl_spec, cl_spec' with + | Types.PredefinedType + { Types.base_type = Types.IntegerType | Types.RealType }, + Types.PredefinedType + { Types.base_type = Types.IntegerType | Types.RealType } -> + Types.PredefinedType + { Types.base_type = Types.BooleanType; attributes = [] } + | (Types.PredefinedType _ | Types.ClassType _ | Types.ComponentType _ | + Types.ArrayType _ | Types.TupleType _), + (Types.PredefinedType _ | Types.ClassType _ | Types.ComponentType _ | + Types.ArrayType _ | Types.TupleType _) -> + raise (CompilError + {err_msg = ["_TypeInconsistWithComparOper"]; + err_info = + [("_ExprKind", "A" ^ (string_of_bin_oper_kind kind) ^ "B"); + ("_TypeOfA", Types.string_of_class_specifier cl_spec); + ("_TypeOfB", Types.string_of_class_specifier cl_spec')]; + err_ctx = ctx}) (*error*) in + (*let var = + let var = evaluate cpnt_type.Types.variability + and var' = evaluate cpnt_type'.Types.variability in + Types.max_variability var var'*) + let var = Types.Discrete + and inout = Types.Acausal + and cl_spec = + lazy (let cl_spec = evaluate cpnt_type.Types.base_class + and cl_spec' = evaluate cpnt_type'.Types.base_class in + comparison_type cl_spec cl_spec') in + let nat = BinaryOperation (kind, arg, arg') in + let elt_nat = + let cpnt_type = + component_element (lazy false) (lazy var) (lazy inout) cl_spec in + Types.ComponentElement cpnt_type in + resolved_expression (Some expr) nat elt_nat in + match arg.info.type_description, arg'.info.type_description with + | Types.ComponentElement cpnt_type, Types.ComponentElement cpnt_type' -> + resolve_comparison' cpnt_type cpnt_type' + | (Types.ComponentElement _ | Types.ClassElement _ | + Types.ComponentTypeElement _ | Types.PredefinedTypeElement _), + (Types.ComponentElement _ | Types.ClassElement _ | + Types.ComponentTypeElement _ | Types.PredefinedTypeElement _) -> + raise (CompilError + {err_msg = ["_ClassElemFoundInExpr"]; + err_info = []; + err_ctx = ctx}) (*error*) + +and resolve_division ctx expr arg arg' = + let resolve_division' cpnt_type cpnt_type' = + let rec division_type cl_spec cl_spec' = match cl_spec, cl_spec' with + | Types.ArrayType (dim, cl_spec), + Types.PredefinedType + { Types.base_type = Types.IntegerType | Types.RealType } -> + Types.ArrayType (dim, division_type cl_spec cl_spec') + | Types.PredefinedType + { Types.base_type = Types.RealType | Types.IntegerType }, + Types.PredefinedType + { Types.base_type = Types.RealType | Types.IntegerType } -> + Types.PredefinedType + { Types.base_type = Types.RealType; attributes = [] } + | (Types.PredefinedType _ | Types.ClassType _ | Types.ComponentType _ | + Types.ArrayType _ | Types.TupleType _), + (Types.PredefinedType _ | Types.ClassType _ | Types.ComponentType _ | + Types.ArrayType _ | Types.TupleType _) -> + raise (CompilError + {err_msg = ["_TypeInconsistentWithDivOper"]; + err_info = + [("_ExprKind", "A / B"); + ("_TypeOfA", Types.string_of_class_specifier cl_spec); + ("_TypeOfB", Types.string_of_class_specifier cl_spec')]; + err_ctx = ctx}) (*error*) in + let var = + lazy (let var = evaluate cpnt_type.Types.variability + and var' = evaluate cpnt_type'.Types.variability in + Types.max_variability var var') + and inout = Types.Acausal + and cl_spec = + lazy (let cl_spec = evaluate cpnt_type.Types.base_class + and cl_spec' = evaluate cpnt_type'.Types.base_class in + division_type cl_spec cl_spec') in + let nat = BinaryOperation (Divide, arg, arg') in + let elt_nat = + let cpnt_type = + component_element (lazy false) var (lazy inout) cl_spec in + Types.ComponentElement cpnt_type in + resolved_expression (Some expr) nat elt_nat in + match arg.info.type_description, arg'.info.type_description with + | Types.ComponentElement cpnt_type, Types.ComponentElement cpnt_type' -> + resolve_division' cpnt_type cpnt_type' + | (Types.ComponentElement _ | Types.ClassElement _ | + Types.ComponentTypeElement _ | Types.PredefinedTypeElement _), + (Types.ComponentElement _ | Types.ClassElement _ | + Types.ComponentTypeElement _ | Types.PredefinedTypeElement _) -> + raise (CompilError + {err_msg = ["_ClassElemFoundInExpr"]; + err_info = []; + err_ctx = ctx}) (*error*) + +and resolve_multiplication ctx expr arg arg' = + let resolve_multiplication' cpnt_type cpnt_type' = + let rec multiplication_type cl_spec cl_spec' = match cl_spec, cl_spec' with + | Types.ArrayType (_, Types.ArrayType (Types.ConstantDimension n, _)), + Types.ArrayType (Types.ConstantDimension n', Types.ArrayType _) + when n <> n' -> + raise (CompilError + {err_msg = ["_ArrayDimsNonCompatibleWithMult"]; + err_info = + [("_ExprKind", "A * B"); + ("_TypeOfA", Types.string_of_component_type cpnt_type); + ("_TypeOfB", Types.string_of_component_type cpnt_type')]; + err_ctx = ctx}) (*error*) + | Types.ArrayType + (dim, Types.ArrayType + (_, Types.PredefinedType + { Types.base_type = Types.IntegerType })), + Types.ArrayType + (_, Types.ArrayType + (dim', Types.PredefinedType + { Types.base_type = Types.IntegerType })) -> + Types.ArrayType + (dim, Types.ArrayType + (dim', Types.PredefinedType + { Types.base_type = Types.IntegerType; attributes = [] })) + | Types.ArrayType + (dim, Types.ArrayType + (_, Types.PredefinedType + { Types.base_type = Types.IntegerType | Types.RealType })), + Types.ArrayType + (_, Types.ArrayType + (dim', Types.PredefinedType + { Types.base_type = Types.IntegerType | Types.RealType })) -> + Types.ArrayType + (dim, Types.ArrayType + (dim', Types.PredefinedType + { Types.base_type = Types.RealType; attributes = [] })) + | Types.ArrayType (_, Types.ArrayType (Types.ConstantDimension n, _)), + Types.ArrayType (Types.ConstantDimension n', _) + when n <> n' -> + raise (CompilError + {err_msg = ["_ArrayDimsNonCompatibleWithMult"]; + err_info = + [("_ExprKind", "A * B"); + ("_TypeOfA", Types.string_of_class_specifier cl_spec); + ("_TypeOfB", Types.string_of_class_specifier cl_spec')]; + err_ctx = ctx}) (*error*) + | Types.ArrayType + (dim, Types.ArrayType + (_, Types.PredefinedType + { Types.base_type = Types.IntegerType })), + Types.ArrayType + (_, Types.PredefinedType + { Types.base_type = Types.IntegerType }) -> + Types.ArrayType + (dim, Types.PredefinedType + { Types.base_type = Types.IntegerType; attributes = [] }) + | Types.ArrayType + (dim, Types.ArrayType + (_, Types.PredefinedType + { Types.base_type = Types.IntegerType | Types.RealType })), + Types.ArrayType + (_, Types.PredefinedType + { Types.base_type = Types.IntegerType | Types.RealType }) -> + Types.ArrayType + (dim, Types.PredefinedType + { Types.base_type = Types.RealType; attributes = [] }) + | Types.ArrayType (Types.ConstantDimension n, _), + Types.ArrayType (Types.ConstantDimension n', Types.ArrayType _) + when n <> n' -> + raise (CompilError + {err_msg = ["_ArrayDimsNonCompatibleWithMult"]; + err_info = + [("_ExprKind", "A * B"); + ("_TypeOfA", Types.string_of_class_specifier cl_spec); + ("_TypeOfB", Types.string_of_class_specifier cl_spec')]; + err_ctx = ctx}) (*error*) + | Types.ArrayType + (_, Types.PredefinedType + { Types.base_type = Types.IntegerType }), + Types.ArrayType + (_, Types.ArrayType + (dim, Types.PredefinedType + { Types.base_type = Types.IntegerType })) -> + Types.ArrayType + (dim, Types.PredefinedType + { Types.base_type = Types.IntegerType; attributes = [] }) + | Types.ArrayType + (_, Types.PredefinedType + { Types.base_type = Types.IntegerType | Types.RealType }), + Types.ArrayType + (_, Types.ArrayType + (dim, Types.PredefinedType + { Types.base_type = Types.IntegerType | Types.RealType })) -> + Types.ArrayType + (dim, Types.PredefinedType + { Types.base_type = Types.RealType; attributes = [] }) + | Types.ArrayType (Types.ConstantDimension n, _), + Types.ArrayType (Types.ConstantDimension n', _) + when n <> n' -> + raise (CompilError + {err_msg = ["_ArrayDimsNonCompatibleWithMult"]; + err_info = + [("_ExprKind", "A * B"); + ("_TypeOfA", Types.string_of_class_specifier cl_spec); + ("_TypeOfB", Types.string_of_class_specifier cl_spec')]; + err_ctx = ctx}) (*error*) + | Types.ArrayType + (_, Types.PredefinedType + { Types.base_type = Types.IntegerType }), + Types.ArrayType + (_, Types.PredefinedType + { Types.base_type = Types.IntegerType }) -> + Types.PredefinedType + { Types.base_type = Types.IntegerType; attributes = [] } + | Types.ArrayType + (_, Types.PredefinedType + { Types.base_type = Types.IntegerType | Types.RealType }), + Types.ArrayType + (_, Types.PredefinedType + { Types.base_type = Types.IntegerType | Types.RealType }) -> + Types.PredefinedType + { Types.base_type = Types.RealType; attributes = [] } + | Types.PredefinedType + { Types.base_type = Types.IntegerType | Types.RealType }, + Types.ArrayType (dim, cl_spec') -> + Types.ArrayType (dim, multiplication_type cl_spec cl_spec') + | Types.ArrayType (dim, cl_spec), + Types.PredefinedType + { Types.base_type = Types.IntegerType | Types.RealType } -> + Types.ArrayType (dim, multiplication_type cl_spec cl_spec') + | Types.PredefinedType { Types.base_type = Types.IntegerType }, + Types.PredefinedType { Types.base_type = Types.IntegerType } -> + Types.PredefinedType + { Types.base_type = Types.IntegerType; attributes = [] } + | Types.PredefinedType + { Types.base_type = Types.RealType | Types.IntegerType }, + Types.PredefinedType + { Types.base_type = Types.RealType | Types.IntegerType } -> + Types.PredefinedType + { Types.base_type = Types.RealType; attributes = [] } + | (Types.PredefinedType _ | Types.ClassType _ | Types.ComponentType _ | + Types.ArrayType _ | Types.TupleType _), + (Types.PredefinedType _ | Types.ClassType _ | Types.ComponentType _ | + Types.ArrayType _ | Types.TupleType _) -> + raise (CompilError + {err_msg = ["*"; "_OperAppliedToNonNumericExpr"]; + err_info = + [("_ExprKind", "A * B"); + ("_TypeOfA", Types.string_of_class_specifier cl_spec); + ("_TypeOfB", Types.string_of_class_specifier cl_spec')]; + err_ctx = ctx}) (*error*) in + let var = + lazy (let var = evaluate cpnt_type.Types.variability + and var' = evaluate cpnt_type'.Types.variability in + Types.max_variability var var') + and inout = Types.Acausal + and cl_spec = + lazy (let cl_spec = evaluate cpnt_type.Types.base_class + and cl_spec' = evaluate cpnt_type'.Types.base_class in + multiplication_type cl_spec cl_spec') in + let nat = BinaryOperation (Times, arg, arg') in + let elt_nat = + let cpnt_type = + component_element (lazy false) var (lazy inout) cl_spec in + Types.ComponentElement cpnt_type in + resolved_expression (Some expr) nat elt_nat in + match arg.info.type_description, arg'.info.type_description with + | Types.ComponentElement cpnt_type, Types.ComponentElement cpnt_type' -> + resolve_multiplication' cpnt_type cpnt_type' + | (Types.ComponentElement _ | Types.ClassElement _ | + Types.ComponentTypeElement _ | Types.PredefinedTypeElement _), + (Types.ComponentElement _ | Types.ClassElement _ | + Types.ComponentTypeElement _ | Types.PredefinedTypeElement _) -> + raise (CompilError + {err_msg = ["_ClassElemFoundInExpr"]; + err_info = []; + err_ctx = ctx}) (*error*) + +and resolve_power ctx expr arg arg' = + let resolve_power' cpnt_type cpnt_type' = + let rec power_type cl_spec cl_spec' = match cl_spec, cl_spec' with + | Types.ArrayType + (Types.ConstantDimension n, Types.ArrayType + (Types.ConstantDimension n', _)), + Types.PredefinedType { Types.base_type = Types.IntegerType } + when n <> n' -> + raise (CompilError + {err_msg = ["_PowerOperOnNonSquareArray"]; + err_info = + [("_ExprKind", "A ^ B"); + ("_TypeOfA", Types.string_of_class_specifier cl_spec); + ("_TypeOfB", Types.string_of_class_specifier cl_spec')]; + err_ctx = ctx}) (*error*) + | Types.ArrayType + (dim, Types.ArrayType + (dim', Types.PredefinedType + { Types.base_type = Types.IntegerType })), + Types.PredefinedType { Types.base_type = Types.IntegerType } -> + Types.ArrayType + (dim, Types.ArrayType + (dim', Types.PredefinedType + { Types.base_type = Types.RealType; attributes = [] })) + | Types.ArrayType + (dim, Types.ArrayType + (dim', Types.PredefinedType { Types.base_type = Types.RealType })), + Types.PredefinedType { Types.base_type = Types.IntegerType } -> + Types.ArrayType + (dim, Types.ArrayType + (dim', Types.PredefinedType + { Types.base_type = Types.RealType; attributes = [] })) + | Types.PredefinedType { Types.base_type = Types.IntegerType }, + Types.PredefinedType { Types.base_type = Types.IntegerType } -> + Types.PredefinedType + { Types.base_type = Types.RealType; attributes = [] } + | Types.PredefinedType + { Types.base_type = Types.RealType | Types.IntegerType }, + Types.PredefinedType + { Types.base_type = Types.RealType | Types.IntegerType } -> + Types.PredefinedType + { Types.base_type = Types.RealType; attributes = [] } + | (Types.PredefinedType _ | Types.ClassType _ | Types.ComponentType _ | + Types.ArrayType _ | Types.TupleType _), + (Types.PredefinedType _ | Types.ClassType _ | Types.ComponentType _ | + Types.ArrayType _ | Types.TupleType _) -> + raise (CompilError + {err_msg = ["^"; "_OperAppliedToNonNumericExpr"]; + err_info = + [("_ExprKind", "A ^ B"); + ("_TypeOfA", Types.string_of_class_specifier cl_spec); + ("_TypeOfB", Types.string_of_class_specifier cl_spec')]; + err_ctx = ctx}) (*error*) in + let var = + lazy (let var = evaluate cpnt_type.Types.variability + and var' = evaluate cpnt_type'.Types.variability in + Types.max_variability var var') + and inout = Types.Acausal + and cl_spec = + lazy (let cl_spec = evaluate cpnt_type.Types.base_class + and cl_spec' = evaluate cpnt_type'.Types.base_class in + power_type cl_spec cl_spec') in + let nat = BinaryOperation (Power, arg, arg') in + let elt_nat = + let cpnt_type = + component_element (lazy false) var (lazy inout) cl_spec in + Types.ComponentElement cpnt_type in + resolved_expression (Some expr) nat elt_nat in + match arg.info.type_description, arg'.info.type_description with + | Types.ComponentElement cpnt_type, Types.ComponentElement cpnt_type' -> + resolve_power' cpnt_type cpnt_type' + | (Types.ComponentElement _ | Types.ClassElement _ | + Types.ComponentTypeElement _ | Types.PredefinedTypeElement _), + (Types.ComponentElement _ | Types.ClassElement _ | + Types.ComponentTypeElement _ | Types.PredefinedTypeElement _) -> + raise (CompilError + {err_msg = ["_ClassElemFoundInExpr"]; + err_info = []; + err_ctx = ctx}) (*error*) + +and resolve_subtraction ctx expr arg arg' = + let resolve_subtraction' cpnt_type cpnt_type' = + let rec subtraction_type cl_spec cl_spec' = match cl_spec, cl_spec' with + | Types.ArrayType (Types.ConstantDimension n, _), + Types.ArrayType (Types.ConstantDimension n', _) when n <> n' -> + raise (CompilError + {err_msg = ["_ArrayDimMustAgreeToPerform"; "_Subtraction"]; + err_info = + [("_ExprKind", "A - B"); + ("_TypeOfA", Types.string_of_class_specifier cl_spec); + ("_TypeOfB", Types.string_of_class_specifier cl_spec')]; + err_ctx = ctx}) (*error*) + | Types.ArrayType (Types.ConstantDimension _, cl_spec), + Types.ArrayType (dim, cl_spec') | + Types.ArrayType (dim, cl_spec), + Types.ArrayType (Types.ConstantDimension _, cl_spec') -> + Types.ArrayType (dim, subtraction_type cl_spec cl_spec') + | Types.ArrayType (Types.ParameterDimension, cl_spec), + Types.ArrayType (dim, cl_spec') | + Types.ArrayType (dim, cl_spec), + Types.ArrayType (Types.ParameterDimension, cl_spec') -> + Types.ArrayType (dim, subtraction_type cl_spec cl_spec') + | Types.ArrayType (Types.DiscreteDimension, cl_spec), + Types.ArrayType (Types.DiscreteDimension, cl_spec') -> + Types.ArrayType + (Types.DiscreteDimension, subtraction_type cl_spec cl_spec') + | Types.PredefinedType { Types.base_type = Types.IntegerType }, + Types.PredefinedType { Types.base_type = Types.IntegerType } -> + Types.PredefinedType + { Types.base_type = Types.IntegerType; attributes = [] } + | Types.PredefinedType + { Types.base_type = Types.RealType | Types.IntegerType }, + Types.PredefinedType + { Types.base_type = Types.RealType | Types.IntegerType } -> + Types.PredefinedType + { Types.base_type = Types.RealType; attributes = [] } + | (Types.PredefinedType _ | Types.ClassType _ | Types.ComponentType _ | + Types.ArrayType _ | Types.TupleType _), + (Types.PredefinedType _ | Types.ClassType _ | Types.ComponentType _ | + Types.ArrayType _ | Types.TupleType _) -> + raise (CompilError + {err_msg = ["-"; "_OperAppliedToNonNumericExpr"]; + err_info = + [("_ExprKind", "A - B"); + ("_TypeOfA", Types.string_of_class_specifier cl_spec); + ("_TypeOfB", Types.string_of_class_specifier cl_spec')]; + err_ctx = ctx}) (*error*) in + let var = + lazy (let var = evaluate cpnt_type.Types.variability + and var' = evaluate cpnt_type'.Types.variability in + Types.max_variability var var') + and inout = Types.Acausal + and cl_spec = + lazy (let cl_spec = evaluate cpnt_type.Types.base_class + and cl_spec' = evaluate cpnt_type'.Types.base_class in + subtraction_type cl_spec cl_spec') in + let nat = BinaryOperation (Minus, arg, arg') in + let elt_nat = + let cpnt_type = + component_element (lazy false) var (lazy inout) cl_spec in + Types.ComponentElement cpnt_type in + resolved_expression (Some expr) nat elt_nat in + match arg.info.type_description, arg'.info.type_description with + | Types.ComponentElement cpnt_type, Types.ComponentElement cpnt_type' -> + resolve_subtraction' cpnt_type cpnt_type' + | (Types.ComponentElement _ | Types.ClassElement _ | + Types.ComponentTypeElement _ | Types.PredefinedTypeElement _), + (Types.ComponentElement _ | Types.ClassElement _ | + Types.ComponentTypeElement _ | Types.PredefinedTypeElement _) -> + raise (CompilError + {err_msg = ["_ClassElemFoundInExpr"]; + err_info = []; + err_ctx = ctx}) (*error*) + +and resolve_unary_minus ctx expr arg = + let resolve_unary_minus' cpnt_type = + let rec unary_minus_type cl_spec = match cl_spec with + | Types.ArrayType (dim, cl_spec) -> + Types.ArrayType (dim, unary_minus_type cl_spec) + | Types.PredefinedType + { Types.base_type = Types.RealType | Types.IntegerType } -> cl_spec + | (Types.PredefinedType _ | Types.ClassType _ | Types.ComponentType _ | + Types.TupleType _) -> + raise (CompilError + {err_msg = ["-"; "_OperAppliedToNonNumericExpr"]; + err_info = + [("_ExprKind", "- A"); + ("_TypeOfA", Types.string_of_class_specifier cl_spec)]; + err_ctx = ctx}) (*error*) in + let var = cpnt_type.Types.variability + and inout = Types.Acausal + and cl_spec = + lazy (let cl_spec = evaluate cpnt_type.Types.base_class in + unary_minus_type cl_spec) in + let nat = UnaryOperation (UnaryMinus, arg) in + let elt_nat = + let cpnt_type = + component_element (lazy false) var (lazy inout) cl_spec in + Types.ComponentElement cpnt_type in + resolved_expression (Some expr) nat elt_nat in + match arg.info.type_description with + | Types.ComponentElement cpnt_type -> resolve_unary_minus' cpnt_type + | Types.ClassElement _ | + Types.ComponentTypeElement _ | Types.PredefinedTypeElement _ -> + raise (CompilError + {err_msg = ["_ClassElemFoundInExpr"]; + err_info = []; + err_ctx = ctx}) (*error*) + +and resolve_not ctx expr arg = + let resolve_not' cpnt_type = + let rec not_type cl_spec = match cl_spec with + | Types.PredefinedType { Types.base_type = Types.BooleanType } -> cl_spec + | (Types.PredefinedType _ | Types.ArrayType _ | Types.ClassType _ | + Types.ComponentType _ | Types.TupleType _) -> + raise (CompilError + {err_msg = ["not"; "_OperAppliedToNonBoolExpr"]; + err_info = + [("_ExprKind", "not A"); + ("_TypeOfA", Types.string_of_class_specifier cl_spec)]; + err_ctx = ctx}) (*error*) in + let var = cpnt_type.Types.variability + and inout = Types.Acausal + and cl_spec = + lazy (let cl_spec = evaluate cpnt_type.Types.base_class in + not_type cl_spec) in + let nat = UnaryOperation (Not, arg) in + let elt_nat = + let cpnt_type = + component_element (lazy false) var (lazy inout) cl_spec in + Types.ComponentElement cpnt_type in + resolved_expression (Some expr) nat elt_nat in + match arg.info.type_description with + | Types.ComponentElement cpnt_type -> resolve_not' cpnt_type + | Types.ClassElement _ | + Types.ComponentTypeElement _ | Types.PredefinedTypeElement _ -> + raise (CompilError + {err_msg = ["_ClassElemFoundInExpr"]; + err_info = []; + err_ctx = ctx}) (*error*) + +and component_element flow var inout cl_spec = + { + Types.flow = flow; + variability = var; + causality = inout; + base_class = cl_spec + } + +and element_nature_class ctx = function + | Types.ClassElement cl_spec -> evaluate cl_spec + | Types.ComponentElement cpnt_type -> evaluate cpnt_type.Types.base_class + | Types.PredefinedTypeElement predef -> Types.PredefinedType predef + | Types.ComponentTypeElement _ -> assert false (*error*) + +and element_field_type_nature ctx flow var inout cl_spec id = + let add_dimension dim = function + | Types.ComponentElement cpnt_type -> + let cpnt_type' = + { cpnt_type with + Types.base_class = + lazy (Types.ArrayType (dim, evaluate cpnt_type.Types.base_class)) + } in + Types.ComponentElement cpnt_type' + | Types.ClassElement _ + | Types.ComponentTypeElement _ + | Types.PredefinedTypeElement _ -> + raise (CompilError + {err_msg = ["_InvalidClassElemModif"]; + err_info = []; + err_ctx = ctx}) (*error*) in + let find_predefined_local_identifier predef id = + match predef.Types.base_type with + | Types.BooleanType when id = "start" -> Types.boolean_type Types.Parameter + | Types.IntegerType when id = "start" -> + Types.integer_type Types.Parameter + | Types.RealType when id = "start" -> + Types.real_type Types.Parameter + | Types.StringType when id = "start" -> Types.string_type Types.Parameter + | Types.EnumerationType enum_lits when id = "start" -> + Types.enumeration_type Types.Parameter enum_lits + | _ when id = "fixed" -> Types.boolean_type Types.Constant + | Types.IntegerType when id = "nominal" -> + Types.integer_type Types.Constant + | Types.RealType when id = "nominal" -> + Types.real_type Types.Constant + | _ -> + raise (CompilError + {err_msg = ["_NotYetImplemented"; "_PredefinedTypeAttribModif"; id]; + err_info = []; + err_ctx = ctx}) + and find_class_local_identifier flow var inout cl_type id = + let apply_prefixes elt_nat = match elt_nat with + | Types.ComponentElement cpnt_type -> + let flow' = lazy (flow || evaluate cpnt_type.Types.flow) in + Types.ComponentElement { cpnt_type with Types.flow = flow' } + | Types.ClassElement _ | Types.ComponentTypeElement _ | + Types.PredefinedTypeElement _ -> elt_nat in + try + let elt_type = + evaluate (List.assoc id cl_type.Types.named_elements) in + match elt_type.Types.dynamic_scope with + | None | Some Types.Inner | Some Types.InnerOuter + when not elt_type.Types.protected -> + apply_prefixes elt_type.Types.element_nature + | None | Some Types.Inner | Some Types.InnerOuter -> + raise (CompilError + {err_msg = ["_CannotAccessProtectElem"; id]; + err_info = []; + err_ctx = ctx}) (*error*) + | Some Types.Outer -> + raise (CompilError + {err_msg = ["_CannotAccessOuterElem"; id]; + err_info = []; + err_ctx = ctx}) (*error*) + with Not_found -> + raise (CompilError + {err_msg = ["_UnknownIdentifier"; id]; + err_info = []; + err_ctx = ctx }) (*error*) in + let rec find_local_identifier flow var inout = function + | Types.PredefinedType predef_type -> + find_predefined_local_identifier predef_type id + | Types.ClassType cl_type -> + find_class_local_identifier flow var inout cl_type id + | Types.ComponentType cpnt_type -> + let flow = flow || evaluate cpnt_type.Types.flow + and var = + Types.max_variability var (evaluate cpnt_type.Types.variability) + and inout = evaluate cpnt_type.Types.causality + and base_class = evaluate cpnt_type.Types.base_class in + find_local_identifier flow var inout base_class + | Types.ArrayType (dim, cl_spec) -> + add_dimension dim (find_local_identifier flow var inout cl_spec) + | Types.TupleType _ -> assert false (*error*) in + find_local_identifier flow var inout cl_spec + +and scalar_element_nature elt_nat = + let rec scalar_element_nature' cl_spec = match cl_spec with + | Types.PredefinedType _ | Types.ClassType _ | Types.ComponentType _ | + Types.TupleType _ -> cl_spec + | Types.ArrayType (_, cl_spec) -> scalar_element_nature' cl_spec in + match elt_nat with + | Types.ComponentElement cpnt_type -> + let base_class' = + lazy (scalar_element_nature' (evaluate cpnt_type.Types.base_class)) in + Types.ComponentElement { cpnt_type with Types.base_class = base_class' } + | Types.ClassElement _ | Types.ComponentTypeElement _ | + Types.PredefinedTypeElement _ -> elt_nat + +and resolve_lhs_expression ctx expr = + raise (CompilError + {err_msg = ["_NotYetImplemented"; + "_ExternalCallWithLeftHandSideExpr"]; + err_info = []; + err_ctx = ctx}) + +and resolve_subscripts ctx expr cl_spec subs = + let rec resolve_subscripts' n cl_spec subs = match cl_spec, subs with + | _, [] -> [] + | Types.ArrayType (dim, cl_spec'), sub :: subs' -> + let sub' = resolve_subscript ctx expr n dim sub in + sub' :: resolve_subscripts' (Int32.add n 1l) cl_spec' subs' + | (Types.PredefinedType _ | Types.ClassType _ | Types.ComponentType _ | + Types.TupleType _), _ :: _ -> + raise (CompilError + {err_msg = ["_CannotSubscriptANonArrayTypeElem"]; + err_info = + [("_ExpectedType", "_ArrayType"); + ("_TypeFound", Types.string_of_class_specifier cl_spec)]; + err_ctx = ctx}) (*error*) in + match subs.Syntax.nature with + | Syntax.Subscripts subs' -> resolve_subscripts' 1l cl_spec subs' + +and resolve_subscript ctx expr n dim sub = match sub.Syntax.nature with + | Syntax.Colon -> resolve_colon ctx expr n dim + | Syntax.Subscript expr' -> + let ctx' = + { ctx with + context_nature = SubscriptContext (ctx, expr, n, dim); + location = expr'.Syntax.info } in + resolve_subscript_expression ctx' expr' + +and resolve_colon ctx expr n dim = + let range var stop = + let nat = Range (one, one, stop) + and elt_nat = Types.integer_array_type var dim in + resolved_expression None nat elt_nat in + match dim with + | Types.ConstantDimension n -> + let stop = + let nat = Integer n + and elt_nat = Types.integer_type Types.Constant in + resolved_expression None nat elt_nat in + range Types.Constant stop + | Types.ParameterDimension -> + let stop = size_function_call ctx None expr n in + range Types.Parameter stop + | Types.DiscreteDimension -> + let stop = size_function_call ctx None expr n in + range Types.Discrete stop + +and resolve_subscript_expression ctx expr = + let expr' = resolve_expression ctx expr in + let resolve_subscript_expression' cpnt_type = + let cl_spec = evaluate cpnt_type.Types.base_class in + match cl_spec with + | Types.PredefinedType { Types.base_type = Types.IntegerType } | + Types.ArrayType + (_, Types.PredefinedType { Types.base_type = Types.IntegerType }) -> + expr' + | Types.PredefinedType _ | Types.ClassType _ | Types.ComponentType _ | + Types.ArrayType _ | Types.TupleType _ -> + raise (CompilError + {err_msg = ["_NonIntegerArraySubscript"]; + err_info = + [("_ExpectedType", "Integer"); + ("_TypeFound", Types.string_of_class_specifier cl_spec)]; + err_ctx = ctx}) (*error*) in + match expr'.info.type_description with + | Types.ComponentElement cpnt_type -> + resolve_subscript_expression' cpnt_type + | Types.ClassElement _ | Types.ComponentTypeElement _ | + Types.PredefinedTypeElement _ -> + raise (CompilError + {err_msg = ["_ClassElemFoundInExpr"]; + err_info = []; + err_ctx = ctx}) (*error*) + +and size_function_call ctx syn arg n = + let size_function_call' cpnt_type = + let cpnt_type' = + { cpnt_type with + Types.base_class = lazy (Types.integer_class_type) + } in + let size = + let nat = PredefinedIdentifier "size" + and elt_nat = + Types.function_type + [("@1", cpnt_type); + ("@2", Types.integer_component_type Types.Constant)] + ["@3", cpnt_type'] in + resolved_expression None nat elt_nat in + let elt_nat = Types.ComponentElement cpnt_type' in + let num = + let nat = Integer n + and elt_nat = Types.integer_type Types.Constant in + resolved_expression None nat elt_nat + and expr = + let args = + let arg1 = + let nat = FunctionArgument 1 + and elt_nat = arg.info.type_description in + resolved_expression None nat elt_nat + and arg2 = + let nat = FunctionArgument 2 + and elt_nat = Types.integer_type Types.Constant in + resolved_expression None nat elt_nat in + [arg1; arg2] in + let nat = FunctionInvocation args in + resolved_expression None nat elt_nat in + let nat = FunctionCall (size, [arg; num], expr) in + resolved_expression syn nat elt_nat in + match arg.info.type_description with + | Types.ComponentElement cpnt_type -> size_function_call' cpnt_type + | Types.ClassElement _ | Types.ComponentTypeElement _ | + Types.PredefinedTypeElement _ -> + raise (CompilError + {err_msg = ["_ClassElemFoundInExpr"]; + err_info = []; + err_ctx = ctx}) (*error*) + +and element_type ctx protect final repl dyn_scope elt_desc = + { + Types.protected = protect; + final = bool_of_final final; + replaceable = bool_of_replaceable repl; + dynamic_scope = dynamic_scope_of_dynamic_scope dyn_scope; + element_nature = element_nature_type ctx elt_desc + } + +and bool_of_replaceable = function + | None -> false + | Some Syntax.Replaceable -> true + +and dynamic_scope_of_dynamic_scope = function + | None -> None + | Some Syntax.Inner -> Some Types.Inner + | Some Syntax.Outer -> Some Types.Outer + | Some Syntax.InnerOuter -> Some Types.InnerOuter + +and element_nature_type ctx elt_desc = + let elt_nat = match elt_desc.element_nature with + | Component cpnt_desc -> Types.ComponentElement (evaluate cpnt_desc.component_type) + | Class cl_def -> Types.ClassElement cl_def.class_type + | ComponentType cpnt_type_desc -> + Types.ComponentTypeElement (evaluate cpnt_type_desc.described_type) + | PredefinedType predef -> Types.PredefinedTypeElement predef in + elt_nat + +and class_specifier_type ctx part kind cl_def cl_spec = + let class_kind kind cl_type = + let check_class () = + if has_inouts cl_type then + raise (CompilError + {err_msg = ["_CannotUseCausPrefixInGenClass"; + class_specifier_name cl_spec]; + err_info = []; + err_ctx = ctx}) (*error*) + else kind + and check_model () = kind + and check_block () = + raise (CompilError + {err_msg = ["_NotYetImplemented"; "_BlockElem"]; + err_info = []; + err_ctx = ctx}) + and check_record () = kind + and check_expandable_connector () = + raise (CompilError + {err_msg = ["_NotYetImplemented"; "_ExpandableConnector"]; + err_info = []; + err_ctx = ctx}) + and check_connector () = kind + and check_package () = kind + and check_function () = kind in + match kind with + | Types.Class -> check_class () + | Types.Model -> check_model () + | Types.Block -> check_block () + | Types.Record -> check_record () + | Types.ExpandableConnector -> check_expandable_connector () + | Types.Connector -> check_connector () + | Types.Package -> check_package () + | Types.Function -> check_function () in + let rec cl_type = + { + Types.partial = bool_of_partial part; + kind = lazy (class_kind kind cl_type); + named_elements = class_type_elements ctx kind cl_def + } in + Types.ClassType cl_type + +and bool_of_partial = function + | None -> false + | Some Syntax.Partial -> true + +and class_type_elements ctx kind cl_def = match evaluate cl_def.description with + | LongDescription long_desc -> long_description_type_elements ctx kind long_desc + | ShortDescription short_desc -> short_description_type_elements ctx kind short_desc + +and short_description_type_elements ctx kind short_desc = + let cl_type = evaluate short_desc.modified_class_type in + let kind' = evaluate cl_type.Types.kind in + match kind, kind' with + | Types.Class, Types.Class | + Types.Model, Types.Model | + Types.Block, Types.Block | + Types.Record, Types.Record | + Types.ExpandableConnector, Types.ExpandableConnector | + Types.Connector, Types.Connector | + Types.Package, Types.Package | + Types.Function, Types.Function -> cl_type.Types.named_elements + | (Types.Class | Types.Model | Types.Block | Types.Record | + Types.ExpandableConnector | Types.Connector | Types.Package | Types.Function), + (Types.Class | Types.Model | Types.Block | Types.Record | + Types.ExpandableConnector | Types.Connector | Types.Package | Types.Function) -> + raise (CompilError + {err_msg = ["_InheritFromDiffClassKindsNotAllowed"]; + err_info = []; + err_ctx = ctx}) (*error*) + +and long_description_type_elements ctx kind long_desc = + let type_element (id, elt_desc) = id, elt_desc.element_type in + let local_elts = List.map type_element long_desc.named_elements in + let add_extensions kinds exts = + let add_named_element protected named_elt named_elts = + let element_type elt_type = + let elt_type' = evaluate elt_type in + { elt_type' with Types.protected = + elt_type'.Types.protected || protected } in + match named_elt with + | id, _ when List.mem_assoc id named_elts -> + raise (CompilError + {err_msg = [id; "_AlreadyDeclaredInParentClass"]; + err_info = []; + err_ctx = ctx}) (*error*) + | id, elt_type -> (id, lazy (element_type elt_type)) :: named_elts in + let add_extension_contribution (visibility, modif_cl) named_elts = + let protected = bool_of_visibility visibility + and cl_type = evaluate modif_cl.modified_class_type in + let named_elts' = cl_type.Types.named_elements in + if List.mem (evaluate cl_type.Types.kind) kinds then + List.fold_right (add_named_element protected) named_elts' named_elts + else + raise (CompilError + {err_msg = ["_InheritFromDiffClassKindsNotAllowed"]; + err_info = []; + err_ctx = ctx}) (*error*) in + List.fold_right add_extension_contribution exts local_elts in + match kind, long_desc.extensions with + | Types.Function, [] -> local_elts + | Types.Function, _ :: _ -> + raise (CompilError + {err_msg = ["_InheritFromFunctionNotAllowed"]; + err_info = []; + err_ctx = ctx}) (*error*) + | (Types.Class | Types.Model | Types.Block | Types.Record | Types.Connector | Types.Package), + exts -> add_extensions [kind] exts + | Types.ExpandableConnector, exts -> + add_extensions [kind; Types.Connector] exts + +and bool_of_visibility = function + | Public -> false + | Protected -> true + +and has_inouts cl_type = + let is_inout_component cpnt_type = + match evaluate cpnt_type.Types.causality with + | Types.Input | Types.Output -> true + | Types.Acausal -> false in + let is_inout = function + | Types.ComponentElement cpnt_type -> is_inout_component cpnt_type + | Types.ClassElement _ | Types.ComponentTypeElement _ | + Types.PredefinedTypeElement _ -> false + and element_nature (_, elt_type) = (evaluate elt_type).Types.element_nature in + List.exists + (function named_elt -> is_inout (element_nature named_elt)) + cl_type.Types.named_elements + +and component_type_of_expression ctx expr = + match expr.info.type_description with + | Types.ComponentElement cpnt_type -> cpnt_type + | Types.ClassElement _ | Types.ComponentTypeElement _ | + Types.PredefinedTypeElement _ -> + raise (CompilError + {err_msg = ["_ClassElemFoundInExpr"]; + err_info = []; + err_ctx = ctx}) (*error*) + +and scalar_class_specifier ctx expr = + let rec scalar_class_specifier' cl_spec = match cl_spec with + | Types.ArrayType (dim, cl_spec) -> + scalar_class_specifier' cl_spec + | _ -> cl_spec in + let cpnt_type = component_type_of_expression ctx expr in + let cl_spec = evaluate cpnt_type.Types.base_class in + scalar_class_specifier' cl_spec + +and expression_of_variable expr = + let vector_variables vec_elts = match vec_elts.Syntax.nature with + | Syntax.VectorReduction _ -> false + | Syntax.VectorElements exprs -> + List.for_all expression_of_variable exprs in + match expr.Syntax.nature with + | Syntax.Identifier _ -> true + | Syntax.FieldAccess (expr', _) -> expression_of_variable expr' + | Syntax.IndexedAccess (expr', subs) -> + expression_of_variable expr' + | Syntax.MatrixConstruction exprss -> + List.for_all (List.for_all expression_of_variable) exprss + | Syntax.Tuple exprs -> + List.for_all expression_of_variable exprs + | Syntax.Vector vec_elts -> vector_variables vec_elts + | _ -> false + +and string_of_bin_oper_kind kind = match kind with + | And -> " and " + | Divide -> " / " + | EqualEqual -> " == " + | GreaterEqual -> " >= " + | Greater -> " > " + | LessEqual -> " <= " + | Less -> " < " + | Times -> " * " + | NotEqual -> " <> " + | Or -> " or " + | Plus -> " + " + | Power -> " ^ " + | Minus -> " - " + +and string_of_un_oper_kind kind = match kind with + | Not -> " not " + | UnaryMinus -> "- " + | UnaryPlus -> "+ " + +and apply_binary_coercions exprs = + let base_type expr = + let rec base_type' cl_spec = match cl_spec with + | Types.ArrayType (_, cl_spec) -> base_type' cl_spec + | Types.PredefinedType pt -> Some pt.Types.base_type + | _ -> None in + match expr.info.type_description with + | Types.ComponentElement cpnt_type -> + let cl_spec = evaluate cpnt_type.Types.base_class in + base_type' cl_spec + | _ -> None + and real_type bt = match bt with + | Some Types.RealType -> true + | _ -> false + and integer_type bt = match bt with + | Some Types.IntegerType -> true + | _ -> false in + match List.map base_type exprs with + | [] | [ _ ] -> exprs + | bts when (List.exists real_type bts) && + (List.exists integer_type bts) -> + let cpnt_type = Types.real_component_type Types.Continuous in + List.map (apply_rhs_coercions cpnt_type) exprs + | _ -> exprs + +and apply_rhs_coercions cpnt_type expr = + let apply_real_of_integer cpnt_type cpnt_type' = + let rec apply_real_of_integer' cl_spec cl_spec' = + match cl_spec, cl_spec' with + | Types.ArrayType (dim, cl_spec), _ -> + apply_real_of_integer' cl_spec cl_spec' + | _, Types.ArrayType (dim', cl_spec') -> + let coer, cl_spec' = apply_real_of_integer' cl_spec cl_spec' in + coer, Types.ArrayType (dim', cl_spec') + | Types.PredefinedType { Types.base_type = Types.RealType }, + Types.PredefinedType { Types.base_type = Types.IntegerType } -> + Some RealOfInteger, Types.real_class_type + | _, _ -> None, cl_spec' in + let cl_spec = evaluate cpnt_type.Types.base_class + and cl_spec' = evaluate cpnt_type'.Types.base_class in + match apply_real_of_integer' cl_spec cl_spec' with + | Some RealOfInteger, cl_spec' -> + let cpnt_type' = + { + cpnt_type' with + Types.base_class = lazy cl_spec' + } + and nat' = Coercion (RealOfInteger, expr) in + let elt_nat' = Types.ComponentElement cpnt_type' in + resolved_expression expr.info.syntax nat' elt_nat' + | _ -> expr in + match expr.info.type_description with + | Types.ComponentElement cpnt_type' -> + apply_real_of_integer cpnt_type cpnt_type' + | _ -> expr + +(* for debug *) +and string_of_expression expr = match expr.nature with + | BinaryOperation (bin_oper_kind, expr, expr') -> + Printf.sprintf "BinaryOperation(_, %s, %s)" + (string_of_expression expr) + (string_of_expression expr') + | DynamicIdentifier (i, s) -> "DynamicIdentifier" + | False -> "False" + | FieldAccess (expr, s) -> "FieldAccess" + | FunctionArgument i -> "FunctionArgument" + | FunctionCall (expr, exprs, expr') -> + Printf.sprintf "FunctionCall(%s, {%s}, %s)" + (string_of_expression expr) + (String.concat "," (List.map string_of_expression exprs)) + (string_of_expression expr') + | FunctionInvocation exprs -> "FunctionInvocation" + | If (alts, expr) -> "If" + | IndexedAccess (expr, exprs) -> "IndexedAccess" + | Integer i -> + Printf.sprintf "Integer(%d)" (Int32.to_int i) + | LocalIdentifier (i, s) -> + Printf.sprintf "LocalIdentifier(%d, %s)" i s + | LoopVariable i -> "LoopVariable" + | NoEvent expr -> "NoEvent" + | PredefinedIdentifier s -> + Printf.sprintf "PredefinedIdentifier(%s)" s + | Range (start, step, stop) -> + Printf.sprintf "Range(%s, %s, %s)" + (string_of_expression start) + (string_of_expression step) + (string_of_expression stop) + | Real f -> "Real" + | String s -> "String" + | ToplevelIdentifier s -> "ToplevelIdentifier" + | True -> "True" + | Tuple exprs -> "Tuple" + | UnaryOperation (un_oper_kind, expr) -> "UnaryOperation" + | Vector exprs -> "Vector" + | VectorReduction (exprs, expr) -> "VectorReduction" + | Coercion _ -> "Coercion" diff --git a/scilab/modules/scicos/src/translator/compilation/types.ml b/scilab/modules/scicos/src/translator/compilation/types.ml index c6d07aa..7da9b7c 100644 --- a/scilab/modules/scicos/src/translator/compilation/types.ml +++ b/scilab/modules/scicos/src/translator/compilation/types.ml @@ -1,630 +1,630 @@ -(* - * Translator from Modelica 2.x to flat Modelica - * - * Copyright (C) 2005 - 2007 Imagine S.A. - * For more information or commercial use please contact us at www.amesim.com - * - * This program is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. - * - *) - - - -type element_type = - { - protected: bool; - final: bool; - replaceable: bool; - dynamic_scope: dynamic_scope option; - element_nature: element_nature - } - -and class_type = - { - partial: bool; - kind: kind Lazy.t; - named_elements: (string * element_type Lazy.t) list - } - -and kind = - | Class - | Model - | Block - | Record - | ExpandableConnector - | Connector - | Package - | Function - -and dynamic_scope = - | Inner - | Outer - | InnerOuter - -and element_nature = - | ComponentElement of component_type - | ClassElement of class_specifier Lazy.t - | ComponentTypeElement of component_type - | PredefinedTypeElement of predefined_type - -and component_type = - { - flow: bool Lazy.t; - variability: variability Lazy.t; - causality: causality Lazy.t; - base_class: class_specifier Lazy.t; - } - -and variability = Continuous | Discrete | Parameter | Constant - -and causality = Acausal | Input | Output - -and class_specifier = - | PredefinedType of predefined_type - | ClassType of class_type - | ComponentType of component_type - | ArrayType of dimension * class_specifier - | TupleType of class_specifier list - -and predefined_type = - { - base_type: base_type; - attributes: (string * bool) list - } - -and base_type = - | BooleanType - | IntegerType - | RealType - | StringType - | EnumerationType of string list - -and dimension = - | ConstantDimension of int32 - | ParameterDimension - | DiscreteDimension - -type type_comparison = - | NotRelated - | Subtype - | Supertype - | SameType - - -(* Useful functions *) - -let evaluate x = Lazy.force x - -(* type calculations *) - -let min_variability var var' = match var, var' with - | Constant, _ | _, Constant -> Constant - | Parameter, _ | _, Parameter -> Parameter - | Discrete, _ | _, Discrete -> Discrete - | Continuous, Continuous -> Continuous - -and max_variability var var' = match var, var' with - | Continuous, _ | _, Continuous -> Continuous - | Discrete, _ | _, Discrete -> Discrete - | Parameter, _ | _, Parameter -> Parameter - | Constant, Constant -> Constant - -let higher_variability var var' = - (max_variability var var') = var - -and lower_variability var var' = - (max_variability var var') = var' - -let add_dimensions dims cl_spec = - let add_dimension dim cl_spec = ArrayType (dim, cl_spec) in - List.fold_right add_dimension dims cl_spec - -(* Utilities *) - -let empty_tuple_class_type = TupleType [] - -let boolean_class_type = - PredefinedType { base_type = BooleanType; attributes = ["start", false] } - -and integer_class_type = - PredefinedType - { base_type = IntegerType; attributes = ["start", false; "nominal", false] } - -and real_class_type = - PredefinedType - { base_type = RealType; attributes = ["start", false; "nominal", false] } - -and string_class_type = - PredefinedType { base_type = StringType; attributes = ["start", false] } - -and enumeration_class_type enum_lits = - PredefinedType - { base_type = EnumerationType enum_lits; attributes = ["start", false] } - -let boolean_component_type var = - { - flow = lazy false; - variability = lazy var; - causality = lazy Acausal; - base_class = lazy boolean_class_type; - } - -let integer_component_type var = - { (boolean_component_type var) with - base_class = lazy integer_class_type - } - -let real_component_type var = - { (boolean_component_type var) with - base_class = lazy real_class_type - } - -let string_component_type var = - { (boolean_component_type var) with - base_class = lazy string_class_type - } - -let enumeration_component_type var enum_lits = - { - (boolean_component_type var) with - base_class = lazy (enumeration_class_type enum_lits) - } - -let integer_array_component_type var dims = - let cl_spec = integer_class_type in - { - flow = lazy false; - variability = lazy var; - causality = lazy Acausal; - base_class = lazy (add_dimensions dims cl_spec) - } - -let empty_tuple_type var = - ComponentElement - { (boolean_component_type var) with - base_class = lazy (empty_tuple_class_type) - } - -let boolean_type var = ComponentElement (boolean_component_type var) - -let integer_type var = ComponentElement (integer_component_type var) - -let integer_array_type var dim = - let cl_spec = - ArrayType - (dim, - PredefinedType { base_type = IntegerType; attributes = [] }) in - let cpnt_type = - { - flow = lazy false; - variability = lazy var; - causality = lazy Acausal; - base_class = lazy cl_spec - } in - ComponentElement cpnt_type - -let real_type var = ComponentElement (real_component_type var) - -let string_type var = - ComponentElement (string_component_type var) - -let enumeration_type var enum_lits = - ComponentElement (enumeration_component_type var enum_lits) - -let function_type inputs outputs = - let named_elements inout args = - let element_type cpnt_type = - { - protected = false; - final = true; - replaceable = false; - dynamic_scope = None; - element_nature = - ComponentElement { cpnt_type with causality = lazy inout } - } in - let named_element (id, cpnt_type) = id, lazy (element_type cpnt_type) in - List.map named_element args in - let cl_type = - { - partial = false; - kind = lazy Function; - named_elements = - named_elements Input inputs @ named_elements Output outputs - } in - ClassElement (lazy (ClassType cl_type)) - -let reversed_element_dimensions elt_type = - let rec reversed_dimensions dims = function - | ArrayType (dim, cl_spec) -> reversed_dimensions (dim :: dims) cl_spec - | PredefinedType _ | ClassType _ | ComponentType _ | TupleType _ -> dims in - match elt_type with - | ComponentElement cpnt_type -> - let cl_spec = evaluate cpnt_type.base_class in - reversed_dimensions [] cl_spec - | ClassElement _ | ComponentTypeElement _ | PredefinedTypeElement _ -> [] - -let scalar_component_type cpnt_type = - let rec scalar_class_specifier cl_spec = match cl_spec with - | ArrayType (_, cl_spec) -> scalar_class_specifier cl_spec - | _ -> cl_spec in - { - cpnt_type with - base_class = lazy (scalar_class_specifier (evaluate cpnt_type.base_class)) - } - - -(* General type comparisons *) - -let rec compare_class_types ct ct' = - match Lazy.force ct.kind, Lazy.force ct'.kind with - | Class, Class -> compare_classes ct ct' - | Model, Model -> compare_models ct ct' - | Block, Block -> compare_blocks ct ct' - | Record, Record -> compare_records ct ct' - | ExpandableConnector, ExpandableConnector -> - compare_expandable_connectors ct ct' - | Connector, Connector -> compare_connectors ct ct' - | Package, Package -> compare_packages ct ct' - | Function, Function -> compare_functions ct ct' - | _ -> NotRelated - -and compare_classes ct ct' = - let rec compare_classes' type_cmp named_elts named_elts' = - match named_elts' with - | [] -> type_cmp - | (s', _) :: _ when not (List.mem_assoc s' named_elts) -> NotRelated - | (s', elt_type') :: named_elts' -> - begin - let type_cmp' = - compare_elements - (Lazy.force (List.assoc s' named_elts)) - (Lazy.force elt_type') in - match type_cmp, type_cmp' with - | SameType, (SameType | Subtype) -> - compare_classes' type_cmp' named_elts named_elts' - | Subtype, (SameType | Subtype) -> - compare_classes' Subtype named_elts named_elts' - | _ -> NotRelated - end in - let named_elts = ct.named_elements - and named_elts' = ct'.named_elements in - let l = List.length named_elts - and l' = List.length named_elts' in - if l < l' then invert (compare_classes' Subtype named_elts' named_elts) - else if l = l' then compare_classes' SameType named_elts named_elts' - else compare_classes' Subtype named_elts named_elts' - -and invert = function - | NotRelated -> NotRelated - | Subtype -> Supertype - | Supertype -> Subtype - | SameType -> SameType - -and compare_models ct ct' = compare_classes ct ct' - -and compare_blocks ct ct' = compare_classes ct ct' - -and compare_records ct ct' = compare_classes ct ct' - -and compare_expandable_connectors ct ct' = compare_classes ct ct' - -and compare_connectors ct ct' = compare_classes ct ct' - -and compare_packages ct ct' = compare_classes ct ct' - -and compare_functions ct ct' = compare_classes ct ct' - -and compare_elements elt_type elt_type' = - if - elt_type.protected = elt_type'.protected && - elt_type.final = elt_type'.final && - elt_type.replaceable = elt_type'.replaceable && - elt_type.dynamic_scope = elt_type'.dynamic_scope - then compare_element_natures elt_type.element_nature elt_type'.element_nature - else NotRelated - -and compare_element_natures elt_nature elt_nature' = match elt_nature, elt_nature' with - | ComponentElement cpntt, ComponentElement cpntt' -> compare_component_types cpntt cpntt' - | ClassElement cs, ClassElement cs' -> compare_specifiers (Lazy.force cs) (Lazy.force cs') - | ComponentTypeElement cpntt, ComponentTypeElement cpntt' -> compare_component_types cpntt cpntt' - | PredefinedTypeElement pt, PredefinedTypeElement pt' -> compare_predefined_types pt pt' - | (ComponentElement _ | ClassElement _ | ComponentTypeElement _ | PredefinedTypeElement _), - (ComponentElement _ | ClassElement _ | ComponentTypeElement _ | PredefinedTypeElement _) -> - NotRelated - -and compare_component_types cpntt cpntt' = - (*if - Lazy.force cpntt.flow = Lazy.force cpntt'.flow && - Lazy.force cpntt.variability = Lazy.force cpntt'.variability && - Lazy.force cpntt.causality = Lazy.force cpntt'.causality - then*) - compare_specifiers (Lazy.force cpntt.base_class) (Lazy.force cpntt'.base_class) - (*else NotRelated*) - -and compare_specifiers cs cs' = match cs, cs' with - | PredefinedType pt, PredefinedType pt' -> compare_predefined_types pt pt' - | ClassType ct, ClassType ct' -> compare_class_types ct ct' - | ComponentType cpntt, ComponentType cpntt' -> compare_component_types cpntt cpntt' - | ArrayType (dim, cs), ArrayType (dim', cs') - when compare_dimensions dim dim' -> - compare_specifiers cs cs' - | TupleType css, TupleType css' -> compare_tuple_types css css' - | (PredefinedType _ | ClassType _ | ComponentType _ | ArrayType _ | TupleType _), - (PredefinedType _ | ClassType _ | ComponentType _ | ArrayType _ | TupleType _) -> - NotRelated - -and compare_dimensions dim dim' = match dim, dim' with - | ConstantDimension i, ConstantDimension i' when i <> i' -> false - | _ -> true - -and compare_tuple_types css css' = - if List.for_all2 (fun cs cs' -> compare_specifiers cs cs' = SameType) css css' then - SameType - else NotRelated - -and compare_predefined_types pt pt' = match pt.base_type, pt'.base_type with - | BooleanType, BooleanType -> SameType - | IntegerType, IntegerType -> SameType - | RealType, RealType -> SameType - | RealType, IntegerType -> Supertype - | IntegerType, RealType -> Subtype - | StringType, StringType -> SameType - | EnumerationType enum_elts, EnumerationType enum_elts' - when enum_elts = enum_elts' -> SameType - | _ -> NotRelated - -(* Printing utilities *) - -let fprint_tabs oc offset = - for i = 1 to offset do Printf.fprintf oc "\t" done - -let rec fprint_class_type oc id cl_type = - if cl_type.partial then Printf.fprintf oc "partial "; - fprint_kind oc (Lazy.force cl_type.kind); - Printf.fprintf oc "%s\n" id; - fprint_named_elements oc 1 cl_type.named_elements; - Printf.fprintf oc "end %s;\n" id - -and fprint_kind oc = function - | Class -> Printf.fprintf oc "class " - | Model -> Printf.fprintf oc "model " - | Block -> Printf.fprintf oc "block " - | Record -> Printf.fprintf oc "record " - | ExpandableConnector -> Printf.fprintf oc "expandable connector " - | Connector -> Printf.fprintf oc "connector " - | Package -> Printf.fprintf oc "package " - | Function -> Printf.fprintf oc "function " - -and fprint_named_elements oc offset named_elts = - List.iter - (function (s, elt_type) -> fprint_named_element oc offset (s, Lazy.force elt_type)) - named_elts - -and fprint_named_element oc offset (id, elt_type) = - fprint_tabs oc offset; - if elt_type.protected then Printf.fprintf oc "protected "; - if elt_type.final then Printf.fprintf oc "final "; - if elt_type.replaceable then Printf.fprintf oc "replaceable "; - fprint_dynamic_scope oc elt_type.dynamic_scope; - fprint_element_nature oc offset id elt_type.element_nature - -and fprint_dynamic_scope oc = function - | None -> () - | Some Inner -> Printf.fprintf oc "inner " - | Some Outer -> Printf.fprintf oc "outer " - | Some InnerOuter -> Printf.fprintf oc "inner outer " - -and fprint_element_nature oc offset id = function - | ComponentElement cpnt_type -> fprint_component_type oc offset id cpnt_type - | ClassElement cl_spec -> fprint_class_specifier oc offset id (Lazy.force cl_spec) - | ComponentTypeElement cpnt_type -> fprint_component_type_type oc offset id cpnt_type - | PredefinedTypeElement predef_type -> fprint_predefined_type_type oc id predef_type - -and fprint_class_specifier oc offset id = function - | PredefinedType _ -> assert false - | ClassType cl_type -> fprint_class_type_specifier oc offset id cl_type - | ComponentType _ -> assert false - | ArrayType (_, cs) -> fprint_class_specifier oc offset id cs - | TupleType _ -> assert false - -and fprint_class_type_specifier oc offset id cl_type = - if cl_type.partial then Printf.fprintf oc "partial "; - fprint_kind oc (Lazy.force cl_type.kind); - Printf.fprintf oc "%s\n" id; - fprint_named_elements oc (offset + 1) cl_type.named_elements; - fprint_tabs oc offset; - Printf.fprintf oc "end %s;\n" id - -and fprint_component_type_type oc offset id cpnt_type = - Printf.fprintf oc "type %s = " id; - fprint_component_type oc offset "" cpnt_type; - Printf.fprintf oc ";\n" - -and fprint_predefined_type_type oc id predef_type = - Printf.fprintf oc "type %s = " id; - fprint_predefined_type oc predef_type; - Printf.fprintf oc ";\n" - -and fprint_component_type oc offset id cpnt_type = - if Lazy.force cpnt_type.flow then Printf.fprintf oc "flow "; - fprint_variability oc (Lazy.force cpnt_type.variability); - fprint_causality oc (Lazy.force cpnt_type.causality); - fprint_class_specifier_type oc offset (Lazy.force cpnt_type.base_class); - fprint_dimensions oc (Lazy.force cpnt_type.base_class); - Printf.fprintf oc " %s;\n" id - -and fprint_variability oc = function - | Continuous -> () - | Discrete -> Printf.fprintf oc "discrete " - | Parameter -> Printf.fprintf oc "parameter " - | Constant -> Printf.fprintf oc "constant " - -and fprint_causality oc = function - | Acausal -> () - | Input -> Printf.fprintf oc "input " - | Output -> Printf.fprintf oc "output " - -and fprint_class_specifier_type oc offset = function - | PredefinedType predef_type -> fprint_predefined_type oc predef_type - | ClassType cl_type -> fprint_class_type_specifier_type oc offset cl_type - | ComponentType cpnt_type -> fprint_component_type_specifier_type oc offset cpnt_type - | ArrayType (_, cs) -> fprint_class_specifier_type oc offset cs - | TupleType _ -> assert false - -and fprint_predefined_type oc predef_type = match predef_type.base_type with - | BooleanType -> Printf.fprintf oc "Boolean" - | IntegerType -> Printf.fprintf oc "Integer" - | RealType -> Printf.fprintf oc "Real" - | StringType -> Printf.fprintf oc "String" - | EnumerationType enum_elts -> fprint_enumeration_type oc enum_elts - -and fprint_enumeration_type oc ss = - let rec fprint_enumeration_type' = function - | [] -> () - | [s] -> Printf.fprintf oc "%s" s - | s :: ss -> Printf.fprintf oc "%s, " s; fprint_enumeration_type' ss in - Printf.fprintf oc "enumeration("; - fprint_enumeration_type' ss; - Printf.fprintf oc ")" - -and fprint_class_type_specifier_type oc offset cl_type = - if cl_type.partial then Printf.fprintf oc "partial "; - fprint_kind oc (Lazy.force cl_type.kind); - Printf.fprintf oc "_\n"; - fprint_named_elements oc (offset + 1) cl_type.named_elements; - fprint_tabs oc offset; - Printf.fprintf oc "end _" - -and fprint_component_type_specifier_type oc offset cpnt_type = - Printf.fprintf oc "("; - if Lazy.force cpnt_type.flow then Printf.fprintf oc "flow "; - fprint_variability oc (Lazy.force cpnt_type.variability); - fprint_causality oc (Lazy.force cpnt_type.causality); - fprint_class_specifier_type oc offset (Lazy.force cpnt_type.base_class); - fprint_dimensions oc (Lazy.force cpnt_type.base_class); - Printf.fprintf oc ")" - -and fprint_dimensions oc cs = - let fprint_dimension = function - | ConstantDimension d -> Printf.fprintf oc "%ld" d - | ParameterDimension -> Printf.fprintf oc "p" - | DiscreteDimension -> Printf.fprintf oc ":" in - let rec fprint_dimensions' dim = function - | PredefinedType _ | ClassType _ | ComponentType _ | TupleType _ -> - fprint_dimension dim - | ArrayType (dim', cs') -> - fprint_dimension dim; - Printf.fprintf oc ", "; - fprint_dimensions' dim' cs' in - match cs with - | PredefinedType _ | ClassType _ | ComponentType _ | TupleType _ -> () - | ArrayType (dim, cs) -> - Printf.fprintf oc "["; fprint_dimensions' dim cs; Printf.fprintf oc "]" - -(* String conversion utilities *) - -let rec string_of_kind kind = match kind with - | Class -> "class " - | Model -> "model " - | Block -> "block " - | Record -> "record " - | ExpandableConnector -> "expandable connector " - | Connector -> "connector " - | Package -> "package " - | Function -> "function " - -and string_of_dynamic_scope dyn_scope = match dyn_scope with - | None -> "" - | Some Inner -> "inner " - | Some Outer -> "outer " - | Some InnerOuter -> "inner outer " - -and string_of_class_specifier cl_spec = - let string_of_dimension dim = match dim with - | ConstantDimension d -> Int32.to_string d - | ParameterDimension -> "p" - | DiscreteDimension -> ":" in - let string_of_dimensions dims = - let rec string_of_dimensions' dims = match dims with - | [] -> "" - | [dim] -> string_of_dimension dim - | dim :: dims -> - (string_of_dimension dim) ^ ", " ^ (string_of_dimensions' dims) in - match dims with - | [] -> "" - | _ -> "[" ^ (string_of_dimensions' dims) ^ "]" in - let rec string_of_class_specifier' dims cl_spec = match cl_spec with - | PredefinedType predef_type -> - (string_of_predefined_type predef_type) ^ - (string_of_dimensions dims) - | ClassType cl_type -> - (string_of_class_type cl_type) ^ - (string_of_dimensions dims) - | ComponentType cpnt_type -> - (string_of_component_type cpnt_type) ^ - (string_of_dimensions dims) - | ArrayType (dim, cs) -> - string_of_class_specifier' (dim :: dims) cs - | TupleType cl_specs -> - "(" ^ (string_of_tuple_type cl_specs) ^ ")" ^ - (string_of_dimensions dims) in - string_of_class_specifier' [] cl_spec - -and string_of_tuple_type cl_specs = match cl_specs with - | [] -> "" - | [cl_spec] -> string_of_class_specifier cl_spec - | cl_spec :: cl_specs -> - (string_of_class_specifier cl_spec) ^ ", " ^ - (string_of_tuple_type cl_specs) - -and string_of_class_type cl_type = - string_of_kind (Lazy.force cl_type.kind) - -and string_of_component_type cpnt_type = - string_of_class_specifier (Lazy.force cpnt_type.base_class) - -and string_of_variability var = match var with - | Continuous -> "continuous" - | Discrete -> "discrete" - | Parameter -> "parameter" - | Constant -> "constant" - -and string_of_causality c = match c with - | Acausal -> "" - | Input -> "input" - | Output -> "output" - -and string_of_predefined_type predef_type = - string_of_base_type predef_type.base_type - -and string_of_base_type base_type = match base_type with - | BooleanType -> "Boolean" - | IntegerType -> "Integer" - | RealType -> "Real" - | StringType -> "String" - | EnumerationType enum_elts -> string_of_enumeration_type enum_elts - -and string_of_enumeration_type ss = - let rec string_of_enumeration_type' ss = match ss with - | [] -> "" - | [s] -> s - | s :: ss -> s ^ ", " ^ (string_of_enumeration_type' ss) in - "enumeration(" ^ (string_of_enumeration_type' ss) ^ ")" - -and string_of_element_nature = function - | ComponentElement _ -> "_ComponentElement" - | ClassElement _ -> "_ClassElement" - | ComponentTypeElement _ -> "_ComponentTypeElement" - | PredefinedTypeElement _ -> "_PredefinedTypeElement" +(* + * Translator from Modelica 2.x to flat Modelica + * + * Copyright (C) 2005 - 2007 Imagine S.A. + * For more information or commercial use please contact us at www.amesim.com + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. + * + *) + + + +type element_type = + { + protected: bool; + final: bool; + replaceable: bool; + dynamic_scope: dynamic_scope option; + element_nature: element_nature + } + +and class_type = + { + partial: bool; + kind: kind Lazy.t; + named_elements: (string * element_type Lazy.t) list + } + +and kind = + | Class + | Model + | Block + | Record + | ExpandableConnector + | Connector + | Package + | Function + +and dynamic_scope = + | Inner + | Outer + | InnerOuter + +and element_nature = + | ComponentElement of component_type + | ClassElement of class_specifier Lazy.t + | ComponentTypeElement of component_type + | PredefinedTypeElement of predefined_type + +and component_type = + { + flow: bool Lazy.t; + variability: variability Lazy.t; + causality: causality Lazy.t; + base_class: class_specifier Lazy.t; + } + +and variability = Continuous | Discrete | Parameter | Constant + +and causality = Acausal | Input | Output + +and class_specifier = + | PredefinedType of predefined_type + | ClassType of class_type + | ComponentType of component_type + | ArrayType of dimension * class_specifier + | TupleType of class_specifier list + +and predefined_type = + { + base_type: base_type; + attributes: (string * bool) list + } + +and base_type = + | BooleanType + | IntegerType + | RealType + | StringType + | EnumerationType of string list + +and dimension = + | ConstantDimension of int32 + | ParameterDimension + | DiscreteDimension + +type type_comparison = + | NotRelated + | Subtype + | Supertype + | SameType + + +(* Useful functions *) + +let evaluate x = Lazy.force x + +(* type calculations *) + +let min_variability var var' = match var, var' with + | Constant, _ | _, Constant -> Constant + | Parameter, _ | _, Parameter -> Parameter + | Discrete, _ | _, Discrete -> Discrete + | Continuous, Continuous -> Continuous + +and max_variability var var' = match var, var' with + | Continuous, _ | _, Continuous -> Continuous + | Discrete, _ | _, Discrete -> Discrete + | Parameter, _ | _, Parameter -> Parameter + | Constant, Constant -> Constant + +let higher_variability var var' = + (max_variability var var') = var + +and lower_variability var var' = + (max_variability var var') = var' + +let add_dimensions dims cl_spec = + let add_dimension dim cl_spec = ArrayType (dim, cl_spec) in + List.fold_right add_dimension dims cl_spec + +(* Utilities *) + +let empty_tuple_class_type = TupleType [] + +let boolean_class_type = + PredefinedType { base_type = BooleanType; attributes = ["start", false] } + +and integer_class_type = + PredefinedType + { base_type = IntegerType; attributes = ["start", false; "nominal", false] } + +and real_class_type = + PredefinedType + { base_type = RealType; attributes = ["start", false; "nominal", false] } + +and string_class_type = + PredefinedType { base_type = StringType; attributes = ["start", false] } + +and enumeration_class_type enum_lits = + PredefinedType + { base_type = EnumerationType enum_lits; attributes = ["start", false] } + +let boolean_component_type var = + { + flow = lazy false; + variability = lazy var; + causality = lazy Acausal; + base_class = lazy boolean_class_type; + } + +let integer_component_type var = + { (boolean_component_type var) with + base_class = lazy integer_class_type + } + +let real_component_type var = + { (boolean_component_type var) with + base_class = lazy real_class_type + } + +let string_component_type var = + { (boolean_component_type var) with + base_class = lazy string_class_type + } + +let enumeration_component_type var enum_lits = + { + (boolean_component_type var) with + base_class = lazy (enumeration_class_type enum_lits) + } + +let integer_array_component_type var dims = + let cl_spec = integer_class_type in + { + flow = lazy false; + variability = lazy var; + causality = lazy Acausal; + base_class = lazy (add_dimensions dims cl_spec) + } + +let empty_tuple_type var = + ComponentElement + { (boolean_component_type var) with + base_class = lazy (empty_tuple_class_type) + } + +let boolean_type var = ComponentElement (boolean_component_type var) + +let integer_type var = ComponentElement (integer_component_type var) + +let integer_array_type var dim = + let cl_spec = + ArrayType + (dim, + PredefinedType { base_type = IntegerType; attributes = [] }) in + let cpnt_type = + { + flow = lazy false; + variability = lazy var; + causality = lazy Acausal; + base_class = lazy cl_spec + } in + ComponentElement cpnt_type + +let real_type var = ComponentElement (real_component_type var) + +let string_type var = + ComponentElement (string_component_type var) + +let enumeration_type var enum_lits = + ComponentElement (enumeration_component_type var enum_lits) + +let function_type inputs outputs = + let named_elements inout args = + let element_type cpnt_type = + { + protected = false; + final = true; + replaceable = false; + dynamic_scope = None; + element_nature = + ComponentElement { cpnt_type with causality = lazy inout } + } in + let named_element (id, cpnt_type) = id, lazy (element_type cpnt_type) in + List.map named_element args in + let cl_type = + { + partial = false; + kind = lazy Function; + named_elements = + named_elements Input inputs @ named_elements Output outputs + } in + ClassElement (lazy (ClassType cl_type)) + +let reversed_element_dimensions elt_type = + let rec reversed_dimensions dims = function + | ArrayType (dim, cl_spec) -> reversed_dimensions (dim :: dims) cl_spec + | PredefinedType _ | ClassType _ | ComponentType _ | TupleType _ -> dims in + match elt_type with + | ComponentElement cpnt_type -> + let cl_spec = evaluate cpnt_type.base_class in + reversed_dimensions [] cl_spec + | ClassElement _ | ComponentTypeElement _ | PredefinedTypeElement _ -> [] + +let scalar_component_type cpnt_type = + let rec scalar_class_specifier cl_spec = match cl_spec with + | ArrayType (_, cl_spec) -> scalar_class_specifier cl_spec + | _ -> cl_spec in + { + cpnt_type with + base_class = lazy (scalar_class_specifier (evaluate cpnt_type.base_class)) + } + + +(* General type comparisons *) + +let rec compare_class_types ct ct' = + match Lazy.force ct.kind, Lazy.force ct'.kind with + | Class, Class -> compare_classes ct ct' + | Model, Model -> compare_models ct ct' + | Block, Block -> compare_blocks ct ct' + | Record, Record -> compare_records ct ct' + | ExpandableConnector, ExpandableConnector -> + compare_expandable_connectors ct ct' + | Connector, Connector -> compare_connectors ct ct' + | Package, Package -> compare_packages ct ct' + | Function, Function -> compare_functions ct ct' + | _ -> NotRelated + +and compare_classes ct ct' = + let rec compare_classes' type_cmp named_elts named_elts' = + match named_elts' with + | [] -> type_cmp + | (s', _) :: _ when not (List.mem_assoc s' named_elts) -> NotRelated + | (s', elt_type') :: named_elts' -> + begin + let type_cmp' = + compare_elements + (Lazy.force (List.assoc s' named_elts)) + (Lazy.force elt_type') in + match type_cmp, type_cmp' with + | SameType, (SameType | Subtype) -> + compare_classes' type_cmp' named_elts named_elts' + | Subtype, (SameType | Subtype) -> + compare_classes' Subtype named_elts named_elts' + | _ -> NotRelated + end in + let named_elts = ct.named_elements + and named_elts' = ct'.named_elements in + let l = List.length named_elts + and l' = List.length named_elts' in + if l < l' then invert (compare_classes' Subtype named_elts' named_elts) + else if l = l' then compare_classes' SameType named_elts named_elts' + else compare_classes' Subtype named_elts named_elts' + +and invert = function + | NotRelated -> NotRelated + | Subtype -> Supertype + | Supertype -> Subtype + | SameType -> SameType + +and compare_models ct ct' = compare_classes ct ct' + +and compare_blocks ct ct' = compare_classes ct ct' + +and compare_records ct ct' = compare_classes ct ct' + +and compare_expandable_connectors ct ct' = compare_classes ct ct' + +and compare_connectors ct ct' = compare_classes ct ct' + +and compare_packages ct ct' = compare_classes ct ct' + +and compare_functions ct ct' = compare_classes ct ct' + +and compare_elements elt_type elt_type' = + if + elt_type.protected = elt_type'.protected && + elt_type.final = elt_type'.final && + elt_type.replaceable = elt_type'.replaceable && + elt_type.dynamic_scope = elt_type'.dynamic_scope + then compare_element_natures elt_type.element_nature elt_type'.element_nature + else NotRelated + +and compare_element_natures elt_nature elt_nature' = match elt_nature, elt_nature' with + | ComponentElement cpntt, ComponentElement cpntt' -> compare_component_types cpntt cpntt' + | ClassElement cs, ClassElement cs' -> compare_specifiers (Lazy.force cs) (Lazy.force cs') + | ComponentTypeElement cpntt, ComponentTypeElement cpntt' -> compare_component_types cpntt cpntt' + | PredefinedTypeElement pt, PredefinedTypeElement pt' -> compare_predefined_types pt pt' + | (ComponentElement _ | ClassElement _ | ComponentTypeElement _ | PredefinedTypeElement _), + (ComponentElement _ | ClassElement _ | ComponentTypeElement _ | PredefinedTypeElement _) -> + NotRelated + +and compare_component_types cpntt cpntt' = + (*if + Lazy.force cpntt.flow = Lazy.force cpntt'.flow && + Lazy.force cpntt.variability = Lazy.force cpntt'.variability && + Lazy.force cpntt.causality = Lazy.force cpntt'.causality + then*) + compare_specifiers (Lazy.force cpntt.base_class) (Lazy.force cpntt'.base_class) + (*else NotRelated*) + +and compare_specifiers cs cs' = match cs, cs' with + | PredefinedType pt, PredefinedType pt' -> compare_predefined_types pt pt' + | ClassType ct, ClassType ct' -> compare_class_types ct ct' + | ComponentType cpntt, ComponentType cpntt' -> compare_component_types cpntt cpntt' + | ArrayType (dim, cs), ArrayType (dim', cs') + when compare_dimensions dim dim' -> + compare_specifiers cs cs' + | TupleType css, TupleType css' -> compare_tuple_types css css' + | (PredefinedType _ | ClassType _ | ComponentType _ | ArrayType _ | TupleType _), + (PredefinedType _ | ClassType _ | ComponentType _ | ArrayType _ | TupleType _) -> + NotRelated + +and compare_dimensions dim dim' = match dim, dim' with + | ConstantDimension i, ConstantDimension i' when i <> i' -> false + | _ -> true + +and compare_tuple_types css css' = + if List.for_all2 (fun cs cs' -> compare_specifiers cs cs' = SameType) css css' then + SameType + else NotRelated + +and compare_predefined_types pt pt' = match pt.base_type, pt'.base_type with + | BooleanType, BooleanType -> SameType + | IntegerType, IntegerType -> SameType + | RealType, RealType -> SameType + | RealType, IntegerType -> Supertype + | IntegerType, RealType -> Subtype + | StringType, StringType -> SameType + | EnumerationType enum_elts, EnumerationType enum_elts' + when enum_elts = enum_elts' -> SameType + | _ -> NotRelated + +(* Printing utilities *) + +let fprint_tabs oc offset = + for i = 1 to offset do Printf.fprintf oc "\t" done + +let rec fprint_class_type oc id cl_type = + if cl_type.partial then Printf.fprintf oc "partial "; + fprint_kind oc (Lazy.force cl_type.kind); + Printf.fprintf oc "%s\n" id; + fprint_named_elements oc 1 cl_type.named_elements; + Printf.fprintf oc "end %s;\n" id + +and fprint_kind oc = function + | Class -> Printf.fprintf oc "class " + | Model -> Printf.fprintf oc "model " + | Block -> Printf.fprintf oc "block " + | Record -> Printf.fprintf oc "record " + | ExpandableConnector -> Printf.fprintf oc "expandable connector " + | Connector -> Printf.fprintf oc "connector " + | Package -> Printf.fprintf oc "package " + | Function -> Printf.fprintf oc "function " + +and fprint_named_elements oc offset named_elts = + List.iter + (function (s, elt_type) -> fprint_named_element oc offset (s, Lazy.force elt_type)) + named_elts + +and fprint_named_element oc offset (id, elt_type) = + fprint_tabs oc offset; + if elt_type.protected then Printf.fprintf oc "protected "; + if elt_type.final then Printf.fprintf oc "final "; + if elt_type.replaceable then Printf.fprintf oc "replaceable "; + fprint_dynamic_scope oc elt_type.dynamic_scope; + fprint_element_nature oc offset id elt_type.element_nature + +and fprint_dynamic_scope oc = function + | None -> () + | Some Inner -> Printf.fprintf oc "inner " + | Some Outer -> Printf.fprintf oc "outer " + | Some InnerOuter -> Printf.fprintf oc "inner outer " + +and fprint_element_nature oc offset id = function + | ComponentElement cpnt_type -> fprint_component_type oc offset id cpnt_type + | ClassElement cl_spec -> fprint_class_specifier oc offset id (Lazy.force cl_spec) + | ComponentTypeElement cpnt_type -> fprint_component_type_type oc offset id cpnt_type + | PredefinedTypeElement predef_type -> fprint_predefined_type_type oc id predef_type + +and fprint_class_specifier oc offset id = function + | PredefinedType _ -> assert false + | ClassType cl_type -> fprint_class_type_specifier oc offset id cl_type + | ComponentType _ -> assert false + | ArrayType (_, cs) -> fprint_class_specifier oc offset id cs + | TupleType _ -> assert false + +and fprint_class_type_specifier oc offset id cl_type = + if cl_type.partial then Printf.fprintf oc "partial "; + fprint_kind oc (Lazy.force cl_type.kind); + Printf.fprintf oc "%s\n" id; + fprint_named_elements oc (offset + 1) cl_type.named_elements; + fprint_tabs oc offset; + Printf.fprintf oc "end %s;\n" id + +and fprint_component_type_type oc offset id cpnt_type = + Printf.fprintf oc "type %s = " id; + fprint_component_type oc offset "" cpnt_type; + Printf.fprintf oc ";\n" + +and fprint_predefined_type_type oc id predef_type = + Printf.fprintf oc "type %s = " id; + fprint_predefined_type oc predef_type; + Printf.fprintf oc ";\n" + +and fprint_component_type oc offset id cpnt_type = + if Lazy.force cpnt_type.flow then Printf.fprintf oc "flow "; + fprint_variability oc (Lazy.force cpnt_type.variability); + fprint_causality oc (Lazy.force cpnt_type.causality); + fprint_class_specifier_type oc offset (Lazy.force cpnt_type.base_class); + fprint_dimensions oc (Lazy.force cpnt_type.base_class); + Printf.fprintf oc " %s;\n" id + +and fprint_variability oc = function + | Continuous -> () + | Discrete -> Printf.fprintf oc "discrete " + | Parameter -> Printf.fprintf oc "parameter " + | Constant -> Printf.fprintf oc "constant " + +and fprint_causality oc = function + | Acausal -> () + | Input -> Printf.fprintf oc "input " + | Output -> Printf.fprintf oc "output " + +and fprint_class_specifier_type oc offset = function + | PredefinedType predef_type -> fprint_predefined_type oc predef_type + | ClassType cl_type -> fprint_class_type_specifier_type oc offset cl_type + | ComponentType cpnt_type -> fprint_component_type_specifier_type oc offset cpnt_type + | ArrayType (_, cs) -> fprint_class_specifier_type oc offset cs + | TupleType _ -> assert false + +and fprint_predefined_type oc predef_type = match predef_type.base_type with + | BooleanType -> Printf.fprintf oc "Boolean" + | IntegerType -> Printf.fprintf oc "Integer" + | RealType -> Printf.fprintf oc "Real" + | StringType -> Printf.fprintf oc "String" + | EnumerationType enum_elts -> fprint_enumeration_type oc enum_elts + +and fprint_enumeration_type oc ss = + let rec fprint_enumeration_type' = function + | [] -> () + | [s] -> Printf.fprintf oc "%s" s + | s :: ss -> Printf.fprintf oc "%s, " s; fprint_enumeration_type' ss in + Printf.fprintf oc "enumeration("; + fprint_enumeration_type' ss; + Printf.fprintf oc ")" + +and fprint_class_type_specifier_type oc offset cl_type = + if cl_type.partial then Printf.fprintf oc "partial "; + fprint_kind oc (Lazy.force cl_type.kind); + Printf.fprintf oc "_\n"; + fprint_named_elements oc (offset + 1) cl_type.named_elements; + fprint_tabs oc offset; + Printf.fprintf oc "end _" + +and fprint_component_type_specifier_type oc offset cpnt_type = + Printf.fprintf oc "("; + if Lazy.force cpnt_type.flow then Printf.fprintf oc "flow "; + fprint_variability oc (Lazy.force cpnt_type.variability); + fprint_causality oc (Lazy.force cpnt_type.causality); + fprint_class_specifier_type oc offset (Lazy.force cpnt_type.base_class); + fprint_dimensions oc (Lazy.force cpnt_type.base_class); + Printf.fprintf oc ")" + +and fprint_dimensions oc cs = + let fprint_dimension = function + | ConstantDimension d -> Printf.fprintf oc "%ld" d + | ParameterDimension -> Printf.fprintf oc "p" + | DiscreteDimension -> Printf.fprintf oc ":" in + let rec fprint_dimensions' dim = function + | PredefinedType _ | ClassType _ | ComponentType _ | TupleType _ -> + fprint_dimension dim + | ArrayType (dim', cs') -> + fprint_dimension dim; + Printf.fprintf oc ", "; + fprint_dimensions' dim' cs' in + match cs with + | PredefinedType _ | ClassType _ | ComponentType _ | TupleType _ -> () + | ArrayType (dim, cs) -> + Printf.fprintf oc "["; fprint_dimensions' dim cs; Printf.fprintf oc "]" + +(* String conversion utilities *) + +let rec string_of_kind kind = match kind with + | Class -> "class " + | Model -> "model " + | Block -> "block " + | Record -> "record " + | ExpandableConnector -> "expandable connector " + | Connector -> "connector " + | Package -> "package " + | Function -> "function " + +and string_of_dynamic_scope dyn_scope = match dyn_scope with + | None -> "" + | Some Inner -> "inner " + | Some Outer -> "outer " + | Some InnerOuter -> "inner outer " + +and string_of_class_specifier cl_spec = + let string_of_dimension dim = match dim with + | ConstantDimension d -> Int32.to_string d + | ParameterDimension -> "p" + | DiscreteDimension -> ":" in + let string_of_dimensions dims = + let rec string_of_dimensions' dims = match dims with + | [] -> "" + | [dim] -> string_of_dimension dim + | dim :: dims -> + (string_of_dimension dim) ^ ", " ^ (string_of_dimensions' dims) in + match dims with + | [] -> "" + | _ -> "[" ^ (string_of_dimensions' dims) ^ "]" in + let rec string_of_class_specifier' dims cl_spec = match cl_spec with + | PredefinedType predef_type -> + (string_of_predefined_type predef_type) ^ + (string_of_dimensions dims) + | ClassType cl_type -> + (string_of_class_type cl_type) ^ + (string_of_dimensions dims) + | ComponentType cpnt_type -> + (string_of_component_type cpnt_type) ^ + (string_of_dimensions dims) + | ArrayType (dim, cs) -> + string_of_class_specifier' (dim :: dims) cs + | TupleType cl_specs -> + "(" ^ (string_of_tuple_type cl_specs) ^ ")" ^ + (string_of_dimensions dims) in + string_of_class_specifier' [] cl_spec + +and string_of_tuple_type cl_specs = match cl_specs with + | [] -> "" + | [cl_spec] -> string_of_class_specifier cl_spec + | cl_spec :: cl_specs -> + (string_of_class_specifier cl_spec) ^ ", " ^ + (string_of_tuple_type cl_specs) + +and string_of_class_type cl_type = + string_of_kind (Lazy.force cl_type.kind) + +and string_of_component_type cpnt_type = + string_of_class_specifier (Lazy.force cpnt_type.base_class) + +and string_of_variability var = match var with + | Continuous -> "continuous" + | Discrete -> "discrete" + | Parameter -> "parameter" + | Constant -> "constant" + +and string_of_causality c = match c with + | Acausal -> "" + | Input -> "input" + | Output -> "output" + +and string_of_predefined_type predef_type = + string_of_base_type predef_type.base_type + +and string_of_base_type base_type = match base_type with + | BooleanType -> "Boolean" + | IntegerType -> "Integer" + | RealType -> "Real" + | StringType -> "String" + | EnumerationType enum_elts -> string_of_enumeration_type enum_elts + +and string_of_enumeration_type ss = + let rec string_of_enumeration_type' ss = match ss with + | [] -> "" + | [s] -> s + | s :: ss -> s ^ ", " ^ (string_of_enumeration_type' ss) in + "enumeration(" ^ (string_of_enumeration_type' ss) ^ ")" + +and string_of_element_nature = function + | ComponentElement _ -> "_ComponentElement" + | ClassElement _ -> "_ClassElement" + | ComponentTypeElement _ -> "_ComponentTypeElement" + | PredefinedTypeElement _ -> "_PredefinedTypeElement" diff --git a/scilab/modules/scicos/src/translator/exceptionHandling/errorDico.ml b/scilab/modules/scicos/src/translator/exceptionHandling/errorDico.ml index 8baa806..784ebd3 100644 --- a/scilab/modules/scicos/src/translator/exceptionHandling/errorDico.ml +++ b/scilab/modules/scicos/src/translator/exceptionHandling/errorDico.ml @@ -1,158 +1,158 @@ -(* - * Translator from Modelica 2.x to flat Modelica - * - * Copyright (C) 2005 - 2007 Imagine S.A. - * For more information or commercial use please contact us at www.amesim.com - * - * This program is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. - * - *) - -(* Compilation error dictionary - @author D. TALBI - @since 05/02/2007 - *) - -type error_description = - { - err_msg: string list; - err_info: (string * string) list; - err_ctx: err_ctx - } - -and err_ctx = - { - path: Instantiation.path; - location: Parser.location; - instance_nature: Instantiation.instance_nature - } - -exception GenericError of error_description - -(* list of compilation errors*) -let ccodes = [ - ("_UnknownIdentifier", "0001"); - ("_EnumTypeDefWithDuplicLit", "0002"); - ("_EncapsulatedCannotBeAppliedTo", "0003"); - ("_InvalidTypeDef", "0004"); - ("_UnspecifiedEnumLits", "0005"); - ("_NotYetImplemented", "0006"); - ("_UnsupportedFeature", "0007"); (*to be documented*) - ("_TypeConflictsInAssign", "0008"); (*to be documented*) - ("_OperBetweenScalarAndArray", "0009"); - ("_ArrayDimMustAgreeToPerform", "0010"); - ("_FuncCallWithDuplicateArg", "0011"); - ("_TooManyArgsInFuncCall", "0012"); - ("_MixedPositAndNamedFuncArgPass", "0013"); - ("_TypeInconsistWithComparOper", "0014"); - ("_EquTermsNotOfTheSameType", "0015"); - ("_NonInputFuncArgElem", "0016"); - ("_OperAppliedToNonNumericExpr", "0017"); - ("_ArrayDimsNonCompatibleWithMult", "0018"); - ("_PowerOperOnNonSquareArray", "0019"); - ("_NonBooleanIfCondExpr", "0020"); - ("_TypeConflictsInIfAlternExprs", "0021"); - ("_OperAppliedToNonBoolExpr", "0022"); - ("_TypeInconsistentWithDivOper", "0023"); - ("_ElemExpected", "0024"); - ("_FinalElemModifNotAllowed", "0025"); - ("_TypeConflictsInVectorExpr", "0026"); - ("_EachAppliedToNonArrayElem", "0027"); - ("_InvalidExprInElemModif", "0028"); - ("_ClassElemFoundInExpr", "0029"); - ("_ArrayDimMismatchInEqu", "0030"); - ("_InvalidKeyWordEndInExpr", "0031"); - ("_InvalidTypeInRangeExpr", "0032"); - ("_InvalidExtensionDef", "0033"); - ("_InvalidUseOfEnumKeyword", "0034"); - ("_UseOfTypePrefixInShortClassDef", "0035"); - ("_UseOfSubsInShortClassDef", "0036"); - ("_NonEmptyFuncCallUsedAsAnEqu", "0037"); - ("_DuplicatedModifOfElem", "0038"); - ("_InvalidClassElemModif", "0039"); - ("_CannotAccessProtectElem", "0040"); - ("_CannotAccessOuterElem", "0041"); - ("_CannotSubscriptANonArrayTypeElem", "0042"); - ("_NonIntegerArraySubscript", "0043"); - ("_RangeStepValueCannotBeNull", "0044"); - ("_CannotInheritFrom", "0045"); - ("_AlreadyDeclaredInParentClass", "0046"); - ("_InheritFromDiffClassKindsNotAllowed", "0047"); - ("_InheritFromFunctionNotAllowed", "0048"); - ("_InvalidAnnOfInvFunc", "0049"); - ("_CannotUseCausPrefixInGenClass", "0050"); - ("_InvalidTypeOfArgInConnectStat", "0051"); - ("_CannotConnectFlowAndNonFlowComp", "0052"); - ("_InvalidTypeOfWhenCond", "0053"); - ("_InstanceUsedInConnection", "0054"); - ("_WhenClausesCannotBeNested", "0055"); - ("_InvalidWhenEquation", "0056"); - ("_WhenConditionMustBeDiscrete", "0057"); - ("_ArgTypeMismatch", "0058"); - ("_VariabilityConflicts", "0059"); (*to be documented*) - ("_CannotUseNamedArgWithBuiltInOper", "0060"); - ("_OperArgMustBeAVar", "0061"); - ("_ArgVariabilityMismatch", "0062"); - ("_EquNotAllowedInTheDefOf", "0063"); - ("_OperCannotBeUsedWithinFuncDef", "0064"); - ("_ArgDimMismatchInVectCall", "0065"); - ("_ArgDimMismatch", "0066"); - ("_TooFewArgsInFuncCall", "0067"); - ("_LHSOfDiscreteEquMustBeAVar", "0068"); - ("_InvalidVarOfRangeExpr", "0069"); - ("_InvalidExternalFuncName", "0070"); (*to be documented*) - ("_InvalidArgOfExternalCall", "0071"); (*to be documented*) - ("_DuplicateDeclarationOfElement", "0072"); (* to be documented *) - ("_InvalidArgOfOper", "0096"); (*to be documented*) - ("_InvalidInteger", "0097") (*to be documented*) - ] - -(* list of instantiation errors*) -let icodes = [ - ("_NotYetImplemented", "1000"); - ("_ZeroRaisedToTheZeroPower", "1001"); - ("_MissingDeclEquForFixedId", "1002"); - ("_RealExponentOfNegativeNumber", "1003"); - ("_ZeroRaisedToNegativePower", "1004"); - ("_CannotAccessToPredefTypeAttrib", "1005"); (*to be documented*) - ("_InvalidCondEquation", "1006"); (*to be documented*) - ("_IndexOutOfBound", "1007"); (*to be documented*) - ("_DivisionByZero", "1008") (*to be documented*) - ] - -(* list of generic errors*) -let gcodes = [ - ("_NotYetImplemented", "2000") - ] - -(* list of syntactic errors*) -let scodes = [ - ("_Unclosed", "3000"); - ("_InvalidMatrixConstruct", "3001"); - ("_InvalidArrayConstruct", "3002"); - ("_SyntaxError", "3003"); - ("_IllegalCharacter", "3004") - ] - -let getCode exn msg = - try - match exn with - | NameResolve.CompilError _ -> List.assoc msg ccodes - | Instantiation.InstantError _ -> List.assoc msg icodes - | GenericError _ -> List.assoc msg gcodes - | Parser.SyntacticError _ -> List.assoc msg scodes - | _ -> "" - with - exn -> "" +(* + * Translator from Modelica 2.x to flat Modelica + * + * Copyright (C) 2005 - 2007 Imagine S.A. + * For more information or commercial use please contact us at www.amesim.com + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. + * + *) + +(* Compilation error dictionary + @author D. TALBI + @since 05/02/2007 + *) + +type error_description = + { + err_msg: string list; + err_info: (string * string) list; + err_ctx: err_ctx + } + +and err_ctx = + { + path: Instantiation.path; + location: Parser.location; + instance_nature: Instantiation.instance_nature + } + +exception GenericError of error_description + +(* list of compilation errors*) +let ccodes = [ + ("_UnknownIdentifier", "0001"); + ("_EnumTypeDefWithDuplicLit", "0002"); + ("_EncapsulatedCannotBeAppliedTo", "0003"); + ("_InvalidTypeDef", "0004"); + ("_UnspecifiedEnumLits", "0005"); + ("_NotYetImplemented", "0006"); + ("_UnsupportedFeature", "0007"); (*to be documented*) + ("_TypeConflictsInAssign", "0008"); (*to be documented*) + ("_OperBetweenScalarAndArray", "0009"); + ("_ArrayDimMustAgreeToPerform", "0010"); + ("_FuncCallWithDuplicateArg", "0011"); + ("_TooManyArgsInFuncCall", "0012"); + ("_MixedPositAndNamedFuncArgPass", "0013"); + ("_TypeInconsistWithComparOper", "0014"); + ("_EquTermsNotOfTheSameType", "0015"); + ("_NonInputFuncArgElem", "0016"); + ("_OperAppliedToNonNumericExpr", "0017"); + ("_ArrayDimsNonCompatibleWithMult", "0018"); + ("_PowerOperOnNonSquareArray", "0019"); + ("_NonBooleanIfCondExpr", "0020"); + ("_TypeConflictsInIfAlternExprs", "0021"); + ("_OperAppliedToNonBoolExpr", "0022"); + ("_TypeInconsistentWithDivOper", "0023"); + ("_ElemExpected", "0024"); + ("_FinalElemModifNotAllowed", "0025"); + ("_TypeConflictsInVectorExpr", "0026"); + ("_EachAppliedToNonArrayElem", "0027"); + ("_InvalidExprInElemModif", "0028"); + ("_ClassElemFoundInExpr", "0029"); + ("_ArrayDimMismatchInEqu", "0030"); + ("_InvalidKeyWordEndInExpr", "0031"); + ("_InvalidTypeInRangeExpr", "0032"); + ("_InvalidExtensionDef", "0033"); + ("_InvalidUseOfEnumKeyword", "0034"); + ("_UseOfTypePrefixInShortClassDef", "0035"); + ("_UseOfSubsInShortClassDef", "0036"); + ("_NonEmptyFuncCallUsedAsAnEqu", "0037"); + ("_DuplicatedModifOfElem", "0038"); + ("_InvalidClassElemModif", "0039"); + ("_CannotAccessProtectElem", "0040"); + ("_CannotAccessOuterElem", "0041"); + ("_CannotSubscriptANonArrayTypeElem", "0042"); + ("_NonIntegerArraySubscript", "0043"); + ("_RangeStepValueCannotBeNull", "0044"); + ("_CannotInheritFrom", "0045"); + ("_AlreadyDeclaredInParentClass", "0046"); + ("_InheritFromDiffClassKindsNotAllowed", "0047"); + ("_InheritFromFunctionNotAllowed", "0048"); + ("_InvalidAnnOfInvFunc", "0049"); + ("_CannotUseCausPrefixInGenClass", "0050"); + ("_InvalidTypeOfArgInConnectStat", "0051"); + ("_CannotConnectFlowAndNonFlowComp", "0052"); + ("_InvalidTypeOfWhenCond", "0053"); + ("_InstanceUsedInConnection", "0054"); + ("_WhenClausesCannotBeNested", "0055"); + ("_InvalidWhenEquation", "0056"); + ("_WhenConditionMustBeDiscrete", "0057"); + ("_ArgTypeMismatch", "0058"); + ("_VariabilityConflicts", "0059"); (*to be documented*) + ("_CannotUseNamedArgWithBuiltInOper", "0060"); + ("_OperArgMustBeAVar", "0061"); + ("_ArgVariabilityMismatch", "0062"); + ("_EquNotAllowedInTheDefOf", "0063"); + ("_OperCannotBeUsedWithinFuncDef", "0064"); + ("_ArgDimMismatchInVectCall", "0065"); + ("_ArgDimMismatch", "0066"); + ("_TooFewArgsInFuncCall", "0067"); + ("_LHSOfDiscreteEquMustBeAVar", "0068"); + ("_InvalidVarOfRangeExpr", "0069"); + ("_InvalidExternalFuncName", "0070"); (*to be documented*) + ("_InvalidArgOfExternalCall", "0071"); (*to be documented*) + ("_DuplicateDeclarationOfElement", "0072"); (* to be documented *) + ("_InvalidArgOfOper", "0096"); (*to be documented*) + ("_InvalidInteger", "0097") (*to be documented*) + ] + +(* list of instantiation errors*) +let icodes = [ + ("_NotYetImplemented", "1000"); + ("_ZeroRaisedToTheZeroPower", "1001"); + ("_MissingDeclEquForFixedId", "1002"); + ("_RealExponentOfNegativeNumber", "1003"); + ("_ZeroRaisedToNegativePower", "1004"); + ("_CannotAccessToPredefTypeAttrib", "1005"); (*to be documented*) + ("_InvalidCondEquation", "1006"); (*to be documented*) + ("_IndexOutOfBound", "1007"); (*to be documented*) + ("_DivisionByZero", "1008") (*to be documented*) + ] + +(* list of generic errors*) +let gcodes = [ + ("_NotYetImplemented", "2000") + ] + +(* list of syntactic errors*) +let scodes = [ + ("_Unclosed", "3000"); + ("_InvalidMatrixConstruct", "3001"); + ("_InvalidArrayConstruct", "3002"); + ("_SyntaxError", "3003"); + ("_IllegalCharacter", "3004") + ] + +let getCode exn msg = + try + match exn with + | NameResolve.CompilError _ -> List.assoc msg ccodes + | Instantiation.InstantError _ -> List.assoc msg icodes + | GenericError _ -> List.assoc msg gcodes + | Parser.SyntacticError _ -> List.assoc msg scodes + | _ -> "" + with + exn -> "" diff --git a/scilab/modules/scicos/src/translator/exceptionHandling/msgDico.ml b/scilab/modules/scicos/src/translator/exceptionHandling/msgDico.ml index 7c9efb4..bec369d 100644 --- a/scilab/modules/scicos/src/translator/exceptionHandling/msgDico.ml +++ b/scilab/modules/scicos/src/translator/exceptionHandling/msgDico.ml @@ -1,462 +1,462 @@ -(* - * Translator from Modelica 2.x to flat Modelica - * - * Copyright (C) 2005 - 2007 Imagine S.A. - * For more information or commercial use please contact us at www.amesim.com - * - * This program is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. - * - *) - -(* Compilation message translation dictionary *) - -let msgs = [ - ("_UnknownIdentifier", - [("ENG", "Unknown identifier")]); - ("_EnumTypeDefWithDuplicLit", - [("ENG", "Enumeration type definition with duplicated literal")]); - ("_NotYetImplemented", - [("ENG", "Use of not yet implemented feature:")]); - ("_EncapsulatedCannotBeAppliedTo", - [("ENG", "\"encapsulated\" keyword cannot be applied to")]); - ("_UnspecifiedEnumLits", - [("ENG", "Enumeration literals not specified")]); - ("_CommandLine", - [("ENG", "command line")]); - ("_CharacterPosition", - [("ENG", "Character position")]); - ("_LineNumber", - [("ENG", "Line number")]); - ("_ColumnNumber", - [("ENG", "Column number")]); - ("_Context", - [("ENG", "Context")]); - ("_UntranslatedText", - [("ENG", "Untranslated text")]); - ("_NonBooleanIfCondExpr", - [("ENG", "Non-Boolean \"if\" condition expression")]); - ("_TypeConflictsInIfAlternExprs", - [("ENG", "If alternative expressions must be of the same type")]); - ("_InvalidTypeInRangeExpr", - [("ENG", "Invalid type of element in range expression")]); - ("_NonIntegerRangeExpr", - [("ENG", "Non-integer range expression")]); - ("_TypeConflictsInVectorExpr", - [("ENG", "Elements of different types in vector expression")]); - ("_NonPredefTypeVectorExpr", - [("ENG", "Only vector expressions of predefined type elements are supported")]); - ("_ArrayDimMustAgreeToPerform", - [("ENG", "Array dimensions must agree to perform")]); - ("_ImplicitIterRange", - [("ENG", "Implicit iteration range")]); - ("_UnaryOperPLUS", - [("ENG", "Unary operator +")]); - ("_MatrixExpr", - [("ENG", "Matrix expression")]); - ("_BinaryOperDIFF", - [("ENG", "Binary operator <>")]); - ("_BinaryOperEQUEQU", - [("ENG", "Binary operator ==")]); - ("_TopLevelExpr", - [("ENG", "expression statement")]); - ("_TopLevelAlgorithm", - [("ENG", "algorithmic statement")]); - ("_WithinClause", - [("ENG", "within clause")]); - ("_ImportClause", - [("ENG", "import clause")]); - ("_InvalidTypeDef", - [("ENG", "Invalid \"type\" definition")]); - ("_ShortClassDef", - [("ENG", "Short class definition")]); - ("_ClassDefByExtension", - [("ENG", "Class definition by extension")]); - ("_InvalidUseOfEnumKeyword", - [("ENG", "Invalid use of \"enumeration\" keyword")]); - ("_ClassExtendsDef", - [("ENG", "Class definition by extension")]); - ("_OperAppliedToNonNumericExpr", - [("ENG", "operator applied to non numeric expression")]); - ("_PowerOperOnNonSquareArray", - [("ENG", "Cannot perform power operation on non square array")]); - ("_ArrayDimMustAgreeToPerform", - [("ENG", "Array dimensions must agree to perform")]); - ("_EachAppliedToNonArrayElem", - [("ENG", "Cannot apply \"each\" keyword to non-array type element")]); - ("_EquTermsNotOfTheSameType", - [("ENG", "Equation terms must be of the same type")]); - ("_ClassElemFoundInExpr", - [("ENG", "Component element expected, but class element found")]); - ("_InvalidExtensionDef", - [("ENG", "Invalid extension definition")]); - ("_VariablityConflictsInCompDef", - [("ENG", "Variability conflicts in component definition")]); - ("_CausalityConflictsInCompDef", - [("ENG", "Causality conflicts in component definition")]); - ("_TypeConflictsInAssign", - [("ENG", "Type conflicts in assignment expression")]); - ("_InvalidExprInElemModif", - [("ENG", "Invalid expression in element modification")]); - ("_FieldAccessInElemModifExpr", - [("ENG", "Field access in element modification expression")]); - ("_ElementRedeclaration", - [("ENG", "Element redeclaration")]); - ("_InvalidTypeOfClassSpec", - [("ENG", "Invalid type of class specifier")]); - ("_RedeclarePredefTypeAttrib", - [("ENG", "Redeclaration not allowed for predefined type attributes")]); - ("_InvalidClassElemModif", - [("ENG", "Invalid modification of class element")]); - ("_FinalElemModifNotAllowed", - [("ENG", "Cannot modify final element")]); - ("_InvalidElemModifDef", - [("ENG", "Invalid element modification definition")]); - ("_ArrayDimMismatchInEqu", - [("ENG", "Array dimensions do not agree in equation")]); - ("_ComponentTypeEqu", - [("ENG", "Component type equation")]); - ("_AlgoClause", - [("ENG", "Algorithm clause")]); - ("_InvalidKeyWordEndInExpr", - [("ENG", "Invalid use of expression \"end\"")]); - ("_InvalidTypeOfFuncValueInEqu", - [("ENG", "Invalid type of function value in equation")]); - ("_FuncArgumentReduction", - [("ENG", "Function argument reduction")]); - ("_TooManyArgsInFuncCall", - [("ENG", "Too many arguments in function call")]); - ("_FuncCallWithDuplicateArg", - [("ENG", "Function call with duplicate named argument")]); - ("_MixedPositAndNamedFuncArgPass", - [("ENG", "Mixed positional and named function argument passing not allowed")]); - ("_NonInputFuncArgElem", - [("ENG", "Function called with non input argument")]); - ("_NoInnerDeclForOuterElem", - [("ENG", "Missed inner declaration for outer element")]); - ("_BlockElem", - [("ENG", "Block element")]); - ("_ExpandableConnector", - [("ENG", "Expandable connector")]); - ("_PredefinedTypeAttribModif", - [("ENG", "Modification of predefined type attribute")]); - ("_UnsupportedFeature", - [("ENG", "Use of unsupported feature:")]); (*to be documented*) - ("_OperAppliedToNonBoolExpr", - [("ENG", "operator applied to non-Boolean expression")]); - ("_TypeDef", - [("ENG", "\"type\" definition")]); - ("_AddOper", - [("ENG", "addition operation")]); - ("_TypeInconsistWithComparOper", - [("ENG", "Type of operands inconsistent with comparison operation")]); - ("_OperBetweenScalarAndArray", - [("ENG", "operator between scalar and array type elements")]); - ("_Addition", - [("ENG", "addition")]); - ("_Subtraction", - [("ENG", "subtraction")]); - ("_TypeInconsistentWithDivOper", - [("ENG", "Type of operands inconsistent with division operation")]); - ("_ArrayDimsNonCompatibleWithMult", - [("ENG", "Arrays do not have compatible dimensions to be multiplied")]); - ("_ERROR", - [("ENG", "ERROR")]); - ("_ElemExpected", - [("ENG", "element expected")]); - ("_UseOfTypePrefixInShortClassDef", - [("ENG", "Use of type prefix not allowed in short class definition")]); - ("_UseOfSubsInShortClassDef", - [("ENG", "Use of subscripts not allowed in short class definition")]); - ("_NonEmptyFuncCallUsedAsAnEqu", - [("ENG", "Non-empty function call cannot be used as an equation")]); - ("_DuplicatedModifOfElem", - [("ENG", "Duplicated modification of element")]); - ("_ComponentTypeElemInstant", - [("ENG", "Component type element instantiation")]); - ("_PredefinedTypeElemInstant", - [("ENG", "Predefined type element instantiation")]); - ("_Component", - [("ENG", "Component")]); - ("_CannotAccessProtectElem", - [("ENG", "Cannot access protected element")]); - ("_CannotAccessOuterElem", - [("ENG", "Cannot access outer element")]); - ("_UnknownFunction", - [("ENG", "Unknown function")]); - ("_ZeroRaisedToTheZeroPower", - [("ENG", "Zero raised to the zero power")]); - ("_IntegerRaisedToIntegerPower", - [("ENG", "Integer raised to an integer power")]); - ("_RealRaisedToIntegerPower", - [("ENG", "Real raised to an integer power")]); - ("_VectorRaisedToIntegerPower", - [("ENG", "Vector raised to an integer power")]); - ("_NonIntegerArrayDim", - [("ENG", "Non-Integer array dimension")]); - ("_EnumType", - [("ENG", "Enumeration type")]); - ("_StringType", - [("ENG", "String type")]); - ("_BooleanType", - [("ENG", "Boolean type")]); - ("_BooleanOperator", - [("ENG", "Boolean operator")]); - ("_DynamicArrayType", - [("ENG", "Dynamic array type")]); - ("_StaticArrayType", - [("ENG", "Static array type")]); - ("_InstanceType", - [("ENG", "Instance type")]); - ("_ConditionalEqu", - [("ENG", "Conditional equation")]); - ("_FieldAccessExpr", - [("ENG", "Field access expression")]); - ("_IndexedAccessExpr", - [("ENG", "Indexed access expression")]); - ("_RangeExpr", - [("ENG", "Range expression")]); - ("_Expr", - [("ENG", "Expression")]); - ("_ExprOfType", - [("ENG", "Expression of type")]); - ("_TupleExpr", - [("ENG", "Tuple expression")]); - ("_VectorReduct", - [("ENG", "Vector reduction")]); - ("_LoopVar", - [("ENG", "Loop variable")]); - ("_PredefinedTypeClassRef", - [("ENG", "Predefined type class reference")]); - ("_NonExternalCallClassRef", - [("ENG", "Use of class reference in expression is allowed only for external function call")]); - ("_ExternalProcedureCall", - [("ENG", "External procedure call")]); - ("_ExternalCallToLanguage", - [("ENG", "External call to language")]); - ("_ExternalCallWithLeftHandSideExpr", - [("ENG", "External call with left hand side expression")]); - ("_AssignExprInElemModif", - [("ENG", "Assignment expression in element modification")]); - ("_CannotSubscriptANonArrayTypeElem", - [("ENG", "Cannot subscript a non array type element")]); - ("_NonIntegerArraySubscript", - [("ENG", "Non-Integer array subscript")]); - ("_RangeStepValueCannotBeNull", - [("ENG", "Range step value cannot be null")]); - ("_TypeOfA", - [("ENG", "Type of A")]); - ("_TypeOfB", - [("ENG", "Type of B")]); - ("_Source", - [("ENG", "Source")]); - ("_ClassName", - [("ENG", "Class name")]); - ("_FunctionCallExpr", - [("ENG", "Function call expression")]); - ("_VectorExpr", - [("ENG", "Vector expression")]); - ("_ExprKind", - [("ENG", "Expression kind")]); - ("_TypeOfThenBranche", - [("ENG", "Type of then branche")]); - ("_TypeOfElseBranche", - [("ENG", "Type of else branche")]); - ("_TypePrefix", - [("ENG", "Type prefix")]); - ("_ElemFound", - [("ENG", "Element found")]); - ("_TypeSpecifierVariability", - [("ENG", "Type specifier variability")]); - ("_TypeSpecifierCausality", - [("ENG", "Type specifier causality")]); - ("_TypeOfCondition", - [("ENG", "Type of \"condition\"")]); - ("_TypeFound", - [("ENG", "Type found")]); - ("_ComponentElement", - [("ENG", "Component element")]); - ("_ExpectedType", - [("ENG", "Expected type")]); - ("_ClassElement", - [("ENG", "Class element")]); - ("_ArrayType", - [("ENG", "Array type")]); - ("_ClassSpecifier", - [("ENG", "Class specifier")]); - ("_TypeOfFuncValue", - [("ENG", "Type of function value")]); - ("_TypeOfFunctionOutput", - [("ENG", "Type of function output")]); - ("_CannotInheritFrom", - [("ENG", "Cannot inherit from")]); - ("_ComponentTypeElement", - [("ENG", "Component type element")]); - ("_PredefinedTypeElement", - [("ENG", "Predefined type element")]); - ("_AlreadyDeclaredInParentClass", - [("ENG", "already declared in parent class")]); - ("_InheritFromDiffClassKindsNotAllowed", - [("ENG", "Inheritance from different class kinds not allowed")]); - ("_MismatchingTypes", - [("ENG", "Mismatching types")]); - ("_InheritFromFunctionNotAllowed", - [("ENG", "Inheritance from function not allowed")]); - ("_InvalidAnnOfInvFunc", - [("ENG", "Invalid annotation of inverse functions:")]); - ("_RedeclarationNotAllowed", - [("ENG", "Redeclaration not allowed")]); - ("_UseOfEachKeywordNotAllowed", - [("ENG", "Use of \"each\" keyword not allowed")]); - ("_UseOfFinalKeywordNotAllowed", - [("ENG", "Use of \"final\" keyword not allowed")]); - ("_UnspecifiedModification", - [("ENG", "Unspecified modification")]); - ("_InvalidModifExpr", - [("ENG", "Invalid modification expression")]); - ("_InvalidFuncCallExpr", - [("ENG", "Invalid function call expression")]); - ("_InvalidTypeOfFuncCallExpr", - [("ENG", "Invalid type of function call expression")]); - ("_ClassType", - [("ENG", "Class type")]); - ("_Function", - [("ENG", "Function")]); - ("_FuncArgReductionNotAllowed", - [("ENG", "Function argument reduction not allowed")]); - ("_CannotUseUnnamedFuncArg", - [("ENG", "Cannot use unnamed function argument")]); - ("_InvalidFuncArgModif", - [("ENG", "Invalid function argument modification")]); - ("_UnknownArgName", - [("ENG", "Unknown argument name")]); - ("_CannotUseCausPrefixInGenClass", - [("ENG", "Input or output component found in generic class")]); - ("_FuncDefInNonInstantiatedClass", - [("ENG", "Function defined in non instantiated class")]); - ("_InvalidTypeOfArgInConnectStat", - [("ENG", "Invalid type of argument in connect statement")]); - ("_CannotConnectFlowAndNonFlowComp", - [("ENG", "Cannot connect flow and non-flow components")]); - ("_InvalidTypeOfWhenCond", - [("ENG", "Invalid type of when condition")]); - ("_NameResolution", - [("ENG", "Name resolution")]); - ("_InstantiationOfComponent", - [("ENG", "Instantiation of component")]); - ("_CodeGenerationForComponent", - [("ENG", "Code generation for component")]); - ("_ExecutionStep", - [("ENG", "Execution step")]); - ("_MissingDeclEquForFixedId", - [("ENG", "Missing declaration equation for fixed identifier")]); - ("_ComponentFuncInvocation", - [("ENG", "Component function invocation")]); - ("_FuncWithManyOutputs", - [("ENG", "Function with many outputs")]); - ("_InstantiationOfClass", - ["ENG", "Instantiation of class"]); - ("_CodeGenerationForClass", - ["ENG", "Code generation for class"]); - ("_InstanceUsedInConnection", - [("ENG", "instance used in connection statement")]); - ("_Unclosed", - [("ENG", "Unclosed")]); - ("_InvalidMatrixConstruct", - [("ENG", "Invalid matrix construction")]); - ("_InvalidArrayConstruct", - [("ENG", "Invalid array construction")]); - ("_SyntaxError", - [("ENG", "Syntax error")]); - ("_SyntacticAnalysis", - [("ENG", "Syntactic analysis")]); - ("_PredefType", - [("ENG", "Predefined type")]); - ("_WhenClausesCannotBeNested", - [("ENG", "When clauses cannot be nested")]); - ("_InvalidWhenEquation", - [("ENG", "Invalid form of equation within when clause")]); - ("_WhenConditionMustBeDiscrete", - [("ENG", "When condition must be discrete-time expression")]); - ("_ArgTypeMismatch", - [("ENG", "Argument type mismatch")]); - ("_VariabilityOfA", - [("ENG", "Variability of A")]); - ("_VariabilityOfB", - [("ENG", "Variability of B")]); - ("_VariabilityConflicts", - [("ENG", "Variability conflicts")]); - ("_CannotUseNamedArgWithBuiltInOper", - [("ENG", "Cannot use named argument with a built-in operator or function")]); - ("_OperArgMustBeAVar", - [("ENG", "operator argument must be a variable")]); - ("_ArgVariabilityMismatch", - [("ENG", "Argument variability mismatch")]); - ("_ExpectedVariability", - [("ENG", "Expected variability")]); - ("_VariabilityFound", - [("ENG", "Variability found")]); - ("_EquNotAllowedInTheDefOf", - [("ENG", "Equations not allowed in the definition of")]); - ("_OperCannotBeUsedWithinFuncDef", - [("ENG", "operator cannot be used within function definition")]); - ("_ArgDimMismatchInVectCall", - [("ENG", "Arguments dimensions mismatch in vectorized function call")]); - ("_ArgDimMismatch", - [("ENG", "Argument dimension mismatch")]); - ("_TooFewArgsInFuncCall", - [("ENG", "Too few arguments in function call")]); - ("_LHSOfDiscreteEquMustBeAVar", - [("ENG", "Left hand side of discrete equation must be a variable")]); - ("_InvalidVarOfRangeExpr", - [("ENG", "Invalid variability of range expression")]); - ("_RealExponentOfNegativeNumber", - [("ENG", "Real exponentiation of negative number")]); - ("_ZeroRaisedToNegativePower", - [("ENG", "Zero raised to negative power")]); - ("_IllegalCharacter", - [("ENG", "Illegal character")]); (*to be documented*) - ("_InvalidExternalFuncName", - [("ENG", "Invalid external function name")]); (*to be documented*) - ("_LHSOfExternalCall", - [("ENG", "Left hand side of external call")]); (*to be documented*) - ("_InvalidArgOfExternalCall", - [("ENG", "Invalid argument of external call")]); (*to be documented*) - ("_CannotAccessToPredefTypeAttrib", - [("ENG", "Cannot access predefined type attribute")]); - ("_InvalidCondEquation", - [("ENG", "Invalid conditional equation")]); - ("_IndexOutOfBound", - [("ENG", "Index out of bound")]); - ("_DivisionByZero", - [("ENG", "Division by zero")]); - ("_PredefinedOperator", - [("ENG", "Predefined operator")]); - ("_InvalidArgOfOper", - [("ENG", "Invalid argument of operator")]); - ("_UnsupportedDerOperArg", - [("ENG", "Unsupported \"der\" operator argument")]); - ("_InvalidInteger", - [("ENG", "Invalid Integer representation")]); - ("_NonSupportedTypeOfFuncInOut", - [("ENG", "Non supported type of function input or output")]); - ("_DuplicateDeclarationOfElement", - [("ENG", "Duplicate declaration of element")]) (* to be documented *) - ] - -let translate msg = - try - List.assoc "ENG" (List.assoc msg msgs) - with - exn -> msg; +(* + * Translator from Modelica 2.x to flat Modelica + * + * Copyright (C) 2005 - 2007 Imagine S.A. + * For more information or commercial use please contact us at www.amesim.com + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. + * + *) + +(* Compilation message translation dictionary *) + +let msgs = [ + ("_UnknownIdentifier", + [("ENG", "Unknown identifier")]); + ("_EnumTypeDefWithDuplicLit", + [("ENG", "Enumeration type definition with duplicated literal")]); + ("_NotYetImplemented", + [("ENG", "Use of not yet implemented feature:")]); + ("_EncapsulatedCannotBeAppliedTo", + [("ENG", "\"encapsulated\" keyword cannot be applied to")]); + ("_UnspecifiedEnumLits", + [("ENG", "Enumeration literals not specified")]); + ("_CommandLine", + [("ENG", "command line")]); + ("_CharacterPosition", + [("ENG", "Character position")]); + ("_LineNumber", + [("ENG", "Line number")]); + ("_ColumnNumber", + [("ENG", "Column number")]); + ("_Context", + [("ENG", "Context")]); + ("_UntranslatedText", + [("ENG", "Untranslated text")]); + ("_NonBooleanIfCondExpr", + [("ENG", "Non-Boolean \"if\" condition expression")]); + ("_TypeConflictsInIfAlternExprs", + [("ENG", "If alternative expressions must be of the same type")]); + ("_InvalidTypeInRangeExpr", + [("ENG", "Invalid type of element in range expression")]); + ("_NonIntegerRangeExpr", + [("ENG", "Non-integer range expression")]); + ("_TypeConflictsInVectorExpr", + [("ENG", "Elements of different types in vector expression")]); + ("_NonPredefTypeVectorExpr", + [("ENG", "Only vector expressions of predefined type elements are supported")]); + ("_ArrayDimMustAgreeToPerform", + [("ENG", "Array dimensions must agree to perform")]); + ("_ImplicitIterRange", + [("ENG", "Implicit iteration range")]); + ("_UnaryOperPLUS", + [("ENG", "Unary operator +")]); + ("_MatrixExpr", + [("ENG", "Matrix expression")]); + ("_BinaryOperDIFF", + [("ENG", "Binary operator <>")]); + ("_BinaryOperEQUEQU", + [("ENG", "Binary operator ==")]); + ("_TopLevelExpr", + [("ENG", "expression statement")]); + ("_TopLevelAlgorithm", + [("ENG", "algorithmic statement")]); + ("_WithinClause", + [("ENG", "within clause")]); + ("_ImportClause", + [("ENG", "import clause")]); + ("_InvalidTypeDef", + [("ENG", "Invalid \"type\" definition")]); + ("_ShortClassDef", + [("ENG", "Short class definition")]); + ("_ClassDefByExtension", + [("ENG", "Class definition by extension")]); + ("_InvalidUseOfEnumKeyword", + [("ENG", "Invalid use of \"enumeration\" keyword")]); + ("_ClassExtendsDef", + [("ENG", "Class definition by extension")]); + ("_OperAppliedToNonNumericExpr", + [("ENG", "operator applied to non numeric expression")]); + ("_PowerOperOnNonSquareArray", + [("ENG", "Cannot perform power operation on non square array")]); + ("_ArrayDimMustAgreeToPerform", + [("ENG", "Array dimensions must agree to perform")]); + ("_EachAppliedToNonArrayElem", + [("ENG", "Cannot apply \"each\" keyword to non-array type element")]); + ("_EquTermsNotOfTheSameType", + [("ENG", "Equation terms must be of the same type")]); + ("_ClassElemFoundInExpr", + [("ENG", "Component element expected, but class element found")]); + ("_InvalidExtensionDef", + [("ENG", "Invalid extension definition")]); + ("_VariablityConflictsInCompDef", + [("ENG", "Variability conflicts in component definition")]); + ("_CausalityConflictsInCompDef", + [("ENG", "Causality conflicts in component definition")]); + ("_TypeConflictsInAssign", + [("ENG", "Type conflicts in assignment expression")]); + ("_InvalidExprInElemModif", + [("ENG", "Invalid expression in element modification")]); + ("_FieldAccessInElemModifExpr", + [("ENG", "Field access in element modification expression")]); + ("_ElementRedeclaration", + [("ENG", "Element redeclaration")]); + ("_InvalidTypeOfClassSpec", + [("ENG", "Invalid type of class specifier")]); + ("_RedeclarePredefTypeAttrib", + [("ENG", "Redeclaration not allowed for predefined type attributes")]); + ("_InvalidClassElemModif", + [("ENG", "Invalid modification of class element")]); + ("_FinalElemModifNotAllowed", + [("ENG", "Cannot modify final element")]); + ("_InvalidElemModifDef", + [("ENG", "Invalid element modification definition")]); + ("_ArrayDimMismatchInEqu", + [("ENG", "Array dimensions do not agree in equation")]); + ("_ComponentTypeEqu", + [("ENG", "Component type equation")]); + ("_AlgoClause", + [("ENG", "Algorithm clause")]); + ("_InvalidKeyWordEndInExpr", + [("ENG", "Invalid use of expression \"end\"")]); + ("_InvalidTypeOfFuncValueInEqu", + [("ENG", "Invalid type of function value in equation")]); + ("_FuncArgumentReduction", + [("ENG", "Function argument reduction")]); + ("_TooManyArgsInFuncCall", + [("ENG", "Too many arguments in function call")]); + ("_FuncCallWithDuplicateArg", + [("ENG", "Function call with duplicate named argument")]); + ("_MixedPositAndNamedFuncArgPass", + [("ENG", "Mixed positional and named function argument passing not allowed")]); + ("_NonInputFuncArgElem", + [("ENG", "Function called with non input argument")]); + ("_NoInnerDeclForOuterElem", + [("ENG", "Missed inner declaration for outer element")]); + ("_BlockElem", + [("ENG", "Block element")]); + ("_ExpandableConnector", + [("ENG", "Expandable connector")]); + ("_PredefinedTypeAttribModif", + [("ENG", "Modification of predefined type attribute")]); + ("_UnsupportedFeature", + [("ENG", "Use of unsupported feature:")]); (*to be documented*) + ("_OperAppliedToNonBoolExpr", + [("ENG", "operator applied to non-Boolean expression")]); + ("_TypeDef", + [("ENG", "\"type\" definition")]); + ("_AddOper", + [("ENG", "addition operation")]); + ("_TypeInconsistWithComparOper", + [("ENG", "Type of operands inconsistent with comparison operation")]); + ("_OperBetweenScalarAndArray", + [("ENG", "operator between scalar and array type elements")]); + ("_Addition", + [("ENG", "addition")]); + ("_Subtraction", + [("ENG", "subtraction")]); + ("_TypeInconsistentWithDivOper", + [("ENG", "Type of operands inconsistent with division operation")]); + ("_ArrayDimsNonCompatibleWithMult", + [("ENG", "Arrays do not have compatible dimensions to be multiplied")]); + ("_ERROR", + [("ENG", "ERROR")]); + ("_ElemExpected", + [("ENG", "element expected")]); + ("_UseOfTypePrefixInShortClassDef", + [("ENG", "Use of type prefix not allowed in short class definition")]); + ("_UseOfSubsInShortClassDef", + [("ENG", "Use of subscripts not allowed in short class definition")]); + ("_NonEmptyFuncCallUsedAsAnEqu", + [("ENG", "Non-empty function call cannot be used as an equation")]); + ("_DuplicatedModifOfElem", + [("ENG", "Duplicated modification of element")]); + ("_ComponentTypeElemInstant", + [("ENG", "Component type element instantiation")]); + ("_PredefinedTypeElemInstant", + [("ENG", "Predefined type element instantiation")]); + ("_Component", + [("ENG", "Component")]); + ("_CannotAccessProtectElem", + [("ENG", "Cannot access protected element")]); + ("_CannotAccessOuterElem", + [("ENG", "Cannot access outer element")]); + ("_UnknownFunction", + [("ENG", "Unknown function")]); + ("_ZeroRaisedToTheZeroPower", + [("ENG", "Zero raised to the zero power")]); + ("_IntegerRaisedToIntegerPower", + [("ENG", "Integer raised to an integer power")]); + ("_RealRaisedToIntegerPower", + [("ENG", "Real raised to an integer power")]); + ("_VectorRaisedToIntegerPower", + [("ENG", "Vector raised to an integer power")]); + ("_NonIntegerArrayDim", + [("ENG", "Non-Integer array dimension")]); + ("_EnumType", + [("ENG", "Enumeration type")]); + ("_StringType", + [("ENG", "String type")]); + ("_BooleanType", + [("ENG", "Boolean type")]); + ("_BooleanOperator", + [("ENG", "Boolean operator")]); + ("_DynamicArrayType", + [("ENG", "Dynamic array type")]); + ("_StaticArrayType", + [("ENG", "Static array type")]); + ("_InstanceType", + [("ENG", "Instance type")]); + ("_ConditionalEqu", + [("ENG", "Conditional equation")]); + ("_FieldAccessExpr", + [("ENG", "Field access expression")]); + ("_IndexedAccessExpr", + [("ENG", "Indexed access expression")]); + ("_RangeExpr", + [("ENG", "Range expression")]); + ("_Expr", + [("ENG", "Expression")]); + ("_ExprOfType", + [("ENG", "Expression of type")]); + ("_TupleExpr", + [("ENG", "Tuple expression")]); + ("_VectorReduct", + [("ENG", "Vector reduction")]); + ("_LoopVar", + [("ENG", "Loop variable")]); + ("_PredefinedTypeClassRef", + [("ENG", "Predefined type class reference")]); + ("_NonExternalCallClassRef", + [("ENG", "Use of class reference in expression is allowed only for external function call")]); + ("_ExternalProcedureCall", + [("ENG", "External procedure call")]); + ("_ExternalCallToLanguage", + [("ENG", "External call to language")]); + ("_ExternalCallWithLeftHandSideExpr", + [("ENG", "External call with left hand side expression")]); + ("_AssignExprInElemModif", + [("ENG", "Assignment expression in element modification")]); + ("_CannotSubscriptANonArrayTypeElem", + [("ENG", "Cannot subscript a non array type element")]); + ("_NonIntegerArraySubscript", + [("ENG", "Non-Integer array subscript")]); + ("_RangeStepValueCannotBeNull", + [("ENG", "Range step value cannot be null")]); + ("_TypeOfA", + [("ENG", "Type of A")]); + ("_TypeOfB", + [("ENG", "Type of B")]); + ("_Source", + [("ENG", "Source")]); + ("_ClassName", + [("ENG", "Class name")]); + ("_FunctionCallExpr", + [("ENG", "Function call expression")]); + ("_VectorExpr", + [("ENG", "Vector expression")]); + ("_ExprKind", + [("ENG", "Expression kind")]); + ("_TypeOfThenBranche", + [("ENG", "Type of then branche")]); + ("_TypeOfElseBranche", + [("ENG", "Type of else branche")]); + ("_TypePrefix", + [("ENG", "Type prefix")]); + ("_ElemFound", + [("ENG", "Element found")]); + ("_TypeSpecifierVariability", + [("ENG", "Type specifier variability")]); + ("_TypeSpecifierCausality", + [("ENG", "Type specifier causality")]); + ("_TypeOfCondition", + [("ENG", "Type of \"condition\"")]); + ("_TypeFound", + [("ENG", "Type found")]); + ("_ComponentElement", + [("ENG", "Component element")]); + ("_ExpectedType", + [("ENG", "Expected type")]); + ("_ClassElement", + [("ENG", "Class element")]); + ("_ArrayType", + [("ENG", "Array type")]); + ("_ClassSpecifier", + [("ENG", "Class specifier")]); + ("_TypeOfFuncValue", + [("ENG", "Type of function value")]); + ("_TypeOfFunctionOutput", + [("ENG", "Type of function output")]); + ("_CannotInheritFrom", + [("ENG", "Cannot inherit from")]); + ("_ComponentTypeElement", + [("ENG", "Component type element")]); + ("_PredefinedTypeElement", + [("ENG", "Predefined type element")]); + ("_AlreadyDeclaredInParentClass", + [("ENG", "already declared in parent class")]); + ("_InheritFromDiffClassKindsNotAllowed", + [("ENG", "Inheritance from different class kinds not allowed")]); + ("_MismatchingTypes", + [("ENG", "Mismatching types")]); + ("_InheritFromFunctionNotAllowed", + [("ENG", "Inheritance from function not allowed")]); + ("_InvalidAnnOfInvFunc", + [("ENG", "Invalid annotation of inverse functions:")]); + ("_RedeclarationNotAllowed", + [("ENG", "Redeclaration not allowed")]); + ("_UseOfEachKeywordNotAllowed", + [("ENG", "Use of \"each\" keyword not allowed")]); + ("_UseOfFinalKeywordNotAllowed", + [("ENG", "Use of \"final\" keyword not allowed")]); + ("_UnspecifiedModification", + [("ENG", "Unspecified modification")]); + ("_InvalidModifExpr", + [("ENG", "Invalid modification expression")]); + ("_InvalidFuncCallExpr", + [("ENG", "Invalid function call expression")]); + ("_InvalidTypeOfFuncCallExpr", + [("ENG", "Invalid type of function call expression")]); + ("_ClassType", + [("ENG", "Class type")]); + ("_Function", + [("ENG", "Function")]); + ("_FuncArgReductionNotAllowed", + [("ENG", "Function argument reduction not allowed")]); + ("_CannotUseUnnamedFuncArg", + [("ENG", "Cannot use unnamed function argument")]); + ("_InvalidFuncArgModif", + [("ENG", "Invalid function argument modification")]); + ("_UnknownArgName", + [("ENG", "Unknown argument name")]); + ("_CannotUseCausPrefixInGenClass", + [("ENG", "Input or output component found in generic class")]); + ("_FuncDefInNonInstantiatedClass", + [("ENG", "Function defined in non instantiated class")]); + ("_InvalidTypeOfArgInConnectStat", + [("ENG", "Invalid type of argument in connect statement")]); + ("_CannotConnectFlowAndNonFlowComp", + [("ENG", "Cannot connect flow and non-flow components")]); + ("_InvalidTypeOfWhenCond", + [("ENG", "Invalid type of when condition")]); + ("_NameResolution", + [("ENG", "Name resolution")]); + ("_InstantiationOfComponent", + [("ENG", "Instantiation of component")]); + ("_CodeGenerationForComponent", + [("ENG", "Code generation for component")]); + ("_ExecutionStep", + [("ENG", "Execution step")]); + ("_MissingDeclEquForFixedId", + [("ENG", "Missing declaration equation for fixed identifier")]); + ("_ComponentFuncInvocation", + [("ENG", "Component function invocation")]); + ("_FuncWithManyOutputs", + [("ENG", "Function with many outputs")]); + ("_InstantiationOfClass", + ["ENG", "Instantiation of class"]); + ("_CodeGenerationForClass", + ["ENG", "Code generation for class"]); + ("_InstanceUsedInConnection", + [("ENG", "instance used in connection statement")]); + ("_Unclosed", + [("ENG", "Unclosed")]); + ("_InvalidMatrixConstruct", + [("ENG", "Invalid matrix construction")]); + ("_InvalidArrayConstruct", + [("ENG", "Invalid array construction")]); + ("_SyntaxError", + [("ENG", "Syntax error")]); + ("_SyntacticAnalysis", + [("ENG", "Syntactic analysis")]); + ("_PredefType", + [("ENG", "Predefined type")]); + ("_WhenClausesCannotBeNested", + [("ENG", "When clauses cannot be nested")]); + ("_InvalidWhenEquation", + [("ENG", "Invalid form of equation within when clause")]); + ("_WhenConditionMustBeDiscrete", + [("ENG", "When condition must be discrete-time expression")]); + ("_ArgTypeMismatch", + [("ENG", "Argument type mismatch")]); + ("_VariabilityOfA", + [("ENG", "Variability of A")]); + ("_VariabilityOfB", + [("ENG", "Variability of B")]); + ("_VariabilityConflicts", + [("ENG", "Variability conflicts")]); + ("_CannotUseNamedArgWithBuiltInOper", + [("ENG", "Cannot use named argument with a built-in operator or function")]); + ("_OperArgMustBeAVar", + [("ENG", "operator argument must be a variable")]); + ("_ArgVariabilityMismatch", + [("ENG", "Argument variability mismatch")]); + ("_ExpectedVariability", + [("ENG", "Expected variability")]); + ("_VariabilityFound", + [("ENG", "Variability found")]); + ("_EquNotAllowedInTheDefOf", + [("ENG", "Equations not allowed in the definition of")]); + ("_OperCannotBeUsedWithinFuncDef", + [("ENG", "operator cannot be used within function definition")]); + ("_ArgDimMismatchInVectCall", + [("ENG", "Arguments dimensions mismatch in vectorized function call")]); + ("_ArgDimMismatch", + [("ENG", "Argument dimension mismatch")]); + ("_TooFewArgsInFuncCall", + [("ENG", "Too few arguments in function call")]); + ("_LHSOfDiscreteEquMustBeAVar", + [("ENG", "Left hand side of discrete equation must be a variable")]); + ("_InvalidVarOfRangeExpr", + [("ENG", "Invalid variability of range expression")]); + ("_RealExponentOfNegativeNumber", + [("ENG", "Real exponentiation of negative number")]); + ("_ZeroRaisedToNegativePower", + [("ENG", "Zero raised to negative power")]); + ("_IllegalCharacter", + [("ENG", "Illegal character")]); (*to be documented*) + ("_InvalidExternalFuncName", + [("ENG", "Invalid external function name")]); (*to be documented*) + ("_LHSOfExternalCall", + [("ENG", "Left hand side of external call")]); (*to be documented*) + ("_InvalidArgOfExternalCall", + [("ENG", "Invalid argument of external call")]); (*to be documented*) + ("_CannotAccessToPredefTypeAttrib", + [("ENG", "Cannot access predefined type attribute")]); + ("_InvalidCondEquation", + [("ENG", "Invalid conditional equation")]); + ("_IndexOutOfBound", + [("ENG", "Index out of bound")]); + ("_DivisionByZero", + [("ENG", "Division by zero")]); + ("_PredefinedOperator", + [("ENG", "Predefined operator")]); + ("_InvalidArgOfOper", + [("ENG", "Invalid argument of operator")]); + ("_UnsupportedDerOperArg", + [("ENG", "Unsupported \"der\" operator argument")]); + ("_InvalidInteger", + [("ENG", "Invalid Integer representation")]); + ("_NonSupportedTypeOfFuncInOut", + [("ENG", "Non supported type of function input or output")]); + ("_DuplicateDeclarationOfElement", + [("ENG", "Duplicate declaration of element")]) (* to be documented *) + ] + +let translate msg = + try + List.assoc "ENG" (List.assoc msg msgs) + with + exn -> msg; diff --git a/scilab/modules/scicos/src/translator/instantiation/instantiation.ml b/scilab/modules/scicos/src/translator/instantiation/instantiation.ml index 038645b..c07ec2c 100644 --- a/scilab/modules/scicos/src/translator/instantiation/instantiation.ml +++ b/scilab/modules/scicos/src/translator/instantiation/instantiation.ml @@ -1,2531 +1,2531 @@ -(* - * Translator from Modelica 2.x to flat Modelica - * - * Copyright (C) 2005 - 2007 Imagine S.A. - * For more information or commercial use please contact us at www.amesim.com - * - * This program is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. - * - *) - -type ('a, 'b) node = - { - nature: 'a; - info: 'b - } - -type instance = - { - enclosing_instance: instance option; - kind: Types.kind; - elements: instance_elements Lazy.t - } - -and instance_elements = - { - named_elements: (string * element_description) list; - unnamed_elements: equation_or_algorithm_clause list - } - -and element_description = - { - redeclare: bool; - element_nature: element_nature Lazy.t - } - -and element_nature = - | Class of class_definition - | Component of component_description - -and class_definition = - { - class_type: Types.class_specifier; - class_path: path; - class_flow: bool option; - class_variability: Types.variability option; - class_causality: Types.causality option; - description: description; - modification: modification_argument list; - class_location: Parser.location - } - -and path = path_element list - -and path_element = - | Name of string - | Index of int - -and description = - | ClassDescription of context * class_description - | PredefinedType of predefined_type - -and class_description = - { - class_kind: Types.kind; - class_annotations: (annotation list) Lazy.t; - long_description: NameResolve.long_description - } - -and annotation = - | InverseFunction of inverse_function Lazy.t - | UnknownAnnotation of Parser.location Syntax.class_modification Lazy.t - -and inverse_function = - { - function_class: class_definition; - arguments: (string * string) list - } - -and class_modification = (string * modification_argument) list - -and modification_argument = - { - each: bool; - action: modification_action - } - -and modification_action = - | ElementModification of modification - | ElementRedeclaration of element_description - -and modification = - | Modification of class_modification * expression Lazy.t option - | Assignment of expression Lazy.t - | Equality of expression Lazy.t - -and component_description = - { - component_path: path; - flow: bool; - variability: Types.variability; - causality: Types.causality; - component_nature: component_nature Lazy.t; - declaration_equation: expression Lazy.t option; - comment: string; - component_location: Parser.location; - class_name: string - } - -and component_nature = - | DynamicArray of component_description - (* one representative member of the collection *) - | Instance of instance - | PredefinedTypeInstance of predefined_type_instance - | StaticArray of component_description array - -and predefined_type_instance = - { - predefined_type: predefined_type; - attributes: (string * expression Lazy.t) list - } - -and predefined_type = - | BooleanType - | IntegerType - | RealType - | StringType - | EnumerationType - -and equation_or_algorithm_clause = - | EquationClause of NameResolve.validity * equation list Lazy.t - | AlgorithmClause of NameResolve.validity * algorithm list Lazy.t - -and validity = Initial | Permanent - -and equation = (equation_desc list, NameResolve.equation) node - -and equation_desc = - | Equal of expression * expression - | ConditionalEquationE of (expression * equation list) list * - equation list - | ConnectFlows of NameResolve.sign * expression * - NameResolve.sign * expression - | WhenClauseE of (expression * equation list) list - -and algorithm = (algorithm_desc list, NameResolve.algorithm) node - -and algorithm_desc = - | Assign of expression * expression - | FunctionCallA of expression * expression list - | MultipleAssign of expression list * expression * expression list - | Break - | Return - | ConditionalEquationA of (expression * algorithm list) list * - algorithm list - | ForClauseA of expression (* range *) * algorithm list - | WhileClause of expression * algorithm list - | WhenClauseA of (expression * algorithm list) list - -and expression = - | BinaryOperation of binary_operator_kind * expression * expression - | ClassReference of class_definition - | ComponentReference of component_description - | EnumerationElement of string - | False - | FieldAccess of expression * string - | FunctionCall of expression * expression list - | If of (expression (* condition *) * expression) list * - expression (* default *) - | IndexedAccess of expression * expression list (* subscripts *) - | Integer of int32 - | LoopVariable of int (* number of nested for loops to skip *) - | NoEvent of expression - | PredefinedIdentifier of string - | Range of expression * expression * expression - | Real of float - | Record of (string * expression) list - | String of string - | True - | Tuple of expression list - | UnaryOperation of unary_operator_kind * expression - | Vector of expression array - | VectorReduction of expression list (* ranges *) * expression - -and unary_operator_kind = - | Not - | UnaryMinus - -and binary_operator_kind = - | And - | Divide - | EqualEqual - | GreaterEqual - | Greater - | LessEqual - | Less - | Times - | NotEqual - | Or - | Plus - | Power - | Minus - -and context = - { - toplevel: (string * element_description) list Lazy.t; - path: path; - context_flow: bool option; - context_variability: Types.variability option; - context_causality: Types.causality option; - parent_context: context option; (* for normal parent scope lookup *) - class_context: context_nature; (* for normal (class-based) lookup *) - instance_context: instance option; (* for dynamically scoped identifiers *) - location: Parser.location; - instance_nature: instance_nature - } - -and context_nature = - | ToplevelContext - | InstanceContext of instance - | ForContext of context * - expression option (* current value of the loop variable, if available *) - | FunctionEvaluationContext of context * expression * expression list - -(* Error description *) -and error_description = - { - err_msg: string list; - err_info: (string * string) list; - err_ctx: context - } - -and instance_nature = - | ClassElement - | ComponentElement of string - -exception InstantError of error_description - - -(* Utilities *) - -let levels = ref 0 - -let spaces () = for i = 1 to !levels do Printf.printf " " done - -let nest i = - spaces (); Printf.printf "ForContext %ld\n" i; - incr levels - -let nest2 i = - spaces (); Printf.printf "ReductionContext %ld\n" i; - incr levels - -let unnest () = - decr levels; - spaces (); Printf.printf "Leaving ForContext\n" - -let evaluate x = Lazy.force x - -module ArrayExt = - struct - let map2 f a a' = - let l = Array.length a - and l' = Array.length a' in - if l <> l' then invalid_arg "ArrayExt.map2" - else begin - let create_array i = f a.(i) a'.(i) in - Array.init l create_array - end - let for_all2 f a a' = - let l = Array.length a - and l' = Array.length a' in - if l <> l' then invalid_arg "ArrayExt.for_all2" - else begin - let rec for_all2' i = - i = l || (f a.(i) a'.(i) && for_all2' (i + 1)) in - for_all2' 0 - end - let exists2 f a a' = - let l = Array.length a - and l' = Array.length a' in - if l <> l' then invalid_arg "ArrayExt.exists2" - else begin - let rec exists2' i = - i < l && (f a.(i) a'.(i) || exists2' (i + 1)) in - exists2' 0 - end - end - - -(* Instantiation functions *) - -let rec evaluate_toplevel_definitions dic defs = - let rec ctx = - { - toplevel = lazy (dic @ evaluate defs'); - path = []; - context_flow = None; - context_variability = None; - context_causality = None; - parent_context = None; - class_context = ToplevelContext; - instance_context = None; - location = {Parser.start = 0; Parser.enddd = 0; filename = Parser.CommandLine}; - instance_nature = ClassElement - } - and defs' = lazy (List.map (evaluate_toplevel_definition ctx) defs) in - evaluate defs' - -and evaluate_toplevel_definition ctx (id, elt_desc) = - let elt_loc = [Name id] in - let ctx = {ctx with - path = elt_loc; - location = elt_desc.NameResolve.element_location; - instance_nature = instance_nature_of_element elt_desc} in - let elt_nat = elt_desc.NameResolve.element_nature in - let elt_desc' = - { - redeclare = false; - element_nature = lazy (evaluate_toplevel_element ctx elt_loc elt_nat) - } in - id, elt_desc' - -and evaluate_toplevel_element ctx elt_loc = function - | NameResolve.Component cpnt_desc -> - let cpnt_desc' = - instantiate_component_description ctx [] None elt_loc cpnt_desc in - Component cpnt_desc' - | NameResolve.Class cl_def -> - let cl_def' = evaluate_class_definition ctx [] elt_loc cl_def in - Class cl_def' - | NameResolve.ComponentType _ -> - raise (InstantError - { err_msg = ["_NotYetImplemented"; "_ComponentTypeElemInstant"]; - err_info = []; - err_ctx = ctx }) (*error*) - | NameResolve.PredefinedType _ -> - raise (InstantError - { err_msg = ["_NotYetImplemented"; "_PredefinedTypeElemInstant"]; - err_info = []; - err_ctx = ctx }) (*error*) - -and instantiate_class_description ctx modifs rhs elt_loc cl_desc = - let elements inst = - let ctx' = - { ctx with - toplevel = lazy (evaluate ctx.toplevel); - path = elt_loc; - parent_context = Some ctx; - class_context = InstanceContext inst; - instance_context = None - } in - instantiate_class_elements ctx' modifs rhs cl_desc.long_description in - let rec inst = - { - enclosing_instance = enclosing_instance ctx; - kind = cl_desc.class_kind; - elements = lazy (elements inst) - } in - inst - -and enclosing_instance ctx = match ctx.class_context with - | ToplevelContext -> None - | InstanceContext inst -> Some inst - | ForContext (ctx', _) | FunctionEvaluationContext (ctx', _, _) -> - enclosing_instance ctx' - -and instantiate_class_elements ctx modifs rhs long_desc = - let rec merge_elements named_elts unnamed_elts = function - | [] -> - { - named_elements = named_elts; - unnamed_elements = unnamed_elts - } - | inherited_elts :: inherited_eltss -> - let named_elts' = named_elts @ inherited_elts.named_elements - and unnamed_elts' = unnamed_elts @ inherited_elts.unnamed_elements in - merge_elements named_elts' unnamed_elts' inherited_eltss in - let named_elts = long_desc.NameResolve.named_elements - and unnamed_elts = long_desc.NameResolve.unnamed_elements - and exts = long_desc.NameResolve.extensions in - let named_elts' = instantiate_local_named_elements ctx modifs rhs named_elts - and unnamed_elts' = instantiate_local_unnamed_elements ctx unnamed_elts - and inherited_eltss = instantiate_inherited_elements ctx modifs rhs exts in - merge_elements named_elts' unnamed_elts' inherited_eltss - -and instantiate_local_named_elements ctx modifs rhs named_elts = - List.fold_right (instantiate_local_named_element ctx modifs rhs) named_elts [] - -and instantiate_local_named_element ctx modifs rhs (id, elt_desc) named_elts = - let rec filter_current_element_modifications = function - | [] -> [] - | (id', arg) :: modifs when id' = id -> - arg :: filter_current_element_modifications modifs - | _ :: modifs -> filter_current_element_modifications modifs - and select_current_element_value = function - | None -> None - | Some expr -> Some (lazy (field_access ctx (evaluate expr) id)) in - let modifs' = filter_current_element_modifications modifs - and rhs' = select_current_element_value rhs - and elt_loc = ctx.path @ [Name id] in - let ctx = {ctx with - path = elt_loc; - location = elt_desc.NameResolve.element_location; - instance_nature = instance_nature_of_element elt_desc} in - let elt_nat = - lazy (instantiate_local_element_nature ctx modifs' rhs' elt_loc elt_desc) in - let named_elt = - id, - { - redeclare = elt_desc.NameResolve.redeclare; - element_nature = elt_nat - } in - named_elt :: named_elts - -and instantiate_local_element_nature ctx modifs rhs elt_loc elt_desc = - match elt_desc.NameResolve.element_nature with - | NameResolve.Component cpnt_desc -> - let cpnt_desc' = - instantiate_component_description ctx modifs rhs elt_loc cpnt_desc in - Component cpnt_desc' - | NameResolve.Class cl_def -> - let cl_def' = evaluate_class_definition ctx modifs elt_loc cl_def in - Class cl_def' - | NameResolve.ComponentType _ -> - raise (InstantError - { err_msg = ["_NotYetImplemented"; "_ComponentTypeElemInstant"]; - err_info = []; - err_ctx = ctx }) - | NameResolve.PredefinedType _ -> - raise (InstantError - { err_msg = ["_NotYetImplemented"; "_PredefinedTypeElemInstant"]; - err_info = []; - err_ctx = ctx }) - -and instantiate_component_description ctx modifs rhs elt_loc cpnt_desc = - let cpnt_type = evaluate cpnt_desc.NameResolve.component_type in - let flow = evaluate cpnt_type.Types.flow - and var = evaluate cpnt_type.Types.variability - and inout = evaluate cpnt_type.Types.causality - and type_spec = evaluate cpnt_desc.NameResolve.type_specifier - and dims = evaluate cpnt_desc.NameResolve.dimensions - and modifs' = match evaluate cpnt_desc.NameResolve.modification with - | None -> modifs - | Some modif -> - let modif' = evaluate_modification ctx modif in - modifs @ [{ each = false; action = ElementModification modif' }] - and cmt = cpnt_desc.NameResolve.comment in - component_nature ctx modifs' rhs elt_loc flow var inout type_spec dims cmt - -and component_nature ctx modifs rhs elt_loc flow var inout type_spec dims cmt = - let type_spec' = evaluate_expression ctx type_spec in - let ctx = {ctx with location = expression_location ctx type_spec} in - expand_array ctx modifs rhs elt_loc flow var inout type_spec' dims cmt - -and expand_array ctx modifs rhs elt_loc flow var inout type_spec dims cmt = - let rec expand_along_dimension dim dims = match dim with - | NameResolve.Colon -> expand_dynamic_array dims - | NameResolve.Expression expr -> - let expr' = evaluate_expression ctx expr in - expand_static_array dims expr' expr - and expand_dynamic_array dims = - (* No need to select modifications since all of them have 'each' set *) - let elt_loc' = elt_loc @ [Index 0] in - let ctx = { ctx with path = elt_loc' } in - let expr = - expand_array ctx modifs rhs elt_loc' flow var inout type_spec dims cmt in - DynamicArray expr - and expand_static_array dims expr' expr = - let ctx = {ctx with location = expression_location ctx expr} in - let expand_element i = - let rec select_subargument arg = match arg.each with - | true -> arg - | false -> { arg with action = select_subarray arg.action } - and select_subarray arg = match arg with - | ElementModification modif -> - ElementModification (select_submodification modif) - | ElementRedeclaration _ -> arg - and select_sub_class_modification_element (id, arg) = - id, select_subargument arg - and select_submodification = function - | Modification (modifs, rhs) -> - let modifs' = List.map select_sub_class_modification_element modifs - and rhs' = select_rhs_subarray rhs in - Modification (modifs', rhs') - | Assignment expr -> - let expr' = lazy (select_row i (evaluate expr)) in - Assignment expr' - | Equality expr -> - let expr' = lazy (select_row i (evaluate expr)) in - Equality expr' - and select_rhs_subarray = function - | None -> None - | Some expr -> Some (lazy (select_row i (evaluate expr))) - and select_row i = function - | Vector exprs -> - begin - try - exprs.(i) - with - | _ -> raise (InstantError - { err_msg = ["_IndexOutOfBound"]; - err_info = []; - err_ctx = ctx}) (*error*) - end - | expr -> - let subs = [Integer (Int32.succ (Int32.of_int i))] in - evaluate_indexed_access ctx expr subs in - let modifs = List.map select_subargument modifs - and rhs = select_rhs_subarray rhs - and elt_loc = elt_loc @ [Index i] in - expand_array ctx modifs rhs elt_loc flow var inout type_spec dims cmt in - match expr' with - | Integer i -> - let a = Array.init (Int32.to_int i) expand_element in - StaticArray a - | _ -> - raise (InstantError - { err_msg = ["_NonIntegerArrayDim"]; - err_info = []; - err_ctx = ctx }) (*error*) in - match dims with - | [] -> - let cl_def = class_definition_of_type_specification ctx type_spec in - create_instance ctx modifs rhs elt_loc flow var inout cl_def cmt - | dim :: dims -> - { - component_path = elt_loc; - flow = flow; - variability = var; - causality = inout; - component_nature = lazy (expand_along_dimension dim dims); - declaration_equation = rhs; - comment = cmt; - component_location = ctx.location; - class_name = instance_class_name ctx.instance_nature - } - -and create_instance ctx modifs rhs elt_loc flow var inout cl_def cmt = - let merge_class_modifications arg modifs = match arg.action with - | ElementModification (Modification (modifs', _)) -> modifs' @ modifs - | ElementModification (Assignment _ | Equality _) -> modifs - | ElementRedeclaration _ -> modifs in - let rec declaration_equation modifs rhs = - let rec declaration_equation' = function - | [] -> None - | { - action = - ElementModification ( - Modification (_, Some expr) | Assignment expr | Equality expr) - } :: _ -> Some expr - | _ :: args -> declaration_equation' args in - match rhs with - | None -> declaration_equation' modifs - | Some _ -> rhs in - let flow' = match cl_def.class_flow, ctx.context_flow with - | None, None -> flow - | Some flow', None | None, Some flow' -> flow || flow' - | Some flow', Some flow'' -> flow || flow' || flow'' - and var' = match cl_def.class_variability, ctx.context_variability with - | None, None -> var - | Some var', None | None, Some var' -> Types.min_variability var var' - | Some var', Some var'' -> - Types.min_variability var (Types.min_variability var' var'') - and inout' = match inout, cl_def.class_causality with - | Types.Input, _ | _, Some Types.Input -> Types.Input - | Types.Output, _ | _, Some Types.Output -> Types.Output - | _ -> Types.Acausal in - let modifs' = - List.fold_right - merge_class_modifications - (modifs @ cl_def.modification) - [] - and rhs' = declaration_equation modifs rhs in - match cl_def.description with - | ClassDescription (ctx', cl_desc) -> - let class_name = instance_class_name ctx.instance_nature in - let ctx' = - { ctx' with - context_flow = Some flow'; - context_variability = Some var'; - context_causality = Some inout'; - instance_context = enclosing_instance ctx; - instance_nature = ComponentElement class_name - } in - { - component_path = elt_loc; - flow = flow'; - variability = var'; - causality = inout'; - component_nature = - lazy (create_class_instance ctx' modifs' rhs' elt_loc cl_desc); - declaration_equation = rhs'; - comment = cmt; - component_location = ctx'.location; - class_name = class_name - } - | PredefinedType predef -> - let class_name = instance_class_name ctx.instance_nature in - let ctx' = - { ctx with - context_flow = Some flow'; - context_variability = Some var'; - context_causality = Some inout'; - instance_nature = ComponentElement class_name - } in - { - component_path = elt_loc; - flow = flow'; - variability = var'; - causality = inout'; - component_nature = - lazy (create_predefined_type_instance ctx' modifs' predef); - declaration_equation = rhs'; - comment = cmt; - component_location = ctx'.location; - class_name = class_name - } - -and create_temporary_instance ctx cl_def = - match cl_def.description with - | ClassDescription (ctx', cl_desc) -> - { - component_path = []; - flow = false; - variability = Types.Continuous; - causality = Types.Acausal; - component_nature = - lazy (create_class_instance ctx' [] None [] cl_desc); - declaration_equation = None; - comment = ""; - component_location = ctx'.location; - class_name = instance_class_name ctx.instance_nature - } - | PredefinedType predef -> assert false (*error*) - -and class_definition_of_type_specification ctx type_spec = - let predefined_class_specifier = function - | "Boolean" -> Types.boolean_class_type - | "Integer" -> Types.integer_class_type - | "Real" -> Types.real_class_type - | "String" -> Types.string_class_type - | s -> - raise (InstantError - { err_msg = ["_UnknownIdentifier"; s]; - err_info = []; - err_ctx = ctx }) (*error*) - and predefined_class_description = function - | "Boolean" -> PredefinedType BooleanType - | "Integer" -> PredefinedType IntegerType - | "Real" -> PredefinedType RealType - | "String" -> PredefinedType StringType - | s -> - raise (InstantError - { err_msg = ["_UnknownIdentifier"; s]; - err_info = []; - err_ctx = ctx }) (*error*) in - match type_spec with - | ClassReference cl_def -> cl_def - | PredefinedIdentifier id -> - { - class_type = predefined_class_specifier id; - class_path = [Name id]; - class_flow = None; - class_variability = None; - class_causality = None; - description = predefined_class_description id; - modification = []; - class_location = ctx.location - } - | _ -> assert false (*error*) - -and create_class_instance ctx modifs rhs elt_loc cl_desc = - let inst = instantiate_class_description ctx modifs rhs elt_loc cl_desc in - Instance inst - -and create_predefined_type_instance ctx modifs predef = - let inst = - { - predefined_type = predef; - attributes = predefined_type_attributes ctx modifs - } in - PredefinedTypeInstance inst - -and predefined_type_attributes ctx modifs = - let rec predefined_type_attributes attrs = function - | [] -> attrs - | (id, { action = ElementModification (Equality expr) }) :: modifs - when not (List.mem_assoc id attrs) -> - let attrs' = (id, expr) :: attrs in - predefined_type_attributes attrs' modifs - | _ :: modifs -> predefined_type_attributes attrs modifs in - predefined_type_attributes [] modifs - -and instantiate_inherited_elements ctx modifs rhs exts = - List.fold_right (instantiate_inherited_element ctx modifs rhs) exts [] - -and instantiate_inherited_element ctx modifs rhs (_, modif_cl) inherited_elts = - let instantiate_inherited_element' modifs cl_def = - match cl_def.description with - | ClassDescription (ctx', cl_desc) -> - let ctx' = { ctx with parent_context = Some ctx' } in - let long_desc = cl_desc.long_description in - instantiate_class_elements ctx' modifs rhs long_desc - | PredefinedType _ -> assert false (*error*) in - let type_spec = evaluate modif_cl.NameResolve.base_class - and modifs' = evaluate modif_cl.NameResolve.class_modification in - let type_spec' = evaluate_expression ctx type_spec - and ctx = {ctx with location = expression_location ctx type_spec} in - let modifs = modifs @ evaluate_class_modification ctx modifs' in - match type_spec' with - | ClassReference cl_def -> - instantiate_inherited_element' modifs cl_def :: inherited_elts - | _ -> assert false (*error*) - -and evaluate_class_definition ctx modifs elt_loc cl_def = - match evaluate cl_def.NameResolve.description with - | NameResolve.LongDescription long_desc -> - let cl_anns = long_desc.NameResolve.class_annotations in - let cl_def' = - { - class_kind = Types.Class; - class_annotations = lazy (evaluate_class_annotations ctx cl_anns); - long_description = long_desc - } in - { - class_type = evaluate cl_def.NameResolve.class_type; - class_path = elt_loc; - class_flow = None; - class_variability = None; - class_causality = None; - description = ClassDescription (ctx, cl_def'); - modification = modifs; - class_location = ctx.location - } - | NameResolve.ShortDescription short_desc -> - raise (InstantError - {err_msg = ["_NotYetImplemented"; "_ShortClassDef"]; - err_info = []; - err_ctx = {ctx with path = elt_loc; - instance_nature = ClassElement}}) - -and evaluate_class_annotations ctx cl_anns = - let evaluate_inverse_function inv_func = - let inv_func = evaluate inv_func in - let expr = - evaluate_expression ctx inv_func.NameResolve.function_class in - match expr with - | ClassReference cl_def -> - { - function_class = cl_def; - arguments = inv_func.NameResolve.arguments - } - | _ -> assert false (*error*) in - let evaluate_class_annotation cl_ann = match cl_ann with - | NameResolve.InverseFunction inv_func -> - InverseFunction (lazy (evaluate_inverse_function inv_func)) - | NameResolve.UnknownAnnotation cl_ann -> - UnknownAnnotation cl_ann in - List.map evaluate_class_annotation (evaluate cl_anns) - -and evaluate_class_modification ctx cl_modif = - let add_modification_argument arg cl_modif' = - match arg.NameResolve.action with - | None -> cl_modif' - | Some modif -> - let arg' = - arg.NameResolve.target, - { - each = arg.NameResolve.each; - action = evaluate_modification_action ctx modif - } in - arg' :: cl_modif' in - List.fold_right add_modification_argument cl_modif [] - -and evaluate_modification_action ctx = function - | NameResolve.ElementModification modif -> - let modif' = evaluate_modification ctx modif in - ElementModification modif' - | NameResolve.ElementRedeclaration elt_desc -> - raise (InstantError - { err_msg = ["_NotYetImplemented"; "_ElementRedeclaration"]; - err_info = []; - err_ctx = ctx }) - -and evaluate_modification ctx = function - | NameResolve.Modification (modifs, rhs) -> - let modifs' = evaluate_class_modification ctx modifs - and rhs' = evaluate_modification_expression ctx rhs in - Modification (modifs', rhs') - | NameResolve.Assignment expr -> - let expr = evaluate expr in - let ctx = {ctx with location = expression_location ctx expr} in - raise (InstantError - { err_msg = ["_NotYetImplemented"; "_AssignExprInElemModif"]; - err_info = []; - err_ctx = ctx }) - | NameResolve.Equality expr -> - let expr' = lazy (evaluate_expression ctx (evaluate expr)) in - Equality expr' - -and evaluate_modification_expression ctx = function - | None -> None - | Some expr -> - let expr' = lazy (evaluate_expression ctx (evaluate expr)) in - Some expr' - -and instantiate_local_unnamed_elements ctx unnamed_elts = - List.map (instantiate_local_unnamed_element ctx) (evaluate unnamed_elts) - -and instantiate_local_unnamed_element ctx unnamed_elt = - match unnamed_elt with - | NameResolve.EquationClause (validity, equs) -> - EquationClause (validity, lazy (instantiate_equations ctx equs)) - | NameResolve.AlgorithmClause (validity, algs) -> - raise (InstantError - { err_msg = ["_NotYetImplemented"; "_AlgoClause"]; - err_info = []; - err_ctx = ctx }) - -and instantiate_equations ctx equs = - let instantiate_equations' equ equs = - let equs' = instantiate_equation ctx equ in - { nature = equs'; info = equ } :: equs in - List.fold_right instantiate_equations' equs [] - -and instantiate_equation ctx equ = match equ.NameResolve.nature with - | NameResolve.Equal (expr, expr') -> instantiate_equal ctx expr expr' - | NameResolve.ConditionalEquationE (alts, default) -> - instantiate_conditional_equation ctx alts default - | NameResolve.ForClauseE (ranges, equs) -> - instantiate_for_clause_e ctx ranges equs - | NameResolve.ConnectFlows (sign, expr, sign', expr') -> - instantiate_connection ctx sign expr sign' expr' - | NameResolve.WhenClauseE alts -> - instantiate_when_clause_e ctx alts - -and instantiate_equal ctx expr expr' = - let rec equal_expr expr expr' = - match expr, expr' with - | BinaryOperation (bin_oper_kind, expr1, expr2), - BinaryOperation (bin_oper_kind', expr1', expr2') -> - (bin_oper_kind = bin_oper_kind') && - (equal_expr expr1 expr1') && - (equal_expr expr2 expr2') - | ClassReference cl_def, ClassReference cl_def' -> - cl_def.class_path = cl_def'.class_path - | ComponentReference cpnt_desc, ComponentReference cpnt_desc' -> - cpnt_desc.component_path = cpnt_desc'.component_path - | EnumerationElement s, EnumerationElement s' -> s = s' - | False, False -> true - | FieldAccess (expr, s), FieldAccess (expr', s') -> - (equal_expr expr expr') && (s = s') - | FunctionCall (expr, exprs), FunctionCall (expr', exprs') -> - (equal_expr expr expr') && - (List.length exprs = List.length exprs') && - (List.for_all2 (=) exprs exprs') - | If (alts, default), If (alts', default') -> - let f (cond, expr) (cond', expr') = - (equal_expr cond cond') && (equal_expr expr expr') in - (List.length alts = List.length alts') && - (List.for_all2 f alts alts') && - (equal_expr default default') - | IndexedAccess (expr, exprs), IndexedAccess (expr', exprs') -> - (equal_expr expr expr') && - (List.length exprs = List.length exprs') && - (List.for_all2 (=) exprs exprs') - | Integer i, Integer i' -> Int32.compare i i' = 0 - | LoopVariable i, LoopVariable i' -> i = i' - | NoEvent expr, NoEvent expr' -> equal_expr expr expr' - | PredefinedIdentifier s, PredefinedIdentifier s' -> s = s' - | Range (start, step, stop), Range (start', step', stop') -> - (equal_expr start start') && - (equal_expr step step') && - (equal_expr stop stop') - | Real f, Real f' -> f = f' - | Record elts, Record elts' -> - let f (s, expr) (s', expr') = - (s = s') && (equal_expr expr expr') in - (List.length elts = List.length elts') && - (List.for_all2 f elts elts') - | String s, String s' -> s = s' - | True, True -> true - | Tuple exprs, Tuple exprs' -> - (List.length exprs = List.length exprs') && - (List.for_all2 equal_expr exprs exprs') - | UnaryOperation (un_oper_kind, expr), - UnaryOperation (un_oper_kind', expr') -> - (un_oper_kind = un_oper_kind') && - (equal_expr expr expr') - | Vector exprs, Vector exprs' -> - (Array.length exprs = Array.length exprs') && - (ArrayExt.for_all2 equal_expr exprs exprs') - | VectorReduction (exprs, expr), VectorReduction (exprs', expr') -> - (List.length exprs = List.length exprs') && - (List.for_all2 equal_expr exprs exprs') && - (equal_expr expr expr') - | _ -> false in - let expr = evaluate_expression ctx expr - and expr' = evaluate_expression ctx expr' in - match equal_expr expr expr' with - | true -> [] - | false -> [ Equal (expr, expr') ] - -and instantiate_conditional_equation ctx alts default = - let rec instantiate_alternatives acc = function - | [] -> instantiate_default acc default - | (cond, equs) :: alts -> instantiate_alternative acc cond equs alts - and instantiate_alternative acc cond equs alts = - let cond' = evaluate_expression ctx cond in - match cond' with - | False -> instantiate_alternatives acc alts - | True -> instantiate_default acc equs - | _ -> - let equs' = instantiate_equations ctx equs in - instantiate_alternatives ((cond', equs') :: acc) alts - and instantiate_default acc equs = - let equs' = instantiate_equations ctx equs in - [ConditionalEquationE (List.rev acc, equs')] in - let alts' = instantiate_alternatives [] alts in - List.flatten (List.map (expand_equation ctx) alts') - -and expand_equation ctx equ = - let rec expand_equation' equ = - let expand_conditional_equation alts default = - let add_alternative (b, equs) altss = - let g equ = List.flatten (List.map expand_equation' equ.nature) in - let equs' = List.flatten (List.map g equs) in - let f (expr1, expr2) (expr1', expr2') = match expr1, expr2 with - | If (alts1, default1), If (alts2, default2) -> - If ((b, expr1') :: alts1, default1), - If ((b, expr2') :: alts2, default2) - | _ -> assert false in - try - List.map2 f altss equs' - with - | _ -> - raise (InstantError - {err_msg = ["_InvalidCondEquation"]; - err_info = []; - err_ctx = ctx}) in - let g equ = List.flatten (List.map expand_equation' equ.nature) in - let default' = List.flatten (List.map g default) in - let f = function (expr1, expr2) -> If ([], expr1), If ([], expr2) in - List.fold_right add_alternative alts (List.map f default') in - match equ with - | ConditionalEquationE (alts, default) -> - expand_conditional_equation alts default - | Equal (expr, expr') -> [ expr, expr' ] - | _ -> - raise (InstantError - {err_msg = ["_InvalidCondEquation"]; - err_info = []; - err_ctx = ctx}) in - let f (expr, expr') = Equal (expr, expr') in - List.map f (expand_equation' equ) - -and instantiate_when_clause_e ctx alts = - let instantiate_alternative (cond, equs) = - let cond' = evaluate_expression ctx cond in - let equs' = instantiate_equations ctx equs in - cond', equs' in - [WhenClauseE (List.map instantiate_alternative alts)] - -and instantiate_connection ctx sign expr sign' expr' = - let expr = evaluate_expression ctx expr - and expr' = evaluate_expression ctx expr' in - [ConnectFlows (sign, expr, sign', expr')] - -and instantiate_for_clause_e ctx ranges equs = - let rec instantiate_for_clause_e' ctx = function - | [] -> List.flatten (List.map (instantiate_equation ctx) equs) - | ranges -> equations_of_reduction ctx ranges - and equations_of_reduction ctx ranges = match ranges with - | (Vector exprs) :: ranges -> - let f expr = - let ctx' = - { ctx with - class_context = ForContext (ctx, Some expr) - } in - instantiate_for_clause_e' ctx' ranges in - List.flatten (List.map f (Array.to_list exprs)) - | _ -> - raise (InstantError - {err_msg = ["_InvalidForClauseRange"]; - err_info = []; - err_ctx = ctx}) in - let ranges = List.map (evaluate_expression ctx) ranges in - instantiate_for_clause_e' ctx ranges - -and evaluate_expression ctx expr = - let ctx = {ctx with location = expression_location ctx expr} in - match expr.NameResolve.nature with - | NameResolve.BinaryOperation (binop, expr, expr') -> - evaluate_binary_operation ctx binop expr expr' - | NameResolve.DynamicIdentifier (level, id) -> - evaluate_dynamic_identifier ctx level id - | NameResolve.False -> False - | NameResolve.FieldAccess (expr, id) -> - evaluate_field_access ctx expr id - | NameResolve.FunctionArgument pos -> evaluate_function_argument ctx pos - | NameResolve.FunctionCall (expr, exprs, expr') -> - evaluate_function_call ctx expr exprs expr' - | NameResolve.FunctionInvocation exprs -> - evaluate_function_invocation ctx exprs - | NameResolve.If (alts, default) -> evaluate_if ctx alts default - | NameResolve.IndexedAccess (expr, exprs) -> - let expr = evaluate_expression ctx expr - and exprs = List.map (evaluate_expression ctx) exprs in - evaluate_indexed_access ctx expr exprs - | NameResolve.Integer i -> Integer i - | NameResolve.LocalIdentifier (level, id) -> - evaluate_local_identifier ctx level id - | NameResolve.LoopVariable level -> evaluate_loop_variable ctx level - | NameResolve.NoEvent expr -> evaluate_no_event ctx expr - | NameResolve.PredefinedIdentifier id -> PredefinedIdentifier id - | NameResolve.Range (start, step, stop) -> - evaluate_range ctx start step stop - | NameResolve.Real f -> Real f - | NameResolve.String s -> String s - | NameResolve.ToplevelIdentifier id -> - evaluate_toplevel_identifier ctx id - | NameResolve.True -> True - | NameResolve.Tuple exprs -> evaluate_tuple ctx exprs - | NameResolve.UnaryOperation (unop, expr) -> - evaluate_unary_operation ctx unop expr - | NameResolve.VectorReduction (ranges, expr) -> - evaluate_vector_reduction ctx ranges expr - | NameResolve.Vector exprs -> evaluate_vector ctx exprs - | NameResolve.Coercion (coer, expr) -> - evaluate_coercion ctx coer expr - -and evaluate_binary_operation ctx binop expr expr' = - let expr = evaluate_expression ctx expr - and expr' = evaluate_expression ctx expr' in - let expr = flatten_expression expr - and expr' = flatten_expression expr' in - match binop with - | NameResolve.And -> evaluate_and expr expr' - | NameResolve.Divide -> evaluate_divide ctx expr expr' - | NameResolve.EqualEqual -> evaluate_equalequal expr expr' - | NameResolve.GreaterEqual -> evaluate_greater_equal expr expr' - | NameResolve.Greater -> evaluate_greater expr expr' - | NameResolve.LessEqual -> evaluate_less_equal expr expr' - | NameResolve.Less -> evaluate_less expr expr' - | NameResolve.Times -> evaluate_times expr expr' - | NameResolve.NotEqual -> evaluate_not_equal expr expr' - | NameResolve.Or -> evaluate_or expr expr' - | NameResolve.Plus -> evaluate_plus expr expr' - | NameResolve.Power -> evaluate_power ctx expr expr' - | NameResolve.Minus -> evaluate_minus expr expr' - -and evaluate_dynamic_identifier ctx level id = - let rec evaluate_dynamic_identifier' inst level = - match level, inst.enclosing_instance with - | 0, _ -> instance_field_access ctx inst id - | _, Some inst -> evaluate_dynamic_identifier' inst (level - 1) - | _, None -> assert false (*error*) in - match ctx.instance_context with - | Some inst -> evaluate_dynamic_identifier' inst level - | None -> assert false (*error*) - -and evaluate_field_access ctx expr id = - let expr = evaluate_expression ctx expr in - field_access ctx expr id - -and evaluate_function_argument ctx pos = match ctx.class_context with - | FunctionEvaluationContext (_, expr, _) when pos = 0 -> expr - | FunctionEvaluationContext (_, _, exprs) -> List.nth exprs (pos - 1) - | ForContext (ctx', _) -> evaluate_function_argument ctx' pos - | InstanceContext _ | ToplevelContext -> assert false (*error*) - -and evaluate_function_call ctx expr exprs expr' = - let expr = evaluate_expression ctx expr - and exprs = List.map (evaluate_expression ctx) exprs in - let exprs = List.map flatten_expression exprs in - let ctx' = - { ctx with - class_context = FunctionEvaluationContext (ctx, expr, exprs) - } in - evaluate_expression ctx' expr' - -and evaluate_function_invocation ctx exprs = - let exprs = List.map (evaluate_expression ctx) exprs in - let exprs = List.map flatten_expression exprs in - let evaluate_function_with_arguments = function - | ClassReference cl_def -> - evaluate_class_function_invocation cl_def exprs - | PredefinedIdentifier s -> - evaluate_predefined_function_invocation ctx s exprs - | ComponentReference _ -> - raise (InstantError - { err_msg = ["_NotYetImplemented"; "_ComponentFuncInvocation"]; - err_info = []; - err_ctx = ctx }) - | _ -> assert false (*error*) in - let rec evaluate_function_invocation' ctx = match ctx.class_context with - | FunctionEvaluationContext (_, expr, _) -> - evaluate_function_with_arguments expr - | ForContext (ctx', _) -> evaluate_function_invocation' ctx' - | InstanceContext _ | ToplevelContext -> assert false (*error*) in - evaluate_function_invocation' ctx - -and evaluate_if ctx alts default = - let create_if alts default = match alts with - | [] -> default - | _ :: _ -> If (alts, default) in - let rec evaluate_alternatives alts' alts = match alts with - | [] -> - let default = evaluate_expression ctx default in - create_if (List.rev alts') default - | (expr, expr') :: alts -> - let expr = evaluate_expression ctx expr in - evaluate_alternative expr expr' alts' alts - and evaluate_alternative expr expr' alts' alts = match expr with - | True -> - let default = evaluate_expression ctx expr' in - create_if (List.rev alts') default - | False -> evaluate_alternatives alts' alts - | _ -> - let expr' = evaluate_expression ctx expr' in - evaluate_alternatives ((expr, expr') :: alts') alts in - evaluate_alternatives [] alts - -and evaluate_indexed_access ctx expr exprs = - let rec vector_indexed_access exprs' exprs = match exprs with - | [] -> expr - | Integer i :: exprs -> - let expr' = - try - exprs'.(Int32.to_int i - 1) - with _ -> - raise (InstantError - { err_msg = ["_IndexOutOfBound"]; - err_info = []; - err_ctx = ctx}) (*error*) in - evaluate_indexed_access ctx expr' exprs - | (Vector subs) :: exprs -> - let f sub = vector_indexed_access exprs' (sub :: exprs) in - Vector (Array.map f subs) - | _ -> IndexedAccess (expr, exprs) - and component_indexed_access cpnt_desc exprs = - let rec static_array_indexed_access cpnt_descs exprs = match exprs with - | [] -> expr - | Integer i :: exprs -> - let i' = Int32.to_int i in - if Array.length cpnt_descs >= i' then - let cpnt_desc = cpnt_descs.(i' - 1) in - let expr' = ComponentReference cpnt_desc in - evaluate_indexed_access ctx expr' exprs - else - raise (InstantError - { err_msg = ["_IndexOutOfBound"]; - err_info = []; - err_ctx = ctx}) (*error*) - | (Vector subs) :: exprs -> - let f sub = static_array_indexed_access cpnt_descs (sub :: exprs) in - Vector (Array.map f subs) - | exprs -> IndexedAccess (expr, exprs) in - match evaluate cpnt_desc.component_nature with - | DynamicArray _ -> IndexedAccess (ComponentReference cpnt_desc, exprs) - | StaticArray cpnt_descs -> - static_array_indexed_access cpnt_descs exprs - | Instance _ | PredefinedTypeInstance _ -> expr in - match expr, exprs with - | _, [] -> expr - | ComponentReference cpnt_desc, _ -> - component_indexed_access cpnt_desc exprs - | Vector exprs', _ -> - vector_indexed_access exprs' exprs - | If (alts, default), _ -> - let f (cond, expr) = (cond, evaluate_indexed_access ctx expr exprs) in - If (List.map f alts, evaluate_indexed_access ctx default exprs) - | _ -> IndexedAccess (expr, exprs) - -and evaluate_local_identifier ctx level id = - let rec evaluate_local_identifier' ctx inst level = - match level, ctx.parent_context with - | 0, _ -> instance_field_access ctx inst id - | _, Some ctx -> evaluate_local_identifier ctx (level - 1) id - | _, None -> assert false (*error*) in - match ctx.class_context with - | ForContext (ctx, _) | FunctionEvaluationContext (ctx, _, _) -> - evaluate_local_identifier ctx level id - | InstanceContext inst -> evaluate_local_identifier' ctx inst level - | ToplevelContext -> assert false (*error*) - -and evaluate_loop_variable ctx level = - let rec evaluate_loop_variable' ctx level' = - match level', ctx.class_context with - | 0, ForContext (_, None) -> assert false (*LoopVariable level'*) - | 0, ForContext (_, Some expr) -> expr - | _, ForContext (ctx, _) -> evaluate_loop_variable ctx (level' - 1) - | _, FunctionEvaluationContext (ctx, _, _) -> - evaluate_loop_variable' ctx level' - | _, (InstanceContext _ | ToplevelContext) -> assert false (*error*) in - evaluate_loop_variable' ctx level - -and evaluate_no_event ctx expr = - let expr = evaluate_expression ctx expr in - match expr with - | True | False | Integer _ | Real _ | String _ | EnumerationElement _ -> - expr - | _ -> NoEvent expr - -and evaluate_range ctx start step stop = - let start = evaluate_expression ctx start - and step = evaluate_expression ctx step - and stop = evaluate_expression ctx stop in - let real_of_expression expr = match expr with - | Real r -> r - | Integer i -> Int32.to_float i - | _ -> assert false in - let integer_interval istart istep istop = match istart, istep, istop with - | _ - when (Int32.compare istop istart) * - (Int32.compare istep Int32.zero) < 0 -> - Vector (Array.make 0 (Integer istart)) - | _ -> - let n = - Int32.div (Int32.sub istop istart) istep in - let n' = Int32.to_int (Int32.succ n) in - let f i = - let i' = Int32.of_int i in - let j = - Int32.add istart (Int32.mul i' istep) in - Integer j in - Vector (Array.init n' f) - and real_interval rstart rstep rstop = match rstart, rstep, rstop with - | _ when (rstop -. rstart) /. rstep < 0. -> - Vector (Array.make 0 (Real rstart)) - | _ -> - let n = truncate ((rstop -. rstart) /. rstep) + 1 - and f i = Real (rstart +. float_of_int i *. rstep) in - Vector (Array.init n f) in - match start, step, stop with - | _, Integer istep, _ - when Int32.compare istep Int32.zero = 0 -> - raise (InstantError - {err_msg = ["_RangeStepValueCannotBeNull"]; - err_info = []; - err_ctx = ctx}) - | _, Real rstep, _ when rstep = 0. -> - raise (InstantError - {err_msg = ["_RangeStepValueCannotBeNull"]; - err_info = []; - err_ctx = ctx}) - | Integer istart, Integer istep, Integer istop -> - integer_interval istart istep istop - | (Integer _ | Real _), (Integer _ | Real _), (Integer _ | Real _) -> - let rstart = real_of_expression start - and rstep = real_of_expression step - and rstop = real_of_expression stop in - real_interval rstart rstep rstop - | _, _, _ -> Range (start, step, stop) - -and evaluate_coercion ctx coer expr = - let rec evaluate_real_of_integer expr' = match expr' with - | Integer i -> Real (Int32.to_float i) - | Vector exprs -> - Vector (Array.map evaluate_real_of_integer exprs) - | _ -> expr' in - let expr' = evaluate_expression ctx expr in - match coer with - | NameResolve.RealOfInteger -> evaluate_real_of_integer expr' - -and evaluate_toplevel_identifier ctx id = - let elt_desc = List.assoc id (evaluate ctx.toplevel) in - match evaluate elt_desc.element_nature with - | Class cl_def -> ClassReference cl_def - | Component cpnt_desc -> ComponentReference cpnt_desc - -and evaluate_tuple ctx exprs = - Tuple (List.map (evaluate_expression ctx) exprs) - -and evaluate_unary_operation ctx unop expr = - let expr = evaluate_expression ctx expr in - let expr = flatten_expression expr in - match unop with - | NameResolve.Not -> evaluate_not expr - | NameResolve.UnaryMinus -> evaluate_unary_minus expr - | NameResolve.UnaryPlus -> expr - -(*and evaluate_vector_reduction ctx ranges expr = - let rec evaluate_vector_reduction' ctx = function - | [] -> evaluate_expression ctx expr - | ranges -> vector_of_reduction ctx ranges - and vector_of_reduction ctx = function - | Range (Integer start, Integer step, Integer stop) :: ranges -> - vector_of_range ctx start step stop ranges - | ranges -> - let ctx' = - { ctx with - class_context = ForContext (ctx, None) - } in - VectorReduction (ranges, evaluate_expression ctx' expr) - and vector_of_range ctx start step stop ranges = - let rec expression_list pred start = match pred start with - | true -> [] - | false -> - let ctx' = - { ctx with - class_context = ForContext (ctx, Some (Integer start)) - } in - let expr = evaluate_vector_reduction' ctx' ranges in - expr :: expression_list pred (Int32.add start step) in - let cmp = Int32.compare step 0l in - match cmp with - | 0 when Int32.compare start stop <> 0 -> assert false (*error*) - | 0 -> Vector [||] - | _ when cmp < 0 -> - let pred = function i -> Int32.compare i stop < 0 in - let exprs = expression_list pred start in - Vector (Array.of_list exprs) - | _ -> - let pred = function i -> Int32.compare i stop > 0 in - let exprs = expression_list pred start in - Vector (Array.of_list exprs) in - let ranges = List.map (evaluate_expression ctx) ranges in - evaluate_vector_reduction' ctx ranges*) - -and evaluate_vector_reduction ctx ranges expr = - let rec evaluate_vector_reduction' ctx = function - | [] -> evaluate_expression ctx expr - | ranges -> vector_of_reduction ctx ranges - and vector_of_reduction ctx = function - | Range (Integer u, Integer p, Integer v) :: ranges -> - vector_of_integer_range ctx u p v ranges - | Range (Real u, Real p, Real v) :: ranges -> - vector_of_real_range ctx u p v ranges - | Vector exprs :: ranges -> - let f i = - let ctx' = - { ctx with - class_context = ForContext (ctx, Some exprs.(i)) - } in - evaluate_vector_reduction' ctx' ranges in - Vector (Array.init (Array.length exprs) f) - | _ -> assert false - and vector_of_integer_range ctx start step stop ranges = - let rec expression_list pred start = match pred start with - | true -> [] - | false -> - let expr = Integer start in - let ctx' = - { ctx with - class_context = - ForContext (ctx, Some expr) - } in - let expr = evaluate_vector_reduction' ctx' ranges in - let next = Int32.add start step in - expr :: expression_list pred next in - match step with - | _ when Int32.compare step Int32.zero = 0 -> - raise (InstantError - {err_msg = ["_RangeStepValueCannotBeNull"]; - err_info = []; - err_ctx = ctx}) - | _ when Int32.compare step Int32.zero < 0 -> - let pred = function i -> (Int32.compare i stop < 0) in - Vector (Array.of_list (expression_list pred start)) - | _ -> - let pred = function i -> (Int32.compare i stop > 0) in - Vector (Array.of_list (expression_list pred start)) - and vector_of_real_range ctx start step stop ranges = - let rec expression_list pred start = match pred start with - | true -> [] - | false -> - let expr = Real start in - let ctx' = - { ctx with - class_context = ForContext (ctx, Some expr) - } in - let expr = evaluate_vector_reduction' ctx' ranges in - expr :: expression_list pred (start +. step) in - match step with - | 0. -> - raise (InstantError - {err_msg = ["_RangeStepValueCannotBeNull"]; - err_info = []; - err_ctx = ctx}) - | _ when step < 0. -> - let pred = function f -> f < stop in - Vector (Array.of_list (expression_list pred start)) - | _ -> - let pred = function f -> f > stop in - Vector (Array.of_list (expression_list pred start)) in - let ranges = List.map (evaluate_expression ctx) ranges in - evaluate_vector_reduction' ctx ranges - -and evaluate_vector ctx exprs = - let exprs = List.map (evaluate_expression ctx) exprs in - Vector (Array.of_list exprs) - -and evaluate_and expr expr' = match expr, expr' with - | False, (False | True) | True, False -> False - | True, True -> True - | Vector exprs, Vector exprs' -> - Vector (ArrayExt.map2 evaluate_and exprs exprs') - | _ -> BinaryOperation (And, expr, expr') - -and evaluate_divide ctx expr expr' = match expr, expr' with - | _, Integer 0l -> - raise (InstantError - { err_msg = ["_DivisionByZero"]; - err_info = []; - err_ctx = ctx }) (*error*) - | Integer 0l, _ -> Integer 0l - | Integer i, Integer i' -> - Real ((Int32.to_float i) /. (Int32.to_float i')) - | _, Real 0. -> - raise (InstantError - { err_msg = ["_DivisionByZero"]; - err_info = []; - err_ctx = ctx }) (*error*) - | Integer i, Real f -> Real (Int32.to_float i /. f) - | Real f, Integer i -> Real (f /. Int32.to_float i) - | Real f, Real f' -> Real (f /. f') - | Vector exprs, _ -> - let divide_element expr = evaluate_divide ctx expr expr' in - Vector (Array.map divide_element exprs) - | _ -> BinaryOperation (Divide, expr, expr') - -and evaluate_equalequal expr expr' = match expr, expr' with - | Integer i, Integer i' when i = i' -> True - | Integer i, Real f | Real f, Integer i when f = Int32.to_float i -> True - | Real f, Real f' when f = f' -> True - | (Integer _ | Real _), (Integer _ | Real _) -> False - | Vector exprs, Vector exprs' - when - ArrayExt.for_all2 - (fun expr expr' -> evaluate_equalequal expr expr' = True) - exprs - exprs' -> True - | Vector _, Vector _ -> False - | _ -> BinaryOperation (EqualEqual, expr, expr') - -and evaluate_greater_equal expr expr' = match expr, expr' with - | Integer i, Integer i' when i >= i' -> True - | Integer i, Real f when Int32.to_float i >= f -> True - | Real f, Integer i when f >= Int32.to_float i -> True - | Real f, Real f' when f >= f' -> True - | (Integer _ | Real _), (Integer _ | Real _) -> False - | _ -> BinaryOperation (GreaterEqual, expr, expr') - -and evaluate_greater expr expr' = match expr, expr' with - | Integer i, Integer i' when i > i' -> True - | Integer i, Real f when Int32.to_float i > f -> True - | Real f, Integer i when f > Int32.to_float i -> True - | Real f, Real f' when f > f' -> True - | (Integer _ | Real _), (Integer _ | Real _) -> False - | _ -> BinaryOperation (Greater, expr, expr') - -and evaluate_less_equal expr expr' = match expr, expr' with - | Integer i, Integer i' when i <= i' -> True - | Integer i, Real f when Int32.to_float i <= f -> True - | Real f, Integer i when f <= Int32.to_float i -> True - | Real f, Real f' when f <= f' -> True - | (Integer _ | Real _), (Integer _ | Real _) -> False - | _ -> BinaryOperation (LessEqual, expr, expr') - -and evaluate_less expr expr' = match expr, expr' with - | Integer i, Integer i' when i < i' -> True - | Integer i, Real f when Int32.to_float i < f -> True - | Real f, Integer i when f < Int32.to_float i -> True - | Real f, Real f' when f < f' -> True - | (Integer _ | Real _), (Integer _ | Real _) -> False - | _ -> BinaryOperation (Less, expr, expr') - -and evaluate_times expr expr' = - let rec line exprs i = match exprs.(i) with - | Vector exprs -> exprs - | _ -> assert false - and column exprs j = - let f i = match exprs.(i) with - | Vector exprs -> exprs.(j) - | _ -> assert false in - Array.init (Array.length exprs) f - and ndims expr = match expr with - | Vector exprs when Array.length exprs = 0 -> assert false - | Vector exprs -> 1 + ndims exprs.(0) - | _ -> 0 - and size expr i = match expr, i with - | _, 0 -> assert false - | Vector exprs, 1 -> Array.length exprs - | _, 1 -> 0 - | Vector exprs, _ when i > 1 -> size exprs.(0) (i - 1) - | _, _ -> assert false - and vector_mult exprs exprs' = - let exprs = ArrayExt.map2 evaluate_times exprs exprs' in - match Array.length exprs with - | 0 -> assert false - | 1 -> exprs.(0) - | n -> - let exprs' = Array.sub exprs 1 (n - 1) in - Array.fold_left evaluate_plus exprs.(0) exprs' in - match expr, expr' with - | Integer 0l, _ | _, Integer 0l -> Integer 0l - | Integer 1l, _ -> expr' - | _, Integer 1l -> expr - | Integer i, Integer i' -> Integer (Int32.mul i i') - | Integer i, Real f | Real f, Integer i -> Real (f *. Int32.to_float i) - | Real f, Real f' -> Real (f *. f') - | _, Vector exprs' when (ndims expr = 0) -> - Vector (Array.map (evaluate_times expr) exprs') - | Vector exprs, _ when (ndims expr' = 0) -> - Vector (Array.map (evaluate_times expr') exprs) - | Vector exprs, Vector exprs' when (ndims expr = 1) && (ndims expr' = 1) -> - vector_mult exprs exprs' - | Vector exprs, Vector exprs' when (ndims expr = 1) && (ndims expr' = 2) -> - let f j = vector_mult exprs (column exprs' j) in - Vector (Array.init (size expr' 2) f) - | Vector exprs, Vector exprs' when (ndims expr = 2) && (ndims expr' = 1) -> - let f i = vector_mult (line exprs i) exprs' in - Vector (Array.init (size expr 1) f) - | Vector exprs, Vector exprs' when (ndims expr = 2) && (ndims expr' = 2) -> - let f i j = vector_mult (line exprs i) (column exprs' j) in - let g i = Vector (Array.init (size expr' 2) (f i)) in - Vector (Array.init (size expr 1) g) - | _ -> BinaryOperation (Times, expr, expr') - -and evaluate_not_equal expr expr' = match expr, expr' with - | Integer i, Integer i' when i <> i' -> True - | Integer i, Real f | Real f, Integer i when f <> Int32.to_float i -> True - | Real f, Real f' when f <> f' -> True - | (Integer _ | Real _), (Integer _ | Real _) -> False - | Vector exprs, Vector exprs' - when - ArrayExt.exists2 - (fun expr expr' -> evaluate_equalequal expr expr' = False) - exprs - exprs' -> True - | Vector _, Vector _ -> False - | _ -> BinaryOperation (NotEqual, expr, expr') - -and evaluate_or expr expr' = match expr, expr' with - | True, (False | True) | False, True -> True - | False, False -> False - | Vector exprs, Vector exprs' -> - Vector (ArrayExt.map2 evaluate_or exprs exprs') - | _ -> BinaryOperation (Or, expr, expr') - -and evaluate_plus expr expr' = match expr, expr' with - | Integer 0l, _ -> expr' - | _, Integer 0l -> expr - | Integer i, Integer i' -> Integer (Int32.add i i') - | Integer i, Real f | Real f, Integer i -> Real (f +. Int32.to_float i) - | Real f, Real f' -> Real (f +. f') - | Vector exprs, Vector exprs' -> - Vector (ArrayExt.map2 evaluate_plus exprs exprs') - | _ -> BinaryOperation (Plus, expr, expr') - -and evaluate_power ctx expr expr' = - match expr, expr' with - | (Integer 0l | Real 0.), (Integer 0l | Real 0.) -> - raise (InstantError - { err_msg = ["_ZeroRaisedToTheZeroPower"]; - err_info = []; - err_ctx = ctx }) (*error*) - | (Integer 0l | Real 0.), Integer i' - when Int32.compare i' 0l < 0 -> - raise (InstantError - { err_msg = ["_ZeroRaisedToNegativePower"]; - err_info = []; - err_ctx = ctx }) (*error*) - | (Integer 0l | Real 0.), Real f' when f' < 0. -> - raise (InstantError - { err_msg = ["_ZeroRaisedToNegativePower"]; - err_info = []; - err_ctx = ctx }) (*error*) - | Integer 0l, Integer _ -> - (* We know the answer for sure since second argument is constant *) - Real 0. - | (Integer 0l | Real 0.), (Integer _ | Real _) -> Real 0. - | Integer i, Real _ when Int32.compare i 0l < 0 -> - raise (InstantError - { err_msg = ["_RealExponentOfNegativeNumber"]; - err_info = []; - err_ctx = ctx }) (*error*) - | Real f, Real _ when f < 0. -> - raise (InstantError - { err_msg = ["_RealExponentOfNegativeNumber"]; - err_info = []; - err_ctx = ctx }) (*error*) - | Integer i, Integer i' -> - Real ((Int32.to_float i) ** (Int32.to_float i')) - | Integer i, Real f -> Real ((Int32.to_float i) ** f) - | Real f, Integer i' -> Real (f ** (Int32.to_float i')) - | Real f, Real f' -> Real (f ** f') - | Vector exprs, Integer i -> - raise (InstantError - { err_msg = ["_NotYetImplemented"; - "_VectorRaisedToIntegerPower"]; - err_info = []; - err_ctx = ctx }) - | _ -> BinaryOperation (Power, expr, expr') - -and evaluate_minus expr expr' = match expr, expr' with - | Integer 0l, _ -> evaluate_unary_minus expr' - | _, Integer 0l -> expr - | Integer i, Integer i' -> Integer (Int32.sub i i') - | Integer i, Real f -> Real (Int32.to_float i -. f) - | Real f, Integer i -> Real (f -. Int32.to_float i) - | Real f, Real f' -> Real (f -. f') - | Vector exprs, Vector exprs' -> - Vector (ArrayExt.map2 evaluate_minus exprs exprs') - | _ -> BinaryOperation (Minus, expr, expr') - -and evaluate_class_function_invocation cl_def exprs = - FunctionCall (ClassReference cl_def, exprs) - -and evaluate_predefined_function_invocation ctx s exprs = - match s, exprs with - | "size", _ -> evaluate_size exprs - | "reinit", [expr; expr'] -> evaluate_reinit expr expr' - | "der", [expr] -> evaluate_der expr - | "pre", [expr] -> evaluate_pre expr - | ("edge" | "change" | "initial" | "terminal" | "sample" | - "delay" | "assert" | "terminate"), _ -> - raise (InstantError - { err_msg = ["_NotYetImplemented"; "_PredefinedOperator"; s]; - err_info = []; - err_ctx = ctx}) (*error*) - | "abs", [expr] -> evaluate_abs expr - | "sign", [expr] -> evaluate_sign expr - | "cos", [expr] -> evaluate_cos expr - | "sin", [expr] -> evaluate_sin expr - | "tan", [expr] -> evaluate_tan expr - | "exp", [expr] -> evaluate_exp expr - | "log", [expr] -> evaluate_log expr - | "sqrt", [expr] -> evaluate_sqrt expr - | "asin", [expr] -> evaluate_asin expr - | "acos", [expr] -> evaluate_acos expr - | "atan", [expr] -> evaluate_atan expr - | "sinh", [expr] -> evaluate_sinh expr - | "cosh", [expr] -> evaluate_cosh expr - | "tanh", [expr] -> evaluate_tanh expr - | "asinh", [expr] -> evaluate_asinh expr - | "acosh", [expr] -> evaluate_acosh expr - | "atanh", [expr] -> evaluate_atanh expr - | "log10", [expr] -> evaluate_log10 expr - | "max", [expr; expr'] -> evaluate_max expr expr' - | "min", [expr; expr'] -> evaluate_min expr expr' - | "div", [expr; expr'] -> evaluate_div ctx expr expr' - | "mod", [expr; expr'] -> evaluate_mod expr expr' - | "rem", [expr; expr'] -> evaluate_rem expr expr' - | "ceil", [expr] -> evaluate_ceil expr - | "floor", [expr] -> evaluate_floor expr - | "max", [expr] -> evaluate_max_array expr - | "min", [expr] -> evaluate_min_array expr - | "sum", [expr] -> evaluate_sum expr - | "product", [expr] -> evaluate_product expr - | "scalar", [expr] -> evaluate_scalar ctx expr - | "ones", exprs -> evaluate_ones ctx exprs - | "zeros", exprs -> evaluate_zeros ctx exprs - | "fill", expr :: exprs -> evaluate_fill ctx expr exprs - | "identity", [expr] -> evaluate_identity ctx expr - | "diagonal", [expr] -> evaluate_diagonal ctx expr - | "vector", [ expr ] -> evaluate_vector_operator ctx expr - | "matrix", [ expr ] -> evaluate_matrix_operator ctx expr - | "transpose", [ expr ] -> evaluate_transpose expr - | "symmetric", [ expr ] -> evaluate_symmetric ctx expr - | _ -> - raise (InstantError - { err_msg = ["_UnknownFunction"; s]; - err_info = []; - err_ctx = ctx}) (*error*) - -and evaluate_symmetric ctx expr = match expr with - | Vector [||] -> assert false - | Vector exprs when size exprs.(0) 0 <> Array.length exprs -> - raise (InstantError - { err_msg = ["_InvalidArgOfOper"; "symmetric"]; - err_info = []; - err_ctx = ctx }) (*error*) - | Vector exprs -> - let f i j = - if i > j then element i (element j expr) - else element j (element i expr) in - let n = Array.length exprs in - let g i = Vector (Array.init n (f i)) in - Vector (Array.init n g) - | _ -> assert false - -and evaluate_transpose expr = - match expr with - | Vector exprs -> - let f i = Vector (Array.map (element i) exprs) in - Vector (Array.init (size expr 1) f) - | _ -> assert false - -and evaluate_matrix_operator ctx expr = - let rec scalar expr = match expr with - | Vector [| expr |] -> scalar expr - | Vector _ -> - raise (InstantError - { err_msg = ["_InvalidArgOfOper"; "matrix"]; - err_info = []; - err_ctx = ctx }) (*error*) - | _ -> expr in - match expr with - | _ when ndims expr < 2 -> - evaluate_promote ctx 2 expr - | _ when ndims expr = 2 -> expr - | Vector exprs -> - let f expr = Vector (Array.map scalar (array_elements expr)) in - Vector (Array.map f exprs) - | _ -> assert false - -and evaluate_promote ctx n expr = - let rec evaluate_promote' i expr = - match expr with - | _ when i = 0 -> expr - | Vector exprs when i > 0 -> - Vector (Array.map (evaluate_promote' i) exprs) - | _ when i > 0 -> - Vector [| evaluate_promote' (i - 1) expr |] - | _ -> assert false in - match ndims expr with - | n' when n' < n -> - evaluate_promote' (n - n') expr - | _ -> expr - -and evaluate_vector_operator ctx expr = - let rec evaluate_scalar expr = match expr with - | Vector [| expr |] -> evaluate_scalar expr - | Vector _ -> - raise (InstantError - { err_msg = ["_InvalidArgOfOper"; "vector"]; - err_info = []; - err_ctx = ctx }) (*error*) - | _ -> expr - and evaluate_vector_operator' expr = match expr with - | Vector [| expr |] -> evaluate_vector_operator' expr - | Vector exprs -> - Array.map evaluate_scalar exprs - | _ -> [| expr |] in - Vector (evaluate_vector_operator' expr) - -and evaluate_max_array expr = - let rec evaluate_max_list exprs = match exprs with - | [] -> assert false - | [ expr ] -> expr - | expr :: exprs -> - evaluate_max expr (evaluate_max_list exprs) in - evaluate_max_list (scalar_elements expr) - -and evaluate_min_array expr = - let rec evaluate_min_list exprs = match exprs with - | [] -> assert false - | [ expr ] -> expr - | expr :: exprs -> - evaluate_min expr (evaluate_min_list exprs) in - evaluate_min_list (scalar_elements expr) - -and evaluate_sum expr = - let rec evaluate_sum_list exprs = match exprs with - | [] -> Integer Int32.zero - | [ expr ] -> expr - | expr :: exprs -> - evaluate_plus expr (evaluate_sum_list exprs) in - match expr with - | Vector exprs -> - evaluate_sum_list (scalar_elements expr) - | _ -> assert false - -and evaluate_product expr = - let rec evaluate_product_list exprs = match exprs with - | [] -> Integer Int32.one - | [ expr ] -> expr - | expr :: exprs -> - evaluate_times expr (evaluate_product_list exprs) in - match expr with - | Vector exprs -> - evaluate_product_list (scalar_elements expr) - | _ -> assert false - -and evaluate_fill ctx expr exprs = - let rec evaluate_fill' dims = match dims with - | [] -> expr - | Integer i :: dims when Int32.compare i Int32.zero > 0 -> - let i = Int32.to_int i in - Vector (Array.make i (evaluate_fill' dims)) - | _ -> - raise (InstantError - { err_msg = ["_InvalidArgOfOper"; "fill"]; - err_info = []; - err_ctx = ctx }) (*error*) in - evaluate_fill' exprs - -and evaluate_zeros ctx exprs = - let rec evaluate_zeros' dims = match dims with - | [] -> Integer Int32.zero - | Integer i :: dims when Int32.compare i Int32.zero > 0 -> - let i = Int32.to_int i in - Vector (Array.make i (evaluate_zeros' dims)) - | _ -> - raise (InstantError - { err_msg = ["_InvalidArgOfOper"; "zeros"]; - err_info = []; - err_ctx = ctx }) (*error*) in - evaluate_zeros' exprs - -and evaluate_ones ctx exprs = - let rec evaluate_ones' dims = match dims with - | [] -> Integer Int32.one - | Integer i :: dims when Int32.compare i Int32.zero > 0 -> - let i = Int32.to_int i in - Vector (Array.make i (evaluate_ones' dims)) - | _ -> - raise (InstantError - { err_msg = ["_InvalidArgOfOper"; "ones"]; - err_info = []; - err_ctx = ctx }) (*error*) in - evaluate_ones' exprs - -and evaluate_identity ctx expr = - let n = match expr with - | Integer i when Int32.compare i Int32.zero > 0 -> - Int32.to_int i - | _ -> - raise (InstantError - { err_msg = ["_InvalidArgOfOper"; "identity"]; - err_info = []; - err_ctx = ctx }) (*error*) in - let f i j = - Integer (if j = i then Int32.one else Int32.zero) in - let g i = Vector (Array.init n (f i)) in - Vector (Array.init n g) - -and evaluate_diagonal ctx expr = - let exprs = match expr with - | Vector [||] -> - raise (InstantError - { err_msg = ["_InvalidArgOfOper"; "diagonal"]; - err_info = []; - err_ctx = ctx }) (*error*) - | Vector exprs -> exprs - | _ -> - raise (InstantError - { err_msg = ["_InvalidArgOfOper"; "diagonal"]; - err_info = []; - err_ctx = ctx }) (*error*) in - let n = Array.length exprs in - let f i j = - if j = i then exprs.(i) else Integer Int32.zero in - let g i = Vector (Array.init n (f i)) in - Vector (Array.init n g) - -and evaluate_scalar ctx expr = - let rec evaluate_scalar' expr = match expr with - | Vector [| expr |] -> evaluate_scalar' expr - | Vector _ -> - raise (InstantError - { err_msg = ["_InvalidArgOfOper"; "scalar"]; - err_info = []; - err_ctx = ctx }) (*error*) - | _ -> expr in - match expr with - | Vector [| expr |] -> evaluate_scalar' expr - | _ -> - raise (InstantError - { err_msg = ["_InvalidArgOfOper"; "scalar"]; - err_info = []; - err_ctx = ctx }) (*error*) - -and evaluate_reinit expr expr' = match expr, expr' with - | Vector exprs, Vector exprs' -> - Vector (ArrayExt.map2 evaluate_reinit exprs exprs') - | _, _ -> - FunctionCall (PredefinedIdentifier "reinit", [ expr; expr' ]) - -and evaluate_der expr = match expr with - | Integer _ | String _ | Real _ -> Real 0. - | Vector exprs -> Vector (Array.map evaluate_der exprs) - | BinaryOperation (Plus, expr, expr') -> - let expr = evaluate_der expr - and expr' = evaluate_der expr' in - BinaryOperation (Plus, expr, expr') - | BinaryOperation (Minus, expr, expr') -> - let expr = evaluate_der expr - and expr' = evaluate_der expr' in - BinaryOperation (Minus, expr, expr') - | BinaryOperation (Times, expr1, expr2) -> - let expr1' = evaluate_der expr1 - and expr2' = evaluate_der expr2 in - let expr1 = BinaryOperation (Times, expr1', expr2) - and expr2 = BinaryOperation (Times, expr1, expr2') in - BinaryOperation (Plus, expr1, expr2) - | BinaryOperation (Divide, expr1, expr2) -> - let expr1' = evaluate_der expr1 - and expr2' = evaluate_der expr2 in - let expr1' = BinaryOperation (Times, expr1', expr2) - and expr2' = BinaryOperation (Times, expr1, expr2') in - let expr1 = BinaryOperation (Minus, expr1', expr2') - and expr2 = BinaryOperation (Times, expr2, expr2) in - BinaryOperation (Divide, expr1, expr2) - | BinaryOperation (Power, expr, Integer i) -> - let expr' = evaluate_der expr - and j = Int32.sub i Int32.one in - let expr' = BinaryOperation (Times, Integer i, expr') - and expr = BinaryOperation (Power, expr, Integer j) in - BinaryOperation (Times, expr', expr) - | BinaryOperation (Power, expr, Real f) -> - let expr' = evaluate_der expr - and f' = f -. 1. in - let expr' = BinaryOperation (Times, Real f, expr') - and expr = BinaryOperation (Power, expr, Real f') in - BinaryOperation (Times, expr', expr) - | FunctionCall (PredefinedIdentifier "cos", [ expr ]) -> - let expr' = evaluate_der expr - and expr = FunctionCall (PredefinedIdentifier "sin", [ expr ]) in - let expr = UnaryOperation (UnaryMinus, expr) in - BinaryOperation (Times, expr', expr) - | FunctionCall (PredefinedIdentifier "sin", [ expr ]) -> - let expr' = evaluate_der expr - and expr = FunctionCall (PredefinedIdentifier "cos", [ expr ]) in - BinaryOperation (Times, expr', expr) - | FunctionCall (PredefinedIdentifier "tan", [ expr1 ]) -> - let expr1' = evaluate_der expr1 - and expr = BinaryOperation (Times, expr, expr) in - let expr = BinaryOperation (Plus, Real 1., expr) in - BinaryOperation (Times, expr1', expr) - | FunctionCall (PredefinedIdentifier "exp", [ expr1 ]) -> - let expr1' = evaluate_der expr1 in - BinaryOperation (Times, expr1', expr) - | FunctionCall (PredefinedIdentifier "log", [ expr1 ]) -> - let expr1' = evaluate_der expr1 in - BinaryOperation (Divide, expr1', expr) - | FunctionCall (PredefinedIdentifier "sqrt", [ expr1 ]) -> - evaluate_der (BinaryOperation (Power, expr1, Real 0.5)) - | FunctionCall (PredefinedIdentifier "asin", [ expr1 ]) -> - let expr1' = evaluate_der expr1 in - let expr1 = BinaryOperation (Times, expr1, expr1) in - let expr1 = BinaryOperation (Minus, Real 1., expr1) in - let expr1 = FunctionCall (PredefinedIdentifier "sqrt", [ expr1 ]) in - BinaryOperation (Divide, expr1', expr1) - | FunctionCall (PredefinedIdentifier "acos", [ expr1 ]) -> - let expr1' = UnaryOperation (UnaryMinus, evaluate_der expr1) in - let expr1 = BinaryOperation (Times, expr1, expr1) in - let expr1 = BinaryOperation (Minus, Real 1., expr1) in - let expr1 = FunctionCall (PredefinedIdentifier "sqrt", [ expr1 ]) in - BinaryOperation (Divide, expr1', expr1) - | FunctionCall (PredefinedIdentifier "atan", [ expr1 ]) -> - let expr1' = evaluate_der expr1 in - let expr1 = BinaryOperation (Times, expr1, expr1) in - let expr1 = BinaryOperation (Plus, Real 1., expr1) in - BinaryOperation (Divide, expr1', expr1) - | FunctionCall (PredefinedIdentifier "sinh", [ expr1 ]) -> - let expr1' = evaluate_der expr1 in - let expr1 = FunctionCall (PredefinedIdentifier "cosh", [ expr1 ]) in - BinaryOperation (Times, expr1', expr1) - | FunctionCall (PredefinedIdentifier "cosh", [ expr1 ]) -> - let expr1' = evaluate_der expr1 in - let expr1 = FunctionCall (PredefinedIdentifier "sinh", [ expr1 ]) in - BinaryOperation (Times, expr1', expr1) - | FunctionCall (PredefinedIdentifier "tanh", [ expr1 ]) -> - let expr1' = evaluate_der expr1 in - let expr1 = BinaryOperation (Times, expr, expr) in - let expr1 = BinaryOperation (Minus, Real 1., expr1) in - BinaryOperation (Times, expr1', expr1) - | FunctionCall (PredefinedIdentifier "asinh", [ expr1 ]) -> - let expr1' = evaluate_der expr1 in - let expr1 = BinaryOperation (Times, expr1, expr1) in - let expr1 = BinaryOperation (Plus, Real 1., expr1) in - let expr1 = FunctionCall (PredefinedIdentifier "sqrt", [ expr1 ]) in - BinaryOperation (Divide, expr1', expr1) - | FunctionCall (PredefinedIdentifier "acosh", [ expr1 ]) -> - let expr1' = evaluate_der expr1 in - let expr1 = BinaryOperation (Times, expr1, expr1) in - let expr1 = BinaryOperation (Minus, expr1, Real 1.) in - let expr1 = FunctionCall (PredefinedIdentifier "sqrt", [ expr1 ]) in - BinaryOperation (Divide, expr1', expr1) - | FunctionCall (PredefinedIdentifier "atanh", [ expr1 ]) -> - let expr1' = evaluate_der expr1 in - let expr1 = BinaryOperation (Times, expr1, expr1) in - let expr1 = BinaryOperation (Minus, expr1, Real 1.) in - BinaryOperation (Divide, expr1', expr1) - | FunctionCall (PredefinedIdentifier "log10", [ expr1 ]) -> - let expr1 = FunctionCall (PredefinedIdentifier "log", [ expr1 ]) in - BinaryOperation (Divide, evaluate_der expr1, Real (log 10.)) - | FunctionCall - (PredefinedIdentifier ("div" | "mod" | "rem" | "ceil" | "floor"), _) -> - Real 0. - | If (alts, default) -> - let alts' = - List.map (function (cond, expr) -> (cond, evaluate_der expr)) alts in - If (alts', evaluate_der default) - | NoEvent expr -> NoEvent (evaluate_der expr) - | UnaryOperation (UnaryMinus, expr) -> - UnaryOperation (UnaryMinus, evaluate_der expr) - | VectorReduction (exprs, expr) -> - VectorReduction (exprs, evaluate_der expr) - | _ -> FunctionCall (PredefinedIdentifier "der", [ expr ]) - -and evaluate_pre expr = match expr with - | Vector exprs -> - Vector (Array.map evaluate_pre exprs) - | _ -> - FunctionCall (PredefinedIdentifier "pre", [ expr ]) - -and evaluate_cos expr = match expr with - | Vector exprs -> - Vector (Array.map evaluate_cos exprs) - | _ -> - FunctionCall (PredefinedIdentifier "cos", [ expr ]) - -and evaluate_sin expr = match expr with - | Vector exprs -> - Vector (Array.map evaluate_sin exprs) - | _ -> - FunctionCall (PredefinedIdentifier "sin", [ expr ]) - -and evaluate_tan expr = match expr with - | Vector exprs -> - Vector (Array.map evaluate_tan exprs) - | _ -> - FunctionCall (PredefinedIdentifier "tan", [ expr ]) - -and evaluate_exp expr = match expr with - | Vector exprs -> - Vector (Array.map evaluate_exp exprs) - | _ -> - FunctionCall (PredefinedIdentifier "exp", [ expr ]) - -and evaluate_log expr = match expr with - | Vector exprs -> - Vector (Array.map evaluate_log exprs) - | _ -> - FunctionCall (PredefinedIdentifier "log", [ expr ]) - -and evaluate_sqrt expr = match expr with - | Vector exprs -> - Vector (Array.map evaluate_sqrt exprs) - | _ -> - FunctionCall (PredefinedIdentifier "sqrt", [ expr ]) - -and evaluate_asin expr = match expr with - | Vector exprs -> - Vector (Array.map evaluate_asin exprs) - | _ -> - FunctionCall (PredefinedIdentifier "asin", [ expr ]) - -and evaluate_acos expr = match expr with - | Vector exprs -> - Vector (Array.map evaluate_acos exprs) - | _ -> - FunctionCall (PredefinedIdentifier "acos", [ expr ]) - -and evaluate_atan expr = match expr with - | Vector exprs -> - Vector (Array.map evaluate_atan exprs) - | _ -> - FunctionCall (PredefinedIdentifier "atan", [ expr ]) - -and evaluate_sinh expr = match expr with - | Vector exprs -> - Vector (Array.map evaluate_sinh exprs) - | _ -> - FunctionCall (PredefinedIdentifier "sinh", [ expr ]) - -and evaluate_cosh expr = match expr with - | Vector exprs -> - Vector (Array.map evaluate_cosh exprs) - | _ -> - FunctionCall (PredefinedIdentifier "cosh", [ expr ]) - -and evaluate_tanh expr = match expr with - | Vector exprs -> - Vector (Array.map evaluate_tanh exprs) - | _ -> - FunctionCall (PredefinedIdentifier "tanh", [ expr ]) - -and evaluate_asinh expr = match expr with - | Vector exprs -> - Vector (Array.map evaluate_asinh exprs) - | _ -> - FunctionCall (PredefinedIdentifier "asinh", [ expr ]) - -and evaluate_acosh expr = match expr with - | Vector exprs -> - Vector (Array.map evaluate_acosh exprs) - | _ -> - FunctionCall (PredefinedIdentifier "acosh", [ expr ]) - -and evaluate_atanh expr = match expr with - | Vector exprs -> - Vector (Array.map evaluate_atanh exprs) - | _ -> - FunctionCall (PredefinedIdentifier "atanh", [ expr ]) - -and evaluate_log10 expr = match expr with - | Vector exprs -> - Vector (Array.map evaluate_log10 exprs) - | _ -> - FunctionCall (PredefinedIdentifier "log10", [ expr ]) - -and evaluate_max expr expr' = match expr, expr' with - | Vector exprs, Vector exprs' -> - Vector (ArrayExt.map2 evaluate_max exprs exprs') - | Real f, Real f' -> Real (max f f') - | _, _ -> - let b = BinaryOperation (GreaterEqual, expr, expr') in - If ([b, expr], expr') - -and evaluate_min expr expr' = match expr, expr' with - | Vector exprs, Vector exprs' -> - Vector (ArrayExt.map2 evaluate_min exprs exprs') - | Real f, Real f' -> Real (min f f') - | _, _ -> - let b = BinaryOperation (GreaterEqual, expr', expr) in - If ([b, expr], expr') - -and evaluate_abs expr = match expr with - | Vector exprs -> - Vector (Array.map evaluate_abs exprs) - | Real f -> Real (abs_float f) - | Integer i -> Integer (Int32.abs i) - | _ -> - let b = BinaryOperation (GreaterEqual, expr, Real 0.) - and default = UnaryOperation (UnaryMinus, expr) in - If ([b, expr], default) - -and evaluate_sign expr = match expr with - | Vector exprs -> - Vector (Array.map evaluate_sign exprs) - | Real f when f > 0. -> Real 1. - | Real f when f < 0. -> Real (-. 1.) - | Real _ -> Real 0. - | Integer i when Int32.compare i Int32.zero > 0 -> - Integer Int32.one - | Integer i when Int32.compare i Int32.zero < 0 -> - Integer Int32.minus_one - | Integer _ -> Integer Int32.zero - | _ -> - let b = BinaryOperation (Greater, expr, Real 0.) - and b' = BinaryOperation (Greater, Real 0., expr) in - If ([(b, Integer Int32.one); (b', Integer Int32.minus_one)], - Integer Int32.zero) - -and evaluate_div ctx expr expr' = match expr, expr' with - | Vector exprs, Vector exprs' -> - Vector (ArrayExt.map2 (evaluate_div ctx) exprs exprs') - | _, Real 0. -> - raise (InstantError - { err_msg = ["_DivisionByZero"]; - err_info = []; - err_ctx = ctx }) (*error*) - | _, Integer i when i = Int32.zero -> - raise (InstantError - { err_msg = ["_DivisionByZero"]; - err_info = []; - err_ctx = ctx }) (*error*) - | Integer i, Integer i' -> Integer (Int32.div i i') - | Real f, Integer i' -> - let f' = Int32.to_float i' in - Real (float_of_int (truncate (f /. f'))) - | Integer i, Real f' -> - let f = Int32.to_float i in - Real (float_of_int (truncate (f /. f'))) - | Real f, Real f' -> - Real (float_of_int (truncate (f /. f'))) - | _, _ -> - FunctionCall (PredefinedIdentifier "div", [ expr; expr' ]) - -and evaluate_mod expr expr' = match expr, expr' with - | Vector exprs, Vector exprs' -> - Vector (ArrayExt.map2 evaluate_mod exprs exprs') - | _, _ -> - FunctionCall (PredefinedIdentifier "mod", [ expr; expr' ]) - -and evaluate_rem expr expr' = match expr, expr' with - | Vector exprs, Vector exprs' -> - Vector (ArrayExt.map2 evaluate_rem exprs exprs') - | _, _ -> - FunctionCall (PredefinedIdentifier "rem", [ expr; expr' ]) - -and evaluate_ceil expr = match expr with - | Vector exprs -> - Vector (Array.map evaluate_ceil exprs) - | _ -> - FunctionCall (PredefinedIdentifier "ceil", [ expr ]) - -and evaluate_floor expr = match expr with - | Vector exprs -> - Vector (Array.map evaluate_floor exprs) - | _ -> - FunctionCall (PredefinedIdentifier "floor", [ expr ]) - -and evaluate_size exprs = - let rec evaluate_size' expr i = match expr, i with - | ComponentReference cpnt_desc, _ -> - evaluate_component_size cpnt_desc i - | Vector exprs, 1 -> Integer (Int32.of_int (Array.length exprs)) - | Vector exprs, _ -> evaluate_size' exprs.(0) (i - 1) - | _ -> assert false (*error*) - and evaluate_component_size cpnt_desc i = - match evaluate cpnt_desc.component_nature, i with - | DynamicArray _, _ -> FunctionCall (PredefinedIdentifier "size", exprs) - | StaticArray cpnt_descs, 1 -> - Integer (Int32.of_int (Array.length cpnt_descs)) - | StaticArray cpnt_descs, _ -> - evaluate_component_size cpnt_descs.(i) (i - 1) - | _ -> assert false (*error*) - and evaluate_size_list = function - | ComponentReference cpnt_desc -> assert false - | Vector exprs -> - let size = Integer (Int32.of_int (Array.length exprs)) in - size :: evaluate_size_list exprs.(0) - | _ -> [] in - match exprs with - | [expr] -> Vector (Array.of_list (evaluate_size_list expr)) - | [expr; Integer i] -> evaluate_size' expr (Int32.to_int i) - | [expr; _] -> FunctionCall (PredefinedIdentifier "size", exprs) - | _ -> assert false (*error*) - -and evaluate_not expr = match expr with - | True -> False - | False -> True - | Vector exprs -> Vector (Array.map evaluate_not exprs) - | _ -> UnaryOperation (Not, expr) - -and evaluate_unary_minus expr = match expr with - | Integer i -> Integer (Int32.neg i) - | Real f -> Real (~-. f) - | Vector exprs -> Vector (Array.map evaluate_unary_minus exprs) - | _ -> UnaryOperation (UnaryMinus, expr) - -and field_access ctx expr id = - let rec field_access' = function - | ClassReference cl_def -> - let cpnt_desc = create_temporary_instance ctx cl_def in - component_field_access cpnt_desc - | ComponentReference cpnt_desc -> component_field_access cpnt_desc - | Record fields -> List.assoc id fields - | Vector exprs -> Vector (Array.map field_access' exprs) - | _ -> FieldAccess (expr, id) - and component_field_access cpnt_desc = - match evaluate cpnt_desc.component_nature with - | DynamicArray _ -> FieldAccess (expr, id) - | Instance inst -> instance_field_access ctx inst id - | PredefinedTypeInstance _ -> - raise (InstantError - { err_msg = ["_CannotAccessToPredefTypeAttrib"; id]; - err_info = []; - err_ctx = ctx}) (*error*) - | StaticArray cpnt_descs -> - Vector (Array.map component_field_access cpnt_descs) in - field_access' expr - -and instance_field_access ctx inst id = - let evaluate_component cpnt_desc = - let evaluate_declaration_equation = function - | Some expr -> evaluate expr - | None -> - raise (InstantError - { err_msg = ["_MissingDeclEquForFixedId"; id]; - err_info = []; - err_ctx = ctx}) (*error*) in - let rec evaluate_parameter cpnt_desc = - let evaluate_predefined_type_instance predef = - match evaluate (List.assoc "fixed" predef.attributes) with - | True -> evaluate_declaration_equation cpnt_desc.declaration_equation - | False -> ComponentReference cpnt_desc - | _ -> assert false (*error*) in - match evaluate cpnt_desc.component_nature with - | PredefinedTypeInstance predef - when List.mem_assoc "fixed" predef.attributes -> - evaluate_predefined_type_instance predef - | DynamicArray cpnt_desc -> assert false - | Instance _ -> ComponentReference cpnt_desc - | PredefinedTypeInstance _ -> - evaluate_declaration_equation cpnt_desc.declaration_equation - | StaticArray cpnt_descs -> - Vector (Array.map evaluate_parameter cpnt_descs) - (*let f i = - let decl_equ = cpnt_descs.(i).declaration_equation in - evaluate_declaration_equation decl_equ in - Vector (Array.init (Array.length cpnt_descs) f)*) in - match cpnt_desc.variability with - | Types.Constant -> - evaluate_declaration_equation cpnt_desc.declaration_equation - | Types.Parameter -> evaluate_parameter cpnt_desc - | _ -> ComponentReference cpnt_desc in - let elts = evaluate inst.elements in - let elt_desc = List.assoc id elts.named_elements in - match evaluate elt_desc.element_nature with - | Class cl_def -> ClassReference cl_def - | Component cpnt_desc -> evaluate_component cpnt_desc - -and expression_location ctx expr = - match expr.NameResolve.info.NameResolve.syntax with - | None -> ctx.location - | Some expr -> expr.Syntax.info - -and class_name_of_component cpnt_desc = - let type_spec = Lazy.force cpnt_desc.NameResolve.type_specifier in - let expr_info = type_spec.NameResolve.info in - match expr_info.NameResolve.syntax with - | None -> "" - | Some expr -> Syntax.string_of_expression expr - -and instance_nature_of_element elt_desc = - match elt_desc.NameResolve.element_nature with - | NameResolve.Component cpnt_desc -> - ComponentElement (class_name_of_component cpnt_desc) - | _ -> ClassElement - -and instance_class_name instance_nature = - match instance_nature with - | ComponentElement s -> s - | ClassElement -> "" - -and flatten_expression expr = - let rec flatten_component cpnt_desc = - match evaluate cpnt_desc.component_nature with - | StaticArray cpnt_descs -> - Vector (Array.map flatten_component cpnt_descs) - | _ -> ComponentReference cpnt_desc in - match expr with - | ComponentReference cpnt_desc -> - flatten_component cpnt_desc - | _ -> expr - -and size expr i = match expr, i with - | Vector [||], _ -> 0 - | Vector exprs, 0 -> Array.length exprs - | Vector exprs, _ when i > 0 -> size exprs.(0) (i - 1) - | _ -> invalid_arg "_IndexOutOfBound" - -and sizes expr = - Array.init (ndims expr) (size expr) - -and ndims expr = - let rec ndims' i expr = match expr with - | Vector [||] -> i + 1 - | Vector exprs -> ndims' (i + 1) exprs.(0) - | _ -> i in - ndims' 0 expr - -and element i expr = match expr with - | Vector exprs -> exprs.(i) - | _ -> assert false - -and array_elements expr = match expr with - | Vector exprs -> exprs - | _ -> assert false - -and scalar_elements expr = match expr with - | Vector exprs -> - let exprss = - Array.to_list (Array.map scalar_elements exprs) in - List.flatten exprss - | _ -> [ expr ] - -(* for debug*) - -and generate_expression oc = function - | BinaryOperation (bin_op, expr, expr') -> - generate_binary_operation oc bin_op expr expr' - | ClassReference cl_def -> - generate_class_reference oc cl_def - | ComponentReference cpnt_desc -> - generate_component_reference oc cpnt_desc - | EnumerationElement _ -> assert false - | False -> assert false - | FieldAccess _ -> assert false - | FunctionCall (expr, exprs) -> - generate_function_call oc expr exprs - | If (alts, expr) -> generate_if oc alts expr - | IndexedAccess _ -> assert false - | Integer i when Int32.to_int i >= 0 -> - Printf.fprintf oc "%ld" i - | Integer i -> - let expr = Integer (Int32.neg i) - and un_op = UnaryMinus in - generate_unary_operation oc un_op expr - | LoopVariable _ -> Printf.fprintf oc "LoopVariable" - | NoEvent expr -> generate_no_event oc expr - | PredefinedIdentifier id -> Printf.fprintf oc "%s" id - | Range _ -> Printf.fprintf oc "Range" - | Real f -> - Printf.fprintf oc "%s" (string_of_float f) - | Record _ -> Printf.fprintf oc "Record" - | String _ -> Printf.fprintf oc "String" - | True -> Printf.fprintf oc "True" - | Tuple _ -> Printf.fprintf oc "Tuple" - | UnaryOperation (un_op, expr) -> - generate_unary_operation oc un_op expr - | Vector exprs -> - generate_vector oc exprs - | VectorReduction _ -> Printf.fprintf oc "VectorReduction" - -and generate_binary_operation oc bin_op expr expr' = - let string_of_binary_operation_kind = function - | And -> "and" - | Divide -> "/" - | EqualEqual -> "==" - | GreaterEqual -> ">=" - | Greater -> ">" - | LessEqual -> "<=" - | Less -> "<" - | Times -> "*" - | NotEqual -> "<>" - | Or -> "or" - | Plus -> "+" - | Power -> "^" - | Minus -> "-" in - Printf.fprintf oc "("; - generate_expression oc expr; - Printf.fprintf oc " %s " (string_of_binary_operation_kind bin_op); - generate_expression oc expr'; - Printf.fprintf oc ")" - -and generate_class_reference oc cl_def = - let rec last = function - | [] -> assert false - | [Name id] -> id - | [Index _] -> assert false - | _ :: path -> last path in - let generate_external_call ext_call = - match ext_call.NameResolve.nature with - | NameResolve.PrimitiveCall "builtin" -> - Printf.fprintf oc "builtin" - | NameResolve.PrimitiveCall "C" -> - Printf.fprintf oc "PrimitiveCall" - | NameResolve.PrimitiveCall lang -> assert false - | NameResolve.ExternalProcedureCall _ -> assert false in - let generate_long_dscription long_desc = - match evaluate long_desc.NameResolve.external_call with - | None -> assert false - | Some ext_call -> generate_external_call ext_call in - match cl_def.description with - | ClassDescription (_, cl_desc) -> - generate_long_dscription cl_desc.long_description - | PredefinedType _ -> assert false - -and generate_component_reference oc cpnt_desc = - let name = ident_of_path cpnt_desc.component_path in - Printf.fprintf oc "%s" name - -and generate_function_call oc expr exprs = - generate_expression oc expr; - Printf.fprintf oc "("; - generate_expressions oc exprs; - Printf.fprintf oc ")" - -and generate_expressions oc = function - | [] -> () - | [expr] -> generate_expression oc expr; - | expr :: exprs -> - generate_expression oc expr; - Printf.fprintf oc ", "; - generate_expressions oc exprs - -and generate_if oc alts expr = - let rec generate_alternatives = function - | [] -> Printf.fprintf oc " "; generate_expression oc expr - | (expr, expr') :: alts -> - Printf.fprintf oc "(if "; - generate_expression oc expr; - Printf.fprintf oc " then "; - generate_expression oc expr'; - Printf.fprintf oc " else"; - generate_alternatives alts; - Printf.fprintf oc ")" in - generate_alternatives alts - -and generate_no_event oc expr = - Printf.fprintf oc "noEvent("; - generate_expression oc expr; - Printf.fprintf oc ")" - -and generate_unary_operation oc un_op expr = - let string_of_unary_operation_kind = function - | Not -> "not" - | UnaryMinus -> "-" in - Printf.fprintf oc "(%s " (string_of_unary_operation_kind un_op); - generate_expression oc expr; - Printf.fprintf oc ")" - -and generate_vector oc exprs = - let exprs' = Array.to_list exprs in - Printf.fprintf oc "{ "; - generate_expressions oc exprs'; - Printf.fprintf oc " }" - -and last_id path = - let rec last_id' id path = match path with - | [] -> id - | (Name id) :: path -> last_id' id path - | (Index _) :: path -> last_id' id path in - last_id' "" path - -and string_of_float f = - let add_parenthesis s = - if String.contains s '-' then Printf.sprintf "(%s)" s else s in - match Printf.sprintf "%.16g" f with - | s when (String.contains s '.') || (String.contains s 'e') -> - add_parenthesis s - | s -> add_parenthesis (Printf.sprintf "%s." s) - -and ident_of_path path = - let rec ident_of_path' path = - match path with - | [] -> assert false - | [Name id] -> id - | [Index i] -> Printf.sprintf "[%d]" (i + 1) - | Name id :: path -> - Printf.sprintf "%s.%s" id (ident_of_path' path) - | Index i :: path -> - Printf.sprintf "[%d].%s" (i + 1) (ident_of_path' path) in - match path with - | [] -> assert false - | [Name id] -> assert false - | [Index i] -> assert false - | Name id :: path -> - Printf.sprintf "`%s`" (ident_of_path' path) - | Index i :: path -> assert false - +(* + * Translator from Modelica 2.x to flat Modelica + * + * Copyright (C) 2005 - 2007 Imagine S.A. + * For more information or commercial use please contact us at www.amesim.com + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. + * + *) + +type ('a, 'b) node = + { + nature: 'a; + info: 'b + } + +type instance = + { + enclosing_instance: instance option; + kind: Types.kind; + elements: instance_elements Lazy.t + } + +and instance_elements = + { + named_elements: (string * element_description) list; + unnamed_elements: equation_or_algorithm_clause list + } + +and element_description = + { + redeclare: bool; + element_nature: element_nature Lazy.t + } + +and element_nature = + | Class of class_definition + | Component of component_description + +and class_definition = + { + class_type: Types.class_specifier; + class_path: path; + class_flow: bool option; + class_variability: Types.variability option; + class_causality: Types.causality option; + description: description; + modification: modification_argument list; + class_location: Parser.location + } + +and path = path_element list + +and path_element = + | Name of string + | Index of int + +and description = + | ClassDescription of context * class_description + | PredefinedType of predefined_type + +and class_description = + { + class_kind: Types.kind; + class_annotations: (annotation list) Lazy.t; + long_description: NameResolve.long_description + } + +and annotation = + | InverseFunction of inverse_function Lazy.t + | UnknownAnnotation of Parser.location Syntax.class_modification Lazy.t + +and inverse_function = + { + function_class: class_definition; + arguments: (string * string) list + } + +and class_modification = (string * modification_argument) list + +and modification_argument = + { + each: bool; + action: modification_action + } + +and modification_action = + | ElementModification of modification + | ElementRedeclaration of element_description + +and modification = + | Modification of class_modification * expression Lazy.t option + | Assignment of expression Lazy.t + | Equality of expression Lazy.t + +and component_description = + { + component_path: path; + flow: bool; + variability: Types.variability; + causality: Types.causality; + component_nature: component_nature Lazy.t; + declaration_equation: expression Lazy.t option; + comment: string; + component_location: Parser.location; + class_name: string + } + +and component_nature = + | DynamicArray of component_description + (* one representative member of the collection *) + | Instance of instance + | PredefinedTypeInstance of predefined_type_instance + | StaticArray of component_description array + +and predefined_type_instance = + { + predefined_type: predefined_type; + attributes: (string * expression Lazy.t) list + } + +and predefined_type = + | BooleanType + | IntegerType + | RealType + | StringType + | EnumerationType + +and equation_or_algorithm_clause = + | EquationClause of NameResolve.validity * equation list Lazy.t + | AlgorithmClause of NameResolve.validity * algorithm list Lazy.t + +and validity = Initial | Permanent + +and equation = (equation_desc list, NameResolve.equation) node + +and equation_desc = + | Equal of expression * expression + | ConditionalEquationE of (expression * equation list) list * + equation list + | ConnectFlows of NameResolve.sign * expression * + NameResolve.sign * expression + | WhenClauseE of (expression * equation list) list + +and algorithm = (algorithm_desc list, NameResolve.algorithm) node + +and algorithm_desc = + | Assign of expression * expression + | FunctionCallA of expression * expression list + | MultipleAssign of expression list * expression * expression list + | Break + | Return + | ConditionalEquationA of (expression * algorithm list) list * + algorithm list + | ForClauseA of expression (* range *) * algorithm list + | WhileClause of expression * algorithm list + | WhenClauseA of (expression * algorithm list) list + +and expression = + | BinaryOperation of binary_operator_kind * expression * expression + | ClassReference of class_definition + | ComponentReference of component_description + | EnumerationElement of string + | False + | FieldAccess of expression * string + | FunctionCall of expression * expression list + | If of (expression (* condition *) * expression) list * + expression (* default *) + | IndexedAccess of expression * expression list (* subscripts *) + | Integer of int32 + | LoopVariable of int (* number of nested for loops to skip *) + | NoEvent of expression + | PredefinedIdentifier of string + | Range of expression * expression * expression + | Real of float + | Record of (string * expression) list + | String of string + | True + | Tuple of expression list + | UnaryOperation of unary_operator_kind * expression + | Vector of expression array + | VectorReduction of expression list (* ranges *) * expression + +and unary_operator_kind = + | Not + | UnaryMinus + +and binary_operator_kind = + | And + | Divide + | EqualEqual + | GreaterEqual + | Greater + | LessEqual + | Less + | Times + | NotEqual + | Or + | Plus + | Power + | Minus + +and context = + { + toplevel: (string * element_description) list Lazy.t; + path: path; + context_flow: bool option; + context_variability: Types.variability option; + context_causality: Types.causality option; + parent_context: context option; (* for normal parent scope lookup *) + class_context: context_nature; (* for normal (class-based) lookup *) + instance_context: instance option; (* for dynamically scoped identifiers *) + location: Parser.location; + instance_nature: instance_nature + } + +and context_nature = + | ToplevelContext + | InstanceContext of instance + | ForContext of context * + expression option (* current value of the loop variable, if available *) + | FunctionEvaluationContext of context * expression * expression list + +(* Error description *) +and error_description = + { + err_msg: string list; + err_info: (string * string) list; + err_ctx: context + } + +and instance_nature = + | ClassElement + | ComponentElement of string + +exception InstantError of error_description + + +(* Utilities *) + +let levels = ref 0 + +let spaces () = for i = 1 to !levels do Printf.printf " " done + +let nest i = + spaces (); Printf.printf "ForContext %ld\n" i; + incr levels + +let nest2 i = + spaces (); Printf.printf "ReductionContext %ld\n" i; + incr levels + +let unnest () = + decr levels; + spaces (); Printf.printf "Leaving ForContext\n" + +let evaluate x = Lazy.force x + +module ArrayExt = + struct + let map2 f a a' = + let l = Array.length a + and l' = Array.length a' in + if l <> l' then invalid_arg "ArrayExt.map2" + else begin + let create_array i = f a.(i) a'.(i) in + Array.init l create_array + end + let for_all2 f a a' = + let l = Array.length a + and l' = Array.length a' in + if l <> l' then invalid_arg "ArrayExt.for_all2" + else begin + let rec for_all2' i = + i = l || (f a.(i) a'.(i) && for_all2' (i + 1)) in + for_all2' 0 + end + let exists2 f a a' = + let l = Array.length a + and l' = Array.length a' in + if l <> l' then invalid_arg "ArrayExt.exists2" + else begin + let rec exists2' i = + i < l && (f a.(i) a'.(i) || exists2' (i + 1)) in + exists2' 0 + end + end + + +(* Instantiation functions *) + +let rec evaluate_toplevel_definitions dic defs = + let rec ctx = + { + toplevel = lazy (dic @ evaluate defs'); + path = []; + context_flow = None; + context_variability = None; + context_causality = None; + parent_context = None; + class_context = ToplevelContext; + instance_context = None; + location = {Parser.start = 0; Parser.enddd = 0; filename = Parser.CommandLine}; + instance_nature = ClassElement + } + and defs' = lazy (List.map (evaluate_toplevel_definition ctx) defs) in + evaluate defs' + +and evaluate_toplevel_definition ctx (id, elt_desc) = + let elt_loc = [Name id] in + let ctx = {ctx with + path = elt_loc; + location = elt_desc.NameResolve.element_location; + instance_nature = instance_nature_of_element elt_desc} in + let elt_nat = elt_desc.NameResolve.element_nature in + let elt_desc' = + { + redeclare = false; + element_nature = lazy (evaluate_toplevel_element ctx elt_loc elt_nat) + } in + id, elt_desc' + +and evaluate_toplevel_element ctx elt_loc = function + | NameResolve.Component cpnt_desc -> + let cpnt_desc' = + instantiate_component_description ctx [] None elt_loc cpnt_desc in + Component cpnt_desc' + | NameResolve.Class cl_def -> + let cl_def' = evaluate_class_definition ctx [] elt_loc cl_def in + Class cl_def' + | NameResolve.ComponentType _ -> + raise (InstantError + { err_msg = ["_NotYetImplemented"; "_ComponentTypeElemInstant"]; + err_info = []; + err_ctx = ctx }) (*error*) + | NameResolve.PredefinedType _ -> + raise (InstantError + { err_msg = ["_NotYetImplemented"; "_PredefinedTypeElemInstant"]; + err_info = []; + err_ctx = ctx }) (*error*) + +and instantiate_class_description ctx modifs rhs elt_loc cl_desc = + let elements inst = + let ctx' = + { ctx with + toplevel = lazy (evaluate ctx.toplevel); + path = elt_loc; + parent_context = Some ctx; + class_context = InstanceContext inst; + instance_context = None + } in + instantiate_class_elements ctx' modifs rhs cl_desc.long_description in + let rec inst = + { + enclosing_instance = enclosing_instance ctx; + kind = cl_desc.class_kind; + elements = lazy (elements inst) + } in + inst + +and enclosing_instance ctx = match ctx.class_context with + | ToplevelContext -> None + | InstanceContext inst -> Some inst + | ForContext (ctx', _) | FunctionEvaluationContext (ctx', _, _) -> + enclosing_instance ctx' + +and instantiate_class_elements ctx modifs rhs long_desc = + let rec merge_elements named_elts unnamed_elts = function + | [] -> + { + named_elements = named_elts; + unnamed_elements = unnamed_elts + } + | inherited_elts :: inherited_eltss -> + let named_elts' = named_elts @ inherited_elts.named_elements + and unnamed_elts' = unnamed_elts @ inherited_elts.unnamed_elements in + merge_elements named_elts' unnamed_elts' inherited_eltss in + let named_elts = long_desc.NameResolve.named_elements + and unnamed_elts = long_desc.NameResolve.unnamed_elements + and exts = long_desc.NameResolve.extensions in + let named_elts' = instantiate_local_named_elements ctx modifs rhs named_elts + and unnamed_elts' = instantiate_local_unnamed_elements ctx unnamed_elts + and inherited_eltss = instantiate_inherited_elements ctx modifs rhs exts in + merge_elements named_elts' unnamed_elts' inherited_eltss + +and instantiate_local_named_elements ctx modifs rhs named_elts = + List.fold_right (instantiate_local_named_element ctx modifs rhs) named_elts [] + +and instantiate_local_named_element ctx modifs rhs (id, elt_desc) named_elts = + let rec filter_current_element_modifications = function + | [] -> [] + | (id', arg) :: modifs when id' = id -> + arg :: filter_current_element_modifications modifs + | _ :: modifs -> filter_current_element_modifications modifs + and select_current_element_value = function + | None -> None + | Some expr -> Some (lazy (field_access ctx (evaluate expr) id)) in + let modifs' = filter_current_element_modifications modifs + and rhs' = select_current_element_value rhs + and elt_loc = ctx.path @ [Name id] in + let ctx = {ctx with + path = elt_loc; + location = elt_desc.NameResolve.element_location; + instance_nature = instance_nature_of_element elt_desc} in + let elt_nat = + lazy (instantiate_local_element_nature ctx modifs' rhs' elt_loc elt_desc) in + let named_elt = + id, + { + redeclare = elt_desc.NameResolve.redeclare; + element_nature = elt_nat + } in + named_elt :: named_elts + +and instantiate_local_element_nature ctx modifs rhs elt_loc elt_desc = + match elt_desc.NameResolve.element_nature with + | NameResolve.Component cpnt_desc -> + let cpnt_desc' = + instantiate_component_description ctx modifs rhs elt_loc cpnt_desc in + Component cpnt_desc' + | NameResolve.Class cl_def -> + let cl_def' = evaluate_class_definition ctx modifs elt_loc cl_def in + Class cl_def' + | NameResolve.ComponentType _ -> + raise (InstantError + { err_msg = ["_NotYetImplemented"; "_ComponentTypeElemInstant"]; + err_info = []; + err_ctx = ctx }) + | NameResolve.PredefinedType _ -> + raise (InstantError + { err_msg = ["_NotYetImplemented"; "_PredefinedTypeElemInstant"]; + err_info = []; + err_ctx = ctx }) + +and instantiate_component_description ctx modifs rhs elt_loc cpnt_desc = + let cpnt_type = evaluate cpnt_desc.NameResolve.component_type in + let flow = evaluate cpnt_type.Types.flow + and var = evaluate cpnt_type.Types.variability + and inout = evaluate cpnt_type.Types.causality + and type_spec = evaluate cpnt_desc.NameResolve.type_specifier + and dims = evaluate cpnt_desc.NameResolve.dimensions + and modifs' = match evaluate cpnt_desc.NameResolve.modification with + | None -> modifs + | Some modif -> + let modif' = evaluate_modification ctx modif in + modifs @ [{ each = false; action = ElementModification modif' }] + and cmt = cpnt_desc.NameResolve.comment in + component_nature ctx modifs' rhs elt_loc flow var inout type_spec dims cmt + +and component_nature ctx modifs rhs elt_loc flow var inout type_spec dims cmt = + let type_spec' = evaluate_expression ctx type_spec in + let ctx = {ctx with location = expression_location ctx type_spec} in + expand_array ctx modifs rhs elt_loc flow var inout type_spec' dims cmt + +and expand_array ctx modifs rhs elt_loc flow var inout type_spec dims cmt = + let rec expand_along_dimension dim dims = match dim with + | NameResolve.Colon -> expand_dynamic_array dims + | NameResolve.Expression expr -> + let expr' = evaluate_expression ctx expr in + expand_static_array dims expr' expr + and expand_dynamic_array dims = + (* No need to select modifications since all of them have 'each' set *) + let elt_loc' = elt_loc @ [Index 0] in + let ctx = { ctx with path = elt_loc' } in + let expr = + expand_array ctx modifs rhs elt_loc' flow var inout type_spec dims cmt in + DynamicArray expr + and expand_static_array dims expr' expr = + let ctx = {ctx with location = expression_location ctx expr} in + let expand_element i = + let rec select_subargument arg = match arg.each with + | true -> arg + | false -> { arg with action = select_subarray arg.action } + and select_subarray arg = match arg with + | ElementModification modif -> + ElementModification (select_submodification modif) + | ElementRedeclaration _ -> arg + and select_sub_class_modification_element (id, arg) = + id, select_subargument arg + and select_submodification = function + | Modification (modifs, rhs) -> + let modifs' = List.map select_sub_class_modification_element modifs + and rhs' = select_rhs_subarray rhs in + Modification (modifs', rhs') + | Assignment expr -> + let expr' = lazy (select_row i (evaluate expr)) in + Assignment expr' + | Equality expr -> + let expr' = lazy (select_row i (evaluate expr)) in + Equality expr' + and select_rhs_subarray = function + | None -> None + | Some expr -> Some (lazy (select_row i (evaluate expr))) + and select_row i = function + | Vector exprs -> + begin + try + exprs.(i) + with + | _ -> raise (InstantError + { err_msg = ["_IndexOutOfBound"]; + err_info = []; + err_ctx = ctx}) (*error*) + end + | expr -> + let subs = [Integer (Int32.succ (Int32.of_int i))] in + evaluate_indexed_access ctx expr subs in + let modifs = List.map select_subargument modifs + and rhs = select_rhs_subarray rhs + and elt_loc = elt_loc @ [Index i] in + expand_array ctx modifs rhs elt_loc flow var inout type_spec dims cmt in + match expr' with + | Integer i -> + let a = Array.init (Int32.to_int i) expand_element in + StaticArray a + | _ -> + raise (InstantError + { err_msg = ["_NonIntegerArrayDim"]; + err_info = []; + err_ctx = ctx }) (*error*) in + match dims with + | [] -> + let cl_def = class_definition_of_type_specification ctx type_spec in + create_instance ctx modifs rhs elt_loc flow var inout cl_def cmt + | dim :: dims -> + { + component_path = elt_loc; + flow = flow; + variability = var; + causality = inout; + component_nature = lazy (expand_along_dimension dim dims); + declaration_equation = rhs; + comment = cmt; + component_location = ctx.location; + class_name = instance_class_name ctx.instance_nature + } + +and create_instance ctx modifs rhs elt_loc flow var inout cl_def cmt = + let merge_class_modifications arg modifs = match arg.action with + | ElementModification (Modification (modifs', _)) -> modifs' @ modifs + | ElementModification (Assignment _ | Equality _) -> modifs + | ElementRedeclaration _ -> modifs in + let rec declaration_equation modifs rhs = + let rec declaration_equation' = function + | [] -> None + | { + action = + ElementModification ( + Modification (_, Some expr) | Assignment expr | Equality expr) + } :: _ -> Some expr + | _ :: args -> declaration_equation' args in + match rhs with + | None -> declaration_equation' modifs + | Some _ -> rhs in + let flow' = match cl_def.class_flow, ctx.context_flow with + | None, None -> flow + | Some flow', None | None, Some flow' -> flow || flow' + | Some flow', Some flow'' -> flow || flow' || flow'' + and var' = match cl_def.class_variability, ctx.context_variability with + | None, None -> var + | Some var', None | None, Some var' -> Types.min_variability var var' + | Some var', Some var'' -> + Types.min_variability var (Types.min_variability var' var'') + and inout' = match inout, cl_def.class_causality with + | Types.Input, _ | _, Some Types.Input -> Types.Input + | Types.Output, _ | _, Some Types.Output -> Types.Output + | _ -> Types.Acausal in + let modifs' = + List.fold_right + merge_class_modifications + (modifs @ cl_def.modification) + [] + and rhs' = declaration_equation modifs rhs in + match cl_def.description with + | ClassDescription (ctx', cl_desc) -> + let class_name = instance_class_name ctx.instance_nature in + let ctx' = + { ctx' with + context_flow = Some flow'; + context_variability = Some var'; + context_causality = Some inout'; + instance_context = enclosing_instance ctx; + instance_nature = ComponentElement class_name + } in + { + component_path = elt_loc; + flow = flow'; + variability = var'; + causality = inout'; + component_nature = + lazy (create_class_instance ctx' modifs' rhs' elt_loc cl_desc); + declaration_equation = rhs'; + comment = cmt; + component_location = ctx'.location; + class_name = class_name + } + | PredefinedType predef -> + let class_name = instance_class_name ctx.instance_nature in + let ctx' = + { ctx with + context_flow = Some flow'; + context_variability = Some var'; + context_causality = Some inout'; + instance_nature = ComponentElement class_name + } in + { + component_path = elt_loc; + flow = flow'; + variability = var'; + causality = inout'; + component_nature = + lazy (create_predefined_type_instance ctx' modifs' predef); + declaration_equation = rhs'; + comment = cmt; + component_location = ctx'.location; + class_name = class_name + } + +and create_temporary_instance ctx cl_def = + match cl_def.description with + | ClassDescription (ctx', cl_desc) -> + { + component_path = []; + flow = false; + variability = Types.Continuous; + causality = Types.Acausal; + component_nature = + lazy (create_class_instance ctx' [] None [] cl_desc); + declaration_equation = None; + comment = ""; + component_location = ctx'.location; + class_name = instance_class_name ctx.instance_nature + } + | PredefinedType predef -> assert false (*error*) + +and class_definition_of_type_specification ctx type_spec = + let predefined_class_specifier = function + | "Boolean" -> Types.boolean_class_type + | "Integer" -> Types.integer_class_type + | "Real" -> Types.real_class_type + | "String" -> Types.string_class_type + | s -> + raise (InstantError + { err_msg = ["_UnknownIdentifier"; s]; + err_info = []; + err_ctx = ctx }) (*error*) + and predefined_class_description = function + | "Boolean" -> PredefinedType BooleanType + | "Integer" -> PredefinedType IntegerType + | "Real" -> PredefinedType RealType + | "String" -> PredefinedType StringType + | s -> + raise (InstantError + { err_msg = ["_UnknownIdentifier"; s]; + err_info = []; + err_ctx = ctx }) (*error*) in + match type_spec with + | ClassReference cl_def -> cl_def + | PredefinedIdentifier id -> + { + class_type = predefined_class_specifier id; + class_path = [Name id]; + class_flow = None; + class_variability = None; + class_causality = None; + description = predefined_class_description id; + modification = []; + class_location = ctx.location + } + | _ -> assert false (*error*) + +and create_class_instance ctx modifs rhs elt_loc cl_desc = + let inst = instantiate_class_description ctx modifs rhs elt_loc cl_desc in + Instance inst + +and create_predefined_type_instance ctx modifs predef = + let inst = + { + predefined_type = predef; + attributes = predefined_type_attributes ctx modifs + } in + PredefinedTypeInstance inst + +and predefined_type_attributes ctx modifs = + let rec predefined_type_attributes attrs = function + | [] -> attrs + | (id, { action = ElementModification (Equality expr) }) :: modifs + when not (List.mem_assoc id attrs) -> + let attrs' = (id, expr) :: attrs in + predefined_type_attributes attrs' modifs + | _ :: modifs -> predefined_type_attributes attrs modifs in + predefined_type_attributes [] modifs + +and instantiate_inherited_elements ctx modifs rhs exts = + List.fold_right (instantiate_inherited_element ctx modifs rhs) exts [] + +and instantiate_inherited_element ctx modifs rhs (_, modif_cl) inherited_elts = + let instantiate_inherited_element' modifs cl_def = + match cl_def.description with + | ClassDescription (ctx', cl_desc) -> + let ctx' = { ctx with parent_context = Some ctx' } in + let long_desc = cl_desc.long_description in + instantiate_class_elements ctx' modifs rhs long_desc + | PredefinedType _ -> assert false (*error*) in + let type_spec = evaluate modif_cl.NameResolve.base_class + and modifs' = evaluate modif_cl.NameResolve.class_modification in + let type_spec' = evaluate_expression ctx type_spec + and ctx = {ctx with location = expression_location ctx type_spec} in + let modifs = modifs @ evaluate_class_modification ctx modifs' in + match type_spec' with + | ClassReference cl_def -> + instantiate_inherited_element' modifs cl_def :: inherited_elts + | _ -> assert false (*error*) + +and evaluate_class_definition ctx modifs elt_loc cl_def = + match evaluate cl_def.NameResolve.description with + | NameResolve.LongDescription long_desc -> + let cl_anns = long_desc.NameResolve.class_annotations in + let cl_def' = + { + class_kind = Types.Class; + class_annotations = lazy (evaluate_class_annotations ctx cl_anns); + long_description = long_desc + } in + { + class_type = evaluate cl_def.NameResolve.class_type; + class_path = elt_loc; + class_flow = None; + class_variability = None; + class_causality = None; + description = ClassDescription (ctx, cl_def'); + modification = modifs; + class_location = ctx.location + } + | NameResolve.ShortDescription short_desc -> + raise (InstantError + {err_msg = ["_NotYetImplemented"; "_ShortClassDef"]; + err_info = []; + err_ctx = {ctx with path = elt_loc; + instance_nature = ClassElement}}) + +and evaluate_class_annotations ctx cl_anns = + let evaluate_inverse_function inv_func = + let inv_func = evaluate inv_func in + let expr = + evaluate_expression ctx inv_func.NameResolve.function_class in + match expr with + | ClassReference cl_def -> + { + function_class = cl_def; + arguments = inv_func.NameResolve.arguments + } + | _ -> assert false (*error*) in + let evaluate_class_annotation cl_ann = match cl_ann with + | NameResolve.InverseFunction inv_func -> + InverseFunction (lazy (evaluate_inverse_function inv_func)) + | NameResolve.UnknownAnnotation cl_ann -> + UnknownAnnotation cl_ann in + List.map evaluate_class_annotation (evaluate cl_anns) + +and evaluate_class_modification ctx cl_modif = + let add_modification_argument arg cl_modif' = + match arg.NameResolve.action with + | None -> cl_modif' + | Some modif -> + let arg' = + arg.NameResolve.target, + { + each = arg.NameResolve.each; + action = evaluate_modification_action ctx modif + } in + arg' :: cl_modif' in + List.fold_right add_modification_argument cl_modif [] + +and evaluate_modification_action ctx = function + | NameResolve.ElementModification modif -> + let modif' = evaluate_modification ctx modif in + ElementModification modif' + | NameResolve.ElementRedeclaration elt_desc -> + raise (InstantError + { err_msg = ["_NotYetImplemented"; "_ElementRedeclaration"]; + err_info = []; + err_ctx = ctx }) + +and evaluate_modification ctx = function + | NameResolve.Modification (modifs, rhs) -> + let modifs' = evaluate_class_modification ctx modifs + and rhs' = evaluate_modification_expression ctx rhs in + Modification (modifs', rhs') + | NameResolve.Assignment expr -> + let expr = evaluate expr in + let ctx = {ctx with location = expression_location ctx expr} in + raise (InstantError + { err_msg = ["_NotYetImplemented"; "_AssignExprInElemModif"]; + err_info = []; + err_ctx = ctx }) + | NameResolve.Equality expr -> + let expr' = lazy (evaluate_expression ctx (evaluate expr)) in + Equality expr' + +and evaluate_modification_expression ctx = function + | None -> None + | Some expr -> + let expr' = lazy (evaluate_expression ctx (evaluate expr)) in + Some expr' + +and instantiate_local_unnamed_elements ctx unnamed_elts = + List.map (instantiate_local_unnamed_element ctx) (evaluate unnamed_elts) + +and instantiate_local_unnamed_element ctx unnamed_elt = + match unnamed_elt with + | NameResolve.EquationClause (validity, equs) -> + EquationClause (validity, lazy (instantiate_equations ctx equs)) + | NameResolve.AlgorithmClause (validity, algs) -> + raise (InstantError + { err_msg = ["_NotYetImplemented"; "_AlgoClause"]; + err_info = []; + err_ctx = ctx }) + +and instantiate_equations ctx equs = + let instantiate_equations' equ equs = + let equs' = instantiate_equation ctx equ in + { nature = equs'; info = equ } :: equs in + List.fold_right instantiate_equations' equs [] + +and instantiate_equation ctx equ = match equ.NameResolve.nature with + | NameResolve.Equal (expr, expr') -> instantiate_equal ctx expr expr' + | NameResolve.ConditionalEquationE (alts, default) -> + instantiate_conditional_equation ctx alts default + | NameResolve.ForClauseE (ranges, equs) -> + instantiate_for_clause_e ctx ranges equs + | NameResolve.ConnectFlows (sign, expr, sign', expr') -> + instantiate_connection ctx sign expr sign' expr' + | NameResolve.WhenClauseE alts -> + instantiate_when_clause_e ctx alts + +and instantiate_equal ctx expr expr' = + let rec equal_expr expr expr' = + match expr, expr' with + | BinaryOperation (bin_oper_kind, expr1, expr2), + BinaryOperation (bin_oper_kind', expr1', expr2') -> + (bin_oper_kind = bin_oper_kind') && + (equal_expr expr1 expr1') && + (equal_expr expr2 expr2') + | ClassReference cl_def, ClassReference cl_def' -> + cl_def.class_path = cl_def'.class_path + | ComponentReference cpnt_desc, ComponentReference cpnt_desc' -> + cpnt_desc.component_path = cpnt_desc'.component_path + | EnumerationElement s, EnumerationElement s' -> s = s' + | False, False -> true + | FieldAccess (expr, s), FieldAccess (expr', s') -> + (equal_expr expr expr') && (s = s') + | FunctionCall (expr, exprs), FunctionCall (expr', exprs') -> + (equal_expr expr expr') && + (List.length exprs = List.length exprs') && + (List.for_all2 (=) exprs exprs') + | If (alts, default), If (alts', default') -> + let f (cond, expr) (cond', expr') = + (equal_expr cond cond') && (equal_expr expr expr') in + (List.length alts = List.length alts') && + (List.for_all2 f alts alts') && + (equal_expr default default') + | IndexedAccess (expr, exprs), IndexedAccess (expr', exprs') -> + (equal_expr expr expr') && + (List.length exprs = List.length exprs') && + (List.for_all2 (=) exprs exprs') + | Integer i, Integer i' -> Int32.compare i i' = 0 + | LoopVariable i, LoopVariable i' -> i = i' + | NoEvent expr, NoEvent expr' -> equal_expr expr expr' + | PredefinedIdentifier s, PredefinedIdentifier s' -> s = s' + | Range (start, step, stop), Range (start', step', stop') -> + (equal_expr start start') && + (equal_expr step step') && + (equal_expr stop stop') + | Real f, Real f' -> f = f' + | Record elts, Record elts' -> + let f (s, expr) (s', expr') = + (s = s') && (equal_expr expr expr') in + (List.length elts = List.length elts') && + (List.for_all2 f elts elts') + | String s, String s' -> s = s' + | True, True -> true + | Tuple exprs, Tuple exprs' -> + (List.length exprs = List.length exprs') && + (List.for_all2 equal_expr exprs exprs') + | UnaryOperation (un_oper_kind, expr), + UnaryOperation (un_oper_kind', expr') -> + (un_oper_kind = un_oper_kind') && + (equal_expr expr expr') + | Vector exprs, Vector exprs' -> + (Array.length exprs = Array.length exprs') && + (ArrayExt.for_all2 equal_expr exprs exprs') + | VectorReduction (exprs, expr), VectorReduction (exprs', expr') -> + (List.length exprs = List.length exprs') && + (List.for_all2 equal_expr exprs exprs') && + (equal_expr expr expr') + | _ -> false in + let expr = evaluate_expression ctx expr + and expr' = evaluate_expression ctx expr' in + match equal_expr expr expr' with + | true -> [] + | false -> [ Equal (expr, expr') ] + +and instantiate_conditional_equation ctx alts default = + let rec instantiate_alternatives acc = function + | [] -> instantiate_default acc default + | (cond, equs) :: alts -> instantiate_alternative acc cond equs alts + and instantiate_alternative acc cond equs alts = + let cond' = evaluate_expression ctx cond in + match cond' with + | False -> instantiate_alternatives acc alts + | True -> instantiate_default acc equs + | _ -> + let equs' = instantiate_equations ctx equs in + instantiate_alternatives ((cond', equs') :: acc) alts + and instantiate_default acc equs = + let equs' = instantiate_equations ctx equs in + [ConditionalEquationE (List.rev acc, equs')] in + let alts' = instantiate_alternatives [] alts in + List.flatten (List.map (expand_equation ctx) alts') + +and expand_equation ctx equ = + let rec expand_equation' equ = + let expand_conditional_equation alts default = + let add_alternative (b, equs) altss = + let g equ = List.flatten (List.map expand_equation' equ.nature) in + let equs' = List.flatten (List.map g equs) in + let f (expr1, expr2) (expr1', expr2') = match expr1, expr2 with + | If (alts1, default1), If (alts2, default2) -> + If ((b, expr1') :: alts1, default1), + If ((b, expr2') :: alts2, default2) + | _ -> assert false in + try + List.map2 f altss equs' + with + | _ -> + raise (InstantError + {err_msg = ["_InvalidCondEquation"]; + err_info = []; + err_ctx = ctx}) in + let g equ = List.flatten (List.map expand_equation' equ.nature) in + let default' = List.flatten (List.map g default) in + let f = function (expr1, expr2) -> If ([], expr1), If ([], expr2) in + List.fold_right add_alternative alts (List.map f default') in + match equ with + | ConditionalEquationE (alts, default) -> + expand_conditional_equation alts default + | Equal (expr, expr') -> [ expr, expr' ] + | _ -> + raise (InstantError + {err_msg = ["_InvalidCondEquation"]; + err_info = []; + err_ctx = ctx}) in + let f (expr, expr') = Equal (expr, expr') in + List.map f (expand_equation' equ) + +and instantiate_when_clause_e ctx alts = + let instantiate_alternative (cond, equs) = + let cond' = evaluate_expression ctx cond in + let equs' = instantiate_equations ctx equs in + cond', equs' in + [WhenClauseE (List.map instantiate_alternative alts)] + +and instantiate_connection ctx sign expr sign' expr' = + let expr = evaluate_expression ctx expr + and expr' = evaluate_expression ctx expr' in + [ConnectFlows (sign, expr, sign', expr')] + +and instantiate_for_clause_e ctx ranges equs = + let rec instantiate_for_clause_e' ctx = function + | [] -> List.flatten (List.map (instantiate_equation ctx) equs) + | ranges -> equations_of_reduction ctx ranges + and equations_of_reduction ctx ranges = match ranges with + | (Vector exprs) :: ranges -> + let f expr = + let ctx' = + { ctx with + class_context = ForContext (ctx, Some expr) + } in + instantiate_for_clause_e' ctx' ranges in + List.flatten (List.map f (Array.to_list exprs)) + | _ -> + raise (InstantError + {err_msg = ["_InvalidForClauseRange"]; + err_info = []; + err_ctx = ctx}) in + let ranges = List.map (evaluate_expression ctx) ranges in + instantiate_for_clause_e' ctx ranges + +and evaluate_expression ctx expr = + let ctx = {ctx with location = expression_location ctx expr} in + match expr.NameResolve.nature with + | NameResolve.BinaryOperation (binop, expr, expr') -> + evaluate_binary_operation ctx binop expr expr' + | NameResolve.DynamicIdentifier (level, id) -> + evaluate_dynamic_identifier ctx level id + | NameResolve.False -> False + | NameResolve.FieldAccess (expr, id) -> + evaluate_field_access ctx expr id + | NameResolve.FunctionArgument pos -> evaluate_function_argument ctx pos + | NameResolve.FunctionCall (expr, exprs, expr') -> + evaluate_function_call ctx expr exprs expr' + | NameResolve.FunctionInvocation exprs -> + evaluate_function_invocation ctx exprs + | NameResolve.If (alts, default) -> evaluate_if ctx alts default + | NameResolve.IndexedAccess (expr, exprs) -> + let expr = evaluate_expression ctx expr + and exprs = List.map (evaluate_expression ctx) exprs in + evaluate_indexed_access ctx expr exprs + | NameResolve.Integer i -> Integer i + | NameResolve.LocalIdentifier (level, id) -> + evaluate_local_identifier ctx level id + | NameResolve.LoopVariable level -> evaluate_loop_variable ctx level + | NameResolve.NoEvent expr -> evaluate_no_event ctx expr + | NameResolve.PredefinedIdentifier id -> PredefinedIdentifier id + | NameResolve.Range (start, step, stop) -> + evaluate_range ctx start step stop + | NameResolve.Real f -> Real f + | NameResolve.String s -> String s + | NameResolve.ToplevelIdentifier id -> + evaluate_toplevel_identifier ctx id + | NameResolve.True -> True + | NameResolve.Tuple exprs -> evaluate_tuple ctx exprs + | NameResolve.UnaryOperation (unop, expr) -> + evaluate_unary_operation ctx unop expr + | NameResolve.VectorReduction (ranges, expr) -> + evaluate_vector_reduction ctx ranges expr + | NameResolve.Vector exprs -> evaluate_vector ctx exprs + | NameResolve.Coercion (coer, expr) -> + evaluate_coercion ctx coer expr + +and evaluate_binary_operation ctx binop expr expr' = + let expr = evaluate_expression ctx expr + and expr' = evaluate_expression ctx expr' in + let expr = flatten_expression expr + and expr' = flatten_expression expr' in + match binop with + | NameResolve.And -> evaluate_and expr expr' + | NameResolve.Divide -> evaluate_divide ctx expr expr' + | NameResolve.EqualEqual -> evaluate_equalequal expr expr' + | NameResolve.GreaterEqual -> evaluate_greater_equal expr expr' + | NameResolve.Greater -> evaluate_greater expr expr' + | NameResolve.LessEqual -> evaluate_less_equal expr expr' + | NameResolve.Less -> evaluate_less expr expr' + | NameResolve.Times -> evaluate_times expr expr' + | NameResolve.NotEqual -> evaluate_not_equal expr expr' + | NameResolve.Or -> evaluate_or expr expr' + | NameResolve.Plus -> evaluate_plus expr expr' + | NameResolve.Power -> evaluate_power ctx expr expr' + | NameResolve.Minus -> evaluate_minus expr expr' + +and evaluate_dynamic_identifier ctx level id = + let rec evaluate_dynamic_identifier' inst level = + match level, inst.enclosing_instance with + | 0, _ -> instance_field_access ctx inst id + | _, Some inst -> evaluate_dynamic_identifier' inst (level - 1) + | _, None -> assert false (*error*) in + match ctx.instance_context with + | Some inst -> evaluate_dynamic_identifier' inst level + | None -> assert false (*error*) + +and evaluate_field_access ctx expr id = + let expr = evaluate_expression ctx expr in + field_access ctx expr id + +and evaluate_function_argument ctx pos = match ctx.class_context with + | FunctionEvaluationContext (_, expr, _) when pos = 0 -> expr + | FunctionEvaluationContext (_, _, exprs) -> List.nth exprs (pos - 1) + | ForContext (ctx', _) -> evaluate_function_argument ctx' pos + | InstanceContext _ | ToplevelContext -> assert false (*error*) + +and evaluate_function_call ctx expr exprs expr' = + let expr = evaluate_expression ctx expr + and exprs = List.map (evaluate_expression ctx) exprs in + let exprs = List.map flatten_expression exprs in + let ctx' = + { ctx with + class_context = FunctionEvaluationContext (ctx, expr, exprs) + } in + evaluate_expression ctx' expr' + +and evaluate_function_invocation ctx exprs = + let exprs = List.map (evaluate_expression ctx) exprs in + let exprs = List.map flatten_expression exprs in + let evaluate_function_with_arguments = function + | ClassReference cl_def -> + evaluate_class_function_invocation cl_def exprs + | PredefinedIdentifier s -> + evaluate_predefined_function_invocation ctx s exprs + | ComponentReference _ -> + raise (InstantError + { err_msg = ["_NotYetImplemented"; "_ComponentFuncInvocation"]; + err_info = []; + err_ctx = ctx }) + | _ -> assert false (*error*) in + let rec evaluate_function_invocation' ctx = match ctx.class_context with + | FunctionEvaluationContext (_, expr, _) -> + evaluate_function_with_arguments expr + | ForContext (ctx', _) -> evaluate_function_invocation' ctx' + | InstanceContext _ | ToplevelContext -> assert false (*error*) in + evaluate_function_invocation' ctx + +and evaluate_if ctx alts default = + let create_if alts default = match alts with + | [] -> default + | _ :: _ -> If (alts, default) in + let rec evaluate_alternatives alts' alts = match alts with + | [] -> + let default = evaluate_expression ctx default in + create_if (List.rev alts') default + | (expr, expr') :: alts -> + let expr = evaluate_expression ctx expr in + evaluate_alternative expr expr' alts' alts + and evaluate_alternative expr expr' alts' alts = match expr with + | True -> + let default = evaluate_expression ctx expr' in + create_if (List.rev alts') default + | False -> evaluate_alternatives alts' alts + | _ -> + let expr' = evaluate_expression ctx expr' in + evaluate_alternatives ((expr, expr') :: alts') alts in + evaluate_alternatives [] alts + +and evaluate_indexed_access ctx expr exprs = + let rec vector_indexed_access exprs' exprs = match exprs with + | [] -> expr + | Integer i :: exprs -> + let expr' = + try + exprs'.(Int32.to_int i - 1) + with _ -> + raise (InstantError + { err_msg = ["_IndexOutOfBound"]; + err_info = []; + err_ctx = ctx}) (*error*) in + evaluate_indexed_access ctx expr' exprs + | (Vector subs) :: exprs -> + let f sub = vector_indexed_access exprs' (sub :: exprs) in + Vector (Array.map f subs) + | _ -> IndexedAccess (expr, exprs) + and component_indexed_access cpnt_desc exprs = + let rec static_array_indexed_access cpnt_descs exprs = match exprs with + | [] -> expr + | Integer i :: exprs -> + let i' = Int32.to_int i in + if Array.length cpnt_descs >= i' then + let cpnt_desc = cpnt_descs.(i' - 1) in + let expr' = ComponentReference cpnt_desc in + evaluate_indexed_access ctx expr' exprs + else + raise (InstantError + { err_msg = ["_IndexOutOfBound"]; + err_info = []; + err_ctx = ctx}) (*error*) + | (Vector subs) :: exprs -> + let f sub = static_array_indexed_access cpnt_descs (sub :: exprs) in + Vector (Array.map f subs) + | exprs -> IndexedAccess (expr, exprs) in + match evaluate cpnt_desc.component_nature with + | DynamicArray _ -> IndexedAccess (ComponentReference cpnt_desc, exprs) + | StaticArray cpnt_descs -> + static_array_indexed_access cpnt_descs exprs + | Instance _ | PredefinedTypeInstance _ -> expr in + match expr, exprs with + | _, [] -> expr + | ComponentReference cpnt_desc, _ -> + component_indexed_access cpnt_desc exprs + | Vector exprs', _ -> + vector_indexed_access exprs' exprs + | If (alts, default), _ -> + let f (cond, expr) = (cond, evaluate_indexed_access ctx expr exprs) in + If (List.map f alts, evaluate_indexed_access ctx default exprs) + | _ -> IndexedAccess (expr, exprs) + +and evaluate_local_identifier ctx level id = + let rec evaluate_local_identifier' ctx inst level = + match level, ctx.parent_context with + | 0, _ -> instance_field_access ctx inst id + | _, Some ctx -> evaluate_local_identifier ctx (level - 1) id + | _, None -> assert false (*error*) in + match ctx.class_context with + | ForContext (ctx, _) | FunctionEvaluationContext (ctx, _, _) -> + evaluate_local_identifier ctx level id + | InstanceContext inst -> evaluate_local_identifier' ctx inst level + | ToplevelContext -> assert false (*error*) + +and evaluate_loop_variable ctx level = + let rec evaluate_loop_variable' ctx level' = + match level', ctx.class_context with + | 0, ForContext (_, None) -> assert false (*LoopVariable level'*) + | 0, ForContext (_, Some expr) -> expr + | _, ForContext (ctx, _) -> evaluate_loop_variable ctx (level' - 1) + | _, FunctionEvaluationContext (ctx, _, _) -> + evaluate_loop_variable' ctx level' + | _, (InstanceContext _ | ToplevelContext) -> assert false (*error*) in + evaluate_loop_variable' ctx level + +and evaluate_no_event ctx expr = + let expr = evaluate_expression ctx expr in + match expr with + | True | False | Integer _ | Real _ | String _ | EnumerationElement _ -> + expr + | _ -> NoEvent expr + +and evaluate_range ctx start step stop = + let start = evaluate_expression ctx start + and step = evaluate_expression ctx step + and stop = evaluate_expression ctx stop in + let real_of_expression expr = match expr with + | Real r -> r + | Integer i -> Int32.to_float i + | _ -> assert false in + let integer_interval istart istep istop = match istart, istep, istop with + | _ + when (Int32.compare istop istart) * + (Int32.compare istep Int32.zero) < 0 -> + Vector (Array.make 0 (Integer istart)) + | _ -> + let n = + Int32.div (Int32.sub istop istart) istep in + let n' = Int32.to_int (Int32.succ n) in + let f i = + let i' = Int32.of_int i in + let j = + Int32.add istart (Int32.mul i' istep) in + Integer j in + Vector (Array.init n' f) + and real_interval rstart rstep rstop = match rstart, rstep, rstop with + | _ when (rstop -. rstart) /. rstep < 0. -> + Vector (Array.make 0 (Real rstart)) + | _ -> + let n = truncate ((rstop -. rstart) /. rstep) + 1 + and f i = Real (rstart +. float_of_int i *. rstep) in + Vector (Array.init n f) in + match start, step, stop with + | _, Integer istep, _ + when Int32.compare istep Int32.zero = 0 -> + raise (InstantError + {err_msg = ["_RangeStepValueCannotBeNull"]; + err_info = []; + err_ctx = ctx}) + | _, Real rstep, _ when rstep = 0. -> + raise (InstantError + {err_msg = ["_RangeStepValueCannotBeNull"]; + err_info = []; + err_ctx = ctx}) + | Integer istart, Integer istep, Integer istop -> + integer_interval istart istep istop + | (Integer _ | Real _), (Integer _ | Real _), (Integer _ | Real _) -> + let rstart = real_of_expression start + and rstep = real_of_expression step + and rstop = real_of_expression stop in + real_interval rstart rstep rstop + | _, _, _ -> Range (start, step, stop) + +and evaluate_coercion ctx coer expr = + let rec evaluate_real_of_integer expr' = match expr' with + | Integer i -> Real (Int32.to_float i) + | Vector exprs -> + Vector (Array.map evaluate_real_of_integer exprs) + | _ -> expr' in + let expr' = evaluate_expression ctx expr in + match coer with + | NameResolve.RealOfInteger -> evaluate_real_of_integer expr' + +and evaluate_toplevel_identifier ctx id = + let elt_desc = List.assoc id (evaluate ctx.toplevel) in + match evaluate elt_desc.element_nature with + | Class cl_def -> ClassReference cl_def + | Component cpnt_desc -> ComponentReference cpnt_desc + +and evaluate_tuple ctx exprs = + Tuple (List.map (evaluate_expression ctx) exprs) + +and evaluate_unary_operation ctx unop expr = + let expr = evaluate_expression ctx expr in + let expr = flatten_expression expr in + match unop with + | NameResolve.Not -> evaluate_not expr + | NameResolve.UnaryMinus -> evaluate_unary_minus expr + | NameResolve.UnaryPlus -> expr + +(*and evaluate_vector_reduction ctx ranges expr = + let rec evaluate_vector_reduction' ctx = function + | [] -> evaluate_expression ctx expr + | ranges -> vector_of_reduction ctx ranges + and vector_of_reduction ctx = function + | Range (Integer start, Integer step, Integer stop) :: ranges -> + vector_of_range ctx start step stop ranges + | ranges -> + let ctx' = + { ctx with + class_context = ForContext (ctx, None) + } in + VectorReduction (ranges, evaluate_expression ctx' expr) + and vector_of_range ctx start step stop ranges = + let rec expression_list pred start = match pred start with + | true -> [] + | false -> + let ctx' = + { ctx with + class_context = ForContext (ctx, Some (Integer start)) + } in + let expr = evaluate_vector_reduction' ctx' ranges in + expr :: expression_list pred (Int32.add start step) in + let cmp = Int32.compare step 0l in + match cmp with + | 0 when Int32.compare start stop <> 0 -> assert false (*error*) + | 0 -> Vector [||] + | _ when cmp < 0 -> + let pred = function i -> Int32.compare i stop < 0 in + let exprs = expression_list pred start in + Vector (Array.of_list exprs) + | _ -> + let pred = function i -> Int32.compare i stop > 0 in + let exprs = expression_list pred start in + Vector (Array.of_list exprs) in + let ranges = List.map (evaluate_expression ctx) ranges in + evaluate_vector_reduction' ctx ranges*) + +and evaluate_vector_reduction ctx ranges expr = + let rec evaluate_vector_reduction' ctx = function + | [] -> evaluate_expression ctx expr + | ranges -> vector_of_reduction ctx ranges + and vector_of_reduction ctx = function + | Range (Integer u, Integer p, Integer v) :: ranges -> + vector_of_integer_range ctx u p v ranges + | Range (Real u, Real p, Real v) :: ranges -> + vector_of_real_range ctx u p v ranges + | Vector exprs :: ranges -> + let f i = + let ctx' = + { ctx with + class_context = ForContext (ctx, Some exprs.(i)) + } in + evaluate_vector_reduction' ctx' ranges in + Vector (Array.init (Array.length exprs) f) + | _ -> assert false + and vector_of_integer_range ctx start step stop ranges = + let rec expression_list pred start = match pred start with + | true -> [] + | false -> + let expr = Integer start in + let ctx' = + { ctx with + class_context = + ForContext (ctx, Some expr) + } in + let expr = evaluate_vector_reduction' ctx' ranges in + let next = Int32.add start step in + expr :: expression_list pred next in + match step with + | _ when Int32.compare step Int32.zero = 0 -> + raise (InstantError + {err_msg = ["_RangeStepValueCannotBeNull"]; + err_info = []; + err_ctx = ctx}) + | _ when Int32.compare step Int32.zero < 0 -> + let pred = function i -> (Int32.compare i stop < 0) in + Vector (Array.of_list (expression_list pred start)) + | _ -> + let pred = function i -> (Int32.compare i stop > 0) in + Vector (Array.of_list (expression_list pred start)) + and vector_of_real_range ctx start step stop ranges = + let rec expression_list pred start = match pred start with + | true -> [] + | false -> + let expr = Real start in + let ctx' = + { ctx with + class_context = ForContext (ctx, Some expr) + } in + let expr = evaluate_vector_reduction' ctx' ranges in + expr :: expression_list pred (start +. step) in + match step with + | 0. -> + raise (InstantError + {err_msg = ["_RangeStepValueCannotBeNull"]; + err_info = []; + err_ctx = ctx}) + | _ when step < 0. -> + let pred = function f -> f < stop in + Vector (Array.of_list (expression_list pred start)) + | _ -> + let pred = function f -> f > stop in + Vector (Array.of_list (expression_list pred start)) in + let ranges = List.map (evaluate_expression ctx) ranges in + evaluate_vector_reduction' ctx ranges + +and evaluate_vector ctx exprs = + let exprs = List.map (evaluate_expression ctx) exprs in + Vector (Array.of_list exprs) + +and evaluate_and expr expr' = match expr, expr' with + | False, (False | True) | True, False -> False + | True, True -> True + | Vector exprs, Vector exprs' -> + Vector (ArrayExt.map2 evaluate_and exprs exprs') + | _ -> BinaryOperation (And, expr, expr') + +and evaluate_divide ctx expr expr' = match expr, expr' with + | _, Integer 0l -> + raise (InstantError + { err_msg = ["_DivisionByZero"]; + err_info = []; + err_ctx = ctx }) (*error*) + | Integer 0l, _ -> Integer 0l + | Integer i, Integer i' -> + Real ((Int32.to_float i) /. (Int32.to_float i')) + | _, Real 0. -> + raise (InstantError + { err_msg = ["_DivisionByZero"]; + err_info = []; + err_ctx = ctx }) (*error*) + | Integer i, Real f -> Real (Int32.to_float i /. f) + | Real f, Integer i -> Real (f /. Int32.to_float i) + | Real f, Real f' -> Real (f /. f') + | Vector exprs, _ -> + let divide_element expr = evaluate_divide ctx expr expr' in + Vector (Array.map divide_element exprs) + | _ -> BinaryOperation (Divide, expr, expr') + +and evaluate_equalequal expr expr' = match expr, expr' with + | Integer i, Integer i' when i = i' -> True + | Integer i, Real f | Real f, Integer i when f = Int32.to_float i -> True + | Real f, Real f' when f = f' -> True + | (Integer _ | Real _), (Integer _ | Real _) -> False + | Vector exprs, Vector exprs' + when + ArrayExt.for_all2 + (fun expr expr' -> evaluate_equalequal expr expr' = True) + exprs + exprs' -> True + | Vector _, Vector _ -> False + | _ -> BinaryOperation (EqualEqual, expr, expr') + +and evaluate_greater_equal expr expr' = match expr, expr' with + | Integer i, Integer i' when i >= i' -> True + | Integer i, Real f when Int32.to_float i >= f -> True + | Real f, Integer i when f >= Int32.to_float i -> True + | Real f, Real f' when f >= f' -> True + | (Integer _ | Real _), (Integer _ | Real _) -> False + | _ -> BinaryOperation (GreaterEqual, expr, expr') + +and evaluate_greater expr expr' = match expr, expr' with + | Integer i, Integer i' when i > i' -> True + | Integer i, Real f when Int32.to_float i > f -> True + | Real f, Integer i when f > Int32.to_float i -> True + | Real f, Real f' when f > f' -> True + | (Integer _ | Real _), (Integer _ | Real _) -> False + | _ -> BinaryOperation (Greater, expr, expr') + +and evaluate_less_equal expr expr' = match expr, expr' with + | Integer i, Integer i' when i <= i' -> True + | Integer i, Real f when Int32.to_float i <= f -> True + | Real f, Integer i when f <= Int32.to_float i -> True + | Real f, Real f' when f <= f' -> True + | (Integer _ | Real _), (Integer _ | Real _) -> False + | _ -> BinaryOperation (LessEqual, expr, expr') + +and evaluate_less expr expr' = match expr, expr' with + | Integer i, Integer i' when i < i' -> True + | Integer i, Real f when Int32.to_float i < f -> True + | Real f, Integer i when f < Int32.to_float i -> True + | Real f, Real f' when f < f' -> True + | (Integer _ | Real _), (Integer _ | Real _) -> False + | _ -> BinaryOperation (Less, expr, expr') + +and evaluate_times expr expr' = + let rec line exprs i = match exprs.(i) with + | Vector exprs -> exprs + | _ -> assert false + and column exprs j = + let f i = match exprs.(i) with + | Vector exprs -> exprs.(j) + | _ -> assert false in + Array.init (Array.length exprs) f + and ndims expr = match expr with + | Vector exprs when Array.length exprs = 0 -> assert false + | Vector exprs -> 1 + ndims exprs.(0) + | _ -> 0 + and size expr i = match expr, i with + | _, 0 -> assert false + | Vector exprs, 1 -> Array.length exprs + | _, 1 -> 0 + | Vector exprs, _ when i > 1 -> size exprs.(0) (i - 1) + | _, _ -> assert false + and vector_mult exprs exprs' = + let exprs = ArrayExt.map2 evaluate_times exprs exprs' in + match Array.length exprs with + | 0 -> assert false + | 1 -> exprs.(0) + | n -> + let exprs' = Array.sub exprs 1 (n - 1) in + Array.fold_left evaluate_plus exprs.(0) exprs' in + match expr, expr' with + | Integer 0l, _ | _, Integer 0l -> Integer 0l + | Integer 1l, _ -> expr' + | _, Integer 1l -> expr + | Integer i, Integer i' -> Integer (Int32.mul i i') + | Integer i, Real f | Real f, Integer i -> Real (f *. Int32.to_float i) + | Real f, Real f' -> Real (f *. f') + | _, Vector exprs' when (ndims expr = 0) -> + Vector (Array.map (evaluate_times expr) exprs') + | Vector exprs, _ when (ndims expr' = 0) -> + Vector (Array.map (evaluate_times expr') exprs) + | Vector exprs, Vector exprs' when (ndims expr = 1) && (ndims expr' = 1) -> + vector_mult exprs exprs' + | Vector exprs, Vector exprs' when (ndims expr = 1) && (ndims expr' = 2) -> + let f j = vector_mult exprs (column exprs' j) in + Vector (Array.init (size expr' 2) f) + | Vector exprs, Vector exprs' when (ndims expr = 2) && (ndims expr' = 1) -> + let f i = vector_mult (line exprs i) exprs' in + Vector (Array.init (size expr 1) f) + | Vector exprs, Vector exprs' when (ndims expr = 2) && (ndims expr' = 2) -> + let f i j = vector_mult (line exprs i) (column exprs' j) in + let g i = Vector (Array.init (size expr' 2) (f i)) in + Vector (Array.init (size expr 1) g) + | _ -> BinaryOperation (Times, expr, expr') + +and evaluate_not_equal expr expr' = match expr, expr' with + | Integer i, Integer i' when i <> i' -> True + | Integer i, Real f | Real f, Integer i when f <> Int32.to_float i -> True + | Real f, Real f' when f <> f' -> True + | (Integer _ | Real _), (Integer _ | Real _) -> False + | Vector exprs, Vector exprs' + when + ArrayExt.exists2 + (fun expr expr' -> evaluate_equalequal expr expr' = False) + exprs + exprs' -> True + | Vector _, Vector _ -> False + | _ -> BinaryOperation (NotEqual, expr, expr') + +and evaluate_or expr expr' = match expr, expr' with + | True, (False | True) | False, True -> True + | False, False -> False + | Vector exprs, Vector exprs' -> + Vector (ArrayExt.map2 evaluate_or exprs exprs') + | _ -> BinaryOperation (Or, expr, expr') + +and evaluate_plus expr expr' = match expr, expr' with + | Integer 0l, _ -> expr' + | _, Integer 0l -> expr + | Integer i, Integer i' -> Integer (Int32.add i i') + | Integer i, Real f | Real f, Integer i -> Real (f +. Int32.to_float i) + | Real f, Real f' -> Real (f +. f') + | Vector exprs, Vector exprs' -> + Vector (ArrayExt.map2 evaluate_plus exprs exprs') + | _ -> BinaryOperation (Plus, expr, expr') + +and evaluate_power ctx expr expr' = + match expr, expr' with + | (Integer 0l | Real 0.), (Integer 0l | Real 0.) -> + raise (InstantError + { err_msg = ["_ZeroRaisedToTheZeroPower"]; + err_info = []; + err_ctx = ctx }) (*error*) + | (Integer 0l | Real 0.), Integer i' + when Int32.compare i' 0l < 0 -> + raise (InstantError + { err_msg = ["_ZeroRaisedToNegativePower"]; + err_info = []; + err_ctx = ctx }) (*error*) + | (Integer 0l | Real 0.), Real f' when f' < 0. -> + raise (InstantError + { err_msg = ["_ZeroRaisedToNegativePower"]; + err_info = []; + err_ctx = ctx }) (*error*) + | Integer 0l, Integer _ -> + (* We know the answer for sure since second argument is constant *) + Real 0. + | (Integer 0l | Real 0.), (Integer _ | Real _) -> Real 0. + | Integer i, Real _ when Int32.compare i 0l < 0 -> + raise (InstantError + { err_msg = ["_RealExponentOfNegativeNumber"]; + err_info = []; + err_ctx = ctx }) (*error*) + | Real f, Real _ when f < 0. -> + raise (InstantError + { err_msg = ["_RealExponentOfNegativeNumber"]; + err_info = []; + err_ctx = ctx }) (*error*) + | Integer i, Integer i' -> + Real ((Int32.to_float i) ** (Int32.to_float i')) + | Integer i, Real f -> Real ((Int32.to_float i) ** f) + | Real f, Integer i' -> Real (f ** (Int32.to_float i')) + | Real f, Real f' -> Real (f ** f') + | Vector exprs, Integer i -> + raise (InstantError + { err_msg = ["_NotYetImplemented"; + "_VectorRaisedToIntegerPower"]; + err_info = []; + err_ctx = ctx }) + | _ -> BinaryOperation (Power, expr, expr') + +and evaluate_minus expr expr' = match expr, expr' with + | Integer 0l, _ -> evaluate_unary_minus expr' + | _, Integer 0l -> expr + | Integer i, Integer i' -> Integer (Int32.sub i i') + | Integer i, Real f -> Real (Int32.to_float i -. f) + | Real f, Integer i -> Real (f -. Int32.to_float i) + | Real f, Real f' -> Real (f -. f') + | Vector exprs, Vector exprs' -> + Vector (ArrayExt.map2 evaluate_minus exprs exprs') + | _ -> BinaryOperation (Minus, expr, expr') + +and evaluate_class_function_invocation cl_def exprs = + FunctionCall (ClassReference cl_def, exprs) + +and evaluate_predefined_function_invocation ctx s exprs = + match s, exprs with + | "size", _ -> evaluate_size exprs + | "reinit", [expr; expr'] -> evaluate_reinit expr expr' + | "der", [expr] -> evaluate_der expr + | "pre", [expr] -> evaluate_pre expr + | ("edge" | "change" | "initial" | "terminal" | "sample" | + "delay" | "assert" | "terminate"), _ -> + raise (InstantError + { err_msg = ["_NotYetImplemented"; "_PredefinedOperator"; s]; + err_info = []; + err_ctx = ctx}) (*error*) + | "abs", [expr] -> evaluate_abs expr + | "sign", [expr] -> evaluate_sign expr + | "cos", [expr] -> evaluate_cos expr + | "sin", [expr] -> evaluate_sin expr + | "tan", [expr] -> evaluate_tan expr + | "exp", [expr] -> evaluate_exp expr + | "log", [expr] -> evaluate_log expr + | "sqrt", [expr] -> evaluate_sqrt expr + | "asin", [expr] -> evaluate_asin expr + | "acos", [expr] -> evaluate_acos expr + | "atan", [expr] -> evaluate_atan expr + | "sinh", [expr] -> evaluate_sinh expr + | "cosh", [expr] -> evaluate_cosh expr + | "tanh", [expr] -> evaluate_tanh expr + | "asinh", [expr] -> evaluate_asinh expr + | "acosh", [expr] -> evaluate_acosh expr + | "atanh", [expr] -> evaluate_atanh expr + | "log10", [expr] -> evaluate_log10 expr + | "max", [expr; expr'] -> evaluate_max expr expr' + | "min", [expr; expr'] -> evaluate_min expr expr' + | "div", [expr; expr'] -> evaluate_div ctx expr expr' + | "mod", [expr; expr'] -> evaluate_mod expr expr' + | "rem", [expr; expr'] -> evaluate_rem expr expr' + | "ceil", [expr] -> evaluate_ceil expr + | "floor", [expr] -> evaluate_floor expr + | "max", [expr] -> evaluate_max_array expr + | "min", [expr] -> evaluate_min_array expr + | "sum", [expr] -> evaluate_sum expr + | "product", [expr] -> evaluate_product expr + | "scalar", [expr] -> evaluate_scalar ctx expr + | "ones", exprs -> evaluate_ones ctx exprs + | "zeros", exprs -> evaluate_zeros ctx exprs + | "fill", expr :: exprs -> evaluate_fill ctx expr exprs + | "identity", [expr] -> evaluate_identity ctx expr + | "diagonal", [expr] -> evaluate_diagonal ctx expr + | "vector", [ expr ] -> evaluate_vector_operator ctx expr + | "matrix", [ expr ] -> evaluate_matrix_operator ctx expr + | "transpose", [ expr ] -> evaluate_transpose expr + | "symmetric", [ expr ] -> evaluate_symmetric ctx expr + | _ -> + raise (InstantError + { err_msg = ["_UnknownFunction"; s]; + err_info = []; + err_ctx = ctx}) (*error*) + +and evaluate_symmetric ctx expr = match expr with + | Vector [||] -> assert false + | Vector exprs when size exprs.(0) 0 <> Array.length exprs -> + raise (InstantError + { err_msg = ["_InvalidArgOfOper"; "symmetric"]; + err_info = []; + err_ctx = ctx }) (*error*) + | Vector exprs -> + let f i j = + if i > j then element i (element j expr) + else element j (element i expr) in + let n = Array.length exprs in + let g i = Vector (Array.init n (f i)) in + Vector (Array.init n g) + | _ -> assert false + +and evaluate_transpose expr = + match expr with + | Vector exprs -> + let f i = Vector (Array.map (element i) exprs) in + Vector (Array.init (size expr 1) f) + | _ -> assert false + +and evaluate_matrix_operator ctx expr = + let rec scalar expr = match expr with + | Vector [| expr |] -> scalar expr + | Vector _ -> + raise (InstantError + { err_msg = ["_InvalidArgOfOper"; "matrix"]; + err_info = []; + err_ctx = ctx }) (*error*) + | _ -> expr in + match expr with + | _ when ndims expr < 2 -> + evaluate_promote ctx 2 expr + | _ when ndims expr = 2 -> expr + | Vector exprs -> + let f expr = Vector (Array.map scalar (array_elements expr)) in + Vector (Array.map f exprs) + | _ -> assert false + +and evaluate_promote ctx n expr = + let rec evaluate_promote' i expr = + match expr with + | _ when i = 0 -> expr + | Vector exprs when i > 0 -> + Vector (Array.map (evaluate_promote' i) exprs) + | _ when i > 0 -> + Vector [| evaluate_promote' (i - 1) expr |] + | _ -> assert false in + match ndims expr with + | n' when n' < n -> + evaluate_promote' (n - n') expr + | _ -> expr + +and evaluate_vector_operator ctx expr = + let rec evaluate_scalar expr = match expr with + | Vector [| expr |] -> evaluate_scalar expr + | Vector _ -> + raise (InstantError + { err_msg = ["_InvalidArgOfOper"; "vector"]; + err_info = []; + err_ctx = ctx }) (*error*) + | _ -> expr + and evaluate_vector_operator' expr = match expr with + | Vector [| expr |] -> evaluate_vector_operator' expr + | Vector exprs -> + Array.map evaluate_scalar exprs + | _ -> [| expr |] in + Vector (evaluate_vector_operator' expr) + +and evaluate_max_array expr = + let rec evaluate_max_list exprs = match exprs with + | [] -> assert false + | [ expr ] -> expr + | expr :: exprs -> + evaluate_max expr (evaluate_max_list exprs) in + evaluate_max_list (scalar_elements expr) + +and evaluate_min_array expr = + let rec evaluate_min_list exprs = match exprs with + | [] -> assert false + | [ expr ] -> expr + | expr :: exprs -> + evaluate_min expr (evaluate_min_list exprs) in + evaluate_min_list (scalar_elements expr) + +and evaluate_sum expr = + let rec evaluate_sum_list exprs = match exprs with + | [] -> Integer Int32.zero + | [ expr ] -> expr + | expr :: exprs -> + evaluate_plus expr (evaluate_sum_list exprs) in + match expr with + | Vector exprs -> + evaluate_sum_list (scalar_elements expr) + | _ -> assert false + +and evaluate_product expr = + let rec evaluate_product_list exprs = match exprs with + | [] -> Integer Int32.one + | [ expr ] -> expr + | expr :: exprs -> + evaluate_times expr (evaluate_product_list exprs) in + match expr with + | Vector exprs -> + evaluate_product_list (scalar_elements expr) + | _ -> assert false + +and evaluate_fill ctx expr exprs = + let rec evaluate_fill' dims = match dims with + | [] -> expr + | Integer i :: dims when Int32.compare i Int32.zero > 0 -> + let i = Int32.to_int i in + Vector (Array.make i (evaluate_fill' dims)) + | _ -> + raise (InstantError + { err_msg = ["_InvalidArgOfOper"; "fill"]; + err_info = []; + err_ctx = ctx }) (*error*) in + evaluate_fill' exprs + +and evaluate_zeros ctx exprs = + let rec evaluate_zeros' dims = match dims with + | [] -> Integer Int32.zero + | Integer i :: dims when Int32.compare i Int32.zero > 0 -> + let i = Int32.to_int i in + Vector (Array.make i (evaluate_zeros' dims)) + | _ -> + raise (InstantError + { err_msg = ["_InvalidArgOfOper"; "zeros"]; + err_info = []; + err_ctx = ctx }) (*error*) in + evaluate_zeros' exprs + +and evaluate_ones ctx exprs = + let rec evaluate_ones' dims = match dims with + | [] -> Integer Int32.one + | Integer i :: dims when Int32.compare i Int32.zero > 0 -> + let i = Int32.to_int i in + Vector (Array.make i (evaluate_ones' dims)) + | _ -> + raise (InstantError + { err_msg = ["_InvalidArgOfOper"; "ones"]; + err_info = []; + err_ctx = ctx }) (*error*) in + evaluate_ones' exprs + +and evaluate_identity ctx expr = + let n = match expr with + | Integer i when Int32.compare i Int32.zero > 0 -> + Int32.to_int i + | _ -> + raise (InstantError + { err_msg = ["_InvalidArgOfOper"; "identity"]; + err_info = []; + err_ctx = ctx }) (*error*) in + let f i j = + Integer (if j = i then Int32.one else Int32.zero) in + let g i = Vector (Array.init n (f i)) in + Vector (Array.init n g) + +and evaluate_diagonal ctx expr = + let exprs = match expr with + | Vector [||] -> + raise (InstantError + { err_msg = ["_InvalidArgOfOper"; "diagonal"]; + err_info = []; + err_ctx = ctx }) (*error*) + | Vector exprs -> exprs + | _ -> + raise (InstantError + { err_msg = ["_InvalidArgOfOper"; "diagonal"]; + err_info = []; + err_ctx = ctx }) (*error*) in + let n = Array.length exprs in + let f i j = + if j = i then exprs.(i) else Integer Int32.zero in + let g i = Vector (Array.init n (f i)) in + Vector (Array.init n g) + +and evaluate_scalar ctx expr = + let rec evaluate_scalar' expr = match expr with + | Vector [| expr |] -> evaluate_scalar' expr + | Vector _ -> + raise (InstantError + { err_msg = ["_InvalidArgOfOper"; "scalar"]; + err_info = []; + err_ctx = ctx }) (*error*) + | _ -> expr in + match expr with + | Vector [| expr |] -> evaluate_scalar' expr + | _ -> + raise (InstantError + { err_msg = ["_InvalidArgOfOper"; "scalar"]; + err_info = []; + err_ctx = ctx }) (*error*) + +and evaluate_reinit expr expr' = match expr, expr' with + | Vector exprs, Vector exprs' -> + Vector (ArrayExt.map2 evaluate_reinit exprs exprs') + | _, _ -> + FunctionCall (PredefinedIdentifier "reinit", [ expr; expr' ]) + +and evaluate_der expr = match expr with + | Integer _ | String _ | Real _ -> Real 0. + | Vector exprs -> Vector (Array.map evaluate_der exprs) + | BinaryOperation (Plus, expr, expr') -> + let expr = evaluate_der expr + and expr' = evaluate_der expr' in + BinaryOperation (Plus, expr, expr') + | BinaryOperation (Minus, expr, expr') -> + let expr = evaluate_der expr + and expr' = evaluate_der expr' in + BinaryOperation (Minus, expr, expr') + | BinaryOperation (Times, expr1, expr2) -> + let expr1' = evaluate_der expr1 + and expr2' = evaluate_der expr2 in + let expr1 = BinaryOperation (Times, expr1', expr2) + and expr2 = BinaryOperation (Times, expr1, expr2') in + BinaryOperation (Plus, expr1, expr2) + | BinaryOperation (Divide, expr1, expr2) -> + let expr1' = evaluate_der expr1 + and expr2' = evaluate_der expr2 in + let expr1' = BinaryOperation (Times, expr1', expr2) + and expr2' = BinaryOperation (Times, expr1, expr2') in + let expr1 = BinaryOperation (Minus, expr1', expr2') + and expr2 = BinaryOperation (Times, expr2, expr2) in + BinaryOperation (Divide, expr1, expr2) + | BinaryOperation (Power, expr, Integer i) -> + let expr' = evaluate_der expr + and j = Int32.sub i Int32.one in + let expr' = BinaryOperation (Times, Integer i, expr') + and expr = BinaryOperation (Power, expr, Integer j) in + BinaryOperation (Times, expr', expr) + | BinaryOperation (Power, expr, Real f) -> + let expr' = evaluate_der expr + and f' = f -. 1. in + let expr' = BinaryOperation (Times, Real f, expr') + and expr = BinaryOperation (Power, expr, Real f') in + BinaryOperation (Times, expr', expr) + | FunctionCall (PredefinedIdentifier "cos", [ expr ]) -> + let expr' = evaluate_der expr + and expr = FunctionCall (PredefinedIdentifier "sin", [ expr ]) in + let expr = UnaryOperation (UnaryMinus, expr) in + BinaryOperation (Times, expr', expr) + | FunctionCall (PredefinedIdentifier "sin", [ expr ]) -> + let expr' = evaluate_der expr + and expr = FunctionCall (PredefinedIdentifier "cos", [ expr ]) in + BinaryOperation (Times, expr', expr) + | FunctionCall (PredefinedIdentifier "tan", [ expr1 ]) -> + let expr1' = evaluate_der expr1 + and expr = BinaryOperation (Times, expr, expr) in + let expr = BinaryOperation (Plus, Real 1., expr) in + BinaryOperation (Times, expr1', expr) + | FunctionCall (PredefinedIdentifier "exp", [ expr1 ]) -> + let expr1' = evaluate_der expr1 in + BinaryOperation (Times, expr1', expr) + | FunctionCall (PredefinedIdentifier "log", [ expr1 ]) -> + let expr1' = evaluate_der expr1 in + BinaryOperation (Divide, expr1', expr) + | FunctionCall (PredefinedIdentifier "sqrt", [ expr1 ]) -> + evaluate_der (BinaryOperation (Power, expr1, Real 0.5)) + | FunctionCall (PredefinedIdentifier "asin", [ expr1 ]) -> + let expr1' = evaluate_der expr1 in + let expr1 = BinaryOperation (Times, expr1, expr1) in + let expr1 = BinaryOperation (Minus, Real 1., expr1) in + let expr1 = FunctionCall (PredefinedIdentifier "sqrt", [ expr1 ]) in + BinaryOperation (Divide, expr1', expr1) + | FunctionCall (PredefinedIdentifier "acos", [ expr1 ]) -> + let expr1' = UnaryOperation (UnaryMinus, evaluate_der expr1) in + let expr1 = BinaryOperation (Times, expr1, expr1) in + let expr1 = BinaryOperation (Minus, Real 1., expr1) in + let expr1 = FunctionCall (PredefinedIdentifier "sqrt", [ expr1 ]) in + BinaryOperation (Divide, expr1', expr1) + | FunctionCall (PredefinedIdentifier "atan", [ expr1 ]) -> + let expr1' = evaluate_der expr1 in + let expr1 = BinaryOperation (Times, expr1, expr1) in + let expr1 = BinaryOperation (Plus, Real 1., expr1) in + BinaryOperation (Divide, expr1', expr1) + | FunctionCall (PredefinedIdentifier "sinh", [ expr1 ]) -> + let expr1' = evaluate_der expr1 in + let expr1 = FunctionCall (PredefinedIdentifier "cosh", [ expr1 ]) in + BinaryOperation (Times, expr1', expr1) + | FunctionCall (PredefinedIdentifier "cosh", [ expr1 ]) -> + let expr1' = evaluate_der expr1 in + let expr1 = FunctionCall (PredefinedIdentifier "sinh", [ expr1 ]) in + BinaryOperation (Times, expr1', expr1) + | FunctionCall (PredefinedIdentifier "tanh", [ expr1 ]) -> + let expr1' = evaluate_der expr1 in + let expr1 = BinaryOperation (Times, expr, expr) in + let expr1 = BinaryOperation (Minus, Real 1., expr1) in + BinaryOperation (Times, expr1', expr1) + | FunctionCall (PredefinedIdentifier "asinh", [ expr1 ]) -> + let expr1' = evaluate_der expr1 in + let expr1 = BinaryOperation (Times, expr1, expr1) in + let expr1 = BinaryOperation (Plus, Real 1., expr1) in + let expr1 = FunctionCall (PredefinedIdentifier "sqrt", [ expr1 ]) in + BinaryOperation (Divide, expr1', expr1) + | FunctionCall (PredefinedIdentifier "acosh", [ expr1 ]) -> + let expr1' = evaluate_der expr1 in + let expr1 = BinaryOperation (Times, expr1, expr1) in + let expr1 = BinaryOperation (Minus, expr1, Real 1.) in + let expr1 = FunctionCall (PredefinedIdentifier "sqrt", [ expr1 ]) in + BinaryOperation (Divide, expr1', expr1) + | FunctionCall (PredefinedIdentifier "atanh", [ expr1 ]) -> + let expr1' = evaluate_der expr1 in + let expr1 = BinaryOperation (Times, expr1, expr1) in + let expr1 = BinaryOperation (Minus, expr1, Real 1.) in + BinaryOperation (Divide, expr1', expr1) + | FunctionCall (PredefinedIdentifier "log10", [ expr1 ]) -> + let expr1 = FunctionCall (PredefinedIdentifier "log", [ expr1 ]) in + BinaryOperation (Divide, evaluate_der expr1, Real (log 10.)) + | FunctionCall + (PredefinedIdentifier ("div" | "mod" | "rem" | "ceil" | "floor"), _) -> + Real 0. + | If (alts, default) -> + let alts' = + List.map (function (cond, expr) -> (cond, evaluate_der expr)) alts in + If (alts', evaluate_der default) + | NoEvent expr -> NoEvent (evaluate_der expr) + | UnaryOperation (UnaryMinus, expr) -> + UnaryOperation (UnaryMinus, evaluate_der expr) + | VectorReduction (exprs, expr) -> + VectorReduction (exprs, evaluate_der expr) + | _ -> FunctionCall (PredefinedIdentifier "der", [ expr ]) + +and evaluate_pre expr = match expr with + | Vector exprs -> + Vector (Array.map evaluate_pre exprs) + | _ -> + FunctionCall (PredefinedIdentifier "pre", [ expr ]) + +and evaluate_cos expr = match expr with + | Vector exprs -> + Vector (Array.map evaluate_cos exprs) + | _ -> + FunctionCall (PredefinedIdentifier "cos", [ expr ]) + +and evaluate_sin expr = match expr with + | Vector exprs -> + Vector (Array.map evaluate_sin exprs) + | _ -> + FunctionCall (PredefinedIdentifier "sin", [ expr ]) + +and evaluate_tan expr = match expr with + | Vector exprs -> + Vector (Array.map evaluate_tan exprs) + | _ -> + FunctionCall (PredefinedIdentifier "tan", [ expr ]) + +and evaluate_exp expr = match expr with + | Vector exprs -> + Vector (Array.map evaluate_exp exprs) + | _ -> + FunctionCall (PredefinedIdentifier "exp", [ expr ]) + +and evaluate_log expr = match expr with + | Vector exprs -> + Vector (Array.map evaluate_log exprs) + | _ -> + FunctionCall (PredefinedIdentifier "log", [ expr ]) + +and evaluate_sqrt expr = match expr with + | Vector exprs -> + Vector (Array.map evaluate_sqrt exprs) + | _ -> + FunctionCall (PredefinedIdentifier "sqrt", [ expr ]) + +and evaluate_asin expr = match expr with + | Vector exprs -> + Vector (Array.map evaluate_asin exprs) + | _ -> + FunctionCall (PredefinedIdentifier "asin", [ expr ]) + +and evaluate_acos expr = match expr with + | Vector exprs -> + Vector (Array.map evaluate_acos exprs) + | _ -> + FunctionCall (PredefinedIdentifier "acos", [ expr ]) + +and evaluate_atan expr = match expr with + | Vector exprs -> + Vector (Array.map evaluate_atan exprs) + | _ -> + FunctionCall (PredefinedIdentifier "atan", [ expr ]) + +and evaluate_sinh expr = match expr with + | Vector exprs -> + Vector (Array.map evaluate_sinh exprs) + | _ -> + FunctionCall (PredefinedIdentifier "sinh", [ expr ]) + +and evaluate_cosh expr = match expr with + | Vector exprs -> + Vector (Array.map evaluate_cosh exprs) + | _ -> + FunctionCall (PredefinedIdentifier "cosh", [ expr ]) + +and evaluate_tanh expr = match expr with + | Vector exprs -> + Vector (Array.map evaluate_tanh exprs) + | _ -> + FunctionCall (PredefinedIdentifier "tanh", [ expr ]) + +and evaluate_asinh expr = match expr with + | Vector exprs -> + Vector (Array.map evaluate_asinh exprs) + | _ -> + FunctionCall (PredefinedIdentifier "asinh", [ expr ]) + +and evaluate_acosh expr = match expr with + | Vector exprs -> + Vector (Array.map evaluate_acosh exprs) + | _ -> + FunctionCall (PredefinedIdentifier "acosh", [ expr ]) + +and evaluate_atanh expr = match expr with + | Vector exprs -> + Vector (Array.map evaluate_atanh exprs) + | _ -> + FunctionCall (PredefinedIdentifier "atanh", [ expr ]) + +and evaluate_log10 expr = match expr with + | Vector exprs -> + Vector (Array.map evaluate_log10 exprs) + | _ -> + FunctionCall (PredefinedIdentifier "log10", [ expr ]) + +and evaluate_max expr expr' = match expr, expr' with + | Vector exprs, Vector exprs' -> + Vector (ArrayExt.map2 evaluate_max exprs exprs') + | Real f, Real f' -> Real (max f f') + | _, _ -> + let b = BinaryOperation (GreaterEqual, expr, expr') in + If ([b, expr], expr') + +and evaluate_min expr expr' = match expr, expr' with + | Vector exprs, Vector exprs' -> + Vector (ArrayExt.map2 evaluate_min exprs exprs') + | Real f, Real f' -> Real (min f f') + | _, _ -> + let b = BinaryOperation (GreaterEqual, expr', expr) in + If ([b, expr], expr') + +and evaluate_abs expr = match expr with + | Vector exprs -> + Vector (Array.map evaluate_abs exprs) + | Real f -> Real (abs_float f) + | Integer i -> Integer (Int32.abs i) + | _ -> + let b = BinaryOperation (GreaterEqual, expr, Real 0.) + and default = UnaryOperation (UnaryMinus, expr) in + If ([b, expr], default) + +and evaluate_sign expr = match expr with + | Vector exprs -> + Vector (Array.map evaluate_sign exprs) + | Real f when f > 0. -> Real 1. + | Real f when f < 0. -> Real (-. 1.) + | Real _ -> Real 0. + | Integer i when Int32.compare i Int32.zero > 0 -> + Integer Int32.one + | Integer i when Int32.compare i Int32.zero < 0 -> + Integer Int32.minus_one + | Integer _ -> Integer Int32.zero + | _ -> + let b = BinaryOperation (Greater, expr, Real 0.) + and b' = BinaryOperation (Greater, Real 0., expr) in + If ([(b, Integer Int32.one); (b', Integer Int32.minus_one)], + Integer Int32.zero) + +and evaluate_div ctx expr expr' = match expr, expr' with + | Vector exprs, Vector exprs' -> + Vector (ArrayExt.map2 (evaluate_div ctx) exprs exprs') + | _, Real 0. -> + raise (InstantError + { err_msg = ["_DivisionByZero"]; + err_info = []; + err_ctx = ctx }) (*error*) + | _, Integer i when i = Int32.zero -> + raise (InstantError + { err_msg = ["_DivisionByZero"]; + err_info = []; + err_ctx = ctx }) (*error*) + | Integer i, Integer i' -> Integer (Int32.div i i') + | Real f, Integer i' -> + let f' = Int32.to_float i' in + Real (float_of_int (truncate (f /. f'))) + | Integer i, Real f' -> + let f = Int32.to_float i in + Real (float_of_int (truncate (f /. f'))) + | Real f, Real f' -> + Real (float_of_int (truncate (f /. f'))) + | _, _ -> + FunctionCall (PredefinedIdentifier "div", [ expr; expr' ]) + +and evaluate_mod expr expr' = match expr, expr' with + | Vector exprs, Vector exprs' -> + Vector (ArrayExt.map2 evaluate_mod exprs exprs') + | _, _ -> + FunctionCall (PredefinedIdentifier "mod", [ expr; expr' ]) + +and evaluate_rem expr expr' = match expr, expr' with + | Vector exprs, Vector exprs' -> + Vector (ArrayExt.map2 evaluate_rem exprs exprs') + | _, _ -> + FunctionCall (PredefinedIdentifier "rem", [ expr; expr' ]) + +and evaluate_ceil expr = match expr with + | Vector exprs -> + Vector (Array.map evaluate_ceil exprs) + | _ -> + FunctionCall (PredefinedIdentifier "ceil", [ expr ]) + +and evaluate_floor expr = match expr with + | Vector exprs -> + Vector (Array.map evaluate_floor exprs) + | _ -> + FunctionCall (PredefinedIdentifier "floor", [ expr ]) + +and evaluate_size exprs = + let rec evaluate_size' expr i = match expr, i with + | ComponentReference cpnt_desc, _ -> + evaluate_component_size cpnt_desc i + | Vector exprs, 1 -> Integer (Int32.of_int (Array.length exprs)) + | Vector exprs, _ -> evaluate_size' exprs.(0) (i - 1) + | _ -> assert false (*error*) + and evaluate_component_size cpnt_desc i = + match evaluate cpnt_desc.component_nature, i with + | DynamicArray _, _ -> FunctionCall (PredefinedIdentifier "size", exprs) + | StaticArray cpnt_descs, 1 -> + Integer (Int32.of_int (Array.length cpnt_descs)) + | StaticArray cpnt_descs, _ -> + evaluate_component_size cpnt_descs.(i) (i - 1) + | _ -> assert false (*error*) + and evaluate_size_list = function + | ComponentReference cpnt_desc -> assert false + | Vector exprs -> + let size = Integer (Int32.of_int (Array.length exprs)) in + size :: evaluate_size_list exprs.(0) + | _ -> [] in + match exprs with + | [expr] -> Vector (Array.of_list (evaluate_size_list expr)) + | [expr; Integer i] -> evaluate_size' expr (Int32.to_int i) + | [expr; _] -> FunctionCall (PredefinedIdentifier "size", exprs) + | _ -> assert false (*error*) + +and evaluate_not expr = match expr with + | True -> False + | False -> True + | Vector exprs -> Vector (Array.map evaluate_not exprs) + | _ -> UnaryOperation (Not, expr) + +and evaluate_unary_minus expr = match expr with + | Integer i -> Integer (Int32.neg i) + | Real f -> Real (~-. f) + | Vector exprs -> Vector (Array.map evaluate_unary_minus exprs) + | _ -> UnaryOperation (UnaryMinus, expr) + +and field_access ctx expr id = + let rec field_access' = function + | ClassReference cl_def -> + let cpnt_desc = create_temporary_instance ctx cl_def in + component_field_access cpnt_desc + | ComponentReference cpnt_desc -> component_field_access cpnt_desc + | Record fields -> List.assoc id fields + | Vector exprs -> Vector (Array.map field_access' exprs) + | _ -> FieldAccess (expr, id) + and component_field_access cpnt_desc = + match evaluate cpnt_desc.component_nature with + | DynamicArray _ -> FieldAccess (expr, id) + | Instance inst -> instance_field_access ctx inst id + | PredefinedTypeInstance _ -> + raise (InstantError + { err_msg = ["_CannotAccessToPredefTypeAttrib"; id]; + err_info = []; + err_ctx = ctx}) (*error*) + | StaticArray cpnt_descs -> + Vector (Array.map component_field_access cpnt_descs) in + field_access' expr + +and instance_field_access ctx inst id = + let evaluate_component cpnt_desc = + let evaluate_declaration_equation = function + | Some expr -> evaluate expr + | None -> + raise (InstantError + { err_msg = ["_MissingDeclEquForFixedId"; id]; + err_info = []; + err_ctx = ctx}) (*error*) in + let rec evaluate_parameter cpnt_desc = + let evaluate_predefined_type_instance predef = + match evaluate (List.assoc "fixed" predef.attributes) with + | True -> evaluate_declaration_equation cpnt_desc.declaration_equation + | False -> ComponentReference cpnt_desc + | _ -> assert false (*error*) in + match evaluate cpnt_desc.component_nature with + | PredefinedTypeInstance predef + when List.mem_assoc "fixed" predef.attributes -> + evaluate_predefined_type_instance predef + | DynamicArray cpnt_desc -> assert false + | Instance _ -> ComponentReference cpnt_desc + | PredefinedTypeInstance _ -> + evaluate_declaration_equation cpnt_desc.declaration_equation + | StaticArray cpnt_descs -> + Vector (Array.map evaluate_parameter cpnt_descs) + (*let f i = + let decl_equ = cpnt_descs.(i).declaration_equation in + evaluate_declaration_equation decl_equ in + Vector (Array.init (Array.length cpnt_descs) f)*) in + match cpnt_desc.variability with + | Types.Constant -> + evaluate_declaration_equation cpnt_desc.declaration_equation + | Types.Parameter -> evaluate_parameter cpnt_desc + | _ -> ComponentReference cpnt_desc in + let elts = evaluate inst.elements in + let elt_desc = List.assoc id elts.named_elements in + match evaluate elt_desc.element_nature with + | Class cl_def -> ClassReference cl_def + | Component cpnt_desc -> evaluate_component cpnt_desc + +and expression_location ctx expr = + match expr.NameResolve.info.NameResolve.syntax with + | None -> ctx.location + | Some expr -> expr.Syntax.info + +and class_name_of_component cpnt_desc = + let type_spec = Lazy.force cpnt_desc.NameResolve.type_specifier in + let expr_info = type_spec.NameResolve.info in + match expr_info.NameResolve.syntax with + | None -> "" + | Some expr -> Syntax.string_of_expression expr + +and instance_nature_of_element elt_desc = + match elt_desc.NameResolve.element_nature with + | NameResolve.Component cpnt_desc -> + ComponentElement (class_name_of_component cpnt_desc) + | _ -> ClassElement + +and instance_class_name instance_nature = + match instance_nature with + | ComponentElement s -> s + | ClassElement -> "" + +and flatten_expression expr = + let rec flatten_component cpnt_desc = + match evaluate cpnt_desc.component_nature with + | StaticArray cpnt_descs -> + Vector (Array.map flatten_component cpnt_descs) + | _ -> ComponentReference cpnt_desc in + match expr with + | ComponentReference cpnt_desc -> + flatten_component cpnt_desc + | _ -> expr + +and size expr i = match expr, i with + | Vector [||], _ -> 0 + | Vector exprs, 0 -> Array.length exprs + | Vector exprs, _ when i > 0 -> size exprs.(0) (i - 1) + | _ -> invalid_arg "_IndexOutOfBound" + +and sizes expr = + Array.init (ndims expr) (size expr) + +and ndims expr = + let rec ndims' i expr = match expr with + | Vector [||] -> i + 1 + | Vector exprs -> ndims' (i + 1) exprs.(0) + | _ -> i in + ndims' 0 expr + +and element i expr = match expr with + | Vector exprs -> exprs.(i) + | _ -> assert false + +and array_elements expr = match expr with + | Vector exprs -> exprs + | _ -> assert false + +and scalar_elements expr = match expr with + | Vector exprs -> + let exprss = + Array.to_list (Array.map scalar_elements exprs) in + List.flatten exprss + | _ -> [ expr ] + +(* for debug*) + +and generate_expression oc = function + | BinaryOperation (bin_op, expr, expr') -> + generate_binary_operation oc bin_op expr expr' + | ClassReference cl_def -> + generate_class_reference oc cl_def + | ComponentReference cpnt_desc -> + generate_component_reference oc cpnt_desc + | EnumerationElement _ -> assert false + | False -> assert false + | FieldAccess _ -> assert false + | FunctionCall (expr, exprs) -> + generate_function_call oc expr exprs + | If (alts, expr) -> generate_if oc alts expr + | IndexedAccess _ -> assert false + | Integer i when Int32.to_int i >= 0 -> + Printf.fprintf oc "%ld" i + | Integer i -> + let expr = Integer (Int32.neg i) + and un_op = UnaryMinus in + generate_unary_operation oc un_op expr + | LoopVariable _ -> Printf.fprintf oc "LoopVariable" + | NoEvent expr -> generate_no_event oc expr + | PredefinedIdentifier id -> Printf.fprintf oc "%s" id + | Range _ -> Printf.fprintf oc "Range" + | Real f -> + Printf.fprintf oc "%s" (string_of_float f) + | Record _ -> Printf.fprintf oc "Record" + | String _ -> Printf.fprintf oc "String" + | True -> Printf.fprintf oc "True" + | Tuple _ -> Printf.fprintf oc "Tuple" + | UnaryOperation (un_op, expr) -> + generate_unary_operation oc un_op expr + | Vector exprs -> + generate_vector oc exprs + | VectorReduction _ -> Printf.fprintf oc "VectorReduction" + +and generate_binary_operation oc bin_op expr expr' = + let string_of_binary_operation_kind = function + | And -> "and" + | Divide -> "/" + | EqualEqual -> "==" + | GreaterEqual -> ">=" + | Greater -> ">" + | LessEqual -> "<=" + | Less -> "<" + | Times -> "*" + | NotEqual -> "<>" + | Or -> "or" + | Plus -> "+" + | Power -> "^" + | Minus -> "-" in + Printf.fprintf oc "("; + generate_expression oc expr; + Printf.fprintf oc " %s " (string_of_binary_operation_kind bin_op); + generate_expression oc expr'; + Printf.fprintf oc ")" + +and generate_class_reference oc cl_def = + let rec last = function + | [] -> assert false + | [Name id] -> id + | [Index _] -> assert false + | _ :: path -> last path in + let generate_external_call ext_call = + match ext_call.NameResolve.nature with + | NameResolve.PrimitiveCall "builtin" -> + Printf.fprintf oc "builtin" + | NameResolve.PrimitiveCall "C" -> + Printf.fprintf oc "PrimitiveCall" + | NameResolve.PrimitiveCall lang -> assert false + | NameResolve.ExternalProcedureCall _ -> assert false in + let generate_long_dscription long_desc = + match evaluate long_desc.NameResolve.external_call with + | None -> assert false + | Some ext_call -> generate_external_call ext_call in + match cl_def.description with + | ClassDescription (_, cl_desc) -> + generate_long_dscription cl_desc.long_description + | PredefinedType _ -> assert false + +and generate_component_reference oc cpnt_desc = + let name = ident_of_path cpnt_desc.component_path in + Printf.fprintf oc "%s" name + +and generate_function_call oc expr exprs = + generate_expression oc expr; + Printf.fprintf oc "("; + generate_expressions oc exprs; + Printf.fprintf oc ")" + +and generate_expressions oc = function + | [] -> () + | [expr] -> generate_expression oc expr; + | expr :: exprs -> + generate_expression oc expr; + Printf.fprintf oc ", "; + generate_expressions oc exprs + +and generate_if oc alts expr = + let rec generate_alternatives = function + | [] -> Printf.fprintf oc " "; generate_expression oc expr + | (expr, expr') :: alts -> + Printf.fprintf oc "(if "; + generate_expression oc expr; + Printf.fprintf oc " then "; + generate_expression oc expr'; + Printf.fprintf oc " else"; + generate_alternatives alts; + Printf.fprintf oc ")" in + generate_alternatives alts + +and generate_no_event oc expr = + Printf.fprintf oc "noEvent("; + generate_expression oc expr; + Printf.fprintf oc ")" + +and generate_unary_operation oc un_op expr = + let string_of_unary_operation_kind = function + | Not -> "not" + | UnaryMinus -> "-" in + Printf.fprintf oc "(%s " (string_of_unary_operation_kind un_op); + generate_expression oc expr; + Printf.fprintf oc ")" + +and generate_vector oc exprs = + let exprs' = Array.to_list exprs in + Printf.fprintf oc "{ "; + generate_expressions oc exprs'; + Printf.fprintf oc " }" + +and last_id path = + let rec last_id' id path = match path with + | [] -> id + | (Name id) :: path -> last_id' id path + | (Index _) :: path -> last_id' id path in + last_id' "" path + +and string_of_float f = + let add_parenthesis s = + if String.contains s '-' then Printf.sprintf "(%s)" s else s in + match Printf.sprintf "%.16g" f with + | s when (String.contains s '.') || (String.contains s 'e') -> + add_parenthesis s + | s -> add_parenthesis (Printf.sprintf "%s." s) + +and ident_of_path path = + let rec ident_of_path' path = + match path with + | [] -> assert false + | [Name id] -> id + | [Index i] -> Printf.sprintf "[%d]" (i + 1) + | Name id :: path -> + Printf.sprintf "%s.%s" id (ident_of_path' path) + | Index i :: path -> + Printf.sprintf "[%d].%s" (i + 1) (ident_of_path' path) in + match path with + | [] -> assert false + | [Name id] -> assert false + | [Index i] -> assert false + | Name id :: path -> + Printf.sprintf "`%s`" (ident_of_path' path) + | Index i :: path -> assert false + diff --git a/scilab/modules/scicos/src/translator/parsing/lexer.ml b/scilab/modules/scicos/src/translator/parsing/lexer.ml index 95d2976..f549eea 100644 --- a/scilab/modules/scicos/src/translator/parsing/lexer.ml +++ b/scilab/modules/scicos/src/translator/parsing/lexer.ml @@ -1,69 +1,69 @@ # 27 "lexer.mll" - - -(** Modelica lexer. *) - -(** Implementation based on {i Modelica language specification 2.0 } *) - -open Parser - -let check_reserved = function - | "algorithm" -> ALGORITHM - | "and" -> AND - | "annotation" -> ANNOTATION - | "block" -> MODEL - | "break" -> BREAK - | "class" -> CLASS - | "connect" -> CONNECT - | "connector" -> CONNECTOR - | "constant" -> CONSTANT - | "discrete" -> DISCRETE - | "each" -> EACH - | "else" -> ELSE - | "elseif" -> ELSEIF - | "elsewhen" -> ELSEWHEN - | "encapsulated" -> ENCAPSULATED - | "enumeration" -> ENUMERATION - | "end" -> END - | "equation" -> EQUATION - | "expandable" -> EXPANDABLE - | "extends" -> EXTENDS - | "external" -> EXTERNAL - | "false" -> FALSE - | "final" -> FINAL - | "flow" -> FLOW - | "for" -> FOR - | "function" -> FUNCTION - | "if" -> IF - | "import" -> IMPORT - | "in" -> IN - | "inner" -> INNER - | "input" -> INPUT - | "loop" -> LOOP - | "model" -> MODEL - | "noEvent" -> NOEVENT - | "not" -> NOT - | "or" -> OR - | "outer" -> OUTER - | "output" -> OUTPUT - | "package" -> PACKAGE - | "parameter" -> PARAMETER - | "partial" -> PARTIAL - | "protected" -> PROTECTED - | "public" -> PUBLIC - | "record" -> RECORD - | "redeclare" -> REDECLARE - | "replaceable" -> REPLACEABLE - | "restricts" -> RESTRICTS - | "return" -> RETURN - | "then" -> THEN - | "true" -> TRUE - | "type" -> TYPE - | "when" -> WHEN - | "while" -> WHILE - | "within" -> WITHIN - | s -> IDENT s - + + +(** Modelica lexer. *) + +(** Implementation based on {i Modelica language specification 2.0 } *) + +open Parser + +let check_reserved = function + | "algorithm" -> ALGORITHM + | "and" -> AND + | "annotation" -> ANNOTATION + | "block" -> MODEL + | "break" -> BREAK + | "class" -> CLASS + | "connect" -> CONNECT + | "connector" -> CONNECTOR + | "constant" -> CONSTANT + | "discrete" -> DISCRETE + | "each" -> EACH + | "else" -> ELSE + | "elseif" -> ELSEIF + | "elsewhen" -> ELSEWHEN + | "encapsulated" -> ENCAPSULATED + | "enumeration" -> ENUMERATION + | "end" -> END + | "equation" -> EQUATION + | "expandable" -> EXPANDABLE + | "extends" -> EXTENDS + | "external" -> EXTERNAL + | "false" -> FALSE + | "final" -> FINAL + | "flow" -> FLOW + | "for" -> FOR + | "function" -> FUNCTION + | "if" -> IF + | "import" -> IMPORT + | "in" -> IN + | "inner" -> INNER + | "input" -> INPUT + | "loop" -> LOOP + | "model" -> MODEL + | "noEvent" -> NOEVENT + | "not" -> NOT + | "or" -> OR + | "outer" -> OUTER + | "output" -> OUTPUT + | "package" -> PACKAGE + | "parameter" -> PARAMETER + | "partial" -> PARTIAL + | "protected" -> PROTECTED + | "public" -> PUBLIC + | "record" -> RECORD + | "redeclare" -> REDECLARE + | "replaceable" -> REPLACEABLE + | "restricts" -> RESTRICTS + | "return" -> RETURN + | "then" -> THEN + | "true" -> TRUE + | "type" -> TYPE + | "when" -> WHEN + | "while" -> WHILE + | "within" -> WITHIN + | s -> IDENT s + # 69 "lexer.ml" let __ocaml_lex_tables = { @@ -1097,12 +1097,12 @@ let | 39 -> # 197 "lexer.mll" - ( raise (SyntacticError - {err_msg = ["_IllegalCharacter"]; - err_info = []; - err_ctx = - {location = {start = Lexing.lexeme_start lexbuf; - enddd = Lexing.lexeme_end lexbuf; + ( raise (SyntacticError + {err_msg = ["_IllegalCharacter"]; + err_info = []; + err_ctx = + {location = {start = Lexing.lexeme_start lexbuf; + enddd = Lexing.lexeme_end lexbuf; filename = !inputfile}}}) ) # 1108 "lexer.ml" diff --git a/scilab/modules/scicos/src/translator/parsing/lexer.mll b/scilab/modules/scicos/src/translator/parsing/lexer.mll index 31618b6..c93ebc2 100644 --- a/scilab/modules/scicos/src/translator/parsing/lexer.mll +++ b/scilab/modules/scicos/src/translator/parsing/lexer.mll @@ -1,203 +1,203 @@ -(* - * Translator from Modelica 2.x to flat Modelica - * - * Copyright (C) 2005 - 2007 Imagine S.A. - * For more information or commercial use please contact us at www.amesim.com - * - * This program is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. - * - *) - -(** Modelica language lexer. *) - -(** Implementation based on {i Modelica language specification 2.0 } *) - -{ - -(** Modelica lexer. *) - -(** Implementation based on {i Modelica language specification 2.0 } *) - -open Parser - -let check_reserved = function - | "algorithm" -> ALGORITHM - | "and" -> AND - | "annotation" -> ANNOTATION - | "block" -> MODEL - | "break" -> BREAK - | "class" -> CLASS - | "connect" -> CONNECT - | "connector" -> CONNECTOR - | "constant" -> CONSTANT - | "discrete" -> DISCRETE - | "each" -> EACH - | "else" -> ELSE - | "elseif" -> ELSEIF - | "elsewhen" -> ELSEWHEN - | "encapsulated" -> ENCAPSULATED - | "enumeration" -> ENUMERATION - | "end" -> END - | "equation" -> EQUATION - | "expandable" -> EXPANDABLE - | "extends" -> EXTENDS - | "external" -> EXTERNAL - | "false" -> FALSE - | "final" -> FINAL - | "flow" -> FLOW - | "for" -> FOR - | "function" -> FUNCTION - | "if" -> IF - | "import" -> IMPORT - | "in" -> IN - | "inner" -> INNER - | "input" -> INPUT - | "loop" -> LOOP - | "model" -> MODEL - | "noEvent" -> NOEVENT - | "not" -> NOT - | "or" -> OR - | "outer" -> OUTER - | "output" -> OUTPUT - | "package" -> PACKAGE - | "parameter" -> PARAMETER - | "partial" -> PARTIAL - | "protected" -> PROTECTED - | "public" -> PUBLIC - | "record" -> RECORD - | "redeclare" -> REDECLARE - | "replaceable" -> REPLACEABLE - | "restricts" -> RESTRICTS - | "return" -> RETURN - | "then" -> THEN - | "true" -> TRUE - | "type" -> TYPE - | "when" -> WHEN - | "while" -> WHILE - | "within" -> WITHIN - | s -> IDENT s - -} - -let blank = [' ' '\t' '\r'] -let digit = ['0'-'9'] -let nondigit = ['_' 'A'-'Z' 'a'-'z'] -let qchar = [^'`' '\\'] -let schar = [^'\"' '\\'] -let sescape = "\\\'" | "\\\"" | "\\?" | "\\\\" | "\\a" | "\\b" | "\\f" | - "\\n" | "\\r" | "\\t" | "\\v" - -let comment = "/*" ( [^ '*'] | '*'+ [^ '*' '/'] )* '*'+ '/' -let line_comment = "//" [^ '\n']* '\n' - -let separators = (blank | ['\n'] | comment | line_comment)+ - -let qident = '`' (qchar | sescape)+ '`' - -let ident = nondigit (nondigit | digit)* | qident - -let unsigned_integer = digit+ - -let fractional_constant = unsigned_integer? '.' unsigned_integer | unsigned_integer '.' - -let exponent_part = ('e' | 'E') ('+' | '-')? unsigned_integer - -let unsigned_real = fractional_constant exponent_part? | unsigned_integer exponent_part - -rule token = parse - - | blank - { token lexbuf } - - | ['\n'] - { token lexbuf } - - - | comment - { token lexbuf } - - | line_comment - { token lexbuf } - - | unsigned_integer as lxm - { UNSIGNED_INTEGER lxm } - - | unsigned_real as lxm - { UNSIGNED_REAL lxm } - - | "initial" separators "algorithm" - { INITIAL_ALGORITHM } - - | "initial" separators "equation" - { INITIAL_EQUATION } - - | "end" separators "for" - { END_FOR } - - | "end" separators "if" - { END_IF } - - | "end" separators "when" - { END_WHEN } - - | "end" separators "while" - { END_WHILE } - - | "end" separators (ident as lxm) - { END_IDENT lxm } - - | ident as lxm - { check_reserved lxm } - - | '\"' ((schar | sescape)* as lxm) '\"' - { STRING lxm } - - | '(' { LP } - | ')' { RP } - | '[' { LSB } - | ']' { RSB } - | '{' { LCB } - | '}' { RCB } - - | '.' { DOT } - | ',' { CM } - | ';' { SC } - | ':' { CL } - - | '+' { PLUS } - | '-' { MINUS } - | '*' { STAR } - | '/' { SLASH } - | '^' { EXP } - - | '=' { EQ } - | ":=" { COLEQ } - - | '<' { LT } - | '>' { GT } - | "<=" { LE } - | ">=" { GE } - | "==" { EE } - | "<>" { NE } - - | eof { EOF } - - | _ { raise (SyntacticError - {err_msg = ["_IllegalCharacter"]; - err_info = []; - err_ctx = - {location = {start = Lexing.lexeme_start lexbuf; - enddd = Lexing.lexeme_end lexbuf; - filename = !inputfile}}}) } +(* + * Translator from Modelica 2.x to flat Modelica + * + * Copyright (C) 2005 - 2007 Imagine S.A. + * For more information or commercial use please contact us at www.amesim.com + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. + * + *) + +(** Modelica language lexer. *) + +(** Implementation based on {i Modelica language specification 2.0 } *) + +{ + +(** Modelica lexer. *) + +(** Implementation based on {i Modelica language specification 2.0 } *) + +open Parser + +let check_reserved = function + | "algorithm" -> ALGORITHM + | "and" -> AND + | "annotation" -> ANNOTATION + | "block" -> MODEL + | "break" -> BREAK + | "class" -> CLASS + | "connect" -> CONNECT + | "connector" -> CONNECTOR + | "constant" -> CONSTANT + | "discrete" -> DISCRETE + | "each" -> EACH + | "else" -> ELSE + | "elseif" -> ELSEIF + | "elsewhen" -> ELSEWHEN + | "encapsulated" -> ENCAPSULATED + | "enumeration" -> ENUMERATION + | "end" -> END + | "equation" -> EQUATION + | "expandable" -> EXPANDABLE + | "extends" -> EXTENDS + | "external" -> EXTERNAL + | "false" -> FALSE + | "final" -> FINAL + | "flow" -> FLOW + | "for" -> FOR + | "function" -> FUNCTION + | "if" -> IF + | "import" -> IMPORT + | "in" -> IN + | "inner" -> INNER + | "input" -> INPUT + | "loop" -> LOOP + | "model" -> MODEL + | "noEvent" -> NOEVENT + | "not" -> NOT + | "or" -> OR + | "outer" -> OUTER + | "output" -> OUTPUT + | "package" -> PACKAGE + | "parameter" -> PARAMETER + | "partial" -> PARTIAL + | "protected" -> PROTECTED + | "public" -> PUBLIC + | "record" -> RECORD + | "redeclare" -> REDECLARE + | "replaceable" -> REPLACEABLE + | "restricts" -> RESTRICTS + | "return" -> RETURN + | "then" -> THEN + | "true" -> TRUE + | "type" -> TYPE + | "when" -> WHEN + | "while" -> WHILE + | "within" -> WITHIN + | s -> IDENT s + +} + +let blank = [' ' '\t' '\r'] +let digit = ['0'-'9'] +let nondigit = ['_' 'A'-'Z' 'a'-'z'] +let qchar = [^'`' '\\'] +let schar = [^'\"' '\\'] +let sescape = "\\\'" | "\\\"" | "\\?" | "\\\\" | "\\a" | "\\b" | "\\f" | + "\\n" | "\\r" | "\\t" | "\\v" + +let comment = "/*" ( [^ '*'] | '*'+ [^ '*' '/'] )* '*'+ '/' +let line_comment = "//" [^ '\n']* '\n' + +let separators = (blank | ['\n'] | comment | line_comment)+ + +let qident = '`' (qchar | sescape)+ '`' + +let ident = nondigit (nondigit | digit)* | qident + +let unsigned_integer = digit+ + +let fractional_constant = unsigned_integer? '.' unsigned_integer | unsigned_integer '.' + +let exponent_part = ('e' | 'E') ('+' | '-')? unsigned_integer + +let unsigned_real = fractional_constant exponent_part? | unsigned_integer exponent_part + +rule token = parse + + | blank + { token lexbuf } + + | ['\n'] + { token lexbuf } + + + | comment + { token lexbuf } + + | line_comment + { token lexbuf } + + | unsigned_integer as lxm + { UNSIGNED_INTEGER lxm } + + | unsigned_real as lxm + { UNSIGNED_REAL lxm } + + | "initial" separators "algorithm" + { INITIAL_ALGORITHM } + + | "initial" separators "equation" + { INITIAL_EQUATION } + + | "end" separators "for" + { END_FOR } + + | "end" separators "if" + { END_IF } + + | "end" separators "when" + { END_WHEN } + + | "end" separators "while" + { END_WHILE } + + | "end" separators (ident as lxm) + { END_IDENT lxm } + + | ident as lxm + { check_reserved lxm } + + | '\"' ((schar | sescape)* as lxm) '\"' + { STRING lxm } + + | '(' { LP } + | ')' { RP } + | '[' { LSB } + | ']' { RSB } + | '{' { LCB } + | '}' { RCB } + + | '.' { DOT } + | ',' { CM } + | ';' { SC } + | ':' { CL } + + | '+' { PLUS } + | '-' { MINUS } + | '*' { STAR } + | '/' { SLASH } + | '^' { EXP } + + | '=' { EQ } + | ":=" { COLEQ } + + | '<' { LT } + | '>' { GT } + | "<=" { LE } + | ">=" { GE } + | "==" { EE } + | "<>" { NE } + + | eof { EOF } + + | _ { raise (SyntacticError + {err_msg = ["_IllegalCharacter"]; + err_info = []; + err_ctx = + {location = {start = Lexing.lexeme_start lexbuf; + enddd = Lexing.lexeme_end lexbuf; + filename = !inputfile}}}) } diff --git a/scilab/modules/scicos/src/translator/parsing/linenum.ml b/scilab/modules/scicos/src/translator/parsing/linenum.ml index e908037..3327bff 100644 --- a/scilab/modules/scicos/src/translator/parsing/linenum.ml +++ b/scilab/modules/scicos/src/translator/parsing/linenum.ml @@ -1,11 +1,11 @@ # 23 "linenum.mll" - - -(** Convert {! Parser.location } to line and column numbers. *) - -let linenum = ref 0 -let linebeg = ref 0 - + + +(** Convert {! Parser.location } to line and column numbers. *) + +let linenum = ref 0 +let linebeg = ref 0 + # 11 "linenum.ml" let __ocaml_lex_tables = { @@ -103,15 +103,15 @@ and __ocaml_lex_skip_line_rec lexbuf __ocaml_lex_state = match Lexing.engine __ocaml_lex_tables __ocaml_lex_state lexbuf with | 0 -> # 34 "linenum.mll" - ( incr linenum; - linebeg := Lexing.lexeme_start lexbuf; + ( incr linenum; + linebeg := Lexing.lexeme_start lexbuf; Lexing.lexeme_end lexbuf ) # 110 "linenum.ml" | 1 -> # 38 "linenum.mll" - ( incr linenum; - linebeg := Lexing.lexeme_start lexbuf; + ( incr linenum; + linebeg := Lexing.lexeme_start lexbuf; raise End_of_file ) # 117 "linenum.ml" @@ -120,19 +120,19 @@ and __ocaml_lex_skip_line_rec lexbuf __ocaml_lex_state = ;; # 42 "linenum.mll" - - -let for_position file loc = - let ic = open_in_bin file in - let lb = Lexing.from_channel ic in - linenum := 1; - linebeg := 0; - begin try - while skip_line lb <= loc do () done - with End_of_file -> () - end; - close_in ic; - (!linenum - 1, !linebeg) - + + +let for_position file loc = + let ic = open_in_bin file in + let lb = Lexing.from_channel ic in + linenum := 1; + linebeg := 0; + begin try + while skip_line lb <= loc do () done + with End_of_file -> () + end; + close_in ic; + (!linenum - 1, !linebeg) + # 139 "linenum.ml" diff --git a/scilab/modules/scicos/src/translator/parsing/linenum.mll b/scilab/modules/scicos/src/translator/parsing/linenum.mll index b0baad4..c043e44 100644 --- a/scilab/modules/scicos/src/translator/parsing/linenum.mll +++ b/scilab/modules/scicos/src/translator/parsing/linenum.mll @@ -1,56 +1,56 @@ -(* - * Translator from Modelica 2.x to flat Modelica - * - * Copyright (C) 2005 - 2007 Imagine S.A. - * For more information or commercial use please contact us at www.amesim.com - * - * This program is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. - * - *) - -{ - -(** Convert {! Parser.location } to line and column numbers. *) - -let linenum = ref 0 -let linebeg = ref 0 - -} - -rule skip_line = parse - | [^ '\n' '\r']* ('\n' | '\r' | "\r\n") - { incr linenum; - linebeg := Lexing.lexeme_start lexbuf; - Lexing.lexeme_end lexbuf } - | [^ '\n' '\r']* eof - { incr linenum; - linebeg := Lexing.lexeme_start lexbuf; - raise End_of_file } - -{ - -let for_position file loc = - let ic = open_in_bin file in - let lb = Lexing.from_channel ic in - linenum := 1; - linebeg := 0; - begin try - while skip_line lb <= loc do () done - with End_of_file -> () - end; - close_in ic; - (!linenum - 1, !linebeg) - -} +(* + * Translator from Modelica 2.x to flat Modelica + * + * Copyright (C) 2005 - 2007 Imagine S.A. + * For more information or commercial use please contact us at www.amesim.com + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. + * + *) + +{ + +(** Convert {! Parser.location } to line and column numbers. *) + +let linenum = ref 0 +let linebeg = ref 0 + +} + +rule skip_line = parse + | [^ '\n' '\r']* ('\n' | '\r' | "\r\n") + { incr linenum; + linebeg := Lexing.lexeme_start lexbuf; + Lexing.lexeme_end lexbuf } + | [^ '\n' '\r']* eof + { incr linenum; + linebeg := Lexing.lexeme_start lexbuf; + raise End_of_file } + +{ + +let for_position file loc = + let ic = open_in_bin file in + let lb = Lexing.from_channel ic in + linenum := 1; + linebeg := 0; + begin try + while skip_line lb <= loc do () done + with End_of_file -> () + end; + close_in ic; + (!linenum - 1, !linebeg) + +} diff --git a/scilab/modules/scicos/src/translator/parsing/parser.ml b/scilab/modules/scicos/src/translator/parsing/parser.ml index 4333fa7..89404c2 100644 --- a/scilab/modules/scicos/src/translator/parsing/parser.ml +++ b/scilab/modules/scicos/src/translator/parsing/parser.ml @@ -91,75 +91,75 @@ type token = open Parsing;; # 30 "parser.mly" - - -(** Modelica parser. *) - -(** Implementation based on {i Modelica language specification 2.0 } *) - -open Syntax - -exception Unclosed of int * string * int * string -exception Invalid_matrix of int * int -exception Invalid_array of int * int -exception End_of_file - -type location = - { - start: int; (* offset in the parsed stream *) - enddd: int; (* offset in the parsed stream *) - filename: filename - } - -and filename = - | LibraryFile of string - | CommandLine - -type error_description = - { - err_msg: string list; - err_info: (string * string) list; - err_ctx: err_ctx - } - -and err_ctx = - { - location: location; - } - -exception SyntacticError of error_description - -let inputfile = ref CommandLine - -let node nature = - { - nature = nature; - info = { start = Parsing.symbol_start (); - enddd = Parsing.symbol_end (); - filename = !inputfile } - } - -let rhs_nodes n n' nature = - { - nature = nature; - info = { start = Parsing.rhs_start n; - enddd = Parsing.rhs_end n'; - filename = !inputfile } - } - -let unclosed opening_symbol opening_pos closing_symbol closing_pos = - let offset = Parsing.rhs_start opening_pos - and offset' = Parsing.rhs_start closing_pos in - raise (Unclosed (offset, opening_symbol, offset', closing_symbol)) - -let invalid_matrix_construction opening_pos error_pos = - raise (Invalid_matrix ( - Parsing.rhs_start opening_pos, Parsing.rhs_start error_pos)) - -let invalid_literal_array_construction opening_pos error_pos = - raise (Invalid_array ( - Parsing.rhs_start opening_pos, Parsing.rhs_start error_pos)) - + + +(** Modelica parser. *) + +(** Implementation based on {i Modelica language specification 2.0 } *) + +open Syntax + +exception Unclosed of int * string * int * string +exception Invalid_matrix of int * int +exception Invalid_array of int * int +exception End_of_file + +type location = + { + start: int; (* offset in the parsed stream *) + enddd: int; (* offset in the parsed stream *) + filename: filename + } + +and filename = + | LibraryFile of string + | CommandLine + +type error_description = + { + err_msg: string list; + err_info: (string * string) list; + err_ctx: err_ctx + } + +and err_ctx = + { + location: location; + } + +exception SyntacticError of error_description + +let inputfile = ref CommandLine + +let node nature = + { + nature = nature; + info = { start = Parsing.symbol_start (); + enddd = Parsing.symbol_end (); + filename = !inputfile } + } + +let rhs_nodes n n' nature = + { + nature = nature; + info = { start = Parsing.rhs_start n; + enddd = Parsing.rhs_end n'; + filename = !inputfile } + } + +let unclosed opening_symbol opening_pos closing_symbol closing_pos = + let offset = Parsing.rhs_start opening_pos + and offset' = Parsing.rhs_start closing_pos in + raise (Unclosed (offset, opening_symbol, offset', closing_symbol)) + +let invalid_matrix_construction opening_pos error_pos = + raise (Invalid_matrix ( + Parsing.rhs_start opening_pos, Parsing.rhs_start error_pos)) + +let invalid_literal_array_construction opening_pos error_pos = + raise (Invalid_array ( + Parsing.rhs_start opening_pos, Parsing.rhs_start error_pos)) + # 164 "parser.ml" let yytransl_const = [| 262 (* ALGORITHM *); @@ -1703,10 +1703,10 @@ let yyact = [| let _2 = (Parsing.peek_val __caml_parser_env 0 : 'component_list) in Obj.repr( # 165 "parser.mly" - ( match _1.nature with - | IndexedAccess (type_spec_node, subscripts_node) -> - node (VariablesDefinitions (type_spec_node, Some subscripts_node, (List.rev _2))) - | type_spec -> + ( match _1.nature with + | IndexedAccess (type_spec_node, subscripts_node) -> + node (VariablesDefinitions (type_spec_node, Some subscripts_node, (List.rev _2))) + | type_spec -> node (VariablesDefinitions (rhs_nodes 1 1 type_spec, None, (List.rev _2))) ) # 1712 "parser.ml" : 'toplevel_expression)) @@ -1902,7 +1902,7 @@ let yyact = [| let _4 = (Parsing.peek_val __caml_parser_env 0 : string) in Obj.repr( # 245 "parser.mly" - ( if _1 <> _4 then unclosed _1 1 _1 4 + ( if _1 <> _4 then unclosed _1 1 _1 4 else node (LongSpecifier (_1, _2, _3)) ) # 1908 "parser.ml" : 'class_specifier)) @@ -1943,7 +1943,7 @@ let yyact = [| let _6 = (Parsing.peek_val __caml_parser_env 0 : string) in Obj.repr( # 255 "parser.mly" - ( if _2 <> _6 then unclosed _2 2 _2 6 + ( if _2 <> _6 then unclosed _2 2 _2 6 else node (ExtensionSpecifier (_2, _3, _4, _5)) ) # 1949 "parser.ml" : 'class_specifier)) @@ -2710,7 +2710,7 @@ let yyact = [| let _3 = (Parsing.peek_val __caml_parser_env 0 : 'component_declaration) in Obj.repr( # 600 "parser.mly" - ( let cpnt = node (ComponentClause (_1, _2, None, [_3])) in + ( let cpnt = node (ComponentClause (_1, _2, None, [_3])) in node (ComponentClauseElement (None, cpnt, [])) ) # 2716 "parser.ml" : 'class_definition_or_component_clause1)) @@ -2735,7 +2735,7 @@ let yyact = [| let _4 = (Parsing.peek_val __caml_parser_env 0 : 'component_declaration) in Obj.repr( # 608 "parser.mly" - ( let cpnt = node (ComponentClause (_2, _3, None, [_4])) in + ( let cpnt = node (ComponentClause (_2, _3, None, [_4])) in node (ComponentClauseElement (Some Replaceable, cpnt, [])) ) # 2741 "parser.ml" : 'class_definition_or_component_clause1)) @@ -2746,7 +2746,7 @@ let yyact = [| let _5 = (Parsing.peek_val __caml_parser_env 0 : 'constraining_clauses) in Obj.repr( # 612 "parser.mly" - ( let cpnt = node (ComponentClause (_2, _3, None, [_4])) in + ( let cpnt = node (ComponentClause (_2, _3, None, [_4])) in node (ComponentClauseElement (Some Replaceable, cpnt, List.rev _5)) ) # 2752 "parser.ml" : 'class_definition_or_component_clause1)) @@ -3603,8 +3603,8 @@ let yyact = [| let _2 = (Parsing.peek_val __caml_parser_env 1 : 'expression_list) in Obj.repr( # 981 "parser.mly" - ( match _2 with - | [expr] -> node expr.Syntax.nature + ( match _2 with + | [expr] -> node expr.Syntax.nature | _ -> node (Tuple _2) ) # 3610 "parser.ml" : 'primary)) @@ -3931,43 +3931,43 @@ let definition (lexfun : Lexing.lexbuf -> token) (lexbuf : Lexing.lexbuf) = (Parsing.yyparse yytables 1 lexfun lexbuf : (location Syntax.toplevel_element_desc, location) Syntax.node) ;; # 1113 "parser.mly" - - -let parse filename token_fun lexbuf = - inputfile := filename; - try - definition token_fun lexbuf - with - | Unclosed (pos, symbol, pos', symbol') -> - raise (SyntacticError - {err_msg = ["_Unclosed"; symbol]; - err_info = []; - err_ctx = - {location = {start = pos; - enddd = pos'; - filename = filename}}}) - | Invalid_matrix (pos, pos') -> - raise (SyntacticError - {err_msg = ["_InvalidMatrixConstruct"]; - err_info = []; - err_ctx = - {location = {start = pos; - enddd = pos'; - filename = filename}}}) - | Invalid_array (pos, pos') -> - raise (SyntacticError - {err_msg = ["_InvalidArrayConstruct"]; - err_info = []; - err_ctx = - {location = {start = pos; - enddd = pos'; - filename = filename}}}) - | Parsing.Parse_error -> - raise (SyntacticError - {err_msg = ["_SyntaxError"]; - err_info = []; - err_ctx = - {location = {start = Lexing.lexeme_start lexbuf; - enddd = Lexing.lexeme_end lexbuf; - filename = filename}}}) + + +let parse filename token_fun lexbuf = + inputfile := filename; + try + definition token_fun lexbuf + with + | Unclosed (pos, symbol, pos', symbol') -> + raise (SyntacticError + {err_msg = ["_Unclosed"; symbol]; + err_info = []; + err_ctx = + {location = {start = pos; + enddd = pos'; + filename = filename}}}) + | Invalid_matrix (pos, pos') -> + raise (SyntacticError + {err_msg = ["_InvalidMatrixConstruct"]; + err_info = []; + err_ctx = + {location = {start = pos; + enddd = pos'; + filename = filename}}}) + | Invalid_array (pos, pos') -> + raise (SyntacticError + {err_msg = ["_InvalidArrayConstruct"]; + err_info = []; + err_ctx = + {location = {start = pos; + enddd = pos'; + filename = filename}}}) + | Parsing.Parse_error -> + raise (SyntacticError + {err_msg = ["_SyntaxError"]; + err_info = []; + err_ctx = + {location = {start = Lexing.lexeme_start lexbuf; + enddd = Lexing.lexeme_end lexbuf; + filename = filename}}}) # 3974 "parser.ml" diff --git a/scilab/modules/scicos/src/translator/parsing/parser.mly b/scilab/modules/scicos/src/translator/parsing/parser.mly index 3d4e4c5..ceb19a9 100644 --- a/scilab/modules/scicos/src/translator/parsing/parser.mly +++ b/scilab/modules/scicos/src/translator/parsing/parser.mly @@ -1,1151 +1,1151 @@ -/* - * Translator from Modelica 2.x to flat Modelica - * - * Copyright (C) 2005 - 2007 Imagine S.A. - * For more information or commercial use please contact us at www.amesim.com - * - * This program is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. - * - */ - -/* - * Parser - * Grammar for the Modelica language v2.2 - * V 1.0 - * S. FURIC - */ - -%{ - -(** Modelica parser. *) - -(** Implementation based on {i Modelica language specification 2.0 } *) - -open Syntax - -exception Unclosed of int * string * int * string -exception Invalid_matrix of int * int -exception Invalid_array of int * int -exception End_of_file - -type location = - { - start: int; (* offset in the parsed stream *) - enddd: int; (* offset in the parsed stream *) - filename: filename - } - -and filename = - | LibraryFile of string - | CommandLine - -type error_description = - { - err_msg: string list; - err_info: (string * string) list; - err_ctx: err_ctx - } - -and err_ctx = - { - location: location; - } - -exception SyntacticError of error_description - -let inputfile = ref CommandLine - -let node nature = - { - nature = nature; - info = { start = Parsing.symbol_start (); - enddd = Parsing.symbol_end (); - filename = !inputfile } - } - -let rhs_nodes n n' nature = - { - nature = nature; - info = { start = Parsing.rhs_start n; - enddd = Parsing.rhs_end n'; - filename = !inputfile } - } - -let unclosed opening_symbol opening_pos closing_symbol closing_pos = - let offset = Parsing.rhs_start opening_pos - and offset' = Parsing.rhs_start closing_pos in - raise (Unclosed (offset, opening_symbol, offset', closing_symbol)) - -let invalid_matrix_construction opening_pos error_pos = - raise (Invalid_matrix ( - Parsing.rhs_start opening_pos, Parsing.rhs_start error_pos)) - -let invalid_literal_array_construction opening_pos error_pos = - raise (Invalid_array ( - Parsing.rhs_start opening_pos, Parsing.rhs_start error_pos)) - -%} - -/*names*/ -%token IDENT END_IDENT - -/*literals*/ -%token UNSIGNED_INTEGER UNSIGNED_REAL STRING - -/*keywords*/ -%token ALGORITHM AND ANNOTATION BLOCK BREAK CLASS CONNECT CONNECTOR CONSTANT -%token DISCRETE EACH ELSE ELSEIF ELSEWHEN ENCAPSULATED END -%token END_IF END_FOR END_WHEN END_WHILE -%token ENUMERATION EQUATION EXPANDABLE -%token EXTENDS EXTERNAL FALSE FINAL FLOW FOR FUNCTION IF IMPORT IN -%token INITIAL_ALGORITHM INITIAL_EQUATION -%token INNER INPUT LOOP MODEL NOT NOEVENT OR OUTER OUTPUT -%token PACKAGE PARAMETER PARTIAL -%token PROTECTED PUBLIC RECORD REDECLARE REPLACEABLE RESTRICTS RETURN -%token THEN TRUE TYPE WHEN WHILE WITHIN - -/*symbols*/ -%token LP RP LSB RSB LCB RCB /* ( ) [ ] { } */ -%token DOT CM SC CL /* . , ; : */ -%token PLUS MINUS STAR SLASH EXP /* + - * / ^ */ -%token EQ COLEQ /* = := */ -%token LT GT LE GE EE NE /* < > <= >= == <> */ - -/*end of file*/ -%token EOF - -%type <(location Syntax.toplevel_element_desc, location) Syntax.node> definition -%start definition - -%% - - -/*(2.2.1)*/ -definition - : class_definitions - { node (ClassDefinitions (List.rev $1)) } - | toplevel_expression SC - { $1 } - | WITHIN SC - { node (Within []) } - | WITHIN within_name SC - { node (Within (List.rev $2)) } - | import_clause SC - { node (Import $1) } - | EOF - { raise End_of_file } - ; - -class_definitions - : FINAL class_definition SC - { [node (ClassDefinition (Some Final, $2))] } - | class_definition SC - { [node (ClassDefinition (None, $1))] } - | class_definitions FINAL class_definition SC - { node (ClassDefinition (Some Final, $3)) :: $1 } - | class_definitions class_definition SC - { node (ClassDefinition (None, $2)) :: $1 } - -toplevel_expression - : expression - { node (Expression $1) } - | component_reference component_list - { match $1.nature with - | IndexedAccess (type_spec_node, subscripts_node) -> - node (VariablesDefinitions (type_spec_node, Some subscripts_node, (List.rev $2))) - | type_spec -> - node (VariablesDefinitions (rhs_nodes 1 1 type_spec, None, (List.rev $2))) } - | component_reference COLEQ expression - { node (Command (node (Assign ($1, $3)))) } - | LP expression_list RP COLEQ component_reference LP RP - { node (Command (node (MultipleAssign ($2, $5, None)))) } - | LP expression_list RP COLEQ component_reference LP function_arguments RP - { node (Command (node (MultipleAssign ($2, $5, Some $7)))) } - | LP expression_list RP COLEQ component_reference LP function_arguments - error - { unclosed "(" 6 ")" 8 } - | LP expression_list RP COLEQ component_reference LP error - { unclosed "(" 6 ")" 7 } - | BREAK - { node (Command (node Break)) } - | RETURN - { node (Command (node Return)) } - | conditional_equation_a - { node (Command (node $1)) } - | for_clause_a - { node (Command (node $1)) } - | while_clause - { node (Command (node $1)) } - | when_clause_a - { node (Command (node $1)) } - ; - -within_name - : IDENT - { [$1] } - | within_name DOT IDENT - { $3 :: $1 } - ; - -/*(2.2.2)*/ -class_definition - : encapsulated_option partial_option class_type class_specifier - { node (Definition ($1, $2, $3, $4)) } - ; - -class_type - : CLASS - { Class } - | MODEL - { Model } - | BLOCK - { Block } - | RECORD - { Record } - | EXPANDABLE CONNECTOR - { ExpandableConnector } - | CONNECTOR - { Connector } - | TYPE - { Type } - | PACKAGE - { Package } - | FUNCTION - { Function } - ; - -encapsulated_option - : - { None } - | ENCAPSULATED - { Some Encapsulated } - ; - -partial_option - : - { None } - | PARTIAL - { Some Partial } - ; - -class_specifier - : IDENT string_comment composition END_IDENT - { if $1 <> $4 then unclosed $1 1 $1 4 - else node (LongSpecifier ($1, $2, $3)) } - | IDENT EQ base_prefix name array_subscripts_option class_modification_option - comment - { node (ShortSpecifier ($1, $3, $4, $5, $6, $7)) } - | IDENT EQ ENUMERATION LP enum_composition_option RP comment - { node (EnumerationSpecifier ($1, rhs_nodes 5 5 $5, $7)) } - | IDENT EQ ENUMERATION LP enum_composition_option error - { unclosed "(" 4 ")" 6 } - | EXTENDS IDENT class_modification_option string_comment composition END_IDENT - { if $2 <> $6 then unclosed $2 2 $2 6 - else node (ExtensionSpecifier ($2, $3, $4, $5)) } - ; - -base_prefix - : type_prefix - { $1 } - ; - -enum_composition_option - : - { EnumList None } - | enum_composition - { $1 } - ; - -enum_composition - : enum_list - { EnumList (Some (List.rev $1)) } - | CL - { EnumColon} - ; - -enum_list - : enumeration_literal - { [$1] } - | enum_list CM enumeration_literal - { $3 :: $1 } - ; - -enumeration_literal - : IDENT comment - { node (EnumerationLiteral ($1, $2)) } - ; - -composition - : other_lists external_option - { node (Composition ([], List.rev $1, $2)) } - | element_list other_lists external_option - { node (Composition (List.rev $1, List.rev $2, $3)) } - ; - -other_lists - : - { [] } - | other_lists PUBLIC element_list - { rhs_nodes 2 3 (Public (List.rev $3)) :: $1 } - | other_lists PROTECTED element_list - { rhs_nodes 2 3 (Protected (List.rev $3)) :: $1 } - | other_lists equation_clause - { rhs_nodes 2 2 $2 :: $1 } - | other_lists algorithm_clause - { rhs_nodes 2 2 $2 :: $1 } - ; - -external_option - : - { None } - | EXTERNAL language_specification_option - external_function_call_option SC - annotation_sc_option - { Some (node (External ($2, $3, None, $5))) } - | EXTERNAL language_specification_option - external_function_call_option annotation SC - annotation_sc_option - { Some (node (External ($2, $3, Some $4, $6))) } - ; - -annotation_option - : - { None } - | annotation - { Some $1 } - ; - -annotation_sc_option - : - { None } - | annotation SC - { Some $1 } - ; - -language_specification_option - : - { None } - | STRING - { Some $1 } - ; - -external_function_call_option - : - { None } - | IDENT LP RP - { Some (node (ExternalFunctionCall (None, $1, []))) } - | IDENT LP expressions RP - { Some (node (ExternalFunctionCall (None, $1, $3))) } - | IDENT LP expressions error - { unclosed "(" 2 ")" 4 } - | IDENT LP error - { unclosed "(" 2 ")" 3 } - | component_reference EQ IDENT LP RP - { Some (node (ExternalFunctionCall (Some $1, $3, []))) } - | component_reference EQ IDENT LP expressions RP - { Some (node (ExternalFunctionCall (Some $1, $3, $5))) } - | component_reference EQ IDENT LP expressions error - { unclosed "(" 4 ")" 6 } - | component_reference EQ IDENT LP error - { unclosed "(" 4 ")" 5 } - ; - -expressions - : expression - { [$1] } - | expression CM expressions - { $1 :: $3 } - ; - -array_subscripts_option - : - { None } - | array_subscripts - { Some $1 } - ; - -class_modification_option - : - { None } - | class_modification - { Some $1 } - ; - -element_list - : annotation SC - { [node (ClassAnnotation $1)] } - | import_clause SC annotation_sc_option - { [node (ImportClause ($1, $3))] } - | extends_clause SC annotation_sc_option - { [node (ExtendsClause ($1, $3))] } - | redeclare_option final_option dynamic_scope_option - element_definition SC annotation_sc_option - { [node (ElementDefinition ($1, $2, $3, $4, $6))] } - | element_list import_clause SC annotation_sc_option - { rhs_nodes 2 3 (ImportClause ($2, $4)) :: $1 } - | element_list extends_clause SC annotation_sc_option - { rhs_nodes 2 3 (ExtendsClause ($2, $4)) :: $1 } - | element_list redeclare_option final_option dynamic_scope_option - element_definition SC annotation_sc_option - { rhs_nodes 2 5 (ElementDefinition ($2, $3, $4, $5, $7)) :: $1 } - ; - -element_definition - : class_definition - { node (ClassDefinitionElement (None, $1, [])) } - | component_clause - { node (ComponentClauseElement (None, $1, [])) } - | REPLACEABLE class_definition - { node (ClassDefinitionElement (Some Replaceable, $2, [])) } - | REPLACEABLE class_definition constraining_clauses - { node (ClassDefinitionElement (Some Replaceable, $2, List.rev $3)) } - | REPLACEABLE component_clause - { node (ComponentClauseElement (Some Replaceable, $2, [])) } - | REPLACEABLE component_clause constraining_clauses - { node (ComponentClauseElement (Some Replaceable, $2, List.rev $3)) } - ; - -redeclare_option - : - { None } - | REDECLARE - { Some Redeclare } - ; - -final_option - : - { None } - | FINAL - { Some Final } - ; - -dynamic_scope_option - : - { None } - | INNER - { Some Inner } - | OUTER - { Some Outer } - | INNER OUTER - { Some InnerOuter } - ; - -import_clause - : IMPORT IDENT EQ name comment - { node (NewIdentifier ($2, $4, $5)) } - | IMPORT name comment - { node (OldIdentifier ($2, $3)) } - | IMPORT name DOT STAR comment - { node (AllIdentifiers ($2, $5)) } - ; - -constraining_clauses - : constraining_clause - { [$1] } - | constraining_clauses constraining_clause - { $2 :: $1 } - ; - -/*(2.2.3)*/ -extends_clause - : EXTENDS name class_modification_option annotation_option - { node (Extends ($2, $3, $4)) } - ; - -constraining_clause - : EXTENDS name class_modification_option comment - { node (Constraint (Extension, $2, $3, $4)) } - | RESTRICTS name class_modification_option comment - { node (Constraint (Restriction, $2, $3, $4)) } - ; - -/*(2.2.4)*/ -component_clause - : type_prefix type_specifier array_subscripts_option component_list - { node (ComponentClause ($1, $2, $3, List.rev $4)) } - ; - -type_prefix - : flow_option variability_option inout_option - { node (TypePrefix ($1, $2, $3)) } - ; - -flow_option - : - { None } - | FLOW - { Some Flow } - ; - -variability_option - : - { None } - | DISCRETE - { Some Discrete } - | PARAMETER - { Some Parameter } - | CONSTANT - { Some Constant } - ; - -inout_option - : - { None } - | INPUT - { Some Input } - | OUTPUT - { Some Output } - ; - -type_specifier - : name - { $1 } - ; - -component_list - : component_declaration - { [$1] } - | component_list CM component_declaration - { $3 :: $1 } - ; - -component_declaration - : declaration comment - { node (ComponentDeclaration ($1, $2)) } - ; - -declaration - : IDENT array_subscripts_option modification_option - { node (Declaration ($1, $2, $3)) } - ; - -modification_option - : - { None } - | modification - { Some $1 } - ; - -/*(2.2.5)*/ -modification - : class_modification EQ expression - { node (Modification ($1, Some $3)) } - | class_modification - { node (Modification ($1, None)) } - | EQ expression - { node (Eq $2) } - | COLEQ expression - { node (ColEq $2) } - ; - -class_modification - : LP RP - { node (ClassModification []) } - | LP argument_list RP - { node (ClassModification (List.rev $2)) } - | LP argument_list error - { unclosed "(" 1 ")" 3 } - | LP error - { unclosed "(" 1 ")" 2 } - ; - -argument_list - : argument - { [$1] } - | argument CM argument_list - { $1 :: $3 } - ; - -argument - : element_modification - { $1 } - | element_redeclaration - { $1 } - ; - -element_modification - : each_option final_option component_reference modification_option - string_comment - { node (ElementModification ($1, $2, $3, $4, $5)) } - ; - -each_option - : - { None } - | EACH - { Some Each } - ; - -element_redeclaration - : REDECLARE each_option final_option class_definition_or_component_clause1 - { node (ElementRedeclaration ($2, $3, $4)) } - ; - -class_definition_or_component_clause1 - : class_definition - { node (ClassDefinitionElement (None, $1, [])) } - | type_prefix type_specifier component_declaration - { let cpnt = node (ComponentClause ($1, $2, None, [$3])) in - node (ComponentClauseElement (None, cpnt, [])) } - | REPLACEABLE class_definition - { node (ClassDefinitionElement (Some Replaceable, $2, [])) } - | REPLACEABLE class_definition constraining_clauses - { node (ClassDefinitionElement (Some Replaceable, $2, List.rev $3)) } - | REPLACEABLE type_prefix type_specifier - component_declaration - { let cpnt = node (ComponentClause ($2, $3, None, [$4])) in - node (ComponentClauseElement (Some Replaceable, cpnt, [])) } - | REPLACEABLE type_prefix type_specifier - component_declaration constraining_clauses - { let cpnt = node (ComponentClause ($2, $3, None, [$4])) in - node (ComponentClauseElement (Some Replaceable, cpnt, List.rev $5)) } - ; - -/*(2.2.6)*/ -equation_clause - : INITIAL_EQUATION - { EquationClause (Some Initial, []) } - | INITIAL_EQUATION equations - { EquationClause (Some Initial, List.rev $2) } - | EQUATION - { EquationClause (None, []) } - | EQUATION equations - { EquationClause (None, List.rev $2) } ; - -equations - : equation comment SC annotation_sc_option - { [node (Equation (rhs_nodes 1 3 $1, $2, $4))] } - | equations equation comment SC annotation_sc_option - { rhs_nodes 2 5 (Equation (rhs_nodes 2 4 $2, $3, $5)) :: $1 } - ; - -algorithm_clause - : INITIAL_ALGORITHM - { AlgorithmClause (Some Initial, []) } - | INITIAL_ALGORITHM algorithms - { AlgorithmClause (Some Initial, List.rev $2) } - | ALGORITHM - { AlgorithmClause (None, []) } - | ALGORITHM algorithms - { AlgorithmClause (None, List.rev $2) } - ; - -algorithms - : algorithm comment SC annotation_sc_option - { [node (Algorithm (rhs_nodes 1 3 $1, $2, $4))] } - | algorithms algorithm comment SC annotation_sc_option - { rhs_nodes 2 5 (Algorithm (rhs_nodes 2 4 $2, $3, $5)) :: $1 } - ; - -equation - : simple_expression EQ expression - { Equal ($1, $3) } - | conditional_equation_e - { $1 } - | for_clause_e - { $1 } - | connect_clause - { $1 } - | when_clause_e - { $1 } - | component_reference LP RP - { FunctionCallE ($1, None) } - | component_reference LP function_arguments RP - { FunctionCallE ($1, Some $3) } - | component_reference LP function_arguments error - { unclosed "(" 2 ")" 4 } - | component_reference LP error - { unclosed "(" 2 ")" 3 } -; - -algorithm - : component_reference COLEQ expression - { Assign ($1, $3) } - | component_reference LP RP - { FunctionCallA ($1, None) } - | component_reference LP function_arguments RP - { FunctionCallA ($1, Some $3) } - | component_reference LP function_arguments error - { unclosed "(" 2 ")" 4 } - | component_reference LP error - { unclosed "(" 2 ")" 3 } - | LP expression_list RP COLEQ component_reference LP RP - { MultipleAssign ($2, $5, None) } - | LP RP COLEQ component_reference LP RP - { MultipleAssign ([], $4, None) } - | LP expression_list RP COLEQ component_reference LP function_arguments RP - { MultipleAssign ($2, $5, Some $7) } - | LP RP COLEQ component_reference LP function_arguments RP - { MultipleAssign ([], $4, Some $6) } - | LP expression_list RP COLEQ component_reference LP function_arguments - error - { unclosed "(" 6 ")" 8 } - | LP RP COLEQ component_reference LP function_arguments error - { unclosed "(" 5 ")" 7 } - | LP expression_list RP COLEQ component_reference LP error - { unclosed "(" 6 ")" 7 } - | LP RP COLEQ component_reference LP error - { unclosed "(" 5 ")" 6 } - | LP expression_list error - { unclosed "(" 1 ")" 3 } - | LP error - { unclosed "(" 1 ")" 2 } - | BREAK - { Break } - | RETURN - { Return } - | conditional_equation_a - { $1 } - | for_clause_a - { $1 } - | while_clause - { $1 } - | when_clause_a - { $1 } - ; - -conditional_equation_e - : IF expression THEN - equations_e - else_if_expressions_e - else_option_e - END_IF - { ConditionalEquationE (($2, List.rev $4) :: $5, $6) } - ; - -else_if_expressions_e - : - { [] } - | ELSEIF expression THEN - equations_e - else_if_expressions_e - { ($2, List.rev $4) :: $5 } - ; - -else_option_e - : - { None } - | ELSE equations_e - { Some (List.rev $2) } - ; - -equations_e - : equation SC - { [node $1] } - | equations_e equation SC - { rhs_nodes 2 3 $2 :: $1 } - ; - -conditional_equation_a - : IF expression THEN - algorithms_a - else_if_expressions_a - else_option_a - END_IF - { ConditionalEquationA (($2, List.rev $4) :: $5, $6) } - ; - -else_if_expressions_a - : - { [] } - | ELSEIF expression THEN - algorithms_a - else_if_expressions_a - { ($2, List.rev $4) :: $5 } - ; - -else_option_a - : - { None } - | ELSE algorithms_a - { Some (List.rev $2) } - ; - -algorithms_a - : algorithm SC - { [node $1] } - | algorithms_a algorithm SC - { rhs_nodes 2 3 $2 :: $1 } - ; - -for_clause_e - : FOR for_indices LOOP - equations_e - END_FOR - { ForClauseE ($2, List.rev $4) } - ; - -for_clause_a - : FOR for_indices LOOP - algorithms_a - END_FOR - { ForClauseA ($2, List.rev $4) } - ; - -for_indices - : for_index - { [$1] } - | for_index CM for_indices - { $1 :: $3 } - ; - -for_index - : IDENT - { ($1, None) } - | IDENT IN expression - { ($1, Some $3) } - ; - -while_clause - : WHILE expression LOOP - algorithms_a - END_WHILE - { WhileClause ($2, List.rev $4) } - ; - -when_clause_e - : WHEN expression THEN - equations_e - else_when_expressions_e - END_WHEN - { WhenClauseE (($2, List.rev $4) :: $5) } - ; - -when_clause_a - : WHEN expression THEN - algorithms_a - else_when_expressions_a - END_WHEN - { WhenClauseA (($2, List.rev $4) :: $5) } - ; - -else_when_expressions_e - : - { [] } - | ELSEWHEN expression THEN - equations_e - else_when_expressions_e - { ($2, List.rev $4) :: $5 } - ; - -else_when_expressions_a - : - { [] } - | ELSEWHEN expression THEN - algorithms_a - else_when_expressions_a - { ($2, List.rev $4) :: $5 } - ; - -connect_clause - : CONNECT LP component_reference CM component_reference RP - { ConnectClause ($3, $5) } - | CONNECT LP component_reference CM component_reference error - { unclosed "(" 2 ")" 6 } - ; - -/*(2.2.7)*/ -expression - : simple_expression - { $1 } - | IF expression THEN expression - elseifs_option - ELSE expression - { node (If (($2, $4) :: $5, $7)) } - ; - -elseifs_option - : - { [] } - | ELSEIF expression THEN expression - elseifs_option - { ($2, $4) :: $5 } - ; - -simple_expression - : logical_expression - { $1 } - | logical_expression CL logical_expression - { node (Range ($1, None, $3)) } - | logical_expression CL logical_expression CL logical_expression - { node (Range ($1, Some $3, $5)) } - ; - -logical_expression - : logical_term - { $1 } - | logical_expression OR logical_term - { node (BinaryOperation (rhs_nodes 2 2 Or, $1, $3)) } - ; - -logical_term - : logical_factor - { $1 } - | logical_term AND logical_factor - { node (BinaryOperation (rhs_nodes 2 2 And, $1, $3)) } - ; - -logical_factor - : relation - { $1 } - | NOT relation - { node (UnaryOperation (rhs_nodes 1 1 Not, $2)) } - ; - -relation - : arithmetic_expression - { $1 } - | arithmetic_expression LT arithmetic_expression - { node (BinaryOperation (rhs_nodes 2 2 Less, $1, $3)) } - | arithmetic_expression GT arithmetic_expression - { node (BinaryOperation (rhs_nodes 2 2 Greater, $1, $3)) } - | arithmetic_expression LE arithmetic_expression - { node (BinaryOperation (rhs_nodes 2 2 LessEqual, $1, $3)) } - | arithmetic_expression GE arithmetic_expression - { node (BinaryOperation (rhs_nodes 2 2 GreaterEqual, $1, $3)) } - | arithmetic_expression EE arithmetic_expression - { node (BinaryOperation (rhs_nodes 2 2 EqualEqual, $1, $3)) } - | arithmetic_expression NE arithmetic_expression - { node (BinaryOperation (rhs_nodes 2 2 NotEqual, $1, $3)) } - ; - -arithmetic_expression - : term - { $1 } - | arithmetic_expression PLUS term - { node (BinaryOperation (rhs_nodes 2 2 Plus, $1, $3)) } - | arithmetic_expression MINUS term - { node (BinaryOperation (rhs_nodes 2 2 Minus, $1, $3)) } - ; - -term - : unary_factor - { $1 } - | term STAR unary_factor - { node (BinaryOperation (rhs_nodes 2 2 Times, $1, $3)) } - | term SLASH unary_factor - { node (BinaryOperation (rhs_nodes 2 2 Divide, $1, $3)) } - ; - -unary_factor - : factor - { $1 } - | PLUS unary_factor - { node (UnaryOperation (rhs_nodes 1 1 UnaryPlus, $2)) } - | MINUS unary_factor - { node (UnaryOperation (rhs_nodes 1 1 UnaryMinus, $2)) } - -factor - : primary - { $1 } - | factor EXP primary - { node (BinaryOperation (rhs_nodes 2 2 Power, $1, $3)) } - ; - -primary - : UNSIGNED_INTEGER - { node (Integer $1) } - | UNSIGNED_REAL - { node (Real $1) } - | STRING - { node (String $1) } - | FALSE - { node False } - | TRUE - { node True } - | NOEVENT LP expression RP - { node (NoEvent $3) } - | component_reference - { $1 } - | component_reference LP RP - { node (FunctionCall ($1, None)) } - | component_reference LP function_arguments RP - { node (FunctionCall ($1, Some $3)) } - | component_reference LP function_arguments error - { unclosed "(" 2 ")" 4 } - | component_reference LP error - { unclosed "(" 2 ")" 3 } - | LP expression_list RP - { match $2 with - | [expr] -> node expr.Syntax.nature - | _ -> node (Tuple $2) } - | LP expression_list error - { unclosed "(" 1 ")" 3 } - | LSB expression_lists RSB - { node (MatrixConstruction $2) } - | LSB error - { invalid_matrix_construction 1 2 } - | LCB vector_elements RCB - { node (Vector $2) } - | LCB error - { invalid_literal_array_construction 1 2 } - | END - { node End } - ; - -expression_lists - : expression_list - { [$1] } - | expression_list SC expression_lists - { $1 :: $3 } - ; - -vector_elements - : expression FOR for_indices - { node (VectorReduction ($1, $3)) } - | expression_list - { node (VectorElements $1) } - ; - -name - : IDENT - { node (Identifier $1) } - | name DOT IDENT - { node (FieldAccess ($1, $3)) } - ; - -component_reference - : IDENT - { node (Identifier $1) } - | IDENT array_subscripts - { node (IndexedAccess (rhs_nodes 1 1 (Identifier $1), $2)) } - | component_reference DOT IDENT - { node (FieldAccess ($1, $3)) } - | component_reference DOT IDENT array_subscripts - { node (IndexedAccess (rhs_nodes 1 3 (FieldAccess ($1, $3)), $4)) } - ; - -function_arguments - : function_arguments_elements - { node (ArgumentList (List.rev $1)) } - | expression FOR for_indices - { node (Reduction ($1, $3)) } - ; - -function_arguments_elements - : expression - { [node (Argument $1)] } - | named_argument - { [$1] } - | function_arguments_elements CM expression - { node (Argument $3) :: $1 } - | function_arguments_elements CM named_argument - { $3 :: $1 } - ; - -named_argument - : IDENT EQ expression - { node (NamedArgument ($1, $3)) } - | FUNCTION IDENT - { failwith "Not yet implemented" } - | FUNCTION IDENT LP RP - { failwith "Not yet implemented" } - | FUNCTION IDENT LP function_arguments RP - { failwith "Not yet implemented" } - | FUNCTION IDENT LP function_arguments error - { unclosed "(" 3 ")" 5 } - | FUNCTION IDENT LP error - { unclosed "(" 3 ")" 4 } - ; - -expression_list - : expression - { [$1] } - | expression CM expression_list - { $1 :: $3 } - ; - -array_subscripts - : LSB subscripts RSB - { node (Subscripts $2) } - ; - -subscripts - : subscript - { [$1] } - | subscript CM subscripts - { $1 :: $3 } - ; - -subscript - : CL - { node Colon } - | expression - { node (Subscript $1) } - ; - -comment - : string_comment annotation_option - { node (Comment ($1, $2)) } - ; - -string_comment - : - { [] } - | strings - { List.rev $1 } - ; - -strings - : STRING - { [$1] } - | strings PLUS STRING - { $3 :: $1 } - ; - -annotation - : ANNOTATION class_modification - { node (Annotation $2) } - ; - -%% - -let parse filename token_fun lexbuf = - inputfile := filename; - try - definition token_fun lexbuf - with - | Unclosed (pos, symbol, pos', symbol') -> - raise (SyntacticError - {err_msg = ["_Unclosed"; symbol]; - err_info = []; - err_ctx = - {location = {start = pos; - enddd = pos'; - filename = filename}}}) - | Invalid_matrix (pos, pos') -> - raise (SyntacticError - {err_msg = ["_InvalidMatrixConstruct"]; - err_info = []; - err_ctx = - {location = {start = pos; - enddd = pos'; - filename = filename}}}) - | Invalid_array (pos, pos') -> - raise (SyntacticError - {err_msg = ["_InvalidArrayConstruct"]; - err_info = []; - err_ctx = - {location = {start = pos; - enddd = pos'; - filename = filename}}}) - | Parsing.Parse_error -> - raise (SyntacticError - {err_msg = ["_SyntaxError"]; - err_info = []; - err_ctx = - {location = {start = Lexing.lexeme_start lexbuf; - enddd = Lexing.lexeme_end lexbuf; - filename = filename}}}) +/* + * Translator from Modelica 2.x to flat Modelica + * + * Copyright (C) 2005 - 2007 Imagine S.A. + * For more information or commercial use please contact us at www.amesim.com + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. + * + */ + +/* + * Parser + * Grammar for the Modelica language v2.2 + * V 1.0 + * S. FURIC + */ + +%{ + +(** Modelica parser. *) + +(** Implementation based on {i Modelica language specification 2.0 } *) + +open Syntax + +exception Unclosed of int * string * int * string +exception Invalid_matrix of int * int +exception Invalid_array of int * int +exception End_of_file + +type location = + { + start: int; (* offset in the parsed stream *) + enddd: int; (* offset in the parsed stream *) + filename: filename + } + +and filename = + | LibraryFile of string + | CommandLine + +type error_description = + { + err_msg: string list; + err_info: (string * string) list; + err_ctx: err_ctx + } + +and err_ctx = + { + location: location; + } + +exception SyntacticError of error_description + +let inputfile = ref CommandLine + +let node nature = + { + nature = nature; + info = { start = Parsing.symbol_start (); + enddd = Parsing.symbol_end (); + filename = !inputfile } + } + +let rhs_nodes n n' nature = + { + nature = nature; + info = { start = Parsing.rhs_start n; + enddd = Parsing.rhs_end n'; + filename = !inputfile } + } + +let unclosed opening_symbol opening_pos closing_symbol closing_pos = + let offset = Parsing.rhs_start opening_pos + and offset' = Parsing.rhs_start closing_pos in + raise (Unclosed (offset, opening_symbol, offset', closing_symbol)) + +let invalid_matrix_construction opening_pos error_pos = + raise (Invalid_matrix ( + Parsing.rhs_start opening_pos, Parsing.rhs_start error_pos)) + +let invalid_literal_array_construction opening_pos error_pos = + raise (Invalid_array ( + Parsing.rhs_start opening_pos, Parsing.rhs_start error_pos)) + +%} + +/*names*/ +%token IDENT END_IDENT + +/*literals*/ +%token UNSIGNED_INTEGER UNSIGNED_REAL STRING + +/*keywords*/ +%token ALGORITHM AND ANNOTATION BLOCK BREAK CLASS CONNECT CONNECTOR CONSTANT +%token DISCRETE EACH ELSE ELSEIF ELSEWHEN ENCAPSULATED END +%token END_IF END_FOR END_WHEN END_WHILE +%token ENUMERATION EQUATION EXPANDABLE +%token EXTENDS EXTERNAL FALSE FINAL FLOW FOR FUNCTION IF IMPORT IN +%token INITIAL_ALGORITHM INITIAL_EQUATION +%token INNER INPUT LOOP MODEL NOT NOEVENT OR OUTER OUTPUT +%token PACKAGE PARAMETER PARTIAL +%token PROTECTED PUBLIC RECORD REDECLARE REPLACEABLE RESTRICTS RETURN +%token THEN TRUE TYPE WHEN WHILE WITHIN + +/*symbols*/ +%token LP RP LSB RSB LCB RCB /* ( ) [ ] { } */ +%token DOT CM SC CL /* . , ; : */ +%token PLUS MINUS STAR SLASH EXP /* + - * / ^ */ +%token EQ COLEQ /* = := */ +%token LT GT LE GE EE NE /* < > <= >= == <> */ + +/*end of file*/ +%token EOF + +%type <(location Syntax.toplevel_element_desc, location) Syntax.node> definition +%start definition + +%% + + +/*(2.2.1)*/ +definition + : class_definitions + { node (ClassDefinitions (List.rev $1)) } + | toplevel_expression SC + { $1 } + | WITHIN SC + { node (Within []) } + | WITHIN within_name SC + { node (Within (List.rev $2)) } + | import_clause SC + { node (Import $1) } + | EOF + { raise End_of_file } + ; + +class_definitions + : FINAL class_definition SC + { [node (ClassDefinition (Some Final, $2))] } + | class_definition SC + { [node (ClassDefinition (None, $1))] } + | class_definitions FINAL class_definition SC + { node (ClassDefinition (Some Final, $3)) :: $1 } + | class_definitions class_definition SC + { node (ClassDefinition (None, $2)) :: $1 } + +toplevel_expression + : expression + { node (Expression $1) } + | component_reference component_list + { match $1.nature with + | IndexedAccess (type_spec_node, subscripts_node) -> + node (VariablesDefinitions (type_spec_node, Some subscripts_node, (List.rev $2))) + | type_spec -> + node (VariablesDefinitions (rhs_nodes 1 1 type_spec, None, (List.rev $2))) } + | component_reference COLEQ expression + { node (Command (node (Assign ($1, $3)))) } + | LP expression_list RP COLEQ component_reference LP RP + { node (Command (node (MultipleAssign ($2, $5, None)))) } + | LP expression_list RP COLEQ component_reference LP function_arguments RP + { node (Command (node (MultipleAssign ($2, $5, Some $7)))) } + | LP expression_list RP COLEQ component_reference LP function_arguments + error + { unclosed "(" 6 ")" 8 } + | LP expression_list RP COLEQ component_reference LP error + { unclosed "(" 6 ")" 7 } + | BREAK + { node (Command (node Break)) } + | RETURN + { node (Command (node Return)) } + | conditional_equation_a + { node (Command (node $1)) } + | for_clause_a + { node (Command (node $1)) } + | while_clause + { node (Command (node $1)) } + | when_clause_a + { node (Command (node $1)) } + ; + +within_name + : IDENT + { [$1] } + | within_name DOT IDENT + { $3 :: $1 } + ; + +/*(2.2.2)*/ +class_definition + : encapsulated_option partial_option class_type class_specifier + { node (Definition ($1, $2, $3, $4)) } + ; + +class_type + : CLASS + { Class } + | MODEL + { Model } + | BLOCK + { Block } + | RECORD + { Record } + | EXPANDABLE CONNECTOR + { ExpandableConnector } + | CONNECTOR + { Connector } + | TYPE + { Type } + | PACKAGE + { Package } + | FUNCTION + { Function } + ; + +encapsulated_option + : + { None } + | ENCAPSULATED + { Some Encapsulated } + ; + +partial_option + : + { None } + | PARTIAL + { Some Partial } + ; + +class_specifier + : IDENT string_comment composition END_IDENT + { if $1 <> $4 then unclosed $1 1 $1 4 + else node (LongSpecifier ($1, $2, $3)) } + | IDENT EQ base_prefix name array_subscripts_option class_modification_option + comment + { node (ShortSpecifier ($1, $3, $4, $5, $6, $7)) } + | IDENT EQ ENUMERATION LP enum_composition_option RP comment + { node (EnumerationSpecifier ($1, rhs_nodes 5 5 $5, $7)) } + | IDENT EQ ENUMERATION LP enum_composition_option error + { unclosed "(" 4 ")" 6 } + | EXTENDS IDENT class_modification_option string_comment composition END_IDENT + { if $2 <> $6 then unclosed $2 2 $2 6 + else node (ExtensionSpecifier ($2, $3, $4, $5)) } + ; + +base_prefix + : type_prefix + { $1 } + ; + +enum_composition_option + : + { EnumList None } + | enum_composition + { $1 } + ; + +enum_composition + : enum_list + { EnumList (Some (List.rev $1)) } + | CL + { EnumColon} + ; + +enum_list + : enumeration_literal + { [$1] } + | enum_list CM enumeration_literal + { $3 :: $1 } + ; + +enumeration_literal + : IDENT comment + { node (EnumerationLiteral ($1, $2)) } + ; + +composition + : other_lists external_option + { node (Composition ([], List.rev $1, $2)) } + | element_list other_lists external_option + { node (Composition (List.rev $1, List.rev $2, $3)) } + ; + +other_lists + : + { [] } + | other_lists PUBLIC element_list + { rhs_nodes 2 3 (Public (List.rev $3)) :: $1 } + | other_lists PROTECTED element_list + { rhs_nodes 2 3 (Protected (List.rev $3)) :: $1 } + | other_lists equation_clause + { rhs_nodes 2 2 $2 :: $1 } + | other_lists algorithm_clause + { rhs_nodes 2 2 $2 :: $1 } + ; + +external_option + : + { None } + | EXTERNAL language_specification_option + external_function_call_option SC + annotation_sc_option + { Some (node (External ($2, $3, None, $5))) } + | EXTERNAL language_specification_option + external_function_call_option annotation SC + annotation_sc_option + { Some (node (External ($2, $3, Some $4, $6))) } + ; + +annotation_option + : + { None } + | annotation + { Some $1 } + ; + +annotation_sc_option + : + { None } + | annotation SC + { Some $1 } + ; + +language_specification_option + : + { None } + | STRING + { Some $1 } + ; + +external_function_call_option + : + { None } + | IDENT LP RP + { Some (node (ExternalFunctionCall (None, $1, []))) } + | IDENT LP expressions RP + { Some (node (ExternalFunctionCall (None, $1, $3))) } + | IDENT LP expressions error + { unclosed "(" 2 ")" 4 } + | IDENT LP error + { unclosed "(" 2 ")" 3 } + | component_reference EQ IDENT LP RP + { Some (node (ExternalFunctionCall (Some $1, $3, []))) } + | component_reference EQ IDENT LP expressions RP + { Some (node (ExternalFunctionCall (Some $1, $3, $5))) } + | component_reference EQ IDENT LP expressions error + { unclosed "(" 4 ")" 6 } + | component_reference EQ IDENT LP error + { unclosed "(" 4 ")" 5 } + ; + +expressions + : expression + { [$1] } + | expression CM expressions + { $1 :: $3 } + ; + +array_subscripts_option + : + { None } + | array_subscripts + { Some $1 } + ; + +class_modification_option + : + { None } + | class_modification + { Some $1 } + ; + +element_list + : annotation SC + { [node (ClassAnnotation $1)] } + | import_clause SC annotation_sc_option + { [node (ImportClause ($1, $3))] } + | extends_clause SC annotation_sc_option + { [node (ExtendsClause ($1, $3))] } + | redeclare_option final_option dynamic_scope_option + element_definition SC annotation_sc_option + { [node (ElementDefinition ($1, $2, $3, $4, $6))] } + | element_list import_clause SC annotation_sc_option + { rhs_nodes 2 3 (ImportClause ($2, $4)) :: $1 } + | element_list extends_clause SC annotation_sc_option + { rhs_nodes 2 3 (ExtendsClause ($2, $4)) :: $1 } + | element_list redeclare_option final_option dynamic_scope_option + element_definition SC annotation_sc_option + { rhs_nodes 2 5 (ElementDefinition ($2, $3, $4, $5, $7)) :: $1 } + ; + +element_definition + : class_definition + { node (ClassDefinitionElement (None, $1, [])) } + | component_clause + { node (ComponentClauseElement (None, $1, [])) } + | REPLACEABLE class_definition + { node (ClassDefinitionElement (Some Replaceable, $2, [])) } + | REPLACEABLE class_definition constraining_clauses + { node (ClassDefinitionElement (Some Replaceable, $2, List.rev $3)) } + | REPLACEABLE component_clause + { node (ComponentClauseElement (Some Replaceable, $2, [])) } + | REPLACEABLE component_clause constraining_clauses + { node (ComponentClauseElement (Some Replaceable, $2, List.rev $3)) } + ; + +redeclare_option + : + { None } + | REDECLARE + { Some Redeclare } + ; + +final_option + : + { None } + | FINAL + { Some Final } + ; + +dynamic_scope_option + : + { None } + | INNER + { Some Inner } + | OUTER + { Some Outer } + | INNER OUTER + { Some InnerOuter } + ; + +import_clause + : IMPORT IDENT EQ name comment + { node (NewIdentifier ($2, $4, $5)) } + | IMPORT name comment + { node (OldIdentifier ($2, $3)) } + | IMPORT name DOT STAR comment + { node (AllIdentifiers ($2, $5)) } + ; + +constraining_clauses + : constraining_clause + { [$1] } + | constraining_clauses constraining_clause + { $2 :: $1 } + ; + +/*(2.2.3)*/ +extends_clause + : EXTENDS name class_modification_option annotation_option + { node (Extends ($2, $3, $4)) } + ; + +constraining_clause + : EXTENDS name class_modification_option comment + { node (Constraint (Extension, $2, $3, $4)) } + | RESTRICTS name class_modification_option comment + { node (Constraint (Restriction, $2, $3, $4)) } + ; + +/*(2.2.4)*/ +component_clause + : type_prefix type_specifier array_subscripts_option component_list + { node (ComponentClause ($1, $2, $3, List.rev $4)) } + ; + +type_prefix + : flow_option variability_option inout_option + { node (TypePrefix ($1, $2, $3)) } + ; + +flow_option + : + { None } + | FLOW + { Some Flow } + ; + +variability_option + : + { None } + | DISCRETE + { Some Discrete } + | PARAMETER + { Some Parameter } + | CONSTANT + { Some Constant } + ; + +inout_option + : + { None } + | INPUT + { Some Input } + | OUTPUT + { Some Output } + ; + +type_specifier + : name + { $1 } + ; + +component_list + : component_declaration + { [$1] } + | component_list CM component_declaration + { $3 :: $1 } + ; + +component_declaration + : declaration comment + { node (ComponentDeclaration ($1, $2)) } + ; + +declaration + : IDENT array_subscripts_option modification_option + { node (Declaration ($1, $2, $3)) } + ; + +modification_option + : + { None } + | modification + { Some $1 } + ; + +/*(2.2.5)*/ +modification + : class_modification EQ expression + { node (Modification ($1, Some $3)) } + | class_modification + { node (Modification ($1, None)) } + | EQ expression + { node (Eq $2) } + | COLEQ expression + { node (ColEq $2) } + ; + +class_modification + : LP RP + { node (ClassModification []) } + | LP argument_list RP + { node (ClassModification (List.rev $2)) } + | LP argument_list error + { unclosed "(" 1 ")" 3 } + | LP error + { unclosed "(" 1 ")" 2 } + ; + +argument_list + : argument + { [$1] } + | argument CM argument_list + { $1 :: $3 } + ; + +argument + : element_modification + { $1 } + | element_redeclaration + { $1 } + ; + +element_modification + : each_option final_option component_reference modification_option + string_comment + { node (ElementModification ($1, $2, $3, $4, $5)) } + ; + +each_option + : + { None } + | EACH + { Some Each } + ; + +element_redeclaration + : REDECLARE each_option final_option class_definition_or_component_clause1 + { node (ElementRedeclaration ($2, $3, $4)) } + ; + +class_definition_or_component_clause1 + : class_definition + { node (ClassDefinitionElement (None, $1, [])) } + | type_prefix type_specifier component_declaration + { let cpnt = node (ComponentClause ($1, $2, None, [$3])) in + node (ComponentClauseElement (None, cpnt, [])) } + | REPLACEABLE class_definition + { node (ClassDefinitionElement (Some Replaceable, $2, [])) } + | REPLACEABLE class_definition constraining_clauses + { node (ClassDefinitionElement (Some Replaceable, $2, List.rev $3)) } + | REPLACEABLE type_prefix type_specifier + component_declaration + { let cpnt = node (ComponentClause ($2, $3, None, [$4])) in + node (ComponentClauseElement (Some Replaceable, cpnt, [])) } + | REPLACEABLE type_prefix type_specifier + component_declaration constraining_clauses + { let cpnt = node (ComponentClause ($2, $3, None, [$4])) in + node (ComponentClauseElement (Some Replaceable, cpnt, List.rev $5)) } + ; + +/*(2.2.6)*/ +equation_clause + : INITIAL_EQUATION + { EquationClause (Some Initial, []) } + | INITIAL_EQUATION equations + { EquationClause (Some Initial, List.rev $2) } + | EQUATION + { EquationClause (None, []) } + | EQUATION equations + { EquationClause (None, List.rev $2) } ; + +equations + : equation comment SC annotation_sc_option + { [node (Equation (rhs_nodes 1 3 $1, $2, $4))] } + | equations equation comment SC annotation_sc_option + { rhs_nodes 2 5 (Equation (rhs_nodes 2 4 $2, $3, $5)) :: $1 } + ; + +algorithm_clause + : INITIAL_ALGORITHM + { AlgorithmClause (Some Initial, []) } + | INITIAL_ALGORITHM algorithms + { AlgorithmClause (Some Initial, List.rev $2) } + | ALGORITHM + { AlgorithmClause (None, []) } + | ALGORITHM algorithms + { AlgorithmClause (None, List.rev $2) } + ; + +algorithms + : algorithm comment SC annotation_sc_option + { [node (Algorithm (rhs_nodes 1 3 $1, $2, $4))] } + | algorithms algorithm comment SC annotation_sc_option + { rhs_nodes 2 5 (Algorithm (rhs_nodes 2 4 $2, $3, $5)) :: $1 } + ; + +equation + : simple_expression EQ expression + { Equal ($1, $3) } + | conditional_equation_e + { $1 } + | for_clause_e + { $1 } + | connect_clause + { $1 } + | when_clause_e + { $1 } + | component_reference LP RP + { FunctionCallE ($1, None) } + | component_reference LP function_arguments RP + { FunctionCallE ($1, Some $3) } + | component_reference LP function_arguments error + { unclosed "(" 2 ")" 4 } + | component_reference LP error + { unclosed "(" 2 ")" 3 } +; + +algorithm + : component_reference COLEQ expression + { Assign ($1, $3) } + | component_reference LP RP + { FunctionCallA ($1, None) } + | component_reference LP function_arguments RP + { FunctionCallA ($1, Some $3) } + | component_reference LP function_arguments error + { unclosed "(" 2 ")" 4 } + | component_reference LP error + { unclosed "(" 2 ")" 3 } + | LP expression_list RP COLEQ component_reference LP RP + { MultipleAssign ($2, $5, None) } + | LP RP COLEQ component_reference LP RP + { MultipleAssign ([], $4, None) } + | LP expression_list RP COLEQ component_reference LP function_arguments RP + { MultipleAssign ($2, $5, Some $7) } + | LP RP COLEQ component_reference LP function_arguments RP + { MultipleAssign ([], $4, Some $6) } + | LP expression_list RP COLEQ component_reference LP function_arguments + error + { unclosed "(" 6 ")" 8 } + | LP RP COLEQ component_reference LP function_arguments error + { unclosed "(" 5 ")" 7 } + | LP expression_list RP COLEQ component_reference LP error + { unclosed "(" 6 ")" 7 } + | LP RP COLEQ component_reference LP error + { unclosed "(" 5 ")" 6 } + | LP expression_list error + { unclosed "(" 1 ")" 3 } + | LP error + { unclosed "(" 1 ")" 2 } + | BREAK + { Break } + | RETURN + { Return } + | conditional_equation_a + { $1 } + | for_clause_a + { $1 } + | while_clause + { $1 } + | when_clause_a + { $1 } + ; + +conditional_equation_e + : IF expression THEN + equations_e + else_if_expressions_e + else_option_e + END_IF + { ConditionalEquationE (($2, List.rev $4) :: $5, $6) } + ; + +else_if_expressions_e + : + { [] } + | ELSEIF expression THEN + equations_e + else_if_expressions_e + { ($2, List.rev $4) :: $5 } + ; + +else_option_e + : + { None } + | ELSE equations_e + { Some (List.rev $2) } + ; + +equations_e + : equation SC + { [node $1] } + | equations_e equation SC + { rhs_nodes 2 3 $2 :: $1 } + ; + +conditional_equation_a + : IF expression THEN + algorithms_a + else_if_expressions_a + else_option_a + END_IF + { ConditionalEquationA (($2, List.rev $4) :: $5, $6) } + ; + +else_if_expressions_a + : + { [] } + | ELSEIF expression THEN + algorithms_a + else_if_expressions_a + { ($2, List.rev $4) :: $5 } + ; + +else_option_a + : + { None } + | ELSE algorithms_a + { Some (List.rev $2) } + ; + +algorithms_a + : algorithm SC + { [node $1] } + | algorithms_a algorithm SC + { rhs_nodes 2 3 $2 :: $1 } + ; + +for_clause_e + : FOR for_indices LOOP + equations_e + END_FOR + { ForClauseE ($2, List.rev $4) } + ; + +for_clause_a + : FOR for_indices LOOP + algorithms_a + END_FOR + { ForClauseA ($2, List.rev $4) } + ; + +for_indices + : for_index + { [$1] } + | for_index CM for_indices + { $1 :: $3 } + ; + +for_index + : IDENT + { ($1, None) } + | IDENT IN expression + { ($1, Some $3) } + ; + +while_clause + : WHILE expression LOOP + algorithms_a + END_WHILE + { WhileClause ($2, List.rev $4) } + ; + +when_clause_e + : WHEN expression THEN + equations_e + else_when_expressions_e + END_WHEN + { WhenClauseE (($2, List.rev $4) :: $5) } + ; + +when_clause_a + : WHEN expression THEN + algorithms_a + else_when_expressions_a + END_WHEN + { WhenClauseA (($2, List.rev $4) :: $5) } + ; + +else_when_expressions_e + : + { [] } + | ELSEWHEN expression THEN + equations_e + else_when_expressions_e + { ($2, List.rev $4) :: $5 } + ; + +else_when_expressions_a + : + { [] } + | ELSEWHEN expression THEN + algorithms_a + else_when_expressions_a + { ($2, List.rev $4) :: $5 } + ; + +connect_clause + : CONNECT LP component_reference CM component_reference RP + { ConnectClause ($3, $5) } + | CONNECT LP component_reference CM component_reference error + { unclosed "(" 2 ")" 6 } + ; + +/*(2.2.7)*/ +expression + : simple_expression + { $1 } + | IF expression THEN expression + elseifs_option + ELSE expression + { node (If (($2, $4) :: $5, $7)) } + ; + +elseifs_option + : + { [] } + | ELSEIF expression THEN expression + elseifs_option + { ($2, $4) :: $5 } + ; + +simple_expression + : logical_expression + { $1 } + | logical_expression CL logical_expression + { node (Range ($1, None, $3)) } + | logical_expression CL logical_expression CL logical_expression + { node (Range ($1, Some $3, $5)) } + ; + +logical_expression + : logical_term + { $1 } + | logical_expression OR logical_term + { node (BinaryOperation (rhs_nodes 2 2 Or, $1, $3)) } + ; + +logical_term + : logical_factor + { $1 } + | logical_term AND logical_factor + { node (BinaryOperation (rhs_nodes 2 2 And, $1, $3)) } + ; + +logical_factor + : relation + { $1 } + | NOT relation + { node (UnaryOperation (rhs_nodes 1 1 Not, $2)) } + ; + +relation + : arithmetic_expression + { $1 } + | arithmetic_expression LT arithmetic_expression + { node (BinaryOperation (rhs_nodes 2 2 Less, $1, $3)) } + | arithmetic_expression GT arithmetic_expression + { node (BinaryOperation (rhs_nodes 2 2 Greater, $1, $3)) } + | arithmetic_expression LE arithmetic_expression + { node (BinaryOperation (rhs_nodes 2 2 LessEqual, $1, $3)) } + | arithmetic_expression GE arithmetic_expression + { node (BinaryOperation (rhs_nodes 2 2 GreaterEqual, $1, $3)) } + | arithmetic_expression EE arithmetic_expression + { node (BinaryOperation (rhs_nodes 2 2 EqualEqual, $1, $3)) } + | arithmetic_expression NE arithmetic_expression + { node (BinaryOperation (rhs_nodes 2 2 NotEqual, $1, $3)) } + ; + +arithmetic_expression + : term + { $1 } + | arithmetic_expression PLUS term + { node (BinaryOperation (rhs_nodes 2 2 Plus, $1, $3)) } + | arithmetic_expression MINUS term + { node (BinaryOperation (rhs_nodes 2 2 Minus, $1, $3)) } + ; + +term + : unary_factor + { $1 } + | term STAR unary_factor + { node (BinaryOperation (rhs_nodes 2 2 Times, $1, $3)) } + | term SLASH unary_factor + { node (BinaryOperation (rhs_nodes 2 2 Divide, $1, $3)) } + ; + +unary_factor + : factor + { $1 } + | PLUS unary_factor + { node (UnaryOperation (rhs_nodes 1 1 UnaryPlus, $2)) } + | MINUS unary_factor + { node (UnaryOperation (rhs_nodes 1 1 UnaryMinus, $2)) } + +factor + : primary + { $1 } + | factor EXP primary + { node (BinaryOperation (rhs_nodes 2 2 Power, $1, $3)) } + ; + +primary + : UNSIGNED_INTEGER + { node (Integer $1) } + | UNSIGNED_REAL + { node (Real $1) } + | STRING + { node (String $1) } + | FALSE + { node False } + | TRUE + { node True } + | NOEVENT LP expression RP + { node (NoEvent $3) } + | component_reference + { $1 } + | component_reference LP RP + { node (FunctionCall ($1, None)) } + | component_reference LP function_arguments RP + { node (FunctionCall ($1, Some $3)) } + | component_reference LP function_arguments error + { unclosed "(" 2 ")" 4 } + | component_reference LP error + { unclosed "(" 2 ")" 3 } + | LP expression_list RP + { match $2 with + | [expr] -> node expr.Syntax.nature + | _ -> node (Tuple $2) } + | LP expression_list error + { unclosed "(" 1 ")" 3 } + | LSB expression_lists RSB + { node (MatrixConstruction $2) } + | LSB error + { invalid_matrix_construction 1 2 } + | LCB vector_elements RCB + { node (Vector $2) } + | LCB error + { invalid_literal_array_construction 1 2 } + | END + { node End } + ; + +expression_lists + : expression_list + { [$1] } + | expression_list SC expression_lists + { $1 :: $3 } + ; + +vector_elements + : expression FOR for_indices + { node (VectorReduction ($1, $3)) } + | expression_list + { node (VectorElements $1) } + ; + +name + : IDENT + { node (Identifier $1) } + | name DOT IDENT + { node (FieldAccess ($1, $3)) } + ; + +component_reference + : IDENT + { node (Identifier $1) } + | IDENT array_subscripts + { node (IndexedAccess (rhs_nodes 1 1 (Identifier $1), $2)) } + | component_reference DOT IDENT + { node (FieldAccess ($1, $3)) } + | component_reference DOT IDENT array_subscripts + { node (IndexedAccess (rhs_nodes 1 3 (FieldAccess ($1, $3)), $4)) } + ; + +function_arguments + : function_arguments_elements + { node (ArgumentList (List.rev $1)) } + | expression FOR for_indices + { node (Reduction ($1, $3)) } + ; + +function_arguments_elements + : expression + { [node (Argument $1)] } + | named_argument + { [$1] } + | function_arguments_elements CM expression + { node (Argument $3) :: $1 } + | function_arguments_elements CM named_argument + { $3 :: $1 } + ; + +named_argument + : IDENT EQ expression + { node (NamedArgument ($1, $3)) } + | FUNCTION IDENT + { failwith "Not yet implemented" } + | FUNCTION IDENT LP RP + { failwith "Not yet implemented" } + | FUNCTION IDENT LP function_arguments RP + { failwith "Not yet implemented" } + | FUNCTION IDENT LP function_arguments error + { unclosed "(" 3 ")" 5 } + | FUNCTION IDENT LP error + { unclosed "(" 3 ")" 4 } + ; + +expression_list + : expression + { [$1] } + | expression CM expression_list + { $1 :: $3 } + ; + +array_subscripts + : LSB subscripts RSB + { node (Subscripts $2) } + ; + +subscripts + : subscript + { [$1] } + | subscript CM subscripts + { $1 :: $3 } + ; + +subscript + : CL + { node Colon } + | expression + { node (Subscript $1) } + ; + +comment + : string_comment annotation_option + { node (Comment ($1, $2)) } + ; + +string_comment + : + { [] } + | strings + { List.rev $1 } + ; + +strings + : STRING + { [$1] } + | strings PLUS STRING + { $3 :: $1 } + ; + +annotation + : ANNOTATION class_modification + { node (Annotation $2) } + ; + +%% + +let parse filename token_fun lexbuf = + inputfile := filename; + try + definition token_fun lexbuf + with + | Unclosed (pos, symbol, pos', symbol') -> + raise (SyntacticError + {err_msg = ["_Unclosed"; symbol]; + err_info = []; + err_ctx = + {location = {start = pos; + enddd = pos'; + filename = filename}}}) + | Invalid_matrix (pos, pos') -> + raise (SyntacticError + {err_msg = ["_InvalidMatrixConstruct"]; + err_info = []; + err_ctx = + {location = {start = pos; + enddd = pos'; + filename = filename}}}) + | Invalid_array (pos, pos') -> + raise (SyntacticError + {err_msg = ["_InvalidArrayConstruct"]; + err_info = []; + err_ctx = + {location = {start = pos; + enddd = pos'; + filename = filename}}}) + | Parsing.Parse_error -> + raise (SyntacticError + {err_msg = ["_SyntaxError"]; + err_info = []; + err_ctx = + {location = {start = Lexing.lexeme_start lexbuf; + enddd = Lexing.lexeme_end lexbuf; + filename = filename}}}) diff --git a/scilab/modules/scicos/src/translator/parsing/syntax.ml b/scilab/modules/scicos/src/translator/parsing/syntax.ml index 39c5035..aafa593 100644 --- a/scilab/modules/scicos/src/translator/parsing/syntax.ml +++ b/scilab/modules/scicos/src/translator/parsing/syntax.ml @@ -1,646 +1,646 @@ -(* - * Translator from Modelica 2.x to flat Modelica - * - * Copyright (C) 2005 - 2007 Imagine S.A. - * For more information or commercial use please contact us at www.amesim.com - * - * This program is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. - * - *) - -(* 'info denotes the type of the information attached to the syntax nodes - (location for instance) in the parse tree *) - -type ('a, 'info) node = - { - nature: 'a; - info: 'info - } - -and 'info toplevel_element = ('info toplevel_element_desc, 'info) node - -and 'info toplevel_element_desc = - | ClassDefinitions of 'info class_definition list - | Expression of 'info expression - | VariablesDefinitions of 'info expression * 'info array_subscripts option * - 'info component_declaration list - | Command of 'info algorithm - | Within of string list - | Import of 'info import_clause - -and 'info class_definition = ('info class_definition_desc, 'info) node - -and 'info class_definition_desc = - | ClassDefinition of final option * 'info definition - -and final = Final - -and 'info definition = ('info definition_desc, 'info) node - -and 'info definition_desc = - | Definition of encapsulated option * partial option * class_kind * - 'info class_specifier - -and class_kind = - | Class - | Model - | Block - | Record - | ExpandableConnector - | Connector - | Type - | Package - | Function - -and encapsulated = Encapsulated - -and partial = Partial - -and 'info class_specifier = ('info class_specifier_desc, 'info) node - -and 'info class_specifier_desc = - | LongSpecifier of ident * string list * 'info composition - | ShortSpecifier of ident * 'info base_prefix * 'info expression * - 'info array_subscripts option * 'info class_modification option * - 'info comment - | EnumerationSpecifier of ident * 'info enumeration_composition * - 'info comment - | ExtensionSpecifier of ident * 'info class_modification option * - string list * 'info composition - -and 'info base_prefix = 'info type_prefix - -and 'info enumeration_composition = ('info enumeration_composition_desc, 'info) node - -and 'info enumeration_composition_desc = - | EnumList of 'info enumeration_literal list option - | EnumColon - -and 'info enumeration_literal = ('info enumeration_literal_desc, 'info) node - -and 'info enumeration_literal_desc = - | EnumerationLiteral of ident * 'info comment - -and 'info composition = ('info composition_desc, 'info) node - -and 'info composition_desc = - | Composition of 'info element list * 'info other_elements list * - 'info externalll option - -and 'info element = ('info element_desc, 'info) node - -and 'info element_desc = - | ClassAnnotation of 'info annotation - | ImportClause of 'info import_clause * 'info annotation option - | ExtendsClause of 'info extends_clause * 'info annotation option - | ElementDefinition of redeclare option * final option * - dynamic_scope option * 'info element_definition * - 'info annotation option - -and 'info element_definition = ('info element_definition_desc, 'info) node - -and 'info element_definition_desc = - | ClassDefinitionElement of replaceable option * 'info definition * - 'info constraining_clause list - | ComponentClauseElement of replaceable option * 'info component_clause * - 'info constraining_clause list - -and replaceable = Replaceable - -and redeclare = Redeclare - -and dynamic_scope = Inner | Outer | InnerOuter - -and 'info extends_clause = ('info extends_clause_desc, 'info) node - -and 'info extends_clause_desc = - | Extends of 'info expression * 'info class_modification option * - 'info annotation option - -and 'info constraining_clause = ('info constraining_clause_desc, 'info) node - -and 'info constraining_clause_desc = - | Constraint of constraint_kind * 'info expression * - 'info class_modification option * 'info comment - -and constraint_kind = Extension | Restriction - -and 'info other_elements = ('info other_elements_desc, 'info) node - -and 'info other_elements_desc = - | Public of 'info element list - | Protected of 'info element list - | EquationClause of initial option * 'info equation_definition list - | AlgorithmClause of initial option * 'info algorithm_definition list - -and initial = Initial - -and 'info externalll = ('info externalll_desc, 'info) node - -and 'info externalll_desc = - | External of string option * 'info external_function_call option * - 'info annotation option * 'info annotation option - -and 'info external_function_call = ('info external_function_call_desc, 'info) node - -and 'info external_function_call_desc = - | ExternalFunctionCall of 'info expression option * ident * 'info expression list - -and 'info import_clause = ('info import_clause_desc, 'info) node - -and 'info import_clause_desc = - | NewIdentifier of ident * 'info expression * 'info comment - | OldIdentifier of 'info expression * 'info comment - | AllIdentifiers of 'info expression * 'info comment - -and 'info component_clause = ('info component_clause_desc, 'info) node - -and 'info component_clause_desc = - | ComponentClause of 'info type_prefix * 'info type_specifier * - 'info array_subscripts option * 'info component_declaration list - -and 'info type_prefix = ('info type_prefix_desc, 'info) node - -and 'info type_prefix_desc = - | TypePrefix of flow option * variability option * inout option - -and flow = Flow - -and variability = Discrete | Parameter | Constant - -and inout = Input | Output - -and 'info type_specifier = 'info expression - -and 'info component_declaration = ('info component_declaration_desc, 'info) node - -and 'info component_declaration_desc = - | ComponentDeclaration of 'info declaration * 'info comment - -and 'info declaration = ('info declaration_desc, 'info) node - -and 'info declaration_desc = - | Declaration of ident * 'info array_subscripts option * - 'info modification option - -and 'info modification = ('info modification_desc, 'info) node - -and 'info modification_desc = - | Modification of 'info class_modification * 'info expression option - | Eq of 'info expression - | ColEq of 'info expression - -and 'info class_modification = ('info class_modification_desc, 'info) node - -and 'info class_modification_desc = - | ClassModification of 'info argument list - -and 'info argument = ('info argument_desc, 'info) node - -and 'info argument_desc = - | ElementModification of each option * final option * 'info expression * - 'info modification option * string list - | ElementRedeclaration of each option * final option * - 'info element_definition - -and each = Each - -and 'info equation_definition = ('info equation_definition_desc, 'info) node - -and 'info equation_definition_desc = - | Equation of 'info equation * 'info comment * 'info annotation option - -and 'info algorithm_definition = ('info algorithm_definition_desc, 'info) node - -and 'info algorithm_definition_desc = - | Algorithm of 'info algorithm * 'info comment * 'info annotation option - -and 'info equation = ('info equation_desc, 'info) node - -and 'info equation_desc = - | Equal of 'info expression * 'info expression - | ConditionalEquationE of ('info expression * 'info equation list) list * - 'info equation list option - | ForClauseE of 'info for_indices * 'info equation list - | ConnectClause of 'info expression * 'info expression - | WhenClauseE of ('info expression * 'info equation list) list - | FunctionCallE of 'info expression * 'info function_arguments option - -and 'info algorithm = ('info algorithm_desc, 'info) node - -and 'info algorithm_desc = - | Assign of 'info expression * 'info expression - | FunctionCallA of 'info expression * 'info function_arguments option - | MultipleAssign of 'info expression list * 'info expression * - 'info function_arguments option - | Break - | Return - | ConditionalEquationA of ('info expression * 'info algorithm list) list * - 'info algorithm list option - | ForClauseA of 'info for_indices * 'info algorithm list - | WhileClause of 'info expression * 'info algorithm list - | WhenClauseA of ('info expression * 'info algorithm list) list - -and 'info for_indices = (ident * 'info expression option) list - -and 'info expression = ('info expression_desc, 'info) node - -and 'info expression_desc = - | BinaryOperation of 'info binary_operator_kind * 'info expression * 'info expression - | End - | False - | FieldAccess of 'info expression * ident - | FunctionCall of 'info expression * 'info function_arguments option - | Identifier of string - | If of ('info expression * 'info expression) list * 'info expression - | IndexedAccess of 'info expression * 'info array_subscripts - | Integer of string - | MatrixConstruction of 'info expression list list - | NoEvent of 'info expression - | Range of 'info expression * 'info expression option * 'info expression - | Real of string - | String of string - | True - | Tuple of 'info expression list - | UnaryOperation of 'info unary_operator_kind * 'info expression - | Vector of 'info vector_elements - -and 'info unary_operator_kind = ('info unary_operator_kind_desc, 'info) node - -and 'info unary_operator_kind_desc = - | UnaryMinus - | Not - | UnaryPlus - -and 'info binary_operator_kind = ('info binary_operator_kind_desc, 'info) node - -and 'info binary_operator_kind_desc = - | Plus - | And - | Divide - | EqualEqual - | GreaterEqual - | Greater - | LessEqual - | Less - | Times - | NotEqual - | Or - | Power - | Minus - -and 'info vector_elements = ('info vector_elements_desc, 'info) node - -and 'info vector_elements_desc = - | VectorReduction of 'info expression * 'info for_indices - | VectorElements of 'info expression list - -and ident = string - -and 'info function_arguments = ('info function_arguments_desc, 'info) node - -and 'info function_arguments_desc = - | Reduction of 'info expression * 'info for_indices - | ArgumentList of 'info function_arguments_element list - -and 'info function_arguments_element = ('info function_arguments_element_desc, 'info) node - -and 'info function_arguments_element_desc = - | Argument of 'info expression - | NamedArgument of ident * 'info expression - -and 'info array_subscripts = ('info array_subscripts_desc, 'info) node - -and 'info array_subscripts_desc = - | Subscripts of 'info array_subscript list - -and 'info array_subscript = ('info array_subscript_desc, 'info) node - -and 'info array_subscript_desc = - | Colon - | Subscript of 'info expression - -and 'info comment = ('info comment_desc, 'info) node - -and 'info comment_desc = - | Comment of string list * 'info annotation option - -and 'info annotation = ('info annotation_desc, 'info) node - -and 'info annotation_desc = - | Annotation of 'info class_modification - -(* Conversion of elements to string, used for error information display *) - -let rec string_of_expression expr = - string_of_subexpression None expr - -and string_of_subexpression expr_option subexpr = - let string_of_subexpression' = - match subexpr.nature with - | BinaryOperation (kind, arg1, arg2) -> - string_of_binOper subexpr kind arg1 arg2 - | End -> "end" - | False -> "false" - | FieldAccess (expr, id) -> - (string_of_expression expr) ^ "." ^ id - | FunctionCall (expr, fun_args) -> - string_of_function_call expr fun_args - | Identifier id -> id - | If (alts, expr) -> string_of_if expr_option alts expr - | IndexedAccess (expr, subs) -> string_of_indexedAccess expr subs - | Integer s -> s - | MatrixConstruction exprss -> string_of_matrix exprss - | NoEvent expr -> "noEvent(" ^ (string_of_expression expr) ^ ")" - | Range (start, step, stop) -> string_of_range start step stop - | Real s -> s - | String s -> "\"" ^ s ^ "\"" - | True -> "true" - | Tuple exprs -> string_of_tuple exprs - | UnaryOperation (kind, arg) -> - string_of_unOper subexpr kind arg - | Vector vec_elts -> string_of_vector vec_elts in - parenthesize expr_option string_of_subexpression' subexpr - -and parenthesize expr_option s subexpr = - let add_parenthesis = - "(" ^ s ^ ")" in - let parenthesize_un_bin_Oper kind kind' = - match kind.nature, kind'.nature with - | (UnaryMinus | UnaryPlus), - (Plus | Minus) -> - add_parenthesis - | Not, _ -> - add_parenthesis - | _, _ -> s in - let parenthesize_bin_bin_Oper kind kind' = - match kind.nature, kind'.nature with - | Divide, - (Plus | Minus | Times) -> - add_parenthesis - | Times, - (Plus | Minus | Divide) -> - add_parenthesis - | Power, _ -> - add_parenthesis - | ( EqualEqual | GreaterEqual | Greater | - LessEqual | Less | NotEqual | And | - Or), - ( EqualEqual | GreaterEqual | Greater | - LessEqual | Less | NotEqual) -> - add_parenthesis - | And, Or -> add_parenthesis - | Or, And -> add_parenthesis - | _, _ -> s in - let parenthesize' expr = - match expr.nature, subexpr.nature with - | BinaryOperation (kind, _, _), - BinaryOperation (kind', _, _) -> - parenthesize_bin_bin_Oper kind kind' - | UnaryOperation (kind, _), - BinaryOperation (kind', _, _) -> - parenthesize_un_bin_Oper kind kind' - | ( BinaryOperation (_, _, _) | - UnaryOperation (_, _) ), - UnaryOperation (_, _) -> - add_parenthesis - | _, _ -> s in - match expr_option with - | None -> s - | Some expr -> parenthesize' expr - -and string_of_binOperKind kind = - match kind.nature with - | Plus -> " + " - | And -> " and " - | Divide -> " / " - | EqualEqual -> " == " - | GreaterEqual -> " >= " - | Greater -> " > " - | LessEqual -> " <= " - | Less -> " < " - | Times -> " * " - | NotEqual -> " <> " - | Or -> " or " - | Power -> " ^ " - | Minus -> " - " - -and string_of_binOper expr kind arg1 arg2 = - (string_of_subexpression (Some expr) arg1) ^ - (string_of_binOperKind kind) ^ - (string_of_subexpression (Some expr) arg2) - -and string_of_range start step stop = - let sstep = match step with - | None -> ":" - | Some step -> ":" ^ (string_of_expression step) ^ ":" in - (string_of_expression start) ^ sstep ^ (string_of_expression stop) - -and string_of_unOperKind kind = - match kind.nature with - | UnaryMinus -> "- " - | Not -> "not " - | UnaryPlus -> "+ " - -and string_of_unOper expr kind arg = - (string_of_unOperKind kind) ^ - (string_of_subexpression (Some expr) arg) - -and string_of_tuple exprs = - let rec string_of_tuple' exprs = - match exprs with - | [] -> "" - | [expr] -> string_of_expression expr - | expr :: exprs -> - (string_of_expression expr) ^ ", " ^ (string_of_tuple' exprs) in - "(" ^ (string_of_tuple' exprs) ^ ")" - -and string_of_if expr_option alts expr = - let add_parenthesis s = - "(" ^ s ^ ")" in - let rec string_of_alts alts = match alts with - | [] -> "" - | (cond, expr) :: alts -> - "if (" ^ (string_of_expression cond) ^ ") then (" ^ - (string_of_expression expr) ^ ") else" ^ - (string_of_alts alts) in - let string_of_if' = - (string_of_alts alts) ^ " " ^ - (add_parenthesis (string_of_expression expr)) in - match expr_option with - | None -> string_of_if' - | Some _ -> add_parenthesis string_of_if' - -and string_of_for_inds for_inds = - let string_of_for_ind for_ind = match for_ind with - | id, None -> id - | id, Some expr -> id ^ " in " ^ string_of_expression expr in - let rec string_of_for_inds' for_inds = match for_inds with - | [] -> "" - | [for_ind] -> string_of_for_ind for_ind - | for_ind :: for_inds -> - (string_of_for_ind for_ind) ^ ", " ^ (string_of_for_inds' for_inds) in - "for " ^ (string_of_for_inds' for_inds) - -and string_of_function_call expr fun_args = - let string_of_arg arg = match arg.nature with - | Argument expr -> string_of_expression expr - | NamedArgument (id, expr) -> - id ^ " = " ^ (string_of_expression expr) in - let rec string_of_args args = match args with - | [] -> "" - | [arg] -> string_of_arg arg - | arg :: args -> (string_of_arg arg) ^ ", " ^ (string_of_args args) in - let string_of_fun_args fun_args = match fun_args.nature with - | ArgumentList args -> string_of_args args - | Reduction (expr, for_inds) when for_inds = [] -> - string_of_expression expr - | Reduction (expr, for_inds) -> - (string_of_expression expr) ^ " " ^ - (string_of_for_inds for_inds) in - let string_of_fun_args_option fun_args = match fun_args with - | None -> "" - | Some fun_args -> string_of_fun_args fun_args in - (string_of_expression expr) ^ - "(" ^ (string_of_fun_args_option fun_args) ^ ")" - -and string_of_indexedAccess expr subs = - let string_of_sub sub = match sub.nature with - | Colon -> " : " - | Subscript expr -> string_of_expression expr in - let rec string_of_subs subs = match subs with - | [] -> "" - | [sub] -> string_of_sub sub - | sub :: subs -> - (string_of_sub sub) ^ ", " ^ string_of_subs subs in - match subs.nature with - | Subscripts subs -> - (string_of_expression expr) ^ "[" ^ (string_of_subs subs) ^ "]" - -and string_of_vectorElements exprs = match exprs with - | [] -> "" - | [expr] -> string_of_expression expr - | expr :: exprs -> - (string_of_expression expr) ^ ", " ^ - (string_of_vectorElements exprs) - -and string_of_vector vec_elts = - let string_of_vector' = match vec_elts.nature with - | VectorReduction (expr, for_inds) -> - "{" ^ (string_of_expression expr) ^ " " ^ - (string_of_for_inds for_inds) ^ "}" - | VectorElements exprs -> - "{" ^ string_of_vectorElements exprs ^ "}" in - string_of_vector' - -and string_of_matrix exprss = - let rec string_of_matrix' exprss = match exprss with - | [] -> "" - | [exprs] -> string_of_vectorElements exprs - | exprs :: exprss -> - (string_of_vectorElements exprs) ^ "; " ^ - (string_of_matrix' exprss) in - "[" ^ (string_of_matrix' exprss) ^ "]" - -let string_of_classDefinitions cl_defs = "" - -let string_of_within path = - let rec string_of_path path = match path with - | [] -> "" - | [s] -> s - | s :: path -> s ^ "." ^ (string_of_path path) in - "within " ^ (string_of_path path) ^ ";" - -let string_of_import imprt = - let string_of_import' = match imprt.nature with - | NewIdentifier (id, expr, _) -> - id ^ " = " ^ (string_of_expression expr) - | OldIdentifier (expr, _) -> - string_of_expression expr - | AllIdentifiers (expr, _) -> - (string_of_expression expr) ^ ".*" in - "import " ^ string_of_import' ^ ";" - -let string_of_MultipleAssign exprs expr func_args = - let rec string_of_LHS exprs = match exprs with - | [] -> "" - | [expr] -> string_of_expression expr - | expr :: exprs -> - (string_of_expression expr) ^ ", " ^ (string_of_LHS exprs) in - (string_of_LHS exprs) ^ " := " ^ (string_of_function_call expr func_args) - -let string_of_for_clause for_inds algos = - (string_of_for_inds for_inds) ^ " loop ... end for" - -let string_of_while_clause expr algos = - "while " ^ (string_of_expression expr) ^ " loop ... end while" - -let string_of_when_clause alts = match alts with - | [] -> "" - | (expr, algos) :: alts -> - "when " ^ (string_of_expression expr) ^ " then ... end when" - -let string_of_if_cond cond = - "if (" ^ (string_of_expression cond) ^ ") then ... end if" - -let string_of_conditional_equ alts algos = match alts with - | [] -> "" - | (expr, algos) :: alts -> string_of_if_cond expr - -let string_of_algo algo = match algo.nature with - | Assign (expr, expr') -> - (string_of_expression expr) ^ " := " ^ (string_of_expression expr') - | FunctionCallA (expr, func_args) -> - string_of_function_call expr func_args - | MultipleAssign (exprs, expr, func_args) -> - string_of_MultipleAssign exprs expr func_args - | Break -> "break" - | Return -> "return" - | ConditionalEquationA (alts, algos) -> - string_of_conditional_equ alts algos - | ForClauseA (for_inds, algos) -> - string_of_for_clause for_inds algos - | WhileClause (expr, algos) -> - string_of_while_clause expr algos - | WhenClauseA alts -> - string_of_when_clause alts - -let string_of_toplevel_element node = match node.nature with - | ClassDefinitions cl_defs -> string_of_classDefinitions cl_defs - | Expression expr -> string_of_expression expr - | VariablesDefinitions (expr, subs, cpnt_decls) -> - string_of_expression expr - | Command algo -> string_of_algo algo - | Within path -> string_of_within path - | Import imprt -> string_of_import imprt - -let string_of_base_prefix base_pref = - let string_of_flow flow_option = match flow_option with - | None -> "" - | Some _ -> "flow " in - let string_of_var var_option = match var_option with - | None -> "" - | Some Discrete -> "discrete " - | Some Parameter -> "parameter " - | Some Constant -> "constant " in - let string_of_inout inout_option = match inout_option with - | None -> "" - | Some Input -> "input " - | Some Output -> "output " in - match base_pref.nature with - | TypePrefix (flow_option, var_option, inout_option) -> - (string_of_flow flow_option) ^ - (string_of_var var_option) ^ - (string_of_inout inout_option) +(* + * Translator from Modelica 2.x to flat Modelica + * + * Copyright (C) 2005 - 2007 Imagine S.A. + * For more information or commercial use please contact us at www.amesim.com + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. + * + *) + +(* 'info denotes the type of the information attached to the syntax nodes + (location for instance) in the parse tree *) + +type ('a, 'info) node = + { + nature: 'a; + info: 'info + } + +and 'info toplevel_element = ('info toplevel_element_desc, 'info) node + +and 'info toplevel_element_desc = + | ClassDefinitions of 'info class_definition list + | Expression of 'info expression + | VariablesDefinitions of 'info expression * 'info array_subscripts option * + 'info component_declaration list + | Command of 'info algorithm + | Within of string list + | Import of 'info import_clause + +and 'info class_definition = ('info class_definition_desc, 'info) node + +and 'info class_definition_desc = + | ClassDefinition of final option * 'info definition + +and final = Final + +and 'info definition = ('info definition_desc, 'info) node + +and 'info definition_desc = + | Definition of encapsulated option * partial option * class_kind * + 'info class_specifier + +and class_kind = + | Class + | Model + | Block + | Record + | ExpandableConnector + | Connector + | Type + | Package + | Function + +and encapsulated = Encapsulated + +and partial = Partial + +and 'info class_specifier = ('info class_specifier_desc, 'info) node + +and 'info class_specifier_desc = + | LongSpecifier of ident * string list * 'info composition + | ShortSpecifier of ident * 'info base_prefix * 'info expression * + 'info array_subscripts option * 'info class_modification option * + 'info comment + | EnumerationSpecifier of ident * 'info enumeration_composition * + 'info comment + | ExtensionSpecifier of ident * 'info class_modification option * + string list * 'info composition + +and 'info base_prefix = 'info type_prefix + +and 'info enumeration_composition = ('info enumeration_composition_desc, 'info) node + +and 'info enumeration_composition_desc = + | EnumList of 'info enumeration_literal list option + | EnumColon + +and 'info enumeration_literal = ('info enumeration_literal_desc, 'info) node + +and 'info enumeration_literal_desc = + | EnumerationLiteral of ident * 'info comment + +and 'info composition = ('info composition_desc, 'info) node + +and 'info composition_desc = + | Composition of 'info element list * 'info other_elements list * + 'info externalll option + +and 'info element = ('info element_desc, 'info) node + +and 'info element_desc = + | ClassAnnotation of 'info annotation + | ImportClause of 'info import_clause * 'info annotation option + | ExtendsClause of 'info extends_clause * 'info annotation option + | ElementDefinition of redeclare option * final option * + dynamic_scope option * 'info element_definition * + 'info annotation option + +and 'info element_definition = ('info element_definition_desc, 'info) node + +and 'info element_definition_desc = + | ClassDefinitionElement of replaceable option * 'info definition * + 'info constraining_clause list + | ComponentClauseElement of replaceable option * 'info component_clause * + 'info constraining_clause list + +and replaceable = Replaceable + +and redeclare = Redeclare + +and dynamic_scope = Inner | Outer | InnerOuter + +and 'info extends_clause = ('info extends_clause_desc, 'info) node + +and 'info extends_clause_desc = + | Extends of 'info expression * 'info class_modification option * + 'info annotation option + +and 'info constraining_clause = ('info constraining_clause_desc, 'info) node + +and 'info constraining_clause_desc = + | Constraint of constraint_kind * 'info expression * + 'info class_modification option * 'info comment + +and constraint_kind = Extension | Restriction + +and 'info other_elements = ('info other_elements_desc, 'info) node + +and 'info other_elements_desc = + | Public of 'info element list + | Protected of 'info element list + | EquationClause of initial option * 'info equation_definition list + | AlgorithmClause of initial option * 'info algorithm_definition list + +and initial = Initial + +and 'info externalll = ('info externalll_desc, 'info) node + +and 'info externalll_desc = + | External of string option * 'info external_function_call option * + 'info annotation option * 'info annotation option + +and 'info external_function_call = ('info external_function_call_desc, 'info) node + +and 'info external_function_call_desc = + | ExternalFunctionCall of 'info expression option * ident * 'info expression list + +and 'info import_clause = ('info import_clause_desc, 'info) node + +and 'info import_clause_desc = + | NewIdentifier of ident * 'info expression * 'info comment + | OldIdentifier of 'info expression * 'info comment + | AllIdentifiers of 'info expression * 'info comment + +and 'info component_clause = ('info component_clause_desc, 'info) node + +and 'info component_clause_desc = + | ComponentClause of 'info type_prefix * 'info type_specifier * + 'info array_subscripts option * 'info component_declaration list + +and 'info type_prefix = ('info type_prefix_desc, 'info) node + +and 'info type_prefix_desc = + | TypePrefix of flow option * variability option * inout option + +and flow = Flow + +and variability = Discrete | Parameter | Constant + +and inout = Input | Output + +and 'info type_specifier = 'info expression + +and 'info component_declaration = ('info component_declaration_desc, 'info) node + +and 'info component_declaration_desc = + | ComponentDeclaration of 'info declaration * 'info comment + +and 'info declaration = ('info declaration_desc, 'info) node + +and 'info declaration_desc = + | Declaration of ident * 'info array_subscripts option * + 'info modification option + +and 'info modification = ('info modification_desc, 'info) node + +and 'info modification_desc = + | Modification of 'info class_modification * 'info expression option + | Eq of 'info expression + | ColEq of 'info expression + +and 'info class_modification = ('info class_modification_desc, 'info) node + +and 'info class_modification_desc = + | ClassModification of 'info argument list + +and 'info argument = ('info argument_desc, 'info) node + +and 'info argument_desc = + | ElementModification of each option * final option * 'info expression * + 'info modification option * string list + | ElementRedeclaration of each option * final option * + 'info element_definition + +and each = Each + +and 'info equation_definition = ('info equation_definition_desc, 'info) node + +and 'info equation_definition_desc = + | Equation of 'info equation * 'info comment * 'info annotation option + +and 'info algorithm_definition = ('info algorithm_definition_desc, 'info) node + +and 'info algorithm_definition_desc = + | Algorithm of 'info algorithm * 'info comment * 'info annotation option + +and 'info equation = ('info equation_desc, 'info) node + +and 'info equation_desc = + | Equal of 'info expression * 'info expression + | ConditionalEquationE of ('info expression * 'info equation list) list * + 'info equation list option + | ForClauseE of 'info for_indices * 'info equation list + | ConnectClause of 'info expression * 'info expression + | WhenClauseE of ('info expression * 'info equation list) list + | FunctionCallE of 'info expression * 'info function_arguments option + +and 'info algorithm = ('info algorithm_desc, 'info) node + +and 'info algorithm_desc = + | Assign of 'info expression * 'info expression + | FunctionCallA of 'info expression * 'info function_arguments option + | MultipleAssign of 'info expression list * 'info expression * + 'info function_arguments option + | Break + | Return + | ConditionalEquationA of ('info expression * 'info algorithm list) list * + 'info algorithm list option + | ForClauseA of 'info for_indices * 'info algorithm list + | WhileClause of 'info expression * 'info algorithm list + | WhenClauseA of ('info expression * 'info algorithm list) list + +and 'info for_indices = (ident * 'info expression option) list + +and 'info expression = ('info expression_desc, 'info) node + +and 'info expression_desc = + | BinaryOperation of 'info binary_operator_kind * 'info expression * 'info expression + | End + | False + | FieldAccess of 'info expression * ident + | FunctionCall of 'info expression * 'info function_arguments option + | Identifier of string + | If of ('info expression * 'info expression) list * 'info expression + | IndexedAccess of 'info expression * 'info array_subscripts + | Integer of string + | MatrixConstruction of 'info expression list list + | NoEvent of 'info expression + | Range of 'info expression * 'info expression option * 'info expression + | Real of string + | String of string + | True + | Tuple of 'info expression list + | UnaryOperation of 'info unary_operator_kind * 'info expression + | Vector of 'info vector_elements + +and 'info unary_operator_kind = ('info unary_operator_kind_desc, 'info) node + +and 'info unary_operator_kind_desc = + | UnaryMinus + | Not + | UnaryPlus + +and 'info binary_operator_kind = ('info binary_operator_kind_desc, 'info) node + +and 'info binary_operator_kind_desc = + | Plus + | And + | Divide + | EqualEqual + | GreaterEqual + | Greater + | LessEqual + | Less + | Times + | NotEqual + | Or + | Power + | Minus + +and 'info vector_elements = ('info vector_elements_desc, 'info) node + +and 'info vector_elements_desc = + | VectorReduction of 'info expression * 'info for_indices + | VectorElements of 'info expression list + +and ident = string + +and 'info function_arguments = ('info function_arguments_desc, 'info) node + +and 'info function_arguments_desc = + | Reduction of 'info expression * 'info for_indices + | ArgumentList of 'info function_arguments_element list + +and 'info function_arguments_element = ('info function_arguments_element_desc, 'info) node + +and 'info function_arguments_element_desc = + | Argument of 'info expression + | NamedArgument of ident * 'info expression + +and 'info array_subscripts = ('info array_subscripts_desc, 'info) node + +and 'info array_subscripts_desc = + | Subscripts of 'info array_subscript list + +and 'info array_subscript = ('info array_subscript_desc, 'info) node + +and 'info array_subscript_desc = + | Colon + | Subscript of 'info expression + +and 'info comment = ('info comment_desc, 'info) node + +and 'info comment_desc = + | Comment of string list * 'info annotation option + +and 'info annotation = ('info annotation_desc, 'info) node + +and 'info annotation_desc = + | Annotation of 'info class_modification + +(* Conversion of elements to string, used for error information display *) + +let rec string_of_expression expr = + string_of_subexpression None expr + +and string_of_subexpression expr_option subexpr = + let string_of_subexpression' = + match subexpr.nature with + | BinaryOperation (kind, arg1, arg2) -> + string_of_binOper subexpr kind arg1 arg2 + | End -> "end" + | False -> "false" + | FieldAccess (expr, id) -> + (string_of_expression expr) ^ "." ^ id + | FunctionCall (expr, fun_args) -> + string_of_function_call expr fun_args + | Identifier id -> id + | If (alts, expr) -> string_of_if expr_option alts expr + | IndexedAccess (expr, subs) -> string_of_indexedAccess expr subs + | Integer s -> s + | MatrixConstruction exprss -> string_of_matrix exprss + | NoEvent expr -> "noEvent(" ^ (string_of_expression expr) ^ ")" + | Range (start, step, stop) -> string_of_range start step stop + | Real s -> s + | String s -> "\"" ^ s ^ "\"" + | True -> "true" + | Tuple exprs -> string_of_tuple exprs + | UnaryOperation (kind, arg) -> + string_of_unOper subexpr kind arg + | Vector vec_elts -> string_of_vector vec_elts in + parenthesize expr_option string_of_subexpression' subexpr + +and parenthesize expr_option s subexpr = + let add_parenthesis = + "(" ^ s ^ ")" in + let parenthesize_un_bin_Oper kind kind' = + match kind.nature, kind'.nature with + | (UnaryMinus | UnaryPlus), + (Plus | Minus) -> + add_parenthesis + | Not, _ -> + add_parenthesis + | _, _ -> s in + let parenthesize_bin_bin_Oper kind kind' = + match kind.nature, kind'.nature with + | Divide, + (Plus | Minus | Times) -> + add_parenthesis + | Times, + (Plus | Minus | Divide) -> + add_parenthesis + | Power, _ -> + add_parenthesis + | ( EqualEqual | GreaterEqual | Greater | + LessEqual | Less | NotEqual | And | + Or), + ( EqualEqual | GreaterEqual | Greater | + LessEqual | Less | NotEqual) -> + add_parenthesis + | And, Or -> add_parenthesis + | Or, And -> add_parenthesis + | _, _ -> s in + let parenthesize' expr = + match expr.nature, subexpr.nature with + | BinaryOperation (kind, _, _), + BinaryOperation (kind', _, _) -> + parenthesize_bin_bin_Oper kind kind' + | UnaryOperation (kind, _), + BinaryOperation (kind', _, _) -> + parenthesize_un_bin_Oper kind kind' + | ( BinaryOperation (_, _, _) | + UnaryOperation (_, _) ), + UnaryOperation (_, _) -> + add_parenthesis + | _, _ -> s in + match expr_option with + | None -> s + | Some expr -> parenthesize' expr + +and string_of_binOperKind kind = + match kind.nature with + | Plus -> " + " + | And -> " and " + | Divide -> " / " + | EqualEqual -> " == " + | GreaterEqual -> " >= " + | Greater -> " > " + | LessEqual -> " <= " + | Less -> " < " + | Times -> " * " + | NotEqual -> " <> " + | Or -> " or " + | Power -> " ^ " + | Minus -> " - " + +and string_of_binOper expr kind arg1 arg2 = + (string_of_subexpression (Some expr) arg1) ^ + (string_of_binOperKind kind) ^ + (string_of_subexpression (Some expr) arg2) + +and string_of_range start step stop = + let sstep = match step with + | None -> ":" + | Some step -> ":" ^ (string_of_expression step) ^ ":" in + (string_of_expression start) ^ sstep ^ (string_of_expression stop) + +and string_of_unOperKind kind = + match kind.nature with + | UnaryMinus -> "- " + | Not -> "not " + | UnaryPlus -> "+ " + +and string_of_unOper expr kind arg = + (string_of_unOperKind kind) ^ + (string_of_subexpression (Some expr) arg) + +and string_of_tuple exprs = + let rec string_of_tuple' exprs = + match exprs with + | [] -> "" + | [expr] -> string_of_expression expr + | expr :: exprs -> + (string_of_expression expr) ^ ", " ^ (string_of_tuple' exprs) in + "(" ^ (string_of_tuple' exprs) ^ ")" + +and string_of_if expr_option alts expr = + let add_parenthesis s = + "(" ^ s ^ ")" in + let rec string_of_alts alts = match alts with + | [] -> "" + | (cond, expr) :: alts -> + "if (" ^ (string_of_expression cond) ^ ") then (" ^ + (string_of_expression expr) ^ ") else" ^ + (string_of_alts alts) in + let string_of_if' = + (string_of_alts alts) ^ " " ^ + (add_parenthesis (string_of_expression expr)) in + match expr_option with + | None -> string_of_if' + | Some _ -> add_parenthesis string_of_if' + +and string_of_for_inds for_inds = + let string_of_for_ind for_ind = match for_ind with + | id, None -> id + | id, Some expr -> id ^ " in " ^ string_of_expression expr in + let rec string_of_for_inds' for_inds = match for_inds with + | [] -> "" + | [for_ind] -> string_of_for_ind for_ind + | for_ind :: for_inds -> + (string_of_for_ind for_ind) ^ ", " ^ (string_of_for_inds' for_inds) in + "for " ^ (string_of_for_inds' for_inds) + +and string_of_function_call expr fun_args = + let string_of_arg arg = match arg.nature with + | Argument expr -> string_of_expression expr + | NamedArgument (id, expr) -> + id ^ " = " ^ (string_of_expression expr) in + let rec string_of_args args = match args with + | [] -> "" + | [arg] -> string_of_arg arg + | arg :: args -> (string_of_arg arg) ^ ", " ^ (string_of_args args) in + let string_of_fun_args fun_args = match fun_args.nature with + | ArgumentList args -> string_of_args args + | Reduction (expr, for_inds) when for_inds = [] -> + string_of_expression expr + | Reduction (expr, for_inds) -> + (string_of_expression expr) ^ " " ^ + (string_of_for_inds for_inds) in + let string_of_fun_args_option fun_args = match fun_args with + | None -> "" + | Some fun_args -> string_of_fun_args fun_args in + (string_of_expression expr) ^ + "(" ^ (string_of_fun_args_option fun_args) ^ ")" + +and string_of_indexedAccess expr subs = + let string_of_sub sub = match sub.nature with + | Colon -> " : " + | Subscript expr -> string_of_expression expr in + let rec string_of_subs subs = match subs with + | [] -> "" + | [sub] -> string_of_sub sub + | sub :: subs -> + (string_of_sub sub) ^ ", " ^ string_of_subs subs in + match subs.nature with + | Subscripts subs -> + (string_of_expression expr) ^ "[" ^ (string_of_subs subs) ^ "]" + +and string_of_vectorElements exprs = match exprs with + | [] -> "" + | [expr] -> string_of_expression expr + | expr :: exprs -> + (string_of_expression expr) ^ ", " ^ + (string_of_vectorElements exprs) + +and string_of_vector vec_elts = + let string_of_vector' = match vec_elts.nature with + | VectorReduction (expr, for_inds) -> + "{" ^ (string_of_expression expr) ^ " " ^ + (string_of_for_inds for_inds) ^ "}" + | VectorElements exprs -> + "{" ^ string_of_vectorElements exprs ^ "}" in + string_of_vector' + +and string_of_matrix exprss = + let rec string_of_matrix' exprss = match exprss with + | [] -> "" + | [exprs] -> string_of_vectorElements exprs + | exprs :: exprss -> + (string_of_vectorElements exprs) ^ "; " ^ + (string_of_matrix' exprss) in + "[" ^ (string_of_matrix' exprss) ^ "]" + +let string_of_classDefinitions cl_defs = "" + +let string_of_within path = + let rec string_of_path path = match path with + | [] -> "" + | [s] -> s + | s :: path -> s ^ "." ^ (string_of_path path) in + "within " ^ (string_of_path path) ^ ";" + +let string_of_import imprt = + let string_of_import' = match imprt.nature with + | NewIdentifier (id, expr, _) -> + id ^ " = " ^ (string_of_expression expr) + | OldIdentifier (expr, _) -> + string_of_expression expr + | AllIdentifiers (expr, _) -> + (string_of_expression expr) ^ ".*" in + "import " ^ string_of_import' ^ ";" + +let string_of_MultipleAssign exprs expr func_args = + let rec string_of_LHS exprs = match exprs with + | [] -> "" + | [expr] -> string_of_expression expr + | expr :: exprs -> + (string_of_expression expr) ^ ", " ^ (string_of_LHS exprs) in + (string_of_LHS exprs) ^ " := " ^ (string_of_function_call expr func_args) + +let string_of_for_clause for_inds algos = + (string_of_for_inds for_inds) ^ " loop ... end for" + +let string_of_while_clause expr algos = + "while " ^ (string_of_expression expr) ^ " loop ... end while" + +let string_of_when_clause alts = match alts with + | [] -> "" + | (expr, algos) :: alts -> + "when " ^ (string_of_expression expr) ^ " then ... end when" + +let string_of_if_cond cond = + "if (" ^ (string_of_expression cond) ^ ") then ... end if" + +let string_of_conditional_equ alts algos = match alts with + | [] -> "" + | (expr, algos) :: alts -> string_of_if_cond expr + +let string_of_algo algo = match algo.nature with + | Assign (expr, expr') -> + (string_of_expression expr) ^ " := " ^ (string_of_expression expr') + | FunctionCallA (expr, func_args) -> + string_of_function_call expr func_args + | MultipleAssign (exprs, expr, func_args) -> + string_of_MultipleAssign exprs expr func_args + | Break -> "break" + | Return -> "return" + | ConditionalEquationA (alts, algos) -> + string_of_conditional_equ alts algos + | ForClauseA (for_inds, algos) -> + string_of_for_clause for_inds algos + | WhileClause (expr, algos) -> + string_of_while_clause expr algos + | WhenClauseA alts -> + string_of_when_clause alts + +let string_of_toplevel_element node = match node.nature with + | ClassDefinitions cl_defs -> string_of_classDefinitions cl_defs + | Expression expr -> string_of_expression expr + | VariablesDefinitions (expr, subs, cpnt_decls) -> + string_of_expression expr + | Command algo -> string_of_algo algo + | Within path -> string_of_within path + | Import imprt -> string_of_import imprt + +let string_of_base_prefix base_pref = + let string_of_flow flow_option = match flow_option with + | None -> "" + | Some _ -> "flow " in + let string_of_var var_option = match var_option with + | None -> "" + | Some Discrete -> "discrete " + | Some Parameter -> "parameter " + | Some Constant -> "constant " in + let string_of_inout inout_option = match inout_option with + | None -> "" + | Some Input -> "input " + | Some Output -> "output " in + match base_pref.nature with + | TypePrefix (flow_option, var_option, inout_option) -> + (string_of_flow flow_option) ^ + (string_of_var var_option) ^ + (string_of_inout inout_option) diff --git a/scilab/modules/scicos/src/translator/translation/codeGeneration.ml b/scilab/modules/scicos/src/translator/translation/codeGeneration.ml index d3849f6..0c994df 100644 --- a/scilab/modules/scicos/src/translator/translation/codeGeneration.ml +++ b/scilab/modules/scicos/src/translator/translation/codeGeneration.ml @@ -1,1355 +1,1355 @@ -(* - * Translator from Modelica 2.x to flat Modelica - * - * Copyright (C) 2005 - 2007 Imagine S.A. - * For more information or commercial use please contact us at www.amesim.com - * - * This program is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. - * - *) - -(** The main functions are: -{ul -{- [ generate_code ]: main function - {ul - {- [ collect_function_definitions ]: Collect function definitions } - {- [ generate_component_description ]: Generate component descriptions - {ul - {- [ collect_component_elements ]: Returns a [ flat_instance ] containing all variables and equations - {ul - {- [ expand_equations ]: Generation of connect equations } - {- [ introduce_derivative_variables ]: Introduce derivative variables} - } - } - {- [ generate_dynamic_description ]: Generate the dynamic Model description - {ul - {- [ generate_flatten_instance ]: Dynamic model description as flat Modelica } - {- [ generate_flatten_XML ]: if the "-xml" option is activated } - } - } - {- [ generate_function_definitions ]: Generate function definitions in a file named filename_functions.mo } - {- [ generate_initial_description ]: Generate initialization description in a file named filename_init.xml, - and abstract relations in a file named filename_relations.xml. - {ul - {- [ generate_flatten_XML ]: Generates an XML description of initialization problem } - {- [ generate_relations ]: Generates an XML description of abstract relations and other informations } - } - } - } - } - } -} -}*) - -open ErrorDico (* To have access to GenericError *) - -type flat_instance = - { - variables: Instantiation.component_description list; - dynamic_equations: Instantiation.equation_desc list; - initial_equations: Instantiation.equation_desc list; - abstract_relations: abstract_relation list - } - -and function_description = - { - inputs: (string * Types.class_specifier) list; - outputs: (string * Types.class_specifier) list - } - -and abstract_relation = - | Rel of Instantiation.component_description list - -and 'a tree = Leaf of (string * 'a) | Node of string * 'a tree list - -and element = - { - kind: element_kind; - id: string; - comment: string; - initial_value: Instantiation.expression option; -(* nominal_value: Instantiation.expression option; -*) - output: bool; - fixed: bool option - } - -and element_kind = - | Input - | Parameter - | Variable - | DiscreteVariable - -type stats = - { - nb_ipars: int; - nb_rpars: int; - nb_spars: int; - nb_dvars: int; - nb_cvars: int; - nb_inps: int; - nb_outps: int - } - - -(* Utilities *) - -let evaluate t = Lazy.force t - -(* Remove enclosing parenthesis *) -let unbraced s = - let n = String.length s in - try - match s.[0], s.[n - 1] with - | '(', ')' -> String.sub s 1 (n - 2) - | _ -> s - with - | _ -> s - -(* function used to hide XML special characters *) -let hide_spc s = - let encoded_s = ref "" in - let hide_special_character c = match c with - | '<' -> encoded_s := !encoded_s ^ "<" - | '>' -> encoded_s := !encoded_s ^ ">" - | '&' -> encoded_s := !encoded_s ^ "&" - | '\'' -> encoded_s := !encoded_s ^ "'" - | '\"' -> encoded_s := !encoded_s ^ """ - | _ -> encoded_s := !encoded_s ^ (String.make 1 c) in - String.iter hide_special_character s; - !encoded_s - - -(* Code generation functions *) - -let rec generate_code xml init filename inst_defs = - let fun_defs = - List.fold_left collect_function_definitions [] inst_defs in - let add_instance_element acc (id, elt_desc) = - match evaluate elt_desc.Instantiation.element_nature with - | Instantiation.Class _ -> acc - | Instantiation.Component cpnt_desc -> (id, cpnt_desc) :: acc in - match List.fold_left add_instance_element [] inst_defs with - | [] -> () - | [ id, cpnt_desc ] -> - generate_component_description xml init filename fun_defs id cpnt_desc - | _ -> assert false - -and collect_function_definitions fun_defs (id, elt_desc) = - match evaluate elt_desc.Instantiation.element_nature with - | Instantiation.Class cl_def -> - let ctx = - { - path = cl_def.Instantiation.class_path; - location = cl_def.Instantiation.class_location; - instance_nature = Instantiation.ClassElement - } in - let cl_spec = cl_def.Instantiation.class_type in - fun_defs @ - collect_function_definitions_in_class_specifier ctx cl_spec - | Instantiation.Component cpnt_desc -> - let ctx = - { - path = cpnt_desc.Instantiation.component_path; - location = cpnt_desc.Instantiation.component_location; - instance_nature = - Instantiation.ComponentElement cpnt_desc.Instantiation.class_name - } in - fun_defs @ - collect_function_definitions_in_component ctx cpnt_desc - -and collect_function_definitions_in_class_specifier ctx = function - | Types.PredefinedType _ | Types.ComponentType _ | Types.ArrayType _ | - Types.TupleType _ -> [] - | Types.ClassType cl_type -> - collect_function_definition_in_class_type ctx cl_type - -and collect_function_definition_in_class_type ctx cl_type = - let fun_defs = collect_inner_functions ctx cl_type in - collect_function ctx fun_defs cl_type - -and collect_inner_functions ctx cl_type = - match evaluate cl_type.Types.kind with - | Types.Class | Types.Model | Types.Block | Types.Package | - Types.Function -> - let named_elts = cl_type.Types.named_elements in - List.fold_left - (collect_function_definitions_in_type ctx) - [] - named_elts - | Types.Record | Types.ExpandableConnector | Types.Connector -> [] - -and collect_function_definitions_in_type ctx fun_defs (id, elt_type) = - let elt_type' = evaluate elt_type in - match elt_type'.Types.dynamic_scope, elt_type'.Types.element_nature with - | None, Types.ClassElement cl_spec -> - let ctx' = - { - ctx with - path = ctx.path @ [Instantiation.Name id] - } in - let cl_spec' = evaluate cl_spec in - let fun_defs' = - collect_function_definitions_in_class_specifier ctx' cl_spec' in - fun_defs' @ fun_defs - | Some _, _ | - None, - (Types.ComponentElement _ | Types.ComponentTypeElement _ | - Types.PredefinedTypeElement _) -> fun_defs - -and collect_function ctx fun_defs cl_type = - match evaluate cl_type.Types.kind with - | Types.Function -> - let named_elts = cl_type.Types.named_elements in - function_description_of_named_elements ctx named_elts :: fun_defs - | Types.Class | Types.Model | Types.Block | Types.Record | - Types.ExpandableConnector | Types.Connector| Types.Package -> fun_defs - -and function_description_of_named_elements ctx named_elts = - let collect_input_or_output (id, elt_type) fun_desc = - let collect_input_or_output' cpnt_type = - match evaluate cpnt_type.Types.causality with - | Types.Input -> - let cl_spec = evaluate cpnt_type.Types.base_class in - { fun_desc with inputs = (id, cl_spec) :: fun_desc.inputs } - | Types.Output -> - let cl_spec = evaluate cpnt_type.Types.base_class in - { fun_desc with outputs = (id, cl_spec) :: fun_desc.outputs } - | Types.Acausal -> fun_desc in - let elt_type' = evaluate elt_type in - match elt_type'.Types.element_nature with - | Types.ComponentElement cpnt_type -> - collect_input_or_output' cpnt_type - | Types.ClassElement _ | Types.ComponentTypeElement _ | - Types.PredefinedTypeElement _ -> fun_desc in - let fun_desc = { inputs = []; outputs = [] } in - ctx, - List.fold_right collect_input_or_output named_elts fun_desc - -and collect_function_definitions_in_component ctx cpnt_desc = - match evaluate cpnt_desc.Instantiation.component_nature with - | Instantiation.DynamicArray cpnt_desc -> - let ctx' = - { ctx with path = ctx.path @ [Instantiation.Index 0] } in - collect_function_definitions_in_component ctx' cpnt_desc - | Instantiation.Instance inst -> - let elts = evaluate inst.Instantiation.elements in - let named_elts = elts.Instantiation.named_elements in - List.fold_left collect_function_definitions [] named_elts - | Instantiation.PredefinedTypeInstance _ -> [] - | Instantiation.StaticArray [||] -> [] - | Instantiation.StaticArray cpnt_descs -> - let ctx' = - { ctx with path = ctx.path @ [Instantiation.Index 0] } in - collect_function_definitions_in_component ctx' cpnt_descs.(0) - -and generate_function_definition oc acc (ctx, fun_desc) = - let ext_name = Printf.sprintf "%s" (last_id ctx.path) - and name = string_of_path ctx.path in - match List.mem ext_name acc with - | true -> acc - | false -> - Printf.fprintf oc "function %s \"%s\"\n" ext_name name; - List.iter (generate_function_inout ctx oc "input") fun_desc.inputs; - List.iter (generate_function_inout ctx oc "output") fun_desc.outputs; - Printf.fprintf oc "external;\nend %s;\n" ext_name; - ext_name :: acc - -and generate_function_inout ctx oc inout (id, cl_spec) = - let generate_dimensions ndims = - let rec generate_dimensions' ndims = - match ndims with - | 0 -> assert false - | 1 -> Printf.fprintf oc ":" - | _ -> Printf.fprintf oc ":, "; generate_dimensions' (ndims - 1) in - match ndims with - | 0 -> () - | _ -> - Printf.fprintf oc "["; - generate_dimensions' ndims; - Printf.fprintf oc "]" in - let rec generate_function_inout' cl_spec ndims = match cl_spec with - | Types.PredefinedType { Types.base_type = Types.RealType } -> - Printf.fprintf oc "\t%s Real" inout; - generate_dimensions ndims; - Printf.fprintf oc " %s;\n" id - | Types.PredefinedType { Types.base_type = Types.IntegerType } - when ndims = 0 && inout = "input" -> - Printf.fprintf oc "\t%s Integer %s;\n" inout id - | Types.PredefinedType { Types.base_type = Types.StringType } - when ndims = 0 && inout = "input" -> - Printf.fprintf oc "\t%s String %s;\n" inout id - | Types.ArrayType (_, cl_spec) when inout = "input" -> - generate_function_inout' cl_spec (ndims + 1) - | _ -> - raise (GenericError - { err_msg = - ["_NotYetImplemented"; "_NonSupportedTypeOfFuncInOut"; id]; - err_info = []; - err_ctx = ctx }) in - generate_function_inout' cl_spec 0 - -and generate_component_description xml init filename fun_defs id cpnt_desc = - let chop_extension s = try Filename.chop_extension s with _ -> s in - let filename = match filename with - | None -> id - | Some s -> chop_extension s in - let ctx = - { - path = cpnt_desc.Instantiation.component_path; - location = cpnt_desc.Instantiation.component_location; - instance_nature = - Instantiation.ComponentElement cpnt_desc.Instantiation.class_name - } - and flat_inst = collect_component_elements cpnt_desc in - generate_dynamic_description ctx xml filename fun_defs id flat_inst; - generate_function_definitions ctx filename fun_defs; - if init then - generate_initial_description ctx filename fun_defs id flat_inst - -and generate_dynamic_description ctx xml filename fun_defs id flat_inst = - let vars = flat_inst.variables - and equs = flat_inst.dynamic_equations - and ext = if xml then ".xml" else ".mo" in - let oc = open_out (filename ^ ext) in - try - if xml then - generate_flatten_XML ctx fun_defs oc id vars equs - else - generate_flatten_instance ctx fun_defs oc id vars equs; - close_out oc; - with exn -> close_out oc; raise exn - -and generate_initial_description ctx filename fun_defs id flat_inst = - let oc = open_out (filename ^ "_init.xml") in - try - let varss = List.map (function Rel r -> r) flat_inst.abstract_relations in - let vars = - List.fold_left add_component flat_inst.variables (List.flatten varss) - and equs = flat_inst.initial_equations in - generate_flatten_XML ctx fun_defs oc id vars equs; - generate_relations filename vars flat_inst.abstract_relations; - close_out oc; - with exn -> close_out oc; raise exn - -and generate_function_definitions ctx filename fun_defs = - let generate_function_definitions' oc = - try - let _ = List.fold_left (generate_function_definition oc) [] fun_defs in - close_out oc - with exn -> close_out oc; raise exn in - match fun_defs with - | [] -> () - | _ -> - let oc = open_out (filename ^ "_functions.mo") in - generate_function_definitions' oc - -and collect_component_elements cpnt_desc = - let ctx = - {path = cpnt_desc.Instantiation.component_path; - location = cpnt_desc.Instantiation.component_location; - instance_nature = - Instantiation.ComponentElement cpnt_desc.Instantiation.class_name} in - match evaluate cpnt_desc.Instantiation.component_nature with - | Instantiation.DynamicArray _ -> - raise (GenericError - { err_msg = ["_NotYetImplemented"; "_DynamicArrayType"]; - err_info = []; - err_ctx = ctx }) - | Instantiation.Instance inst -> collect_instance_elements ctx inst - | Instantiation.PredefinedTypeInstance _ - when is_fixed_parameter cpnt_desc -> - { - variables = []; - dynamic_equations = []; - initial_equations = []; - abstract_relations = [] - } - | Instantiation.PredefinedTypeInstance _ -> - let decl_equs = collect_declaration_equation cpnt_desc in - { - variables = [ cpnt_desc ]; - dynamic_equations = decl_equs; - initial_equations = decl_equs; - abstract_relations = [] - } - | Instantiation.StaticArray cpnt_descs -> - collect_array_elements cpnt_descs - -and collect_instance_elements ctx inst = - let elts = evaluate inst.Instantiation.elements in - let named_elts = elts.Instantiation.named_elements - and unnamed_elts = elts.Instantiation.unnamed_elements in - let flat_inst = collect_instance_named_elements named_elts - and dyn_equs, init_equs = - List.fold_left (collect_equations ctx) ([], []) unnamed_elts in - let init_equs, rels = - List.fold_left - (introduce_derivative_variables ctx) - ([], []) - (dyn_equs @ init_equs) in - { flat_inst with - dynamic_equations = flat_inst.dynamic_equations @ dyn_equs; - initial_equations = flat_inst.initial_equations @ init_equs; - abstract_relations = flat_inst.abstract_relations @ rels - } - -and collect_instance_named_elements named_elts = - let collect_instance_named_elements' flat_inst (_, elt_desc) = - let elt_nat = evaluate elt_desc.Instantiation.element_nature in - match elt_nat with - | Instantiation.Class _ -> flat_inst - | Instantiation.Component cpnt_desc -> - let flat_inst' = collect_component_elements cpnt_desc in - { - variables = flat_inst.variables @ flat_inst'.variables; - dynamic_equations = - flat_inst.dynamic_equations @ flat_inst'.dynamic_equations; - initial_equations = - flat_inst.initial_equations @ flat_inst'.initial_equations; - abstract_relations = - flat_inst.abstract_relations @ flat_inst'.abstract_relations - } in - let flat_inst = - { - variables = []; - dynamic_equations = []; - initial_equations = []; - abstract_relations = [] - } in - List.fold_left collect_instance_named_elements' flat_inst named_elts - -and introduce_derivative_variables ctx (init_equs, rels) equ = - let rec introduce_derivative_variables' expr = match expr with - | Instantiation.BinaryOperation (oper_kind, expr1, expr2) -> - let expr1, cpnt_descs1 = introduce_derivative_variables' expr1 - and expr2, cpnt_descs2 = introduce_derivative_variables' expr2 in - Instantiation.BinaryOperation (oper_kind, expr1, expr2), - cpnt_descs1 @ cpnt_descs2 - | Instantiation.FunctionCall - (Instantiation.PredefinedIdentifier "der", - [ Instantiation.ComponentReference cpnt_desc ]) -> - let cpnt_desc' = component_derivative cpnt_desc in - Instantiation.ComponentReference cpnt_desc', - [ cpnt_desc' ] - | Instantiation.FunctionCall - (Instantiation.PredefinedIdentifier "der", _) -> - raise (GenericError - { err_msg = ["_NotYetImplemented"; "_UnsupportedDerOperArg"]; - err_info = []; - err_ctx = ctx }) (*error*) - | Instantiation.If (alts, default) -> - let f (cond, expr) = - let cond, cpnt_descs1 = introduce_derivative_variables' cond - and expr, cpnt_descs2 = introduce_derivative_variables' expr in - (cond, expr), cpnt_descs1 @ cpnt_descs2 in - let alts, cpnt_descss = List.split (List.map f alts) in - let default, cpnt_descs' = introduce_derivative_variables' default in - Instantiation.If (alts, default), - (List.flatten cpnt_descss) @ cpnt_descs' - | Instantiation.IndexedAccess (expr, exprs) -> - let expr, cpnt_descs = introduce_derivative_variables' expr in - Instantiation.IndexedAccess (expr, exprs), - cpnt_descs - | Instantiation.NoEvent expr -> - let expr, cpnt_descs = introduce_derivative_variables' expr in - Instantiation.NoEvent expr, - cpnt_descs - | Instantiation.UnaryOperation (oper_kind, expr) -> - let expr, cpnt_descs = introduce_derivative_variables' expr in - Instantiation.UnaryOperation (oper_kind, expr), - cpnt_descs - | Instantiation.VectorReduction (exprs, expr) -> - let expr, cpnt_descs = introduce_derivative_variables' expr in - Instantiation.VectorReduction (exprs, expr), - cpnt_descs - | Instantiation.Record record_elts -> - let f (id, expr) = - let expr, cpnt_descs = introduce_derivative_variables' expr in - (id, expr), cpnt_descs in - let record_elts, cpnt_descs = List.split (List.map f record_elts) in - Instantiation.Record record_elts, - List.flatten cpnt_descs - | Instantiation.Tuple exprs -> - let exprs' = List.map introduce_derivative_variables' exprs in - let exprs', cpnt_descs' = List.split exprs' in - Instantiation.Tuple exprs', - List.flatten cpnt_descs' - | Instantiation.Vector exprs -> - let exprs' = Array.map introduce_derivative_variables' exprs in - let exprs', cpnt_descs' = List.split (Array.to_list exprs') in - Instantiation.Vector (Array.of_list exprs'), - List.flatten cpnt_descs' - | Instantiation.FunctionCall (expr, exprs) -> - let exprs' = List.map introduce_derivative_variables' exprs in - let exprs', cpnt_descs' = List.split exprs' in - Instantiation.FunctionCall (expr, exprs'), - List.flatten cpnt_descs' - | Instantiation.ComponentReference cpnt_desc -> expr, [ cpnt_desc ] - | _ -> expr, [] in - match equ with - | Instantiation.Equal (expr1, expr2) -> - let expr1, cpnt_descs1 = introduce_derivative_variables' expr1 - and expr2, cpnt_descs2 = introduce_derivative_variables' expr2 in - let cpnt_descs = - List.fold_left add_component [] (cpnt_descs1 @ cpnt_descs2) in - (Instantiation.Equal (expr1, expr2)) :: init_equs, - (Rel cpnt_descs) :: rels - | Instantiation.ConnectFlows _ | Instantiation.ConditionalEquationE _ | - Instantiation.WhenClauseE _ -> init_equs, rels - -and collect_equations ctx (dyn_equs, init_equs) unnamed_elt = - match unnamed_elt with - | Instantiation.EquationClause (NameResolve.Permanent, equs) -> - dyn_equs @ (expand_equations ctx (evaluate equs)), init_equs - | Instantiation.EquationClause (NameResolve.Initial, equs) -> - dyn_equs, init_equs @ (expand_equations ctx (evaluate equs)) - | Instantiation.AlgorithmClause _ -> - raise (GenericError - { err_msg = ["_NotYetImplemented"; "_AlgorithmClause"]; - err_info = []; - err_ctx = ctx }) (*error*) - -and expand_equations ctx equs = - let expand_equation equ = equ.Instantiation.nature in - let add_connection (expr, sign) (expr', sign') cnect_sets = - let contains_at_least_one_node_to_connect cnect_set = - List.mem_assoc expr cnect_set || List.mem_assoc expr' cnect_set in - let cnect_sets, cnect_sets' = - List.partition contains_at_least_one_node_to_connect cnect_sets in - match cnect_sets with - | [] -> [(expr, sign); (expr', sign')] :: cnect_sets' - | [cnect_set; cnect_set'] -> (cnect_set @ cnect_set') :: cnect_sets' - | [cnect_set] when List.mem_assoc expr cnect_set -> - ((expr', sign') :: cnect_set) :: cnect_sets' - | [cnect_set] -> ((expr, sign) :: cnect_set) :: cnect_sets' - | _ :: _ :: _ :: _ -> assert false in - let expand_connection cnect_sets = function - | Instantiation.ConnectFlows (sign, expr, sign', expr') -> - add_connection (expr, sign) (expr', sign') cnect_sets - | Instantiation.Equal _ | Instantiation.ConditionalEquationE _ | - Instantiation.WhenClauseE _ -> cnect_sets in - let generate_flow_equation cnect_set = - let to_expression (expr, sign) = match sign with - | NameResolve.Positive -> expr - | NameResolve.Negative -> - Instantiation.UnaryOperation (Instantiation.UnaryMinus, expr) in - let add_expressions expr expr' = - Instantiation.BinaryOperation (Instantiation.Plus, expr, expr') in - let exprs = List.map to_expression cnect_set in - let lhs = List.fold_left add_expressions (Instantiation.Real 0.) exprs in - Instantiation.Equal (lhs, Instantiation.Real 0.) in - let collect_equation equs equ = match equ with - | Instantiation.ConnectFlows _ -> equs - | Instantiation.Equal _ | Instantiation.ConditionalEquationE _ | - Instantiation.WhenClauseE _ -> equ :: equs in - let equ_descs = List.flatten (List.map expand_equation equs) in - let cnect_sets = List.fold_left expand_connection [] equ_descs - and equs = List.fold_left collect_equation [] equ_descs in - let equs' = List.map generate_flow_equation cnect_sets in - equs @ equs' - -and collect_array_elements cpnt_descs = - let rec collect_array_elements' flat_inst i = - if i = Array.length cpnt_descs then flat_inst - else - let flat_inst' = collect_component_elements cpnt_descs.(i) in - let flat_inst = - { - variables = flat_inst.variables @ flat_inst'.variables; - dynamic_equations = - flat_inst.dynamic_equations @ flat_inst'.dynamic_equations; - initial_equations = - flat_inst.initial_equations @ flat_inst'.initial_equations; - abstract_relations = - flat_inst.abstract_relations @ flat_inst'.abstract_relations - } in - collect_array_elements' flat_inst (i + 1) in - let flat_inst = - { - variables = []; - dynamic_equations = []; - initial_equations = []; - abstract_relations = [] - } in - collect_array_elements' flat_inst 0 - -and collect_declaration_equation cpnt_desc = - let var = cpnt_desc.Instantiation.variability - and equ = cpnt_desc.Instantiation.declaration_equation in - match var, equ with - | (Types.Continuous | Types.Discrete), Some expr -> - let expr' = Instantiation.ComponentReference cpnt_desc in - [ Instantiation.Equal (expr', evaluate expr) ] - | _ -> [] - -and generate_flatten_instance ctx fun_defs oc id vars equs = - Printf.fprintf oc "class %s\n" id; - List.iter (generate_variable_declaration ctx oc) vars; - Printf.fprintf oc "equation\n"; - generate_equation_descriptions ctx fun_defs oc equs; - Printf.fprintf oc "end %s;\n" id - -and generate_variable_declaration ctx oc cpnt_desc = - Printf.fprintf oc "\t"; - generate_variable_variability oc cpnt_desc; - generate_variable_causality oc cpnt_desc; - generate_variable_type ctx oc cpnt_desc; - generate_variable_name oc cpnt_desc; - generate_variable_start_value ctx oc cpnt_desc; - generate_initialization ctx oc cpnt_desc; - generate_comment oc cpnt_desc; - Printf.fprintf oc ";\n" - -and generate_variable_variability oc cpnt_desc = - match cpnt_desc.Instantiation.variability with - | Types.Constant -> Printf.fprintf oc "constant " - | Types.Parameter -> Printf.fprintf oc "parameter " - | Types.Discrete -> Printf.fprintf oc "discrete " - | Types.Continuous -> () - -and generate_variable_causality oc cpnt_desc = - let inout = cpnt_desc.Instantiation.causality in - match inout with - | Types.Input -> Printf.fprintf oc "input " - | Types.Output -> Printf.fprintf oc "output " - | Types.Acausal -> () - -and generate_variable_type ctx oc cpnt_desc = - let generate_variable_type' predef = - let var = cpnt_desc.Instantiation.variability in - match predef.Instantiation.predefined_type, var with - | Instantiation.IntegerType, Types.Parameter -> - Printf.fprintf oc "Integer " - | Instantiation.IntegerType, _ -> - raise (GenericError - { err_msg = ["_NotYetImplemented"; "_IntegerType"]; - err_info = []; - err_ctx = ctx }) (*error*) - | Instantiation.RealType, _ -> Printf.fprintf oc "Real " - | Instantiation.BooleanType, _ -> - raise (GenericError - { err_msg = ["_NotYetImplemented"; "_BooleanType"]; - err_info = []; - err_ctx = ctx }) (*error*) - | Instantiation.StringType, Types.Parameter -> - Printf.fprintf oc "String " - | Instantiation.StringType, _ -> - raise (GenericError - { err_msg = ["_NotYetImplemented"; "_StringType"]; - err_info = []; - err_ctx = ctx }) (*error*) - | Instantiation.EnumerationType, _ -> - raise (GenericError - { err_msg = ["_NotYetImplemented"; "_EnumType"]; - err_info = []; - err_ctx = ctx }) (*error*) in - let var_type = evaluate cpnt_desc.Instantiation.component_nature in - match var_type with - | Instantiation.PredefinedTypeInstance predef -> - generate_variable_type' predef - | Instantiation.DynamicArray _ -> - raise (GenericError - { err_msg = ["_NotYetImplemented"; "_DynamicArrayType"]; - err_info = []; - err_ctx = ctx }) (*error*) - | Instantiation.Instance _ -> - raise (GenericError - { err_msg = ["_NotYetImplemented"; "_InstanceType"]; - err_info = []; - err_ctx = ctx }) (*error*) - | Instantiation.StaticArray _ -> - raise (GenericError - { err_msg = ["_NotYetImplemented"; "_StaticArrayType"]; - err_info = []; - err_ctx = ctx }) (*error*) - -and generate_variable_name oc cpnt_desc = - let name = ident_of_path cpnt_desc.Instantiation.component_path in - Printf.fprintf oc "%s" name - -and generate_variable_start_value ctx oc cpnt_desc = - let generate_start_value attrs = - try - let expr = evaluate (List.assoc "start" attrs) in - Printf.fprintf oc "(start=%s)" - (string_of_expression ctx [] expr) - with Not_found -> () in - let generate_variable_start_value' predef = - let attrs = predef.Instantiation.attributes in - generate_start_value attrs in - let var_type = evaluate cpnt_desc.Instantiation.component_nature in - match var_type with - | Instantiation.PredefinedTypeInstance predef -> - generate_variable_start_value' predef - | Instantiation.DynamicArray _ -> - raise (GenericError - { err_msg = ["_NotYetImplemented"; "_DynamicArrayType"]; - err_info = []; - err_ctx = ctx }) (*error*) - | Instantiation.Instance _ -> - raise (GenericError - { err_msg = ["_NotYetImplemented"; "_InstanceType"]; - err_info = []; - err_ctx = ctx }) (*error*) - | Instantiation.StaticArray _ -> - raise (GenericError - { err_msg = ["_NotYetImplemented"; "_StaticArrayType"]; - err_info = []; - err_ctx = ctx }) (*error*) - -and string_of_path = function - | [] -> assert false - | [Instantiation.Name id] -> id - | [Instantiation.Index i] -> Printf.sprintf "[%d]" (i + 1) - | Instantiation.Name id :: path -> - Printf.sprintf "%s.%s" id (string_of_path path) - | Instantiation.Index i :: path -> - Printf.sprintf "[%d].%s" (i + 1) (string_of_path path) - -and ident_of_path path = - let rec ident_of_path' path = - match path with - | [] -> assert false - | [Instantiation.Name id] -> unquoted id - | [Instantiation.Index i] -> Printf.sprintf "[%d]" (i + 1) - | Instantiation.Name id :: path -> - Printf.sprintf "%s.%s" (unquoted id) (ident_of_path' path) - | Instantiation.Index i :: path -> - Printf.sprintf "[%d].%s" (i + 1) (ident_of_path' path) in - match path with - | [] -> assert false - | [Instantiation.Name id] -> assert false - | [Instantiation.Index i] -> assert false - | Instantiation.Name id :: path -> - Printf.sprintf "`%s`" (ident_of_path' path) - | Instantiation.Index i :: path -> assert false - -and unquoted id = - let n = String.length id in - try - match id.[0] with - | '`' | '\'' -> String.sub id 1 (n - 2) - | _ -> id - with - | _ -> id - -and generate_initialization ctx oc cpnt_desc = - let var = cpnt_desc.Instantiation.variability - and equ = cpnt_desc.Instantiation.declaration_equation in - match var, equ with - | Types.Parameter, Some expr -> - Printf.fprintf oc " = %s" - (string_of_expression ctx [] (evaluate expr)) - | _ -> () - -and generate_comment oc cpnt_desc = - Printf.fprintf oc " \"%s\"" cpnt_desc.Instantiation.comment - -and generate_equation_descriptions ctx fun_defs oc equ_descs = - List.iter (generate_equation_description ctx fun_defs oc) equ_descs - -and generate_equation_description ctx fun_defs oc equ_desc = - match equ_desc with - | Instantiation.Equal (expr, expr') -> - Printf.fprintf oc "%s" (string_of_equal ctx fun_defs expr expr') - | Instantiation.ConditionalEquationE _ -> assert false - | Instantiation.ConnectFlows _ -> assert false - | Instantiation.WhenClauseE alts -> - generate_when_clause ctx fun_defs oc alts - -and string_of_equal ctx fun_defs expr expr' = match expr with - | Instantiation.Tuple [] -> - Printf.sprintf "\t%s;\n" - (string_of_expression ctx fun_defs expr') - | _ -> - Printf.sprintf "\t%s = %s;\n" - (string_of_expression ctx fun_defs expr) - (string_of_expression ctx fun_defs expr') - -and generate_when_clause ctx fun_defs oc alts = match alts with - | [] -> () - | [ (expr, equs) ] -> - Printf.fprintf oc "when %s then\n" - (string_of_expression ctx fun_defs expr); - List.iter (generate_when_equation ctx fun_defs oc) equs; - Printf.fprintf oc "end when;\n" - | (expr, equs) :: alts -> - Printf.fprintf oc "when %s then\n" - (string_of_expression ctx fun_defs expr); - List.iter (generate_when_equation ctx fun_defs oc) equs; - Printf.fprintf oc "else"; - generate_when_clause ctx fun_defs oc alts - -and generate_when_equation ctx fun_defs oc equ = - let equ' = equ.Instantiation.nature in - generate_equation_descriptions ctx fun_defs oc equ' - -and string_of_expression ctx fun_defs = function - | Instantiation.BinaryOperation (bin_op, expr, expr') -> - string_of_binary_operation ctx fun_defs bin_op expr expr' - | Instantiation.ClassReference cl_def -> - string_of_class_reference fun_defs cl_def - | Instantiation.ComponentReference cpnt_desc -> - ident_of_path cpnt_desc.Instantiation.component_path - | Instantiation.EnumerationElement _ -> - raise (GenericError - { err_msg = [ "_NotYetImplemented"; - "_ExprOfType"; - "enumeration" ]; - err_info = []; - err_ctx = ctx }) (*error*) - | Instantiation.False -> - raise (GenericError - { err_msg = ["_NotYetImplemented"; "_Expr"; "false"]; - err_info = []; - err_ctx = ctx }) (*error*) - | Instantiation.FieldAccess _ -> - raise (GenericError - { err_msg = ["_NotYetImplemented"; "_FieldAccessExpr"]; - err_info = []; - err_ctx = ctx }) (*error*) - | Instantiation.FunctionCall (expr, exprs) -> - string_of_function_call ctx fun_defs expr exprs - | Instantiation.If (alts, expr) -> - string_of_if ctx fun_defs alts expr - | Instantiation.IndexedAccess _ -> - raise (GenericError - { err_msg = ["_NotYetImplemented"; "_IndexedAccessExpr"]; - err_info = []; - err_ctx = ctx }) (*error*) - | Instantiation.Integer i when Int32.to_int i >= 0 -> - Printf.sprintf "%ld" i - | Instantiation.Integer i -> - let expr = Instantiation.Integer (Int32.neg i) - and un_op = Instantiation.UnaryMinus in - string_of_unary_operation ctx fun_defs un_op expr - | Instantiation.LoopVariable _ -> - raise (GenericError - { err_msg = ["_NotYetImplemented"; "_LoopVar"]; - err_info = []; - err_ctx = ctx }) (*error*) - | Instantiation.NoEvent expr -> string_of_no_event ctx fun_defs expr - | Instantiation.PredefinedIdentifier id -> Printf.sprintf "%s" id - | Instantiation.Range _ -> - raise (GenericError - { err_msg = ["_NotYetImplemented"; "_RangeExpr"]; - err_info = []; - err_ctx = ctx }) (*error*) - | Instantiation.Real f -> - Printf.sprintf "%s" (string_of_float f) - | Instantiation.Record _ -> - raise (GenericError - { err_msg = ["_NotYetImplemented"; "_ExprOfType"; "record"]; - err_info = []; - err_ctx = ctx }) (*error*) - | Instantiation.String s -> Printf.sprintf "\"%s\"" s - | Instantiation.True -> - raise (GenericError - { err_msg = ["_NotYetImplemented"; "_Expr"; "true"]; - err_info = []; - err_ctx = ctx }) (*error*) - | Instantiation.Tuple _ -> - raise (GenericError - { err_msg = ["_NotYetImplemented"; "_TupleExpr"]; - err_info = []; - err_ctx = ctx }) (*error*) - | Instantiation.UnaryOperation (un_op, expr) -> - string_of_unary_operation ctx fun_defs un_op expr - | Instantiation.Vector exprs -> - string_of_vector ctx fun_defs exprs - | Instantiation.VectorReduction _ -> - raise (GenericError - { err_msg = ["_NotYetImplemented"; "_VectorReduct"]; - err_info = []; - err_ctx = ctx }) (*error*) - -and string_of_binary_operation ctx fun_defs bin_op expr expr' = - let string_of_binary_operation_kind = function - | Instantiation.And -> "and" - | Instantiation.Divide -> "/" - | Instantiation.EqualEqual -> "==" - | Instantiation.GreaterEqual -> ">=" - | Instantiation.Greater -> ">" - | Instantiation.LessEqual -> "<=" - | Instantiation.Less -> "<" - | Instantiation.Times -> "*" - | Instantiation.NotEqual -> "<>" - | Instantiation.Or -> "or" - | Instantiation.Plus -> "+" - | Instantiation.Power -> "^" - | Instantiation.Minus -> "-" in - Printf.sprintf "(%s %s %s)" - (string_of_expression ctx fun_defs expr) - (string_of_binary_operation_kind bin_op) - (string_of_expression ctx fun_defs expr') - -and string_of_class_reference fun_defs cl_def = - let rec last = function - | [] -> assert false - | [Instantiation.Name id] -> id - | [Instantiation.Index _] -> assert false - | _ :: path -> last path in - let ctx = - { - path = cl_def.Instantiation.class_path; - location = cl_def.Instantiation.class_location; - instance_nature = Instantiation.ClassElement - } in - let string_of_external_call ext_call = - match ext_call.NameResolve.nature with - | NameResolve.PrimitiveCall "builtin" | - NameResolve.PrimitiveCall "C" -> last ctx.path - | NameResolve.PrimitiveCall lang -> - raise (GenericError - { err_msg = ["_NotYetImplemented"; - "_ExternalCallToLanguage"; - lang]; - err_info = []; - err_ctx = ctx }) (*error*) - | NameResolve.ExternalProcedureCall _ -> - raise (GenericError - { err_msg = ["_NotYetImplemented"; - "_ExternalProcedureCall"]; - err_info = []; - err_ctx = ctx }) (*error*) in - let string_of_long_description long_desc = - match evaluate long_desc.NameResolve.external_call with - | None -> - raise (GenericError - { err_msg = ["_NotYetImplemented"; - "_NonExternalCallClassRef"]; - err_info = []; - err_ctx = ctx }) (*error*) - | Some ext_call -> string_of_external_call ext_call in - match cl_def.Instantiation.description with - | Instantiation.ClassDescription (_, cl_desc) -> - string_of_long_description cl_desc.Instantiation.long_description - | Instantiation.PredefinedType _ -> - raise (GenericError - { err_msg = ["_NotYetImplemented"; - "_PredefinedTypeClassRef"]; - err_info = []; - err_ctx = ctx }) (*error*) - -and string_of_function_call ctx fun_defs expr exprs = - Printf.sprintf "%s(%s)" - (string_of_expression ctx fun_defs expr) - (string_of_expressions ctx fun_defs exprs) - -and string_of_expressions ctx fun_defs exprs = - String.concat ", " (List.map (string_of_expression ctx fun_defs) exprs) - -and string_of_if ctx fun_defs alts expr = - let rec string_of_alternatives = function - | [] -> Printf.sprintf " %s" (string_of_expression ctx fun_defs expr) - | (expr, expr') :: alts -> - Printf.sprintf "(if %s then %s else%s)" - (string_of_expression ctx fun_defs expr) - (string_of_expression ctx fun_defs expr') - (string_of_alternatives alts) in - string_of_alternatives alts - -and string_of_no_event ctx fun_defs expr = - Printf.sprintf "noEvent(%s)" - (string_of_expression ctx fun_defs expr) - -and string_of_unary_operation ctx fun_defs un_op expr = - let string_of_unary_operation_kind = function - | Instantiation.Not -> "not" - | Instantiation.UnaryMinus -> "-" in - Printf.sprintf "(%s %s)" - (string_of_unary_operation_kind un_op) - (string_of_expression ctx fun_defs expr) - -and string_of_vector ctx fun_defs exprs = - let exprs' = Array.to_list exprs in - Printf.sprintf "{ %s }" - (string_of_expressions ctx fun_defs exprs') - -and last_id path = - let rec last_id' id path = match path with - | [] -> id - | (Instantiation.Name id) :: path -> last_id' id path - | (Instantiation.Index _) :: path -> last_id' id path in - last_id' "" path - -and string_of_float f = - let add_parenthesis s = - if String.contains s '-' then Printf.sprintf "(%s)" s else s in - match Printf.sprintf "%.16g" f with - | s when (String.contains s '.') || (String.contains s 'e') -> - add_parenthesis s - | s -> add_parenthesis (Printf.sprintf "%s." s) - -and component_derivative cpnt_desc = - let derivative_path path = - let rec derivative_path' path = - match path with - | [] -> assert false - | (Instantiation.Name s) :: path -> - (Instantiation.Name ("__der_" ^ s)) :: path - | (Instantiation.Index i) :: path -> - (Instantiation.Index i) :: (derivative_path' path) in - List.rev (derivative_path' (List.rev path)) in - let path = cpnt_desc.Instantiation.component_path in - let id = unquoted (ident_of_path path) in - let component_derivative_nature cpnt_desc = - match evaluate cpnt_desc.Instantiation.component_nature with - | Instantiation.PredefinedTypeInstance predef_type_inst -> - let attribs = [ "start", lazy (Instantiation.Real 0.) ] in - Instantiation.PredefinedTypeInstance - { predef_type_inst with Instantiation.attributes = attribs } - | cpnt_nat -> cpnt_nat in - { - cpnt_desc with - Instantiation.component_path = derivative_path path; - Instantiation.component_nature = - lazy (component_derivative_nature cpnt_desc); - Instantiation.declaration_equation = None; - Instantiation.comment = "Time derivative of " ^ id - } - -and add_component cpnt_descs cpnt_desc = - let equal_components cpnt_desc cpnt_desc' = - cpnt_desc.Instantiation.component_path = - cpnt_desc'.Instantiation.component_path in - match List.exists (equal_components cpnt_desc) cpnt_descs with - | false -> cpnt_desc :: cpnt_descs - | true -> cpnt_descs - -and is_fixed_parameter cpnt_desc = - match cpnt_desc.Instantiation.variability with - | Types.Constant -> true - | Types.Parameter -> is_fixed cpnt_desc - | _ -> false - -and is_fixed cpnt_desc = - let var = cpnt_desc.Instantiation.variability - and cpnt_nat = evaluate cpnt_desc.Instantiation.component_nature in - let bool_of_fixed predef = - match evaluate (List.assoc "fixed" predef.Instantiation.attributes) with - | Instantiation.False -> false - | _ -> true in - match var, cpnt_nat with - | Types.Constant, _ -> true - | _, Instantiation.PredefinedTypeInstance predef - when List.mem_assoc "fixed" predef.Instantiation.attributes -> - bool_of_fixed predef - | Types.Parameter, _ -> true - | _ -> false - -and defined_attribute cpnt_desc attrib_name = - match evaluate cpnt_desc.Instantiation.component_nature with - | Instantiation.PredefinedTypeInstance predef -> - List.mem_assoc "fixed" predef.Instantiation.attributes - | _ -> false - -and generate_relations filename vars rels = - let add_indentifier_stats stats cpnt_desc = - match - cpnt_desc.Instantiation.variability, - cpnt_desc.Instantiation.causality, - Lazy.force cpnt_desc.Instantiation.component_nature - with - | Types.Parameter, _, - Instantiation.PredefinedTypeInstance - { Instantiation.predefined_type = Instantiation.IntegerType } -> - { stats with nb_ipars = stats.nb_ipars + 1 } - | Types.Parameter, _, - Instantiation.PredefinedTypeInstance - { Instantiation.predefined_type = Instantiation.RealType } -> - { stats with nb_rpars = stats.nb_rpars + 1 } - | Types.Parameter, _, - Instantiation.PredefinedTypeInstance - { Instantiation.predefined_type = Instantiation.StringType } -> - { stats with nb_spars = stats.nb_spars + 1 } - | Types.Discrete, _, _ -> { stats with nb_dvars = stats.nb_dvars + 1 } - | Types.Continuous, Types.Input, _ -> - { stats with nb_inps = stats.nb_inps + 1 } - | Types.Continuous, Types.Output, _ -> - { stats with - nb_cvars = stats.nb_cvars + 1; - nb_outps = stats.nb_outps + 1 - } - | Types.Continuous, Types.Acausal, _ -> - { stats with nb_cvars = stats.nb_cvars + 1 } - | _ -> stats in - let variable_id cpnt_desc = - let name = ident_of_path cpnt_desc.Instantiation.component_path in - hide_spc (unquoted name) in - let generate_identifier oc tabs cpnt_desc = - let rec generate_tabs tabs = - if tabs > 0 then begin - Printf.fprintf oc "\t"; generate_tabs (tabs - 1) - end in - match - cpnt_desc.Instantiation.variability, - cpnt_desc.Instantiation.causality - with - | Types.Parameter, _ -> - let id = variable_id cpnt_desc in - generate_tabs tabs; - Printf.fprintf oc "%s\n" id - | Types.Constant, _ -> () - | _, (Types.Acausal | Types.Output) -> - let id = variable_id cpnt_desc in - generate_tabs tabs; - Printf.fprintf oc "%s\n" id - | _, Types.Input -> - let id = variable_id cpnt_desc in - generate_tabs tabs; - Printf.fprintf oc "%s\n" id in - let generate_relation oc rel = - match rel with - | Rel cpnt_descs -> - Printf.fprintf oc "\t\t\n"; - List.iter (generate_identifier oc 3) cpnt_descs; - Printf.fprintf oc "\t\t\n" in - let generate_output oc cpnt_desc = - match - cpnt_desc.Instantiation.variability, - cpnt_desc.Instantiation.causality - with - | (Types.Parameter | Types.Constant), _ | - _, (Types.Acausal | Types.Input) -> () - | _, Types.Output -> - let id = variable_id cpnt_desc in - Printf.fprintf oc - "\t\t\n\ - \t\t\t%s\n\ - \t\t\t\n\ - \t\t\t\t%s\n\ - \t\t\t\n\ - \t\t\n" - id - id in - let oc' = open_out (filename ^ "_relations.xml") in - Printf.fprintf oc' "\n"; - let stats = - List.fold_left - add_indentifier_stats - { - nb_ipars = 0; - nb_rpars = 0; - nb_spars = 0; - nb_dvars = 0; - nb_cvars = 0; - nb_inps = 0; - nb_outps = 0 - } - vars in - Printf.fprintf oc' - "\t\n\ - \t\t%d\n\ - \t\t%d\n\ - \t\t%d\n\ - \t\t%d\n\ - \t\t%d\n\ - \t\t%d\n\ - \t\t%d\n\ - \t\t%d\n\ - \t\n" - stats.nb_ipars - stats.nb_rpars - stats.nb_spars - stats.nb_dvars - stats.nb_cvars - stats.nb_cvars - stats.nb_inps - stats.nb_outps; - Printf.fprintf oc' "\t\n"; - List.iter (generate_identifier oc' 2) vars; - Printf.fprintf oc' "\t\n"; - Printf.fprintf oc' "\t\n"; - List.iter (generate_relation oc') rels; - Printf.fprintf oc' "\t\n"; - Printf.fprintf oc' "\t\n"; - List.iter (generate_output oc') vars; - Printf.fprintf oc' "\t\n"; - Printf.fprintf oc' "\n"; - close_out oc' - -and generate_flatten_XML ctx fun_defs oc id vars equs = - let print_when_clause equ = - let string_of_equation equ = - let string_of_equation' equ_desc = match equ_desc with - | Instantiation.Equal (expr, expr') -> - hide_spc (string_of_equal ctx fun_defs expr expr') - | _ -> assert false in - String.concat - " " - (List.map string_of_equation' equ.Instantiation.nature) in - let rec string_of_when_clause alts = match alts with - | [] -> "" - | [ (expr, equs) ] -> - Printf.sprintf "when %s then\n %s end when;\n" - (string_of_expression ctx fun_defs expr) - (String.concat " " (List.map string_of_equation equs)) - | (expr, equs) :: alts -> - Printf.sprintf "when %s then\n %s else %s" - (string_of_expression ctx fun_defs expr) - (String.concat " " (List.map string_of_equation equs)) - (string_of_when_clause alts) in - match equ with - | Instantiation.WhenClauseE alts -> - Printf.fprintf oc "\n" - (string_of_when_clause alts) - | _ -> () - and print_equation equ = match equ with - | Instantiation.Equal (expr, expr') -> - Printf.fprintf oc "\n" - (hide_spc (string_of_equal ctx fun_defs expr expr')) - | _ -> () in - let print_equations equs = - Printf.fprintf oc "\n"; - List.iter print_equation equs; - Printf.fprintf oc "\n" - and print_when_clauses equs = - Printf.fprintf oc " \n"; - List.iter print_when_clause equs; - Printf.fprintf oc " \n" in - Printf.fprintf oc "\n"; - Printf.fprintf oc "%s\n" (hide_spc id); - print_tree ctx fun_defs oc (build_tree vars); - print_equations equs; - print_when_clauses equs; - Printf.fprintf oc "\n" - -and build_tree vars = - let is_output caus = match caus with - | Types.Output -> true - | _ -> false - and variable_kind caus var = match caus, var with - | Types.Input, _ -> Input - | _, Types.Parameter -> Parameter - | _, Types.Discrete -> DiscreteVariable - | _ -> Variable - and attribute_value name attrs = - try - Some (evaluate (List.assoc name attrs)) - with Not_found -> None in - let variable_initial_value cpnt_desc = - let cpnt_nat = evaluate cpnt_desc.Instantiation.component_nature - and var = cpnt_desc.Instantiation.variability - and equ = cpnt_desc.Instantiation.declaration_equation in - match cpnt_nat, var, equ with - | Instantiation.PredefinedTypeInstance _, Types.Parameter, Some expr -> - Some (evaluate expr) - | Instantiation.PredefinedTypeInstance predef, - (Types.Continuous | Types.Discrete), - _ -> - let attrs = predef.Instantiation.attributes in - attribute_value "start" attrs - | _ -> None - and variable_nominal_value cpnt_desc = - match evaluate cpnt_desc.Instantiation.component_nature with - | Instantiation.PredefinedTypeInstance predef -> - let attrs = predef.Instantiation.attributes in - attribute_value "nominal" attrs - | _ -> None - and fixed cpnt_desc = - match defined_attribute cpnt_desc "fixed" with - | false -> None - | true -> Some (is_fixed cpnt_desc) in - let terminal_element cpnt_desc = - let caus = cpnt_desc.Instantiation.causality - and var = cpnt_desc.Instantiation.variability in - let id = - unquoted (ident_of_path cpnt_desc.Instantiation.component_path) in - { - kind = variable_kind caus var; - id = id; - comment = cpnt_desc.Instantiation.comment; - initial_value = variable_initial_value cpnt_desc; -(* nominal_value = variable_nominal_value cpnt_desc; -*) - output = is_output caus; - fixed = fixed cpnt_desc - } in - let t_elts = List.map terminal_element vars in - List.fold_left - (fun ts t_elt -> insert (split t_elt.id) t_elt ts) - [] - t_elts - -and print_tree ctx fun_defs oc ts = - let string_of_kind = function - | Input -> "input" - | Parameter -> "fixed_parameter" - | Variable -> "variable" - | DiscreteVariable -> "discrete_variable" in - let string_of_initial_value elt = match elt.initial_value with - | None -> "" - | Some expr -> string_of_expression ctx fun_defs expr in -(* let string_of_nominal_value elt = match elt.nominal_value with - | None -> "" - | Some expr -> string_of_expression ctx fun_defs expr in *) - let string_of_fixed elt = match elt.fixed with - | None -> "" - | Some true -> "true" - | Some false -> "false" in - let rec print_tree_element = function - | Node (s, ts) -> - Printf.fprintf oc "\n"; - Printf.fprintf oc "%s\n" (hide_spc s); - Printf.fprintf oc "\n"; - List.iter print_tree_element ts; - Printf.fprintf oc "\n"; - Printf.fprintf oc "\n" - | Leaf (s, elt) -> - Printf.fprintf oc "\n"; - Printf.fprintf oc "%s\n" (hide_spc s); - Printf.fprintf oc "%s\n" (string_of_kind elt.kind); - Printf.fprintf oc "%s\n" (hide_spc elt.id); - Printf.fprintf oc "\n" (string_of_fixed elt); - Printf.fprintf oc "\n" - (hide_spc (unbraced (string_of_initial_value elt))); -(* Printf.fprintf oc "\n" - (hide_spc (unbraced (string_of_nominal_value elt))); -*) - Printf.fprintf oc "\n" (hide_spc elt.comment); - if elt.output then - Printf.fprintf oc "\n"; - if elt.kind <> Parameter && elt.initial_value <> None then - Printf.fprintf oc "\n"; - Printf.fprintf oc "\n" - in - Printf.fprintf oc " \n"; - List.iter print_tree_element ts; - Printf.fprintf oc " \n" - -and insert path x ts = - let rec insert' s path' = function - | [] -> [Node (s, insert path' x [])] - | Node (s', ts'') :: ts' when s = s' -> Node (s', insert path' x ts'') :: ts' - | t' :: ts' -> t' :: insert' s path' ts' in - match path with - | [s] -> ts @ [Leaf (s, x)] (*the order of elements is important in Scicos*) - | s :: path' -> insert' s path' ts - | [] -> assert false - -and cut_on_dot s = - let rec cut_on_dot' i = - if i = String.length s then s, None - else if s.[i] = '.' then String.sub s 0 i, Some (String.sub s (i + 1) (String.length s - i - 1)) - else cut_on_dot' (i + 1) - in cut_on_dot' 0 - -and split name = - let s, name_opt = cut_on_dot name in - match name_opt with - | None -> [s] - | Some name' -> s :: split name' +(* + * Translator from Modelica 2.x to flat Modelica + * + * Copyright (C) 2005 - 2007 Imagine S.A. + * For more information or commercial use please contact us at www.amesim.com + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License + * as published by the Free Software Foundation; either version 2 + * of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. + * + *) + +(** The main functions are: +{ul +{- [ generate_code ]: main function + {ul + {- [ collect_function_definitions ]: Collect function definitions } + {- [ generate_component_description ]: Generate component descriptions + {ul + {- [ collect_component_elements ]: Returns a [ flat_instance ] containing all variables and equations + {ul + {- [ expand_equations ]: Generation of connect equations } + {- [ introduce_derivative_variables ]: Introduce derivative variables} + } + } + {- [ generate_dynamic_description ]: Generate the dynamic Model description + {ul + {- [ generate_flatten_instance ]: Dynamic model description as flat Modelica } + {- [ generate_flatten_XML ]: if the "-xml" option is activated } + } + } + {- [ generate_function_definitions ]: Generate function definitions in a file named filename_functions.mo } + {- [ generate_initial_description ]: Generate initialization description in a file named filename_init.xml, + and abstract relations in a file named filename_relations.xml. + {ul + {- [ generate_flatten_XML ]: Generates an XML description of initialization problem } + {- [ generate_relations ]: Generates an XML description of abstract relations and other informations } + } + } + } + } + } +} +}*) + +open ErrorDico (* To have access to GenericError *) + +type flat_instance = + { + variables: Instantiation.component_description list; + dynamic_equations: Instantiation.equation_desc list; + initial_equations: Instantiation.equation_desc list; + abstract_relations: abstract_relation list + } + +and function_description = + { + inputs: (string * Types.class_specifier) list; + outputs: (string * Types.class_specifier) list + } + +and abstract_relation = + | Rel of Instantiation.component_description list + +and 'a tree = Leaf of (string * 'a) | Node of string * 'a tree list + +and element = + { + kind: element_kind; + id: string; + comment: string; + initial_value: Instantiation.expression option; +(* nominal_value: Instantiation.expression option; +*) + output: bool; + fixed: bool option + } + +and element_kind = + | Input + | Parameter + | Variable + | DiscreteVariable + +type stats = + { + nb_ipars: int; + nb_rpars: int; + nb_spars: int; + nb_dvars: int; + nb_cvars: int; + nb_inps: int; + nb_outps: int + } + + +(* Utilities *) + +let evaluate t = Lazy.force t + +(* Remove enclosing parenthesis *) +let unbraced s = + let n = String.length s in + try + match s.[0], s.[n - 1] with + | '(', ')' -> String.sub s 1 (n - 2) + | _ -> s + with + | _ -> s + +(* function used to hide XML special characters *) +let hide_spc s = + let encoded_s = ref "" in + let hide_special_character c = match c with + | '<' -> encoded_s := !encoded_s ^ "<" + | '>' -> encoded_s := !encoded_s ^ ">" + | '&' -> encoded_s := !encoded_s ^ "&" + | '\'' -> encoded_s := !encoded_s ^ "'" + | '\"' -> encoded_s := !encoded_s ^ """ + | _ -> encoded_s := !encoded_s ^ (String.make 1 c) in + String.iter hide_special_character s; + !encoded_s + + +(* Code generation functions *) + +let rec generate_code xml init filename inst_defs = + let fun_defs = + List.fold_left collect_function_definitions [] inst_defs in + let add_instance_element acc (id, elt_desc) = + match evaluate elt_desc.Instantiation.element_nature with + | Instantiation.Class _ -> acc + | Instantiation.Component cpnt_desc -> (id, cpnt_desc) :: acc in + match List.fold_left add_instance_element [] inst_defs with + | [] -> () + | [ id, cpnt_desc ] -> + generate_component_description xml init filename fun_defs id cpnt_desc + | _ -> assert false + +and collect_function_definitions fun_defs (id, elt_desc) = + match evaluate elt_desc.Instantiation.element_nature with + | Instantiation.Class cl_def -> + let ctx = + { + path = cl_def.Instantiation.class_path; + location = cl_def.Instantiation.class_location; + instance_nature = Instantiation.ClassElement + } in + let cl_spec = cl_def.Instantiation.class_type in + fun_defs @ + collect_function_definitions_in_class_specifier ctx cl_spec + | Instantiation.Component cpnt_desc -> + let ctx = + { + path = cpnt_desc.Instantiation.component_path; + location = cpnt_desc.Instantiation.component_location; + instance_nature = + Instantiation.ComponentElement cpnt_desc.Instantiation.class_name + } in + fun_defs @ + collect_function_definitions_in_component ctx cpnt_desc + +and collect_function_definitions_in_class_specifier ctx = function + | Types.PredefinedType _ | Types.ComponentType _ | Types.ArrayType _ | + Types.TupleType _ -> [] + | Types.ClassType cl_type -> + collect_function_definition_in_class_type ctx cl_type + +and collect_function_definition_in_class_type ctx cl_type = + let fun_defs = collect_inner_functions ctx cl_type in + collect_function ctx fun_defs cl_type + +and collect_inner_functions ctx cl_type = + match evaluate cl_type.Types.kind with + | Types.Class | Types.Model | Types.Block | Types.Package | + Types.Function -> + let named_elts = cl_type.Types.named_elements in + List.fold_left + (collect_function_definitions_in_type ctx) + [] + named_elts + | Types.Record | Types.ExpandableConnector | Types.Connector -> [] + +and collect_function_definitions_in_type ctx fun_defs (id, elt_type) = + let elt_type' = evaluate elt_type in + match elt_type'.Types.dynamic_scope, elt_type'.Types.element_nature with + | None, Types.ClassElement cl_spec -> + let ctx' = + { + ctx with + path = ctx.path @ [Instantiation.Name id] + } in + let cl_spec' = evaluate cl_spec in + let fun_defs' = + collect_function_definitions_in_class_specifier ctx' cl_spec' in + fun_defs' @ fun_defs + | Some _, _ | + None, + (Types.ComponentElement _ | Types.ComponentTypeElement _ | + Types.PredefinedTypeElement _) -> fun_defs + +and collect_function ctx fun_defs cl_type = + match evaluate cl_type.Types.kind with + | Types.Function -> + let named_elts = cl_type.Types.named_elements in + function_description_of_named_elements ctx named_elts :: fun_defs + | Types.Class | Types.Model | Types.Block | Types.Record | + Types.ExpandableConnector | Types.Connector| Types.Package -> fun_defs + +and function_description_of_named_elements ctx named_elts = + let collect_input_or_output (id, elt_type) fun_desc = + let collect_input_or_output' cpnt_type = + match evaluate cpnt_type.Types.causality with + | Types.Input -> + let cl_spec = evaluate cpnt_type.Types.base_class in + { fun_desc with inputs = (id, cl_spec) :: fun_desc.inputs } + | Types.Output -> + let cl_spec = evaluate cpnt_type.Types.base_class in + { fun_desc with outputs = (id, cl_spec) :: fun_desc.outputs } + | Types.Acausal -> fun_desc in + let elt_type' = evaluate elt_type in + match elt_type'.Types.element_nature with + | Types.ComponentElement cpnt_type -> + collect_input_or_output' cpnt_type + | Types.ClassElement _ | Types.ComponentTypeElement _ | + Types.PredefinedTypeElement _ -> fun_desc in + let fun_desc = { inputs = []; outputs = [] } in + ctx, + List.fold_right collect_input_or_output named_elts fun_desc + +and collect_function_definitions_in_component ctx cpnt_desc = + match evaluate cpnt_desc.Instantiation.component_nature with + | Instantiation.DynamicArray cpnt_desc -> + let ctx' = + { ctx with path = ctx.path @ [Instantiation.Index 0] } in + collect_function_definitions_in_component ctx' cpnt_desc + | Instantiation.Instance inst -> + let elts = evaluate inst.Instantiation.elements in + let named_elts = elts.Instantiation.named_elements in + List.fold_left collect_function_definitions [] named_elts + | Instantiation.PredefinedTypeInstance _ -> [] + | Instantiation.StaticArray [||] -> [] + | Instantiation.StaticArray cpnt_descs -> + let ctx' = + { ctx with path = ctx.path @ [Instantiation.Index 0] } in + collect_function_definitions_in_component ctx' cpnt_descs.(0) + +and generate_function_definition oc acc (ctx, fun_desc) = + let ext_name = Printf.sprintf "%s" (last_id ctx.path) + and name = string_of_path ctx.path in + match List.mem ext_name acc with + | true -> acc + | false -> + Printf.fprintf oc "function %s \"%s\"\n" ext_name name; + List.iter (generate_function_inout ctx oc "input") fun_desc.inputs; + List.iter (generate_function_inout ctx oc "output") fun_desc.outputs; + Printf.fprintf oc "external;\nend %s;\n" ext_name; + ext_name :: acc + +and generate_function_inout ctx oc inout (id, cl_spec) = + let generate_dimensions ndims = + let rec generate_dimensions' ndims = + match ndims with + | 0 -> assert false + | 1 -> Printf.fprintf oc ":" + | _ -> Printf.fprintf oc ":, "; generate_dimensions' (ndims - 1) in + match ndims with + | 0 -> () + | _ -> + Printf.fprintf oc "["; + generate_dimensions' ndims; + Printf.fprintf oc "]" in + let rec generate_function_inout' cl_spec ndims = match cl_spec with + | Types.PredefinedType { Types.base_type = Types.RealType } -> + Printf.fprintf oc "\t%s Real" inout; + generate_dimensions ndims; + Printf.fprintf oc " %s;\n" id + | Types.PredefinedType { Types.base_type = Types.IntegerType } + when ndims = 0 && inout = "input" -> + Printf.fprintf oc "\t%s Integer %s;\n" inout id + | Types.PredefinedType { Types.base_type = Types.StringType } + when ndims = 0 && inout = "input" -> + Printf.fprintf oc "\t%s String %s;\n" inout id + | Types.ArrayType (_, cl_spec) when inout = "input" -> + generate_function_inout' cl_spec (ndims + 1) + | _ -> + raise (GenericError + { err_msg = + ["_NotYetImplemented"; "_NonSupportedTypeOfFuncInOut"; id]; + err_info = []; + err_ctx = ctx }) in + generate_function_inout' cl_spec 0 + +and generate_component_description xml init filename fun_defs id cpnt_desc = + let chop_extension s = try Filename.chop_extension s with _ -> s in + let filename = match filename with + | None -> id + | Some s -> chop_extension s in + let ctx = + { + path = cpnt_desc.Instantiation.component_path; + location = cpnt_desc.Instantiation.component_location; + instance_nature = + Instantiation.ComponentElement cpnt_desc.Instantiation.class_name + } + and flat_inst = collect_component_elements cpnt_desc in + generate_dynamic_description ctx xml filename fun_defs id flat_inst; + generate_function_definitions ctx filename fun_defs; + if init then + generate_initial_description ctx filename fun_defs id flat_inst + +and generate_dynamic_description ctx xml filename fun_defs id flat_inst = + let vars = flat_inst.variables + and equs = flat_inst.dynamic_equations + and ext = if xml then ".xml" else ".mo" in + let oc = open_out (filename ^ ext) in + try + if xml then + generate_flatten_XML ctx fun_defs oc id vars equs + else + generate_flatten_instance ctx fun_defs oc id vars equs; + close_out oc; + with exn -> close_out oc; raise exn + +and generate_initial_description ctx filename fun_defs id flat_inst = + let oc = open_out (filename ^ "_init.xml") in + try + let varss = List.map (function Rel r -> r) flat_inst.abstract_relations in + let vars = + List.fold_left add_component flat_inst.variables (List.flatten varss) + and equs = flat_inst.initial_equations in + generate_flatten_XML ctx fun_defs oc id vars equs; + generate_relations filename vars flat_inst.abstract_relations; + close_out oc; + with exn -> close_out oc; raise exn + +and generate_function_definitions ctx filename fun_defs = + let generate_function_definitions' oc = + try + let _ = List.fold_left (generate_function_definition oc) [] fun_defs in + close_out oc + with exn -> close_out oc; raise exn in + match fun_defs with + | [] -> () + | _ -> + let oc = open_out (filename ^ "_functions.mo") in + generate_function_definitions' oc + +and collect_component_elements cpnt_desc = + let ctx = + {path = cpnt_desc.Instantiation.component_path; + location = cpnt_desc.Instantiation.component_location; + instance_nature = + Instantiation.ComponentElement cpnt_desc.Instantiation.class_name} in + match evaluate cpnt_desc.Instantiation.component_nature with + | Instantiation.DynamicArray _ -> + raise (GenericError + { err_msg = ["_NotYetImplemented"; "_DynamicArrayType"]; + err_info = []; + err_ctx = ctx }) + | Instantiation.Instance inst -> collect_instance_elements ctx inst + | Instantiation.PredefinedTypeInstance _ + when is_fixed_parameter cpnt_desc -> + { + variables = []; + dynamic_equations = []; + initial_equations = []; + abstract_relations = [] + } + | Instantiation.PredefinedTypeInstance _ -> + let decl_equs = collect_declaration_equation cpnt_desc in + { + variables = [ cpnt_desc ]; + dynamic_equations = decl_equs; + initial_equations = decl_equs; + abstract_relations = [] + } + | Instantiation.StaticArray cpnt_descs -> + collect_array_elements cpnt_descs + +and collect_instance_elements ctx inst = + let elts = evaluate inst.Instantiation.elements in + let named_elts = elts.Instantiation.named_elements + and unnamed_elts = elts.Instantiation.unnamed_elements in + let flat_inst = collect_instance_named_elements named_elts + and dyn_equs, init_equs = + List.fold_left (collect_equations ctx) ([], []) unnamed_elts in + let init_equs, rels = + List.fold_left + (introduce_derivative_variables ctx) + ([], []) + (dyn_equs @ init_equs) in + { flat_inst with + dynamic_equations = flat_inst.dynamic_equations @ dyn_equs; + initial_equations = flat_inst.initial_equations @ init_equs; + abstract_relations = flat_inst.abstract_relations @ rels + } + +and collect_instance_named_elements named_elts = + let collect_instance_named_elements' flat_inst (_, elt_desc) = + let elt_nat = evaluate elt_desc.Instantiation.element_nature in + match elt_nat with + | Instantiation.Class _ -> flat_inst + | Instantiation.Component cpnt_desc -> + let flat_inst' = collect_component_elements cpnt_desc in + { + variables = flat_inst.variables @ flat_inst'.variables; + dynamic_equations = + flat_inst.dynamic_equations @ flat_inst'.dynamic_equations; + initial_equations = + flat_inst.initial_equations @ flat_inst'.initial_equations; + abstract_relations = + flat_inst.abstract_relations @ flat_inst'.abstract_relations + } in + let flat_inst = + { + variables = []; + dynamic_equations = []; + initial_equations = []; + abstract_relations = [] + } in + List.fold_left collect_instance_named_elements' flat_inst named_elts + +and introduce_derivative_variables ctx (init_equs, rels) equ = + let rec introduce_derivative_variables' expr = match expr with + | Instantiation.BinaryOperation (oper_kind, expr1, expr2) -> + let expr1, cpnt_descs1 = introduce_derivative_variables' expr1 + and expr2, cpnt_descs2 = introduce_derivative_variables' expr2 in + Instantiation.BinaryOperation (oper_kind, expr1, expr2), + cpnt_descs1 @ cpnt_descs2 + | Instantiation.FunctionCall + (Instantiation.PredefinedIdentifier "der", + [ Instantiation.ComponentReference cpnt_desc ]) -> + let cpnt_desc' = component_derivative cpnt_desc in + Instantiation.ComponentReference cpnt_desc', + [ cpnt_desc' ] + | Instantiation.FunctionCall + (Instantiation.PredefinedIdentifier "der", _) -> + raise (GenericError + { err_msg = ["_NotYetImplemented"; "_UnsupportedDerOperArg"]; + err_info = []; + err_ctx = ctx }) (*error*) + | Instantiation.If (alts, default) -> + let f (cond, expr) = + let cond, cpnt_descs1 = introduce_derivative_variables' cond + and expr, cpnt_descs2 = introduce_derivative_variables' expr in + (cond, expr), cpnt_descs1 @ cpnt_descs2 in + let alts, cpnt_descss = List.split (List.map f alts) in + let default, cpnt_descs' = introduce_derivative_variables' default in + Instantiation.If (alts, default), + (List.flatten cpnt_descss) @ cpnt_descs' + | Instantiation.IndexedAccess (expr, exprs) -> + let expr, cpnt_descs = introduce_derivative_variables' expr in + Instantiation.IndexedAccess (expr, exprs), + cpnt_descs + | Instantiation.NoEvent expr -> + let expr, cpnt_descs = introduce_derivative_variables' expr in + Instantiation.NoEvent expr, + cpnt_descs + | Instantiation.UnaryOperation (oper_kind, expr) -> + let expr, cpnt_descs = introduce_derivative_variables' expr in + Instantiation.UnaryOperation (oper_kind, expr), + cpnt_descs + | Instantiation.VectorReduction (exprs, expr) -> + let expr, cpnt_descs = introduce_derivative_variables' expr in + Instantiation.VectorReduction (exprs, expr), + cpnt_descs + | Instantiation.Record record_elts -> + let f (id, expr) = + let expr, cpnt_descs = introduce_derivative_variables' expr in + (id, expr), cpnt_descs in + let record_elts, cpnt_descs = List.split (List.map f record_elts) in + Instantiation.Record record_elts, + List.flatten cpnt_descs + | Instantiation.Tuple exprs -> + let exprs' = List.map introduce_derivative_variables' exprs in + let exprs', cpnt_descs' = List.split exprs' in + Instantiation.Tuple exprs', + List.flatten cpnt_descs' + | Instantiation.Vector exprs -> + let exprs' = Array.map introduce_derivative_variables' exprs in + let exprs', cpnt_descs' = List.split (Array.to_list exprs') in + Instantiation.Vector (Array.of_list exprs'), + List.flatten cpnt_descs' + | Instantiation.FunctionCall (expr, exprs) -> + let exprs' = List.map introduce_derivative_variables' exprs in + let exprs', cpnt_descs' = List.split exprs' in + Instantiation.FunctionCall (expr, exprs'), + List.flatten cpnt_descs' + | Instantiation.ComponentReference cpnt_desc -> expr, [ cpnt_desc ] + | _ -> expr, [] in + match equ with + | Instantiation.Equal (expr1, expr2) -> + let expr1, cpnt_descs1 = introduce_derivative_variables' expr1 + and expr2, cpnt_descs2 = introduce_derivative_variables' expr2 in + let cpnt_descs = + List.fold_left add_component [] (cpnt_descs1 @ cpnt_descs2) in + (Instantiation.Equal (expr1, expr2)) :: init_equs, + (Rel cpnt_descs) :: rels + | Instantiation.ConnectFlows _ | Instantiation.ConditionalEquationE _ | + Instantiation.WhenClauseE _ -> init_equs, rels + +and collect_equations ctx (dyn_equs, init_equs) unnamed_elt = + match unnamed_elt with + | Instantiation.EquationClause (NameResolve.Permanent, equs) -> + dyn_equs @ (expand_equations ctx (evaluate equs)), init_equs + | Instantiation.EquationClause (NameResolve.Initial, equs) -> + dyn_equs, init_equs @ (expand_equations ctx (evaluate equs)) + | Instantiation.AlgorithmClause _ -> + raise (GenericError + { err_msg = ["_NotYetImplemented"; "_AlgorithmClause"]; + err_info = []; + err_ctx = ctx }) (*error*) + +and expand_equations ctx equs = + let expand_equation equ = equ.Instantiation.nature in + let add_connection (expr, sign) (expr', sign') cnect_sets = + let contains_at_least_one_node_to_connect cnect_set = + List.mem_assoc expr cnect_set || List.mem_assoc expr' cnect_set in + let cnect_sets, cnect_sets' = + List.partition contains_at_least_one_node_to_connect cnect_sets in + match cnect_sets with + | [] -> [(expr, sign); (expr', sign')] :: cnect_sets' + | [cnect_set; cnect_set'] -> (cnect_set @ cnect_set') :: cnect_sets' + | [cnect_set] when List.mem_assoc expr cnect_set -> + ((expr', sign') :: cnect_set) :: cnect_sets' + | [cnect_set] -> ((expr, sign) :: cnect_set) :: cnect_sets' + | _ :: _ :: _ :: _ -> assert false in + let expand_connection cnect_sets = function + | Instantiation.ConnectFlows (sign, expr, sign', expr') -> + add_connection (expr, sign) (expr', sign') cnect_sets + | Instantiation.Equal _ | Instantiation.ConditionalEquationE _ | + Instantiation.WhenClauseE _ -> cnect_sets in + let generate_flow_equation cnect_set = + let to_expression (expr, sign) = match sign with + | NameResolve.Positive -> expr + | NameResolve.Negative -> + Instantiation.UnaryOperation (Instantiation.UnaryMinus, expr) in + let add_expressions expr expr' = + Instantiation.BinaryOperation (Instantiation.Plus, expr, expr') in + let exprs = List.map to_expression cnect_set in + let lhs = List.fold_left add_expressions (Instantiation.Real 0.) exprs in + Instantiation.Equal (lhs, Instantiation.Real 0.) in + let collect_equation equs equ = match equ with + | Instantiation.ConnectFlows _ -> equs + | Instantiation.Equal _ | Instantiation.ConditionalEquationE _ | + Instantiation.WhenClauseE _ -> equ :: equs in + let equ_descs = List.flatten (List.map expand_equation equs) in + let cnect_sets = List.fold_left expand_connection [] equ_descs + and equs = List.fold_left collect_equation [] equ_descs in + let equs' = List.map generate_flow_equation cnect_sets in + equs @ equs' + +and collect_array_elements cpnt_descs = + let rec collect_array_elements' flat_inst i = + if i = Array.length cpnt_descs then flat_inst + else + let flat_inst' = collect_component_elements cpnt_descs.(i) in + let flat_inst = + { + variables = flat_inst.variables @ flat_inst'.variables; + dynamic_equations = + flat_inst.dynamic_equations @ flat_inst'.dynamic_equations; + initial_equations = + flat_inst.initial_equations @ flat_inst'.initial_equations; + abstract_relations = + flat_inst.abstract_relations @ flat_inst'.abstract_relations + } in + collect_array_elements' flat_inst (i + 1) in + let flat_inst = + { + variables = []; + dynamic_equations = []; + initial_equations = []; + abstract_relations = [] + } in + collect_array_elements' flat_inst 0 + +and collect_declaration_equation cpnt_desc = + let var = cpnt_desc.Instantiation.variability + and equ = cpnt_desc.Instantiation.declaration_equation in + match var, equ with + | (Types.Continuous | Types.Discrete), Some expr -> + let expr' = Instantiation.ComponentReference cpnt_desc in + [ Instantiation.Equal (expr', evaluate expr) ] + | _ -> [] + +and generate_flatten_instance ctx fun_defs oc id vars equs = + Printf.fprintf oc "class %s\n" id; + List.iter (generate_variable_declaration ctx oc) vars; + Printf.fprintf oc "equation\n"; + generate_equation_descriptions ctx fun_defs oc equs; + Printf.fprintf oc "end %s;\n" id + +and generate_variable_declaration ctx oc cpnt_desc = + Printf.fprintf oc "\t"; + generate_variable_variability oc cpnt_desc; + generate_variable_causality oc cpnt_desc; + generate_variable_type ctx oc cpnt_desc; + generate_variable_name oc cpnt_desc; + generate_variable_start_value ctx oc cpnt_desc; + generate_initialization ctx oc cpnt_desc; + generate_comment oc cpnt_desc; + Printf.fprintf oc ";\n" + +and generate_variable_variability oc cpnt_desc = + match cpnt_desc.Instantiation.variability with + | Types.Constant -> Printf.fprintf oc "constant " + | Types.Parameter -> Printf.fprintf oc "parameter " + | Types.Discrete -> Printf.fprintf oc "discrete " + | Types.Continuous -> () + +and generate_variable_causality oc cpnt_desc = + let inout = cpnt_desc.Instantiation.causality in + match inout with + | Types.Input -> Printf.fprintf oc "input " + | Types.Output -> Printf.fprintf oc "output " + | Types.Acausal -> () + +and generate_variable_type ctx oc cpnt_desc = + let generate_variable_type' predef = + let var = cpnt_desc.Instantiation.variability in + match predef.Instantiation.predefined_type, var with + | Instantiation.IntegerType, Types.Parameter -> + Printf.fprintf oc "Integer " + | Instantiation.IntegerType, _ -> + raise (GenericError + { err_msg = ["_NotYetImplemented"; "_IntegerType"]; + err_info = []; + err_ctx = ctx }) (*error*) + | Instantiation.RealType, _ -> Printf.fprintf oc "Real " + | Instantiation.BooleanType, _ -> + raise (GenericError + { err_msg = ["_NotYetImplemented"; "_BooleanType"]; + err_info = []; + err_ctx = ctx }) (*error*) + | Instantiation.StringType, Types.Parameter -> + Printf.fprintf oc "String " + | Instantiation.StringType, _ -> + raise (GenericError + { err_msg = ["_NotYetImplemented"; "_StringType"]; + err_info = []; + err_ctx = ctx }) (*error*) + | Instantiation.EnumerationType, _ -> + raise (GenericError + { err_msg = ["_NotYetImplemented"; "_EnumType"]; + err_info = []; + err_ctx = ctx }) (*error*) in + let var_type = evaluate cpnt_desc.Instantiation.component_nature in + match var_type with + | Instantiation.PredefinedTypeInstance predef -> + generate_variable_type' predef + | Instantiation.DynamicArray _ -> + raise (GenericError + { err_msg = ["_NotYetImplemented"; "_DynamicArrayType"]; + err_info = []; + err_ctx = ctx }) (*error*) + | Instantiation.Instance _ -> + raise (GenericError + { err_msg = ["_NotYetImplemented"; "_InstanceType"]; + err_info = []; + err_ctx = ctx }) (*error*) + | Instantiation.StaticArray _ -> + raise (GenericError + { err_msg = ["_NotYetImplemented"; "_StaticArrayType"]; + err_info = []; + err_ctx = ctx }) (*error*) + +and generate_variable_name oc cpnt_desc = + let name = ident_of_path cpnt_desc.Instantiation.component_path in + Printf.fprintf oc "%s" name + +and generate_variable_start_value ctx oc cpnt_desc = + let generate_start_value attrs = + try + let expr = evaluate (List.assoc "start" attrs) in + Printf.fprintf oc "(start=%s)" + (string_of_expression ctx [] expr) + with Not_found -> () in + let generate_variable_start_value' predef = + let attrs = predef.Instantiation.attributes in + generate_start_value attrs in + let var_type = evaluate cpnt_desc.Instantiation.component_nature in + match var_type with + | Instantiation.PredefinedTypeInstance predef -> + generate_variable_start_value' predef + | Instantiation.DynamicArray _ -> + raise (GenericError + { err_msg = ["_NotYetImplemented"; "_DynamicArrayType"]; + err_info = []; + err_ctx = ctx }) (*error*) + | Instantiation.Instance _ -> + raise (GenericError + { err_msg = ["_NotYetImplemented"; "_InstanceType"]; + err_info = []; + err_ctx = ctx }) (*error*) + | Instantiation.StaticArray _ -> + raise (GenericError + { err_msg = ["_NotYetImplemented"; "_StaticArrayType"]; + err_info = []; + err_ctx = ctx }) (*error*) + +and string_of_path = function + | [] -> assert false + | [Instantiation.Name id] -> id + | [Instantiation.Index i] -> Printf.sprintf "[%d]" (i + 1) + | Instantiation.Name id :: path -> + Printf.sprintf "%s.%s" id (string_of_path path) + | Instantiation.Index i :: path -> + Printf.sprintf "[%d].%s" (i + 1) (string_of_path path) + +and ident_of_path path = + let rec ident_of_path' path = + match path with + | [] -> assert false + | [Instantiation.Name id] -> unquoted id + | [Instantiation.Index i] -> Printf.sprintf "[%d]" (i + 1) + | Instantiation.Name id :: path -> + Printf.sprintf "%s.%s" (unquoted id) (ident_of_path' path) + | Instantiation.Index i :: path -> + Printf.sprintf "[%d].%s" (i + 1) (ident_of_path' path) in + match path with + | [] -> assert false + | [Instantiation.Name id] -> assert false + | [Instantiation.Index i] -> assert false + | Instantiation.Name id :: path -> + Printf.sprintf "`%s`" (ident_of_path' path) + | Instantiation.Index i :: path -> assert false + +and unquoted id = + let n = String.length id in + try + match id.[0] with + | '`' | '\'' -> String.sub id 1 (n - 2) + | _ -> id + with + | _ -> id + +and generate_initialization ctx oc cpnt_desc = + let var = cpnt_desc.Instantiation.variability + and equ = cpnt_desc.Instantiation.declaration_equation in + match var, equ with + | Types.Parameter, Some expr -> + Printf.fprintf oc " = %s" + (string_of_expression ctx [] (evaluate expr)) + | _ -> () + +and generate_comment oc cpnt_desc = + Printf.fprintf oc " \"%s\"" cpnt_desc.Instantiation.comment + +and generate_equation_descriptions ctx fun_defs oc equ_descs = + List.iter (generate_equation_description ctx fun_defs oc) equ_descs + +and generate_equation_description ctx fun_defs oc equ_desc = + match equ_desc with + | Instantiation.Equal (expr, expr') -> + Printf.fprintf oc "%s" (string_of_equal ctx fun_defs expr expr') + | Instantiation.ConditionalEquationE _ -> assert false + | Instantiation.ConnectFlows _ -> assert false + | Instantiation.WhenClauseE alts -> + generate_when_clause ctx fun_defs oc alts + +and string_of_equal ctx fun_defs expr expr' = match expr with + | Instantiation.Tuple [] -> + Printf.sprintf "\t%s;\n" + (string_of_expression ctx fun_defs expr') + | _ -> + Printf.sprintf "\t%s = %s;\n" + (string_of_expression ctx fun_defs expr) + (string_of_expression ctx fun_defs expr') + +and generate_when_clause ctx fun_defs oc alts = match alts with + | [] -> () + | [ (expr, equs) ] -> + Printf.fprintf oc "when %s then\n" + (string_of_expression ctx fun_defs expr); + List.iter (generate_when_equation ctx fun_defs oc) equs; + Printf.fprintf oc "end when;\n" + | (expr, equs) :: alts -> + Printf.fprintf oc "when %s then\n" + (string_of_expression ctx fun_defs expr); + List.iter (generate_when_equation ctx fun_defs oc) equs; + Printf.fprintf oc "else"; + generate_when_clause ctx fun_defs oc alts + +and generate_when_equation ctx fun_defs oc equ = + let equ' = equ.Instantiation.nature in + generate_equation_descriptions ctx fun_defs oc equ' + +and string_of_expression ctx fun_defs = function + | Instantiation.BinaryOperation (bin_op, expr, expr') -> + string_of_binary_operation ctx fun_defs bin_op expr expr' + | Instantiation.ClassReference cl_def -> + string_of_class_reference fun_defs cl_def + | Instantiation.ComponentReference cpnt_desc -> + ident_of_path cpnt_desc.Instantiation.component_path + | Instantiation.EnumerationElement _ -> + raise (GenericError + { err_msg = [ "_NotYetImplemented"; + "_ExprOfType"; + "enumeration" ]; + err_info = []; + err_ctx = ctx }) (*error*) + | Instantiation.False -> + raise (GenericError + { err_msg = ["_NotYetImplemented"; "_Expr"; "false"]; + err_info = []; + err_ctx = ctx }) (*error*) + | Instantiation.FieldAccess _ -> + raise (GenericError + { err_msg = ["_NotYetImplemented"; "_FieldAccessExpr"]; + err_info = []; + err_ctx = ctx }) (*error*) + | Instantiation.FunctionCall (expr, exprs) -> + string_of_function_call ctx fun_defs expr exprs + | Instantiation.If (alts, expr) -> + string_of_if ctx fun_defs alts expr + | Instantiation.IndexedAccess _ -> + raise (GenericError + { err_msg = ["_NotYetImplemented"; "_IndexedAccessExpr"]; + err_info = []; + err_ctx = ctx }) (*error*) + | Instantiation.Integer i when Int32.to_int i >= 0 -> + Printf.sprintf "%ld" i + | Instantiation.Integer i -> + let expr = Instantiation.Integer (Int32.neg i) + and un_op = Instantiation.UnaryMinus in + string_of_unary_operation ctx fun_defs un_op expr + | Instantiation.LoopVariable _ -> + raise (GenericError + { err_msg = ["_NotYetImplemented"; "_LoopVar"]; + err_info = []; + err_ctx = ctx }) (*error*) + | Instantiation.NoEvent expr -> string_of_no_event ctx fun_defs expr + | Instantiation.PredefinedIdentifier id -> Printf.sprintf "%s" id + | Instantiation.Range _ -> + raise (GenericError + { err_msg = ["_NotYetImplemented"; "_RangeExpr"]; + err_info = []; + err_ctx = ctx }) (*error*) + | Instantiation.Real f -> + Printf.sprintf "%s" (string_of_float f) + | Instantiation.Record _ -> + raise (GenericError + { err_msg = ["_NotYetImplemented"; "_ExprOfType"; "record"]; + err_info = []; + err_ctx = ctx }) (*error*) + | Instantiation.String s -> Printf.sprintf "\"%s\"" s + | Instantiation.True -> + raise (GenericError + { err_msg = ["_NotYetImplemented"; "_Expr"; "true"]; + err_info = []; + err_ctx = ctx }) (*error*) + | Instantiation.Tuple _ -> + raise (GenericError + { err_msg = ["_NotYetImplemented"; "_TupleExpr"]; + err_info = []; + err_ctx = ctx }) (*error*) + | Instantiation.UnaryOperation (un_op, expr) -> + string_of_unary_operation ctx fun_defs un_op expr + | Instantiation.Vector exprs -> + string_of_vector ctx fun_defs exprs + | Instantiation.VectorReduction _ -> + raise (GenericError + { err_msg = ["_NotYetImplemented"; "_VectorReduct"]; + err_info = []; + err_ctx = ctx }) (*error*) + +and string_of_binary_operation ctx fun_defs bin_op expr expr' = + let string_of_binary_operation_kind = function + | Instantiation.And -> "and" + | Instantiation.Divide -> "/" + | Instantiation.EqualEqual -> "==" + | Instantiation.GreaterEqual -> ">=" + | Instantiation.Greater -> ">" + | Instantiation.LessEqual -> "<=" + | Instantiation.Less -> "<" + | Instantiation.Times -> "*" + | Instantiation.NotEqual -> "<>" + | Instantiation.Or -> "or" + | Instantiation.Plus -> "+" + | Instantiation.Power -> "^" + | Instantiation.Minus -> "-" in + Printf.sprintf "(%s %s %s)" + (string_of_expression ctx fun_defs expr) + (string_of_binary_operation_kind bin_op) + (string_of_expression ctx fun_defs expr') + +and string_of_class_reference fun_defs cl_def = + let rec last = function + | [] -> assert false + | [Instantiation.Name id] -> id + | [Instantiation.Index _] -> assert false + | _ :: path -> last path in + let ctx = + { + path = cl_def.Instantiation.class_path; + location = cl_def.Instantiation.class_location; + instance_nature = Instantiation.ClassElement + } in + let string_of_external_call ext_call = + match ext_call.NameResolve.nature with + | NameResolve.PrimitiveCall "builtin" | + NameResolve.PrimitiveCall "C" -> last ctx.path + | NameResolve.PrimitiveCall lang -> + raise (GenericError + { err_msg = ["_NotYetImplemented"; + "_ExternalCallToLanguage"; + lang]; + err_info = []; + err_ctx = ctx }) (*error*) + | NameResolve.ExternalProcedureCall _ -> + raise (GenericError + { err_msg = ["_NotYetImplemented"; + "_ExternalProcedureCall"]; + err_info = []; + err_ctx = ctx }) (*error*) in + let string_of_long_description long_desc = + match evaluate long_desc.NameResolve.external_call with + | None -> + raise (GenericError + { err_msg = ["_NotYetImplemented"; + "_NonExternalCallClassRef"]; + err_info = []; + err_ctx = ctx }) (*error*) + | Some ext_call -> string_of_external_call ext_call in + match cl_def.Instantiation.description with + | Instantiation.ClassDescription (_, cl_desc) -> + string_of_long_description cl_desc.Instantiation.long_description + | Instantiation.PredefinedType _ -> + raise (GenericError + { err_msg = ["_NotYetImplemented"; + "_PredefinedTypeClassRef"]; + err_info = []; + err_ctx = ctx }) (*error*) + +and string_of_function_call ctx fun_defs expr exprs = + Printf.sprintf "%s(%s)" + (string_of_expression ctx fun_defs expr) + (string_of_expressions ctx fun_defs exprs) + +and string_of_expressions ctx fun_defs exprs = + String.concat ", " (List.map (string_of_expression ctx fun_defs) exprs) + +and string_of_if ctx fun_defs alts expr = + let rec string_of_alternatives = function + | [] -> Printf.sprintf " %s" (string_of_expression ctx fun_defs expr) + | (expr, expr') :: alts -> + Printf.sprintf "(if %s then %s else%s)" + (string_of_expression ctx fun_defs expr) + (string_of_expression ctx fun_defs expr') + (string_of_alternatives alts) in + string_of_alternatives alts + +and string_of_no_event ctx fun_defs expr = + Printf.sprintf "noEvent(%s)" + (string_of_expression ctx fun_defs expr) + +and string_of_unary_operation ctx fun_defs un_op expr = + let string_of_unary_operation_kind = function + | Instantiation.Not -> "not" + | Instantiation.UnaryMinus -> "-" in + Printf.sprintf "(%s %s)" + (string_of_unary_operation_kind un_op) + (string_of_expression ctx fun_defs expr) + +and string_of_vector ctx fun_defs exprs = + let exprs' = Array.to_list exprs in + Printf.sprintf "{ %s }" + (string_of_expressions ctx fun_defs exprs') + +and last_id path = + let rec last_id' id path = match path with + | [] -> id + | (Instantiation.Name id) :: path -> last_id' id path + | (Instantiation.Index _) :: path -> last_id' id path in + last_id' "" path + +and string_of_float f = + let add_parenthesis s = + if String.contains s '-' then Printf.sprintf "(%s)" s else s in + match Printf.sprintf "%.16g" f with + | s when (String.contains s '.') || (String.contains s 'e') -> + add_parenthesis s + | s -> add_parenthesis (Printf.sprintf "%s." s) + +and component_derivative cpnt_desc = + let derivative_path path = + let rec derivative_path' path = + match path with + | [] -> assert false + | (Instantiation.Name s) :: path -> + (Instantiation.Name ("__der_" ^ s)) :: path + | (Instantiation.Index i) :: path -> + (Instantiation.Index i) :: (derivative_path' path) in + List.rev (derivative_path' (List.rev path)) in + let path = cpnt_desc.Instantiation.component_path in + let id = unquoted (ident_of_path path) in + let component_derivative_nature cpnt_desc = + match evaluate cpnt_desc.Instantiation.component_nature with + | Instantiation.PredefinedTypeInstance predef_type_inst -> + let attribs = [ "start", lazy (Instantiation.Real 0.) ] in + Instantiation.PredefinedTypeInstance + { predef_type_inst with Instantiation.attributes = attribs } + | cpnt_nat -> cpnt_nat in + { + cpnt_desc with + Instantiation.component_path = derivative_path path; + Instantiation.component_nature = + lazy (component_derivative_nature cpnt_desc); + Instantiation.declaration_equation = None; + Instantiation.comment = "Time derivative of " ^ id + } + +and add_component cpnt_descs cpnt_desc = + let equal_components cpnt_desc cpnt_desc' = + cpnt_desc.Instantiation.component_path = + cpnt_desc'.Instantiation.component_path in + match List.exists (equal_components cpnt_desc) cpnt_descs with + | false -> cpnt_desc :: cpnt_descs + | true -> cpnt_descs + +and is_fixed_parameter cpnt_desc = + match cpnt_desc.Instantiation.variability with + | Types.Constant -> true + | Types.Parameter -> is_fixed cpnt_desc + | _ -> false + +and is_fixed cpnt_desc = + let var = cpnt_desc.Instantiation.variability + and cpnt_nat = evaluate cpnt_desc.Instantiation.component_nature in + let bool_of_fixed predef = + match evaluate (List.assoc "fixed" predef.Instantiation.attributes) with + | Instantiation.False -> false + | _ -> true in + match var, cpnt_nat with + | Types.Constant, _ -> true + | _, Instantiation.PredefinedTypeInstance predef + when List.mem_assoc "fixed" predef.Instantiation.attributes -> + bool_of_fixed predef + | Types.Parameter, _ -> true + | _ -> false + +and defined_attribute cpnt_desc attrib_name = + match evaluate cpnt_desc.Instantiation.component_nature with + | Instantiation.PredefinedTypeInstance predef -> + List.mem_assoc "fixed" predef.Instantiation.attributes + | _ -> false + +and generate_relations filename vars rels = + let add_indentifier_stats stats cpnt_desc = + match + cpnt_desc.Instantiation.variability, + cpnt_desc.Instantiation.causality, + Lazy.force cpnt_desc.Instantiation.component_nature + with + | Types.Parameter, _, + Instantiation.PredefinedTypeInstance + { Instantiation.predefined_type = Instantiation.IntegerType } -> + { stats with nb_ipars = stats.nb_ipars + 1 } + | Types.Parameter, _, + Instantiation.PredefinedTypeInstance + { Instantiation.predefined_type = Instantiation.RealType } -> + { stats with nb_rpars = stats.nb_rpars + 1 } + | Types.Parameter, _, + Instantiation.PredefinedTypeInstance + { Instantiation.predefined_type = Instantiation.StringType } -> + { stats with nb_spars = stats.nb_spars + 1 } + | Types.Discrete, _, _ -> { stats with nb_dvars = stats.nb_dvars + 1 } + | Types.Continuous, Types.Input, _ -> + { stats with nb_inps = stats.nb_inps + 1 } + | Types.Continuous, Types.Output, _ -> + { stats with + nb_cvars = stats.nb_cvars + 1; + nb_outps = stats.nb_outps + 1 + } + | Types.Continuous, Types.Acausal, _ -> + { stats with nb_cvars = stats.nb_cvars + 1 } + | _ -> stats in + let variable_id cpnt_desc = + let name = ident_of_path cpnt_desc.Instantiation.component_path in + hide_spc (unquoted name) in + let generate_identifier oc tabs cpnt_desc = + let rec generate_tabs tabs = + if tabs > 0 then begin + Printf.fprintf oc "\t"; generate_tabs (tabs - 1) + end in + match + cpnt_desc.Instantiation.variability, + cpnt_desc.Instantiation.causality + with + | Types.Parameter, _ -> + let id = variable_id cpnt_desc in + generate_tabs tabs; + Printf.fprintf oc "%s\n" id + | Types.Constant, _ -> () + | _, (Types.Acausal | Types.Output) -> + let id = variable_id cpnt_desc in + generate_tabs tabs; + Printf.fprintf oc "%s\n" id + | _, Types.Input -> + let id = variable_id cpnt_desc in + generate_tabs tabs; + Printf.fprintf oc "%s\n" id in + let generate_relation oc rel = + match rel with + | Rel cpnt_descs -> + Printf.fprintf oc "\t\t\n"; + List.iter (generate_identifier oc 3) cpnt_descs; + Printf.fprintf oc "\t\t\n" in + let generate_output oc cpnt_desc = + match + cpnt_desc.Instantiation.variability, + cpnt_desc.Instantiation.causality + with + | (Types.Parameter | Types.Constant), _ | + _, (Types.Acausal | Types.Input) -> () + | _, Types.Output -> + let id = variable_id cpnt_desc in + Printf.fprintf oc + "\t\t\n\ + \t\t\t%s\n\ + \t\t\t\n\ + \t\t\t\t%s\n\ + \t\t\t\n\ + \t\t\n" + id + id in + let oc' = open_out (filename ^ "_relations.xml") in + Printf.fprintf oc' "\n"; + let stats = + List.fold_left + add_indentifier_stats + { + nb_ipars = 0; + nb_rpars = 0; + nb_spars = 0; + nb_dvars = 0; + nb_cvars = 0; + nb_inps = 0; + nb_outps = 0 + } + vars in + Printf.fprintf oc' + "\t\n\ + \t\t%d\n\ + \t\t%d\n\ + \t\t%d\n\ + \t\t%d\n\ + \t\t%d\n\ + \t\t%d\n\ + \t\t%d\n\ + \t\t%d\n\ + \t\n" + stats.nb_ipars + stats.nb_rpars + stats.nb_spars + stats.nb_dvars + stats.nb_cvars + stats.nb_cvars + stats.nb_inps + stats.nb_outps; + Printf.fprintf oc' "\t\n"; + List.iter (generate_identifier oc' 2) vars; + Printf.fprintf oc' "\t\n"; + Printf.fprintf oc' "\t\n"; + List.iter (generate_relation oc') rels; + Printf.fprintf oc' "\t\n"; + Printf.fprintf oc' "\t\n"; + List.iter (generate_output oc') vars; + Printf.fprintf oc' "\t\n"; + Printf.fprintf oc' "\n"; + close_out oc' + +and generate_flatten_XML ctx fun_defs oc id vars equs = + let print_when_clause equ = + let string_of_equation equ = + let string_of_equation' equ_desc = match equ_desc with + | Instantiation.Equal (expr, expr') -> + hide_spc (string_of_equal ctx fun_defs expr expr') + | _ -> assert false in + String.concat + " " + (List.map string_of_equation' equ.Instantiation.nature) in + let rec string_of_when_clause alts = match alts with + | [] -> "" + | [ (expr, equs) ] -> + Printf.sprintf "when %s then\n %s end when;\n" + (string_of_expression ctx fun_defs expr) + (String.concat " " (List.map string_of_equation equs)) + | (expr, equs) ::