compute.ml 7.11 KB
Newer Older
1
2
open Parse
open Typed
3
open Compile
4
open Camlp4.PreCast
5
6
open Types
open Big_int
7

8
(* Gives a unique id for a name *)
9
10
module Locals = Map.Make(String)

11
(* To throw in case of an unbound name *)
12
13
exception Error

14
15
let type_of_string s = match s with
  | "Int" -> interval [Intervals.Any]
16
  | "String" -> Sequence.string
17
18
  | "Char" -> char Chars.any
  | _ -> empty
19

20
21
let rec type_of_ptype arg = match arg with
  | Type(t) -> type_of_string t
22
  | PType(t) -> any (* TODO: Check this solution *)
23
24
  | TPair(t1, t2) -> times (cons (type_of_ptype t1)) (cons (type_of_ptype t2))
  | TArrow(t1, t2) -> arrow (cons (type_of_ptype t1)) (cons (type_of_ptype t2))
Julien Lopez's avatar
Julien Lopez committed
25
  | TSeq(t) -> Sequence.star (type_of_ptype t)
26

27
28
29
30
31
32
33
34
35
36
37
38
39
let rec type_of_iface iface rtype =
  let rec _type_of_iface iface rtype res =
  match iface with
  | (_, pname, ptype) :: rest -> _type_of_iface rest rtype
    (arrow (cons res) (cons (type_of_ptype ptype)))
  | [] -> arrow (cons res) (cons rtype)
  in
  match iface with
  | (_, pname, ptype) :: [] -> arrow (cons (type_of_ptype ptype)) (cons rtype)
  | (_, pname, ptype) :: (_, pname2, ptype2) :: rest ->
    let res = type_of_ptype ptype2 in
    arrow (cons (type_of_ptype ptype)) (cons (_type_of_iface rest rtype res))
  | [] -> assert false
40

41
let rec _to_typed env l expr =
42
43
  (* From Camlp4 locations to CDuce locations *)
  let loc = caml_loc_to_cduce (get_loc expr) in
44
  match expr with
45
    | Parse.Apply (_, e1, e2) ->
46
47
      let _, _, e1 = _to_typed env l e1 in
      let _, _, e2 = _to_typed env l e2 in
48
49
      env, l, { exp_loc=loc; exp_typ=empty; exp_descr=Apply(e1, e2) }
    | Abstr (_, fun_name, params, rtype, body) ->
50
      parse_abstr env l [] loc (Some(0, fun_name)) params rtype body
51
52
    | Match (_, e, t, b) ->
      let b = parse_branches env l t b [] in
53
      let t = type_of_ptype t in
54
      let brs = { br_typ=t; br_accept=t; br_branches=b } in
55
      let _, _, exp_descr = _to_typed env l e in
56
      env, l, { exp_loc=loc; exp_typ=t;
57
		exp_descr=Match(exp_descr, brs) }
58
    | Pair (_, e1, e2) ->
59
60
      let _, _, exp_descr1 = _to_typed env l e1 in
      let _, _, exp_descr2 = _to_typed env l e2 in
61
      env, l, { exp_loc=loc; exp_typ=empty;
62
		exp_descr=Pair(exp_descr1, exp_descr2) }
63
64
65
66
    | Var (origloc, vname) ->
      let line = Loc.start_line origloc in
      let cbegin = Loc.start_off origloc - Loc.start_bol origloc in
      let cend = Loc.stop_off origloc - Loc.start_bol origloc in
67
68
      let index = (try Locals.find vname l with Not_found ->
	Printf.eprintf "File %s, line %d, characters %d-%d:\nUnbound identifier %s\n"
69
          (Loc.file_name origloc) line cbegin cend vname; raise Error) in
70
      env, l, { exp_loc=loc; exp_typ=empty; exp_descr=Var(index, vname) }
71
    | Int (_, i) ->
72
      let i = Big_int.big_int_of_int i in
73
74
      env, l, { exp_loc=loc; exp_typ=(type_of_string "Int");
		exp_descr=Cst(Integer i) }
75
    | String (_, s) ->
76
77
78
79
      let s = String (0, (String.length s) - 1, s,
			    Integer (Big_int.big_int_of_int 0)) in
      env, l, { exp_loc=loc; exp_typ=(type_of_string "String");
		exp_descr=Cst s }
80

81
82
and parse_abstr env l fv loc fun_name params rtype body =
  let rec _parse_abstr env l oldfv loc fun_name params rtype body nb =
83
    let brloc = caml_loc_to_cduce (get_loc body) in
84
    let empty, env, l, fv, iface, rest =
85
      parse_iface env l params [] nb [] rtype in
86
    let fun_typ = type_of_iface params rtype in
87
    let node = make_node fv in
88
89
90
    let l = (match fun_name with
      | None -> l
      | Some (id, name) -> Locals.add name id l) in
91
92
    let env, l, body = if empty
      then let _, _, body = _to_typed env l body in env, l, body
93
94
      else let env, l, body = _parse_abstr env l (oldfv @ fv) loc None rest
	     rtype body (nb + 1) in env, l, body
95
    in
96
97
    let b = { br_loc=brloc; br_used=true; br_ghost=false; br_vars_empty=[];
	      br_pat=node; br_body=body } in
98
    let brs = { br_typ=rtype; br_accept=any; br_branches=[b] } in
99
    let abstr = { fun_name=fun_name; fun_iface=iface; fun_body=brs;
100
                  fun_typ=fun_typ; fun_fv=oldfv } in
101
102
    (* TODO: Fix exp_typ *)
    env, l, { exp_loc=loc; exp_typ=any; exp_descr=Abstraction(abstr) }
103
  in
104
  _parse_abstr env l fv loc fun_name params (type_of_ptype rtype) body 0
105

106
107
and make_node fv =
  let d = (match fv with
108
109
110
    | el :: rest -> Patterns.Capture(el)
    | [] -> Patterns.Dummy)
  in
111
  make_patterns any fv d
112

113
114
and parse_iface env l params fv nb iface rtype = match params with
  | (_, pname, ptype) :: [] -> true, env, (Locals.add pname nb l),
115
    (fv @ [nb, pname]), (iface @ [type_of_ptype ptype, rtype]), []
116
  | (_, pname, ptype) :: rest -> false, env, (Locals.add pname nb l),
117
118
    (fv @ [nb, pname]),
    (iface @ [type_of_ptype ptype, type_of_iface rest rtype]), rest
119
  | [] -> true, env, l, fv, iface, []
120

121
122
and itype iface res = match iface with
  | (_, _, t) :: rest -> itype rest
123
    (arrow (cons res) (cons (type_of_ptype t)))
124
125
  | [] -> res

126
and parse_branches env l toptype brs res = match brs with
127
  | (loc, p, e) :: rest ->
128
    let brloc = caml_loc_to_cduce loc in
129
130
    let t, d, list, br_locals, br_used =
      parse_match_value env l [] p toptype in
131
132
133
134
    let line = Loc.start_line loc in
    let cbegin = Loc.start_off loc - Loc.start_bol loc in
    let cend = Loc.stop_off loc - Loc.start_bol loc in
    let _, _, br_body = _to_typed env br_locals e in
135
136
137
138
139
    let fname = Loc.file_name loc in
    let node =
      (if not br_used then
	  (Printf.eprintf
	     "File %s, line %d, characters %d-%d:\nWarning: This branch is not used\n"
140
141
	     fname line cbegin cend; make_patterns t [] d)
       else make_patterns t list d) in
142
    let b = { br_loc=brloc; br_used=br_used; br_ghost=false; br_vars_empty=[];
143
	      br_pat=node; br_body=br_body} in
144
    parse_branches env l toptype rest (res @ [b])
145
  | [] -> res
146

147
and make_patterns t fv d = incr Patterns.counter;
148
  { Patterns.id=(!Patterns.counter);
149
    Patterns.descr=(t, fv, d);
150
    Patterns.accept=(cons t); fv=fv }
151

152
and parse_match_value env l list p toptype = match p with
Julien Lopez's avatar
Julien Lopez committed
153
  | MPair (_, m1, m2) ->
154
    let top1, top2 =
Julien Lopez's avatar
Julien Lopez committed
155
156
      (match toptype with | TPair(t1, t2) -> t1, t2 | TSeq(t) -> t, TSeq(t)
	| _ -> Type("Empty"), Type("Empty")) in
157
158
    let t1, d1, list1, l, b1 = parse_match_value env l list m1 top1 in
    let t2, d2, list2, l, b2 = parse_match_value env l list m2 top2 in
159
    times (cons t1) (cons t2),
160
161
    Patterns.Times (make_patterns t1 list1 d1, make_patterns t2 list2 d2),
    (list1 @ list2), l, b1 && b2;
162
163
  | MVar (_, mname, mtype) ->
    let lsize = Locals.cardinal l in
164
165
    let l = Locals.add mname lsize l in
    let list = list @ [lsize, mname] in
166
    let d1 = any, list, Patterns.Capture(lsize, mname) in
167
    let t2 = type_of_ptype mtype in
168
    let d2 = t2, [], Patterns.Constr(t2) in
169
    t2, Patterns.Cap(d1, d2), list, l, Types.subtype (type_of_ptype toptype) t2
170
171
  | MInt (_, i) ->
    let t = constant (Integer(big_int_of_int i)) in
172
173
    t, Patterns.Constr(t), list, l, Types.subtype (type_of_ptype toptype)
      (type_of_string "Int")
174
175
176
  | MString (_, s) ->
    let t = constant (String(0, String.length s - 1, s,
			     Integer(big_int_of_int 0))) in
177
178
    t, Patterns.Constr(t), list, l, Types.subtype (type_of_ptype toptype)
      (type_of_string "String")
179

180
let to_typed expr =
181
  let env, l, expr = _to_typed empty_toplevel Locals.empty expr in
182
  env, expr