[r2002-12-02 23:05:47 by cvscast] Empty log message

Original author: cvscast
Date: 2002-12-02 23:05:47+00:00

runtime/run_dispatch.ml

 (* Running dispatchers *)
 
+(* TODO: remove `Absent and clean .... *)
+
 open Value
 
 
@@ -94,28 +96,27 @@ and run_disp_prod2 v1 r1 v v2 x =
 	    
 and run_disp_record f v bindings fields other = function
   | None -> assert false
-  | Some record -> run_disp_record' f v bindings None fields other record
+  | Some record -> run_disp_record' f v bindings fields other record
 
-and run_disp_record' f v bindings abs fields other = function
+and run_disp_record' f v bindings fields other = function
   | `Result r ->
       make_result_record f v bindings r
-  | `Result_other (r1,r2) -> 
+  | `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 other = function
 	| (l1,_) :: rem when l1 < l -> aux true rem
 	| (l1,vl) :: rem when l1 = l -> 
-	    run_disp_field f v bindings abs rem other l vl present
+	    run_disp_field f v bindings rem other l vl present
 	| _ -> run_disp_record f v bindings fields other absent
       in
       aux other fields
 
-and run_disp_field f v bindings abs fields other l vl = function
+and run_disp_field f v bindings fields other l vl = function
   | `None -> assert false
-  | `Ignore r -> run_disp_record' f v bindings abs fields other r
+  | `Ignore r -> run_disp_record' f v bindings 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 other bl.(codel)
+      run_disp_record' f v ((l,rl)::bindings) fields other bl.(codel)

types/patterns.ml

@@ -1046,8 +1046,7 @@ struct
   and record = 
       [ `Label of Types.label * record dispatch * record option
       | `Result of result
-      | `Result_other of result * result
-      | `Absent ]
+      | `Result_other of Types.label list * result * result ]
       
   and 'a dispatch =
       [ `Dispatch of dispatcher * 'a array
@@ -1135,8 +1134,8 @@ struct
   let combine_record l present absent = 
     match (present,absent) with
       | (`Ignore r1, Some r2) when r1 = r2 -> r1
-      | (`Ignore `Absent, Some r) -> r
-      | (`Ignore r, None) -> r
+      | (`Ignore r, None) -> r 
+      | (`None, Some r) -> r
       | _ -> `Label (l, present, absent)
 
   let detect_right_tail_call = function
@@ -1231,13 +1230,8 @@ struct
     aux 0 d.interface
 
   let create_result pl =
-    Array.of_list (
-      Array.fold_right
-		     (fun x accu -> match x with
-			| Some b -> b @ accu 
-			| None -> accu)
-		     pl []
-    )
+    let aux x accu = match x with Some b -> b @ accu | None -> accu in
+    Array.of_list (Array.fold_right aux pl [])
 
   let return disp pl f =
     let aux = function [x] -> Some (f x) | [] -> None | _ -> assert false in
@@ -1441,12 +1435,12 @@ struct
     let prep p = List.map (fun (res,r) -> (res,[],r)) p.Normal.nrecord in
     let pl0 = Array.map prep disp.pl in
     let t = Types.Record.get disp.t in
-    let r = dispatch_record_opt disp t pl0 in
+    let r = dispatch_record_opt disp t pl0 [] in
 (*    memo_dispatch_record := []; *)
     r
-  and dispatch_record_opt disp t pl =
+  and dispatch_record_opt disp t pl labs =
     if Types.Record.is_empty t then None 
-    else Some (dispatch_record_label disp t pl)
+    else Some (dispatch_record_label disp t pl labs)
 (*  and dispatch_record_label disp t pl =
     try List.assoc (t,pl) !memo_dispatch_record
     with Not_found ->
@@ -1458,7 +1452,7 @@ struct
       let r = !memo_dr_count, r in 
       memo_dispatch_record := ((t,pl),r) :: !memo_dispatch_record;
       r *)
-  and dispatch_record_label disp t pl =
+  and dispatch_record_label disp t pl labs =
     match collect_first_label pl with
       | None -> 
 	  let aux_final (res, catch, x) =
@@ -1479,36 +1473,32 @@ struct
 	  in
 	  (match (somefield,nofield) with
 	     | Some r1, Some r2 -> 
-		 if r1 = r2 then `Result r1 else `Result_other(r1,r2)
+		 if r1 = r2 then `Result r1 else `Result_other(labs,r1,r2)
 	     | Some r1, None -> `Result r1
 	     | None, Some r2 -> `Result r2
 	     | _ -> assert false)
       | Some l ->
+	  let labs = l :: labs in
 	  let (plabs,absent) = 
 	    let pl = label_not_found l pl in
 	    let t = Types.Record.restrict_label_absent t l in
-	    pl, dispatch_record_opt disp t pl
+	    pl, dispatch_record_opt disp t pl labs
 	  in
 	  let present =
 	    let pl = label_found l pl in
 	    let t = Types.Record.restrict_label_present t l in
-	    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)
-	      )
+	    if Types.Record.is_empty t then `None else 
+	      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 labs)
+		(fun x -> combine x)
 	  in
-	  (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 =
+	  combine_record l present absent
+  and dispatch_record_field l disp t plabs labs tfield pl others =
     let t = Types.Record.restrict_field t l tfield in
     let aux (ret, ncatchv, (res, catch, rem)) = 
       let catch = if ret = [] then catch else (l,ret) :: catch in
@@ -1526,7 +1516,7 @@ struct
 	 Need to investigate ....
       *)
 	 
-    dispatch_record_label disp t pl
+    dispatch_record_label disp t pl labs
     
       
   let actions disp =
@@ -1638,9 +1628,8 @@ struct
 	  Format.fprintf ppf "     @[%a@]@\n"  print_record r
     and print_record ppf = function
       | `Result r -> Format.fprintf ppf "%a" print_ret r
-      | `Result_other (r1,r2) -> Format.fprintf ppf "SomeField:%a;NoField:%a" 
+      | `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
 	  Format.fprintf ppf "check label %s:@\n" l;

types/patterns.mli

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