1: # 14 "./lpsrc/flx_pat.ipk"
2: open Flx_util
3: open Flx_ast
4: open Flx_print
5: open Flx_typing
6: open List
7: open Flx_srcref
8: open Flx_exceptions
9:
10: (* These routine just check that the shape of a list
11: of patterns match the pattern class indicated by their names.
12:
13: These routines are used for class based desugaring.
14: Note that type correctness isn't checked, since
15: type binding isn't done yet.
16: *)
17:
18: let rec check_match_int pats =
19: let rec check pat = match pat with
20: | `PAT_any _
21: | `PAT_int _
22: | `PAT_int_range _
23: | `PAT_name _ -> ()
24:
25: | `PAT_coercion (_,pat,_)
26: | `PAT_as (_,pat,_)
27: | `PAT_when (_,pat,_) -> check pat
28: | _ ->
29: let sr = src_of_pat pat in clierr sr
30: (
31: "Integer pattern expected"
32: )
33: in
34: List.iter check pats
35:
36: and check_match_string pats =
37: let rec check pat = match pat with
38: | `PAT_any _
39: | `PAT_string _
40: | `PAT_string_range _
41: | `PAT_regexp _
42: | `PAT_name _ -> ()
43:
44: | `PAT_coercion (_,pat,_)
45: | `PAT_as (_,pat,_)
46: | `PAT_when (_,pat,_) -> check pat
47: | _ ->
48: let sr = src_of_pat pat in clierr sr
49: (
50: "String pattern expected"
51: )
52: in
53: List.iter check pats
54:
55: and check_match_float pats =
56: let rec check pat = match pat with
57: | `PAT_none _ -> assert false
58: | `PAT_nan _
59: | `PAT_any _
60: | `PAT_float_range _
61: | `PAT_name _ -> ()
62: | `PAT_coercion (_,pat,_)
63: | `PAT_as (_,pat,_)
64: | `PAT_when (_,pat,_) -> check pat
65: | _ ->
66: let sr = src_of_pat pat in clierr sr
67: (
68: "Float pattern expected"
69: )
70: in
71: List.iter check pats
72:
73: and check_match_record pats =
74: let rec check pat = match pat with
75: | `PAT_record _
76: | `PAT_any _
77: | `PAT_name _ -> ()
78:
79: | `PAT_as (_,pat,_)
80: | `PAT_coercion (_,pat,_)
81: | `PAT_when (_,pat,_) -> check pat
82: | _ ->
83: let sr = src_of_pat pat in clierr sr
84: "Record pattern expected"
85: in
86: List.iter check pats
87:
88: and check_match_tuple n pats =
89: let rec check n pat = match pat with
90: | `PAT_any _
91: | `PAT_name _ -> ()
92: | `PAT_tuple (sr,pats) ->
93: if List.length pats <> n
94: then let sr = src_of_pat pat in clierr sr
95: (
96: "Tuple pattern wrong length"
97: )
98: | `PAT_coercion (_,pat,_)
99: | `PAT_as (_,pat,_)
100: | `PAT_when (_,pat,_) -> check n pat
101: | _ ->
102: let sr = src_of_pat pat in clierr sr
103: (
104: "Tuple pattern expected"
105: )
106: in
107: List.iter (check n) pats
108: ;
109: let rec match_split pat = match pat with
110: | `PAT_any _ -> []
111: | `PAT_name _ -> []
112:
113: | `PAT_coercion (_,pat,_)
114: | `PAT_as (_,pat,_)
115: | `PAT_when (_,pat,_) -> match_split pat
116:
117: | `PAT_tuple (_,ps) -> ps
118: | _ ->
119: let sr = src_of_pat pat in clierr sr
120: (
121: "Tuple pattern expected"
122: )
123: in let tpats =
124: try
125: Flx_util.transpose
126: (
127: List.filter
128: (function | [] -> false | _ -> true)
129: (List.map match_split pats)
130: )
131: with _ -> failwith "Transpose failed"
132: in
133: List.iter
134: (fun pats ->
135: if List.length pats = 0
136: then failwith "Null list?"
137: else find_match_type (List.hd pats) pats
138: )
139: tpats
140:
141: and check_match_union pats =
142: let rec check pat = match pat with
143: | `PAT_any _
144: | `PAT_nonconst_ctor _
145: | `PAT_const_ctor _
146: | `PAT_name _ -> ()
147:
148: | `PAT_coercion (_,pat,_)
149: | `PAT_as (_,pat,_)
150: | `PAT_when (_,pat,_) -> check pat
151: | _ ->
152: let sr = src_of_pat pat in clierr sr
153: (
154: short_string_of_src (src_of_pat pat) ^
155: ": union pattern expected"
156: )
157: in
158: List.iter check pats
159:
160: and renaming pats = ()
161:
162: (* This routine finds the checker routine for given
163: pattern. Note that 'renaming' checks nothing:
164: if this kind is the head of a match list,
165: the following matches will never be executed.
166: [They should be checked for correctness anyhow ..
167: but instead, we consider this an error temporarily
168: ]
169: *)
170: and find_match_type pat = match pat with
171: | `PAT_none _ -> assert false
172: | `PAT_nan _ -> check_match_float
173: | `PAT_int _ -> check_match_int
174: | `PAT_string _ -> check_match_string
175:
176: (* ranges *)
177: | `PAT_int_range _ -> check_match_int
178: | `PAT_string_range _ -> check_match_string
179: | `PAT_float_range _ -> check_match_float
180:
181: (* other *)
182: | `PAT_name _ -> renaming
183: | `PAT_tuple (_,pats) -> check_match_tuple (List.length pats)
184: | `PAT_any _ -> renaming
185: | `PAT_regexp _ -> check_match_string
186: | `PAT_const_ctor _ -> check_match_union
187: | `PAT_nonconst_ctor _ -> check_match_union
188: | `PAT_record (_,_) -> check_match_record
189:
190: | `PAT_as (_,pat,_)
191: | `PAT_when (_,pat,_)
192: | `PAT_coercion (_,pat,_) -> find_match_type pat
193:
194: (* This routine is used to check all but the last
195: pattern match isn't a match all
196: *)
197:
198: let rec is_universal pat = match pat with
199: | `PAT_any _
200: | `PAT_name (_,_)
201: | `PAT_float_range (_, Float_minus_inf, Float_inf)
202: -> true
203:
204: | `PAT_as (_,pat,_) -> is_universal pat
205: | `PAT_coercion (_,pat,_) -> is_universal pat
206: | `PAT_tuple (_,ps) -> fold_left (fun a p -> a && is_universal p) true ps
207:
208: | _ -> false
209:
210: let rec check_terminal pat = match pat with
211: | `PAT_any sr ->
212: failwith
213: (
214: "'Any' pattern '_' must be last in match in " ^
215: short_string_of_src sr
216: )
217: | `PAT_name (sr,x) ->
218: failwith
219: (
220: "'Name' pattern '"^x^"' must be last in match in " ^
221: short_string_of_src sr
222: )
223: | `PAT_float_range (sr, Float_minus_inf, Float_inf) ->
224: failwith
225: (
226: "Whole floating range must be last in match in " ^
227: short_string_of_src sr
228: )
229:
230: | `PAT_as (_,pat,_) -> check_terminal pat
231: | `PAT_coercion (_,pat,_) -> check_terminal pat
232: | _ -> ()
233:
234: let validate_patterns pats =
235: if List.length pats = 0
236: then failwith "Empty pattern list";
237: let hpat = List.hd pats in
238: let checker = find_match_type hpat in
239: checker pats;
240: List.iter check_terminal (List.tl (List.rev pats));
241: List.iter
242: (fun x -> match x with
243: | `PAT_none sr -> assert false
244: | `PAT_nan sr ->
245: failwith
246: (
247: "NaN test must be first in match in " ^
248: short_string_of_src sr
249: )
250: | _ -> ()
251: )
252: (List.tl pats)
253: