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_patvar _
60: | `AST_patany _
61: | `AST_case _
62: | `AST_vsprintf _
63: | `AST_interpolate _
64: | `AST_type_match _
65: | `AST_noexpand _
66: | `AST_letin _
67: | `AST_cond _
68: | `AST_expr _
69: | `AST_typeof _
70: | `AST_product _
71: | `AST_void _
72: | `AST_sum _
73: | `AST_andlist _
74: | `AST_orlist _
75: | `AST_typed_case _
76: | `AST_case_arg _
77: | `AST_arrow _
78: | `AST_longarrow _
79: | `AST_superscript _
80: | `AST_match _
81: | `AST_regmatch _
82: | `AST_string_regmatch _
83: | `AST_reglex _
84: | `AST_ellipsis _
85: | `AST_parse _
86: | `AST_sparse _
87: | `AST_setunion _
88: | `AST_setintersection _
89: | `AST_macro_ctor _
90: | `AST_macro_statements _
91: | `AST_callback _
92: | `AST_record_type _
93: | `AST_variant_type _
94: | `AST_lift _
95: ->
96: let sr = src_of_expr e in
97: clierr sr "[mbind:subst] Not expected in when part of pattern"
98:
99: | `AST_case_index _ -> e
100: | `AST_index _ -> e
101: | `AST_the _ -> e
102: | `AST_lookup _ -> e
103: | `AST_suffix _ -> e
104: | `AST_literal _ -> e
105: | `AST_case_tag _ -> e
106: | `AST_as _ -> e
107:
108: | `AST_name (sr,name,idx) ->
109: if idx = [] then
110: if Hashtbl.mem vars name
111: then
112: let sr,extractor = Hashtbl.find vars name in
113: gen_extractor extractor mv
114: else e
115: else failwith "Can't use indexed name in when clause :("
116:
117:
118:
119: | `AST_deref (sr,e') -> `AST_deref (sr,subst e')
120: | `AST_ref (sr,e') -> `AST_ref (sr,subst e')
121: | `AST_new (sr,e') -> `AST_new (sr,subst e')
122: | `AST_lvalue (sr,e') -> `AST_lvalue (sr,subst e')
123: | `AST_apply (sr,(f,e)) -> `AST_apply (sr,(subst f,subst e))
124: | `AST_map (sr,f,e) -> `AST_map (sr,subst f,subst e)
125: | `AST_tuple (sr,es) -> `AST_tuple (sr,map subst es)
126: | `AST_record (sr,es) -> `AST_record (sr,map (fun (s,e)->s,subst e) es)
127: | `AST_variant (sr,(s,e)) -> `AST_variant (sr,(s,subst e))
128: | `AST_arrayof (sr,es) -> `AST_arrayof (sr,map subst es)
129:
130:
131: (* Only one of these should occur, but I can't
132: figure out which one at the moment
133: *)
134: | `AST_method_apply (sr,(id,e,ts)) ->
135: `AST_method_apply (sr,(id, subst e,ts))
136:
137: (*
138: | `AST_dot (sr,(e,id,ts)) ->
139: `AST_dot (sr,(subst e, id,ts))
140: *)
141:
142: | `AST_dot (sr,(e,e2)) ->
143: `AST_dot (sr,(subst e, subst e2))
144:
145: | `AST_lambda _ -> assert false
146:
147: | `AST_match_case _
148: | `AST_ctor_arg _
149: | `AST_get_n _
150: | `AST_get_named_variable _
151: | `AST_get_named_method _
152: | `AST_match_ctor _
153: ->
154: let sr = src_of_expr e in
155: clierr sr "[subst] not implemented in when part of pattern"
156:
157: | `AST_coercion _ -> failwith "subst: coercion"
158:
159: (* This routine runs through a pattern looking for
160: pattern variables, and adds a record to a hashtable
161: keyed by each variable name. The data recorded
162: is the list of extractors which must be applied
163: to 'deconstruct' the data type to get the part
164: which the variable denotes in the pattern
165:
166: for example, for the pattern
167:
168: | Ctor (1,(x,_))
169:
170: the extractor for x is
171:
172: [Udtor "Ctor"; Proj_n 2; Proj_n 1]
173:
174: since x is the first component of the second
175: component of the argument of the constructor "Ctor"
176: *)
177:
178: let rec get_pattern_vars
179: vars (* Hashtable of variable -> range_srcref * extractor *)
180: pat (* pattern *)
181: extractor (* extractor for this pattern *)
182: =
183: match pat with
184: | `PAT_name (sr,id) -> Hashtbl.add vars id (sr,extractor)
185:
186: | `PAT_tuple (sr,pats) ->
187: let n = ref 0 in
188: List.iter
189: (fun pat ->
190: let sr = src_of_pat pat in
191: let extractor' = (Proj_n (sr,!n)) :: extractor in
192: incr n;
193: get_pattern_vars vars pat extractor'
194: )
195: pats
196:
197: | `PAT_regexp _ ->
198: failwith "[get_pattern_vars] Can't handle regexp yet"
199:
200: | `PAT_nonconst_ctor (sr,name,pat) ->
201: let extractor' = (Udtor (sr, name)) :: extractor in
202: get_pattern_vars vars pat extractor'
203:
204: | `PAT_as (sr,pat,id) ->
205: Hashtbl.add vars id (sr,extractor);
206: get_pattern_vars vars pat extractor
207:
208: | `PAT_coercion (sr,pat,_)
209: | `PAT_when (sr,pat,_) ->
210: get_pattern_vars vars pat extractor
211:
212: | `PAT_record (sr,rpats) ->
213: List.iter
214: (fun (s,pat) ->
215: let sr = src_of_pat pat in
216: let extractor' = (Proj_s (sr,s)) :: extractor in
217: get_pattern_vars vars pat extractor'
218: )
219: rpats
220:
221: | _ -> ()
222:
223: let rec gen_match_check pat (arg:expr_t) =
224: let lint sr t i = `AST_literal (sr,`AST_int (t,i))
225: and lstr sr s = `AST_literal (sr,`AST_string s)
226: and lfloat sr t x = `AST_literal (sr,`AST_float (t,x))
227: and apl sr f x =
228: `AST_apply
229: (
230: sr,
231: (
232: `AST_name (sr,f,[]),
233: x
234: )
235: )
236: and apl2 sr f x1 x2 =
237: match f,x1,x2 with
238: | "land",`AST_typed_case(_,1,`TYP_unitsum 2),x -> x
239: | "land",x,`AST_typed_case(_,1,`TYP_unitsum 2) -> x
240: | _ ->
241: `AST_apply
242: (
243: sr,
244: (
245: `AST_name (sr,f,[]),
246: `AST_tuple (sr,[x1;x2])
247: )
248: )
249: and truth sr = `AST_typed_case (sr,1,flx_bool)
250: and ssrc x = short_string_of_src x
251: in
252: match pat with
253: | `PAT_int (sr,t,i) -> apl2 sr "eq" (lint sr t i) arg
254: | `PAT_string (sr,s) -> apl2 sr "eq" (lstr sr s) arg
255: | `PAT_nan sr -> apl sr "isnan" arg
256: | `PAT_none sr -> clierr sr "Empty pattern not allowed"
257:
258: (* ranges *)
259: | `PAT_int_range (sr,t1,i1,t2,i2) ->
260: let b1 = apl2 sr "le" (lint sr t1 i1) arg
261: and b2 = apl2 sr "le" arg (lint sr t2 i2)
262: in apl2 sr "land" b1 b2
263:
264: | `PAT_string_range (sr,s1,s2) ->
265: let b1 = apl2 sr "le" (lstr sr s1) arg
266: and b2 = apl2 sr "le" arg (lstr sr s2)
267: in apl2 sr "land" b1 b2
268:
269: | `PAT_float_range (sr,x1,x2) ->
270: begin match x1,x2 with
271: | (Float_plus (t1,v1), Float_plus (t2,v2)) ->
272: if t1 <> t2 then
273: failwith ("Inconsistent endpoint types in " ^ ssrc sr)
274: else
275: let b1 = apl2 sr "le" (lfloat sr t1 v1) arg
276: and b2 = apl2 sr "le" arg (lfloat sr t2 v2)
277: in apl2 sr "land" b1 b2
278:
279: | (Float_minus(t1,v1), Float_minus (t2,v2)) ->
280: if t1 <> t2 then
281: failwith ("Inconsistent endpoint types in " ^ ssrc sr)
282: else
283: let b1 = apl2 sr "le" (lfloat sr t1 ("-"^ v1)) arg
284: and b2 = apl2 sr "le" arg (lfloat sr t2 ("-"^v2))
285: in apl2 sr "land" b1 b2
286:
287:
288: | (Float_minus (t1,v1), Float_plus (t2,v2)) ->
289: if t1 <> t2 then
290: failwith ("Inconsistent endpoint types in " ^ ssrc sr)
291: else
292: let b1 = apl2 sr "le" (lfloat sr t1 ("-"^ v1)) arg
293: and b2 = apl2 sr "le" arg (lfloat sr t2 v2)
294: in apl2 sr "land" b1 b2
295:
296:
297: | (Float_minus (t1,v1), Float_inf) ->
298: apl2 sr "le" (lfloat sr t1 ("-"^ v1)) arg
299:
300: | (Float_plus (t1,v1), Float_inf) ->
301: apl2 sr "le" (lfloat sr t1 v1) arg
302:
303: | (Float_minus_inf, Float_minus (t2,v2)) ->
304: apl2 sr "le" arg (lfloat sr t2 ("-"^v2))
305:
306: | (Float_minus_inf, Float_plus (t2,v2)) ->
307: apl2 sr "le" arg (lfloat sr t2 v2)
308:
309: | (Float_minus_inf , Float_inf ) ->
310: apl sr "not" (apl sr "isnan" arg)
311:
312:
313: | (Float_plus _, Float_minus _)
314: | (Float_inf, _)
315: | (_ , Float_minus_inf) ->
316: failwith ("Empty float range at " ^ ssrc sr)
317: end
318:
319: (* other *)
320: | `PAT_name (sr,_) -> truth sr
321: | `PAT_tuple (sr,pats) ->
322: let counter = ref 1 in
323: List.fold_left
324: (fun init pat ->
325: let sr = src_of_pat pat in
326: let n = !counter in
327: incr counter;
328: apl2 sr "land" init
329: (
330: gen_match_check pat (`AST_get_n (sr,(n, arg)))
331: )
332: )
333: (
334: let pat = List.hd pats in
335: let sr = src_of_pat pat in
336: gen_match_check pat (`AST_get_n (sr,(0, arg)))
337: )
338: (List.tl pats)
339:
340: | `PAT_record (sr,rpats) ->
341: List.fold_left
342: (fun init (s,pat) ->
343: let sr = src_of_pat pat in
344: apl2 sr "land" init
345: (
346: gen_match_check pat (`AST_get_named_variable (sr,(s, arg)))
347: )
348: )
349: (
350: let s,pat = List.hd rpats in
351: let sr = src_of_pat pat in
352: gen_match_check pat (`AST_get_named_variable (sr,(s, arg)))
353: )
354: (List.tl rpats)
355:
356: | `PAT_any sr -> truth sr
357: | `PAT_regexp _ ->
358: failwith "[gen_match_check] Can't handle regexp yet"
359: | `PAT_const_ctor (sr,name) ->
360: `AST_match_ctor (sr,(name,arg))
361:
362: | `PAT_nonconst_ctor (sr,name,pat) ->
363: let check_component = `AST_match_ctor (sr,(name,arg)) in
364: let tuple = `AST_ctor_arg (sr,(name,arg)) in
365: let check_tuple = gen_match_check pat tuple in
366: apl2 sr "land" check_component check_tuple
367:
368: | `PAT_coercion (sr,pat,_)
369: | `PAT_as (sr,pat,_) ->
370: gen_match_check pat arg
371:
372: | `PAT_when (sr,pat,expr) ->
373: let vars = Hashtbl.create 97 in
374: get_pattern_vars vars pat [];
375: apl2 sr "land" (gen_match_check pat arg) (subst vars expr arg)
376:
377: