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