1: # 33 "./lpsrc/flx_mbind.ipk"
2: open Flx_util
3: open Flx_ast
4: open Flx_types
5: open Flx_print
6: open Flx_typing
7: open Flx_lookup
8: open Flx_srcref
9: open Flx_typing
10: open Flx_exceptions
11: open List
12:
13: type extract_t =
14: | Proj_n of range_srcref * int (* tuple projections 1 .. n *)
15: | Udtor of range_srcref * qualified_name_t (* argument of union component s *)
16: | Proj_s of range_srcref * string (* record projection name *)
17:
18: (* the extractor is a function to be applied to
19: the argument to extract the value of the identifier;
20: it is represented here as a list of functions
21: to be applied, with the function at the top
22: of the list to be applied last.
23:
24: Note that the difference between an abstract
25: extractor and a concrete one is that the
26: abstract one isn't applied to anything,
27: while the concrete one is applied to a specific
28: expression.
29: *)
30:
31: let gen_extractor
32: (extractor : extract_t list)
33: (mv : expr_t)
34: : expr_t =
35: List.fold_right
36: (fun x marg -> match x with
37: | Proj_n (sr,n) -> `AST_get_n (sr,(n,marg))
38: | Udtor (sr,qn) -> `AST_ctor_arg (sr,(qn,marg))
39: | Proj_s (sr,s) -> `AST_get_named_variable (sr,(s,marg))
40: )
41: extractor
42: mv
43:
44: (* this routine is used to substitute match variables
45: in a when expression with their bindings ..
46: it needs to be completed!!!
47: *)
48: let rec subst vars (e:expr_t) mv : expr_t =
49: let subst e = subst vars e mv in
50: (* FIXME: most of these cases are legal, the when clause should
51: be made into a function call to an arbitrary function, passing
52: the match variables as arguments.
53:
54: We can do this now, since we have type extractors matching
55: the structure extractors Proj_n and Udtor (ie, we can
56: name the types of the arguments now)
57: *)
58: match e with
59: | `AST_vsprintf _
60: | `AST_type_match _
61: | `AST_noexpand _
62: | `AST_letin _
63: | `AST_cond _
64: | `AST_expr _
65: | `AST_typeof _
66: | `AST_product _
67: | `AST_void _
68: | `AST_sum _
69: | `AST_andlist _
70: | `AST_orlist _
71: | `AST_typed_case _
72: | `AST_case_arg _
73: | `AST_arrow _
74: | `AST_longarrow _
75: | `AST_superscript _
76: | `AST_match _
77: | `AST_regmatch _
78: | `AST_string_regmatch _
79: | `AST_reglex _
80: | `AST_ellipsis _
81: | `AST_parse _
82: | `AST_sparse _
83: | `AST_setunion _
84: | `AST_setintersection _
85: | `AST_macro_ctor _
86: | `AST_macro_statements _
87: | `AST_callback _
88: | `AST_record_type _
89: | `AST_variant_type _
90: ->
91: let sr = src_of_expr e in
92: clierr sr "[mbind:subst] Not expected in when part of pattern"
93:
94: | `AST_case_index _ -> e
95: | `AST_index _ -> e
96: | `AST_the _ -> e
97: | `AST_lookup _ -> e
98: | `AST_suffix _ -> e
99: | `AST_literal _ -> e
100: | `AST_case_tag _ -> e
101: | `AST_as _ -> e
102:
103: | `AST_name (sr,name,idx) ->
104: if idx = [] then
105: if Hashtbl.mem vars name
106: then
107: let sr,extractor = Hashtbl.find vars name in
108: gen_extractor extractor mv
109: else e
110: else failwith "Can't use indexed name in when clause :("
111:
112:
113:
114: | `AST_deref (sr,e') -> `AST_deref (sr,subst e')
115: | `AST_ref (sr,e') -> `AST_ref (sr,subst e')
116: | `AST_lvalue (sr,e') -> `AST_lvalue (sr,subst e')
117: | `AST_apply (sr,(f,e)) -> `AST_apply (sr,(subst f,subst e))
118: | `AST_map (sr,f,e) -> `AST_map (sr,subst f,subst e)
119: | `AST_tuple (sr,es) -> `AST_tuple (sr,map subst es)
120: | `AST_record (sr,es) -> `AST_record (sr,map (fun (s,e)->s,subst e) es)
121: | `AST_variant (sr,(s,e)) -> `AST_variant (sr,(s,subst e))
122: | `AST_arrayof (sr,es) -> `AST_arrayof (sr,map subst es)
123:
124:
125: (* Only one of these should occur, but I can't
126: figure out which one at the moment
127: *)
128: | `AST_method_apply (sr,(id,e,ts)) ->
129: `AST_method_apply (sr,(id, subst e,ts))
130:
131: | `AST_dot (sr,(e,id,ts)) ->
132: `AST_dot (sr,(subst e, id,ts))
133:
134: | `AST_lambda _ -> assert false
135:
136: | `AST_match_case _
137: | `AST_ctor_arg _
138: | `AST_get_n _
139: | `AST_get_named_variable _
140: | `AST_get_named_method _
141: | `AST_match_ctor _
142: ->
143: let sr = src_of_expr e in
144: clierr sr "[subst] not implemented in when part of pattern"
145:
146: | `AST_coercion _ -> failwith "subst: coercion"
147:
148: (* This routine runs through a pattern looking for
149: pattern variables, and adds a record to a hashtable
150: keyed by each variable name. The data recorded
151: is the list of extractors which must be applied
152: to 'deconstruct' the data type to get the part
153: which the variable denotes in the pattern
154:
155: for example, for the pattern
156:
157: | Ctor (1,(x,_))
158:
159: the extractor for x is
160:
161: [Udtor "Ctor"; Proj_n 2; Proj_n 1]
162:
163: since x is the first component of the second
164: component of the argument of the constructor "Ctor"
165: *)
166:
167: let rec get_pattern_vars
168: vars (* Hashtable of variable -> range_srcref * extractor *)
169: pat (* pattern *)
170: extractor (* extractor for this pattern *)
171: =
172: match pat with
173: | `PAT_name (sr,id) -> Hashtbl.add vars id (sr,extractor)
174:
175: | `PAT_tuple (sr,pats) ->
176: let n = ref 0 in
177: List.iter
178: (fun pat ->
179: let sr = src_of_pat pat in
180: let extractor' = (Proj_n (sr,!n)) :: extractor in
181: incr n;
182: get_pattern_vars vars pat extractor'
183: )
184: pats
185:
186: | `PAT_regexp _ ->
187: failwith "[get_pattern_vars] Can't handle regexp yet"
188:
189: | `PAT_nonconst_ctor (sr,name,pat) ->
190: let extractor' = (Udtor (sr, name)) :: extractor in
191: get_pattern_vars vars pat extractor'
192:
193: | `PAT_as (sr,pat,id) ->
194: Hashtbl.add vars id (sr,extractor);
195: get_pattern_vars vars pat extractor
196:
197: | `PAT_coercion (sr,pat,_)
198: | `PAT_when (sr,pat,_) ->
199: get_pattern_vars vars pat extractor
200:
201: | `PAT_record (sr,rpats) ->
202: List.iter
203: (fun (s,pat) ->
204: let sr = src_of_pat pat in
205: let extractor' = (Proj_s (sr,s)) :: extractor in
206: get_pattern_vars vars pat extractor'
207: )
208: rpats
209:
210: | _ -> ()
211:
212: let rec gen_match_check pat (arg:expr_t) =
213: let lint sr t i = `AST_literal (sr,`AST_int (t,i))
214: and lstr sr s = `AST_literal (sr,`AST_string s)
215: and lfloat sr t x = `AST_literal (sr,`AST_float (t,x))
216: and apl sr f x =
217: `AST_apply
218: (
219: sr,
220: (
221: `AST_name (sr,f,[]),
222: x
223: )
224: )
225: and apl2 sr f x1 x2 =
226: match f,x1,x2 with
227: | "land",`AST_typed_case(_,1,`TYP_unitsum 2),x -> x
228: | "land",x,`AST_typed_case(_,1,`TYP_unitsum 2) -> x
229: | _ ->
230: `AST_apply
231: (
232: sr,
233: (
234: `AST_name (sr,f,[]),
235: `AST_tuple (sr,[x1;x2])
236: )
237: )
238: and truth sr = `AST_typed_case (sr,1,flx_bool)
239: and ssrc x = short_string_of_src x
240: in
241: match pat with
242: | `PAT_int (sr,t,i) -> apl2 sr "eq" (lint sr t i) arg
243: | `PAT_string (sr,s) -> apl2 sr "eq" (lstr sr s) arg
244: | `PAT_nan sr -> apl sr "isnan" arg
245: | `PAT_none sr -> clierr sr "Empty pattern not allowed"
246:
247: (* ranges *)
248: | `PAT_int_range (sr,t1,i1,t2,i2) ->
249: let b1 = apl2 sr "le" (lint sr t1 i1) arg
250: and b2 = apl2 sr "le" arg (lint sr t2 i2)
251: in apl2 sr "land" b1 b2
252:
253: | `PAT_string_range (sr,s1,s2) ->
254: let b1 = apl2 sr "le" (lstr sr s1) arg
255: and b2 = apl2 sr "le" arg (lstr sr s2)
256: in apl2 sr "land" b1 b2
257:
258: | `PAT_float_range (sr,x1,x2) ->
259: begin match x1,x2 with
260: | (Float_plus (t1,v1), Float_plus (t2,v2)) ->
261: if t1 <> t2 then
262: failwith ("Inconsistent endpoint types in " ^ ssrc sr)
263: else
264: let b1 = apl2 sr "le" (lfloat sr t1 v1) arg
265: and b2 = apl2 sr "le" arg (lfloat sr t2 v2)
266: in apl2 sr "land" b1 b2
267:
268: | (Float_minus(t1,v1), Float_minus (t2,v2)) ->
269: if t1 <> t2 then
270: failwith ("Inconsistent endpoint types in " ^ ssrc sr)
271: else
272: let b1 = apl2 sr "le" (lfloat sr t1 ("-"^ v1)) arg
273: and b2 = apl2 sr "le" arg (lfloat sr t2 ("-"^v2))
274: in apl2 sr "land" b1 b2
275:
276:
277: | (Float_minus (t1,v1), Float_plus (t2,v2)) ->
278: if t1 <> t2 then
279: failwith ("Inconsistent endpoint types in " ^ ssrc sr)
280: else
281: let b1 = apl2 sr "le" (lfloat sr t1 ("-"^ v1)) arg
282: and b2 = apl2 sr "le" arg (lfloat sr t2 v2)
283: in apl2 sr "land" b1 b2
284:
285:
286: | (Float_minus (t1,v1), Float_inf) ->
287: apl2 sr "le" (lfloat sr t1 ("-"^ v1)) arg
288:
289: | (Float_plus (t1,v1), Float_inf) ->
290: apl2 sr "le" (lfloat sr t1 v1) arg
291:
292: | (Float_minus_inf, Float_minus (t2,v2)) ->
293: apl2 sr "le" arg (lfloat sr t2 ("-"^v2))
294:
295: | (Float_minus_inf, Float_plus (t2,v2)) ->
296: apl2 sr "le" arg (lfloat sr t2 v2)
297:
298: | (Float_minus_inf , Float_inf ) ->
299: apl sr "not" (apl sr "isnan" arg)
300:
301:
302: | (Float_plus _, Float_minus _)
303: | (Float_inf, _)
304: | (_ , Float_minus_inf) ->
305: failwith ("Empty float range at " ^ ssrc sr)
306: end
307:
308: (* other *)
309: | `PAT_name (sr,_) -> truth sr
310: | `PAT_tuple (sr,pats) ->
311: let counter = ref 1 in
312: List.fold_left
313: (fun init pat ->
314: let sr = src_of_pat pat in
315: let n = !counter in
316: incr counter;
317: apl2 sr "land" init
318: (
319: gen_match_check pat (`AST_get_n (sr,(n, arg)))
320: )
321: )
322: (
323: let pat = List.hd pats in
324: let sr = src_of_pat pat in
325: gen_match_check pat (`AST_get_n (sr,(0, arg)))
326: )
327: (List.tl pats)
328:
329: | `PAT_record (sr,rpats) ->
330: List.fold_left
331: (fun init (s,pat) ->
332: let sr = src_of_pat pat in
333: apl2 sr "land" init
334: (
335: gen_match_check pat (`AST_get_named_variable (sr,(s, arg)))
336: )
337: )
338: (
339: let s,pat = List.hd rpats in
340: let sr = src_of_pat pat in
341: gen_match_check pat (`AST_get_named_variable (sr,(s, arg)))
342: )
343: (List.tl rpats)
344:
345: | `PAT_any sr -> truth sr
346: | `PAT_regexp _ ->
347: failwith "[gen_match_check] Can't handle regexp yet"
348: | `PAT_const_ctor (sr,name) ->
349: `AST_match_ctor (sr,(name,arg))
350:
351: | `PAT_nonconst_ctor (sr,name,pat) ->
352: let check_component = `AST_match_ctor (sr,(name,arg)) in
353: let tuple = `AST_ctor_arg (sr,(name,arg)) in
354: let check_tuple = gen_match_check pat tuple in
355: apl2 sr "land" check_component check_tuple
356:
357: | `PAT_coercion (sr,pat,_)
358: | `PAT_as (sr,pat,_) ->
359: gen_match_check pat arg
360:
361: | `PAT_when (sr,pat,expr) ->
362: let vars = Hashtbl.create 97 in
363: get_pattern_vars vars pat [];
364: apl2 sr "land" (gen_match_check pat arg) (subst vars expr arg)
365:
366: