Project

General

Profile

Revision fd834769 src/backends/Ada/ada_backend.ml

View differences:

src/backends/Ada/ada_backend.ml
12 12
open Format
13 13
open Machine_code_types
14 14

  
15
let gen_ada destname print suffix machine =
16
  (* Next line permit to get the final package name mostly to clean the
17
    identifier for Ada *)
18
  let name = asprintf "%a" Ada_backend_common.pp_package_name machine.mname in
19
  let name = String.lowercase_ascii name in
20
  let path = destname ^ name ^ suffix in
15
open Ada_backend_common
16

  
17
let indent_size = 2
18

  
19
(** Log at level 2 a string message with some indentation.
20
   @param indent the indentation level
21
   @param info the message
22
**)
23
let log_str_level_two indent info =
24
  let str_indent = String.make (indent*indent_size) ' ' in
25
  let pp_message fmt = fprintf fmt "%s.. %s@." str_indent info in
26
  Log.report ~level:2 pp_message
27

  
28
(** Encapsulate a pretty print function to lower case its result when applied
29
   @param pp the pretty print function
30
   @param fmt the formatter
31
   @param arg the argument of the pp function
32
**)
33
let pp_lowercase pp fmt arg =
34
  let str = asprintf "%a" pp arg in
35
  fprintf fmt "%s" (String. lowercase_ascii str)
36

  
37
(** Write a new file with formatter
38
   @param destname folder where the file shoudl be created
39
   @param pp_filename function printing the filename
40
   @param pp_file function wich pretty print the file
41
   @param arg will be given to pp_filename and pp_file
42
**)
43
let write_file destname pp_filename pp_file arg =
44
  let path = asprintf "%s%a" destname pp_filename arg in
21 45
  let out = open_out path in
22 46
  let fmt = formatter_of_out_channel out in
23
  print fmt machine;
47
  pp_file fmt arg;
48
  pp_print_flush fmt ();
24 49
  close_out out;
25
  Log.report ~level:2 (fun fmt -> fprintf fmt "    .. %s generated @." path)
50
  log_str_level_two 2 (path^" generated")
51

  
26 52

  
53
(** Print the filename of a package by lowercasing it and appending
54
  an extension.
55
   @param extension the extension to append to the package name
56
   @param fmt the formatter
57
   @param fmt the machine corresponding to the package
58
**)
59
let pp_machine_filename extension fmt machine =
60
  fprintf fmt "%a.%s"
61
    (pp_lowercase pp_package_name) machine.mname
62
    extension
63

  
64
(** Exception raised when a machine contains a feature not supported by the
65
  Ada backend*)
27 66
exception CheckFailed of string
28 67

  
68

  
69
(** Check that a machine match the requirement for an Ada compilation :
70
      - No constants.
71
   @param machine the machine to test
72
**)
29 73
let check machine =
30 74
  match machine.mconst with
31 75
    | [] -> ()
32 76
    | _ -> raise (CheckFailed "machine.mconst should be void")
33 77

  
78
(** Print the name of the ada project file.
79
   @param fmt the formater to print on
80
   @param main_machine the machine associated to the main node
81
**)
82
let pp_project_name fmt main_machine =
83
  fprintf fmt "%a.gpr" pp_package_name main_machine.mname
84

  
85
(** Main function of the Ada backend. It calls all the subfunction creating all
86
the file and fill them with Ada code representing the machines list given.
87
   @param basename useless
88
   @param prog useless
89
   @param prog list of machines to translate
90
   @param dependencies useless
91
**)
34 92
let translate_to_ada basename prog machines dependencies =
35 93
  let module Ads = Ada_backend_ads.Main in
36 94
  let module Adb = Ada_backend_adb.Main in
37 95
  let module Wrapper = Ada_backend_wrapper.Main in
38 96

  
39
  let destname = !Options.dest_dir ^ "/" in
97
  (* Extract the main machine if there is one *)
98
  let main_machine = (match !Options.main_node with
99
  | "" -> None
100
  | main_node -> (
101
    match Machine_code_common.get_machine_opt main_node machines with
102
    | None -> begin
103
      Format.eprintf "Ada Code generation error: %a@." Error.pp_error_msg Error.Main_not_found;
104
      raise (Corelang.Error (Location.dummy_loc, Error.Main_not_found))
105
    end
106
    | Some m -> Some m
107
  )) in
40 108

  
41
  Log.report ~level:2 (fun fmt -> fprintf fmt "  .. Checking machines@.");
109
  let destname = !Options.dest_dir ^ "/" in
42 110

  
111
  log_str_level_two 1 "Checking machines";
43 112
  List.iter check machines;
44 113

  
45
  Log.report ~level:2 (fun fmt -> fprintf fmt "  .. Generating ads@.");
114
  log_str_level_two 1 "Generating ads";
115
  List.iter (write_file destname (pp_machine_filename "ads") Ads.pp_file) machines;
46 116

  
47
  List.iter (gen_ada destname Ads.print ".ads") machines;
117
  log_str_level_two 1 "Generating adb";
118
  List.iter (write_file destname (pp_machine_filename "adb") Adb.pp_file) machines;
48 119

  
49
  Log.report ~level:2 (fun fmt -> fprintf fmt "  .. Generating adb@.");
120
  (* If a main node is given we generate a main adb file and a project file *)
121
  log_str_level_two 1 "Generating wrapper files";
122
  match main_machine with
123
    | None -> log_str_level_two 2 "File not generated(no -node argument)";
124
    | Some machine -> begin
125
        write_file destname pp_project_name Wrapper.pp_project_file machine;
126
        write_file destname pp_main_filename Wrapper.pp_main_file machine;
127
      end
50 128

  
51
  List.iter (gen_ada destname Adb.print ".adb") machines
52 129

  
53 130
(* Local Variables: *)
54 131
(* compile-command:"make -C ../../.." *)

Also available in: Unified diff