compute.ml 7.23 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
    | Var (origloc, vname) ->
64
65
66
67
68
69
70
71
72
      if vname = "`nil" then
	let nil_atom = Atoms.V.mk_ascii "nil" in
        env, l, { exp_loc=loc; exp_typ=(Types.atom (Atoms.atom nil_atom)); exp_descr=(Cst (Atom nil_atom)) }
      else
	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
	let index = (try Locals.find vname l with Not_found -> Printf.eprintf
	  "File %s, line %d, characters %d-%d:\nUnbound identifier %s\n"
73
          (Loc.file_name origloc) line cbegin cend vname; raise Error) in
74
	env, l, { exp_loc=loc; exp_typ=empty; exp_descr=Var(index, vname) }
75
    | Int (_, i) ->
76
      let i = big_int_of_int i in
77
78
      env, l, { exp_loc=loc; exp_typ=(type_of_string "Int");
		exp_descr=Cst(Integer i) }
79
    | String (_, s) ->
80
      let s = String (0, (String.length s) - 1, s,
81
			    Integer (big_int_of_int 0)) in
82
83
      env, l, { exp_loc=loc; exp_typ=(type_of_string "String");
		exp_descr=Cst s }
84

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

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

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

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

129
and parse_branches env l toptype brs res = match brs with
130
  | (loc, p, e) :: rest ->
131
    let brloc = caml_loc_to_cduce loc in
132
133
    let t, d, list, br_locals, br_used =
      parse_match_value env l [] p toptype in
134
135
136
137
    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
138
139
140
141
142
    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"
143
144
	     fname line cbegin cend; make_patterns t [] d)
       else make_patterns t list d) in
145
    let b = { br_loc=brloc; br_used=br_used; br_ghost=false; br_vars_empty=[];
146
	      br_pat=node; br_body=br_body} in
147
    parse_branches env l toptype rest (res @ [b])
148
  | [] -> res
149

150
and make_patterns t fv d = incr Patterns.counter;
151
  { Patterns.id=(!Patterns.counter);
152
    Patterns.descr=(t, fv, d);
153
    Patterns.accept=(cons t); fv=fv }
154

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

183
let to_typed expr =
184
  let env, l, expr = _to_typed empty_toplevel Locals.empty expr in
185
  env, expr