Commit 1deb9afa authored by Pietro Abate's avatar Pietro Abate
Browse files

Remove global open statements to avoid namespace pollution

parent 3597ff2a
open Parse
open Typed
open Compile
open Camlp4.PreCast
open Types
open Big_int
(* Gives a unique id for a name *)
module Locals = Map.Make(String)
......@@ -12,23 +8,23 @@ module Locals = Map.Make(String)
exception Error
let type_of_string s = match s with
| "Int" -> interval [Intervals.Any]
| "Int" -> Types.interval [Intervals.Any]
| "String" -> Sequence.string
| "Char" -> char Chars.any
| _ -> empty
| "Char" -> Types.char Chars.any
| _ -> Types.empty
let rec _to_typed env l expr =
let open Typed in
(* From Camlp4 locations to CDuce locations *)
let loc = caml_loc_to_cduce (get_loc expr) in
match expr with
| Subst (_, e, s) ->
let _, _, e = _to_typed env l e in
env, l, { exp_loc=loc; exp_typ=empty;
exp_descr=(Subst (e, make_sigma s)) }
(env, l, { exp_loc=loc; exp_typ=Types.empty; exp_descr=(Subst (e, make_sigma s)) })
| Apply (_, e1, e2) ->
let _, _, e1 = _to_typed env l e1 in
let _, _, e2 = _to_typed env l e2 in
env, l, { exp_loc=loc; exp_typ=empty; exp_descr=Apply(e1, e2) }
env, l, { exp_loc=loc; exp_typ=Types.empty; exp_descr=Apply(e1, e2) }
| Abstr (_, fun_name, params, rtype, body) ->
parse_abstr env l [] loc (Some(0, fun_name)) params rtype body
| Match (_, e, t, b) ->
......@@ -36,34 +32,31 @@ let rec _to_typed env l expr =
let t = type_of_ptype t in
let brs = { br_typ=t; br_accept=t; br_branches=b } in
let _, _, exp_descr = _to_typed env l e in
env, l, { exp_loc=loc; exp_typ=t;
exp_descr=Match(exp_descr, brs) }
(env, l, { exp_loc=loc; exp_typ=t; exp_descr=Match(exp_descr, brs) })
| Pair (_, e1, e2) ->
let _, _, exp_descr1 = _to_typed env l e1 in
let _, _, exp_descr2 = _to_typed env l e2 in
env, l, { exp_loc=loc; exp_typ=empty;
exp_descr=Pair(exp_descr1, exp_descr2) }
(env, l, { exp_loc=loc; exp_typ=Types.empty; exp_descr=Pair(exp_descr1, exp_descr2) })
| Var (origloc, vname) ->
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)) }
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 (Types.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"
(Loc.file_name origloc) line cbegin cend vname; raise Error) in
env, l, { exp_loc=loc; exp_typ=empty; exp_descr=Var(index, 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
let index = (try Locals.find vname l with Not_found -> Printf.eprintf
"File %s, line %d, characters %d-%d:\nUnbound identifier %s\n"
(Loc.file_name origloc) line cbegin cend vname; raise Error)
in
(env, l, { exp_loc=loc; exp_typ=Types.empty; exp_descr=Var(index, vname) })
| Int (_, i) ->
let i = big_int_of_int i in
env, l, { exp_loc=loc; exp_typ=(type_of_string "Int");
exp_descr=Cst(Integer i) }
let i = Big_int.big_int_of_int i in
(env, l, { exp_loc=loc; exp_typ=(type_of_string "Int"); exp_descr=Cst(Types.Integer i) })
| String (_, s) ->
let s = String (0, (String.length s) - 1, s,
Integer (big_int_of_int 0)) in
env, l, { exp_loc=loc; exp_typ=(type_of_string "String");
exp_descr=Cst s }
let i = Big_int.big_int_of_int 0 in
let s = Types.String (0, (String.length s) - 1, s, Types.Integer i) in
(env, l, { exp_loc=loc; exp_typ=(type_of_string "String"); exp_descr=Cst s })
and make_sigma s =
let rec aux acc = function
......@@ -76,12 +69,13 @@ and make_sigma s =
and type_of_sigma x s =
let rec aux x acc = function
| [] -> acc
| (id, t2) :: rest when id = x -> aux x (cup acc (type_of_ptype t2)) rest
| (id, t2) :: rest when id = x -> aux x (Types.cup acc (type_of_ptype t2)) rest
| _ :: rest -> aux x acc rest
in
aux x empty s
aux x Types.empty s
and type_of_ptype = function
and type_of_ptype =
let open Types in function
| Type(t) -> type_of_string t
| PType(t, s) ->
if s = [] then var (`Var (Var.make_id t)) else type_of_sigma t s
......@@ -93,6 +87,7 @@ and type_of_ptype = function
| TSeq(t) -> Sequence.star (type_of_ptype t)
and type_of_iface iface rtype =
let open Types in
let rec _type_of_iface iface rtype res =
match iface with
| (_, pname, ptype) :: rest -> _type_of_iface rest rtype
......@@ -121,12 +116,12 @@ and parse_abstr env l fv loc fun_name params rtype body =
else let env, l, body = _parse_abstr env l (oldfv @ fv) loc None rest
rtype body (nb + 1) in env, l, body
in
let b = { br_loc=brloc; br_used=true; br_ghost=false; br_vars_empty=[];
let b = { Typed.br_loc=brloc; br_used=true; br_ghost=false; br_vars_empty=[];
br_pat=node; br_body=body } in
let brs = { br_typ=rtype; br_accept=any; br_branches=[b] } in
let abstr = { fun_name=fun_name; fun_iface=iface; fun_body=brs;
let brs = { Typed.br_typ=rtype; br_accept=Types.any; br_branches=[b] } in
let abstr = { Typed.fun_name=fun_name; fun_iface=iface; fun_body=brs;
fun_typ=fun_typ; fun_fv=oldfv } in
env, l, { exp_loc=loc; exp_typ=any; exp_descr=Abstraction(abstr) }
env, l, { Typed.exp_loc=loc; exp_typ=Types.any; exp_descr=Typed.Abstraction(abstr) }
in
_parse_abstr env l fv loc fun_name params (type_of_ptype rtype) body 0
......@@ -135,7 +130,7 @@ and make_node fv =
| el :: rest -> Patterns.Capture(el)
| [] -> Patterns.Dummy)
in
make_patterns any fv d
make_patterns Types.any fv d
and parse_iface env l params fv nb iface rtype = match params with
| (_, pname, ptype) :: [] -> true, env, (Locals.add pname nb l),
......@@ -145,10 +140,10 @@ and parse_iface env l params fv nb iface rtype = match params with
(iface @ [type_of_ptype ptype, type_of_iface rest rtype]), rest
| [] -> true, env, l, fv, iface, []
and itype iface res = match iface with
| (_, _, t) :: rest -> itype rest
(arrow (cons res) (cons (type_of_ptype t)))
| [] -> res
and itype acc =
let open Types in function
| (_, _, t) :: rest -> itype (arrow (cons acc) (cons (type_of_ptype t))) rest
| [] -> acc
and parse_branches env l toptype brs res = match brs with
| (loc, p, e) :: rest ->
......@@ -166,7 +161,7 @@ and parse_branches env l toptype brs res = match brs with
"File %s, line %d, characters %d-%d:\nWarning: This branch is not used\n"
fname line cbegin cend; make_patterns t [] d)
else make_patterns t list d) in
let b = { br_loc=brloc; br_used=br_used; br_ghost=false; br_vars_empty=[];
let b = { Typed.br_loc=brloc; br_used=br_used; br_ghost=false; br_vars_empty=[];
br_pat=node; br_body=br_body} in
parse_branches env l toptype rest (res @ [b])
| [] -> res
......@@ -174,7 +169,7 @@ and parse_branches env l toptype brs res = match brs with
and make_patterns t fv d = incr Patterns.counter;
{ Patterns.id=(!Patterns.counter);
Patterns.descr=(t, fv, d);
Patterns.accept=(cons t); fv=fv }
Patterns.accept=(Types.cons t); fv=fv }
and parse_match_value env l list p toptype = match p with
| MPair (_, m1, m2) ->
......@@ -183,27 +178,27 @@ and parse_match_value env l list p toptype = match p with
| _ -> Type("Empty"), Type("Empty")) in
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
times (cons t1) (cons t2),
Types.times (Types.cons t1) (Types.cons t2),
Patterns.Times (make_patterns t1 list1 d1, make_patterns t2 list2 d2),
(list1 @ list2), l, b1 && b2;
| MVar (_, mname, mtype) ->
let lsize = Locals.cardinal l in
let l = Locals.add mname lsize l in
let list = list @ [lsize, mname] in
let d1 = any, list, Patterns.Capture(lsize, mname) in
let d1 = Types.any, list, Patterns.Capture(lsize, mname) in
let t2 = type_of_ptype mtype in
let d2 = t2, [], Patterns.Constr(t2) in
t2, Patterns.Cap(d1, d2), list, l, Types.subtype t2 (type_of_ptype toptype)
let is_subtype = Types.subtype t2 (type_of_ptype toptype) in
(t2, Patterns.Cap(d1, d2), list, l, is_subtype)
| MInt (_, i) ->
let t = constant (Integer(big_int_of_int i)) in
t, Patterns.Constr(t), list, l, Types.subtype (type_of_string "Int")
(type_of_ptype toptype)
let t = Types.constant (Types.Integer(Big_int.big_int_of_int i)) in
let is_subtype = Types.subtype (type_of_string "Int") (type_of_ptype toptype) in
(t, Patterns.Constr(t), list, l, is_subtype)
| MString (_, s) ->
let t = constant (String(0, String.length s - 1, s,
Integer(big_int_of_int 0))) in
t, Patterns.Constr(t), list, l, Types.subtype (type_of_string "String")
(type_of_ptype toptype)
let t = Types.constant (Types.String(0, String.length s - 1, s, Types.Integer(Big_int.big_int_of_int 0))) in
let is_subtype = Types.subtype (type_of_string "String") (type_of_ptype toptype) in
(t, Patterns.Constr(t), list, l, is_subtype)
let to_typed expr =
let env, l, expr = _to_typed empty_toplevel Locals.empty expr in
let env, l, expr = _to_typed Compile.empty_toplevel Locals.empty expr in
env, expr
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment