1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
|
(***********************************************************************)
(* *)
(* Objective Caml *)
(* *)
(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *)
(* Objective Caml 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 = "") or (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)))
|
