Commit 48ac778a authored by Pietro Abate's avatar Pietro Abate
Browse files

[r2005-03-06 18:26:47 by afrisch] Concatenation in types

Original author: afrisch
Date: 2005-03-06 18:26:47+00:00
parent 9ed9051b
......@@ -26,6 +26,7 @@ Since 0.2.2
- the ";" between fields is optional even for records
(used to be optional only for attributes)
* Keywords are now allowed as type names
* Concatenatiom @ allowed in types
- Tools:
* A new tool cduce_mktop produces customized CDuce toplevels with embedded
......
......@@ -112,6 +112,7 @@ and ppat' =
| Record of bool * (label * (ppat * ppat option)) list
| Constant of U.t * pexpr
| Regexp of regexp
| Concat of ppat * ppat
and regexp =
| Epsilon
......
......@@ -553,7 +553,8 @@ EXTEND
b = LIST1 [ (la,a) = located_ident; "="; y = pat ->
(la,a,y) ] SEP "and"
-> mk loc (Recurs (x,b)) ]
| RIGHTA [ x = pat; "->"; y = pat -> mk loc (Arrow (x,y)) ]
| RIGHTA [ x = pat; "->"; y = pat -> mk loc (Arrow (x,y))
| x = pat; "@"; y = pat -> mk loc (Concat (x,y)) ]
| "no_arrow" [ x = pat; "|"; y = pat -> mk loc (Or (x,y)) ]
| "simple" [ x = pat; "&"; y = pat -> mk loc (And (x,y))
| x = pat; "\\"; y = pat -> mk loc (Diff (x,y)) ]
......
......@@ -281,6 +281,7 @@ module IType = struct
| IRecord of bool * (node * node option) label_map
| ICapture of id
| IConstant of id * Types.const
| IConcat of node * node
let rec node_temp = {
desc = ILink node_temp;
......@@ -309,6 +310,7 @@ module IType = struct
257*(LabelMap.hash (hash_field f) r)
| ICapture x -> 10 + 17 * (Id.hash x)
| IConstant (x,c) -> 11 + 17 * (Id.hash x) + 257*(Types.Const.hash c)
| IConcat (p1,p2) -> assert false
let hash0 = hash (fun n -> 1)
let hash1 = hash hash0
......@@ -524,6 +526,7 @@ module IType = struct
| IRecord (o,r) -> Types.record' (o, LabelMap.map compute_typ_field r)
| ILink _ -> assert false
| ICapture _ | IConstant (_,_) -> assert false
| IConcat _ -> assert false
and compute_typ_field = function
| (s, None) -> typ_node s
| (s, Some _) ->
......@@ -583,7 +586,7 @@ module IType = struct
| IConstant (x,c) -> Patterns.constant x c
| IArrow _ ->
raise (Patterns.Error "Arrows are not allowed in patterns")
| IType _ | ILink _ -> assert false
| IType _ | ILink _ | IConcat _ -> assert false
and pat_node n =
let n = repr n in
......@@ -606,6 +609,8 @@ module IType = struct
let penv tenv = { penv_tenv = tenv; penv_derec = Env.empty }
let concats = ref []
let mk d = { node_temp with desc = d }
let mk_delayed () = { node_temp with desc = ILink node_temp }
let itype t = mk (IType (t, Types.hash t))
......@@ -760,17 +765,11 @@ module IType = struct
let l = !all_delayed in
all_delayed := [];
List.iter check_one_delayed l
let rec derecurs env p = match p.descr with
| PatVar (cu,v) -> derecurs_var env p.loc cu v
(*
| SchemaVar (kind, schema_name, component_name) ->
let name = qname env.penv_tenv p.loc component_name in
itype (find_schema_descr env.penv_tenv kind schema_name name)
*)
| Recurs (p,b) -> derecurs (derecurs_def env b) p
| Recurs (p,b) -> derecurs (fst (derecurs_def env b)) p
| Internal t -> itype t
| NsT ns ->
itype (Types.atom (Atoms.any_in_ns (parse_ns env.penv_tenv p.loc ns)))
......@@ -792,6 +791,10 @@ module IType = struct
| Regexp r ->
let r,_ = derecurs_regexp IdSet.empty false IdSet.empty true env r in
rexp r
| Concat (p1,p2) ->
let n = mk (IConcat (derecurs env p1, derecurs env p2)) in
concats := n :: !concats;
n
and derecurs_regexp vars b rvars f env = function
(* - vars: seq variables to be propagated top-down and added
......@@ -869,10 +872,74 @@ module IType = struct
List.fold_left (fun env (v,p,s) -> Env.add v s env) env.penv_derec b in
let env = { env with penv_derec = n } in
List.iter (fun (v,p,s) -> s.desc <- ILink (derecurs env p)) b;
env
(env, b)
module H = Hashtbl.Make(Types)
let rec elim_concat n =
match n.desc with
| IConcat (a,b) ->
if (n.sid > 0) then
raise (Patterns.Error "Ill-formed concatenation loop");
n.sid <- 1;
n.desc <- ILink (elim_conc a b)
| _ -> ()
and elim_conc n q =
let mem = ref [] in
let rec aux n =
try List.assq n !mem
with Not_found ->
let r = mk_delayed () in
mem := (n,r) :: !mem;
let rec aux2 n =
let m = match n.desc with
| ILink n' -> aux2 n'
| IOr (a,b) -> ior (aux a) (aux b)
| ITimes (a,b) -> mk (ITimes (a, aux b))
| IConcat (a,b) -> elim_concat n; aux2 n
| IType (t,_) -> elim_concat_type t q
| _ -> assert false in
m
in
r.desc <- ILink (aux2 n);
r
in
aux n
and elim_concat_type t q =
if not (Types.subtype t Sequence.any) then
raise (Patterns.Error "Left argument of concatenation is not a sequence type");
(* TODO: check t <= [ Any* ] *)
let mem = H.create 17 in
let rec aux t =
try H.find mem t
with Not_found ->
let n = mk_delayed () in
H.add mem t n;
let d =
List.fold_left
(fun accu (t1,t2) -> ior accu (mk (ITimes (itype t1, aux t2))))
(if Types.Atom.has_atom t Sequence.nil_atom then q else iempty)
(Types.Product.get t) in
n.desc <- d.desc;
n
in
aux t
let elim_concats () =
try
List.iter elim_concat !concats;
List.iter (fun n -> n.sid <- 0) !concats;
concats := []
with exn ->
List.iter (fun n -> n.sid <- 0) !concats;
concats := [];
raise exn
let derec penv p =
let d = derecurs penv p in
elim_concats ();
check_delayed ();
internalize d;
d
......@@ -882,22 +949,24 @@ module IType = struct
module Ids = Set.Make(Id)
let type_defs env b =
let penv = derecurs_def (penv env) b in
let aux t =
let d = derec penv t in
check_no_fv t.loc d;
let _,b' = derecurs_def (penv env) b in
elim_concats ();
check_delayed ();
let aux loc d =
internalize d;
check_no_fv loc d;
try typ d
with Patterns.Error s -> raise_loc_generic t.loc s
with Patterns.Error s -> raise_loc_generic loc s
in
let b =
List.map
(fun (loc,v,p) ->
let t = aux p in
List.map2
(fun (loc,v,p) (v',_,d) ->
let t = aux loc d in
if (loc <> noloc) && (Types.is_empty t) then
warning loc
("This definition yields an empty type for " ^ (U.to_string v));
let v = ident env loc v in
(v,t)) b in
(v',t)) b b' in
List.iter (fun (v,t) -> Types.Print.register_global
(Types.CompUnit.get_current ()) (Id.value v) t) b;
b
......
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