(* * 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. * *) open Precompilation (* Misc *) let opt_map f = function | Some x -> Some (f x) | None -> None (* Exceptions *) exception InvalidModification exception TypeError (* Datatypes *) type compilation_context = | ClassContext of compilation_context * compiled_class Lazy.t | ForContext of compilation_context * string | ModificationContext of compilation_context * compiled_class Lazy.t | TopLevelContext of (string * compiled_unit) list and compiled_unit = | CompiledClass of compiled_class Lazy.t | CompiledFunction of compiled_class Lazy.t and compiled_class = { ccl_public_cpnts: (string * compiled_component Lazy.t) list Lazy.t; ccl_initial_equs: compiled_equation list Lazy.t; ccl_equs: compiled_equation list Lazy.t; } and compiled_modification = | CompiledModification of field * compiled_modification list * compiled_expression option and field = string * compiled_subscript array and compiled_reference = | ParameterReference of level * path | VariableReference of level * path | LoopVariableReference of level | ClassReference of level * string list and path = field list and level = int and compiled_subscript = | Indefinite | Definite of compiled_expression and parameter = | IntegerParameter of parameter_attributes | StringParameter of parameter_attributes | RealParameter of parameter_attributes and parameter_attributes = { pat_dimensions: compiled_subscript array; pat_comment: string; pat_value: compiled_expression option; pat_infos: variable_infos } and variable = | IntegerVariable of variable_attributes | StringVariable of variable_attributes | DiscreteVariable of variable_attributes | RealVariable of variable_attributes | CompoundVariable of compiled_class Lazy.t * variable_attributes and variable_attributes = { vat_dimensions: compiled_subscript array; vat_nature: nature; vat_inout: inout; vat_comment: string; vat_modifications: compiled_modification list; vat_infos: variable_infos } and compiled_component = | Parameter of parameter | Variable of variable and nature = | Flow | Potential and inout = | Input | Output | Both and variable_infos = { var_name: string; title: string; unit: string; quantity: string; min: string; max: string; port_name: string; port_type: string; order: int; io: int; weight: float } and compiled_equation = | CompiledEquality of compiled_expression * compiled_expression | CompiledFlowConnection of compiled_expression * compiled_expression | CompiledIf of (compiled_expression * compiled_equation list) list * compiled_equation list | CompiledFor of compiled_expression * compiled_expression * compiled_expression * compiled_equation list | CompiledWhen of (compiled_expression * compiled_when_expression list) list and compiled_when_expression = | Reinit of compiled_reference * compiled_expression | Assign of compiled_reference * compiled_expression and compiled_expression = | Abs of compiled_expression | Acos of compiled_expression | Acosh of compiled_expression | Addition of compiled_expression * compiled_expression | And of compiled_expression * compiled_expression | Asin of compiled_expression | Asinh of compiled_expression | Atan of compiled_expression | Atanh of compiled_expression | Boolean of bool | Cardinality of compiled_expression | Cos of compiled_expression | Cosh of compiled_expression | Der of compiled_expression | Division of compiled_expression * compiled_expression | Equals of compiled_expression * compiled_expression | Exp of compiled_expression | ExternalFunctionCall of string list * compiled_class Lazy.t * compiled_argument list | Floor of compiled_expression | GreaterEqualThan of compiled_expression * compiled_expression | GreaterThan of compiled_expression * compiled_expression | If of (compiled_expression * compiled_expression) list * compiled_expression | Integer of int32 | Log of compiled_expression | Max of compiled_expression * compiled_expression | Min of compiled_expression * compiled_expression | Minus of compiled_expression | Mod of compiled_expression * compiled_expression | Multiplication of compiled_expression * compiled_expression | NoEvent of compiled_expression | Not of compiled_expression | NotEquals of compiled_expression * compiled_expression | Or of compiled_expression * compiled_expression | Power of compiled_expression * compiled_expression | Pre of compiled_expression | Real of float | Reference of compiled_reference | Sin of compiled_expression | Sinh of compiled_expression | Sqrt of compiled_expression | String of string | Subtraction of compiled_expression * compiled_expression | Tan of compiled_expression | Tanh of compiled_expression | Time | Vector of compiled_expression array and compiled_argument = | ScalarArgument of compiled_expression | ArrayArgument of int list * compiled_expression array (* Marshaling *) let paths = ref [""] (*current searching path (for marshaling) *) let read_class_file f = let rec read_class_file' = function | [] -> let s = Filename.chop_extension f in failwith ("read_class_file: Class " ^ s ^ " not found") | s :: ss -> try let ic = open_in_bin (Filename.concat s f) in let paths', cu = (Marshal.from_channel ic : string list ref * compiled_unit) in paths' := !paths; (* **side effect**: Updating new path before evaluating lazy values *) cu with | Sys_error _ -> read_class_file' ss in read_class_file' !paths let rec last = function | [] -> failwith "last" | [x] -> x | _ :: xs -> last xs let write_class_file f cu = let oc = open_out_bin f and flags = [Marshal.Closures] in Marshal.to_channel oc (paths, cu : string list ref * compiled_unit) flags let create_filename name ext = let rec create_name prefix = function | [] -> failwith "create_name: Empty name" | [s] -> prefix, s | s :: ss -> create_name (prefix @ [s]) ss in let prefix, base = create_name [] name in List.fold_right Filename.concat prefix (base ^ ext) let rec get_compiled_class ctx name = let name' = last name in match ctx with | ClassContext (ctx', _) | ForContext (ctx', _) | ModificationContext (ctx', _) -> get_compiled_class ctx' name | TopLevelContext funcs when List.mem_assoc name' funcs -> List.assoc name' funcs | TopLevelContext funcs -> let f = create_filename name ".moc" in read_class_file f (* Compilation *) let rec compile_main_class pcls = let add_class (cls, funcs) (id, pcl) = match pcl.class_kind with | ParseTree.Function -> cls, (id, pcl) :: funcs | ParseTree.Class | ParseTree.Model -> (id, pcl) :: cls, funcs | _ -> failwith "compile_main_class: Only external functions, models and \ classes allowed" in let pcls = List.flatten (List.map (function pcl -> pcl.public_classes) pcls) in match List.fold_left add_class ([], []) pcls with | [], _ -> failwith "compile_main_class: No main class declared" | [id, pcl], funcs -> let compile_function (id, pcl) = id, CompiledFunction (compile_compound_class (TopLevelContext []) pcl) in let funcs' = List.map compile_function funcs in id, CompiledClass (compile_compound_class (TopLevelContext funcs') pcl) | _ :: _, _ -> failwith "compile_main_class: More than one class declared at toplevel" and compile_compound_class ctx pcl = let rec ctx' = ClassContext (ctx, lccl) and defined_equs = lazy (compile_equation_clauses ctx' pcl.equs) and lccl = lazy { ccl_public_cpnts = lazy (compile_components ctx' 0 pcl.public_cpnts); ccl_initial_equs = lazy (fst (Lazy.force defined_equs)); ccl_equs = lazy (snd (Lazy.force defined_equs)) } in lccl and compile_components ctx i cpnts = match cpnts with | [] -> [] | (id, cpnt) :: cpnts -> (id, lazy (compile_component ctx i id cpnt)) :: compile_components ctx (i + 1) cpnts and compile_equation_clauses ctx equ_clauses = let rec compile_equation_clauses' init_equs equs = function | [] -> init_equs, equs | ParseTree.EquationClause (ParseTree.Initial, pt_equs) :: equ_clauses -> let init_equs' = List.fold_left (fun init_equs pt_equ -> (compile_equation_or_annotation ctx pt_equ) @ init_equs) init_equs pt_equs in compile_equation_clauses' init_equs' equs equ_clauses | ParseTree.EquationClause (ParseTree.NotInitial, pt_equs) :: equ_clauses -> let equs' = List.fold_left (fun equs pt_equ -> (compile_equation_or_annotation ctx pt_equ) @ equs) equs pt_equs in compile_equation_clauses' init_equs equs' equ_clauses in compile_equation_clauses' [] [] equ_clauses and compile_equation_or_annotation ctx = function | ParseTree.Equation (equ, _) -> compile_equation ctx equ | ParseTree.EquationAnnotation _ -> failwith "compile_equation: Annotations not allowed" and compile_equation ctx = function | ParseTree.Equality (expr, expr') -> let cexpr = compile_expression ctx expr and cexpr' = compile_expression ctx expr' in [CompiledEquality (cexpr, cexpr')] | ParseTree.ConnectClause (conn_ref, conn_ref') -> let var = find_connector ctx conn_ref and var' = find_connector ctx conn_ref' in begin match var, var' with | CompoundVariable (lccl, attrs), CompoundVariable (lccl', attrs') -> compile_connection ctx conn_ref conn_ref' lccl attrs lccl' attrs' | _ -> failwith "compile_equation: Invalid connection" end | ParseTree.WhenClauseE when_clauses -> [CompiledWhen (List.map (compile_when_clause ctx) when_clauses)] | ParseTree.ConditionalEquationE (if_clauses, equs) -> let cif_clauses = List.map (compile_if_clause ctx) if_clauses and cequs = List.fold_left (fun equs equ -> compile_equation ctx equ @ equs) [] equs in [CompiledIf (cif_clauses, cequs)] | ParseTree.ForClauseE (for_indices, equs) -> compile_for_clause ctx for_indices equs | ParseTree.FunctionCallE _ -> failwith "compile_equation: Unsupported equation type" and find_connector ctx conn_ref = match ctx, conn_ref with | ClassContext (_, lccl), [(s, array_subscr)] when List.mem_assoc s (Lazy.force (Lazy.force lccl).ccl_public_cpnts) -> let ccl = Lazy.force lccl in begin match Lazy.force (List.assoc s (Lazy.force ccl.ccl_public_cpnts)) with | Variable var -> var | _ -> failwith "find_connector: Bad reference" end | ClassContext _, [(s, _)] -> failwith ("find_connector: unknown identifier: " ^ s) | ClassContext (_, lccl), (s, array_subscr) :: ([(s', array_subscr')] as conn_ref') when List.mem_assoc s (Lazy.force (Lazy.force lccl).ccl_public_cpnts) -> let ccl = Lazy.force lccl in begin match Lazy.force (List.assoc s (Lazy.force ccl.ccl_public_cpnts)) with | Variable (CompoundVariable (lccl', _)) -> let ctx' = ClassContext (ctx, lccl') in find_connector ctx' conn_ref' | _ -> failwith "find_connector: Bad reference" end | ClassContext _, (s, _) :: _ -> failwith ("find_connector: unknown identifier: " ^ s) | ClassContext (_, lccl), [] -> failwith "find_connector: empty reference" | ForContext (_, id), _ -> failwith ("find_connector: connector defined in a for loop on variable " ^ id) | _ -> assert false and compile_connection ctx conn_ref conn_ref' lccl attrs lccl' attrs' = let create_connection (s, lcpnt) = match Lazy.force lcpnt with | Variable (RealVariable { vat_nature = Flow }) -> let cref = compile_component_reference ctx (conn_ref @ [(s, [||])]) and cref' = compile_component_reference ctx (conn_ref' @ [(s, [||])]) in CompiledFlowConnection (Reference cref, Reference cref') | Variable (RealVariable { vat_nature = Potential }) -> let cref = compile_component_reference ctx (conn_ref @ [(s, [||])]) and cref' = compile_component_reference ctx (conn_ref' @ [(s, [||])]) in CompiledEquality (Reference cref, Reference cref') | _ -> failwith "compile_connection: Invalid connector" in List.map create_connection (Lazy.force (Lazy.force lccl).ccl_public_cpnts) (*FIXME: check class equality *) and compile_if_clause ctx = function | expr, equs -> compile_expression ctx expr, List.fold_left (fun equs equ -> compile_equation ctx equ @ equs) [] equs and compile_when_clause ctx = function | expr, when_equs -> compile_expression ctx expr, List.map (compile_when_equation ctx) when_equs and compile_when_equation ctx = function | ParseTree.FunctionCallE ([("reinit", [||])], Some (ParseTree.ArgList ([ParseTree.Reference cpnt_ref; expr] , None))) -> Reinit ( compile_component_reference ctx cpnt_ref, compile_expression ctx expr) | ParseTree.Equality (ParseTree.Reference cpnt_ref, expr) -> Assign ( compile_component_reference ctx cpnt_ref, compile_expression ctx expr) | _ -> failwith "compile_when_equation: Invalid equation" and compile_for_clause ctx for_indices equs = match for_indices with | [] -> List.fold_left (fun equs equ -> compile_equation ctx equ @ equs) [] equs | ( s, Some (ParseTree.Range (expr, expr', None))) :: for_indices' -> let cexpr = compile_expression ctx expr and cexpr' = compile_expression ctx expr' and ctx' = ForContext (ctx, s) in let cfor = compile_for_clause ctx' for_indices' equs in [CompiledFor (cexpr, cexpr', Integer (Int32.one), cfor)] | ( s, Some (ParseTree.Range (expr, expr', Some expr''))) :: for_indices' -> let cexpr = compile_expression ctx expr and cexpr' = compile_expression ctx expr' and cexpr'' = compile_expression ctx expr'' and ctx' = ForContext (ctx, s) in let cfor = compile_for_clause ctx' for_indices' equs in [CompiledFor (cexpr, cexpr', cexpr'', cfor)] | _ -> failwith "compile_for_clause: Invalid range" and compile_expression ctx expr = let rec compile_expression' = function | ParseTree.Addition (expr, expr') -> let cexpr = compile_expression' expr and cexpr' = compile_expression' expr' in Addition (cexpr, cexpr') | ParseTree.And (expr, expr') -> let cexpr = compile_expression' expr and cexpr' = compile_expression' expr' in And (cexpr, cexpr') | ParseTree.Division (expr, expr') -> let cexpr = compile_expression' expr and cexpr' = compile_expression' expr' in Division (cexpr, cexpr') | ParseTree.End -> failwith "compile_expression: end keyword not allowed" | ParseTree.Equals (expr, expr') -> let cexpr = compile_expression' expr and cexpr' = compile_expression' expr' in Equals (cexpr, cexpr') | ParseTree.ExpressionList [|expr|] -> compile_expression' expr | ParseTree.ExpressionList exprs -> failwith "compile_expression: expression lists not allowed" | ParseTree.False -> Boolean false | ParseTree.FunctionCall ([("noEvent", [||])], Some (ParseTree.ArgList ([expr] , None))) -> let cexpr = compile_expression' expr in NoEvent cexpr | ParseTree.FunctionCall ([("der", [||])], Some (ParseTree.ArgList ([expr] , None))) -> let cexpr = compile_expression' expr in Der cexpr | ParseTree.FunctionCall ([("pre", [||])], Some (ParseTree.ArgList ([expr] , None))) -> let cexpr = compile_expression' expr in Pre cexpr | ParseTree.FunctionCall ([("floor", [||])], Some (ParseTree.ArgList ([expr] , None))) -> let cexpr = compile_expression' expr in Floor cexpr | ParseTree.FunctionCall ([("max", [||])], Some (ParseTree.ArgList ([expr; expr'] , None))) -> let cexpr = compile_expression' expr and cexpr' = compile_expression' expr' in Max (cexpr, cexpr') | ParseTree.FunctionCall ([("min", [||])], Some (ParseTree.ArgList ([expr; expr'] , None))) -> let cexpr = compile_expression' expr and cexpr' = compile_expression' expr' in Min (cexpr, cexpr') | ParseTree.FunctionCall ([("mod", [||])], Some (ParseTree.ArgList ([expr; expr'] , None))) -> let cexpr = compile_expression' expr and cexpr' = compile_expression' expr' in Mod (cexpr, cexpr') | ParseTree.FunctionCall ([("cardinality", [||])], Some (ParseTree.ArgList ([expr] , None))) -> let cexpr = compile_expression' expr in Cardinality cexpr | ParseTree.FunctionCall ([("abs", [||])], Some (ParseTree.ArgList ([expr] , None))) -> let cexpr = compile_expression' expr in Abs cexpr | ParseTree.FunctionCall ([("sin", [||])], Some (ParseTree.ArgList ([expr] , None))) -> let cexpr = compile_expression' expr in Sin cexpr | ParseTree.FunctionCall ([("cos", [||])], Some (ParseTree.ArgList ([expr] , None))) -> let cexpr = compile_expression' expr in Cos cexpr | ParseTree.FunctionCall ([("tan", [||])], Some (ParseTree.ArgList ([expr] , None))) -> let cexpr = compile_expression' expr in Tan cexpr | ParseTree.FunctionCall ([("asin", [||])], Some (ParseTree.ArgList ([expr] , None))) -> let cexpr = compile_expression' expr in Asin cexpr | ParseTree.FunctionCall ([("acos", [||])], Some (ParseTree.ArgList ([expr] , None))) -> let cexpr = compile_expression' expr in Acos cexpr | ParseTree.FunctionCall ([("atan", [||])], Some (ParseTree.ArgList ([expr] , None))) -> let cexpr = compile_expression' expr in Atan cexpr | ParseTree.FunctionCall ([("sinh", [||])], Some (ParseTree.ArgList ([expr] , None))) -> let cexpr = compile_expression' expr in Sinh cexpr | ParseTree.FunctionCall ([("cosh", [||])], Some (ParseTree.ArgList ([expr] , None))) -> let cexpr = compile_expression' expr in Cosh cexpr | ParseTree.FunctionCall ([("tanh", [||])], Some (ParseTree.ArgList ([expr] , None))) -> let cexpr = compile_expression' expr in Tanh cexpr | ParseTree.FunctionCall ([("asinh", [||])], Some (ParseTree.ArgList ([expr] , None))) -> let cexpr = compile_expression' expr in Asinh cexpr | ParseTree.FunctionCall ([("acosh", [||])], Some (ParseTree.ArgList ([expr] , None))) -> let cexpr = compile_expression' expr in Acosh cexpr | ParseTree.FunctionCall ([("atanh", [||])], Some (ParseTree.ArgList ([expr] , None))) -> let cexpr = compile_expression' expr in Atanh cexpr | ParseTree.FunctionCall ([("exp", [||])], Some (ParseTree.ArgList ([expr] , None))) -> let cexpr = compile_expression' expr in Exp cexpr | ParseTree.FunctionCall ([("log", [||])], Some (ParseTree.ArgList ([expr] , None))) -> let cexpr = compile_expression' expr in Log cexpr | ParseTree.FunctionCall ([("log10", [||])], Some (ParseTree.ArgList ([expr] , None))) -> let cexpr = compile_expression' expr in Division (Log cexpr, Log (Real 10.)) | ParseTree.FunctionCall ([("sqrt", [||])], Some (ParseTree.ArgList ([expr] , None))) -> let cexpr = compile_expression' expr in Sqrt cexpr | ParseTree.FunctionCall (path, Some (ParseTree.ArgList (exprs , None))) -> let cexprs = List.map compile_expression' exprs and name, lccl = get_function_from path in ExternalFunctionCall (name, lccl, List.map to_argument cexprs) | ParseTree.FunctionCall _ -> failwith "compile_expression: invalid function call" | ParseTree.GreaterEqualThan (expr, expr') -> let cexpr = compile_expression' expr and cexpr' = compile_expression' expr' in GreaterEqualThan (cexpr, cexpr') | ParseTree.GreaterThan (expr, expr') -> let cexpr = compile_expression' expr and cexpr' = compile_expression' expr' in GreaterThan (cexpr, cexpr') | ParseTree.If (assocs, expr) -> compile_if assocs expr | ParseTree.Integer s ->Integer (Int32.of_string s) | ParseTree.LessEqualThan (expr, expr') -> let cexpr = compile_expression' expr and cexpr' = compile_expression' expr' in GreaterEqualThan (cexpr', cexpr) | ParseTree.LessThan (expr, expr') -> let cexpr = compile_expression' expr and cexpr' = compile_expression' expr' in GreaterThan (cexpr', cexpr) | ParseTree.ArrayConcatenation exprss -> failwith "compile_expression: array concatenation not allowed" | ParseTree.Minus expr -> Minus (compile_expression' expr) | ParseTree.Multiplication (expr, expr') -> let cexpr = compile_expression' expr and cexpr' = compile_expression' expr' in Multiplication (cexpr, cexpr') | ParseTree.Not expr -> Not (compile_expression' expr) | ParseTree.NotEquals (expr, expr') -> let cexpr = compile_expression' expr and cexpr' = compile_expression' expr' in NotEquals (cexpr, cexpr') | ParseTree.Or (expr, expr') -> let cexpr = compile_expression' expr and cexpr' = compile_expression' expr' in Or (cexpr, cexpr') | ParseTree.Plus expr -> compile_expression' expr | ParseTree.Power (expr, expr') -> let cexpr = compile_expression' expr and cexpr' = compile_expression' expr' in Power (cexpr, cexpr') | ParseTree.Range (expr, expr', expr_opt) -> failwith "compile_expression: ranges not allowed" | ParseTree.Real s -> Real (float_of_string s) | ParseTree.Reference [("time", [||])] -> Time | ParseTree.Reference cpnt_ref -> Reference (compile_component_reference ctx cpnt_ref) | ParseTree.String s -> String s | ParseTree.Subtraction (expr, expr') -> let cexpr = compile_expression' expr and cexpr' = compile_expression' expr' in Subtraction (cexpr, cexpr') | ParseTree.True -> Boolean true | ParseTree.VectorOrRecord (ParseTree.ArgList (exprs, None)) -> Vector (Array.of_list (List.map compile_expression' exprs)) | ParseTree.VectorOrRecord (ParseTree.ArgList (_, Some _)) -> failwith "compile_expression: for expressions not allowed" | ParseTree.VectorOrRecord (ParseTree.NamedArgList _) -> failwith "compile_expression: records not allowed" and get_function_from path = let name = List.map (function | (s, [||]) -> s | _ -> failwith "compile_expression: invalid function reference") path in let cu = get_compiled_class ctx name in match cu with | CompiledFunction lccl -> name, lccl | CompiledClass _ -> failwith "compile_expression: invalid function reference" and compile_if couples expr = let cexpr = compile_expression' expr in let ccouples = List.fold_right (fun couple ccouples -> let cexpr, cexpr' = compile_couple couple in (cexpr, cexpr') :: ccouples) couples [] in If (ccouples, cexpr) and compile_couple (expr, expr') = let cexpr = compile_expression' expr and cexpr' = compile_expression' expr' in cexpr, cexpr' in compile_expression' expr and to_argument cexpr = let rec array_dimensions = function | Vector cexprs -> Array.length cexprs :: array_dimensions cexprs.(0) | _ -> [] in let rec flatten = function | Vector cexprs -> Array.fold_right (fun cexpr acc -> flatten cexpr @ acc) cexprs [] | cexpr -> [cexpr] in match cexpr with | Vector _ -> ArrayArgument (array_dimensions cexpr, Array.of_list (flatten cexpr)) | _ -> ScalarArgument cexpr and compile_component_reference ctx cpnt_ref = let rec compile_reference' ctx' level level' cpnt_ref = match ctx' with | TopLevelContext _ -> raise Not_found | ClassContext (ctx'', lccl) -> compile_component_path ctx ctx' level cpnt_ref | ModificationContext (ctx'', lccl) -> begin try compile_reference' ctx'' (level + 1) level' cpnt_ref with | Not_found -> compile_component_path ctx ctx' level cpnt_ref end | ForContext (ctx'', id) -> compile_loop_variable ctx'' level level' id cpnt_ref and compile_loop_variable ctx'' level level' id = function | [(id', [||])] when id' = id -> LoopVariableReference level' | _ -> compile_reference' ctx'' level (level' + 1) cpnt_ref in compile_reference' ctx 0 0 cpnt_ref and compile_component_path ctx ctx' level cpnt_ref = let rec compile_component_path_in lccl = function | [] -> failwith "compile_component_path: Invalid path" | (id, array_subscrs) :: cpnt_ref -> let cpnt = find_local_component_in lccl id in let cs = compile_subscripts ctx array_subscrs in (*FIXME: range case *) let path = (id, cs) :: compile_path_rest cpnt_ref in begin match cpnt with | Parameter _ -> ParameterReference (level, path) | Variable _ -> VariableReference (level, path) end and compile_path_rest = function | [] -> [] | (id, array_subscrs) :: cpnt_ref -> let cs = compile_subscripts ctx array_subscrs in (*FIXME: range case *) (id, cs) :: compile_path_rest cpnt_ref in match ctx' with | ClassContext (_, lccl) | ModificationContext (_, lccl) -> compile_component_path_in lccl cpnt_ref | TopLevelContext _ | ForContext _ -> assert false (* Never applied to this kind of context *) and compile_subscripts ctx subscripts = let rec compile_subscript = function | ParseTree.All -> Indefinite | ParseTree.Subscript expr -> Definite (compile_expression ctx expr) in Array.map compile_subscript subscripts and compile_modifications ctx modifs = List.rev_map (compile_modification ctx) modifs and compile_modification ctx modif = try compile_component_modification ctx modif with | Not_found -> let s = match modif with | Modification (cpnt_ref, _, _) -> List.fold_left (fun acc (id, _) -> acc ^ "." ^ id) "" cpnt_ref in failwith ("compile_modification: component not found: " ^ s) and find_local_component_in lccl id = let public_cpnts = Lazy.force (Lazy.force lccl).ccl_public_cpnts in try Lazy.force (List.assoc id public_cpnts) with | Not_found -> failwith ("find_local_component_in: " ^ id ^ " not found") and find_local_component_class_in lccl id = match find_local_component_in lccl id with | Variable (CompoundVariable (lccl, _)) -> lccl | _ -> failwith "find_local_component_class_in: base type" and is_base_type_parameter_of lccl id = match find_local_component_in lccl id with | Parameter (IntegerParameter _ | RealParameter _) -> true | _ -> false and is_base_type_variable_of lccl id = match find_local_component_in lccl id with | Variable (DiscreteVariable _ | RealVariable _) -> true | _ -> false and compile_component_modification ctx modif = match ctx, modif with | ModificationContext (_, lccl), Modification ([(id, subscrs)], [], Some expr) when is_base_type_parameter_of lccl id -> let cs = compile_subscripts ctx subscrs and cexpr = compile_expression ctx expr in CompiledModification ((id, cs), [], Some cexpr) | ModificationContext (_, lccl), Modification ((id, _) :: _, _, _) when is_base_type_parameter_of lccl id -> failwith "compile_component_modification: invalid parameter modification" | ModificationContext (_, lccl), Modification ([(id, subscrs)], modifs, None) when is_base_type_variable_of lccl id -> let cs = compile_subscripts ctx subscrs and cmodifs = compile_base_type_variable_modifications ctx modifs in CompiledModification ((id, cs), cmodifs, None) | ModificationContext (_, lccl), Modification ([(id, _)], _, _) when is_base_type_variable_of lccl id -> failwith "compile_component_modification: invalid variable modification" | ModificationContext (_, lccl), Modification ([_], _, _) -> failwith "compile_component_modification: invalid component modification" | ModificationContext (_, lccl), Modification ((id, subscrs) :: cpnt_ref, modifs, expr_opt) -> let cs = compile_subscripts ctx subscrs and cexpr_opt = opt_map (compile_expression ctx) expr_opt and ctx' = ModificationContext (ctx, find_local_component_class_in lccl id) and modif = Modification (cpnt_ref, modifs, None) in let cmodif = compile_modification ctx' modif in CompiledModification ((id, cs), [cmodif], cexpr_opt) | (TopLevelContext _ | ClassContext _), _ -> assert false (* Never applied to this kind of context *) | _ -> raise InvalidModification and compile_base_type_variable_modifications ctx = function | [] -> [] | Modification (["start", [||]], [], Some expr) :: modifs -> let cexpr = compile_expression ctx expr in CompiledModification (("start", [||]), [], Some cexpr) :: compile_base_type_variable_modifications ctx modifs | Modification (["unit", [||]], [], Some expr) :: modifs -> let cexpr = compile_expression ctx expr in CompiledModification (("unit", [||]), [], Some cexpr) :: compile_base_type_variable_modifications ctx modifs | Modification (["quantity", [||]], [], Some expr) :: modifs -> let cexpr = compile_expression ctx expr in CompiledModification (("quantity", [||]), [], Some cexpr) :: compile_base_type_variable_modifications ctx modifs | Modification (["min", [||]], [], Some expr) :: modifs -> let cexpr = compile_expression ctx expr in CompiledModification (("min", [||]), [], Some cexpr) :: compile_base_type_variable_modifications ctx modifs | Modification (["max", [||]], [], Some expr) :: modifs -> let cexpr = compile_expression ctx expr in CompiledModification (("max", [||]), [], Some cexpr) :: compile_base_type_variable_modifications ctx modifs | _ :: modifs -> compile_base_type_variable_modifications ctx modifs (*failwith "compile_base_type_variable_modifications: invalid modification"*) and compile_component ctx i id pcpnt = match pcpnt.variability with | Some ParseTree.Parameter -> Parameter (compile_parameter ctx i id pcpnt) | Some ParseTree.Discrete | None -> Variable (compile_variable ctx i id pcpnt) | _ -> failwith "compile_component: only variables and parameters allowed" and compile_parameter ctx i id pcpnt = let cmodifs = match pcpnt.class_name, snd pcpnt.modification with | ["Integer"], _ | ["Real"], _ | ["String"], _ -> compile_base_type_variable_modifications ctx (fst pcpnt.modification) | _ -> [] in let attrs = { pat_dimensions = compile_subscripts ctx pcpnt.subscripts; pat_comment = compile_comment pcpnt.comment; pat_value = opt_map (compile_expression ctx) (snd pcpnt.modification); pat_infos = compile_infos i id pcpnt.comment cmodifs } in match pcpnt.class_name with | ["Integer"] -> IntegerParameter attrs | ["Real"] -> RealParameter attrs | ["String"] -> StringParameter attrs | _ -> failwith "compile_parameter: only base types allowed" and compile_variable ctx i id pcpnt = let cmodifs = match pcpnt.class_name, snd pcpnt.modification with | ["Integer"], None | ["Real"], None | ["String"], None -> compile_base_type_variable_modifications ctx (fst pcpnt.modification) | name, None -> let cu = get_compiled_class ctx name in begin match cu with | CompiledClass lccl -> let ctx' = ModificationContext (ctx, lccl) in compile_modifications ctx' (fst pcpnt.modification) | CompiledFunction _ -> failwith "compile_variable: functions not allowed as variables" end | _, Some _ -> failwith "compile_variable: equations not allowed in variable declarations" in let attrs = { vat_dimensions = compile_subscripts ctx pcpnt.subscripts; vat_nature = compile_nature pcpnt.flow; vat_inout = compile_inout pcpnt.inout; vat_comment = compile_comment pcpnt.comment; vat_modifications = start_modifications cmodifs; vat_infos = compile_infos i id pcpnt.comment cmodifs } in match pcpnt.class_name, pcpnt.variability with | ["Real"], Some ParseTree.Discrete -> DiscreteVariable attrs | ["Real"], None -> RealVariable attrs | ["Integer"], None -> IntegerVariable attrs | ["String"], None -> StringVariable attrs | name, None -> let cu = get_compiled_class ctx name in begin match cu with | CompiledClass lccl -> CompoundVariable (lccl, attrs) | CompiledFunction _ -> failwith "compile_variable: functions not allowed as variables" end | _ -> failwith "compile_variable: invalid variable declaration" and start_modifications cmodifs = match cmodifs with | [] -> [] | (CompiledModification (("start", _), _, _) as cmodif) :: cmodifs' -> cmodif :: start_modifications cmodifs' | _ :: cmodifs' -> start_modifications cmodifs' and compile_nature = function | Some ParseTree.Flow -> Flow | None -> Potential and compile_inout inout = match inout with | Some ParseTree.Input -> Input | Some ParseTree.Output -> Output | None -> Both and compile_comment = function | ParseTree.Comment (ParseTree.StringComment ss, _) -> List.fold_left ( ^ ) "" ss (*| ParseTree.Comment (_, Some _) -> failwith "compile_comment: Annotations not allowed"*) and compile_infos i id cmt cmodifs = let weight, port_name, port_type = match cmt with | ParseTree.Comment (_, Some ann) -> compile_annotation ann | _ -> 1.0, "", "" in let port_name = match port_name with | "" -> id | _ -> port_name in let rec modif_infos (unit, qt, min, max) cmodifs = match cmodifs with | [] -> unit, qt, min, max | (CompiledModification (("unit", _), _, Some (String s))) :: cmodifs' -> modif_infos (s, qt, min, max) cmodifs' | (CompiledModification (("quantity", _), _, Some (String s))) :: cmodifs' -> modif_infos (unit, s, min, max) cmodifs' | (CompiledModification (("min", _), _, Some (String s))) :: cmodifs' -> modif_infos (unit, qt, s, max) cmodifs' | (CompiledModification (("max", _), _, Some (String s))) :: cmodifs' -> modif_infos (unit, qt, min, s) cmodifs' | _ :: cmodifs' -> modif_infos (unit, qt, min, max) cmodifs' in let unit, qt, min, max = modif_infos ("null", "", "", "") cmodifs in { var_name = id; title = id; unit = unit; quantity = qt; min = min; max = max; port_name = port_name; port_type = port_type; order = i; io = 1; weight = weight } and compile_annotation ann = let rec compile_port_arguments (weight, port_name, port_type) args = match args with | [] -> weight, port_name, port_type | ParseTree.ElementModification (_, _, ["port_name", [||]], ParseTree.Eq (ParseTree.Reference [id, [||]]), _) :: args' -> compile_port_arguments (weight, id, port_type) args' | ParseTree.ElementModification (_, _, ["port_type", [||]], ParseTree.Eq (ParseTree.Reference [id, [||]]), _) :: args' -> compile_port_arguments (weight, port_name, id) args' | _ :: args' -> compile_port_arguments (weight, port_name, port_type) args' and compile_initialization_arguments (weight, port_name, port_type) args = match args with | [] -> weight, port_name, port_type | ParseTree.ElementModification (_, _, ["weight", [||]], ParseTree.Eq (ParseTree.Real s), _) :: args' -> compile_initialization_arguments (float_of_string s, port_name, port_type) args' | _ :: args' -> compile_initialization_arguments (weight, port_name, port_type) args' in let compile_port_annotation modif = match modif with | ParseTree.Modification (ParseTree.ClassModification args, None) -> compile_port_arguments (1.0, "", "") args | _ -> 1.0, "", "" in let compile_initialization_annotation modif = match modif with | ParseTree.Modification (ParseTree.ClassModification args, None) -> compile_initialization_arguments (1.0, "", "") args | _ -> 1.0, "", "" in let compile_imagine_annotation_argument (weight, port_name, port_type) arg = match arg with | ParseTree.ElementModification (_, _, ["port", [||]], modif, _) -> compile_port_annotation modif | ParseTree.ElementModification (_, _, ["initialization", [||]], modif, _) -> compile_initialization_annotation modif | _ -> weight, port_name, port_type in let compile_imagine_annotation modif = match modif with | ParseTree.Modification (ParseTree.ClassModification args, None) -> List.fold_left compile_imagine_annotation_argument (1.0, "", "") args | _ -> 1.0, "", "" in let compile_scicos_annotation_argument (weight, port_name, port_type) arg = match arg with | ParseTree.ElementModification (_, _, ["initialization", [||]], modif, _) -> compile_initialization_annotation modif | _ -> weight, port_name, port_type in let compile_scicos_annotation modif = match modif with | ParseTree.Modification (ParseTree.ClassModification args, None) -> List.fold_left compile_scicos_annotation_argument (1.0, "", "") args | _ -> 1.0, "", "" in let compile_argument arg = match arg with | ParseTree.ElementModification (_, _, ["__imagine", [||]], modif, _) -> compile_imagine_annotation modif | ParseTree.ElementModification (_, _, ["__scicos", [||]], modif, _) -> compile_scicos_annotation modif | _ -> 1.0, "", "" in match ann with | ParseTree.Annotation (ParseTree.ClassModification [arg]) -> compile_argument arg | _ -> 1.0, "", ""