Commit 82b418ed authored by Pietro Abate's avatar Pietro Abate
Browse files

[r2002-10-14 22:05:40 by cvscast] Empty log message

Original author: cvscast
Date: 2002-10-14 22:05:40+00:00
parent 8ff6637d
parser/ast.cmo: parser/location.cmi types/patterns.cmi types/types.cmi
parser/ast.cmx: parser/location.cmx types/patterns.cmx types/types.cmx
parser/ast.cmo: types/patterns.cmi types/types.cmi
parser/ast.cmx: types/patterns.cmx types/types.cmx
parser/location.cmo: parser/location.cmi
parser/location.cmx: parser/location.cmi
parser/parser.cmo: parser/ast.cmo parser/location.cmi types/types.cmi \
......
......@@ -66,7 +66,7 @@ module P = struct
];
arrow: [
[ t1 = pat LEVEL "prod"; "->"; t2 = pat -> (t1,t2)]
[ t1 = pat LEVEL "no_arrow"; "->"; t2 = pat -> (t1,t2)]
];
branches: [
......@@ -130,8 +130,8 @@ module P = struct
mk loc (Record (Types.label l,o,x))
] SEP ";" ->
match r with
| [] -> mk noloc (Internal Types.Record.any)
| h::t -> List.fold_left (fun t1 t2 -> mk noloc (And (t1,t2))) h t
| [] -> mk loc (Internal Types.Record.any)
| h::t -> List.fold_left (fun t1 t2 -> mk loc (And (t1,t2))) h t
] ];
const:
......
......@@ -14,7 +14,7 @@ open Location
type tpat = Patterns.node
type ttyp = Types.node
type texpr = { exp_loc : Location.loc;
type texpr = { exp_loc : loc;
mutable exp_typ : Types.descr;
exp_descr : texpr';
}
......@@ -36,18 +36,21 @@ and texpr' =
and abstr = {
fun_name : string option;
fun_iface : (ttyp * ttyp) list;
fun_iface : (Types.descr * Types.descr) list;
fun_body : branches;
fun_typ : Types.descr;
fun_fv : string list;
}
and branches = branch list
and branch =
{ mutable br_used : bool;
mutable br_typ : Types.descr; (* TODO: move to branches and update *)
br_pat : tpat;
br_body : texpr }
and branches = {
mutable br_typ : Types.descr;
br_branches: branch list
}
and branch = {
mutable br_used : bool;
br_pat : tpat;
br_body : texpr
}
and op = string
......@@ -3,14 +3,17 @@
open Location
open Ast
exception ParsingPattern of string
let raise_loc loc msg = raise (Location loc (ParsingPattern msg))
exception Pattern of string
exception NonExhaustive of Types.descr
exception Constraint of Types.descr * Types.descr * string
let raise_loc loc exn = raise (Location (loc,exn))
(* Internal representation as a graph (desugar recursive types and regexp),
to compute freevars, etc... *)
type ti = {
type ti = {
id : int;
mutable loc' : loc;
mutable fv : string SortedList.t option;
......@@ -19,7 +22,7 @@ type ti = {
mutable pat_node: Patterns.node option
}
and descr =
[ `Alias of ti
[ `Alias of string * ti
| `Type of Types.descr
| `Or of ti * ti
| `And of ti * ti
......@@ -41,8 +44,14 @@ let mk' =
let counter = ref 0 in
fun () ->
incr counter;
let rec x = { id = !counter; loc' = noloc; fv = None; descr' = `Alias x;
type_node = None; pat_node = None } in
let rec x = {
id = !counter;
loc' = noloc;
fv = None;
descr' = `Alias ("__dummy__", x);
type_node = None;
pat_node = None
} in
x
let cons loc d =
......@@ -146,13 +155,16 @@ let rec compile env { loc = loc; descr = d } : ti =
match (d : Ast.ppat') with
| PatVar s ->
(try StringMap.find s env
with Not_found -> raise_loc loc "Undefined variable"
with Not_found ->
raise_loc loc (Pattern ("Undefined type variable " ^ s))
)
| Recurs (t, b) ->
let b = List.map (fun (v,t) -> (v,t,mk' ())) b in
let env =
List.fold_left (fun env (v,t,x) -> StringMap.add v x env) env b in
List.iter (fun (v,t,x) -> x.descr' <- `Alias (compile env t)) b;
List.iter
(fun (v,t,x) -> x.loc' <- t.loc; x.descr' <- `Alias (v, compile env t))
b;
compile env t
| Regexp (r,q) -> compile env (Regexp.compile r q)
| Internal t -> cons loc (`Type t)
......@@ -171,7 +183,7 @@ let rec comp_fv seen s =
| None ->
let l =
match s.descr' with
| `Alias x -> if List.memq s seen then [] else comp_fv (s :: seen) x
| `Alias (_,x) -> if List.memq s seen then [] else comp_fv (s :: seen) x
| `Or (s1,s2)
| `And (s1,s2)
| `Diff (s1,s2)
......@@ -190,8 +202,11 @@ let fv = comp_fv []
let rec typ seen s : Types.descr =
match s.descr' with
| `Alias x ->
if List.memq s seen then failwith "Unguarded recursion in this type"
| `Alias (v,x) ->
if List.memq s seen then
raise_loc s.loc'
(Pattern
("Unguarded recursion on variable " ^ v ^ " in this type"))
else typ (s :: seen) x
| `Type t -> t
| `Or (s1,s2) -> Types.cup (typ seen s1) (typ seen s2)
......@@ -200,7 +215,7 @@ let rec typ seen s : Types.descr =
| `Times (s1,s2) -> Types.times (typ_node s1) (typ_node s2)
| `Arrow (s1,s2) -> Types.arrow (typ_node s1) (typ_node s2)
| `Record (l,o,s) -> Types.record l o (typ_node s)
| _ -> failwith "This is not a type"
| `Capture _ | `Constant _ -> assert false
and typ_node s : Types.node =
match s.type_node with
......@@ -217,19 +232,29 @@ let type_node s = Types.internalize (typ_node s)
let rec pat seen s : Patterns.descr =
if fv s = [] then Patterns.constr (type_node s) else
match s.descr' with
| `Alias x ->
if List.memq s seen then failwith "Unguarded recursion in this pattern"
| `Alias (v,x) ->
if List.memq s seen then
raise_loc s.loc'
(Pattern
("Unguarded recursion on variable " ^ v ^ " in this pattern"))
else pat (s :: seen) x
| `Or (s1,s2) -> Patterns.cup (pat seen s1) (pat seen s2)
| `And (s1,s2) -> Patterns.cap (pat seen s1) (pat seen s2)
| `Diff (s1,s2) when fv s2 = [] ->
let s2 = Types.cons (Types.neg (Types.descr (type_node s2)))in
Patterns.cap (pat seen s1) (Patterns.constr s2)
| `Diff _ ->
raise_loc s.loc' (Pattern "Difference not allowed in patterns")
| `Times (s1,s2) -> Patterns.times (pat_node s1) (pat_node s2)
| `Record (l,false,s) -> Patterns.record l (pat_node s)
| `Record _ ->
raise_loc s.loc'
(Pattern "Optional field not allowed in record patterns")
| `Capture x -> Patterns.capture x
| `Constant (x,c) -> Patterns.constant x c
| _ -> failwith "This is not a pattern"
| `Arrow _ ->
raise_loc s.loc' (Pattern "Arrow not allowed in patterns")
| `Type _ -> assert false
and pat_node s : Patterns.node =
match s.pat_node with
......@@ -243,7 +268,9 @@ and pat_node s : Patterns.node =
let typ e =
let e = compile StringMap.empty e in
if fv e = [] then type_node e else failwith "This is not a type"
if fv e = [] then type_node e
else (raise_loc e.loc'
(Pattern "Capture variables are not allowed in types"))
let pat e =
let e = compile StringMap.empty e in
......@@ -267,6 +294,9 @@ let rec expr { loc = loc; descr = d } =
let t = List.fold_left
(fun accu (t1,t2) -> Types.cap accu (Types.arrow t1 t2))
Types.any iface in
let iface = List.map
(fun (t1,t2) -> (Types.descr t1, Types.descr t2))
iface in
let (fv0,body) = branches a.fun_body in
let fv = match a.fun_name with
| None -> fv0
......@@ -318,11 +348,10 @@ let rec expr { loc = loc; descr = d } =
let (fv2,e) = expr e in
fv := Fv.union !fv fv2;
{ Typed.br_used = false;
Typed.br_typ = Types.empty;
Typed.br_pat = pat p;
Typed.br_body = e }
) b in
(!fv,b)
(!fv, { Typed.br_typ = Types.empty; Typed.br_branches = b } )
module Env = StringMap
......@@ -343,9 +372,9 @@ and compute_type' loc env = function
| None -> env
| Some f -> Env.add f a.fun_typ env in
List.iter (fun (t1,t2) ->
let t = type_branches env (Types.descr t1) a.fun_body in
if not (Types.subtype t (Types.descr t2)) then
failwith "Constraint not satisfied"
let t = type_branches loc env t1 a.fun_body in
if not (Types.subtype t t2) then
raise_loc loc (Constraint (t,t2,"Constraint not satisfied in interface"))
) a.fun_iface;
a.fun_typ
| Cst c -> Types.constant c
......@@ -363,22 +392,25 @@ and compute_type' loc env = function
| Op (op,e) -> assert false
| Match (e,b) ->
let t = compute_type env e in
type_branches env t b
type_branches loc env t b
| Map (e,b) -> assert false
and type_branches env targ branches =
and type_branches loc env targ brs =
if Types.is_empty targ then Types.empty
else branches_aux env targ Types.empty branches
else (
brs.br_typ <- Types.cup brs.br_typ targ;
branches_aux loc env targ Types.empty brs.br_branches
)
and branches_aux env targ tres = function
| [] -> failwith "Non-exhaustive pattern matching"
and branches_aux loc env targ tres = function
| [] -> raise_loc loc (NonExhaustive targ)
| b :: rem ->
let p = b.br_pat in
let acc = Types.descr (Patterns.accept p) in
let targ' = Types.cap targ acc in
if Types.is_empty targ'
then branches_aux env targ tres rem
then branches_aux loc env targ tres rem
else
( b.br_used <- true;
let res = Patterns.filter targ' p in
......@@ -386,7 +418,10 @@ and branches_aux env targ tres = function
(fun env (x,t) -> Env.add x (Types.descr t) env)
env res in
let t = compute_type env' b.br_body in
branches_aux env (Types.diff targ acc) (Types.cup t tres) rem
let tres = Types.cup t tres in
let targ'' = Types.diff targ acc in
if (Types.non_empty targ'') then
branches_aux loc env targ'' (Types.cup t tres) rem
else
tres
)
exception ParsingPattern of string
exception Pattern of string
exception NonExhaustive of Types.descr
exception Constraint of Types.descr * Types.descr * string
val compile_regexp : Ast.regexp -> Ast.ppat -> Ast.ppat
......
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