ocaml/debugger/pattern_matching.ml

(***********************************************************************)
(*                                                                     *)
(*                                OCaml                                *)
(*                                                                     *)
(*          Jerome Vouillon, projet Cristal, INRIA Rocquencourt        *)
(*          OCaml port by John Malecki and Xavier Leroy                *)
(*                                                                     *)
(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
(*  en Automatique.  All rights reserved.  This file is distributed    *)
(*  under the terms of the Q Public License version 1.0.               *)
(*                                                                     *)
(***********************************************************************)

(* $Id$ *)

(************************ Simple pattern matching **********************)

open Debugger_config
(*open Primitives*)
open Misc
(*open Const*)
(*open Globals*)
(*open Builtins*)
open Typedtree
(*open Modules*)
(*open Symtable*)
(*open Value*)
open Parser_aux

(*
let rec find_constr tag = function
    [] ->
      fatal_error "find_constr: unknown constructor for this type"
  | constr::rest ->
      match constr.info.cs_tag with
        ConstrRegular(t, _) ->
          if t == tag then constr else find_constr tag rest
      | ConstrExtensible _ ->
          fatal_error "find_constr: extensible"

let find_exception tag =
  let (qualid, stamp) = get_exn_of_num tag in
  let rec select_exn = function
    [] ->
      raise Not_found
  | constr :: rest ->
      match constr.info.cs_tag with
        ConstrExtensible(_,st) ->
          if st == stamp then constr else select_exn rest
      | ConstrRegular(_,_) ->
          fatal_error "find_exception: regular" in
  select_exn(hashtbl__find_all (find_module qualid.qual).mod_constrs qualid.id)
*)

let error_matching () =
  prerr_endline "Pattern matching failed";
  raise Toplevel

(*
let same_name {qualid = name1} =
  function
    GRname name2 ->
      (name2 = "") || (name1.id = name2)
  | GRmodname name2 ->
      name1 = name2

let check_same_constr constr constr2 =
  try
    if not (same_name constr constr2) then
      error_matching ()
  with
    Desc_not_found ->
      prerr_endline "Undefined constructor.";
      raise Toplevel
*)

let rec pattern_matching pattern obj ty =
  match pattern with
    P_dummy ->
      []
  | P_variable var ->
      [var, obj, ty]
  | _ ->
    match (Ctype.repr ty).desc with
      Tvar | Tarrow _ ->
        error_matching ()
    | Ttuple(ty_list) ->
        (match pattern with
           P_tuple pattern_list ->
             pattern_matching_list pattern_list obj ty_list
         | P_nth (n, patt) ->
             if n >= List.length ty_list then
               (prerr_endline "Out of range."; raise Toplevel);
             pattern_matching patt (Debugcom.get_field obj n) (List.nth ty_list n)
         | _ ->
             error_matching ())
    | Tconstr(cstr, [ty_arg],_) when same_type_constr cstr constr_type_list ->
        (match pattern with
           P_list pattern_list ->
             let (last, list) =
               it_list
                 (fun (current, list) pattern ->
                    if value_tag current = 0 then error_matching ();
                    (Debugcom.get_field current 1,
                     (pattern, Debugcom.get_field current 0)::list))
                 (obj, [])
                 pattern_list
             in
               if value_tag last <> 0 then error_matching ();
               flat_map
                 (function (x, y) -> pattern_matching x y ty_arg)
                 (rev list)
         | P_nth (n, patt) ->
             let rec find k current =
               if value_tag current = 0 then
                 (prerr_endline "Out of range."; raise Toplevel);
               if k = 0 then
                 pattern_matching patt (Debugcom.get_field current 0) ty_arg
               else
                 find (k - 1) (Debugcom.get_field current 1)
             in
               find n obj
         | P_concat (pattern1, pattern2) ->
             if value_tag obj == 0 then error_matching ();
             (pattern_matching pattern1 (Debugcom.get_field obj 0) ty_arg)
                @ (pattern_matching pattern2 (Debugcom.get_field obj 1) ty)
         | _ ->
             error_matching ())
    | Tconstr(cstr, [ty_arg]) when same_type_constr cstr constr_type_vect ->
        (match pattern with
           P_nth (n, patt) ->
             if n >= value_size obj then
               (prerr_endline "Out of range."; raise Toplevel);
             pattern_matching patt (Debugcom.get_field obj n) ty_arg
         | _ ->
             error_matching ())
    | Tconstr(cstr, ty_list) ->
        (match cstr.info.ty_abbr with
           Tabbrev(params, body) ->
             pattern_matching pattern obj (expand_abbrev params body ty_list)
         | _ ->
             match_concrete_type pattern obj cstr ty ty_list)

and match_concrete_type pattern obj cstr ty ty_list =
  let typ_descr =
    type_descr_of_type_constr cstr in
  match typ_descr.info.ty_desc with
    Abstract_type ->
      error_matching ()
  | Variant_type constr_list ->
      let tag = value_tag obj in
        (try
           let constr =
             if same_type_constr cstr constr_type_exn then
               find_exception tag
             else
               find_constr tag constr_list
           in
             let (ty_res, ty_arg) =
               type_pair_instance (constr.info.cs_res, constr.info.cs_arg)
             in
               filter (ty_res, ty);
               match constr.info.cs_kind with
                 Constr_constant ->
                   error_matching ()
               | Constr_regular ->
                   (match pattern with
                      P_constr (constr2, patt) ->
                        check_same_constr constr constr2;
                        pattern_matching patt (Debugcom.get_field obj 0) ty_arg
                    | _ ->
                        error_matching ())
               | Constr_superfluous n ->
                   (match pattern with
                      P_constr (constr2, patt) ->
                        check_same_constr constr constr2;
                        (match patt with
                           P_tuple pattern_list ->
                             pattern_matching_list
                               pattern_list
                               obj
                               (filter_product n ty_arg)
                         | P_nth (n2, patt) ->
                             let ty_list = filter_product n ty_arg in
                               if n2 >= n then
                                 (prerr_endline "Out of range.";
                                  raise Toplevel);
                               pattern_matching
                                 patt
                                 (Debugcom.get_field obj n2)
                                 (List.nth ty_list n2)
                         | P_variable var ->
                             [var,
                              obj,
                              {typ_desc = Tproduct (filter_product n ty_arg);
                               typ_level = generic}]
                         | P_dummy ->
                             []
                         | _ ->
                             error_matching ())
                    | _ ->
                        error_matching ())
         with
           Not_found ->
             error_matching ()
         | Unify ->
             fatal_error "pattern_matching: types should match")
  | Record_type label_list ->
      let match_field (label, patt) =
        let lbl =
          try
            primitives__find
              (function l -> same_name l label)
              label_list
          with Not_found ->
              prerr_endline "Label not found.";
              raise Toplevel
        in
          let (ty_res, ty_arg) =
            type_pair_instance (lbl.info.lbl_res, lbl.info.lbl_arg)
          in
            (try
               filter (ty_res, ty)
             with Unify ->
               fatal_error "pattern_matching: types should match");
            pattern_matching patt (Debugcom.get_field obj lbl.info.lbl_pos) ty_arg
      in
        (match pattern with
           P_record pattern_label_list ->
             flat_map match_field pattern_label_list
         | _ ->
             error_matching ())
  | Abbrev_type(_,_) ->
      fatal_error "pattern_matching: abbrev type"

and pattern_matching_list pattern_list obj ty_list =
  let val_list =
    try
      pair__combine (pattern_list, ty_list)
    with
      Invalid_argument _ -> error_matching ()
  in
    flat_map
      (function (x, y, z) -> pattern_matching x y z)
      (rev
         (snd
            (it_list
               (fun (num, list) (pattern, typ) ->
                  (num + 1, (pattern, Debugcom.get_field obj num, typ)::list))
               (0, [])
               val_list)))