Commit 203537de authored by Pietro Abate's avatar Pietro Abate
Browse files

[r2004-12-25 20:39:15 by afrisch] Default values for record fields

Original author: afrisch
Date: 2004-12-25 20:39:15+00:00
parent 75975fa4
......@@ -106,7 +106,7 @@ and ppat' =
| XmlT of ppat * ppat
| Arrow of ppat * ppat
| Optional of ppat
| Record of bool * (label * ppat) list
| Record of bool * (label * (ppat * ppat option)) list
| Constant of id * pexpr
| Regexp of regexp * ppat
(* regular expression, continuation: [ re ; cont ], e.g: [ re ; nil ] *)
......
......@@ -506,8 +506,9 @@ EXTEND
| "{|"; r = record_spec; "|}" -> mk loc (Record (false,r))
| "ref"; p = pat ->
let get_fun = mk loc (Arrow (pat_nil, p))
and set_fun = mk loc (Arrow (p, pat_nil)) in
let fields = [ label "get", get_fun; label "set", set_fun ] in
and set_fun = mk loc (Arrow (p, pat_nil))in
let fields =
[ label "get", (get_fun, None); label "set", (set_fun, None) ] in
mk loc (Record (false, fields))
| IDENT "_" -> mk loc (Internal Types.any)
| "("; a = IDENT; ":="; c = expr; ")" ->
......@@ -562,12 +563,14 @@ EXTEND
];
or_else : [ [ OPT [ "else"; y = pat -> y ] ] ];
record_spec:
[ [ r = LIST0 [ l = [IDENT | keyword ]; "=";
o = [ "?" -> true | -> false];
x = pat ->
x = pat; y = or_else ->
let x = if o then mk loc (Optional x) else x in
(label l, x)
(label l, (x,y))
] SEP ";" ->
r
] ];
......@@ -581,9 +584,9 @@ EXTEND
attrib_spec:
[ [ r = LIST0 [ l = [IDENT | keyword ]; "=";
o = [ "?" -> true | -> false];
x = pat; OPT ";" ->
x = pat; y = or_else; OPT ";" ->
let x = if o then mk loc (Optional x) else x in
(label l, x)
(label l, (x, y))
] ->
mk loc (Record (true,r))
| "("; t = pat; ")" -> t
......
......@@ -111,10 +111,14 @@ let rec var_of_ppat x =
|XmlT(p1,p2) -> var_of_ppat p1 @ var_of_ppat p2
|Arrow(p1,p2) -> var_of_ppat p1 @ var_of_ppat p2
|Optional(p1) -> var_of_ppat p1
|Record(b,lm) -> let rec listing l=(match l with
[] -> []
|(s,ppat)::r -> var_of_ppat(ppat) @ listing r
)in listing (lm)
|Record(b,lm) ->
let rec aux accu (_,(ppat,e)) =
let accu = var_of_ppat ppat @ accu in
match e with
| None -> accu
| Some ppat -> var_of_ppat ppat @ accu
in
List.fold_left aux [] lm
|Constant(i,t) -> [i]
|Regexp(rg,p) -> var_of_rg rg @ var_of_ppat p
......
......@@ -55,7 +55,8 @@ EXTEND
a = [IDENT|keyword]-> (* projection sur 1 attribut *)
let tag = mk loc (Internal(Types.atom Atoms.any)) in
let any = mk loc (Internal(Types.any)) in
let att = mk loc (Record(true,[(label a,mk loc (PatVar(U.mk "$$$")))]))in
let att = mk loc (Record(true,[(label a,
(mk loc (PatVar(U.mk "$$$")),None))]))in
(*let ct= mk loc (Regexp(Elem any , any)) in *)
let p = mk loc(XmlT (tag,multi_prod loc[att;any])) in
let t =(p, Pair(Var (Id.value id_dummy),cst_nil))
......
......@@ -285,7 +285,7 @@ type derecurs_slot = {
| PXml of derecurs * derecurs
| PArrow of derecurs * derecurs
| POptional of derecurs
| PRecord of bool * derecurs label_map
| PRecord of bool * (derecurs * derecurs option) label_map
| PCapture of id
| PConstant of id * Types.const
| PRegexp of derecurs_regexp * derecurs
......@@ -311,7 +311,7 @@ type descr =
| IXml of slot * slot
| IArrow of slot * slot
| IOptional of descr
| IRecord of bool * slot label_map
| IRecord of bool * (slot * descr option) label_map
| ICapture of id
| IConstant of id * Types.const
and slot = {
......@@ -361,13 +361,16 @@ let rec hash_derecurs = function
| POptional p ->
8 + 17 * (hash_derecurs p)
| PRecord (o,r) ->
(if o then 9 else 10) + 17 * (LabelMap.hash hash_derecurs r)
(if o then 9 else 10) + 17 * (LabelMap.hash hash_derecurs_field r)
| PCapture x ->
11 + 17 * (Id.hash x)
| PConstant (x,c) ->
12 + 17 * (Id.hash x) + 257 * (Types.Const.hash c)
| PRegexp (p,q) ->
13 + 17 * (hash_derecurs_regexp p) + 257 * (hash_derecurs q)
and hash_derecurs_field = function
| (p, Some e) -> 1 + 17 * hash_derecurs p + 257 * hash_derecurs e
| (p, None) -> 2 + 17 * hash_derecurs p
and hash_derecurs_regexp = function
| PEpsilon ->
1
......@@ -399,7 +402,7 @@ let rec equal_derecurs p1 p2 = (p1 == p2) || match p1,p2 with
| POptional p1, POptional p2 ->
equal_derecurs p1 p2
| PRecord (o1,r1), PRecord (o2,r2) ->
(o1 == o2) && (LabelMap.equal equal_derecurs r1 r2)
(o1 == o2) && (LabelMap.equal equal_derecurs_field r1 r2)
| PCapture x1, PCapture x2 ->
Id.equal x1 x2
| PConstant (x1,c1), PConstant (x2,c2) ->
......@@ -407,6 +410,10 @@ let rec equal_derecurs p1 p2 = (p1 == p2) || match p1,p2 with
| PRegexp (p1,q1), PRegexp (p2,q2) ->
(equal_derecurs_regexp p1 p2) && (equal_derecurs q1 q2)
| _ -> false
and equal_derecurs_field r1 r2 = match (r1,r2) with
| (p1,None),(p2,None) -> equal_derecurs p1 p2
| (p1, Some e1), (p2, Some e2) -> equal_derecurs p1 p2 && equal_derecurs e1 e2
| _ -> false
and equal_derecurs_regexp r1 r2 = match r1,r2 with
| PEpsilon, PEpsilon ->
true
......@@ -453,9 +460,12 @@ let rec hash_descr = function
| ITimes (s1,s2) -> 5 + 17 * (hash_slot s1) + 257 * (hash_slot s2)
| IXml (s1,s2) -> 6 + 17 * (hash_slot s1) + 257 * (hash_slot s2)
| IArrow (s1,s2) -> 7 + 17 * (hash_slot s1) + 257 * (hash_slot s2)
| IRecord (o,r) -> (if o then 8 else 9) + 17 * (LabelMap.hash hash_slot r)
| IRecord (o,r) -> (if o then 8 else 9) + 17 * (LabelMap.hash hash_descr_field r)
| ICapture x -> 10 + 17 * (Id.hash x)
| IConstant (x,y) -> 11 + 17 * (Id.hash x) + 257 * (Types.Const.hash y)
and hash_descr_field = function
| (d, Some e) -> 1 + 17 * hash_slot d + 257 * hash_descr e
| (d, None) -> 2 + 17 * hash_slot d
and hash_slot s =
if s.gen1 = !gen then 13 * s.rank1
else (
......@@ -475,11 +485,15 @@ let rec equal_descr d1 d2 =
| IXml (x1,y1), IXml (x2,y2)
| IArrow (x1,y1), IArrow (x2,y2) -> (equal_slot x1 x2) && (equal_slot y1 y2)
| IRecord (o1,r1), IRecord (o2,r2) ->
(o1 = o2) && (LabelMap.equal equal_slot r1 r2)
(o1 = o2) && (LabelMap.equal equal_descr_field r1 r2)
| ICapture x1, ICapture x2 -> Id.equal x1 x2
| IConstant (x1,y1), IConstant (x2,y2) ->
(Id.equal x1 x2) && (Types.Const.equal y1 y2)
| _ -> false
and equal_descr_field d1 d2 = match (d1,d2) with
| (d1,None),(d2,None) -> equal_slot d1 d2
| (d1, Some e1), (d2, Some e2) -> equal_slot d1 d2 && equal_descr e1 e2
| _ -> false
and equal_slot s1 s2 =
((s1.gen1 = !gen) && (s2.gen2 = !gen) && (s1.rank1 = s2.rank2))
||
......@@ -584,7 +598,11 @@ let rec derecurs env p = match p.descr with
| XmlT (p1,p2) -> PXml (derecurs env p1, derecurs env p2)
| Arrow (p1,p2) -> PArrow (derecurs env p1, derecurs env p2)
| Optional p -> POptional (derecurs env p)
| Record (o,r) -> PRecord (o, parse_record env.penv_tenv p.loc (derecurs env) r)
| Record (o,r) ->
let aux = function
| (p,Some e) -> (derecurs env p, Some (derecurs env e))
| (p,None) -> derecurs env p, None in
PRecord (o, parse_record env.penv_tenv p.loc aux r)
| Constant (x,c) -> PConstant (x,const env.penv_tenv p.loc c)
| Cst c -> PType (Types.constant (const env.penv_tenv p.loc c))
| Regexp (r,q) ->
......@@ -657,8 +675,12 @@ and fv_descr = function
| IXml (s1,s2)
| IArrow (s1,s2) -> IdSet.cup (fv_slot s1) (fv_slot s2)
| IRecord (o,r) ->
List.fold_left IdSet.cup IdSet.empty (LabelMap.map_to_list fv_slot r)
List.fold_left IdSet.cup IdSet.empty (LabelMap.map_to_list fv_field r)
| ICapture x | IConstant (x,_) -> IdSet.singleton x
and fv_field = function
| (d,Some e) -> IdSet.cup (fv_slot d) (fv_descr e)
| (d,None) -> fv_slot d
let compute_fv s =
match s.fv with
......@@ -703,11 +725,15 @@ and real_compile = function
| PXml (t1,t2) -> IXml (compile_slot t1, compile_slot t2)
| PArrow (t1,t2) -> IArrow (compile_slot t1, compile_slot t2)
| POptional t -> IOptional (compile t)
| PRecord (o,r) -> IRecord (o, LabelMap.map compile_slot r)
| PRecord (o,r) -> IRecord (o, LabelMap.map compile_field r)
| PConstant (x,v) -> IConstant (x,v)
| PCapture x -> ICapture x
| PRegexp (r,q) -> compile (remove_regexp r q)
and compile_field = function
| (p, Some e) -> (compile_slot p, Some (compile e))
| (p, None) -> (compile_slot p, None)
and compile_slot p =
try DerecursTable.find compile_slot_hash p
with Not_found ->
......@@ -743,9 +769,14 @@ let rec typ = function
| IXml (s1,s2) -> Types.xml (typ_node s1) (typ_node s2)
| IArrow (s1,s2) -> Types.arrow (typ_node s1) (typ_node s2)
| IOptional s -> Types.Record.or_absent (typ s)
| IRecord (o,r) -> Types.record' (o, LabelMap.map typ_node r)
| IRecord (o,r) -> Types.record' (o, LabelMap.map typ_field r)
| IDummy | ICapture _ | IConstant (_,_) -> assert false
and typ_field = function
| (s, None) -> typ_node s
| (s, Some _) ->
raise (Patterns.Error "Or-else clauses are not allowed in types")
and typ_node s : Types.Node.t =
try SlotTable.find typ_nodes s
with Not_found ->
......@@ -774,11 +805,20 @@ and pat_aux = function
raise (Patterns.Error "Optional fields are not allowed in record patterns")
| IRecord (o,r) ->
let pats = ref [] in
let aux l s =
if IdSet.is_empty (fv_slot s) then typ_node s
else
( pats := Patterns.record l (pat_node s) :: !pats;
Types.any_node )
let aux l = function
| (s,None) ->
if IdSet.is_empty (fv_slot s) then typ_node s
else
( pats := Patterns.record l (pat_node s) :: !pats;
Types.any_node )
| (s,Some e) ->
if IdSet.is_empty (fv_slot s) then
raise (Patterns.Error "Or-else clauses are not allowed in types")
else
( pats := Patterns.cup
(Patterns.record l (pat_node s))
(pat e) :: !pats;
Types.Record.any_or_absent_node )
in
let constr = Types.record' (o,LabelMap.mapi aux r) in
List.fold_left Patterns.cap (Patterns.constr constr) !pats
......@@ -1612,7 +1652,7 @@ module Schema_converter =
| _ -> cd_type_of_simple_type ~schema at.attr_decl.attr_typdef
in
let r = if at.attr_required then r else POptional r in
(LabelPool.mk (Ns.empty, at.attr_decl.attr_name), r))
(LabelPool.mk (Ns.empty, at.attr_decl.attr_name), (r,None)))
attr_uses in
PRecord (false, LabelMap.from_list_disj fields)
......@@ -1620,7 +1660,7 @@ module Schema_converter =
let r = cd_type_of_simple_type ~schema att.attr_typdef in
PRecord (false,
LabelMap.from_list_disj
[(LabelPool.mk (schema.targetNamespace, att.attr_name), r)])
[(LabelPool.mk (schema.targetNamespace, att.attr_name), (r,None))])
and cd_type_of_elt_decl ~schema elt =
let atom_type =
......
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