Project

General

Profile

Statistics
| Branch: | Tag: | Revision:

lustrec / lib / delay.ml @ 9b0432bc

History | View | Annotate | Download (2.99 KB)

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

    
12
(** Types definitions and a few utility functions on delay types. *)
13
(** Delay analysis by type polymorphism instead of constraints *)
14
open Utils
15

    
16
type delay_expr =
17
    {mutable ddesc: delay_desc;
18
     did: int}
19

    
20
and delay_desc =
21
  | Dvar (* Monomorphic type variable *)
22
  | Dundef
23
  | Darrow of delay_expr * delay_expr
24
  | Dtuple of delay_expr list
25
  | Dlink of delay_expr (* During unification, make links instead of substitutions *)
26
  | Dunivar (* Polymorphic type variable *)
27
[@@deriving show]
28

    
29
type error =
30
  | Delay_clash of delay_expr * delay_expr
31

    
32
exception Unify of delay_expr * delay_expr
33
exception Error of Location.t * error
34

    
35
let new_id = ref (-1)
36

    
37
let new_delay desc =
38
  incr new_id; {ddesc = desc; did = !new_id }
39

    
40
let new_var () =
41
  new_delay Dvar
42

    
43
let new_univar () =
44
  new_delay Dunivar
45

    
46
let rec repr =
47
  function
48
    {ddesc = Dlink i'} ->
49
      repr i'
50
  | i -> i
51

    
52
(** Splits [ty] into the [lhs,rhs] of an arrow type. Expects an arrow type
53
    (ensured by language syntax) *)
54
let split_arrow de =
55
  match (repr de).ddesc with
56
  | Darrow (din,dout) -> din,dout
57
    (* Functions are not first order, I don't think the var case
58
       needs to be considered here *)
59
  | _ -> failwith "Internal error: not an arrow type"
60

    
61
(** Returns the type corresponding to a type list. *)
62
let delay_of_delay_list de =
63
  if (List.length de) > 1 then
64
    new_delay (Dtuple de)
65
  else
66
    List.hd de
67

    
68
(** [is_polymorphic de] returns true if [de] is polymorphic. *)
69
let rec is_polymorphic de =
70
  match de.ddesc with
71
  | Dvar  -> false
72
  | Dundef -> false
73
  | Darrow (de1,de2) -> (is_polymorphic de1) || (is_polymorphic de2)
74
  | Dtuple dl -> List.exists is_polymorphic dl
75
  | Dlink d' -> is_polymorphic d'
76
  | Dunivar -> true
77

    
78
(* Pretty-print*)
79
open Format
80
  
81
let rec print_delay fmt de =
82
  match de.ddesc with
83
  | Dvar ->
84
    fprintf fmt "'_%s" (name_of_type de.did)
85
  | Dundef ->
86
    fprintf fmt "1"
87
  | Darrow (de1,de2) ->
88
    fprintf fmt "%a->%a" print_delay de1 print_delay de2
89
  | Dtuple delist ->
90
    fprintf fmt "(%a)"
91
      (Utils.fprintf_list ~sep:"*" print_delay) delist
92
  | Dlink de ->
93
      print_delay fmt de
94
  | Dunivar ->
95
    fprintf fmt "'%s" (name_of_delay de.did)
96

    
97
let pp_error fmt = function
98
  | Delay_clash (de1,de2) ->
99
      Utils.reset_names ();
100
    fprintf fmt "Expected delay %a, got delay %a@." print_delay de1 print_delay de2