[r2002-10-27 07:00:51 by cvscast] Empty log message

Original author: cvscast
Date: 2002-10-27 07:00:51+00:00

runtime/value.ml

@@ -116,7 +116,11 @@ let dummy_r = [||]
 
 let rec run_dispatcher d v = 
   let actions = Patterns.Compile.actions d in
-  match v with
+  match actions with
+    | `Ignore r -> make_result_basic v r
+    | `Kind k -> run_disp_kind k v
+
+and run_disp_kind actions v = match v with
   | Pair (v1,v2) -> run_disp_prod v v1 v2 actions.Patterns.Compile.prod
   | Record r -> run_disp_record v [] r actions.Patterns.Compile.record
   | Atom a -> 

types/patterns.ml

@@ -324,7 +324,10 @@ end
 
 module Compile = 
 struct
-  type actions = {
+  type actions =
+      [ `Ignore of result
+      | `Kind of actions_kind ]
+  and actions_kind = {
     basic: (Types.descr * result) list;
     prod: result dispatch dispatch;
     record: record option;
@@ -378,6 +381,27 @@ struct
     in
     aux f a 0
 
+  let combine_kind basic prod record =
+    try (
+      let rs = [] in
+      let rs = match basic with
+	| [_,r] -> r :: rs
+	| [] -> rs
+	| _ -> raise Exit in
+      let rs = match prod with
+	| `None -> rs
+	| `Ignore (`Ignore r) -> r :: rs
+	| _ -> raise Exit in
+      let rs = match record with
+	| None -> rs
+	| Some (`Result r) -> r :: rs
+	| _ -> raise Exit in
+      match rs with
+	| r :: rs when List.for_all ( (=) r ) rs -> `Ignore r
+	| _ -> raise Exit
+    )
+    with Exit -> `Kind { basic = basic; prod = prod; record = record }
+
   let combine (disp,act) =
     if Array.length act = 0 then `None
     else
@@ -705,11 +729,11 @@ struct
     match disp.actions with
       | Some a -> a
       | None ->
-	  let a = {
-	    basic = dispatch_basic disp;
-	    prod  = dispatch_prod disp;
-	    record = dispatch_record disp;
-	  } in
+	  let a = combine_kind
+		    (dispatch_basic disp)
+		    (dispatch_prod disp)
+		    (dispatch_record disp)
+	  in
 	  disp.actions <- Some a;
 	  a
 
@@ -722,26 +746,27 @@ struct
       to_print := d :: !to_print
     )
 
-  let print_actions ppf actions =
-    let print_source ppf = function
-      | `Catch  -> Format.fprintf ppf "v"
-      | `Const c -> Types.Print.print_const ppf c
-      | `Left i -> Format.fprintf ppf "l%i" i
-      | `Right j -> Format.fprintf ppf "r%i" j
-      | `Recompose (i,j) -> Format.fprintf ppf "(l%i,r%i)" i j
-      | `Field (l,i) -> Format.fprintf ppf "%s%i" (Types.label_name l) i
-    in
-    let print_result ppf =
-      Array.iteri 
-	(fun i s ->
-	   if i > 0 then Format.fprintf ppf ",";
-	  print_source ppf s; 
-	)
-    in
-    let print_ret ppf (code,ret) = 
-      Format.fprintf ppf "$%i" code;
-      if Array.length ret <> 0 then 
-	Format.fprintf ppf "(%a)" print_result ret in
+  let print_source ppf = function
+    | `Catch  -> Format.fprintf ppf "v"
+    | `Const c -> Types.Print.print_const ppf c
+    | `Left i -> Format.fprintf ppf "l%i" i
+    | `Right j -> Format.fprintf ppf "r%i" j
+    | `Recompose (i,j) -> Format.fprintf ppf "(l%i,r%i)" i j
+    | `Field (l,i) -> Format.fprintf ppf "%s%i" (Types.label_name l) i
+
+  let print_result ppf =
+    Array.iteri 
+      (fun i s ->
+	 if i > 0 then Format.fprintf ppf ",";
+	 print_source ppf s; 
+      )
+
+  let print_ret ppf (code,ret) = 
+    Format.fprintf ppf "$%i" code;
+    if Array.length ret <> 0 then 
+      Format.fprintf ppf "(%a)" print_result ret
+
+  let print_kind ppf actions =
     let print_lhs ppf (code,prefix,d) =
       let arity = match d.codes.(code) with (_,a,_) -> a in
       Format.fprintf ppf "$%i(" code;
@@ -835,6 +860,10 @@ struct
     print_prod actions.prod;
     print_record_opt ppf actions.record
 
+  let print_actions ppf = function
+    | `Kind k -> print_kind ppf k
+    | `Ignore r -> Format.fprintf ppf "v -> %a@\n" print_ret r
+
   let rec print_dispatchers ppf =
     match !to_print with
       | [] -> ()

types/patterns.mli

@@ -41,7 +41,10 @@ module Compile: sig
   type dispatcher
   val dispatcher: Types.descr -> normal array -> dispatcher
 
-  type actions = {
+  type actions =
+      [ `Ignore of result
+      | `Kind of actions_kind ]
+  and actions_kind = {
     basic: (Types.descr * result) list;
     prod: result dispatch dispatch;
     record: record option;