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

Original author: cvscast
Date: 2003-03-14 18:13:42+00:00

parser/ast.ml

@@ -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

parser/parser.ml

@@ -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]))  

runtime/eval.ml

@@ -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

tests/memento.xml

@@ -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>

types/normal.ml

@@ -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 

types/normal.mli

@@ -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

types/patterns.ml

@@ -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))

types/sortedList.ml

@@ -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 ->

types/sortedList.mli

@@ -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

types/types.ml

@@ -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
 

types/types.mli

@@ -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

typing/typed.ml

@@ -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 *)

typing/typer.ml

@@ -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 =