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