add translator & XML2modelica
[scilab.git] / scilab / modules / scicos / src / translator / exceptionHandling / exceptHandler.ml
1 (*
2  *  Translator from Modelica 2.x to flat Modelica
3  *
4  *  Copyright (C) 2005 - 2007 Imagine S.A.
5  *  For more information or commercial use please contact us at www.amesim.com
6  *
7  *  This program is free software; you can redistribute it and/or
8  *  modify it under the terms of the GNU General Public License
9  *  as published by the Free Software Foundation; either version 2
10  *  of the License, or (at your option) any later version.
11  *
12  *  This program is distributed in the hope that it will be useful,
13  *  but WITHOUT ANY WARRANTY; without even the implied warranty of
14  *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
15  *  GNU General Public License for more details.
16  *
17  *  You should have received a copy of the GNU General Public License
18  *  along with this program; if not, write to the Free Software
19  *  Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA.
20  *
21  *)
22
23 (* Exception handler module *)
24
25 open Parser
26
27 type execution_step =
28   | NameResolution
29   | Instantiation of Instantiation.instance_nature
30   | CodeGeneration of Instantiation.instance_nature
31   | SyntacticAnalysis
32
33 let display s =
34   print_string (MsgDico.translate s)
35
36 let print_offset =
37   function s ->
38       Printf.printf "\n";
39       for i = 1 to 3 do print_string s done;
40       Printf.printf " "
41
42 let display_header exn err_msg =
43   let display_code exn err_msg =
44     let rec display_code' err_msg =
45       match err_msg with
46         | [] -> ()
47         | s :: err_msg when s.[0] = '_' -> display (ErrorDico.getCode exn s)
48         | _ :: err_msg -> display_code' err_msg in
49     Printf.printf "\n";
50     display "_ERROR";
51     Printf.printf " ";
52     display_code' err_msg;
53     Printf.printf ":" in
54   let display_message err_msg =
55     let display_elem s =
56       match s with
57         | "" -> ()
58         | s when s.[0] = '_' -> display s; Printf.printf " "
59         | s ->
60             Printf.printf "\"";
61             print_string s;
62             Printf.printf "\" " in
63     let rec display_message' err_msg =
64       match err_msg with
65         | [] -> ()
66         | s :: err_msg ->
67             display_elem s;
68             display_message' err_msg in
69     print_offset("-");
70     display_message' err_msg in
71   display_code exn err_msg;
72   display_message err_msg
73   
74 let display_info err_info =
75   let display_value sn sv =
76     match sv with
77       | "" -> ()
78       | s when s.[0] = '_' -> display s
79       | s when sn = "_ExprKind" -> Printf.printf "\"%s\"" s
80       | s -> print_string s in
81   let rec display_info' err_info =
82     match err_info with
83       | [] -> ()
84       | (sn, sv) :: err_info ->
85           print_offset("-");
86           display sn;
87           Printf.printf ": ";
88           display_value sn sv;
89           display_info' err_info in
90   Printf.printf "\n";
91   display_info' err_info
92
93 (*let string_of_path path =
94   let rec string_of_path' elem path = match elem, path with
95     | None, []
96     | Some (Instantiation.Name _), [] -> ""
97     | Some (Instantiation.Index _), [] -> "]"
98     | None, (Instantiation.Name s) :: path ->
99         s ^ (string_of_path' (Some (Instantiation.Name s)) path)
100     | Some (Instantiation.Name _), (Instantiation.Name s) :: path ->
101         "." ^ s ^ (string_of_path' (Some (Instantiation.Name s)) path)
102     | Some (Instantiation.Index _), (Instantiation.Name s) :: path ->
103         "]." ^ s ^ (string_of_path' (Some (Instantiation.Name s)) path)
104     | Some (Instantiation.Index _), (Instantiation.Index i) :: path ->
105         ", " ^ (string_of_int i) ^
106         (string_of_path' (Some (Instantiation.Index i)) path)
107     | _, (Instantiation.Index i) :: path ->
108         "[" ^ (string_of_int i) ^
109         (string_of_path' (Some (Instantiation.Index i)) path) in
110   string_of_path' None path*)
111
112 let last path =
113   let rec last' id path = match path with
114     | [] -> id
115     | (Instantiation.Name id) :: path -> last' id path
116     | (Instantiation.Index _) :: path -> last' id path in
117   last' "" path
118
119 let loc_info loc =
120   match loc.filename with
121     | Parser.CommandLine ->
122         [("_Source", "_CommandLine");
123          ("_CharacterPosition", string_of_int (loc.Parser.start + 1))]
124     | Parser.LibraryFile lib_file ->
125         let linenum, linebeg =
126           Linenum.for_position lib_file loc.Parser.start in
127         [("_Source", lib_file);
128          ("_LineNumber", string_of_int linenum);
129          ("_ColumnNumber", string_of_int (loc.Parser.start - linebeg + 1))]
130
131 let class_name_info instance_nature = match instance_nature with
132   | Instantiation.ClassElement -> []
133   | Instantiation.ComponentElement s -> [("_ClassName", s)]
134
135 let exec_step_info step opath =
136   let string_of_step = match step with
137     | NameResolution -> "_NameResolution"
138     | Instantiation Instantiation.ClassElement ->
139         "_InstantiationOfClass"
140     | Instantiation Instantiation.ComponentElement _ ->
141         "_InstantiationOfComponent"
142     | CodeGeneration Instantiation.ClassElement ->
143         "_CodeGenerationForClass"
144     | CodeGeneration Instantiation.ComponentElement _ ->
145         "_CodeGenerationForComponent"
146     | SyntacticAnalysis -> "_SyntacticAnalysis" in
147   let path_info = match opath with
148     | None -> ""
149     | Some path -> " \"" ^ (last path) ^ "\"" in
150   [("_ExecutionStep", (MsgDico.translate string_of_step) ^ path_info)]
151
152 (* This function is'nt called if all exception types are correctly handled. *)
153 let handle_unhandledException exn =
154   Printf.printf "\nUnhandled exception: %s\n" (Printexc.to_string exn)
155
156 let handle exn =
157   let handle' =
158     match exn with
159       | NameResolve.CompilError { NameResolve.err_msg = err_msg;
160                                   NameResolve.err_info = err_info;
161                                   NameResolve.err_ctx = ctx } ->
162           display_header exn err_msg;
163           display_info (exec_step_info NameResolution None);
164           display_info
165             (loc_info ctx.NameResolve.location);
166           display_info err_info;
167           Printf.printf "\n"
168       | Instantiation.InstantError { Instantiation.err_msg = err_msg;
169                                      Instantiation.err_info = err_info;
170                                      Instantiation.err_ctx = ctx } ->
171           display_header exn err_msg;
172           let opath = (Some ctx.Instantiation.path)
173           and step = Instantiation ctx.Instantiation.instance_nature in
174           display_info (exec_step_info step opath);
175           display_info
176             ((class_name_info ctx.Instantiation.instance_nature) @
177             (loc_info ctx.Instantiation.location));
178           display_info err_info;
179           Printf.printf "\n"
180       | ErrorDico.GenericError { ErrorDico.err_msg = err_msg;
181                                  ErrorDico.err_info = err_info;
182                                  ErrorDico.err_ctx = ctx } ->
183           display_header exn err_msg;
184           let step = CodeGeneration ctx.ErrorDico.instance_nature in
185           display_info (exec_step_info step (Some ctx.ErrorDico.path));
186           display_info
187             ((class_name_info ctx.ErrorDico.instance_nature) @
188             (loc_info ctx.ErrorDico.location));
189           display_info err_info;
190           Printf.printf "\n"
191       | Parser.SyntacticError { Parser.err_msg = err_msg;
192                                 Parser.err_info = err_info;
193                                 Parser.err_ctx = ctx } ->
194           display_header exn err_msg;
195           display_info (exec_step_info SyntacticAnalysis None);
196           display_info
197             (loc_info ctx.Parser.location);
198           display_info err_info;
199           Printf.printf "\n"
200       | _ -> 
201           handle_unhandledException exn in
202   handle'
203