Project

General

Profile

Revision 3b2bd83d

View differences:

Makefile.in
7 7
includedir = ${prefix}/include
8 8

  
9 9
LUSI_LIBS=include/math.lusi include/conv.lusi
10
LUSI_MPFR_LIB=include/mpfr_lustre.lusi
10 11
LOCAL_BINDIR=bin
11 12
LOCAL_DOCDIR=doc/manual
12 13

  
13
lustrec:
14
$(LOCAL_BINDIR)/lustrec: configure Makefile
14 15
	@echo Compiling binary lustrec
15
	@$(OCAMLBUILD) -cflags -I,@OCAMLGRAPH_PATH@ -lflag @OCAMLGRAPH_PATH@/graph.cmxa -I src -I src/backends/C src/main_lustre_compiler.native
16
	@$(OCAMLBUILD) -cflags -I,@OCAMLGRAPH_PATH@ -lflag @OCAMLGRAPH_PATH@/graph.cmxa -lflag nums.cmxa -I src -I src/backends/C -I src/plugins/scopes src/main_lustre_compiler.native
16 17
	@mkdir -p $(LOCAL_BINDIR)
17 18
	@mv _build/src/main_lustre_compiler.native $(LOCAL_BINDIR)/lustrec
18 19

  
20
configure: configure.ac
21
	@echo configure.ac has changed relaunching autoconf
22
	@autoconf
23

  
24
Makefile: Makefile.in config.status configure
25
	@echo Makefile.in has changed relaunching autoconf
26
	@./config.status --recheck
27

  
19 28
doc:
20 29
	@echo Generating doc
21 30
	@$(OCAMLBUILD) lustrec.docdir/index.html
......
30 39
clean:
31 40
	$(OCAMLBUILD) -clean
32 41

  
33
dist-clean: clean
34
	@rm -f Makefile myocamlbuild.ml config.log config.status configure include/*.lusic include/math.h include/conv.h
42
dist-src-clean: clean
43
	@rm -f config.log config.status include/*.lusic include/math.h include/conv.h include/mpfr_lustre.h
44

  
45
DIST_ARCHIVE_NAME=lustrec-$(shell $(LOCAL_BINDIR)/lustrec -version | grep version | cut -d, -f 2 | sed -e "s/ version //" -e "s/ (/-/" -e "s/ /-/" -e "s/\//-/" -e "s/)//")-src.tar.gz
46

  
47
dist-gzip: $(LOCAL_BINDIR)/lustrec dist-src-clean
48
	@rm -f $(shell ls ../*lustrec*src*tar.gz)
49
	@tar zcvf ../$(DIST_ARCHIVE_NAME) -C .. --exclude-vcs --exclude=Makefile  --exclude=$(LOCAL_BINDIR) $(shell basename $(PWD))
50
	@echo "Source distribution built: ../$(DIST_ARCHIVE_NAME)"
51

  
52
dist-clean: dist-src-clean
53
	@rm -f myocamlbuild.ml configure Makefile
35 54

  
36 55
%.lusic: %.lusi
37 56
	@echo Compiling $<
......
39 58

  
40 59
clean-lusic:
41 60
	@rm -f $(LUSI_LIBS:%.lusi=%.lusic)
61
	@rm -f $(LUSI_MPFR_LIB:%.lusi=%.lusic)
42 62

  
43 63
compile-lusi: $(LUSI_LIBS:%.lusi=%.lusic)
44 64

  
45
install: clean-lusic compile-lusi
65
compile-mpfr-lusi: $(LUSI_MPFR_LIB)
66
	@echo Compiling $<
67
	@$(LOCAL_BINDIR)/lustrec -verbose 0 -mpfr 1 -d include $<
68

  
69
install: clean-lusic compile-lusi compile-mpfr-lusi
46 70
	mkdir -p ${bindir}
47 71
	install -m 0755 $(LOCAL_BINDIR)/* ${bindir}
48 72
	mkdir -p ${includedir}/lustrec
configure.ac
1
define([svnversion], esyscmd([sh -c "svnversion|sed "s/:.*//"|tr -d '\n'"]))dnl
2
AC_INIT([lustrec], [1.1-svnversion], [ploc@garoche.net])
1
define([gitversion], esyscmd([sh -c "git log --oneline | wc -l | tr -d '\n'"]))
3 2

  
3
AC_INIT([lustrec], [1.3-gitversion], [ploc@garoche.net])
4
AC_SUBST(VERSION_CODENAME, "Xia/Zhong-Kang-dev")
5
# Next release will be
6
#AC_INIT([lustrec], [1.3], [ploc@garoche.net])
7
#AC_SUBST(VERSION_CODENAME, "Xia/Zhong-Kang")
4 8

  
5
AC_DEFINE(SVN_REVISION, "svnversion", [SVN Revision])
6
AC_SUBST(SVN_REVISION)
9
#AC_DEFINE(SVN_REVISION, "svnversion", [SVN Revision])
10
#AC_SUBST(SVN_REVISION)
7 11

  
8 12
AC_CONFIG_SRCDIR([src/main_lustre_compiler.ml])
9 13

  
......
23 27
)
24 28
AC_SUBST(OCAMLGRAPH_PATH)
25 29

  
30
AC_SUBST(SRC_PATH, esyscmd([sh -c "pwd" | tr -d '\n']))
26 31

  
27 32
AC_PATH_PROG([OCAMLC],[ocamlc],[:])
28 33
AC_MSG_CHECKING(OCaml version)
29 34
ocamlc_version=`$OCAMLC -v | grep version | rev| cut -d \  -f 1 | rev`
30 35
major=`echo $ocamlc_version | cut -d . -f 1`
31 36
minor=`echo $ocamlc_version | cut -d . -f 2`
32
if (test "$major" -lt 3 -a "$minor" -lt 11 ); then
33
  AC_MSG_ERROR([Ocaml version must be at least 3.11. You have version $ocamlc_version])
37
if (test "$major" -lt 4 -a "$minor" -lt 0 ); then
38
  AC_MSG_ERROR([Ocaml version must be at least 4.0. You have version $ocamlc_version])
34 39
fi
35 40
AC_MSG_RESULT(valid ocaml version detected: $ocamlc_version)
36 41

  
......
43 48
AC_MSG_CHECKING(ocamlgraph library)
44 49
   ocamlgraph_lib=`find $OCAMLGRAPH_PATH -iname graph.cmxa | grep -m 1 -o "graph.cmxa"`
45 50
   if (test "x$ocamlgraph_lib" = xgraph.cmxa ); then
46
	ocamlgraph_lib_full=`find $OCAMLGRAPH_PATH -iname graph.cmxa  | grep -m 1 "graph.cmxa"`
51
	ocamlgraph_lib_full=`find $OCAMLGRAPH_PATH -iname graph.cmxa | grep -m 1 "graph.cmxa"`
47 52
      AC_MSG_RESULT(library detected: $ocamlgraph_lib_full )
48 53
   else
49 54
      AC_MSG_ERROR([ocamlgraph library not installed in $OCAMLGRAPH_PATH])
50 55
   fi
51 56

  
57
AC_CHECK_LIB(gmp, __gmpz_init, 
58
      [gmp=yes],
59
      [AC_MSG_RESULT([GNU MP not found])
60
      gmp=no])
61

  
62
AC_CHECK_LIB(mpfr, mpfr_add, [mpfr=yes], 
63
		   [AC_MSG_RESULT(
64
[MPFR not found])
65
mpfr=no])
66

  
52 67

  
53 68
# Workaround to solve an issue with ocamlbuild and C libraries.
54 69
# oCFLAGS="$CFLAGS"
......
87 102
AC_CONFIG_FILES([Makefile
88 103
		 src/Makefile
89 104
                 src/myocamlbuild.ml
90
		 src/version.ml])
105
		 src/version.ml
106
		 test/test-compile.sh
107
		 ])
91 108

  
92 109
AC_OUTPUT
93 110

  
94 111

  
95 112
# summary
96
dnl AC_MSG_NOTICE(******** Configuration ********)
113
AC_MSG_NOTICE(******** Configuration ********)
114
AC_MSG_NOTICE(bin path:     $prefix/bin)
115
AC_MSG_NOTICE(include path: $prefix/include)
116
AC_MSG_NOTICE(********    Plugins    ********)
117

  
118
  if (test "x$gmp" = xyes -a "x$mpfr" = xyes ); then
119
       AC_MSG_NOTICE([-mpfr option enable])
120

  
121
   else 
122
       AC_MSG_WARN([MPFR option cannot be activated. Requires GMP and MPFR libs])
123
      
124
   fi
125
 
126
AC_MSG_NOTICE
127
AC_MSG_NOTICE(******** Configuration ********)
128

  
include/arrow.h
17 17
  _arrow_DECLARE(attr, inst);\
18 18
  _arrow_LINK(inst)
19 19

  
20
#define _arrow_init(self) {}
21

  
22
#define _arrow_clear(self) {}
23

  
20 24
#define _arrow_step(x,y,output,self) ((self)->_reg._first?((self)->_reg._first=0,(*output = x)):(*output = y))
21 25

  
22 26
#define _arrow_reset(self) {(self)->_reg._first = 1;}
src/Makefile
1
OCAMLBUILD=/Users/teme/.opam/4.02.1/bin/ocamlbuild -classic-display -no-links 
1
OCAMLBUILD=/opt/local/bin/ocamlbuild -classic-display -use-ocamlfind -no-links 
2 2

  
3
prefix=/usr/local
3
prefix=/Users/Teme/Documents/GitHub/lustrec/cocosim
4 4
exec_prefix=${prefix}
5 5
bindir=${exec_prefix}/bin
6 6
datarootdir = ${prefix}/share
src/Makefile.in
1
OCAMLBUILD=@OCAMLBUILD@ -classic-display -no-links 
1
OCAMLBUILD=@OCAMLBUILD@ -classic-display -use-ocamlfind -no-links 
2 2

  
3 3
prefix=@prefix@
4 4
exec_prefix=@exec_prefix@
src/automata.ml
139 139
let node_of_unless nused used node aut_id aut_state handler =
140 140
(*Format.eprintf "node_of_unless %s@." node.node_id;*)
141 141
  let inputs = unless_read ISet.empty handler in
142
  let var_inputs = aut_state.incoming_r :: aut_state.incoming_s :: (node_vars_of_idents node inputs) in
142
  let var_inputs = aut_state.incoming_r (*:: aut_state.incoming_s*) :: (node_vars_of_idents node inputs) in
143 143
  let var_outputs = aut_state.actual_r :: aut_state.actual_s :: [] in
144
  let expr_outputs = List.fold_right add_branch handler.hand_unless (mkidentpair handler.hand_loc aut_state.incoming_r.var_id aut_state.incoming_s.var_id) in
144
  let init_expr = mkpair handler.hand_loc (mkident handler.hand_loc aut_state.incoming_r.var_id) (mkconst handler.hand_loc handler.hand_state) in
145
(*  let init_expr = mkidentpair handler.hand_loc aut_state.incoming_r.var_id aut_state.incoming_s.var_id in *)
146
  let expr_outputs = List.fold_right add_branch handler.hand_unless init_expr in
145 147
  let eq_outputs = Eq (mkeq handler.hand_loc ([aut_state.actual_r.var_id; aut_state.actual_s.var_id], expr_outputs)) in
146 148
  let node_id = mk_new_name nused (Format.sprintf "%s__%s_unless" aut_id handler.hand_state) in
147 149
  let args = List.map (fun v -> mkexpr handler.hand_loc (Expr_when (mkident handler.hand_loc v.var_id, aut_state.incoming_s.var_id, handler.hand_state))) var_inputs in
......
185 187
  let writes = handler_write ISet.empty handler in
186 188
  let inputs = ISet.diff (handler_read (until_read ISet.empty handler) handler) writes in
187 189
  let frename = mk_frename used writes in
188
  let var_inputs = node_vars_of_idents node inputs in
190
  let var_inputs = aut_state.actual_r (*:: aut_state.actual_s*) :: node_vars_of_idents node inputs in
189 191
  let new_var_locals = node_vars_of_idents node writes in
190 192
  let var_outputs = List.sort IdentModule.compare (node_vars_of_idents node writes) in
191 193
  let new_var_outputs = List.map (fun vdecl -> { vdecl with var_id = frename vdecl.var_id }) var_outputs in
192 194
  let new_output_eqs = List.map2 (fun o o' -> Eq (mkeq handler.hand_loc ([o'.var_id], mkident handler.hand_loc o.var_id))) var_outputs new_var_outputs in
193
  let until_expr = List.fold_right add_branch handler.hand_until (mkidentpair handler.hand_loc aut_state.actual_r.var_id aut_state.actual_s.var_id) in
195
  let init_until = mkpair handler.hand_loc (mkconst handler.hand_loc tag_false) (mkconst handler.hand_loc handler.hand_state) in
196
  let until_expr = List.fold_right add_branch handler.hand_until init_until in
194 197
  let until_eq = Eq (mkeq handler.hand_loc ([aut_state.incoming_r.var_id; aut_state.incoming_s.var_id], until_expr)) in
195 198
  let node_id = mk_new_name nused (Format.sprintf "%s__%s_handler_until" aut_id handler.hand_state) in
196
  let var_inputs = aut_state.actual_r :: aut_state.actual_s :: var_inputs in
197 199
  let args = List.map (fun v -> mkexpr handler.hand_loc (Expr_when (mkident handler.hand_loc v.var_id, aut_state.actual_s.var_id, handler.hand_state))) var_inputs in
198 200
  let reset = Some (mkident handler.hand_loc aut_state.actual_r.var_id) in
199 201
  List.fold_left (fun res v -> ISet.add v.var_id res) ISet.empty var_outputs,
src/backends/C/c_backend.ml
25 25
  )
26 26
*)
27 27

  
28
let gen_files funs basename prog machines dependencies header_file source_lib_file source_main_file makefile_file machines =
29

  
30
  let header_out = open_out header_file in
31
  let header_fmt = formatter_of_out_channel header_out in
32
  let source_lib_out = open_out source_lib_file in
33
  let source_lib_fmt = formatter_of_out_channel source_lib_out in
34

  
28
let gen_files funs basename prog machines dependencies =
29
  let destname = !Options.dest_dir ^ "/" ^ basename in
30
  let source_main_file = destname ^ "_main.c" in (* Could be changed *)
31
  let makefile_file = destname ^ ".makefile" in (* Could be changed *)
32
  
35 33
  let print_header, print_lib_c, print_main_c, print_makefile = funs in
34

  
36 35
  (* Generating H file *)
36
  let alloc_header_file = destname ^ "_alloc.h" in (* Could be changed *)
37
  let header_out = open_out alloc_header_file in
38
  let header_fmt = formatter_of_out_channel header_out in
37 39
  print_header header_fmt basename prog machines dependencies;
38
 
40
  close_out header_out;
41
  
39 42
  (* Generating Lib C file *)
43
  let source_lib_file = destname ^ ".c" in (* Could be changed *)
44
  let source_lib_out = open_out source_lib_file in
45
  let source_lib_fmt = formatter_of_out_channel source_lib_out in
40 46
  print_lib_c source_lib_fmt basename prog machines dependencies;
41
 
42
  close_out header_out;
43 47
  close_out source_lib_out;
44 48

  
45 49
  match !Options.main_node with
46
  | "" ->  () (* No main node: we do not genenrate main nor makefile *)
50
  | "" ->  () (* No main node: we do not generate main nor makefile *)
47 51
  | main_node -> (
48 52
    match Machine_code.get_machine_opt main_node machines with
49
    | None -> Format.eprintf "Unable to find a main node named %s@.@?" main_node; assert false
53
    | None -> begin
54
      Global.main_node := main_node;
55
      Format.eprintf "Code generation error: %a@." Corelang.pp_error LustreSpec.Main_not_found;
56
      raise (Corelang.Error (Location.dummy_loc, LustreSpec.Main_not_found))
57
    end
50 58
    | Some m -> begin
51 59
      let source_main_out = open_out source_main_file in
52 60
      let source_main_fmt = formatter_of_out_channel source_main_out in
......
57 65
      print_main_c source_main_fmt m basename prog machines dependencies;
58 66
      
59 67
      (* Generating Makefile *)
60
     print_makefile basename main_node dependencies makefile_fmt;
68
      print_makefile basename main_node dependencies makefile_fmt;
61 69

  
62 70
     close_out source_main_out;
63 71
     close_out makefile_out
......
65 73
    end
66 74
  )
67 75

  
68
let translate_to_c header source_lib source_main makefile basename prog machines dependencies =
76
let translate_to_c basename prog machines dependencies =
69 77
  match !Options.spec with
70 78
  | "no" -> begin
71 79
    let module HeaderMod = C_backend_header.EmptyMod in
......
84 92
      SourceMain.print_main_c, 
85 93
      Makefile.print_makefile 
86 94
    in
87
    gen_files 
88
      funs basename prog machines dependencies 
89
      header source_lib source_main makefile machines
95
    gen_files funs basename prog machines dependencies 
90 96

  
91 97
  end
92 98
  | "acsl" -> begin
......
107 113
      SourceMain.print_main_c,
108 114
      Makefile.print_makefile 
109 115
    in
110
    gen_files
111
      funs basename prog machines dependencies
112
      header source_lib source_main makefile machines
116
    gen_files funs basename prog machines dependencies 
113 117

  
114 118
  end
115 119
  | "c" -> begin
src/backends/C/c_backend_common.ml
17 17

  
18 18
let print_version fmt =
19 19
  Format.fprintf fmt 
20
    "/* @[<v>C code generated by %s@,SVN version number %s@,Code is %s compliant */@,@]@."
20
    "/* @[<v>C code generated by %s@,Version number %s@,Code is %s compliant@,Using %s numbers */@,@]@."
21 21
    (Filename.basename Sys.executable_name) 
22 22
    Version.number 
23 23
    (if !Options.ansi then "ANSI C90" else "C99")
24
 
24
    (if !Options.mpfr then "MPFR multi-precision" else "(double) floating-point")
25

  
26
let file_to_module_name basename =
27
  let baseNAME = String.uppercase basename in
28
  let baseNAME = Str.global_replace (Str.regexp "\\.\\|\\ ") "_" baseNAME in
29
  baseNAME
30

  
25 31
(* Generation of a non-clashing name for the self memory variable (for step and reset functions) *)
26 32
let mk_self m =
27 33
  let used name =
......
83 89
    if List.exists (fun v -> v.var_id = s) vars then aux () else s
84 90
  in aux ()
85 91
*)
92
let pp_global_init_name fmt id = fprintf fmt "%s_INIT" id
93
let pp_global_clear_name fmt id = fprintf fmt "%s_CLEAR" id
86 94
let pp_machine_memtype_name fmt id = fprintf fmt "struct %s_mem" id
87 95
let pp_machine_regtype_name fmt id = fprintf fmt "struct %s_reg" id
88 96
let pp_machine_alloc_name fmt id = fprintf fmt "%s_alloc" id
......
90 98
let pp_machine_static_link_name fmt id = fprintf fmt "%s_LINK" id
91 99
let pp_machine_static_alloc_name fmt id = fprintf fmt "%s_ALLOC" id
92 100
let pp_machine_reset_name fmt id = fprintf fmt "%s_reset" id
101
let pp_machine_init_name fmt id = fprintf fmt "%s_init" id
102
let pp_machine_clear_name fmt id = fprintf fmt "%s_clear" id
93 103
let pp_machine_step_name fmt id = fprintf fmt "%s_step" id
94 104

  
95 105
let rec pp_c_dimension fmt dim =
......
116 126

  
117 127
let pp_basic_c_type fmt t =
118 128
  match (Types.repr t).Types.tdesc with
119
  | Types.Tbool           -> fprintf fmt "_Bool"
120
  | Types.Treal           -> fprintf fmt "double"
121
  | Types.Tint            -> fprintf fmt "int"
129
  | Types.Tbool                    -> fprintf fmt "_Bool"
130
  | Types.Treal when !Options.mpfr -> fprintf fmt "%s" Mpfr.mpfr_t
131
  | Types.Treal                    -> fprintf fmt "double"
132
  | Types.Tint                     -> fprintf fmt "int"
122 133
  | _ -> assert false (* Not a basic C type. Do not handle arrays or pointers *)
123 134

  
124 135
let pp_c_type var fmt t =
125 136
  let rec aux t pp_suffix =
126 137
    match (Types.repr t).Types.tdesc with
127 138
    | Types.Tclock t'       -> aux t' pp_suffix
128
    | Types.Tbool | Types.Treal | Types.Tint 
139
    | Types.Tbool | Types.Tint | Types.Treal
129 140
                            -> fprintf fmt "%a %s%a" pp_basic_c_type t var pp_suffix ()
130 141
    | Types.Tarray (d, t')  ->
131 142
      let pp_suffix' fmt () = fprintf fmt "%a[%a]" pp_suffix () pp_c_dimension d in
......
135 146
    | Types.Tarrow (_, _)   -> fprintf fmt "void (*%s)()" var
136 147
    | _                     -> eprintf "internal error: C_backend_common.pp_c_type %a@." Types.print_ty t; assert false
137 148
  in aux t (fun fmt () -> ())
138

  
149
(*
139 150
let rec pp_c_initialize fmt t = 
140 151
  match (Types.repr t).Types.tdesc with
141 152
  | Types.Tint -> pp_print_string fmt "0"
142 153
  | Types.Tclock t' -> pp_c_initialize fmt t'
143 154
  | Types.Tbool -> pp_print_string fmt "0" 
144
  | Types.Treal -> pp_print_string fmt "0."
155
  | Types.Treal when not !Options.mpfr -> pp_print_string fmt "0."
145 156
  | Types.Tarray (d, t') when Dimension.is_dimension_const d ->
146 157
    fprintf fmt "{%a}"
147 158
      (Utils.fprintf_list ~sep:"," (fun fmt _ -> pp_c_initialize fmt t'))
148 159
      (Utils.duplicate 0 (Dimension.size_const_dimension d))
149 160
  | _ -> assert false
150

  
151

  
161
 *)
152 162
let pp_c_tag fmt t =
153 163
 pp_print_string fmt (if t = tag_true then "1" else if t = tag_false then "0" else t)
154 164

  
155

  
156 165
(* Prints a constant value *)
157 166
let rec pp_c_const fmt c =
158 167
  match c with
159 168
    | Const_int i     -> pp_print_int fmt i
160
    | Const_real r    -> pp_print_string fmt r
161
    | Const_float r   -> pp_print_float fmt r
169
    | Const_real (c,e,s)-> pp_print_string fmt s (* Format.fprintf fmt "%ie%i" c e*)
170
    (* | Const_float r   -> pp_print_float fmt r *)
162 171
    | Const_tag t     -> pp_c_tag fmt t
163 172
    | Const_array ca  -> fprintf fmt "{%a }" (Utils.fprintf_list ~sep:", " pp_c_const) ca
164 173
    | Const_struct fl -> fprintf fmt "{%a }" (Utils.fprintf_list ~sep:", " (fun fmt (f, c) -> pp_c_const fmt c)) fl
......
169 178
   but an offset suffix may be added for array variables
170 179
*)
171 180
let rec pp_c_val self pp_var fmt v =
172
  (*Format.eprintf "C_backend_common.pp_c_val %a@." pp_val v;*)
173
  match v with
181
  match v.value_desc with
174 182
  | Cst c         -> pp_c_const fmt c
175 183
  | Array vl      -> fprintf fmt "{%a}" (Utils.fprintf_list ~sep:", " (pp_c_val self pp_var)) vl
176 184
  | Access (t, i) -> fprintf fmt "%a[%a]" (pp_c_val self pp_var) t (pp_c_val self pp_var) i
......
179 187
  | StateVar v    ->
180 188
    (* array memory vars are represented by an indirection to a local var with the right type,
181 189
       in order to avoid casting everywhere. *)
182
    if Types.is_array_type v.var_type
190
    if Types.is_array_type v.var_type && not (Types.is_real_type v.var_type && !Options.mpfr)
183 191
    then fprintf fmt "%a" pp_var v
184 192
    else fprintf fmt "%s->_reg.%a" self pp_var v
185 193
  | Fun (n, vl)   -> Basic_library.pp_c n (pp_c_val self pp_var) fmt vl
......
191 199
   - moreover, dereference memory array variables.
192 200
*)
193 201
let pp_c_var_read m fmt id =
202
  (* mpfr_t is a static array, not treated as general arrays *)
194 203
  if Types.is_address_type id.var_type
195 204
  then
196
    if is_memory m id
205
    if is_memory m id && not (Types.is_real_type id.var_type && !Options.mpfr)
197 206
    then fprintf fmt "(*%s)" id.var_id
198 207
    else fprintf fmt "%s" id.var_id
199 208
  else
......
289 298
let pp_registers_struct fmt m =
290 299
  if m.mmemory <> []
291 300
  then
292
    fprintf fmt "@[%a {@[%a; @]}@] _reg; "
301
    fprintf fmt "@[%a {@[<v>%a;@ @]}@] _reg; "
293 302
      pp_machine_regtype_name m.mname.node_id
294
      (Utils.fprintf_list ~sep:"; " pp_c_decl_struct_var) m.mmemory
303
      (Utils.fprintf_list ~sep:";@ " pp_c_decl_struct_var) m.mmemory
295 304
  else
296 305
    ()
297 306

  
......
302 311
  else
303 312
    begin
304 313
      (* Define struct *)
305
      fprintf fmt "@[%a {@[%a%a%t@]};@]@."
314
      fprintf fmt "@[%a {@[<v>%a%t%a%t@]};@]@."
306 315
	pp_machine_memtype_name m.mname.node_id
307 316
	pp_registers_struct m
308
	(Utils.fprintf_list ~sep:"; " pp_c_decl_instance_var) m.minstances
309
	(Utils.pp_final_char_if_non_empty "; " m.minstances)
317
	(Utils.pp_final_char_if_non_empty "@ " m.mmemory)
318
	(Utils.fprintf_list ~sep:";@ " pp_c_decl_instance_var) m.minstances
319
	(Utils.pp_final_char_if_non_empty ";@ " m.minstances)
310 320
    end
311 321

  
312 322
let print_machine_struct_from_header fmt inode =
......
324 334
(*                      Prototype Printing functions                                        *)
325 335
(********************************************************************************************)
326 336

  
337
let print_global_init_prototype fmt baseNAME =
338
  fprintf fmt "void %a ()"
339
    pp_global_init_name baseNAME
340

  
341
let print_global_clear_prototype fmt baseNAME =
342
  fprintf fmt "void %a ()"
343
    pp_global_clear_name baseNAME
344

  
327 345
let print_alloc_prototype fmt (name, static) =
328 346
  fprintf fmt "%a * %a (%a)"
329 347
    pp_machine_memtype_name name
......
338 356
    pp_machine_memtype_name name
339 357
    self
340 358

  
359
let print_init_prototype self fmt (name, static) =
360
  fprintf fmt "void %a (@[<v>%a%t%a *%s@])"
361
    pp_machine_init_name name
362
    (Utils.fprintf_list ~sep:",@ " pp_c_decl_input_var) static
363
    (Utils.pp_final_char_if_non_empty ",@," static) 
364
    pp_machine_memtype_name name
365
    self
366

  
367
let print_clear_prototype self fmt (name, static) =
368
  fprintf fmt "void %a (@[<v>%a%t%a *%s@])"
369
    pp_machine_clear_name name
370
    (Utils.fprintf_list ~sep:",@ " pp_c_decl_input_var) static
371
    (Utils.pp_final_char_if_non_empty ",@," static) 
372
    pp_machine_memtype_name name
373
    self
374

  
341 375
let print_stateless_prototype fmt (name, inputs, outputs) =
342 376
  fprintf fmt "void %a (@[<v>@[%a%t@]@,@[%a@]@,@])"
343 377
    pp_machine_step_name name
......
366 400
    name
367 401
    (Utils.fprintf_list ~sep:",@ " pp_c_decl_input_var) inputs
368 402
    
369
    
403
let print_import_init fmt (Dep (local, basename, _, _)) =
404
  if local then
405
    let baseNAME = file_to_module_name basename in
406
    fprintf fmt "%a();" pp_global_init_name baseNAME
407
  else ()
408

  
409
let print_import_clear fmt (Dep (local, basename, _, _)) =
410
  if local then
411
    let baseNAME = file_to_module_name basename in
412
    fprintf fmt "%a();" pp_global_clear_name baseNAME
413
  else ()
370 414

  
371 415
let print_import_prototype fmt (Dep (_, s, _, _)) =
372 416
  fprintf fmt "#include \"%s.h\"@," s
......
383 427
  | _                -> ()
384 428
  ) header
385 429

  
430

  
431
let pp_c_main_var_input fmt id =  
432
  fprintf fmt "%s" id.var_id
433

  
434
let pp_c_main_var_output fmt id =
435
  if Types.is_address_type id.var_type
436
  then
437
    fprintf fmt "%s" id.var_id
438
  else
439
    fprintf fmt "&%s" id.var_id
440

  
441
let pp_main_call mname self fmt m (inputs: value_t list) (outputs: var_decl list) =
442
  if fst (get_stateless_status m)
443
  then
444
    fprintf fmt "%a (%a%t%a);"
445
      pp_machine_step_name mname
446
      (Utils.fprintf_list ~sep:", " (pp_c_val self pp_c_main_var_input)) inputs
447
      (Utils.pp_final_char_if_non_empty ", " inputs) 
448
      (Utils.fprintf_list ~sep:", " pp_c_main_var_output) outputs
449
  else
450
    fprintf fmt "%a (%a%t%a%t%s);"
451
      pp_machine_step_name mname
452
      (Utils.fprintf_list ~sep:", " (pp_c_val self pp_c_main_var_input)) inputs
453
      (Utils.pp_final_char_if_non_empty ", " inputs) 
454
      (Utils.fprintf_list ~sep:", " pp_c_main_var_output) outputs
455
      (Utils.pp_final_char_if_non_empty ", " outputs)
456
      self
457

  
458
let pp_c_var m self pp_var fmt var =
459
  if is_memory m var
460
  then
461
    pp_c_val self pp_var fmt (mk_val (StateVar var) var.var_type)
462
  else
463
    pp_c_val self pp_var fmt (mk_val (LocalVar var) var.var_type)
464

  
465
let pp_array_suffix fmt loop_vars =
466
  Utils.fprintf_list ~sep:"" (fun fmt v -> fprintf fmt "[%s]" v) fmt loop_vars
467

  
468
(* type directed initialization: useless wrt the lustre compilation model,
469
   except for MPFR injection, where values are dynamically allocated
470
*)
471
let pp_initialize m self pp_var fmt var =
472
  let rec aux indices fmt typ =
473
    if Types.is_array_type typ
474
    then
475
      let dim = Types.array_type_dimension typ in
476
      let idx = mk_loop_var m () in
477
      fprintf fmt "@[<v 2>{@,int %s;@,for(%s=0;%s<%a;%s++)@,%a @]@,}"
478
	idx idx idx pp_c_dimension dim idx
479
	(aux (idx::indices)) (Types.array_element_type typ)
480
    else
481
      let indices = List.rev indices in
482
      let pp_var_suffix fmt var =
483
	fprintf fmt "%a%a" (pp_c_var m self pp_var) var pp_array_suffix indices in
484
      Mpfr.pp_inject_init pp_var_suffix fmt var
485
  in
486
  if !Options.mpfr && Types.is_real_type (Types.array_base_type var.var_type)
487
  then
488
    begin
489
      reset_loop_counter ();
490
      aux [] fmt var.var_type
491
    end
492

  
493
let pp_const_initialize pp_var fmt const =
494
  let var = mk_val (LocalVar (Corelang.var_decl_of_const const)) const.const_type in
495
  let rec aux indices value fmt typ =
496
    if Types.is_array_type typ
497
    then
498
      let dim = Types.array_type_dimension typ in
499
      let szl = Utils.enumerate (Dimension.size_const_dimension dim) in
500
      let typ' = Types.array_element_type typ in
501
      let value = match value with
502
	| Const_array ca -> List.nth ca
503
	| _                      -> assert false in
504
      fprintf fmt "%a"
505
	(Utils.fprintf_list ~sep:"@," (fun fmt i -> aux (string_of_int i::indices) (value i) fmt typ')) szl
506
    else
507
      let indices = List.rev indices in
508
      let pp_var_suffix fmt var =
509
	fprintf fmt "%a%a" (pp_c_val "" pp_var) var pp_array_suffix indices in
510
      begin
511
	Mpfr.pp_inject_init pp_var_suffix fmt var;
512
	fprintf fmt "@,";
513
	Mpfr.pp_inject_real pp_var_suffix pp_c_const fmt var value
514
      end
515
  in
516
  if !Options.mpfr && Types.is_real_type (Types.array_base_type const.const_type)
517
  then
518
    begin
519
      reset_loop_counter ();
520
      aux [] const.const_value fmt const.const_type
521
    end
522

  
523
(* type directed clear: useless wrt the lustre compilation model,
524
   except for MPFR injection, where values are dynamically allocated
525
*)
526
let pp_clear m self pp_var fmt var =
527
  let rec aux indices fmt typ =
528
    if Types.is_array_type typ
529
    then
530
      let dim = Types.array_type_dimension typ in
531
      let idx = mk_loop_var m () in
532
      fprintf fmt "@[<v 2>{@,int %s;@,for(%s=0;%s<%a;%s++)@,%a @]@,}"
533
	idx idx idx pp_c_dimension dim idx
534
	(aux (idx::indices)) (Types.array_element_type typ)
535
    else
536
      let indices = List.rev indices in
537
      let pp_var_suffix fmt var =
538
	fprintf fmt "%a%a" (pp_c_var m self pp_var) var pp_array_suffix indices in
539
      Mpfr.pp_inject_clear pp_var_suffix fmt var
540
  in
541
  if !Options.mpfr && Types.is_real_type (Types.array_base_type var.var_type)
542
  then
543
    begin
544
      reset_loop_counter ();
545
      aux [] fmt var.var_type
546
    end
547

  
548
let pp_const_clear pp_var fmt const =
549
  let m = Machine_code.empty_machine in
550
  let var = Corelang.var_decl_of_const const in
551
  let rec aux indices fmt typ =
552
    if Types.is_array_type typ
553
    then
554
      let dim = Types.array_type_dimension typ in
555
      let idx = mk_loop_var m () in
556
      fprintf fmt "@[<v 2>{@,int %s;@,for(%s=0;%s<%a;%s++)@,%a @]@,}"
557
	idx idx idx pp_c_dimension dim idx
558
	(aux (idx::indices)) (Types.array_element_type typ)
559
    else
560
      let indices = List.rev indices in
561
      let pp_var_suffix fmt var =
562
	fprintf fmt "%a%a" (pp_c_var m "" pp_var) var pp_array_suffix indices in
563
      Mpfr.pp_inject_clear pp_var_suffix fmt var 
564
  in
565
  if !Options.mpfr && Types.is_real_type (Types.array_base_type var.var_type)
566
  then
567
    begin
568
      reset_loop_counter ();
569
      aux [] fmt var.var_type
570
    end
571

  
572
let pp_call m self pp_read pp_write fmt i (inputs: value_t list) (outputs: var_decl list) =
573
 try (* stateful node instance *)
574
   let (n,_) = List.assoc i m.minstances in
575
   fprintf fmt "%a (%a%t%a%t%s->%s);"
576
     pp_machine_step_name (node_name n)
577
     (Utils.fprintf_list ~sep:", " (pp_c_val self pp_read)) inputs
578
     (Utils.pp_final_char_if_non_empty ", " inputs) 
579
     (Utils.fprintf_list ~sep:", " pp_write) outputs
580
     (Utils.pp_final_char_if_non_empty ", " outputs)
581
     self
582
     i
583
 with Not_found -> (* stateless node instance *)
584
   let (n,_) = List.assoc i m.mcalls in
585
   fprintf fmt "%a (%a%t%a);"
586
     pp_machine_step_name (node_name n)
587
     (Utils.fprintf_list ~sep:", " (pp_c_val self pp_read)) inputs
588
     (Utils.pp_final_char_if_non_empty ", " inputs) 
589
     (Utils.fprintf_list ~sep:", " pp_write) outputs 
590

  
591
let pp_basic_instance_call m self fmt i (inputs: value_t list) (outputs: var_decl list) =
592
  pp_call m self (pp_c_var_read m) (pp_c_var_write m) fmt i inputs outputs
593
(*
594
 try (* stateful node instance *)
595
   let (n,_) = List.assoc i m.minstances in
596
   fprintf fmt "%a (%a%t%a%t%s->%s);"
597
     pp_machine_step_name (node_name n)
598
     (Utils.fprintf_list ~sep:", " (pp_c_val self (pp_c_var_read m))) inputs
599
     (Utils.pp_final_char_if_non_empty ", " inputs) 
600
     (Utils.fprintf_list ~sep:", " (pp_c_var_write m)) outputs
601
     (Utils.pp_final_char_if_non_empty ", " outputs)
602
     self
603
     i
604
 with Not_found -> (* stateless node instance *)
605
   let (n,_) = List.assoc i m.mcalls in
606
   fprintf fmt "%a (%a%t%a);"
607
     pp_machine_step_name (node_name n)
608
     (Utils.fprintf_list ~sep:", " (pp_c_val self (pp_c_var_read m))) inputs
609
     (Utils.pp_final_char_if_non_empty ", " inputs) 
610
     (Utils.fprintf_list ~sep:", " (pp_c_var_write m)) outputs 
611
*)
612

  
613
let pp_instance_call m self fmt i (inputs: value_t list) (outputs: var_decl list) =
614
  let pp_offset pp_var indices fmt var =
615
    match indices with
616
    | [] -> fprintf fmt "%a" pp_var var
617
    | _  -> fprintf fmt "%a[%a]" pp_var var (Utils.fprintf_list ~sep:"][" pp_print_string) indices in
618
  let rec aux indices fmt typ =
619
    if Types.is_array_type typ
620
    then
621
      let dim = Types.array_type_dimension typ in
622
      let idx = mk_loop_var m () in
623
      fprintf fmt "@[<v 2>{@,int %s;@,for(%s=0;%s<%a;%s++)@,%a @]@,}"
624
	idx idx idx pp_c_dimension dim idx
625
	(aux (idx::indices)) (Types.array_element_type typ)
626
    else
627
      let pp_read  = pp_offset (pp_c_var_read  m) indices in
628
      let pp_write = pp_offset (pp_c_var_write m) indices in
629
      pp_call m self pp_read pp_write fmt i inputs outputs
630
  in
631
  begin
632
    reset_loop_counter ();
633
    aux [] fmt (List.hd inputs).value_type
634
  end
635

  
386 636
(* Local Variables: *)
387 637
(* compile-command:"make -C ../../.." *)
388 638
(* End: *)
src/backends/C/c_backend_header.ml
34 34
struct
35 35

  
36 36
let print_import_standard fmt =
37
  fprintf fmt "#include \"%s/arrow.h\"@.@." Version.include_path
37
  begin
38
    if !Options.mpfr then
39
      begin
40
	fprintf fmt "#include <mpfr.h>@."
41
      end;
42
    fprintf fmt "#include \"%s/arrow.h\"@.@." Version.include_path
43
  end
38 44

  
39 45
let rec print_static_val pp_var fmt v =
40
  match v with
46
  match v.value_desc with
41 47
  | Cst c         -> pp_c_const fmt c
42 48
  | LocalVar v    -> pp_var fmt v
43 49
  | Fun (n, vl)   -> Basic_library.pp_c n (print_static_val pp_var) fmt vl
......
145 151
    inst
146 152

  
147 153
let print_machine_decl fmt m =
148
  Mod.print_machine_decl_prefix fmt m;
149
  if fst (get_stateless_status m) then
150
    begin
151
      fprintf fmt "extern %a;@.@."
152
	print_stateless_prototype
153
	(m.mname.node_id, m.mstep.step_inputs, m.mstep.step_outputs)
154
    end
155
  else
156
    begin
157
      (* Static allocation *)
158
      if !Options.static_mem
159
      then
160
	begin
161
	  let inst = mk_instance m in
162
	  let attr = mk_attribute m in
163
	  fprintf fmt "%a@.%a@.%a@."
164
	    print_static_declare_macro (m, attr, inst)
165
	    print_static_link_macro (m, attr, inst)
166
	    print_static_alloc_macro (m, attr, inst)
167
	end
168
      else
169
	begin 
170
        (* Dynamic allocation *)
171
	  fprintf fmt "extern %a;@.@."
172
	    print_alloc_prototype (m.mname.node_id, m.mstatic)
173
	end;
174
      let self = mk_self m in
175
      fprintf fmt "extern %a;@.@."
176
	(print_reset_prototype self) (m.mname.node_id, m.mstatic);
154
  begin
155
    Mod.print_machine_decl_prefix fmt m;
156
    if fst (get_stateless_status m) then
157
      begin
158
	fprintf fmt "extern %a;@.@."
159
	  print_stateless_prototype
160
	  (m.mname.node_id, m.mstep.step_inputs, m.mstep.step_outputs)
161
      end
162
    else
163
      begin
164
        (* Static allocation *)
165
	if !Options.static_mem
166
	then
167
	  begin
168
	    let inst = mk_instance m in
169
	    let attr = mk_attribute m in
170
	    fprintf fmt "%a@.%a@.%a@."
171
	      print_static_declare_macro (m, attr, inst)
172
	      print_static_link_macro (m, attr, inst)
173
	      print_static_alloc_macro (m, attr, inst)
174
	  end
175
	else
176
	  begin 
177
            (* Dynamic allocation *)
178
	    fprintf fmt "extern %a;@.@."
179
	      print_alloc_prototype (m.mname.node_id, m.mstatic)
180
	  end;
181
	let self = mk_self m in
182
	fprintf fmt "extern %a;@.@."
183
	  (print_reset_prototype self) (m.mname.node_id, m.mstatic);
177 184

  
178
      fprintf fmt "extern %a;@.@."
179
	(print_step_prototype self)
180
	(m.mname.node_id, m.mstep.step_inputs, m.mstep.step_outputs)
181
    end
185
	fprintf fmt "extern %a;@.@."
186
	  (print_step_prototype self)
187
	  (m.mname.node_id, m.mstep.step_inputs, m.mstep.step_outputs);
188
	
189
	if !Options.mpfr then
190
	  begin
191
	    fprintf fmt "extern %a;@.@."
192
	      (print_init_prototype self) (m.mname.node_id, m.mstatic);
193

  
194
	    fprintf fmt "extern %a;@.@."
195
	      (print_clear_prototype self) (m.mname.node_id, m.mstatic);
196
	  end
197
      end
198
  end
182 199

  
183 200
let print_machine_alloc_decl fmt m =
184 201
  Mod.print_machine_decl_prefix fmt m;
......
215 232
	  print_stateless_C_prototype
216 233
	  (inode.nodei_id, inode.nodei_inputs, inode.nodei_outputs)
217 234
      end
218
    else (
219
      raise (Invalid_argument ("A node with declared prototype C cannot be stateful, it has to be a function")))
235
    else (Format.eprintf "internal error: print_machine_decl_from_header"; assert false)
220 236
  else
221 237
    if inode.nodei_stateless then
222 238
    begin
......
233 249
	let self = mk_new_name used "self" in
234 250
	fprintf fmt "extern %a;@.@."
235 251
	  (print_reset_prototype self) (inode.nodei_id, static_inputs);
236
	
252

  
253
	fprintf fmt "extern %a;@.@."
254
	  (print_init_prototype self) (inode.nodei_id, static_inputs);
255

  
256
	fprintf fmt "extern %a;@.@."
257
	  (print_clear_prototype self) (inode.nodei_id, static_inputs);
258

  
237 259
	fprintf fmt "extern %a;@.@."
238 260
	  (print_step_prototype self)
239 261
	  (inode.nodei_id, inode.nodei_inputs, inode.nodei_outputs)
240 262
      end
241 263

  
242 264
let print_const_decl fmt cdecl =
243
  fprintf fmt "extern %a;@." 
244
    (pp_c_type cdecl.const_id) cdecl.const_type
265
  if !Options.mpfr &&  Types.is_real_type (Types.array_base_type cdecl.const_type)
266
  then
267
    fprintf fmt "extern %a;@." 
268
      (pp_c_type cdecl.const_id) (Types.dynamic_type cdecl.const_type) 
269
  else
270
    fprintf fmt "extern %a;@." 
271
      (pp_c_type cdecl.const_id) cdecl.const_type
245 272

  
246 273
let rec pp_c_struct_type_field filename cpt fmt (label, tdesc) =
247 274
  fprintf fmt "%a;" (pp_c_type_decl filename cpt label) tdesc
......
249 276
  match tdecl with
250 277
  | Tydec_any           -> assert false
251 278
  | Tydec_int           -> fprintf fmt "int %s" var
279
  | Tydec_real when !Options.mpfr
280
                        -> fprintf fmt "%s %s" Mpfr.mpfr_t var
252 281
  | Tydec_real          -> fprintf fmt "double %s" var
253
  | Tydec_float         -> fprintf fmt "float %s" var
282
  (* | Tydec_float         -> fprintf fmt "float %s" var *)
254 283
  | Tydec_bool          -> fprintf fmt "_Bool %s" var
255 284
  | Tydec_clock ty      -> pp_c_type_decl filename cpt var fmt ty
256 285
  | Tydec_const c       -> fprintf fmt "%s %s" c var
......
290 319
(********************************************************************************************)
291 320
let print_header header_fmt basename prog machines dependencies =
292 321
  (* Include once: start *)
293
  let baseNAME = String.uppercase basename in
294
  let baseNAME = Str.global_replace (Str.regexp "\\.\\|\\ ") "_" baseNAME in
322
  let baseNAME = file_to_module_name basename in
295 323
  begin
296
    (* Print the svn version number and the supported C standard (C90 or C99) *)
324
    (* Print the version number and the supported C standard (C90 or C99) *)
297 325
    print_version header_fmt;
298 326
    fprintf header_fmt "#ifndef _%s@.#define _%s@." baseNAME baseNAME;
299 327
    pp_print_newline header_fmt ();
......
302 330
    print_import_standard header_fmt;
303 331
    pp_print_newline header_fmt ();
304 332
    (* imports dependencies *)
305
    fprintf header_fmt "/* Import Dependencies */@.";
333
    fprintf header_fmt "/* Import dependencies */@.";
306 334
    fprintf header_fmt "@[<v>";
307 335
    List.iter (print_import_prototype header_fmt) dependencies;
308 336
    fprintf header_fmt "@]@.";
......
314 342
    fprintf header_fmt "/* Global constant (declarations, definitions are in C file) */@.";
315 343
    List.iter (fun c -> print_const_decl header_fmt (const_of_top c)) (get_consts prog);
316 344
    pp_print_newline header_fmt ();
345
    if !Options.mpfr then
346
      begin
347
	fprintf header_fmt "/* Global initialization declaration */@.";
348
	fprintf header_fmt "extern %a;@.@."
349
	  print_global_init_prototype baseNAME;
350
	
351
	fprintf header_fmt "/* Global clear declaration */@.";
352
	fprintf header_fmt "extern %a;@.@."
353
	  print_global_clear_prototype baseNAME;
354
      end;
317 355
    (* Print the struct declarations of all machines. *)
318
    fprintf header_fmt "/* Struct declarations */@.";
356
    fprintf header_fmt "/* Structs declarations */@.";
319 357
    List.iter (print_machine_struct header_fmt) machines;
320 358
    pp_print_newline header_fmt ();
321 359
    (* Print the prototypes of all machines *)
......
329 367

  
330 368
let print_alloc_header header_fmt basename prog machines dependencies =
331 369
  (* Include once: start *)
332
  let baseNAME = String.uppercase basename in
333
  let baseNAME = Str.global_replace (Str.regexp "\\.\\|\\ ") "_" baseNAME in
370
  let baseNAME = file_to_module_name basename in
334 371
  begin
335 372
    (* Print the svn version number and the supported C standard (C90 or C99) *)
336 373
    print_version header_fmt;
......
362 399
   header. *)
363 400
let print_header_from_header header_fmt basename header =
364 401
  (* Include once: start *)
365
  let baseNAME = String.uppercase basename in
366
  let baseNAME = Str.global_replace (Str.regexp "\\.\\|\\ ") "_" baseNAME in
402
  let baseNAME = file_to_module_name basename in
367 403
  let types = get_typedefs header in
368 404
  let consts = get_consts header in
369 405
  let nodes = get_imported_nodes header in
370 406
  let dependencies = get_dependencies header in
371 407
  begin
372
    (* Print the svn version number and the supported C standard (C90 or C99) *)
408
    (* Print the version number and the supported C standard (C90 or C99) *)
373 409
    print_version header_fmt;
374 410
    fprintf header_fmt "#ifndef _%s@.#define _%s@." baseNAME baseNAME;
375 411
    pp_print_newline header_fmt ();
......
395 431
    fprintf header_fmt "/* Global constant (declarations, definitions are in C file) */@.";
396 432
    List.iter (fun c -> print_const_decl header_fmt (const_of_top c)) consts;
397 433
    pp_print_newline header_fmt ();
434
    if !Options.mpfr then
435
      begin
436
	fprintf header_fmt "/* Global initialization declaration */@.";
437
	fprintf header_fmt "extern %a;@.@."
438
	  print_global_init_prototype baseNAME;
439
	
440
	fprintf header_fmt "/* Global clear declaration */@.";
441
	fprintf header_fmt "extern %a;@.@."
442
	  print_global_clear_prototype baseNAME;
443
      end;
398 444
    (* Print the struct declarations of all machines. *)
399
    fprintf header_fmt "/* Struct declarations */@.";
445
    fprintf header_fmt "/* Structs declarations */@.";
400 446
    List.iter (fun node -> print_machine_struct_from_header header_fmt (imported_node_of_top node)) nodes;
401 447
    pp_print_newline header_fmt ();
402 448
    (* Print the prototypes of all machines *)
src/backends/C/c_backend_main.ml
30 30
(*                         Main related functions                                           *)
31 31
(********************************************************************************************)
32 32

  
33
let print_get_input fmt v =
34
  match (Types.repr v.var_type).Types.tdesc with
35
    | Types.Tint -> fprintf fmt "_get_int(\"%s\")" v.var_id
36
    | Types.Tbool -> fprintf fmt "_get_bool(\"%s\")" v.var_id
37
    | Types.Treal -> fprintf fmt "_get_double(\"%s\")" v.var_id
38
    | _ -> assert false
33
let print_get_inputs fmt m =
34
  let pi fmt (v', v) =
35
  match (Types.unclock_type v.var_type).Types.tdesc with
36
    | Types.Tint -> fprintf fmt "%s = _get_int(\"%s\")" v.var_id v'.var_id
37
    | Types.Tbool -> fprintf fmt "%s = _get_bool(\"%s\")" v.var_id v'.var_id
38
    | Types.Treal when !Options.mpfr -> fprintf fmt "mpfr_set_d(%s, _get_double(\"%s\"), %i)" v.var_id v'.var_id (Mpfr.mpfr_prec ())
39
    | Types.Treal -> fprintf fmt "%s = _get_double(\"%s\")" v.var_id v'.var_id
40
    | _ ->
41
      begin
42
	Global.main_node := !Options.main_node;
43
	Format.eprintf "Code generation error: %a%a@."
44
	  pp_error Main_wrong_kind
45
	  Location.pp_loc v'.var_loc;
46
	raise (Error (v'.var_loc, Main_wrong_kind))
47
      end
48
  in
49
  List.iter2 (fun v' v -> fprintf fmt "@ %a;" pi (v', v)) m.mname.node_inputs m.mstep.step_inputs
39 50

  
40
let print_put_outputs fmt ol = 
41
  let po fmt o =
42
    match (Types.repr o.var_type).Types.tdesc with
43
    | Types.Tint -> fprintf fmt "_put_int(\"%s\", %s)" o.var_id o.var_id
44
    | Types.Tbool -> fprintf fmt "_put_bool(\"%s\", %s)" o.var_id o.var_id
45
    | Types.Treal -> fprintf fmt "_put_double(\"%s\", %s)" o.var_id o.var_id
51
let print_put_outputs fmt m = 
52
  let po fmt (o', o) =
53
    match (Types.unclock_type o.var_type).Types.tdesc with
54
    | Types.Tint -> fprintf fmt "_put_int(\"%s\", %s)" o'.var_id o.var_id
55
    | Types.Tbool -> fprintf fmt "_put_bool(\"%s\", %s)" o'.var_id o.var_id
56
    | Types.Treal when !Options.mpfr -> fprintf fmt "_put_double(\"%s\", mpfr_get_d(%s, %s))" o'.var_id o.var_id (Mpfr.mpfr_rnd ())
57
    | Types.Treal -> fprintf fmt "_put_double(\"%s\", %s)" o'.var_id o.var_id
46 58
    | _ -> assert false
47 59
  in
48
  List.iter (fprintf fmt "@ %a;" po) ol
60
  List.iter2 (fun v' v -> fprintf fmt "@ %a;" po (v', v)) m.mname.node_outputs m.mstep.step_outputs
61

  
62
let print_main_inout_declaration fmt m =
63
  begin
64
    fprintf fmt "/* Declaration of inputs/outputs variables */@ ";
65
    List.iter 
66
      (fun v -> fprintf fmt "%a;@ " (pp_c_type v.var_id) v.var_type
67
      ) m.mstep.step_inputs;
68
    List.iter 
69
      (fun v -> fprintf fmt "%a;@ " (pp_c_type v.var_id) v.var_type
70
      ) m.mstep.step_outputs
71
  end
72

  
73
let print_main_memory_allocation mname main_mem fmt m =
74
  if not (fst (get_stateless_status m)) then
75
  begin  
76
    fprintf fmt "@ /* Main memory allocation */@ ";
77
    if (!Options.static_mem && !Options.main_node <> "")
78
    then (fprintf fmt "%a(static,main_mem);@ " pp_machine_static_alloc_name mname)
79
    else (fprintf fmt "%a *main_mem = %a();@ " pp_machine_memtype_name mname pp_machine_alloc_name mname);
80
    fprintf fmt "@ /* Initialize the main memory */@ ";
81
    fprintf fmt "%a(%s);@ " pp_machine_reset_name mname main_mem;
82
  end
83

  
84
let print_global_initialize fmt basename =
85
  let mNAME = file_to_module_name basename in
86
  fprintf fmt "@ /* Initialize global constants */@ %a();@ "
87
    pp_global_init_name mNAME
88

  
89
let print_global_clear fmt basename =
90
  let mNAME = file_to_module_name basename in
91
  fprintf fmt "@ /* Clear global constants */@ %a();@ "
92
    pp_global_clear_name mNAME
93

  
94
let print_main_initialize mname main_mem fmt m =
95
  if not (fst (get_stateless_status m))
96
  then
97
    fprintf fmt "@ /* Initialize inputs, outputs and memories */@ %a%t%a%t%a(%s);@ "
98
      (Utils.fprintf_list ~sep:"@ " (pp_initialize m main_mem (pp_c_var_read m))) m.mstep.step_inputs
99
      (Utils.pp_newline_if_non_empty m.mstep.step_inputs)
100
      (Utils.fprintf_list ~sep:"@ " (pp_initialize m main_mem (pp_c_var_read m))) m.mstep.step_outputs
101
      (Utils.pp_newline_if_non_empty m.mstep.step_inputs)
102
      pp_machine_init_name mname
103
      main_mem
104
  else
105
    fprintf fmt "@ /* Initialize inputs and outputs */@ %a%t%a@ "
106
      (Utils.fprintf_list ~sep:"@ " (pp_initialize m main_mem (pp_c_var_read m))) m.mstep.step_inputs
107
      (Utils.pp_newline_if_non_empty m.mstep.step_inputs)
108
      (Utils.fprintf_list ~sep:"@ " (pp_initialize m main_mem (pp_c_var_read m))) m.mstep.step_outputs
109

  
110
let print_main_clear mname main_mem fmt m =
111
  if not (fst (get_stateless_status m))
112
  then
113
    fprintf fmt "@ /* Clear inputs, outputs and memories */@ %a%t%a%t%a(%s);@ "
114
      (Utils.fprintf_list ~sep:"@ " (pp_clear m main_mem (pp_c_var_read m))) m.mstep.step_inputs
115
      (Utils.pp_newline_if_non_empty m.mstep.step_inputs)
116
      (Utils.fprintf_list ~sep:"@ " (pp_clear m main_mem (pp_c_var_read m))) m.mstep.step_outputs
117
      (Utils.pp_newline_if_non_empty m.mstep.step_inputs)
118
      pp_machine_clear_name mname
119
      main_mem
120
  else
121
    fprintf fmt "@ /* Clear inputs and outputs */@ %a%t%a@ "
122
      (Utils.fprintf_list ~sep:"@ " (pp_clear m main_mem (pp_c_var_read m))) m.mstep.step_inputs
123
      (Utils.pp_newline_if_non_empty m.mstep.step_inputs)
124
      (Utils.fprintf_list ~sep:"@ " (pp_clear m main_mem (pp_c_var_read m))) m.mstep.step_outputs
125

  
126
let print_main_loop mname main_mem fmt m =
127
  let input_values =
128
    List.map (fun v -> mk_val (LocalVar v) v.var_type)
129
      m.mstep.step_inputs in
130
  begin
131
    fprintf fmt "@ ISATTY = isatty(0);@ ";
132
    fprintf fmt "@ /* Infinite loop */@ ";
133
    fprintf fmt "@[<v 2>while(1){@ ";
134
    fprintf fmt  "fflush(stdout);@ ";
135
    fprintf fmt "%a@ %t%a"
136
      print_get_inputs m
137
      (fun fmt -> pp_main_call mname main_mem fmt m input_values m.mstep.step_outputs)
138
      print_put_outputs m
139
  end
49 140

  
50
let print_main_fun machines m fmt =
141
let print_main_code fmt basename m =
51 142
  let mname = m.mname.node_id in
52 143
  let main_mem =
53 144
    if (!Options.static_mem && !Options.main_node <> "")
54 145
    then "&main_mem"
55 146
    else "main_mem" in
56 147
  fprintf fmt "@[<v 2>int main (int argc, char *argv[]) {@ ";
57
  fprintf fmt "/* Declaration of inputs/outputs variables */@ ";
58
  List.iter 
59
    (fun v -> fprintf fmt "%a = %a;@ " (pp_c_type v.var_id) v.var_type pp_c_initialize v.var_type
60
    ) m.mstep.step_inputs;
61
  List.iter 
62
    (fun v -> fprintf fmt "%a = %a;@ " (pp_c_type v.var_id) v.var_type pp_c_initialize v.var_type
63
    ) m.mstep.step_outputs;
64
  fprintf fmt "@ /* Main memory allocation */@ ";
65
  if (!Options.static_mem && !Options.main_node <> "")
66
  then (fprintf fmt "%a(static,main_mem);@ " pp_machine_static_alloc_name mname)
67
  else (fprintf fmt "%a *main_mem = %a();@ " pp_machine_memtype_name mname pp_machine_alloc_name mname);
68
  fprintf fmt "@ /* Initialize the main memory */@ ";
69
  fprintf fmt "%a(%s);@ " pp_machine_reset_name mname main_mem;
70
  fprintf fmt "@ ISATTY = isatty(0);@ ";
71
  fprintf fmt "@ /* Infinite loop */@ ";
72
  fprintf fmt "@[<v 2>while(1){@ ";
73
  fprintf fmt  "fflush(stdout);@ ";
74
  List.iter 
75
    (fun v -> fprintf fmt "%s = %a;@ "
76
      v.var_id
77
      print_get_input v
78
    ) m.mstep.step_inputs;
79
  (match m.mstep.step_outputs with
80
    (* | [] -> ( *)
81
    (*   fprintf fmt "%a(%a%t%s);@ "  *)
82
    (* 	pp_machine_step_name mname *)
83
    (* 	(Utils.fprintf_list ~sep:", " (fun fmt v -> pp_print_string fmt v.var_id)) m.mstep.step_inputs *)
84
    (* 	(pp_final_char_if_non_empty ", " m.mstep.step_inputs) *)
85
    (* 	main_mem *)
86
    (* ) *)
87
    (* | [o] -> ( *)
88
    (*   fprintf fmt "%s = %a(%a%t%a, %s);%a" *)
89
    (* 	o.var_id *)
90
    (* 	pp_machine_step_name mname *)
91
    (* 	(Utils.fprintf_list ~sep:", " (fun fmt v -> pp_print_string fmt v.var_id)) m.mstep.step_inputs *)
92
    (* 	(pp_final_char_if_non_empty ", " m.mstep.step_inputs) *)
93
    (* 	(Utils.fprintf_list ~sep:", " (fun fmt v -> fprintf fmt "&%s" v.var_id)) m.mstep.step_outputs *)
94
    (* 	main_mem *)
95
    (* 	print_put_outputs [o]) *)
96
    | _ -> (
97
      fprintf fmt "%a(%a%t%a, %s);%a"
98
	pp_machine_step_name mname
99
	(Utils.fprintf_list ~sep:", " (fun fmt v -> pp_print_string fmt v.var_id)) m.mstep.step_inputs
100
	(Utils.pp_final_char_if_non_empty ", " m.mstep.step_inputs)
101
	(Utils.fprintf_list ~sep:", " (fun fmt v -> fprintf fmt "&%s" v.var_id)) m.mstep.step_outputs
102
	main_mem
103
	print_put_outputs m.mstep.step_outputs)
104
  );
105
  fprintf fmt "@]@ }@ ";
106
  fprintf fmt "return 1;";
148
  print_main_inout_declaration fmt m;
149
  print_main_memory_allocation mname main_mem fmt m;
150
  if !Options.mpfr then
151
    begin
152
      print_global_initialize fmt basename;
153
      print_main_initialize mname main_mem fmt m;
154
    end;
155
  print_main_loop mname main_mem fmt m;
156
  if Scopes.Plugin.is_active () then
157
    begin
158
      fprintf fmt "@ %t" Scopes.Plugin.pp 
159
    end;    
160
  fprintf fmt "@]@ }@ @ ";
161
  if !Options.mpfr then
162
    begin
163
      print_main_clear mname main_mem fmt m;
164
      print_global_clear fmt basename;
165
    end;
166
  fprintf fmt "@ return 1;";
107 167
  fprintf fmt "@]@ }@."       
108 168

  
109 169
let print_main_header fmt =
......
118 178

  
119 179
  (* Print the svn version number and the supported C standard (C90 or C99) *)
120 180
  print_version main_fmt;
121
  print_main_fun machines main_machine main_fmt
181
  print_main_code main_fmt basename main_machine
122 182
end  
123 183

  
124 184
(* Local Variables: *)
src/backends/C/c_backend_makefile.ml
18 18
    (fun top -> 
19 19
      match top.top_decl_desc with
20 20
      | Const _ -> true 
21
      | ImportedNode nd -> nd.nodei_in_lib = None
21
      | ImportedNode nd -> nd.nodei_in_lib = []
22 22
      | _ -> false
23 23
    )
24 24
    header
......
26 26
let header_libs header =
27 27
  List.fold_left (fun accu top ->
28 28
    match top.top_decl_desc with
29
      | ImportedNode nd -> (match nd.nodei_in_lib with 
30
	| None -> accu 
31
	| Some lib -> Utils.list_union [lib] accu)
29
      | ImportedNode nd -> Utils.list_union nd.nodei_in_lib accu
32 30
      | _ -> accu 
33 31
  ) [] header 
34 32
    
......
72 70
  fprintf fmt "@.";
73 71

  
74 72
  (* Main binary *)
75
  fprintf fmt "%s_%s:@." basename nodename;
76
  fprintf fmt "\t${GCC} -I${INC} -I. -c %s.c@." basename;  
77
  fprintf fmt "\t${GCC} -I${INC} -I. -c %s_main.c@." basename;   
73
  fprintf fmt "%s_%s: %s.c %s_main.c@." basename nodename basename basename;
74
  fprintf fmt "\t${GCC} -O0 -I${INC} -I. -c %s.c@." basename;  
75
  fprintf fmt "\t${GCC} -O0 -I${INC} -I. -c %s_main.c@." basename;   
78 76
  fprintf_dependencies fmt dependencies;    
79
  fprintf fmt "\t${GCC} -o %s_%s io_frontend.o %a %s.o %s_main.o %a@." basename nodename 
77
  fprintf fmt "\t${GCC} -O0 -o %s_%s io_frontend.o %a %s.o %s_main.o %a@." basename nodename 
80 78
    (Utils.fprintf_list ~sep:" " (fun fmt (Dep (_, s, _, _)) -> Format.fprintf fmt "%s.o" s)) 
81 79
    (compiled_dependencies dependencies)
82 80
    basename (* library .o *)
......
87 85
 fprintf fmt "clean:@.";
88 86
 fprintf fmt "\t\\rm -f *.o %s_%s@." basename nodename;
89 87
 fprintf fmt "@.";
88
 fprintf fmt ".PHONY: %s_%s@." basename nodename;
89
 fprintf fmt "@.";
90 90
 Mod.other_targets fmt basename nodename dependencies;
91 91
 fprintf fmt "@.";
92 92

  
src/backends/C/c_backend_src.ml
30 30
(*                    Instruction Printing functions                                        *)
31 31
(********************************************************************************************)
32 32

  
33

  
34 33
(* Computes the depth to which multi-dimension array assignments should be expanded.
35 34
   It equals the maximum number of nested static array constructions accessible from root [v].
36 35
*)
37
let rec expansion_depth v =
38
 match v with
39
 | Cst (Const_array cl) -> 1 + List.fold_right (fun c -> max (expansion_depth (Cst c))) cl 0
40
 | Cst _
41
 | LocalVar _
42
 | StateVar _  -> 0
43
 | Fun (_, vl) -> List.fold_right (fun v -> max (expansion_depth v)) vl 0
44
 | Array vl    -> 1 + List.fold_right (fun v -> max (expansion_depth v)) vl 0
45
 | Access (v, i) -> max 0 (expansion_depth v - 1)
46
 | Power (v, n)  -> 0 (*1 + expansion_depth v*)
47

  
48
let rec merge_static_loop_profiles lp1 lp2 =
49
  match lp1, lp2 with
50
  | []      , _        -> lp2
51
  | _       , []       -> lp1
52
  | p1 :: q1, p2 :: q2 -> (p1 || p2) :: merge_static_loop_profiles q1 q2
36
  let rec expansion_depth v =
37
    match v.value_desc with
38
    | Cst cst -> expansion_depth_cst cst
39
    | LocalVar _
40
    | StateVar _  -> 0
41
    | Fun (_, vl) -> List.fold_right (fun v -> max (expansion_depth v)) vl 0
42
    | Array vl    -> 1 + List.fold_right (fun v -> max (expansion_depth v)) vl 0
43
    | Access (v, i) -> max 0 (expansion_depth v - 1)
44
    | Power (v, n)  -> 0 (*1 + expansion_depth v*)
45
  and expansion_depth_cst c = 
46
    match c with
47
      Const_array cl -> 1 + List.fold_right (fun c -> max (expansion_depth_cst c)) cl 0
48
    | _ -> 0
49
  
50
  let rec merge_static_loop_profiles lp1 lp2 =
51
    match lp1, lp2 with
52
    | []      , _        -> lp2
53
    | _       , []       -> lp1
54
    | p1 :: q1, p2 :: q2 -> (p1 || p2) :: merge_static_loop_profiles q1 q2
53 55

  
54 56
(* Returns a list of bool values, indicating whether the indices must be static or not *)
55
let rec static_loop_profile v =
56
 match v with
57
 | Cst (Const_array cl) ->
58
   List.fold_right (fun c lp -> merge_static_loop_profiles lp (static_loop_profile (Cst c))) cl []
59
 | Cst _
60
 | LocalVar _
61
 | StateVar _  -> []
62
 | Fun (_, vl) -> List.fold_right (fun v lp -> merge_static_loop_profiles lp (static_loop_profile v)) vl []
63
 | Array vl    -> true :: List.fold_right (fun v lp -> merge_static_loop_profiles lp (static_loop_profile v)) vl []
64
 | Access (v, i) -> (match (static_loop_profile v) with [] -> [] | _ :: q -> q)
65
 | Power (v, n)  -> false :: static_loop_profile v
66

  
57
  let rec static_loop_profile v =
58
    match v.value_desc with
59
    | Cst cst  -> static_loop_profile_cst cst
60
    | LocalVar _
61
    | StateVar _  -> []
62
    | Fun (_, vl) -> List.fold_right (fun v lp -> merge_static_loop_profiles lp (static_loop_profile v)) vl []
63
    | Array vl    -> true :: List.fold_right (fun v lp -> merge_static_loop_profiles lp (static_loop_profile v)) vl []
64
    | Access (v, i) -> (match (static_loop_profile v) with [] -> [] | _ :: q -> q)
65
    | Power (v, n)  -> false :: static_loop_profile v
66
  and static_loop_profile_cst cst =
67
    match cst with
68
      Const_array cl -> List.fold_right 
69
	(fun c lp -> merge_static_loop_profiles lp (static_loop_profile_cst c))
70
	cl 
71
	[]
72
    | _ -> [] 
73
  
74
  
67 75
let rec is_const_index v =
68
  match v with
76
  match v.value_desc with
69 77
  | Cst (Const_int _) -> true
70 78
  | Fun (_, vl)       -> List.for_all is_const_index vl
71 79
  | _                 -> false
......
108 116
 match snd lv with
109 117
 | LVar v -> fprintf fmt "[%s]" v
110 118
 | LInt r -> fprintf fmt "[%d]" !r
111
 | LAcc i -> fprintf fmt "[%a]" pp_c_dimension (dimension_of_value i)
119
 | LAcc i -> fprintf fmt "[%a]" pp_val i
112 120

  
113 121
(* Prints a suffix of loop variables for arrays *)
114 122
let pp_suffix fmt loop_vars =
......
121 129
(* Prints a constant value before a suffix (needs casting) *)
122 130
let rec pp_c_const_suffix var_type fmt c =
123 131
  match c with
124
    | Const_int i     -> pp_print_int fmt i
125
    | Const_real r    -> pp_print_string fmt r
126
    | Const_float r   -> pp_print_float fmt r
127
    | Const_tag t     -> pp_c_tag fmt t
128
    | Const_array ca  -> let var_type = Types.array_element_type var_type in
129
                         fprintf fmt "(%a[]){%a }" (pp_c_type "") var_type (Utils.fprintf_list ~sep:", " (pp_c_const_suffix var_type)) ca
130
    | Const_struct fl -> fprintf fmt "{%a }" (Utils.fprintf_list ~sep:", " (fun fmt (f, c) -> (pp_c_const_suffix (Types.struct_field_type var_type f)) fmt c)) fl
131
    | Const_string _ -> assert false (* string occurs in annotations not in C *)
132
    | Const_int i          -> pp_print_int fmt i
133
    | Const_real (_, _, s) -> pp_print_string fmt s
134
    | Const_tag t          -> pp_c_tag fmt t
135
    | Const_array ca       -> let var_type = Types.array_element_type var_type in
136
                              fprintf fmt "(%a[]){%a }" (pp_c_type "") var_type (Utils.fprintf_list ~sep:", " (pp_c_const_suffix var_type)) ca
137
    | Const_struct fl       -> fprintf fmt "{%a }" (Utils.fprintf_list ~sep:", " (fun fmt (f, c) -> (pp_c_const_suffix (Types.struct_field_type var_type f)) fmt c)) fl
138
    | Const_string _        -> assert false (* string occurs in annotations not in C *)
132 139

  
133 140

  
134 141
(* Prints a [value] of type [var_type] indexed by the suffix list [loop_vars] *)
135 142
let rec pp_value_suffix self var_type loop_vars pp_value fmt value =
136
(*Format.eprintf "pp_value_suffix: %a %a %a@." Types.print_ty var_type Machine_code.pp_val value pp_suffix loop_vars;*)
137
 match loop_vars, value with
143
 (*Format.eprintf "pp_value_suffix: %a %a %a@." Types.print_ty var_type Machine_code.pp_val value pp_suffix loop_vars;*)
144
 match loop_vars, value.value_desc with
138 145
 | (x, LAcc i) :: q, _ when is_const_index i ->
139 146
   let r = ref (Dimension.size_const_dimension (Machine_code.dimension_of_value i)) in
140 147
   pp_value_suffix self var_type ((x, LInt r)::q) pp_value fmt value
141 148
 | (_, LInt r) :: q, Cst (Const_array cl) ->
142 149
   let var_type = Types.array_element_type var_type in
143
   pp_value_suffix self var_type q pp_value fmt (Cst (List.nth cl !r))
150
   pp_value_suffix self var_type q pp_value fmt (mk_val (Cst (List.nth cl !r)) Type_predef.type_int)
144 151
 | (_, LInt r) :: q, Array vl      ->
145 152
   let var_type = Types.array_element_type var_type in
146 153
   pp_value_suffix self var_type q pp_value fmt (List.nth vl !r)
......
171 178
   which may yield constant arrays in expressions.
172 179
   Type is needed to correctly print constant arrays.
173 180
 *)
174
let pp_c_val self pp_var fmt (t, v) =
175
  pp_value_suffix self t [] pp_var fmt v
181
let pp_c_val self pp_var fmt v =
182
  pp_value_suffix self v.value_type [] pp_var fmt v
183

  
184
let pp_basic_assign pp_var fmt typ var_name value =
185
  if Types.is_real_type typ && !Options.mpfr
186
  then
187
    Mpfr.pp_inject_assign pp_var fmt var_name value
188
  else
189
    fprintf fmt "%a = %a;" 
190
      pp_var var_name
191
      pp_var value
176 192

  
177 193
(* type_directed assignment: array vs. statically sized type
178 194
   - [var_type]: type of variable to be assigned
......
180 196
   - [value]: assigned value
181 197
   - [pp_var]: printer for variables
182 198
*)
183
(*
184
let pp_assign_rec pp_var var_type var_name value =
185
  match (Types.repr var_type).Types.tdesc, value with
186
  | Types.Tarray (d, ty'), Array vl     ->
187
    let szl = Utils.enumerate (Dimension.size_const_dimension d) in
188
    fprintf fmt "@[<v 2>{@,%a@]@,}"
189
      (Utils.fprintf_list ~sep:"@," (fun fmt i -> r := i; aux fmt q)) szl
190
  | Types.Tarray (d, ty'), Power (v, _) -> 
191
  | Types.Tarray (d, ty'), _            ->
192
  | _                    , _            ->
193
    fprintf fmt "%a = %a;" 
194
      pp_var var_name
195
      (pp_value_suffix self loop_vars pp_var) value
196
*)
197 199
let pp_assign m self pp_var fmt var_type var_name value =
198 200
  let depth = expansion_depth value in
199
(*Format.eprintf "pp_assign %a %a %a %d@." Types.print_ty var_type pp_val var_name pp_val value depth;*)
201
  (*Format.eprintf "pp_assign %a %a %a %d@." Types.print_ty var_type pp_val var_name pp_val value depth;*)
200 202
  let loop_vars = mk_loop_variables m var_type depth in
201 203
  let reordered_loop_vars = reorder_loop_variables loop_vars in
202
  let rec aux fmt vars =
204
  let rec aux typ fmt vars =
203 205
    match vars with
204 206
    | [] ->
205
      fprintf fmt "%a = %a;" 
206
	(pp_value_suffix self var_type loop_vars pp_var) var_name
207
	(pp_value_suffix self var_type loop_vars pp_var) value
207
       pp_basic_assign (pp_value_suffix self var_type loop_vars pp_var) fmt typ var_name value
208 208
    | (d, LVar i) :: q ->
209
(*eprintf "pp_aux %a %s@." Dimension.pp_dimension d i;*)
209
       let typ' = Types.array_element_type typ in
210
      (*eprintf "pp_aux %a %s@." Dimension.pp_dimension d i;*)
210 211
      fprintf fmt "@[<v 2>{@,int %s;@,for(%s=0;%s<%a;%s++)@,%a @]@,}"
211
	i i i Dimension.pp_dimension d i
212
	aux q
212
	i i i pp_c_dimension d i
213
	(aux typ') q
213 214
    | (d, LInt r) :: q ->
214
(*eprintf "pp_aux %a %d@." Dimension.pp_dimension d (!r);*)
215
      let szl = Utils.enumerate (Dimension.size_const_dimension d) in
216
      fprintf fmt "@[<v 2>{@,%a@]@,}"
217
	(Utils.fprintf_list ~sep:"@," (fun fmt i -> r := i; aux fmt q)) szl
215
       (*eprintf "pp_aux %a %d@." Dimension.pp_dimension d (!r);*)
216
       let typ' = Types.array_element_type typ in
217
       let szl = Utils.enumerate (Dimension.size_const_dimension d) in
218
       fprintf fmt "@[<v 2>{@,%a@]@,}"
219
	       (Utils.fprintf_list ~sep:"@," (fun fmt i -> r := i; aux typ' fmt q)) szl
218 220
    | _ -> assert false
219 221
  in
220 222
  begin
221 223
    reset_loop_counter ();
222 224
    (*reset_addr_counter ();*)
223
    aux fmt reordered_loop_vars
225
    aux var_type fmt reordered_loop_vars;
226
    (*Format.eprintf "end pp_assign@.";*)
224 227
  end
225 228

  
229
let pp_machine_reset (m: machine_t) self fmt inst =
230
  let (node, static) =
231
    try
232
      List.assoc inst m.minstances
233
    with Not_found -> (Format.eprintf "internal error: pp_machine_reset %s %s %s:@." m.mname.node_id self inst; raise Not_found) in
234
  fprintf fmt "%a(%a%t%s->%s);"
235
    pp_machine_reset_name (node_name node)
... This diff was truncated because it exceeds the maximum size that can be displayed.

Also available in: Unified diff