[r2003-03-15 08:40:32 by cvscast] Empty log message

Original author: cvscast
Date: 2003-03-15 08:40:32+00:00

parser/parser.ml

@@ -123,9 +123,9 @@ EXTEND
     ]
 
     | 
-    [ e1 = expr; op = ["+" | "-" | "@" | "++"]; e2 = expr -> 
+    [ e1 = expr; op = ["+" | "-" | "@" ]; e2 = expr -> 
 	mk loc (Op (op,[e1;e2]))
-    | e = expr; "--"; l = [LIDENT | UIDENT] -> 
+    | e = expr; "\\"; l = [LIDENT | UIDENT] -> 
 	mk loc (RemoveField (e,LabelPool.mk l)) 
     ]
     |

runtime/eval.ml

@@ -75,7 +75,6 @@ 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)
@@ -128,6 +127,7 @@ and eval_remove_field l = function
 
 and eval_add x y = match (x,y) with
   | (Integer x, Integer y) -> Integer (Intervals.vadd x y)
+  | Record r1, Record r2 -> Record (LabelMap.merge (fun x y -> y) r1 r2)
   | _ -> assert false
 
 and eval_mul x y = match (x,y) with
@@ -200,9 +200,3 @@ and eval_gt v1 v2 =
 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

types/types.ml

@@ -1260,6 +1260,16 @@ struct
     if t.absent then raise Not_found;
     t
 
+  let project_opt d l =
+    let t = TR.pi1 (split d l) in
+    { t with absent = false }
+
+  let condition d l t =
+    TR.pi2_restricted t (split d l)
+
+(* TODO: eliminate this cap ... (reord l only_absent_node) when
+   not necessary. eg. {| ..... |} \ l *)
+
   let remove_field d l = 
     cap (TR.pi2 (split d l)) (record l only_absent_node)
 
@@ -1281,6 +1291,17 @@ struct
 		    )
 	      d.record in
     (x land 2 <> 0, x land 1 <> 0)
+
+  let has_empty_record d =
+    BoolRec.compute
+      ~empty:false ~full:true ~cup:(||) ~cap:(&&)
+      ~diff:(fun a b -> a && not b)
+      ~atom:(function (o,r) ->
+	       List.for_all 
+	         (fun (l,t) -> (descr t).absent)
+	         (LabelMap.get r)
+	    )
+      d.record
     
 
 (*TODO: optimize merge

types/types.mli

@@ -108,6 +108,12 @@ module Record : sig
   val project : descr -> label -> descr
     (* Raise Not_found if label is not necessarily present *)
 
+  val condition : descr -> label -> descr -> descr
+    (* condition t1 l t2 : What must follow if field l hash type t2 *)
+  val project_opt : descr -> label -> descr
+  val has_empty_record: descr -> bool
+
+
   val first_label: descr -> label
 
   val empty_cases: descr -> bool * bool

typing/typer.ml

@@ -556,6 +556,9 @@ let let_decl glb p e =
 
 (* III. Type-checks *)
 
+let int_cup_record = Types.cup Types.Int.any Types.Record.any
+
+
 type env = Types.descr Env.t
 
 open Typed
@@ -613,22 +616,15 @@ and type_check' loc env e constr precise = match e with
   | Xml (e1,e2) ->
       type_check_pair ~kind:`XML loc env e1 e2 constr precise
 
-(*
   | RecordLitt r ->
-      let rconstr = Types.Record.get constr in
-      if Types.Record.is_empty rconstr then
+      if not (Types.Record.has_record constr) then
 	raise_loc loc (ShouldHave (constr,"but it is a record."));
-
-(* Completely buggy !  Need to check at the end that all required labels 
-   are present ...A better to do it without precise = true ? *)
-      let precise = true in
-
       let (rconstr,res) = 
-	List.fold_left 
+	List.fold_left
 	  (fun (rconstr,res) (l,e) ->
-	     let rconstr = Types.Record.restrict_label_present rconstr l in
-	     let pi = Types.Record.project_field rconstr l in
-	     if Types.Record.is_empty rconstr then
+	     (* could compute (split l e) once... *)
+	     let pi = Types.Record.project_opt rconstr l in
+	     if Types.is_empty pi then 
 	       raise_loc loc 
 		 (ShouldHave (constr,(Printf.sprintf 
 					"Field %s is not allowed here."
@@ -636,19 +632,17 @@ and type_check' loc env e constr precise = match e with
 				     )
 			     ));
 	     let t = type_check env e pi true in
-	     let rconstr = Types.Record.restrict_field rconstr l t in
-	     
-	     let res = 
-	       if precise 
-	       then Types.cap res (Types.record l false (Types.cons t))
-	       else res in
+	     let rconstr = Types.Record.condition rconstr l t in
+	     let res = if precise then (l,Types.cons t) :: res else res in
 	     (rconstr,res)
-	  ) (rconstr, if precise then Types.Record.any else constr) r
+	  ) (constr, []) (LabelMap.get r)
       in
-(*      check loc res constr ""; *)
-      res
-*)
-
+      if not (Types.Record.has_empty_record rconstr) then
+	raise_loc loc 
+	  (ShouldHave (constr,"More field should be present"));
+      if precise then
+	Types.record' (false, LabelMap.from_list (fun _ _ -> assert false) res)
+      else constr
   | Map (e,b) ->
       let t = type_check env e (Sequence.star b.br_accept) true in
 
@@ -859,7 +853,33 @@ and type_rec_funs env l =
 and type_op loc op args =
   match (op,args) with
     | "+", [loc1,t1; loc2,t2] ->
-	type_int_binop Intervals.add loc1 t1 loc2 t2
+	check loc1 t1 int_cup_record
+	"The first argument of + must be an integer or a record";
+	let int = Types.Int.get t1 in
+	let int = if Intervals.is_empty int then None else Some int in
+	let r = if Types.Record.has_record t1 then Some t1 else None in
+	(match (int,r) with
+	   | Some t1, None ->
+	       if not (Types.Int.is_int t2) then
+		 raise_loc loc2
+		   (Constraint 
+		      (t2,Types.Int.any,
+		       "The second argument of + must be an integer"));
+	       Types.Int.put
+		 (Intervals.add t1 (Types.Int.get t2));
+	   | None, Some r1 ->
+	       check loc2 t2 Types.Record.any 
+	       "The second argument of + must be a record";
+	       Types.Record.merge r1 t2
+	   | None, None ->
+	       Types.empty
+	   | Some t1, Some r1 ->
+	       check loc2 t2 int_cup_record
+	       "The second argument of + must be an integer or a record";
+	       Types.cup 
+		 (Types.Int.put (Intervals.add t1 (Types.Int.get t2)))
+		 (Types.Record.merge r1 t2)
+	)
     | "-", [loc1,t1; loc2,t2] ->
 	type_int_binop Intervals.sub loc1 t1 loc2 t2
     | ("*" | "/" | "mod"), [loc1,t1; loc2,t2] ->
@@ -913,12 +933,6 @@ 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 =