Project

General

Profile

Download (2.96 KB) Statistics
| Branch: | Tag: | Revision:
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
open Utils
13
(** Types definitions and a few utility functions on delay types. Delay analysis
14
    by type polymorphism instead of constraints *)
15

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

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

    
28
type error = Delay_clash of delay_expr * delay_expr
29

    
30
exception Unify of delay_expr * delay_expr
31

    
32
exception Error of Location.t * error
33

    
34
let new_id = ref (-1)
35

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

    
40
let new_var () = new_delay Dvar
41

    
42
let new_univar () = new_delay Dunivar
43

    
44
let rec repr = function { ddesc = Dlink i'; _ } -> repr i' | i -> i
45

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

    
57
(** Returns the type corresponding to a type list. *)
58
let delay_of_delay_list de =
59
  if List.length de > 1 then new_delay (Dtuple de) else List.hd de
60

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

    
77
(* Pretty-print*)
78
open Format
79

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

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