1(**************************************************************************)
2(*                                                                        *)
3(*                                 OCaml                                  *)
4(*                                                                        *)
5(*           Jerome Vouillon, projet Cristal, INRIA Rocquencourt          *)
6(*           OCaml port by John Malecki and Xavier Leroy                  *)
7(*                                                                        *)
8(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
9(*     en Automatique.                                                    *)
10(*                                                                        *)
11(*   All rights reserved.  This file is distributed under the terms of    *)
12(*   the GNU Lesser General Public License version 2.1, with the          *)
13(*   special exception on linking described in the file LICENSE.          *)
14(*                                                                        *)
15(**************************************************************************)
16
17(************************ Simple pattern matching **********************)
18
19open Debugger_config
20(*open Primitives*)
21open Misc
22(*open Const*)
23(*open Globals*)
24(*open Builtins*)
25open Typedtree
26(*open Modules*)
27(*open Symtable*)
28(*open Value*)
29open Parser_aux
30
31(*
32let rec find_constr tag = function
33    [] ->
34      fatal_error "find_constr: unknown constructor for this type"
35  | constr::rest ->
36      match constr.info.cs_tag with
37        ConstrRegular(t, _) ->
38          if t == tag then constr else find_constr tag rest
39      | ConstrExtensible _ ->
40          fatal_error "find_constr: extensible"
41
42let find_exception tag =
43  let (qualid, stamp) = get_exn_of_num tag in
44  let rec select_exn = function
45    [] ->
46      raise Not_found
47  | constr :: rest ->
48      match constr.info.cs_tag with
49        ConstrExtensible(_,st) ->
50          if st == stamp then constr else select_exn rest
51      | ConstrRegular(_,_) ->
52          fatal_error "find_exception: regular" in
53  select_exn(hashtbl__find_all (find_module qualid.qual).mod_constrs qualid.id)
54*)
55
56let error_matching () =
57  prerr_endline "Pattern matching failed";
58  raise Toplevel
59
60(*
61let same_name {qualid = name1} =
62  function
63    GRname name2 ->
64      (name2 = "") || (name1.id = name2)
65  | GRmodname name2 ->
66      name1 = name2
67
68let check_same_constr constr constr2 =
69  try
70    if not (same_name constr constr2) then
71      error_matching ()
72  with
73    Desc_not_found ->
74      prerr_endline "Undefined constructor.";
75      raise Toplevel
76*)
77
78let rec pattern_matching pattern obj ty =
79  match pattern with
80    P_dummy ->
81      []
82  | P_variable var ->
83      [var, obj, ty]
84  | _ ->
85    match (Ctype.repr ty).desc with
86      Tvar | Tarrow _ ->
87        error_matching ()
88    | Ttuple(ty_list) ->
89        (match pattern with
90           P_tuple pattern_list ->
91             pattern_matching_list pattern_list obj ty_list
92         | P_nth (n, patt) ->
93             if n >= List.length ty_list then
94               (prerr_endline "Out of range."; raise Toplevel);
95             pattern_matching patt (Debugcom.get_field obj n)
96                              (List.nth ty_list n)
97         | _ ->
98             error_matching ())
99    | Tconstr(cstr, [ty_arg],_) when same_type_constr cstr constr_type_list ->
100        (match pattern with
101           P_list pattern_list ->
102             let (last, list) =
103               it_list
104                 (fun (current, list) pattern ->
105                    if value_tag current = 0 then error_matching ();
106                    (Debugcom.get_field current 1,
107                     (pattern, Debugcom.get_field current 0)::list))
108                 (obj, [])
109                 pattern_list
110             in
111               if value_tag last <> 0 then error_matching ();
112               flat_map
113                 (function (x, y) -> pattern_matching x y ty_arg)
114                 (rev list)
115         | P_nth (n, patt) ->
116             let rec find k current =
117               if value_tag current = 0 then
118                 (prerr_endline "Out of range."; raise Toplevel);
119               if k = 0 then
120                 pattern_matching patt (Debugcom.get_field current 0) ty_arg
121               else
122                 find (k - 1) (Debugcom.get_field current 1)
123             in
124               find n obj
125         | P_concat (pattern1, pattern2) ->
126             if value_tag obj == 0 then error_matching ();
127             (pattern_matching pattern1 (Debugcom.get_field obj 0) ty_arg)
128                @ (pattern_matching pattern2 (Debugcom.get_field obj 1) ty)
129         | _ ->
130             error_matching ())
131    | Tconstr(cstr, [ty_arg]) when same_type_constr cstr constr_type_vect ->
132        (match pattern with
133           P_nth (n, patt) ->
134             if n >= value_size obj then
135               (prerr_endline "Out of range."; raise Toplevel);
136             pattern_matching patt (Debugcom.get_field obj n) ty_arg
137         | _ ->
138             error_matching ())
139    | Tconstr(cstr, ty_list) ->
140        (match cstr.info.ty_abbr with
141           Tabbrev(params, body) ->
142             pattern_matching pattern obj (expand_abbrev params body ty_list)
143         | _ ->
144             match_concrete_type pattern obj cstr ty ty_list)
145
146and match_concrete_type pattern obj cstr ty ty_list =
147  let typ_descr =
148    type_descr_of_type_constr cstr in
149  match typ_descr.info.ty_desc with
150    Abstract_type ->
151      error_matching ()
152  | Variant_type constr_list ->
153      let tag = value_tag obj in
154        (try
155           let constr =
156             if same_type_constr cstr constr_type_exn then
157               find_exception tag
158             else
159               find_constr tag constr_list
160           in
161             let (ty_res, ty_arg) =
162               type_pair_instance (constr.info.cs_res, constr.info.cs_arg)
163             in
164               filter (ty_res, ty);
165               match constr.info.cs_kind with
166                 Constr_constant ->
167                   error_matching ()
168               | Constr_regular ->
169                   (match pattern with
170                      P_constr (constr2, patt) ->
171                        check_same_constr constr constr2;
172                        pattern_matching patt (Debugcom.get_field obj 0) ty_arg
173                    | _ ->
174                        error_matching ())
175               | Constr_superfluous n ->
176                   (match pattern with
177                      P_constr (constr2, patt) ->
178                        check_same_constr constr constr2;
179                        (match patt with
180                           P_tuple pattern_list ->
181                             pattern_matching_list
182                               pattern_list
183                               obj
184                               (filter_product n ty_arg)
185                         | P_nth (n2, patt) ->
186                             let ty_list = filter_product n ty_arg in
187                               if n2 >= n then
188                                 (prerr_endline "Out of range.";
189                                  raise Toplevel);
190                               pattern_matching
191                                 patt
192                                 (Debugcom.get_field obj n2)
193                                 (List.nth ty_list n2)
194                         | P_variable var ->
195                             [var,
196                              obj,
197                              {typ_desc = Tproduct (filter_product n ty_arg);
198                               typ_level = generic}]
199                         | P_dummy ->
200                             []
201                         | _ ->
202                             error_matching ())
203                    | _ ->
204                        error_matching ())
205         with
206           Not_found ->
207             error_matching ()
208         | Unify ->
209             fatal_error "pattern_matching: types should match")
210  | Record_type label_list ->
211      let match_field (label, patt) =
212        let lbl =
213          try
214            primitives__find
215              (function l -> same_name l label)
216              label_list
217          with Not_found ->
218              prerr_endline "Label not found.";
219              raise Toplevel
220        in
221          let (ty_res, ty_arg) =
222            type_pair_instance (lbl.info.lbl_res, lbl.info.lbl_arg)
223          in
224            (try
225               filter (ty_res, ty)
226             with Unify ->
227               fatal_error "pattern_matching: types should match");
228            pattern_matching patt (Debugcom.get_field obj lbl.info.lbl_pos)
229                             ty_arg
230      in
231        (match pattern with
232           P_record pattern_label_list ->
233             flat_map match_field pattern_label_list
234         | _ ->
235             error_matching ())
236  | Abbrev_type(_,_) ->
237      fatal_error "pattern_matching: abbrev type"
238
239and pattern_matching_list pattern_list obj ty_list =
240  let val_list =
241    try
242      pair__combine (pattern_list, ty_list)
243    with
244      Invalid_argument _ -> error_matching ()
245  in
246    flat_map
247      (function (x, y, z) -> pattern_matching x y z)
248      (rev
249         (snd
250            (it_list
251               (fun (num, list) (pattern, typ) ->
252                  (num + 1, (pattern, Debugcom.get_field obj num, typ)::list))
253               (0, [])
254               val_list)))
255