luc2c.ml 24.2 KB
Newer Older
1
2
3
4
5
6
(*-----------------------------------------------------------------------
** Copyright (C) - Verimag.
** This file may only be copied under the terms of the GNU Library General
** Public License
**-----------------------------------------------------------------------
**
7
** File: luc2c.ml
8
9
10
11
** Author: jahier@imag.fr
**
** Generates C files to call Lucky from C.
**
12

13
14
*)

15
open LucProg
16

17

Erwan Jahier's avatar
Erwan Jahier committed
18
type gen_mode = Lustre | Scade | Alice | Luciole | Nop
19
20
21
22
23
24
25
type step_mode = Inside | Edges | Vertices

let step_mode_to_str = function 
    Inside  -> "step_inside"
  | Edges  -> "step_edges"
  | Vertices -> "step_vertices"

26
type optionT = {
27
28
  mutable pp : string option;
  mutable output : string option;
29
  mutable calling_module_name : string;
30
  mutable gen_mode : gen_mode;
31
  mutable use_sockets : bool;
32
33
  mutable step_mode : step_mode;
  mutable seed : int option;
34
35
  mutable env : string list;
  mutable sock_addr : string
36
37
38
}


39
let (option : optionT) = {
40
41
  pp = None;
  output = None;
Erwan Jahier's avatar
Erwan Jahier committed
42
  gen_mode = Nop;
43
  use_sockets = false;
44
45
46
  calling_module_name = "XXX_SCADE_MODULE_NAME";
  step_mode = Inside;
  seed = None;
47
48
  env = [];
  sock_addr = "127.0.0.1"
49
50
51
52
53
}


(****************************************************************************)

54
55
let (gen_lustre_ext_h : string -> unit) =
  fun fn  -> 
56
    let oc = open_out (option.calling_module_name ^ "_ext.h") in
57
    let putln s = output_string oc (s^"\n") in
58
      putln (Util.entete "// ");
59
      putln ("#include \"" ^ option.calling_module_name ^ "_ext_func.h\"");
60
61
      flush oc;
      close_out oc
62
             
63
64
let (gen_lustre_ext_func_h : string -> Exp.var list -> Exp.var list -> unit) =
  fun fn in_vars out_vars -> 
65
    let oc = open_out (option.calling_module_name ^ "_ext_func.h") in
66
67
68
    let put s = output_string oc s in
    let putln s = output_string oc (s^"\n") in
    let rec putlist = function
69
70
        [] -> ()
      | [x] -> put x
71
72
      | x::l' -> put x; put ", "; putlist l'
    in 
73
      putln (Util.entete "// ");
74
      putln  ("#include \"" ^ option.calling_module_name ^ ".h\"");
75
      putln  ("#include \"" ^ fn ^ ".h\"");
76
      putln "#define bool int";
77
78
79
80
81
82
83
      putln "";

      putln ("// A C function that implements "^fn^" which profile is the one ");
      putln "// expected when calling an external C function from Lustre.";
      put ("extern void " ^ fn ^ "(");
      putln "";
      let l1 = List.fold_left
84
85
86
        (fun acc var -> acc @ [(Type.to_cstring (Var.typ var)) ^ "*"])
        []
        out_vars
87
88
      in 
      let l2 = List.fold_left
89
90
91
        (fun acc var -> acc @ [Type.to_cstring (Var.typ var)])
        l1
        in_vars
92
      in
93
94
        putlist l2;
        putln ");";
95

96
97
98
        flush oc;
        close_out oc
             
99
100
let (gen_lustre_ext_func_c : string -> Exp.var list -> Exp.var list -> unit) =
  fun fn in_vars out_vars -> 
101
    let oc = open_out (option.calling_module_name ^ "_ext_func.c") in
102
103
104
    let put s = output_string oc s in
    let putln s = output_string oc (s^"\n") in
    let rec putlist = function
105
106
        [] -> ()
      |        [x] -> put x
107
108
      | x::l' -> put x; put ", "; putlist l'
    in 
109
      putln (Util.entete "// ");
110
      putln  ("#include \"" ^ option.calling_module_name ^ "_ext_func.h\"");
111
112
113
114
      putln "";

      putln "// Output procedures";
      List.iter
115
116
117
118
119
120
121
        (fun var -> 
           put ("void " ^ fn ^ "_O_" ^ (Var.name var) ^ "(" ^
                  fn  ^"_ctx* lucky_ctx, ");
           put ((Type.to_cstring (Var.typ var)) ^ " v) { lucky_ctx->_");
           putln ((Var.name var) ^ " = v; };");
        )
        out_vars;
122
123
124
125
126
127
128
129
130
131
      
      putln "";
      putln "#define false 0";
      putln "#define true 1";

      putln (fn ^ "_ctx* lucky_ctx;");
      putln "int not_init = true;";
      putln "";
      put ("void " ^ fn ^ "(");
      let l1 = List.fold_left
132
133
134
135
        (fun acc var -> 
           acc @ [(Type.to_cstring (Var.typ var)) ^ "* " ^ (Var.name var)])
        []
        out_vars
136
137
      in 
      let l2 = List.fold_left
138
139
140
        (fun acc var -> acc @ [Type.to_cstring (Var.typ var)^" "^(Var.name var)])
        l1
        in_vars
141
      in
142
143
144
145
146
        putlist l2;
        putln "){";
        
        putln "";
        putln ("  if (not_init) {
147
148
    lucky_ctx = "^fn^"_new_ctx(NULL);
    not_init = false;");
149
        (match option.seed with
150
151
152
153
154
155
156
157
158
159
            None -> ()
          | Some i -> putln ("    lucky_set_seed(" ^ (string_of_int i) ^ ");");
        );
        putln "  };";
        List.iter
          (fun var -> 
             put ("  "^fn ^ "_I_" ^ (Var.name var) ^ "(lucky_ctx, ");
             putln ((Var.name var) ^ ");")
          )
          in_vars;
160
      
161
        putln ("  "^fn^ "_step(lucky_ctx, "^ (step_mode_to_str option.step_mode)^ ");");
162
163
164
165
166
167
168
169
170
171
172
        List.iter
          (fun var -> 
             putln ("  *" ^ (Var.name var) ^ "=lucky_ctx->_" ^(Var.name var) ^ ";");
          )
          out_vars;
        putln "}";
        putln "";
        
        
        flush oc;
        close_out oc
173
174
175



176
177
178

(****************************************************************************)
let (gen_h_file : string -> Exp.var list -> Exp.var list -> Exp.var list -> unit) =
179
  fun fn in_vars out_vars loc_vars ->
180
181
182
    let oc = open_out (fn ^ ".h") in
    let put s = output_string oc s in
    let putln s = output_string oc (s^"\n") in
183
    let max_buff_size =
184
185
186
187
188
189
      (* 10 digits per I/O is enough? *)
      let in_nb = List.length in_vars in
      let out_nb = List.length out_vars in
      let io_size = 10 in
        2 lsl (int_of_float (log (float_of_int (20+io_size*(in_nb+out_nb))) /. (log 2.))) 
    in
190
191
192
193
194
195
196
197
    let put_var_decl_in_struct var =
      put "  ";
      put (Type.to_cstring (Var.typ var));
      put " _";
      put (Var.name var);
      putln ";";
    in
      
198
      putln (Util.entete "// ");
199
      
200
201
      putln  ("#ifndef _" ^ fn ^ "_H_INCLUDED \n");
      putln  ("#define _" ^ fn ^ "_H_INCLUDED \n");
202
203
204
205
      if not option.use_sockets then
        putln  "#include <luc4c_stubs.h> \n";
      putln "#include <stdio.h>";

206
      putln "//-------- Predefined types ---------";
207
208
209
210
211
212
213
214
215
216
217
218
219
220
      putln "#ifndef _EC2C_PREDEF_TYPES
#define _EC2C_PREDEF_TYPES
typedef int _bool;
typedef int _boolean;
typedef int _int;
typedef int _integer;
typedef char* _string;
typedef double _real;
typedef double _double;
typedef float _float;
#define _false 0
#define _true 1
#endif
";
221
      if option.use_sockets then (
222
        putln ("#define MAX_BUFF_SIZE "^(string_of_int max_buff_size)^"");
223
224
        putln ("#define MAX_BUFF_SIZE_4 "^(string_of_int (4*max_buff_size))^"");
      );
225
226
      putln "//--------- Pragmas ----------------";
      putln ("//MODULE: " ^ fn ^ " " ^ (string_of_int (List.length in_vars)) 
227
             ^ " " ^  (string_of_int (List.length out_vars)));
228
      List.iter
229
230
231
232
        (fun var -> 
           putln ("//IN: " ^ (Type.to_cstring (Var.typ var)) ^ " " ^(Var.name var))
        )
        in_vars;
233
      List.iter
234
235
236
237
        (fun var -> 
           putln ("//OUT: " ^ (Type.to_cstring (Var.typ var)) ^ " " ^(Var.name var))
        )
        out_vars;
238
239
240


      putln ("\n//--------Context type ------------");
241
242
243
244
245
246
      putln "/*--------";
      putln "Internal structure for the call";
      putln "--------*/";


      putln "";
247
      if option.gen_mode = Scade then 
248
249
250
251
252
253
254
255
256
257
        (

          putln ("/* \n// Put the following in the scade generated file " ^ fn ^
                   "_fctext.h\n// (#included hereafter), " ^
                   "before the definition of the structure \n// _C_"  
                 ^ fn ^ ".");
          putln ("// Also, add the following field to the structure _C_"  ^ 
                   fn ^ ":");
          putln ("// ==>   " ^ fn ^ "_ctx * scade_ctx;\n");
        );
258
259
260
261
262
263
264
265
266
267
      putln ("struct C_" ^ fn ^ ";");
      putln ("struct _" ^ fn ^ "_ctx");
      putln " {";
      putln "  void* client_data;";
      putln "  //INPUTS";
      List.iter put_var_decl_in_struct in_vars;
      putln "  //OUTPUTS";
      List.iter put_var_decl_in_struct out_vars;

      putln "  ";
268
269
270
271
272
273
274
275
276
277
      put "  // lucky process number";
      put "  
#ifndef _WIN32
   int lp;
#endif
";
      if option.use_sockets then (
        putln "  char buff [MAX_BUFF_SIZE];";
        putln "  int sock;";
      );
278
      if option.gen_mode = Scade then (
279
        putln "  // Scade node context";
280
        putln ("   struct C_" ^ option.calling_module_name ^ " * client_data;");
281
282
283
284
        putln "};\n";
        putln ("typedef struct _" ^ fn ^ "_ctx " ^ fn ^ "_ctx;\n");
        putln "*/\n";
        putln ("#include \""^ fn ^"_fctext.h\"\n\n");
285
286
      )
      else
287
288
289
290
        (
          putln "};\n";
          putln ("typedef struct _" ^ fn ^ "_ctx " ^ fn ^ "_ctx;\n");
        );
291

292
      putln "FILE* fp;";
293
294
      putln "// To be defined by users";
      List.iter
295
296
297
298
299
300
        (fun var -> 
           put ("extern void " ^ fn ^ "_O_" ^ (Var.name var) ^ "(" ^
                  fn  ^"_ctx* ctx, ");
           put ((Type.to_cstring (Var.typ var)) ^ " f);\n");
        )
        out_vars;
301

302
303
      putln "\n//--------Context allocation --------";
      putln ("extern "^fn^"_ctx* "^fn^"_new_ctx(void* client_data);");
304
305
306


      putln ("\n//-------Context copy --------------");
307
      putln ("extern void "^fn^"_copy_ctx("^fn^"_ctx* dest, "^ fn ^
308
               "_ctx* src);");
309

310
311
312
313
      if option.use_sockets then (
        putln "\n//--------Terminate procedure -----------";
        putln ("extern void "^fn^"_terminate("^fn^"_ctx* ctx);");
      );
314
315
      putln "\n//--------Reset procedure -----------";
      putln ("extern void "^fn^"_reset("^fn^"_ctx* ctx);");
316
317
318
319


      putln ("\n//-------Step procedure -----------");

320
321
322
323
      if option.use_sockets then
        putln ("extern void "^fn^"_step("^fn^"_ctx* ctx);")
      else
        putln ("extern void "^fn^"_step("^fn^"_ctx* ctx, step_mode sm);");
324
325
326

      putln ("\n//-------Input procedures ---------");
      List.iter
327
328
329
330
331
332
        (fun var -> 
           put ("extern void " ^ fn ^ "_I_" ^ (Var.name var) ^ 
                  "("^fn^"_ctx*, ");
           put ((Type.to_cstring (Var.typ var)) ^ ");\n");
        )
        in_vars;
333

334
      putln  "#endif \n";
335
336
337
      
      flush oc;
      close_out oc
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369

let var_to_format_print var =
  match Var.typ var with
    | Type.BoolT -> "%d"
    | Type.IntT -> "%d"
    | Type.FloatT -> "%lf"
    | Type.UT _ -> assert false

let var_to_format_scan var =
  match Var.typ var with
    | Type.BoolT -> "%c"
    | Type.IntT -> "%d"
    | Type.FloatT -> "%lf"
    | Type.UT _ -> assert false

let var_to_cast var =
  match Var.typ var with
    | Type.BoolT -> ""
    | Type.IntT -> ""
    | Type.FloatT -> "(float)"
    | Type.UT _ -> assert false


let put_socket_func put fn in_vars out_vars loc_vars =
  let putln str = put (str^"\n") in
    put ("
#include <stdio.h>
#include <sys/types.h>
#include <signal.h>
#ifdef _WINSOCK
  #include <windows.h>
  #include <process.h>
370
  #pragma comment(lib, \"Ws2_32.lib\")
371
372
373
374
375
376
377
#else
  #include <sys/socket.h>
  #include <netinet/in.h>
  #include <netdb.h>
#endif

#ifdef _DEBUG
378
#define dbg_printf(...) fprintf(fp, __VA_ARGS__); fflush(fp)
379
#else
380
#define dbg_printf(...)  while(0)
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
#endif

/*--------
Output procedures must be defined,
Input procedures must be used:
--------*/
");       
    List.iter
      (fun var -> 
         put ("void " ^ fn ^ "_I_" ^ (Var.name var) ^ 
                "(" ^ fn ^ "_ctx* ctx, ");
         put ((Type.to_cstring (Var.typ var)) ^ " _" ^ (Var.name var)^ "){\n");
         putln ("  ctx->_" ^ (Var.name var) ^ " = _" ^ (Var.name var)^ ";");
         putln "}\n";
      )
      in_vars;
    
398
    putln ("
399
400
/*--------
launch the lutin interpreter and init socket stuff
401
402
403
404
405
406
407
408
409
410
411
412
413
--------*/
" ^ fn ^ "_ctx* " ^ fn ^ "_new_ctx(void* cdata){
  " ^ fn ^ "_ctx* ctx;     
  int sockfd;
  int newsockfd;
  int portno;
  int clilen;
  int rc;
#ifndef _WIN32
  int lutin_pid;
#endif
  struct sockaddr_in serv_addr;
  struct sockaddr_in cli_addr;
414
  char portno_str[10];
415
  char buff[MAX_BUFF_SIZE_4];
416
417
418
419
420
421
422
423
424
425
426
427
428
429
  char *sock_addr = \""^option.sock_addr^"\";
  const char *args[] = { 
#ifdef _WIN32
    \"call-via-socket.exe\", sock_addr, portno_str, \"lutin.exe\",
#else
    \"call-via-socket\", sock_addr, portno_str, \"lutin\",
#endif 
   " ^
             (match option.seed with None -> "" | Some i -> ("\"-seed\", \""^(string_of_int i)^"\", "))
           ^" \""^
(List.hd option.env) (* only work with lutin XXX fixme! *)

           ^"\", \"-rif\",\""^fn^".rif\", NULL};

430
431
432
433
434
435
436
  
  // Socket administration stuff   
#ifdef _WINSOCK
  WSADATA WSAData;
  WSAStartup(MAKEWORD(2,0), &WSAData);
#endif

437
438
439
  ctx = malloc(sizeof("^ fn ^ "_ctx));
  ctx->client_data = cdata;

440
441
442
  sockfd = socket(AF_INET, SOCK_STREAM, 0);
  if (sockfd < 0) printf(\"Error: opening socket\");
  serv_addr.sin_family = AF_INET;
443
  serv_addr.sin_addr.s_addr = inet_addr(sock_addr);
444
445
446
447
448

  portno = 2000;
  serv_addr.sin_port = htons(portno);
  while (bind(sockfd, (struct sockaddr *) &serv_addr, sizeof(serv_addr)) ) {
    portno++;
449
    dbg_printf(\"Binding  %s:%d...\\n\",sock_addr,portno);
450
    serv_addr.sin_port = htons(portno);
451
    if (portno > 4000) { printf(\"Error: cannot bind socket\\n\"); exit(2); }
452
453
454
  };
  
  sprintf(portno_str, \"%d\", portno);
455
456
#ifndef _LAUNCH_LUTIN_AUTOMATICALLY
  printf(\" >>> Waiting for lutin to connect on %s:%s\\n\", sock_addr, portno_str);
457
#else
458
  dbg_printf(\"Forking...%d\\n\",portno);
459
460
461
462
463
464
465
466
467
468
#ifdef _WIN32
  _spawnvp(_P_DETACH,  args[0], args);
#else
  lutin_pid = fork();
  if(lutin_pid == 0) {
    execvp(args[0], args);
    printf(\"Unknown command\\n\");
    return 0;
  }
#endif
469
#endif 
470
471
472
473
474
475
476
477

  dbg_printf(\"Listening...\\n\");
  listen(sockfd,5);
  clilen = sizeof(cli_addr);
  dbg_printf(\"Accepting...\\n\");
  newsockfd = accept(sockfd, (struct sockaddr *) &cli_addr, &clilen);
  if (newsockfd < 0) printf(\"Error:  on accept\");
  ctx->sock = newsockfd;
478
479
  rc = recv(ctx->sock, buff, MAX_BUFF_SIZE_4, 0);
  if (rc<0)  { printf(\"Error: cannot read on socket\\n\"); exit(2); }
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
  dbg_printf(\"Skipping '%s'\\n\", ctx->buff);

  memset(ctx->buff, 0, MAX_BUFF_SIZE);
#ifndef _WIN32
  ctx->lp = lutin_pid;
#endif

  return ctx;
}

/*--------
Step procedure
--------*/

void " ^ fn ^ "_step(" ^ fn ^ "_ctx* ctx){
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
  int rc;
  int i;
" ^
let cpt = ref 0 in
let decl_char acc var =
  if (Var.typ var= Type.BoolT) then (
    incr cpt; 
    ("  char c"^(string_of_int !cpt)^";\n")::acc)
  else
    acc
in
let char_decl =
  (String.concat "" (List.rev (List.fold_left decl_char [] out_vars)))
in
  (if !cpt = 0 then "" else char_decl) ^ "
  sprintf(ctx->buff, \""^(
    List.fold_left
      (fun acc var -> acc ^ (var_to_format_print var) ^ " ")
513
      ""
514
515
516
517
518
519
520
521
522
523
524
525
526
527
      in_vars) ^"\\n\", "
  ^
    let var_to_adress var ="ctx->_" ^ (Var.name var) in
      (List.fold_left
         (fun acc var -> acc ^ ", "^ (var_to_adress var))
         (var_to_adress (List.hd in_vars))
         ((List.tl in_vars)))
      ^
        ");
  dbg_printf(\"\\n\\n ---- A new Step begins. Sending to sock: '%s'\\n\",ctx->buff);
  send(ctx->sock, ctx->buff, (int) strlen(ctx->buff),0);
  dbg_printf(\"reading inputs\\n\");

  rc = 0;
528
529
530
  rc = recv(ctx->sock, ctx->buff, MAX_BUFF_SIZE, 0);
  if (rc<0)  { printf(\"Error: cannot read on socket\\n\"); exit(2); }
  dbg_printf(\"reading '%s'\\n\",ctx->buff);
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
  sscanf(ctx->buff, \"#step %d #outs " ^ 
        let cpt = ref 0 in
        let var_to_adress var =
          if (Var.typ var= Type.BoolT) then (
            incr cpt; "&c"^(string_of_int !cpt))
          else
            "&(ctx->_"^ (Var.name var)^")"
        in
          (List.fold_left
             (fun acc var -> acc ^ " " ^ (var_to_format_scan var))
             ""
             out_vars)^"\", &i," 
          ^
            (List.fold_left
               (fun acc var -> acc^", "^(var_to_adress var))
               (var_to_adress (List.hd out_vars))
               (List.tl out_vars)) ^ ");
548
" ^
549
550
551
552
553
554
555
556
            let cpt = ref 0 in
            let copy_char_to_ctx acc var =
              if (Var.typ var= Type.BoolT) then (
                incr cpt; 
                let c = ("c"^(string_of_int !cpt)) in
                let conv_char = 
                  "   if (("^c^" == '0') || ("^c^" == 'f') || ("^c^" == 'F')) ctx->_"
                  ^(Var.name var)^" = _false;
557
   if (("^c^" == '1') || ("^c^" == 't') || ("^c^" == 'T')) ctx->_"
558
                  ^(Var.name var)^" = _true;
559
"
560
561
562
563
564
565
566
567
                in
                  conv_char::acc)
              else
                acc
            in
              (String.concat ""
                 (List.rev (List.fold_left copy_char_to_ctx [] out_vars)))
              ^ "
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
   memset(ctx->buff, 0, rc);       
   dbg_printf(\"----- step done\\n\");
}

/*--------
Terminate procedure
--------*/

void " ^ fn ^ "_terminate(" ^ fn ^ "_ctx* ctx){
  send(ctx->sock, \"q\\n\", 2, 0);
#ifdef _WINSOCK
  WSACleanup();
#else
  close(ctx->sock);
  kill(ctx->lp, SIGKILL); // parano
#endif
}

/*--------
Reset procedure
--------*/

void " ^ fn ^ "_reset(" ^ fn ^ "_ctx* ctx){
591
592
  " ^ fn ^ "_terminate(ctx);
  ctx = " ^ fn ^ "_new_ctx(ctx->client_data);
593
}")
594
595
596
597
598



let (gen_c_file : string -> Exp.var list -> Exp.var list -> Exp.var list -> unit) =
  fun fn in_vars out_vars loc_vars -> 
599
    let oc = 
600
      if option.gen_mode = Scade then
601
        open_out (fn ^ "_fctext.c")         
602
      else
603
        open_out (fn ^ ".c") 
604
    in
605
606
    let put s = output_string oc s in
    let putln s = output_string oc (s^"\n") in
607
      (*     let in_out_vars = in_vars @ out_vars in *)
608

609
      putln (Util.entete "// ");
610
      put (( if option.gen_mode = Scade then
611
612
613
614
615
616
617
                 "#include \"" ^ option.calling_module_name ^ ".h\" \n" 
               else
                 "#include \"" ^ fn ^ ".h\" \n" 
             ) ^
             "");

      if option.use_sockets then (
618
619
620
621
622
        put "
#include <stdlib.h>
#include <string.h>
";
        put_socket_func put fn in_vars out_vars loc_vars;
623
624
625
626
627
628
      )
      else (
        if option.gen_mode = Scade then 
          begin
            (*           putln ("static " ^ fn ^ "_ctx* ctx;\n");       *)
            putln "
629
630
631
/*------
Output procedures
--------*/
632
";        
633
634
635
636
637
638
639
640
641
642
643
644
            List.iter
              (fun var -> 
                 put ("void " ^ fn ^ "_O_" ^ (Var.name var));
                 put ("("^ fn ^ "_ctx* ctx, " ^ (Type.to_cstring (Var.typ var)));
                 putln (" "^(Var.name var) ^ ") {");
                 put ("  ctx->client_data->_<SCADE_VAR_NAME_OF_" ^ (Var.name var));
                 putln ("> = " ^ (Var.name var) ^ ";");
                 putln "  return;";
                 putln "}\n";
              )
              out_vars;
            putln "/*------
645
646
Input procedures
--------*/
647
";        
648
649
650
          end
        else 
          begin
651
652
            putln "
/*--------
653
654
Output procedures must be defined,
Input procedures must be used:
655
--------*/
656

657
";
658
659
660
661
662
663
664
665
666
667
668
669
670
          end;
        
        List.iter
          (fun var -> 
             put ("void " ^ fn ^ "_I_" ^ (Var.name var) ^ 
                    "(" ^ fn ^ "_ctx* ctx, ");
             put ((Type.to_cstring (Var.typ var)) ^ " _" ^ (Var.name var)^ "){\n");
             putln ("  ctx->_" ^ (Var.name var) ^ " = _" ^ (Var.name var)^ ";");
             putln "}\n";
          )
          in_vars;
        
        putln ("/*--------
671
672
673
Copy the value of an internal structure
--------*/
void "^ fn ^"_copy_ctx("^ fn ^"_ctx* dest, "^ fn ^"_ctx* src){
674
  memcpy((void*)dest, (void*)src, sizeof("^ fn ^"_ctx));
675
676
}");

677
678
679
680
681
682
683
684
685
686
687
      putln "
/*--------
Dynamic allocation of an internal structure
--------*/";
      putln (fn ^ "_ctx* " ^ fn ^ "_new_ctx(void* cdata){");
      putln ("  " ^ fn ^ "_ctx* ctx;");
      putln "";
      putln "  lucky_caml_init();";
      putln ("  ctx = malloc(sizeof("^ fn ^ "_ctx));");
      putln "  ctx->client_data = cdata;";
      put  ("  ctx->lp = make(" );
688
      put (match option.pp with | None -> "\"\"" | Some pp -> ("\""^pp^"\""));
689
      put (", \"");
690
691
692
      assert (option.env <> []);
      put (List.hd option.env);
      List.iter (fun x -> put (" " ^ x)) (List.tl option.env);
693
      putln "\");";
694
      
695
696
697
698
      putln "  return ctx;";
      putln "}";

      putln "
699
700
701
/*--------
Step procedure
--------*/";
702
703

      put ("void " ^ fn ^ "_step(" ^ fn ^ "_ctx* ctx, step_mode sm){\n");
704
      
705
      List.iter
Erwan Jahier's avatar
Erwan Jahier committed
706
        (fun var ->
707
708
709
710
711
712
           putln ("  lucky_set_input_" ^
                    (Type.to_string (Var.typ var)) ^ "(ctx->lp, \"" ^
                    (Var.name var) ^ "\", ctx->_" ^
                    (Var.name var) ^");");
        )
        in_vars;
713
      
714
715
716
      putln "  lucky_step(ctx->lp, sm);";

      List.iter
717
718
719
720
721
722
723
        (fun var -> 
           putln ("  " ^ fn ^ "_O_" ^ (Var.name var) ^ 
                    "(ctx, lucky_get_output_" ^
                    (Type.to_string (Var.typ var)) ^ "(ctx->lp, \"" ^
                    (Var.name var) ^ "\"));");
        )
        out_vars;
724
725
      putln "}";

726
727
728
729
      putln "
/*--------
Reset procedure
--------*/";
730
      put ("void " ^ fn ^ "_reset(" ^ fn ^ "_ctx* ctx){\n");
731
      put  ("  ctx->lp = make(" );
732
      put (match option.pp with | None -> "\"\"" | Some pp -> ("\""^pp^"\""));
733
      put (", \"");
734
735
736
      assert (option.env <> []);
      put (List.hd option.env);
      List.iter (fun x -> put (" " ^ x)) (List.tl option.env);
737
      putln "\");";
738
      
739
      putln "}";
740

741
      if option.gen_mode = Scade then (
742
        putln "
743
744
745
746
747

/*------
This is the main function to be called by Scade
--------*/";

748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
        putln ("void " ^ option.calling_module_name ^ "_init(_C_" ^ 
                 option.calling_module_name ^ " * _C_)");
        putln "{";
        putln ("  _C_->lucky_ctx = " ^ fn ^ "_new_ctx(_C_);");
        putln "}";

        put ("void " ^ option.calling_module_name ^ "(_C_" ^ 
               option.calling_module_name ^ " *_C_){");

        putln "\n  // sets the inputs";
        List.iter 
          (fun var -> 
             put ("  " ^ fn ^ "_I_"^ (Var.name var) ^ "(_C_->lucky_ctx, ");
             putln ((Var.name var) ^ ");")
          )
          in_vars;
        
        putln "\n  // perform the step";
        putln ("  " ^ fn ^ "_step(_C_->lucky_ctx, step_inside);");
        
        putln "}"; 
      );
770
771
      );
      
772
773
774
      flush oc;
      close_out oc

775
776
777
778
779
780
781
782
783
784
(****************************************************************************)
(*
  Invent a file name from the list of file names, unless one was provided
  at the command line.
*)

let (build_file_name : string list -> string) =
  fun el ->
    let change_file_name f =
      (* make sure that there is no strange char in the name of the
785
786
787
         file as it will be used as a C ident.
         Therefore, we replace " " and "-" by "_".
         Is there any other problematic chars?
788
789
790
791
      *)
      let f0 = (Filename.basename (Filename.chop_extension f)) in
      let f1 = Str.global_replace (Str.regexp " ") "_" f0 in
      let f2 = Str.global_replace (Str.regexp "-") "_" f1 in
792
        f2
793
    in
794
      match option.output with
795
796
797
798
799
800
801
802
          None -> 
            let fn = 
              assert (el <> []);
              List.fold_left 
              (fun f acc -> (acc^"_"^(change_file_name f))) 
                (change_file_name (List.hd el))
                (List.tl el) 
            in
803
              option.output <- Some fn;
804
805
              fn
        | Some fn -> fn
806
807
808


(****************************************************************************)
809
open Prog
810

811
let (main : unit -> unit) =
812
  fun _ ->
813
814
    let env_list = option.env in
    let state = LucProg.make_state option.pp env_list in
Erwan Jahier's avatar
Erwan Jahier committed
815
    let _ =  assert (env_list <> []) in
816
817
818
819
820
821
822
823
824
825
826
827
    let from_lutin = Util.get_extension (List.hd env_list) = ".lut"  in
    let fn = build_file_name env_list in
    let _ = 
      gen_c_file fn state.s.in_vars state.s.out_vars state.s.loc_vars;
      gen_h_file fn state.s.in_vars state.s.out_vars state.s.loc_vars
    in
    let gen_files_for_lustre () =
      gen_lustre_ext_func_c fn state.s.in_vars state.s.out_vars ;
      gen_lustre_ext_func_h fn state.s.in_vars state.s.out_vars ;
      gen_lustre_ext_h fn
    in
      (match option.gen_mode with
Erwan Jahier's avatar
Erwan Jahier committed
828
         | Nop -> ()
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
         | Lustre -> gen_files_for_lustre ()
         | Luciole -> 
             let var_to_vn_ct v =
               (Var.name v, 
                Type.to_cstring (Var.typ v)
               )
             in
               Luciole.gen_stubs false from_lutin fn
                 (List.map var_to_vn_ct state.s.in_vars)
                 (List.map var_to_vn_ct state.s.out_vars)
         | Scade -> ()
         | Alice ->
             let alice_args = {
               Luc2alice.env_name = fn;
               Luc2alice.alice_module_name = option.calling_module_name ;
               Luc2alice.seed = option.seed;
               Luc2alice.env_in_vars = state.s.in_vars ;
               Luc2alice.env_out_vars = state.s.out_vars ;
847
               Luc2alice.use_sockets = option.use_sockets ;
848
849
850
851
852

             }
             in
               Luc2alice.gen_alice_stub_c alice_args;
               Luc2alice.gen_alice_stub_h alice_args;
853
      )
854

855