[r2002-12-02 22:22:04 by cvscast] Empty log message

Original author: cvscast
Date: 2002-12-02 22:22:04+00:00

depend

@@ -44,8 +44,6 @@ types/patterns.cmo: types/sortedList.cmi types/sortedMap.cmi misc/state.cmi \
     types/types.cmi types/patterns.cmi 
 types/patterns.cmx: types/sortedList.cmx types/sortedMap.cmx misc/state.cmx \
     types/types.cmx types/patterns.cmi 
-types/record.cmo: types/boolean.cmi types/sortedList.cmi 
-types/record.cmx: types/boolean.cmx types/sortedList.cmx 
 types/recursive_noshare.cmo: types/recursive.cmo misc/state.cmi 
 types/recursive_noshare.cmx: types/recursive.cmx misc/state.cmx 
 types/recursive_share.cmo: types/recursive.cmo misc/state.cmi 
@@ -59,11 +57,11 @@ types/sortedMap.cmx: types/sortedMap.cmi
 types/type_bool.cmo: types/boolean.cmi types/recursive.cmo 
 types/type_bool.cmx: types/boolean.cmx types/recursive.cmx 
 types/types.cmo: types/atoms.cmi types/boolean.cmi types/chars.cmi \
-    types/intervals.cmi misc/pool.cmi types/recursive.cmo \
+    types/intervals.cmi types/normal.cmi misc/pool.cmi types/recursive.cmo \
     types/recursive_noshare.cmo types/sortedList.cmi types/sortedMap.cmi \
     misc/state.cmi types/types.cmi 
 types/types.cmx: types/atoms.cmx types/boolean.cmx types/chars.cmx \
-    types/intervals.cmx misc/pool.cmx types/recursive.cmx \
+    types/intervals.cmx types/normal.cmx misc/pool.cmx types/recursive.cmx \
     types/recursive_noshare.cmx types/sortedList.cmx types/sortedMap.cmx \
     misc/state.cmx types/types.cmi 
 runtime/eval.cmo: runtime/load_xml.cmi parser/location.cmi \
@@ -112,8 +110,8 @@ types/patterns.cmi: types/sortedList.cmi types/sortedMap.cmi types/types.cmi
 types/sequence.cmi: types/types.cmi 
 types/sortedMap.cmi: types/sortedList.cmi 
 types/syntax.cmi: types/patterns.cmi types/types.cmi 
-types/types.cmi: types/atoms.cmi types/boolean.cmi types/chars.cmi \
-    types/intervals.cmi misc/pool.cmi 
+types/types.cmi: types/atoms.cmi types/chars.cmi types/intervals.cmi \
+    misc/pool.cmi types/sortedMap.cmi 
 runtime/eval.cmi: typing/typed.cmo runtime/value.cmi 
 runtime/load_xml.cmi: runtime/value.cmi 
 runtime/run_dispatch.cmi: types/patterns.cmi runtime/value.cmi 

runtime/run_dispatch.ml

@@ -50,7 +50,7 @@ and run_disp_kind actions v =
   match v with
   | Pair (v1,v2) -> run_disp_prod v v1 v2 actions.Patterns.Compile.prod
   | Xml (v1,v2) -> run_disp_prod v v1 v2 actions.Patterns.Compile.xml
-  | Record r -> run_disp_record r v [] r actions.Patterns.Compile.record
+  | Record r -> run_disp_record r v [] r false actions.Patterns.Compile.record
   | Atom a -> 
       run_disp_basic v (fun t -> Types.Atom.has_atom t a) 
         actions.Patterns.Compile.basic
@@ -92,26 +92,30 @@ and run_disp_prod2 v1 r1 v v2 x =
       let (code2,r2) = run_dispatcher d2 v2 in
       make_result_prod v1 r1 v2 r2 v b2.(code2)
 	    
-and run_disp_record f v bindings fields = function
+and run_disp_record f v bindings fields other = function
   | None -> assert false
-  | Some record -> run_disp_record' f v bindings None fields record
+  | Some record -> run_disp_record' f v bindings None fields other record
 
-and run_disp_record' f v bindings abs fields = function
-  | `Result r -> make_result_record f v bindings r
-  | `Absent -> run_disp_record f v bindings fields abs
+and run_disp_record' f v bindings abs fields other = function
+  | `Result r ->
+      make_result_record f v bindings r
+  | `Result_other (r1,r2) -> 
+      let other = other || fields <> [] in
+      make_result_record f v bindings (if other then r1 else r2)
+  | `Absent -> run_disp_record f v bindings fields other abs
   | `Label (l, present, absent) ->
-      let rec aux = function
-	| (l1,_) :: rem when l1 < l -> aux rem
+      let rec aux other = function
+	| (l1,_) :: rem when l1 < l -> aux true rem
 	| (l1,vl) :: rem when l1 = l -> 
-	    run_disp_field f v bindings abs rem l vl present
-	| _ -> run_disp_record f v bindings fields absent
+	    run_disp_field f v bindings abs rem other l vl present
+	| _ -> run_disp_record f v bindings fields other absent
       in
-      aux fields
+      aux other fields
 
-and run_disp_field f v bindings abs fields l vl = function
+and run_disp_field f v bindings abs fields other l vl = function
   | `None -> assert false
-  | `Ignore r -> run_disp_record' f v bindings abs fields r
+  | `Ignore r -> run_disp_record' f v bindings abs fields other r
   | `TailCall d -> run_dispatcher d vl
   | `Dispatch (dl,bl) ->
       let (codel,rl) = run_dispatcher dl vl in
-      run_disp_record' f v ((l,rl)::bindings) abs fields bl.(codel)
+      run_disp_record' f v ((l,rl)::bindings) abs fields other bl.(codel)

types/patterns.ml

@@ -699,6 +699,8 @@ module Normal : sig
   type 'a nline = (result *  'a) list
   type record =
       [ `Success
+      | `SomeField
+      | `NoField
       | `Fail
       | `Dispatch of (nnf * record) list
       | `Label of Types.label * (nnf * record) list * record ]
@@ -742,6 +744,8 @@ struct
   type 'a nline = (result *  'a) sl
   type record =
       [ `Success
+      | `SomeField
+      | `NoField
       | `Fail
       | `Dispatch of (nnf * record) list
       | `Label of Types.label * (nnf * record) list * record ]
@@ -755,6 +759,9 @@ struct
     nrecord: record nline
   }
 
+  let fus = SortedMap.union_disj
+  let slcup = SortedList.cup
+(*
   let nempty = { nfv = []; ncatchv = []; na = Types.empty;
 		 nbasic = []; nprod = []; nxml = []; nrecord = [] }
 
@@ -771,9 +778,6 @@ struct
       nrecord = SortedList.cup nf1.nrecord nf2.nrecord;
     }
 
-  let fus = SortedMap.union_disj
-  let slcup = SortedList.cup
-
   let double_fold f l1 l2 =
     SortedList.from_list
       (List.fold_left 
@@ -818,7 +822,7 @@ struct
 	na = acc;
 	nprod = SortedList.from_list prod
     }
-
+*)
     
 
   let empty = { v = []; catchv = []; 
@@ -981,9 +985,11 @@ struct
       let rec aux nr fields = 
 	match (nr,fields) with
 	  | (`Success, []) -> `Success
-	  | (`Fail,_) -> `Fail
-	  | (`Success, (l2,pl)::fields) ->
-	      `Label (l2, [(pl,Types.any), aux nr fields], `Fail)
+	  | (`SomeField, []) -> `SomeField
+	  | (`NoField, []) -> `NoField
+	  | (`Fail,_) | (`NoField,_::_) -> `Fail
+	  | ((`Success|`SomeField), (l2,pl)::fields) ->
+	      `Label (l2, [(pl,Types.any), aux `Success fields], `Fail)
 	  | (`Label (l1, _, _), (l2,pl)::fields) when l2 < l1 ->
 	      `Label (l2, [(pl,Types.any), aux nr fields], `Fail)
 	  | (`Label (l1, pr, _), (l2,pl)::fields) when l1 = l2 ->
@@ -999,9 +1005,6 @@ struct
 					if x==ab then aux_ab else
 					aux x fields)) pr in
 	      `Label (l1, pr, aux_ab)
-
-(* TODO:!!!*)
-	  | ((`NoField|`SomeField),_) -> aux `Success fields
       in
 
       let line accu ((res,fields),acc) =
@@ -1043,6 +1046,7 @@ struct
   and record = 
       [ `Label of Types.label * record dispatch * record option
       | `Result of result
+      | `Result_other of result * result
       | `Absent ]
       
   and 'a dispatch =
@@ -1380,20 +1384,20 @@ struct
   let map_record f = 
     let rec aux = function
       | [] -> []
-      | h::t -> (match f h with (_,_,`Fail) -> aux t | x -> x :: (aux t)) in
+      | (res,catch,h)::t -> 
+	  (match f h with `Fail -> aux t | x -> (res,catch,x) :: (aux t)) in
     Array.map aux
 
   let label_found l = 
     map_record 
       (function
-	 | (res, catch, `Label (l1, pr, _)) when l1 = l -> 
-	     (res, catch, `Dispatch pr)
+	 | `Label (l1, pr, _) when l1 = l -> `Dispatch pr
 	 | x -> x)
 
   let label_not_found l = 
     map_record 
       (function
-	 | (res, catch, `Label (l1, _, ab)) when l1 = l -> (res, catch, ab)
+	 | `Label (l1, _, ab) when l1 = l -> ab
 	 | x -> x)
 
 (*
@@ -1458,9 +1462,27 @@ struct
     match collect_first_label pl with
       | None -> 
 	  let aux_final (res, catch, x) =
-	    assert (x = `Success);
-	    List.map (conv_source_record catch) res in
-	  `Result (return disp pl aux_final)
+	    assert (x = `Success); 
+	    List.map (conv_source_record catch) res 
+	  in
+	  let somefield = 
+	    if Types.Record.somefield_possible t then
+	      let aux = function `Success | `SomeField -> `Success | _ -> `Fail in
+	      Some (return disp (map_record aux pl) aux_final)
+	    else None
+	  in
+	  let nofield = 
+	    if Types.Record.nofield_possible t then 
+	      let aux = function `Success | `NoField -> `Success | _ -> `Fail in
+	      Some (return disp (map_record aux pl) aux_final)
+	    else None
+	  in
+	  (match (somefield,nofield) with
+	     | Some r1, Some r2 -> 
+		 if r1 = r2 then `Result r1 else `Result_other(r1,r2)
+	     | Some r1, None -> `Result r1
+	     | None, Some r2 -> `Result r2
+	     | _ -> assert false)
       | Some l ->
 	  let (plabs,absent) = 
 	    let pl = label_not_found l pl in
@@ -1470,16 +1492,22 @@ struct
 	  let present =
 	    let pl = label_found l pl in
 	    let t = Types.Record.restrict_label_present t l in
-	    get_tests pl
-	      (function 
-		 | (res,catch, `Dispatch d) -> 
-		     List.map (fun (p, r) -> p, (res, catch, r)) d, []
-		 | x -> [],[x])
-	      (Types.Record.project_field t l)
-	      (dispatch_record_field l disp t plabs)
-	      (fun x -> combine x)
+	    if Types.Record.is_empty t then None else 
+	      Some (
+		get_tests pl
+		      (function 
+			 | (res,catch, `Dispatch d) -> 
+			     List.map (fun (p, r) -> p, (res, catch, r)) d, []
+			 | x -> [],[x])
+		      (Types.Record.project_field t l)
+		      (dispatch_record_field l disp t plabs)
+		      (fun x -> combine x)
+	      )
 	  in
-	  combine_record l present absent
+	  (match (present,absent) with
+	    | (Some present, absent) -> combine_record l present absent
+	    | (None, Some absent) -> absent
+	    | _ -> assert false)
   and dispatch_record_field l disp t plabs tfield pl others =
     let t = Types.Record.restrict_field t l tfield in
     let aux (ret, ncatchv, (res, catch, rem)) = 
@@ -1609,7 +1637,9 @@ struct
 	  Format.fprintf ppf " | Record -> @\n";
 	  Format.fprintf ppf "     @[%a@]@\n"  print_record r
     and print_record ppf = function
-      | `Result r -> print_ret ppf r
+      | `Result r -> Format.fprintf ppf "%a" print_ret r
+      | `Result_other (r1,r2) -> Format.fprintf ppf "SomeField:%a;NoField:%a" 
+		   print_ret r1 print_ret r2
       | `Absent -> Format.fprintf ppf "Jump to Absent"
       | `Label (l, present, absent) ->
 	  let l = Types.LabelPool.value l in
@@ -1621,7 +1651,9 @@ struct
 		   print_record r
 	    | None -> ()
     and print_present l ppf = function
-      | `None -> assert false
+      | `None -> 
+	  Format.fprintf ppf "(cannot happen)"
+	  (* assert false *)
       | `TailCall d ->
 	  queue d;
 	  Format.fprintf ppf "disp_%i@\n" d.id 

types/patterns.mli

@@ -59,7 +59,8 @@ module Compile: sig
   }
   and record = 
       [ `Label of Types.label * record dispatch * record option
-      | `Result of result 
+      | `Result of result
+      | `Result_other of result * result
       | `Absent ]
       
   and 'a dispatch =

types/sortedMap.ml

@@ -50,6 +50,11 @@ let add f x y m =
 let change x f =
   add (fun _ -> f) x
 
+let rec change_exists x1 f = function
+  | [] -> raise Not_found
+  | (x,y)::q when x = x1 -> (x,f y)::q
+  | h::q -> h::(change_exists x1 f q)
+
 let rec diff l1 l2 =
   match (l1,l2) with
     | (((x1,y1) as t1)::q1, x2::q2) ->

types/sortedMap.mli

@@ -11,6 +11,8 @@ val map: ('b -> 'c) -> ('a,'b) t -> ('a,'c) t
 val add: ('b -> 'b -> 'b) -> 'a -> 'b -> ('a,'b) t -> ('a,'b) t
 val change: 'a -> ('b -> 'b) -> 'b -> ('a,'b) t -> ('a,'b) t
 
+val change_exists: 'a -> ('b -> 'b) -> ('a,'b) t -> ('a,'b) t
+
 val diff: ('a,'b) t -> 'a SortedList.t -> ('a,'b) t
 
 val iter: ('a -> 'b -> unit) -> ('a,'b) t -> unit

types/types.ml

@@ -194,6 +194,8 @@ let any = descr any_node
 
 let neg x = diff any x
 
+let any_node = cons any
+
 (*
 let get_record r =
   let add = SortedMap.add (fun (o1,t1) (o2,t2) -> (o1&&o2, cap t1 t2)) in
@@ -981,6 +983,12 @@ struct
     | (true,[]) -> Boolean.full
     | (o,l) -> Boolean.atom (o,l)
 
+  let somefield_possible t =
+    not (R.empty (R.diff t (Boolean.atom (false,[]))))
+
+  let nofield_possible t =    
+    not (R.empty (R.cap t (Boolean.atom (false,[]))))
+
   let restrict_label_absent t l =
     Boolean.compute_bool
       (fun (o,r) as x ->
@@ -1023,11 +1031,16 @@ struct
     TR.boolean x
 
   let restrict_label_present t l =
-    t
-(*
-    let r = label_present t l in
-    List.fold_left (fun accu (_,t) -> Boolean.cup accu t) Boolean.empty r
-*)
+    Boolean.compute_bool
+      (fun (o,r) as x ->
+	 try
+	   Boolean.atom (o, SortedMap.change_exists l (fun (_,lt) -> (false,lt)) r)
+	 with Not_found -> 
+	   if o then Boolean.atom 
+	     (true, SortedMap.union_disj [l, (false,any_node)] r)
+	   else Boolean.empty
+      )
+      t
 
   let project_field t l =
     let r = label_present t l in

types/types.mli

@@ -101,6 +101,8 @@ module Record : sig
   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