Commit e4949133 authored by Pietro Abate's avatar Pietro Abate

[r2003-03-14 18:11:21 by cvscast] Empty log message

Original author: cvscast
Date: 2003-03-14 18:13:42+00:00
parent f0b3a7b5
......@@ -41,7 +41,8 @@ and pexpr' =
| Op of string * pexpr list
| Match of pexpr * branches
| Map of pexpr * branches
| Dot of (pexpr* label)
| Dot of pexpr* label
| RemoveField of pexpr * label
(* Exceptions *)
| Try of pexpr * branches
......
......@@ -123,11 +123,10 @@ EXTEND
]
|
[ e1 = expr; op = ["+" | "-" | "@"]; e2 = expr -> mk loc (Op (op,[e1;e2]))
]
|
[ e1 = expr; "++"; "{"; l = [LIDENT | UIDENT]; "="; e = expr; "}" ->
assert false
[ e1 = expr; op = ["+" | "-" | "@" | "++"]; e2 = expr ->
mk loc (Op (op,[e1;e2]))
| e = expr; "--"; l = [LIDENT | UIDENT] ->
mk loc (RemoveField (e,LabelPool.mk l))
]
|
[ e1 = expr; op = ["*"]; e2 = expr -> mk loc (Op (op,[e1;e2]))
......
......@@ -75,7 +75,9 @@ let rec eval env e0 =
| Typed.Op ("<=",[e1; e2]) -> eval_lte (eval env e1) (eval env e2)
| Typed.Op (">",[e1; e2]) -> eval_gt (eval env e1) (eval env e2)
| Typed.Op (">=",[e1; e2]) -> eval_gte (eval env e1) (eval env e2)
| Typed.Op ("++",[e1; e2]) -> eval_merge_record (eval env e1) (eval env e2)
| Typed.Dot (e, l) -> eval_dot l (eval env e)
| Typed.RemoveField (e, l) -> eval_remove_field l (eval env e)
| Typed.Op (o,_) -> failwith ("Unknown operator " ^ o)
......@@ -120,6 +122,10 @@ and eval_dot l = function
| Record r -> LabelMap.assoc l r
| _ -> assert false
and eval_remove_field l = function
| Record r -> Record (LabelMap.remove l r)
| _ -> assert false
and eval_add x y = match (x,y) with
| (Integer x, Integer y) -> Integer (Intervals.vadd x y)
| _ -> assert false
......@@ -195,3 +201,8 @@ and eval_gte v1 v2 =
let c = Value.compare v1 v2 in
Value.vbool (Value.compare v1 v2 >= 0)
and eval_merge_record v1 v2 =
match (v1,v2) with
| Record r1, Record r2 -> Record (LabelMap.merge (fun x y -> y) r1 r2)
| _ -> assert false
......@@ -110,6 +110,23 @@ Integer,Integer -> Bool = <duce>`true | `false</duce>
</ul>
</section>
<section>
<title>Record</title>
<ul>
<li>Records litteral <duce>{ l1 = e1; ...; ln = en }</duce></li>
<li>Types: <duce>{| l1 = t1; ...; ln = tn |}</duce> (closed, no more
fields allowed), <duce>>{ l1 = t1; ...; ln = tn }</duce> (open,
any other field allowed). Optional fields: <duce>li =? ti</duce>
instead of <duce>li = ti</duce>.</li>
<li>Record concatenation: <duce>e1 ++ e2</duce>
(priority to the fields from the right argument) </li>
<li>Field removal: <duce>e1 -- l</duce> (does nothing if the
field <duce>l</duce> is not present)</li>
<li>Field access: <duce>e1 . l</duce></li>
<li>Record: <duce>{ l1 = p1; ...; ln = pn }</duce></li>
</ul>
</section>
<section>
<title>Strings</title>
<ul>
......
......@@ -86,6 +86,9 @@ struct
let pi1 =
List.fold_left (fun accu (t1,t2) -> X1.cup accu t1) X1.empty
let pi2 =
List.fold_left (fun accu (t1,t2) -> X2.cup accu t2) X2.empty
let pi2_restricted restr =
List.fold_left (fun accu (t1,t2) ->
if X1.is_empty (X1.cap t1 restr) then accu
......
......@@ -27,5 +27,6 @@ sig
val boolean: (X1.t * X2.t) bool -> t
val pi1: t -> X1.t
val pi2: t -> X2.t
val pi2_restricted: X1.t -> t -> X2.t
end
......@@ -370,7 +370,6 @@ struct
let record =
match lab with
| None ->
(* Should check that r has only empty_cases *)
let (x,y) = Types.Record.empty_cases t in
RecNolabel ((if x then Some empty_res else None),
(if y then Some empty_res else None))
......
......@@ -64,6 +64,7 @@ sig
val is_empty: ('a,'b) map -> bool
val singleton: 'a elem -> 'b -> ('a,'b) map
val assoc_remove: 'a elem -> ('a,'b) map -> 'b * ('a,'b) map
val remove: 'a elem -> ('a,'b) map -> ('a,'b) map
val merge: ('b -> 'b -> 'b ) -> ('a,'b) map -> ('a,'b) map -> ('a,'b) map
val merge_elem: 'b -> ('a,'b) map -> ('a,'b) map -> ('a,'b) map
val union_disj: ('a,'b) map -> ('a,'b) map -> ('a,'b) map
......@@ -254,6 +255,16 @@ module Map = struct
let l = assoc_remove_aux v r l in
(!r, l)
(* TODO: is is faster to raise exception Not_found and return
original list ? *)
let rec remove v = function
| (((x,y) as a)::rem) as l->
let c = X.compare x v in
if c = 0 then rem
else if c < 0 then a :: (remove v rem)
else l
| [] -> []
let rec merge f l1 l2 =
match (l1,l2) with
| ((x1,y1) as t1)::q1, ((x2,y2) as t2)::q2 ->
......
......@@ -60,6 +60,7 @@ sig
val is_empty: ('a,'b) map -> bool
val singleton: 'a elem -> 'b -> ('a,'b) map
val assoc_remove: 'a elem -> ('a,'b) map -> 'b * ('a,'b) map
val remove: 'a elem -> ('a,'b) map -> ('a,'b) map
val merge: ('b -> 'b -> 'b ) -> ('a,'b) map -> ('a,'b) map -> ('a,'b) map
val merge_elem: 'b -> ('a,'b) map -> ('a,'b) map -> ('a,'b) map
val union_disj: ('a,'b) map -> ('a,'b) map -> ('a,'b) map
......
......@@ -1212,9 +1212,9 @@ struct
if o && LabelMap.is_empty l then any_record else
{ empty with record = BoolRec.atom (o,l) }
type zor = Pair of descr * descr | Any | Empty
type zor = Pair of descr * descr | Any
let aux d l=
let aux_split d l=
let f (o,r) =
try
let (lt,rem) = LabelMap.assoc_remove l r in
......@@ -1223,7 +1223,9 @@ struct
if o then
if LabelMap.is_empty r then Any else
Pair (any_or_absent, { empty with record = BoolRec.atom (o,r) })
else Empty
else
Pair ({empty with absent = true},
{ empty with record = BoolRec.atom (o,r) })
in
List.fold_left
(fun b (p,n) ->
......@@ -1231,14 +1233,12 @@ struct
| x::p ->
(match f x with
| Pair (t1,t2) -> aux_p ((t1,t2)::accu) p
| Any -> aux_p accu p
| Empty -> b)
| Any -> aux_p accu p)
| [] -> aux_n accu [] n
and aux_n p accu = function
| x::n ->
(match f x with
| Pair (t1,t2) -> aux_n p ((t1,t2)::accu) n
| Empty -> aux_n p accu n
| Any -> b)
| [] -> (p,accu) :: b in
aux_p [] p)
......@@ -1246,10 +1246,10 @@ struct
(BoolRec.get d.record)
let split (d : descr) l =
TR.boolean (aux d l)
TR.boolean (aux_split d l)
let split_normal d l =
TR.boolean_normal (aux d l)
TR.boolean_normal (aux_split d l)
let project d l =
......@@ -1257,6 +1257,9 @@ struct
if t.absent then raise Not_found;
t
let remove_field d l =
TR.pi2 (split d l)
let first_label d =
let min = ref LabelPool.dummy_max in
let aux (_,r) =
......@@ -1277,6 +1280,38 @@ struct
(x land 2 <> 0, x land 1 <> 0)
(*TODO: optimize merge
- pre-compute the sequence of labels
- remove empty or full { l = t }
*)
let merge d1 d2 =
let res = ref empty in
let rec aux accu d1 d2 =
let l = min (first_label d1) (first_label d2) in
if l = LabelPool.dummy_max then
let (some1,none1) = empty_cases d1
and (some2,none2) = empty_cases d2 in
let none = none1 && none2 and some = some1 || some2 in
let accu = LabelMap.from_list (fun _ _ -> assert false) accu in
(* approx for the case (some && not none) ... *)
res := cup !res (record' (some, accu))
else
let l1 = split d1 l and l2 = split d2 l in
let loop (t1,d1) (t2,d2) =
let t =
if t2.absent
then cup t1 { t2 with absent = false }
else t2
in
aux ((l,cons t)::accu) d1 d2
in
List.iter (fun x -> List.iter (loop x) l2) l1
in
aux [] d1 d2;
!res
let any = { empty with record = any.record }
end
......
......@@ -112,50 +112,8 @@ module Record : sig
val empty_cases: descr -> bool * bool
(*
val restrict_field : t -> label -> descr -> t
val restrict_label_absent: t -> label -> t
val restrict_label_present: t -> label -> t
val label_present: t -> label -> (descr * t) list
val somefield_possible: t -> bool
val nofield_possible: t -> bool
val any : descr
val project_field: t -> label -> descr
val project : descr -> label -> descr
(*
(* List of maps label -> (optional, content) *)
type t (* = (label, (bool * descr)) SortedMap.t list *)
val get: descr -> t
val descr: t -> descr
val is_empty: t -> bool
val restrict_label_present: t -> label -> t
val restrict_field: t -> label -> descr -> t
val restrict_label_absent: t -> label -> t
val project_field: t -> label -> descr
*)
type normal =
[ `Success (* { } *)
| `Fail (* Empty *)
| `NoField (* {| |} *)
| `SomeField (* { } \ {| |} *)
| `Label of label * (descr * normal) list * normal ]
val normal: descr -> normal
val normal': t -> label -> (descr * t) list * t
val first_label: t -> [ `Success|`Fail|`NoField|`SomeField|`Label of label ]
val change_field: t -> label -> node -> t
(*
val project : descr -> label -> descr
(* Raise Not_found if label is not necessarily present *)
*)
*)
val merge: descr -> descr -> descr
val remove_field: descr -> label -> descr
end
module Arrow : sig
......
......@@ -36,6 +36,7 @@ and texpr' =
| Op of string * texpr list
| Match of texpr * branches
| Map of texpr * branches
| RemoveField of texpr * label
| Dot of texpr * label
(* Exception *)
......
......@@ -489,6 +489,9 @@ let rec expr loc' glb { loc = loc; descr = d } =
| Dot (e,l) ->
let (fv,e) = expr loc glb e in
(fv, Typed.Dot (e,l))
| RemoveField (e,l) ->
let (fv,e) = expr loc glb e in
(fv, Typed.RemoveField (e,l))
| RecordLitt r ->
let fv = ref Fv.empty in
let r = LabelMap.map
......@@ -771,6 +774,9 @@ and compute_type' loc env = function
let t = type_check env e Types.Record.any true in
(try (Types.Record.project t l)
with Not_found -> raise_loc loc (WrongLabel(t,l)))
| RemoveField (e,l) ->
let t = type_check env e Types.Record.any true in
Types.Record.remove_field t l
| Op (op, el) ->
let args = List.map (fun e -> (e.exp_loc, compute_type env e)) el in
type_op loc op args
......@@ -907,6 +913,12 @@ and type_op loc op args =
| ("<=" | "<" | ">" | ">=" ), [loc1,t1; loc2,t2] ->
(* could prevent comparision of functional value here... *)
Builtin.bool
| "++", [loc1,t1; loc2,t2] ->
check loc1 t1 Types.Record.any
"The left argument of ++ must be a record";
check loc2 t2 Types.Record.any
"The right argument of ++ must be a record";
Types.Record.merge t1 t2
| _ -> assert false
and type_int_binop f loc1 t1 loc2 t2 =
......
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