Project

General

Profile

Statistics
| Branch: | Tag: | Revision:

lustrec / src / lusic.ml @ 01d48bb0

History | View | Annotate | Download (3.57 KB)

1

    
2
(********************************************************************)
3
(*                                                                  *)
4
(*  The LustreC compiler toolset   /  The LustreC Development Team  *)
5
(*  Copyright 2012 -    --   ONERA - CNRS - INPT                    *)
6
(*                                                                  *)
7
(*  LustreC is free software, distributed WITHOUT ANY WARRANTY      *)
8
(*  under the terms of the GNU Lesser General Public License        *)
9
(*  version 2.1.                                                    *)
10
(*                                                                  *)
11
(********************************************************************)
12

    
13
open Format 
14
open LustreSpec
15
open Corelang
16

    
17
(********************************************************************************************)
18
(*                      Lusic to/from Header Printing functions                             *)
19
(********************************************************************************************)
20

    
21
type lusic =
22
{
23
  obsolete  : bool;
24
  from_lusi : bool;
25
  contents  : top_decl list;
26
}
27

    
28
module HeaderMod = C_backend_header.EmptyMod
29
module Header = C_backend_header.Main (HeaderMod)
30

    
31
(* extracts a header from a program representing module owner = dirname/basename *)
32
let extract_header dirname basename prog =
33
  let owner = dirname ^ "/" ^ basename in
34
 List.fold_right
35
   (fun decl header ->
36
(*Format.eprintf "Lusic.extract_header: owner = %s decl_owner = %s@." owner decl.top_decl_owner;*)
37
     if decl.top_decl_itf || decl.top_decl_owner <> owner then header else
38
    match decl.top_decl_desc with
39
    | Node nd        -> { decl with top_decl_desc = ImportedNode (Corelang.get_node_interface nd) } :: header 
40
    | ImportedNode _ -> header
41
    | Const _
42
    | TypeDef _
43
    | Open _         -> decl :: header)
44
   prog []
45

    
46
let check_obsolete lusic basename =
47
  if lusic.obsolete then raise (Error (Location.dummy_loc, Wrong_number basename))
48

    
49
let check_lusic lusic basename =
50
  try
51
    check_obsolete lusic basename
52
  with
53
  | Corelang.Error (loc, err) as exc -> (
54
    eprintf "Library error: %a%a@."
55
      Corelang.pp_error err
56
      Location.pp_loc loc;
57
    raise exc
58
  )
59

    
60
(* encode and write a header in a file *)
61
let write_lusic lusi (header : top_decl list) basename extension =
62
  let target_name = basename ^ extension in
63
  let outchan = open_out_bin target_name in
64
  begin
65
    Marshal.to_channel outchan (Version.number, lusi : string * bool) [];
66
    Marshal.to_channel outchan (header : top_decl list) [];
67
    close_out outchan
68
  end
69

    
70
(* read and decode a header from a file *)
71
let read_lusic basename extension =
72
  let source_name = basename ^ extension in
73
  let inchan = open_in_bin source_name in
74
  let number, from_lusi = (Marshal.from_channel inchan : string * bool) in
75
  if number <> Version.number
76
  then
77
    begin
78
      close_in inchan;
79
      {
80
	obsolete  = true;
81
	from_lusi = from_lusi;
82
	contents  = [];
83
      }
84
    end
85
  else    
86
    begin
87
      let lusic = (Marshal.from_channel inchan : top_decl list) in
88
      close_in inchan;
89
      {
90
	obsolete  = false;
91
	from_lusi = from_lusi;
92
	contents  = lusic;
93
      }
94
    end
95

    
96
let print_lusic_to_h basename extension =
97
  let lusic = read_lusic basename extension in
98
  let header_name = basename ^ ".h" in
99
  let h_out = open_out header_name in
100
  let h_fmt = formatter_of_out_channel h_out in
101
  begin
102
    check_lusic lusic basename;
103
    Typing.uneval_prog_generics lusic.contents;
104
    Clock_calculus.uneval_prog_generics lusic.contents;
105
    Header.print_header_from_header h_fmt (Filename.basename basename) lusic.contents;
106
    close_out h_out
107
  end
108

    
109