corrected bug 325

git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@3481 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02

3 files changed, 110 insertions, 36 deletions

diff --git a/bytecomp/bytegen.ml b/bytecomp/bytegen.ml
index c71c1eac6c..0da180edff 100644
--- a/bytecomp/bytegen.ml
+++ b/bytecomp/bytegen.ml
@@ -115,31 +115,17 @@ let rec add_pop n cont =
     | Kreraise :: _ -> cont
     | _ -> Kpop n :: cont
 
-(* Translates the accumulator + n-1 positions, m places down on the stack *)
-let rec squeeze_rec i n m cont =
-  if i <= 1 then
-    Kacc 0::add_pop  (if m <= n then m+1 else  m-n+1) (Kpush::cont)
-  else
-    Kacc (i-1)::
-    Kassign (m+i-1)::
-    squeeze_rec (i-1) n m cont
-    
-
-let add_squeeze n m cont =
-  if n=0 then add_pop m cont
-  else if n=1 then add_pop m (Kpush::cont)
-  else if m=0 then Kpush::cont    
-  else
-    Kpush::
-    squeeze_rec n n m cont
-      
-    
 (* Add the constant "unit" in front of a continuation *)
 
 let add_const_unit = function
     (Kacc _ | Kconst _ | Kgetglobal _ | Kpush_retaddr _) :: _ as cont -> cont
   | cont -> Kconst const_unit :: cont
 
+let rec push_dummies n k = match n with
+| 0 -> k
+| _ -> Kconst const_unit::Kpush::push_dummies (n-1) k
+
+
 (**** Auxiliary for compiling "let rec" ****)
 
 let rec size_of_lambda = function
@@ -564,24 +550,45 @@ let rec comp_expr env exp sz cont =
       comp_args env args sz (comp_primitive p args :: cont)
   | Lprim(p, args) ->
       comp_args env args sz (comp_primitive p args :: cont)
-  | Lstaticcatch (body, (i, vars) , handler) ->
-      let branch1, cont1 = make_branch cont
-      and nvars = List.length vars in
-      let lbl_handler, cont2 =
-        label_code
-          (comp_expr
-             (add_vars vars (sz+1) env)
-             handler (sz+nvars) (add_pop nvars cont1)) in
-      sz_static_raises := (i, (lbl_handler, sz+nvars)) :: !sz_static_raises ;
-      let cont3 = comp_expr env body sz (branch1 :: cont2) in
+   | Lstaticcatch (body, (i, vars) , handler) ->      
+      let nvars = List.length vars in
+      let branch1, cont1 = make_branch cont in
+      let r = 
+        if nvars <> 1 then begin (* general case *)
+          let lbl_handler, cont2 =
+            label_code
+              (comp_expr
+                (add_vars vars (sz+1) env)
+                handler (sz+nvars) (add_pop nvars cont1)) in
+          sz_static_raises :=
+            (i, (lbl_handler, sz+nvars)) :: !sz_static_raises ;
+          push_dummies nvars
+            (comp_expr env body (sz+nvars)
+            (add_pop nvars (branch1 :: cont2)))
+        end else begin (* small optimization for nvars = 1 *)
+          let var = match vars with [var] -> var | _ -> assert false in
+          let lbl_handler, cont2 =
+            label_code
+              (Kpush::comp_expr
+                (add_var var (sz+1) env)
+                handler (sz+1) (add_pop 1 cont1)) in
+          sz_static_raises :=
+            (i, (lbl_handler, sz)) :: !sz_static_raises ;
+          comp_expr env body sz (branch1 :: cont2)
+        end in
       sz_static_raises := List.tl !sz_static_raises ;
-      cont3
+      r
   | Lstaticraise (i, args) ->
       let cont = discard_dead_code cont in
       let label,size = find_raise_label i in
-      comp_expr_list env args sz
-      (add_squeeze (List.length args) (sz+List.length args-size)
-         (branch_to label cont))
+      begin match args with
+      | [arg] -> (* optim, argument passed in accumulator *)
+          comp_expr env arg sz
+            (add_pop (sz-size) (branch_to label cont))
+      | _ ->
+          comp_exit_args env args sz size
+            (add_pop (sz-size) (branch_to label cont))
+      end
   | Ltrywith(body, id, handler) ->
       let (branch1, cont1) = make_branch cont in
       let lbl_handler = new_label() in
@@ -713,13 +720,21 @@ let rec comp_expr env exp sz cont =
 and comp_args env argl sz cont =
   comp_expr_list env (List.rev argl) sz cont
 
-and comp_expr_list env exprl sz cont =
-  match exprl with
+and comp_expr_list env exprl sz cont = match exprl with
     [] -> cont
   | [exp] -> comp_expr env exp sz cont
   | exp :: rem ->
       comp_expr env exp sz (Kpush :: comp_expr_list env rem (sz+1) cont)
 
+and comp_exit_args  env argl sz pos cont =
+   comp_expr_list_assign env (List.rev argl) sz pos cont
+
+and comp_expr_list_assign env exprl sz pos cont = match exprl with
+  | [] -> cont
+  | exp :: rem ->
+      comp_expr env exp sz
+        (Kassign (sz-pos)::comp_expr_list_assign env rem sz (pos-1) cont)
+
 (* Compile an if-then-else test. *)
 
 and comp_binary_test env cond ifso ifnot sz cont =
diff --git a/bytecomp/emitcode.ml b/bytecomp/emitcode.ml
index 64da57469b..c84159b510 100644
--- a/bytecomp/emitcode.ml
+++ b/bytecomp/emitcode.ml
@@ -327,6 +327,10 @@ let rec emit = function
         out_const k ;
         out_label lbl ;
         emit rem
+(* Some special case of push ; i ; ret generated by the match compiler *)
+  | Kpush :: Kacc 0 :: Kreturn m :: c ->
+      emit (Kreturn (m-1) :: c)
+(* General push then access scheme *)
   | Kpush :: Kacc n :: c ->
       if n < 8 then out(opPUSHACC0 + n) else (out opPUSHACC; out_int n);
       emit c
diff --git a/test/Moretest/morematch.ml b/test/Moretest/morematch.ml
index 0607fc3446..0ac0e9f749 100644
--- a/test/Moretest/morematch.ml
+++ b/test/Moretest/morematch.ml
@@ -1,3 +1,20 @@
+(**************************************************************)
+(*  This suite tests the pattern-matching compiler            *)
+(*  it should just compile and run.                           *)
+(*  While compiling the following messages are normal:        *)
+(**************************************************************)
+
+(*
+File "morematch.ml", line 21, characters 10-93:
+Warning: this pattern-matching is not exhaustive.
+Here is an example of a value that is not matched:
+0
+File "morematch.ml", line 376, characters 2-15:
+Warning: this match case is unused.
+File "morematch.ml", line 443, characters 2-7:
+Warning: this match case is unused.
+*)
+
 let test msg f arg r =
   if f arg <> r then begin
     prerr_endline msg ;
@@ -623,7 +640,7 @@ test "jerome_constr"
    replicaContent2shortString (`ABSENT, `PropsChanged) "assert false" ;
 ;;
 
-(* Ohl's bug *)
+(* bug 319 *)
 
 type ab = A of int | B of int
 type cd = C | D
@@ -636,6 +653,8 @@ let ohl = function
 test "ohl" ohl (A 0,C) 0 ;
 test "ohl" ohl (B 0,D) 0 ; ()
 ;;
+
+(* bug 324 *)
 type pottier =
   | A
   | B
@@ -652,3 +671,39 @@ test "pottier" pottier ((B,2),B) true ;
 test "pottier" pottier ((A,2),A) true ; ()
 ;;
 
+(* bug 325 in bytecode compiler *)
+let coquery q =  match q with
+| y,0,([modu;defs]| [defs;modu;_]) -> y+defs-modu
+| _ -> 0
+;;
+
+test "coquery" coquery (1,0,[1 ; 2 ; 3]) 0 ;
+test "coquery" coquery (1,0,[1 ; 2]) 2 ; ()
+;;
+
+(*
+  Two other variable in or-pat tests
+*)
+type vars = A of int | B of (int * int) | C
+;;
+
+
+let vars1 = function
+  | (A x | B (_,x)) -> x
+  | C -> 0
+;;
+
+test "vars1" vars1 (A 1) 1 ;
+test "vars1" vars1 (B (1,2)) 2 ; ()
+;;
+
+let vars2 = function
+  | ([x]|[1 ; x ]|[1 ; 2 ; x]) -> x
+  | _ -> 0
+;;
+
+test"vars2" vars2 [1] 1 ;
+test"vars2" vars2 [1;2] 2 ;
+test"vars2" vars2 [1;2;3] 3 ;
+test"vars2" vars2 [0 ; 0] 0 ; ()
+;;