Project

General

Profile

« Previous | Next » 

Revision 04e26a3f

Added by Xavier Thirioux almost 9 years ago

answer to #feature 50:
- arrows are now factorized out and become part of include
as files arrow.h and arrow.c
- no more arrows in generated code
- compiling and linking arrow.c is only necessary
in case of dynamic allocation
- version now includes installation prefix (for the standard lib)
and svn number

git-svn-id: https://cavale.enseeiht.fr/svn/lustrec/lustre_compiler/trunk@180 041b043f-8d7c-46b2-b46e-ef0dd855326e

View differences:

_oasis
6 6
License:     LGPL-2.1
7 7
Plugins:     DevFiles (0.2)
8 8
# , Custom (0.2)
9
PreBuildCommand: ./svn_version.sh 
10
PostInstallCommand: mkdir -p $(prefix)/include; cp -rf include $(prefix)/include/lustrec
9
PreBuildCommand: ./svn_version.sh $(prefix)
10
PostInstallCommand: mkdir -p $(prefix)/include/lustrec; cp -rf include/*.[ch] $(prefix)/include/lustrec; cp -rf include/*.java $(prefix)/include/lustrec
11 11

  
12 12
Executable lustrec
13 13
  Path:       src
_tags
1 1
# OASIS_START
2
# DO NOT EDIT (digest: 54aa7498411485980381101fb69226dd)
2
# DO NOT EDIT (digest: 98bcbc21d29d2f6266238c1025fff223)
3
# Ignore VCS directories, you can use the same kind of rule outside 
4
# OASIS_START/STOP if you want to exclude directories that contains 
5
# useless stuff for the build process
6
<**/.svn>: -traverse
7
<**/.svn>: not_hygienic
8
".bzr": -traverse
9
".bzr": not_hygienic
10
".hg": -traverse
11
".hg": not_hygienic
12
".git": -traverse
13
".git": not_hygienic
14
"_darcs": -traverse
15
"_darcs": not_hygienic
3 16
# Executable lustrec
4
"src/main_lustre_compiler.native": pkg_unix
5
"src/main_lustre_compiler.native": pkg_str
6 17
"src/main_lustre_compiler.native": pkg_ocamlgraph
7
<src/*.ml{,i}>: pkg_unix
8
<src/*.ml{,i}>: pkg_str
18
"src/main_lustre_compiler.native": pkg_str
19
"src/main_lustre_compiler.native": pkg_unix
9 20
<src/*.ml{,i}>: pkg_ocamlgraph
21
<src/*.ml{,i}>: pkg_str
22
<src/*.ml{,i}>: pkg_unix
10 23
# OASIS_STOP
configure
1 1
#!/bin/sh
2 2

  
3 3
# OASIS_START
4
# DO NOT EDIT (digest: ed33e59fe00e48bc31edf413bbc8b8d6)
4
# DO NOT EDIT (digest: 425187ed8bfdbdd207fd76392dd243a7)
5 5
set -e
6 6

  
7
ocaml setup.ml -configure $*
7
FST=true
8
for i in "$@"; do 
9
  if $FST; then
10
    set --
11
    FST=false
12
  fi
13

  
14
  case $i in
15
    --*=*)
16
      ARG=${i%%=*}
17
      VAL=${i##*=}
18
      set -- "$@" "$ARG" "$VAL"
19
      ;;
20
    *)
21
      set -- "$@" "$i"
22
      ;;
23
  esac
24
done
25

  
26
ocaml setup.ml -configure "$@"
8 27
# OASIS_STOP
include/arrow.c
1
#include <stdlib.h>
2
#include <assert.h>
3
#include "arrow.h"
4

  
5
struct _arrow_mem *arrow_alloc() {
6
  struct _arrow_mem *_alloc;
7
  _alloc = (struct _arrow_mem *) malloc(sizeof(struct _arrow_mem *));
8
  assert (_alloc);
9
  return _alloc;
10
}
include/arrow.h
1

  
2
#ifndef _ARROW
3
#define _ARROW
4

  
5
struct _arrow_mem {struct _arrow_reg {_Bool _first; } _reg; };
6

  
7
extern struct _arrow_mem *arrow_alloc ();
8

  
9
#define _arrow_DECLARE(inst)\
10
  struct _arrow_mem inst;
11
  
12
#define _arrow_LINK(inst) do {\
13
  ;\
14
} while (0)
15

  
16
#define _arrow_step(x,y,output,self) ((self)->_reg._first?((self)->_reg._first=0,(*output = x)):(*output = y))
17

  
18
#define _arrow_reset(self) {(self)->_reg._first = 1;}
19

  
20
#endif
myocamlbuild.ml
1 1
(* OASIS_START *)
2
(* DO NOT EDIT (digest: 7eabc0106cad87d67c960d9a2ff80b28) *)
2
(* DO NOT EDIT (digest: 00359f2e15a7ed8f31f1d7ce086345f9) *)
3 3
module OASISGettext = struct
4
# 21 "/build/buildd/oasis-0.2.0/src/oasis/OASISGettext.ml"
5
  
6
  let ns_ str = 
4
(* # 21 "/build/buildd/oasis-0.3.0/src/oasis/OASISGettext.ml" *)
5

  
6
  let ns_ str =
7 7
    str
8
  
9
  let s_ str = 
8

  
9
  let s_ str =
10 10
    str
11
  
11

  
12 12
  let f_ (str : ('a, 'b, 'c, 'd) format4) =
13 13
    str
14
  
14

  
15 15
  let fn_ fmt1 fmt2 n =
16 16
    if n = 1 then
17 17
      fmt1^^""
18 18
    else
19 19
      fmt2^^""
20
  
21
  let init = 
20

  
21
  let init =
22 22
    []
23
  
23

  
24 24
end
25 25

  
26 26
module OASISExpr = struct
27
# 21 "/build/buildd/oasis-0.2.0/src/oasis/OASISExpr.ml"
28
  
29
  
30
  
27
(* # 21 "/build/buildd/oasis-0.3.0/src/oasis/OASISExpr.ml" *)
28

  
29

  
30

  
31 31
  open OASISGettext
32
  
32

  
33 33
  type test = string 
34
  
34

  
35 35
  type flag = string 
36
  
36

  
37 37
  type t =
38 38
    | EBool of bool
39 39
    | ENot of t
......
42 42
    | EFlag of flag
43 43
    | ETest of test * string
44 44
    
45
  
45

  
46 46
  type 'a choices = (t * 'a) list 
47
  
47

  
48 48
  let eval var_get t =
49
    let rec eval' = 
49
    let rec eval' =
50 50
      function
51 51
        | EBool b ->
52 52
            b
53
  
54
        | ENot e -> 
53

  
54
        | ENot e ->
55 55
            not (eval' e)
56
  
56

  
57 57
        | EAnd (e1, e2) ->
58 58
            (eval' e1) && (eval' e2)
59
  
60
        | EOr (e1, e2) -> 
59

  
60
        | EOr (e1, e2) ->
61 61
            (eval' e1) || (eval' e2)
62
  
62

  
63 63
        | EFlag nm ->
64 64
            let v =
65 65
              var_get nm
66 66
            in
67 67
              assert(v = "true" || v = "false");
68 68
              (v = "true")
69
  
69

  
70 70
        | ETest (nm, vl) ->
71 71
            let v =
72 72
              var_get nm
......
74 74
              (v = vl)
75 75
    in
76 76
      eval' t
77
  
77

  
78 78
  let choose ?printer ?name var_get lst =
79
    let rec choose_aux = 
79
    let rec choose_aux =
80 80
      function
81 81
        | (cond, vl) :: tl ->
82
            if eval var_get cond then 
83
              vl 
82
            if eval var_get cond then
83
              vl
84 84
            else
85 85
              choose_aux tl
86 86
        | [] ->
87
            let str_lst = 
87
            let str_lst =
88 88
              if lst = [] then
89 89
                s_ "<empty>"
90 90
              else
91
                String.concat 
91
                String.concat
92 92
                  (s_ ", ")
93 93
                  (List.map
94 94
                     (fun (cond, vl) ->
......
97 97
                          | None -> s_ "<no printer>")
98 98
                     lst)
99 99
            in
100
              match name with 
100
              match name with
101 101
                | Some nm ->
102 102
                    failwith
103
                      (Printf.sprintf 
103
                      (Printf.sprintf
104 104
                         (f_ "No result for the choice list '%s': %s")
105 105
                         nm str_lst)
106 106
                | None ->
......
110 110
                         str_lst)
111 111
    in
112 112
      choose_aux (List.rev lst)
113
  
113

  
114 114
end
115 115

  
116 116

  
117
# 117 "myocamlbuild.ml"
117 118
module BaseEnvLight = struct
118
# 21 "/build/buildd/oasis-0.2.0/src/base/BaseEnvLight.ml"
119
  
119
(* # 21 "/build/buildd/oasis-0.3.0/src/base/BaseEnvLight.ml" *)
120

  
120 121
  module MapString = Map.Make(String)
121
  
122

  
122 123
  type t = string MapString.t
123
  
124

  
124 125
  let default_filename =
125
    Filename.concat 
126
    Filename.concat
126 127
      (Sys.getcwd ())
127 128
      "setup.data"
128
  
129

  
129 130
  let load ?(allow_empty=false) ?(filename=default_filename) () =
130 131
    if Sys.file_exists filename then
131 132
      begin
......
138 139
        let line =
139 140
          ref 1
140 141
        in
141
        let st_line = 
142
        let st_line =
142 143
          Stream.from
143 144
            (fun _ ->
144 145
               try
145
                 match Stream.next st with 
146
                 match Stream.next st with
146 147
                   | '\n' -> incr line; Some '\n'
147 148
                   | c -> Some c
148 149
               with Stream.Failure -> None)
149 150
        in
150
        let lexer = 
151
        let lexer =
151 152
          Genlex.make_lexer ["="] st_line
152 153
        in
153 154
        let rec read_file mp =
154
          match Stream.npeek 3 lexer with 
155
          match Stream.npeek 3 lexer with
155 156
            | [Genlex.Ident nm; Genlex.Kwd "="; Genlex.String value] ->
156
                Stream.junk lexer; 
157
                Stream.junk lexer; 
157
                Stream.junk lexer;
158
                Stream.junk lexer;
158 159
                Stream.junk lexer;
159 160
                read_file (MapString.add nm value mp)
160 161
            | [] ->
......
177 178
      end
178 179
    else
179 180
      begin
180
        failwith 
181
          (Printf.sprintf 
181
        failwith
182
          (Printf.sprintf
182 183
             "Unable to load environment, the file '%s' doesn't exist."
183 184
             filename)
184 185
      end
185
  
186

  
186 187
  let var_get name env =
187 188
    let rec var_expand str =
188 189
      let buff =
189 190
        Buffer.create ((String.length str) * 2)
190 191
      in
191
        Buffer.add_substitute 
192
        Buffer.add_substitute
192 193
          buff
193
          (fun var -> 
194
             try 
194
          (fun var ->
195
             try
195 196
               var_expand (MapString.find var env)
196 197
             with Not_found ->
197
               failwith 
198
                 (Printf.sprintf 
198
               failwith
199
                 (Printf.sprintf
199 200
                    "No variable %s defined when trying to expand %S."
200
                    var 
201
                    var
201 202
                    str))
202 203
          str;
203 204
        Buffer.contents buff
204 205
    in
205 206
      var_expand (MapString.find name env)
206
  
207
  let var_choose lst env = 
207

  
208
  let var_choose lst env =
208 209
    OASISExpr.choose
209 210
      (fun nm -> var_get nm env)
210 211
      lst
211 212
end
212 213

  
213 214

  
215
# 215 "myocamlbuild.ml"
214 216
module MyOCamlbuildFindlib = struct
215
# 21 "/build/buildd/oasis-0.2.0/src/plugins/ocamlbuild/MyOCamlbuildFindlib.ml"
216
  
217
(* # 21 "/build/buildd/oasis-0.3.0/src/plugins/ocamlbuild/MyOCamlbuildFindlib.ml" *)
218

  
217 219
  (** OCamlbuild extension, copied from 
218 220
    * http://brion.inria.fr/gallium/index.php/Using_ocamlfind_with_ocamlbuild
219 221
    * by N. Pouillard and others
......
223 225
    * Modified by Sylvain Le Gall 
224 226
    *)
225 227
  open Ocamlbuild_plugin
226
  
228

  
227 229
  (* these functions are not really officially exported *)
228 230
  let run_and_read = 
229 231
    Ocamlbuild_pack.My_unix.run_and_read
230
  
232

  
231 233
  let blank_sep_strings = 
232 234
    Ocamlbuild_pack.Lexers.blank_sep_strings
233
  
235

  
234 236
  let split s ch =
235 237
    let x = 
236 238
      ref [] 
......
245 247
      try
246 248
        go s
247 249
      with Not_found -> !x
248
  
250

  
249 251
  let split_nl s = split s '\n'
250
  
252

  
251 253
  let before_space s =
252 254
    try
253 255
      String.before s (String.index s ' ')
254 256
    with Not_found -> s
255
  
257

  
256 258
  (* this lists all supported packages *)
257 259
  let find_packages () =
258 260
    List.map before_space (split_nl & run_and_read "ocamlfind list")
259
  
261

  
260 262
  (* this is supposed to list available syntaxes, but I don't know how to do it. *)
261 263
  let find_syntaxes () = ["camlp4o"; "camlp4r"]
262
  
264

  
263 265
  (* ocamlfind command *)
264 266
  let ocamlfind x = S[A"ocamlfind"; x]
265
  
267

  
266 268
  let dispatch =
267 269
    function
268 270
      | Before_options ->
......
292 294
              flag ["ocaml"; "infer_interface"; "pkg_"^pkg] & S[A"-package"; A pkg];
293 295
            end 
294 296
            (find_packages ());
295
  
297

  
296 298
          (* Like -package but for extensions syntax. Morover -syntax is useless
297 299
           * when linking. *)
298 300
          List.iter begin fun syntax ->
......
301 303
          flag ["ocaml"; "doc";      "syntax_"^syntax] & S[A"-syntax"; A syntax];
302 304
          flag ["ocaml"; "infer_interface"; "syntax_"^syntax] & S[A"-syntax"; A syntax];
303 305
          end (find_syntaxes ());
304
  
306

  
305 307
          (* The default "thread" tag is not compatible with ocamlfind.
306 308
           * Indeed, the default rules add the "threads.cma" or "threads.cmxa"
307 309
           * options when using this tag. When using the "-linkpkg" option with
......
311 313
           * the "threads" package using the previous plugin.
312 314
           *)
313 315
          flag ["ocaml"; "pkg_threads"; "compile"] (S[A "-thread"]);
316
          flag ["ocaml"; "pkg_threads"; "doc"] (S[A "-I"; A "+threads"]);
314 317
          flag ["ocaml"; "pkg_threads"; "link"] (S[A "-thread"]);
315 318
          flag ["ocaml"; "pkg_threads"; "infer_interface"] (S[A "-thread"])
316
  
319

  
317 320
      | _ -> 
318 321
          ()
319
  
322

  
320 323
end
321 324

  
322 325
module MyOCamlbuildBase = struct
323
# 21 "/build/buildd/oasis-0.2.0/src/plugins/ocamlbuild/MyOCamlbuildBase.ml"
324
  
326
(* # 21 "/build/buildd/oasis-0.3.0/src/plugins/ocamlbuild/MyOCamlbuildBase.ml" *)
327

  
325 328
  (** Base functions for writing myocamlbuild.ml
326 329
      @author Sylvain Le Gall
327 330
    *)
328
  
329
  
330
  
331

  
332

  
333

  
331 334
  open Ocamlbuild_plugin
332
  
335
  module OC = Ocamlbuild_pack.Ocaml_compiler
336

  
333 337
  type dir = string 
334 338
  type file = string 
335 339
  type name = string 
336 340
  type tag = string 
337
  
338
# 55 "/build/buildd/oasis-0.2.0/src/plugins/ocamlbuild/MyOCamlbuildBase.ml"
339
  
341

  
342
(* # 56 "/build/buildd/oasis-0.3.0/src/plugins/ocamlbuild/MyOCamlbuildBase.ml" *)
343

  
340 344
  type t =
341 345
      {
342 346
        lib_ocaml: (name * dir list) list;
343 347
        lib_c:     (name * dir * file list) list; 
344 348
        flags:     (tag list * (spec OASISExpr.choices)) list;
349
        (* Replace the 'dir: include' from _tags by a precise interdepends in
350
         * directory.
351
         *)
352
        includes:  (dir * dir list) list; 
345 353
      } 
346
  
354

  
347 355
  let env_filename =
348 356
    Pathname.basename 
349 357
      BaseEnvLight.default_filename
350
  
358

  
351 359
  let dispatch_combine lst =
352 360
    fun e ->
353 361
      List.iter 
354 362
        (fun dispatch -> dispatch e)
355 363
        lst 
356
  
364

  
365
  let tag_libstubs nm =
366
    "use_lib"^nm^"_stubs"
367

  
368
  let nm_libstubs nm =
369
    nm^"_stubs"
370

  
357 371
  let dispatch t e = 
358 372
    let env = 
359 373
      BaseEnvLight.load 
......
380 394
                  Options.ext_lib, "ext_lib";
381 395
                  Options.ext_dll, "ext_dll";
382 396
                ]
383
  
397

  
384 398
        | After_rules -> 
385 399
            (* Declare OCaml libraries *)
386 400
            List.iter 
387 401
              (function
388
                 | lib, [] ->
389
                     ocaml_lib lib;
390
                 | lib, dir :: tl ->
391
                     ocaml_lib ~dir:dir lib;
402
                 | nm, [] ->
403
                     ocaml_lib nm
404
                 | nm, dir :: tl ->
405
                     ocaml_lib ~dir:dir (dir^"/"^nm);
392 406
                     List.iter 
393 407
                       (fun dir -> 
394
                          flag 
395
                            ["ocaml"; "use_"^lib; "compile"] 
396
                            (S[A"-I"; P dir]))
408
                          List.iter
409
                            (fun str ->
410
                               flag ["ocaml"; "use_"^nm; str] (S[A"-I"; P dir]))
411
                            ["compile"; "infer_interface"; "doc"])
397 412
                       tl)
398 413
              t.lib_ocaml;
399
  
414

  
415
            (* Declare directories dependencies, replace "include" in _tags. *)
416
            List.iter 
417
              (fun (dir, include_dirs) ->
418
                 Pathname.define_context dir include_dirs)
419
              t.includes;
420

  
400 421
            (* Declare C libraries *)
401 422
            List.iter
402 423
              (fun (lib, dir, headers) ->
403 424
                   (* Handle C part of library *)
404
                   flag ["link"; "library"; "ocaml"; "byte"; "use_lib"^lib]
405
                     (S[A"-dllib"; A("-l"^lib); A"-cclib"; A("-l"^lib)]);
406
  
407
                   flag ["link"; "library"; "ocaml"; "native"; "use_lib"^lib]
408
                     (S[A"-cclib"; A("-l"^lib)]);
425
                   flag ["link"; "library"; "ocaml"; "byte"; tag_libstubs lib]
426
                     (S[A"-dllib"; A("-l"^(nm_libstubs lib)); A"-cclib";
427
                        A("-l"^(nm_libstubs lib))]);
428

  
429
                   flag ["link"; "library"; "ocaml"; "native"; tag_libstubs lib]
430
                     (S[A"-cclib"; A("-l"^(nm_libstubs lib))]);
409 431
                        
410
                   flag ["link"; "program"; "ocaml"; "byte"; "use_lib"^lib]
411
                     (S[A"-dllib"; A("dll"^lib)]);
412
  
432
                   flag ["link"; "program"; "ocaml"; "byte"; tag_libstubs lib]
433
                     (S[A"-dllib"; A("dll"^(nm_libstubs lib))]);
434

  
413 435
                   (* When ocaml link something that use the C library, then one
414 436
                      need that file to be up to date.
415 437
                    *)
416
                   dep  ["link"; "ocaml"; "use_lib"^lib] 
417
                     [dir/"lib"^lib^"."^(!Options.ext_lib)];
418
  
438
                   dep ["link"; "ocaml"; "program"; tag_libstubs lib]
439
                     [dir/"lib"^(nm_libstubs lib)^"."^(!Options.ext_lib)];
440

  
441
                   dep  ["compile"; "ocaml"; "program"; tag_libstubs lib]
442
                     [dir/"lib"^(nm_libstubs lib)^"."^(!Options.ext_lib)];
443

  
419 444
                   (* TODO: be more specific about what depends on headers *)
420 445
                   (* Depends on .h files *)
421 446
                   dep ["compile"; "c"] 
422 447
                     headers;
423
  
448

  
424 449
                   (* Setup search path for lib *)
425 450
                   flag ["link"; "ocaml"; "use_"^lib] 
426 451
                     (S[A"-I"; P(dir)]);
427 452
              )
428 453
              t.lib_c;
429
  
454

  
430 455
              (* Add flags *)
431 456
              List.iter
432 457
              (fun (tags, cond_specs) ->
......
437 462
              t.flags
438 463
        | _ -> 
439 464
            ()
440
  
465

  
441 466
  let dispatch_default t =
442 467
    dispatch_combine 
443 468
      [
444 469
        dispatch t;
445 470
        MyOCamlbuildFindlib.dispatch;
446 471
      ]
447
  
472

  
448 473
end
449 474

  
450 475

  
476
# 476 "myocamlbuild.ml"
451 477
open Ocamlbuild_plugin;;
452 478
let package_default =
453
  {MyOCamlbuildBase.lib_ocaml = []; lib_c = []; flags = []; }
479
  {MyOCamlbuildBase.lib_ocaml = []; lib_c = []; flags = []; includes = []; }
454 480
  ;;
455 481

  
456 482
let dispatch_default = MyOCamlbuildBase.dispatch_default package_default;;
457 483

  
484
# 485 "myocamlbuild.ml"
458 485
(* OASIS_STOP *)
459 486
Ocamlbuild_plugin.dispatch dispatch_default;;
setup.ml
1 1
(* setup.ml generated for the first time by OASIS v0.2.0 *)
2 2

  
3 3
(* OASIS_START *)
4
(* DO NOT EDIT (digest: 6666f62d55895fd4c2e5dbbf8e9d4998) *)
4
(* DO NOT EDIT (digest: 199ddf56e2399fc7ababf7124443bcc9) *)
5 5
(*
6
   Regenerated by OASIS v0.2.0
6
   Regenerated by OASIS v0.3.0
7 7
   Visit http://oasis.forge.ocamlcore.org for more information and
8 8
   documentation about functions used in this file.
9 9
*)
10 10
module OASISGettext = struct
11
# 21 "/build/buildd/oasis-0.2.0/src/oasis/OASISGettext.ml"
12
  
13
  let ns_ str = 
11
(* # 21 "/build/buildd/oasis-0.3.0/src/oasis/OASISGettext.ml" *)
12

  
13
  let ns_ str =
14 14
    str
15
  
16
  let s_ str = 
15

  
16
  let s_ str =
17 17
    str
18
  
18

  
19 19
  let f_ (str : ('a, 'b, 'c, 'd) format4) =
20 20
    str
21
  
21

  
22 22
  let fn_ fmt1 fmt2 n =
23 23
    if n = 1 then
24 24
      fmt1^^""
25 25
    else
26 26
      fmt2^^""
27
  
28
  let init = 
27

  
28
  let init =
29 29
    []
30
  
30

  
31 31
end
32 32

  
33 33
module OASISContext = struct
34
# 21 "/build/buildd/oasis-0.2.0/src/oasis/OASISContext.ml"
35
  
36
  open OASISGettext 
37
  
34
(* # 21 "/build/buildd/oasis-0.3.0/src/oasis/OASISContext.ml" *)
35

  
36
  open OASISGettext
37

  
38 38
  type level =
39 39
    [ `Debug
40
    | `Info 
40
    | `Info
41 41
    | `Warning
42 42
    | `Error]
43
  
43

  
44 44
  type t =
45 45
    {
46
      verbose:        bool;
47
      debug:          bool;
48
      ignore_plugins: bool;
49
      printf:         level -> string -> unit; 
46
      quiet:                 bool;
47
      info:                  bool;
48
      debug:                 bool;
49
      ignore_plugins:        bool;
50
      ignore_unknown_fields: bool;
51
      printf:                level -> string -> unit;
50 52
    }
51
  
52
  let printf lvl str = 
53
    let beg = 
54
      match lvl with 
53

  
54
  let printf lvl str =
55
    let beg =
56
      match lvl with
55 57
        | `Error -> s_ "E: "
56 58
        | `Warning -> s_ "W: "
57 59
        | `Info  -> s_ "I: "
58 60
        | `Debug -> s_ "D: "
59 61
    in
60
      match lvl with 
61
        | `Error ->
62
            prerr_endline (beg^str)
63
        | _ ->
64
            print_endline (beg^str)
65
  
62
      prerr_endline (beg^str)
63

  
66 64
  let default =
67
    ref 
65
    ref
68 66
      {
69
        verbose        = true;
70
        debug          = false;
71
        ignore_plugins = false;
72
        printf         = printf;
67
        quiet                 = false;
68
        info                  = false;
69
        debug                 = false;
70
        ignore_plugins        = false;
71
        ignore_unknown_fields = false;
72
        printf                = printf;
73 73
      }
74
  
75
  let quiet = 
76
    {!default with 
77
         verbose = false;
78
         debug   = false;
79
    }
80
  
81
  
74

  
75
  let quiet =
76
    {!default with quiet = true}
77

  
78

  
82 79
  let args () =
83 80
    ["-quiet",
84
     Arg.Unit (fun () -> default := {!default with verbose = false}),
81
     Arg.Unit (fun () -> default := {!default with quiet = true}),
85 82
     (s_ " Run quietly");
86
  
83

  
84
     "-info",
85
     Arg.Unit (fun () -> default := {!default with info = true}),
86
     (s_ " Display information message");
87

  
88

  
87 89
     "-debug",
88 90
     Arg.Unit (fun () -> default := {!default with debug = true}),
89 91
     (s_ " Output debug message")]
90 92
end
91 93

  
94
module OASISString = struct
95
(* # 1 "/build/buildd/oasis-0.3.0/src/oasis/OASISString.ml" *)
96

  
97

  
98

  
99
  (** Various string utilities.
100
     
101
      Mostly inspired by extlib and batteries ExtString and BatString libraries.
102

  
103
      @author Sylvain Le Gall
104
    *)
105

  
106
  let nsplitf str f =
107
    if str = "" then
108
      []
109
    else
110
      let buf = Buffer.create 13 in
111
      let lst = ref [] in
112
      let push () =
113
        lst := Buffer.contents buf :: !lst;
114
        Buffer.clear buf
115
      in
116
      let str_len = String.length str in
117
        for i = 0 to str_len - 1 do
118
          if f str.[i] then
119
            push ()
120
          else
121
            Buffer.add_char buf str.[i]
122
        done;
123
        push ();
124
        List.rev !lst
125

  
126
  (** [nsplit c s] Split the string [s] at char [c]. It doesn't include the
127
      separator.
128
    *)
129
  let nsplit str c =
130
    nsplitf str ((=) c)
131

  
132
  let find ~what ?(offset=0) str =
133
    let what_idx = ref 0 in
134
    let str_idx = ref offset in 
135
      while !str_idx < String.length str && 
136
            !what_idx < String.length what do
137
        if str.[!str_idx] = what.[!what_idx] then
138
          incr what_idx
139
        else
140
          what_idx := 0;
141
        incr str_idx
142
      done;
143
      if !what_idx <> String.length what then
144
        raise Not_found
145
      else 
146
        !str_idx - !what_idx
147

  
148
  let sub_start str len = 
149
    let str_len = String.length str in
150
    if len >= str_len then
151
      ""
152
    else
153
      String.sub str len (str_len - len)
154

  
155
  let sub_end ?(offset=0) str len =
156
    let str_len = String.length str in
157
    if len >= str_len then
158
      ""
159
    else
160
      String.sub str 0 (str_len - len)
161

  
162
  let starts_with ~what ?(offset=0) str =
163
    let what_idx = ref 0 in
164
    let str_idx = ref offset in
165
    let ok = ref true in
166
      while !ok &&
167
            !str_idx < String.length str && 
168
            !what_idx < String.length what do
169
        if str.[!str_idx] = what.[!what_idx] then
170
          incr what_idx
171
        else
172
          ok := false;
173
        incr str_idx
174
      done;
175
      if !what_idx = String.length what then
176
        true
177
      else 
178
        false
179

  
180
  let strip_starts_with ~what str =
181
    if starts_with ~what str then
182
      sub_start str (String.length what)
183
    else
184
      raise Not_found
185

  
186
  let ends_with ~what ?(offset=0) str =
187
    let what_idx = ref ((String.length what) - 1) in
188
    let str_idx = ref ((String.length str) - 1) in
189
    let ok = ref true in
190
      while !ok &&
191
            offset <= !str_idx && 
192
            0 <= !what_idx do
193
        if str.[!str_idx] = what.[!what_idx] then
194
          decr what_idx
195
        else
196
          ok := false;
197
        decr str_idx
198
      done;
199
      if !what_idx = -1 then
200
        true
201
      else 
202
        false
203

  
204
  let strip_ends_with ~what str =
205
    if ends_with ~what str then
206
      sub_end str (String.length what)
207
    else
208
      raise Not_found
209

  
210
  let replace_chars f s =
211
    let buf = String.make (String.length s) 'X' in
212
      for i = 0 to String.length s - 1 do
213
        buf.[i] <- f s.[i]
214
      done;
215
      buf
216

  
217
end
218

  
92 219
module OASISUtils = struct
93
# 21 "/build/buildd/oasis-0.2.0/src/oasis/OASISUtils.ml"
94
  
220
(* # 21 "/build/buildd/oasis-0.3.0/src/oasis/OASISUtils.ml" *)
221

  
222
  open OASISGettext
223

  
95 224
  module MapString = Map.Make(String)
96
  
225

  
97 226
  let map_string_of_assoc assoc =
98 227
    List.fold_left
99 228
      (fun acc (k, v) -> MapString.add k v acc)
100 229
      MapString.empty
101 230
      assoc
102
  
231

  
103 232
  module SetString = Set.Make(String)
104
  
233

  
105 234
  let set_string_add_list st lst =
106
    List.fold_left 
235
    List.fold_left
107 236
      (fun acc e -> SetString.add e acc)
108 237
      st
109 238
      lst
110
  
239

  
111 240
  let set_string_of_list =
112 241
    set_string_add_list
113 242
      SetString.empty
114
  
115
  
116
  let compare_csl s1 s2 = 
243

  
244

  
245
  let compare_csl s1 s2 =
117 246
    String.compare (String.lowercase s1) (String.lowercase s2)
118
  
119
  module HashStringCsl = 
247

  
248
  module HashStringCsl =
120 249
    Hashtbl.Make
121 250
      (struct
122 251
         type t = string
123
  
124
         let equal s1 s2 = 
252

  
253
         let equal s1 s2 =
125 254
             (String.lowercase s1) = (String.lowercase s2)
126
  
255

  
127 256
         let hash s =
128 257
           Hashtbl.hash (String.lowercase s)
129 258
       end)
130
  
131
  let split sep str =
132
    let str_len =
133
      String.length str
134
    in
135
    let rec split_aux acc pos =
136
      if pos < str_len then
137
        (
138
          let pos_sep = 
139
            try
140
              String.index_from str pos sep
141
            with Not_found ->
142
              str_len
143
          in
144
          let part = 
145
            String.sub str pos (pos_sep - pos) 
146
          in
147
          let acc = 
148
            part :: acc
149
          in
150
            if pos_sep >= str_len then
151
              (
152
                (* Nothing more in the string *)
153
                List.rev acc
154
              )
155
            else if pos_sep = (str_len - 1) then
156
              (
157
                (* String end with a separator *)
158
                List.rev ("" :: acc)
159
              )
160
            else
161
              (
162
                split_aux acc (pos_sep + 1)
163
              )
164
        )
165
      else
166
        (
167
          List.rev acc
168
        )
169
    in
170
      split_aux [] 0
171
  
172
  
173
  let varname_of_string ?(hyphen='_') s = 
259

  
260
  let varname_of_string ?(hyphen='_') s =
174 261
    if String.length s = 0 then
175 262
      begin
176
        invalid_arg "varname_of_string" 
263
        invalid_arg "varname_of_string"
177 264
      end
178 265
    else
179 266
      begin
180
        let buff = 
181
          Buffer.create (String.length s)
182
        in
183
          (* Start with a _ if digit *)
184
          if '0' <= s.[0] && s.[0] <= '9' then
185
            Buffer.add_char buff hyphen;
186
  
187
          String.iter
267
        let buf =
268
          OASISString.replace_chars
188 269
            (fun c ->
189
               if ('a' <= c && c <= 'z') 
190
                 || 
191
                  ('A' <= c && c <= 'Z') 
192
                 || 
270
               if ('a' <= c && c <= 'z')
271
                 ||
272
                  ('A' <= c && c <= 'Z')
273
                 ||
193 274
                  ('0' <= c && c <= '9') then
194
                 Buffer.add_char buff c
275
                 c
195 276
               else
196
                 Buffer.add_char buff hyphen)
277
                 hyphen)
197 278
            s;
198
  
199
          String.lowercase (Buffer.contents buff)
279
        in
280
        let buf =
281
          (* Start with a _ if digit *)
282
          if '0' <= s.[0] && s.[0] <= '9' then
283
            "_"^buf
284
          else
285
            buf
286
        in
287
          String.lowercase buf
200 288
      end
201
  
202
  let varname_concat ?(hyphen='_') p s = 
203
    let p = 
204
      let p_len =
205
        String.length p
206
      in
207
        if p_len > 0 && p.[p_len - 1] = hyphen then
208
          String.sub p 0 (p_len - 1)
209
        else
210
          p
289

  
290
  let varname_concat ?(hyphen='_') p s =
291
    let what = String.make 1 hyphen in
292
    let p =
293
      try
294
        OASISString.strip_ends_with ~what p
295
      with Not_found ->
296
        p
211 297
    in
212
    let s = 
213
      let s_len =
214
        String.length s
215
      in
216
        if s_len > 0 && s.[0] = hyphen then
217
          String.sub s 1 (s_len - 1)
218
        else
219
          s
298
    let s =
299
      try
300
        OASISString.strip_starts_with ~what s
301
      with Not_found ->
302
        s
220 303
    in
221
      Printf.sprintf "%s%c%s" p hyphen s
222
  
223
  
224
  let is_varname str = 
304
      p^what^s
305

  
306

  
307
  let is_varname str =
225 308
    str = varname_of_string str
226
  
227
  let failwithf1 fmt a =
228
    failwith (Printf.sprintf fmt a)
229
  
230
  let failwithf2 fmt a b =
231
    failwith (Printf.sprintf fmt a b)
232
  
233
  let failwithf3 fmt a b c =
234
    failwith (Printf.sprintf fmt a b c)
235
  
236
  let failwithf4 fmt a b c d =
237
    failwith (Printf.sprintf fmt a b c d)
238
  
239
  let failwithf5 fmt a b c d e =
240
    failwith (Printf.sprintf fmt a b c d e)
241
  
309

  
310
  let failwithf fmt = Printf.ksprintf failwith fmt
311

  
242 312
end
243 313

  
244 314
module PropList = struct
245
# 21 "/build/buildd/oasis-0.2.0/src/oasis/PropList.ml"
246
  
315
(* # 21 "/build/buildd/oasis-0.3.0/src/oasis/PropList.ml" *)
316

  
247 317
  open OASISGettext
248
  
318

  
249 319
  type name = string
250
  
251
  exception Not_set of name * string option 
320

  
321
  exception Not_set of name * string option
252 322
  exception No_printer of name
253 323
  exception Unknown_field of name * name
254
  
255
  let string_of_exception =
256
    function
257
      | Not_set (nm, Some rsn) ->
258
          Printf.sprintf (f_ "Field '%s' is not set: %s") nm rsn
259
      | Not_set (nm, None) ->
260
          Printf.sprintf (f_ "Field '%s' is not set") nm
261
      | No_printer nm ->
262
          Printf.sprintf (f_ "No default printer for value %s") nm
263
      | Unknown_field (nm, schm) ->
264
          Printf.sprintf (f_ "Field %s is not defined in schema %s") nm schm
265
      | e ->
266
          raise e
267
  
324

  
325
  let () =
326
    Printexc.register_printer
327
      (function
328
         | Not_set (nm, Some rsn) ->
329
             Some 
330
               (Printf.sprintf (f_ "Field '%s' is not set: %s") nm rsn)
331
         | Not_set (nm, None) ->
332
             Some 
333
               (Printf.sprintf (f_ "Field '%s' is not set") nm)
334
         | No_printer nm ->
335
             Some
336
               (Printf.sprintf (f_ "No default printer for value %s") nm)
337
         | Unknown_field (nm, schm) ->
338
             Some 
339
               (Printf.sprintf (f_ "Field %s is not defined in schema %s") nm schm)
340
         | _ ->
341
             None)
342

  
268 343
  module Data =
269 344
  struct
270
  
271
    type t = 
345

  
346
    type t =
272 347
        (name, unit -> unit) Hashtbl.t
273
  
348

  
274 349
    let create () =
275 350
      Hashtbl.create 13
276
  
351

  
277 352
    let clear t =
278 353
      Hashtbl.clear t
279
  
280
# 59 "/build/buildd/oasis-0.2.0/src/oasis/PropList.ml"
354

  
355
(* # 71 "/build/buildd/oasis-0.3.0/src/oasis/PropList.ml" *)
281 356
  end
282
  
283
  module Schema = 
357

  
358
  module Schema =
284 359
  struct
285
  
360

  
286 361
    type ('ctxt, 'extra) value =
287 362
        {
288 363
          get:   Data.t -> string;
......
290 365
          help:  (unit -> string) option;
291 366
          extra: 'extra;
292 367
        }
293
  
368

  
294 369
    type ('ctxt, 'extra) t =
295 370
        {
296 371
          name:      name;
......
298 373
          order:     name Queue.t;
299 374
          name_norm: string -> string;
300 375
        }
301
  
302
    let create ?(case_insensitive=false) nm = 
376

  
377
    let create ?(case_insensitive=false) nm =
303 378
      {
304 379
        name      = nm;
305 380
        fields    = Hashtbl.create 13;
306 381
        order     = Queue.create ();
307
        name_norm = 
308
          (if case_insensitive then 
382
        name_norm =
383
          (if case_insensitive then
309 384
             String.lowercase
310 385
           else
311 386
             fun s -> s);
312 387
      }
313
  
314
    let add t nm set get extra help = 
315
      let key = 
388

  
389
    let add t nm set get extra help =
390
      let key =
316 391
        t.name_norm nm
317 392
      in
318
  
393

  
319 394
        if Hashtbl.mem t.fields key then
320 395
          failwith
321
            (Printf.sprintf 
396
            (Printf.sprintf
322 397
               (f_ "Field '%s' is already defined in schema '%s'")
323 398
               nm t.name);
324
        Hashtbl.add 
325
          t.fields 
326
          key 
399
        Hashtbl.add
400
          t.fields
401
          key
327 402
          {
328
            set   = set; 
329
            get   = get; 
403
            set   = set;
404
            get   = get;
330 405
            help  = help;
331 406
            extra = extra;
332 407
          };
333
        Queue.add nm t.order 
334
  
408
        Queue.add nm t.order
409

  
335 410
    let mem t nm =
336
      Hashtbl.mem t.fields nm 
337
  
338
    let find t nm = 
411
      Hashtbl.mem t.fields nm
412

  
413
    let find t nm =
339 414
      try
340 415
        Hashtbl.find t.fields (t.name_norm nm)
341 416
      with Not_found ->
342 417
        raise (Unknown_field (nm, t.name))
343
  
418

  
344 419
    let get t data nm =
345 420
      (find t nm).get data
346
  
421

  
347 422
    let set t data nm ?context x =
348
      (find t nm).set 
349
        data 
350
        ?context 
423
      (find t nm).set
424
        data
425
        ?context
351 426
        x
352
  
427

  
353 428
    let fold f acc t =
354
      Queue.fold 
429
      Queue.fold
355 430
        (fun acc k ->
356 431
           let v =
357 432
             find t k
358 433
           in
359 434
             f acc k v.extra v.help)
360
        acc 
435
        acc
361 436
        t.order
362
  
437

  
363 438
    let iter f t =
364
      fold 
439
      fold
365 440
        (fun () -> f)
366 441
        ()
367 442
        t
368
  
369
    let name t = 
443

  
444
    let name t =
370 445
      t.name
371 446
  end
372
  
447

  
373 448
  module Field =
374 449
  struct
375
  
450

  
376 451
    type ('ctxt, 'value, 'extra) t =
377 452
        {
378 453
          set:    Data.t -> ?context:'ctxt -> 'value -> unit;
......
382 457
          help:   (unit -> string) option;
383 458
          extra:  'extra;
384 459
        }
385
  
386
    let new_id = 
460

  
461
    let new_id =
387 462
      let last_id =
388 463
        ref 0
389 464
      in
390 465
        fun () -> incr last_id; !last_id
391
  
466

  
392 467
    let create ?schema ?name ?parse ?print ?default ?update ?help extra =
393 468
      (* Default value container *)
394
      let v = 
395
        ref None 
469
      let v =
470
        ref None
396 471
      in
397
  
472

  
398 473
      (* If name is not given, create unique one *)
399
      let nm = 
400
        match name with 
474
      let nm =
475
        match name with
401 476
          | Some s -> s
402 477
          | None -> Printf.sprintf "_anon_%d" (new_id ())
403 478
      in
404
  
479

  
405 480
      (* Last chance to get a value: the default *)
406
      let default () = 
407
        match default with 
481
      let default () =
482
        match default with
408 483
          | Some d -> d
409 484
          | None -> raise (Not_set (nm, Some (s_ "no default value")))
410 485
      in
411
  
486

  
412 487
      (* Get data *)
413 488
      let get data =
414 489
        (* Get value *)
415
        try 
490
        try
416 491
          (Hashtbl.find data nm) ();
417
          match !v with 
418
            | Some x -> x 
492
          match !v with
493
            | Some x -> x
419 494
            | None -> default ()
420 495
        with Not_found ->
421 496
          default ()
422 497
      in
423
  
498

  
424 499
      (* Set data *)
425
      let set data ?context x = 
426
        let x = 
427
          match update with 
500
      let set data ?context x =
501
        let x =
502
          match update with
428 503
            | Some f ->
429 504
                begin
430
                  try 
505
                  try
431 506
                    f ?context (get data) x
432 507
                  with Not_set _ ->
433 508
                    x
......
435 510
            | None ->
436 511
                x
437 512
        in
438
          Hashtbl.replace 
439
            data 
440
            nm 
441
            (fun () -> v := Some x) 
513
          Hashtbl.replace
514
            data
515
            nm
516
            (fun () -> v := Some x)
442 517
      in
443
  
518

  
444 519
      (* Parse string value, if possible *)
445 520
      let parse =
446
        match parse with 
447
          | Some f -> 
521
        match parse with
522
          | Some f ->
448 523
              f
449 524
          | None ->
450 525
              fun ?context s ->
451
                failwith 
452
                  (Printf.sprintf 
526
                failwith
527
                  (Printf.sprintf
453 528
                     (f_ "Cannot parse field '%s' when setting value %S")
454 529
                     nm
455 530
                     s)
456 531
      in
457
  
532

  
458 533
      (* Set data, from string *)
459 534
      let sets data ?context s =
460 535
        set ?context data (parse ?context s)
461 536
      in
462
  
537

  
463 538
      (* Output value as string, if possible *)
464 539
      let print =
465 540
        match print with
......
468 543
          | None ->
469 544
              fun _ -> raise (No_printer nm)
470 545
      in
471
  
546

  
472 547
      (* Get data, as a string *)
473 548
      let gets data =
474 549
        print (get data)
475 550
      in
476
  
477
        begin 
478
          match schema with 
551

  
552
        begin
553
          match schema with
479 554
            | Some t ->
480 555
                Schema.add t nm sets gets extra help
481 556
            | None ->
482 557
                ()
483 558
        end;
484
  
559

  
485 560
        {
486 561
          set   = set;
487 562
          get   = get;
......
490 565
          help  = help;
491 566
          extra = extra;
492 567
        }
493
  
494
    let fset data t ?context x = 
568

  
569
    let fset data t ?context x =
495 570
      t.set data ?context x
496
  
571

  
497 572
    let fget data t =
498 573
      t.get data
499
  
574

  
... This diff was truncated because it exceeds the maximum size that can be displayed.

Also available in: Unified diff