Commit a845c226 authored by Pietro Abate's avatar Pietro Abate
Browse files

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

Original author: cvscast
Date: 2003-03-15 08:40:32+00:00
parent 227c58cc
......@@ -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))
]
|
......
......@@ -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
......@@ -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
......
......@@ -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
......
......@@ -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 =
......
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