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:

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

  
500 575
    let fsets data t ?context s =
501 576
      t.sets data ?context s
502
  
577

  
503 578
    let fgets data t =
504
      t.gets data 
505
  
579
      t.gets data
580

  
506 581
  end
507
  
582

  
508 583
  module FieldRO =
509 584
  struct
510
  
585

  
511 586
    let create ?schema ?name ?parse ?print ?default ?update ?help extra =
512
      let fld = 
587
      let fld =
513 588
        Field.create ?schema ?name ?parse ?print ?default ?update ?help extra
514 589
      in
515 590
        fun data -> Field.fget data fld
516
  
591

  
517 592
  end
518 593
end
519 594

  
520 595
module OASISMessage = struct
521
# 21 "/build/buildd/oasis-0.2.0/src/oasis/OASISMessage.ml"
522
  
523
  
596
(* # 21 "/build/buildd/oasis-0.3.0/src/oasis/OASISMessage.ml" *)
597

  
598

  
524 599
  open OASISGettext
525 600
  open OASISContext
526
  
601

  
527 602
  let generic_message ~ctxt lvl fmt =
528
    let cond = 
529
      match lvl with 
530
        | `Debug -> ctxt.debug
531
        | _ -> ctxt.verbose
603
    let cond =
604
      if ctxt.quiet then
605
        false
606
      else
607
        match lvl with
608
          | `Debug -> ctxt.debug
609
          | `Info  -> ctxt.info
610
          | _ -> true
532 611
    in
533
      Printf.ksprintf 
534
        (fun str -> 
612
      Printf.ksprintf
613
        (fun str ->
535 614
           if cond then
536 615
             begin
537 616
               ctxt.printf lvl str
538 617
             end)
539 618
        fmt
540
  
619

  
541 620
  let debug ~ctxt fmt =
542 621
    generic_message ~ctxt `Debug fmt
543
  
544
  let info ~ctxt fmt = 
622

  
623
  let info ~ctxt fmt =
545 624
    generic_message ~ctxt `Info fmt
546
  
625

  
547 626
  let warning ~ctxt fmt =
548 627
    generic_message ~ctxt `Warning fmt
549
  
628

  
550 629
  let error ~ctxt fmt =
551 630
    generic_message ~ctxt `Error fmt
552
  
553
  
554
  let string_of_exception e = 
555
    try 
556
      PropList.string_of_exception e
557
    with 
558
      | Failure s ->
559
          s
560
      | e ->
561
          Printexc.to_string e
562
  
563
  (* TODO
564
  let register_exn_printer f =
565
   *)
566
  
631

  
567 632
end
568 633

  
569 634
module OASISVersion = struct
570
# 21 "/build/buildd/oasis-0.2.0/src/oasis/OASISVersion.ml"
571
  
635
(* # 21 "/build/buildd/oasis-0.3.0/src/oasis/OASISVersion.ml" *)
636

  
572 637
  open OASISGettext
573
  
574
  
575
  
638

  
639

  
640

  
576 641
  type s = string
577
  
642

  
578 643
  type t = string 
579
  
580
  type comparator = 
644

  
645
  type comparator =
581 646
    | VGreater of t
582 647
    | VGreaterEqual of t
583 648
    | VEqual of t
......
586 651
    | VOr of  comparator * comparator
587 652
    | VAnd of comparator * comparator
588 653
    
589
  
654

  
590 655
  (* Range of allowed characters *)
591 656
  let is_digit c =
592 657
    '0' <= c && c <= '9'
593
  
658

  
594 659
  let is_alpha c =
595 660
    ('a' <= c && c <= 'z') || ('A' <= c && c <= 'Z')
596
  
661

  
597 662
  let is_special =
598
    function 
663
    function
599 664
      | '.' | '+' | '-' | '~' -> true
600 665
      | _ -> false
601
  
666

  
602 667
  let rec version_compare v1 v2 =
603 668
    if v1 <> "" || v2 <> "" then
604 669
      begin
605
        (* Compare ascii string, using special meaning for version 
670
        (* Compare ascii string, using special meaning for version
606 671
         * related char
607 672
         *)
608
        let val_ascii c = 
673
        let val_ascii c =
609 674
          if c = '~' then -1
610 675
          else if is_digit c then 0
611 676
          else if c = '\000' then 0
612 677
          else if is_alpha c then Char.code c
613 678
          else (Char.code c) + 256
614 679
        in
615
  
680

  
616 681
        let len1 = String.length v1 in
617 682
        let len2 = String.length v2 in
618
  
683

  
619 684
        let p = ref 0 in
620
  
685

  
621 686
        (** Compare ascii part *)
622
        let compare_vascii () = 
687
        let compare_vascii () =
623 688
          let cmp = ref 0 in
624
          while !cmp = 0 && 
625
                !p < len1 && !p < len2 && 
626
                not (is_digit v1.[!p] && is_digit v2.[!p]) do 
689
          while !cmp = 0 &&
690
                !p < len1 && !p < len2 &&
691
                not (is_digit v1.[!p] && is_digit v2.[!p]) do
627 692
            cmp := (val_ascii v1.[!p]) - (val_ascii v2.[!p]);
628 693
            incr p
629 694
          done;
630 695
          if !cmp = 0 && !p < len1 && !p = len2 then
631
            val_ascii v1.[!p] 
696
            val_ascii v1.[!p]
632 697
          else if !cmp = 0 && !p = len1 && !p < len2 then
633 698
            - (val_ascii v2.[!p])
634 699
          else
635 700
            !cmp
636 701
        in
637
  
702

  
638 703
        (** Compare digit part *)
639
        let compare_digit () = 
704
        let compare_digit () =
640 705
          let extract_int v p =
641 706
            let start_p = !p in
642
              while !p < String.length v && is_digit v.[!p] do 
707
              while !p < String.length v && is_digit v.[!p] do
643 708
                incr p
644 709
              done;
645
              match String.sub v start_p (!p - start_p) with 
646
                | "" -> 0, 
647
                        v
648
                | s -> int_of_string s, 
649
                       String.sub v !p ((String.length v) - !p)
710
              let substr = 
711
                String.sub v !p ((String.length v) - !p)
712
              in 
713
              let res = 
714
                match String.sub v start_p (!p - start_p) with 
715
                  | "" -> 0
716
                  | s -> int_of_string s
717
              in
718
                res, substr
650 719
          in
651 720
          let i1, tl1 = extract_int v1 (ref !p) in
652 721
          let i2, tl2 = extract_int v2 (ref !p) in
653 722
            i1 - i2, tl1, tl2
654 723
        in
655
  
724

  
656 725
          match compare_vascii () with
657 726
            | 0 ->
658 727
                begin
659
                  match compare_digit () with 
728
                  match compare_digit () with
660 729
                    | 0, tl1, tl2 ->
661 730
                        if tl1 <> "" && is_digit tl1.[0] then
662 731
                          1
......
674 743
      begin
675 744
        0
676 745
      end
677
  
678
  
679
  let version_of_string str =
680
    String.iter 
681
      (fun c ->
682
         if is_alpha c || is_digit c || is_special c then
683
           ()
684
         else
685
           failwith
686
             (Printf.sprintf 
687
                (f_ "Char %C is not allowed in version '%s'")
688
                c str))
689
      str;
690
    str
691
  
692
  let string_of_version t =
693
    t
694
  
695
  let chop t = 
696
    try 
697
      let pos = 
698
        String.rindex t '.' 
746

  
747

  
748
  let version_of_string str = str
749

  
750
  let string_of_version t = t
751

  
752
  let chop t =
753
    try
754
      let pos =
755
        String.rindex t '.'
699 756
      in
700 757
        String.sub t 0 pos
701 758
    with Not_found ->
702 759
      t
703
  
760

  
704 761
  let rec comparator_apply v op =
705 762
    match op with
706 763
      | VGreater cv ->
......
717 774
          (comparator_apply v op1) || (comparator_apply v op2)
718 775
      | VAnd (op1, op2) ->
719 776
          (comparator_apply v op1) && (comparator_apply v op2)
720
  
777

  
721 778
  let rec string_of_comparator =
722
    function 
779
    function
723 780
      | VGreater v  -> "> "^(string_of_version v)
724 781
      | VEqual v    -> "= "^(string_of_version v)
725 782
      | VLesser v   -> "< "^(string_of_version v)
726 783
      | VGreaterEqual v -> ">= "^(string_of_version v)
727 784
      | VLesserEqual v  -> "<= "^(string_of_version v)
728
      | VOr (c1, c2)  -> 
785
      | VOr (c1, c2)  ->
729 786
          (string_of_comparator c1)^" || "^(string_of_comparator c2)
730
      | VAnd (c1, c2) -> 
787
      | VAnd (c1, c2) ->
731 788
          (string_of_comparator c1)^" && "^(string_of_comparator c2)
732
  
789

  
733 790
  let rec varname_of_comparator =
734
    let concat p v = 
791
    let concat p v =
735 792
      OASISUtils.varname_concat
736
        p 
737
        (OASISUtils.varname_of_string 
793
        p
794
        (OASISUtils.varname_of_string
738 795
           (string_of_version v))
739 796
    in
740
      function 
797
      function
741 798
        | VGreater v -> concat "gt" v
742 799
        | VLesser v  -> concat "lt" v
743 800
        | VEqual v   -> concat "eq" v
......
747 804
            (varname_of_comparator c1)^"_or_"^(varname_of_comparator c2)
748 805
        | VAnd (c1, c2) ->
749 806
            (varname_of_comparator c1)^"_and_"^(varname_of_comparator c2)
750
  
807

  
808
  let version_0_3_or_after t =
809
    comparator_apply t (VGreaterEqual (string_of_version "0.3"))
810

  
751 811
end
752 812

  
753 813
module OASISLicense = struct
754
# 21 "/build/buildd/oasis-0.2.0/src/oasis/OASISLicense.ml"
755
  
814
(* # 21 "/build/buildd/oasis-0.3.0/src/oasis/OASISLicense.ml" *)
815

  
756 816
  (** License for _oasis fields
757 817
      @author Sylvain Le Gall
758 818
    *)
759
  
760
  
761
  
819

  
820

  
821

  
762 822
  type license = string 
763
  
823

  
764 824
  type license_exception = string 
765
  
766
  type license_version = 
825

  
826
  type license_version =
767 827
    | Version of OASISVersion.t
768 828
    | VersionOrLater of OASISVersion.t
769 829
    | NoVersion
770 830
    
771
  
772
  type license_dep_5 = 
773
      {
774
        license:    license;
775
        exceptions: license_exception list;
776
        version:    license_version;
777
      } 
778
  
831

  
832
  type license_dep_5_unit =
833
    {
834
      license:   license;
835
      excption:  license_exception option;
836
      version:   license_version;
837
    }
838
    
839

  
840
  type license_dep_5 =
841
    | DEP5Unit of license_dep_5_unit
842
    | DEP5Or of license_dep_5 list
843
    | DEP5And of license_dep_5 list
844
    
845

  
779 846
  type t =
780 847
    | DEP5License of license_dep_5
781 848
    | OtherLicense of string (* URL *)
782 849
    
783
  
850

  
784 851
end
785 852

  
786 853
module OASISExpr = struct
787
# 21 "/build/buildd/oasis-0.2.0/src/oasis/OASISExpr.ml"
788
  
789
  
790
  
854
(* # 21 "/build/buildd/oasis-0.3.0/src/oasis/OASISExpr.ml" *)
855

  
856

  
857

  
791 858
  open OASISGettext
792
  
859

  
793 860
  type test = string 
794
  
861

  
795 862
  type flag = string 
796
  
863

  
797 864
  type t =
798 865
    | EBool of bool
799 866
    | ENot of t
......
802 869
    | EFlag of flag
803 870
    | ETest of test * string
804 871
    
805
  
872

  
806 873
  type 'a choices = (t * 'a) list 
807
  
874

  
808 875
  let eval var_get t =
809
    let rec eval' = 
876
    let rec eval' =
810 877
      function
811 878
        | EBool b ->
812 879
            b
813
  
814
        | ENot e -> 
880

  
881
        | ENot e ->
815 882
            not (eval' e)
816
  
883

  
817 884
        | EAnd (e1, e2) ->
818 885
            (eval' e1) && (eval' e2)
819
  
820
        | EOr (e1, e2) -> 
886

  
887
        | EOr (e1, e2) ->
821 888
            (eval' e1) || (eval' e2)
822
  
889

  
823 890
        | EFlag nm ->
824 891
            let v =
825 892
              var_get nm
826 893
            in
827 894
              assert(v = "true" || v = "false");
828 895
              (v = "true")
829
  
896

  
830 897
        | ETest (nm, vl) ->
831 898
            let v =
832 899
              var_get nm
......
834 901
              (v = vl)
835 902
    in
836 903
      eval' t
837
  
904

  
838 905
  let choose ?printer ?name var_get lst =
839
    let rec choose_aux = 
906
    let rec choose_aux =
840 907
      function
841 908
        | (cond, vl) :: tl ->
842
            if eval var_get cond then 
843
              vl 
909
            if eval var_get cond then
910
              vl
844 911
            else
845 912
              choose_aux tl
846 913
        | [] ->
847
            let str_lst = 
914
            let str_lst =
848 915
              if lst = [] then
849 916
                s_ "<empty>"
850 917
              else
851
                String.concat 
918
                String.concat
852 919
                  (s_ ", ")
853 920
                  (List.map
854 921
                     (fun (cond, vl) ->
......
857 924
                          | None -> s_ "<no printer>")
858 925
                     lst)
859 926
            in
860
              match name with 
927
              match name with
861 928
                | Some nm ->
862 929
                    failwith
863
                      (Printf.sprintf 
930
                      (Printf.sprintf
864 931
                         (f_ "No result for the choice list '%s': %s")
865 932
                         nm str_lst)
866 933
                | None ->
......
870 937
                         str_lst)
871 938
    in
872 939
      choose_aux (List.rev lst)
873
  
940

  
874 941
end
875 942

  
876 943
module OASISTypes = struct
877
# 21 "/build/buildd/oasis-0.2.0/src/oasis/OASISTypes.ml"
878
  
879
  
880
  
881
  
944
(* # 21 "/build/buildd/oasis-0.3.0/src/oasis/OASISTypes.ml" *)
945

  
946

  
947

  
948

  
882 949
  type name          = string 
883 950
  type package_name  = string 
884 951
  type url           = string 
......
890 957
  type arg           = string 
891 958
  type args          = string list 
892 959
  type command_line  = (prog * arg list) 
893
  
960

  
894 961
  type findlib_name = string 
895 962
  type findlib_full = string 
896
  
963

  
897 964
  type compiled_object =
898 965
    | Byte
899 966
    | Native
900 967
    | Best
901 968
    
902
  
903
  type dependency = 
969

  
970
  type dependency =
904 971
    | FindlibPackage of findlib_full * OASISVersion.comparator option
905 972
    | InternalLibrary of name
906 973
    
907
  
974

  
908 975
  type tool =
909 976
    | ExternalTool of name
910
    | InternalExecutable of name 
977
    | InternalExecutable of name
911 978
    
912
  
913
  type vcs = 
914
    | Darcs 
915
    | Git 
916
    | Svn 
917
    | Cvs 
918
    | Hg 
919
    | Bzr 
920
    | Arch 
979

  
980
  type vcs =
981
    | Darcs
982
    | Git
983
    | Svn
984
    | Cvs
985
    | Hg
986
    | Bzr
987
    | Arch
921 988
    | Monotone
922 989
    | OtherVCS of url
923 990
    
924
  
925
  type plugin_kind = 
926
      [  `Configure 
927
       | `Build 
928
       | `Doc 
929
       | `Test 
930
       | `Install 
991

  
992
  type plugin_kind =
993
      [  `Configure
994
       | `Build
995
       | `Doc
996
       | `Test
997
       | `Install
931 998
       | `Extra
932 999
      ]
933
  
1000

  
934 1001
  type plugin_data_purpose =
935 1002
      [  `Configure
936 1003
       | `Build
......
944 1011
       | `Extra
945 1012
       | `Other of string
946 1013
      ]
947
  
1014

  
948 1015
  type 'a plugin = 'a * name * OASISVersion.t option 
949
  
950
  type all_plugin = plugin_kind plugin 
951
  
1016

  
1017
  type all_plugin = plugin_kind plugin
1018

  
952 1019
  type plugin_data = (all_plugin * plugin_data_purpose * (unit -> unit)) list
953
  
954
# 102 "/build/buildd/oasis-0.2.0/src/oasis/OASISTypes.ml"
955
  
1020

  
1021
(* # 102 "/build/buildd/oasis-0.3.0/src/oasis/OASISTypes.ml" *)
1022

  
956 1023
  type 'a conditional = 'a OASISExpr.choices 
957
  
958
  type custom = 
1024

  
1025
  type custom =
959 1026
      {
960 1027
        pre_command:  (command_line option) conditional;
961
        post_command: (command_line option) conditional; 
1028
        post_command: (command_line option) conditional;
962 1029
      }
963 1030
      
964
  
1031

  
965 1032
  type common_section =
966 1033
      {
967 1034
        cs_name: name;
......
969 1036
        cs_plugin_data: plugin_data;
970 1037
      }
971 1038
      
972
  
1039

  
973 1040
  type build_section =
974 1041
      {
975 1042
        bs_build:           bool conditional;
......
988 1055
        bs_nativeopt:       args conditional;
989 1056
      }
990 1057
      
991
  
992
  type library = 
1058

  
1059
  type library =
993 1060
      {
994 1061
        lib_modules:            string list;
1062
        lib_pack:               bool;
995 1063
        lib_internal_modules:   string list;
996 1064
        lib_findlib_parent:     findlib_name option;
997 1065
        lib_findlib_name:       findlib_name option;
998 1066
        lib_findlib_containers: findlib_name list;
999 1067
      } 
1000
  
1001
  type executable = 
1068

  
1069
  type executable =
1002 1070
      {
1003 1071
        exec_custom:          bool;
1004 1072
        exec_main_is:         unix_filename;
1005 1073
      } 
1006
  
1007
  type flag = 
1074

  
1075
  type flag =
1008 1076
      {
... This diff was truncated because it exceeds the maximum size that can be displayed.

Also available in: Unified diff