1: # 1306 "./lpsrc/flx_types.ipk"
2: open Flx_ast
3: open Flx_types
4: open List
5: open Flx_typing
6:
7: let rec list_of_n_things thing lst n =
8: if n = 0 then lst
9: else list_of_n_things thing (thing::lst) (n-1)
10:
11: let map_type f (t:typecode_t):typecode_t = match t with
12: | `AST_name (sr,name,ts) -> `AST_name (sr,name, map f ts)
13: | `AST_lookup (sr,(e,name,ts)) -> `AST_lookup (sr,(e,name,map f ts))
14: | `AST_suffix (sr,(qn,t)) -> `AST_suffix (sr,(qn, f t))
15:
16: | `AST_typed_case (sr,i,t) -> `AST_typed_case (sr,i, f t)
17: | `TYP_tuple ts -> `TYP_tuple (map f ts)
18: | `TYP_record ts -> `TYP_record (map (fun (s,t) -> s,f t) ts)
19: | `TYP_variant ts -> `TYP_variant (map (fun (s,t) -> s,f t) ts)
20: | `TYP_isin (a,b) -> `TYP_isin (f a, f b)
21:
22: (* we have to do this, so that a large unitsume
23: can be specified without overflowing the compiler
24: storage
25: *)
26: | `TYP_unitsum k ->
27: if k>0 then
28: let mapped_unit = f (`TYP_tuple []) in
29: match mapped_unit with
30: | `TYP_tuple [] ->
31: `TYP_unitsum k
32: | _ -> `TYP_tuple ( list_of_n_things mapped_unit [] k)
33: else `TYP_unitsum k
34:
35: (* here we don't need to go to a unitsum, since
36: we have already used up storage
37: *)
38: | `TYP_sum ts -> `TYP_sum (map f ts)
39: | `TYP_intersect ts -> `TYP_intersect (map f ts)
40: | `TYP_function (a,b) -> `TYP_function (f a, f b)
41: | `TYP_cfunction (a,b) -> `TYP_cfunction (f a, f b)
42: | `TYP_pointer t -> `TYP_pointer (f t)
43: | `TYP_lvalue t -> `TYP_lvalue (f t)
44: | `TYP_array (t1, t2) -> `TYP_array (f t1, f t2)
45: | `TYP_as (t,s) -> `TYP_as (f t,s)
46:
47: (* type sets *)
48: | `TYP_typeset ts -> `TYP_typeset (map f ts)
49: | `TYP_setintersection ts -> `TYP_setintersection (map f ts)
50: | `TYP_setunion ts -> `TYP_setunion (map f ts)
51:
52: (* destructors *)
53: | `TYP_dom t -> `TYP_dom (f t)
54: | `TYP_dual t -> `TYP_dual (f t)
55: | `TYP_cod t -> `TYP_cod (f t)
56: | `TYP_proj (i,t) -> `TYP_proj (i, f t)
57: | `TYP_case_arg (i,t) -> `TYP_case_arg (i, f t)
58: | `TYP_case (t1,ls,t2) -> `TYP_case (f t1, ls, f t2)
59:
60: (*
61: | `TYP_type_match (t,ps) ->
62: let ps = map (fun (p,t) -> p, f t) ps in
63: `TYP_type_match (f t, ps)
64: *)
65: | `TYP_type_match (t,ps) ->
66: let ps = map (fun (p,t) -> f p, f t) ps in
67: `TYP_type_match (f t, ps)
68:
69: (* meta constructors *)
70: | `TYP_apply (a,b) -> `TYP_apply (f a, f b)
71: | `TYP_typefun (ps, a, b) -> `TYP_typefun (ps, f a, f b)
72: | `TYP_type_tuple ts -> `TYP_type_tuple (map f ts)
73: | `TYP_lift t -> `TYP_lift (f t)
74:
75:
76: (* invariant ..?? *)
77: | `TYP_typeof _
78: | `AST_callback _
79: | `AST_case_tag _
80: | `AST_index _
81: | `AST_the _
82: | `TYP_glr_attr_type _
83: | `TYP_var _
84: | `AST_patvar _
85: | `AST_patany _
86:
87: (* absolute constants *)
88: | `AST_void _
89: | `TYP_ellipsis
90: | `TYP_type
91: | `TYP_none
92:
93: -> t
94:
95:
96: let map_expr f (e:expr_t):expr_t = match e with
97: | `AST_patvar _
98: | `AST_patany _
99: | `AST_vsprintf _ -> e
100: | `AST_interpolate _ -> e
101: | `AST_map (sr,a,b) -> `AST_map (sr,f a, f b)
102: | `AST_noexpand (sr,x) -> e (* DO NOT EXPAND .. HMM .. *)
103: | `AST_name _ -> e
104: | `AST_callback _ -> e
105: | `AST_the _ -> e
106: | `AST_index _ -> e
107: | `AST_case_tag _ -> e
108: | `AST_typed_case _ -> e
109: | `AST_lookup (sr,(x,s,ts)) -> `AST_lookup (sr,(f x, s, ts))
110: | `AST_apply (sr,(a,b)) -> `AST_apply (sr,(f a, f b))
111: | `AST_tuple (sr,es) -> `AST_tuple (sr, map f es)
112: | `AST_record (sr,es) -> `AST_record (sr, map (fun (s,e) -> s,f e) es)
113: | `AST_variant (sr,(s,e)) -> `AST_variant (sr, (s,f e))
114: | `AST_arrayof (sr, es) -> `AST_arrayof (sr, map f es)
115: | `AST_coercion (sr, (x,t)) -> `AST_coercion (sr,(f x, t))
116: | `AST_suffix _ -> e
117:
118: | `AST_record_type (sr,ts) -> e
119: | `AST_variant_type (sr,ts) -> e
120: | `AST_void sr -> e
121: | `AST_ellipsis sr -> e
122: | `AST_product (sr,es) -> `AST_product (sr, map f es)
123: | `AST_sum (sr,es) -> `AST_sum (sr, map f es)
124: | `AST_setunion (sr,es) -> `AST_setunion (sr, map f es)
125: | `AST_setintersection (sr,es) -> `AST_setintersection (sr, map f es)
126: | `AST_orlist (sr,es) -> `AST_orlist (sr, map f es)
127: | `AST_andlist (sr,es) -> `AST_andlist (sr, map f es)
128: | `AST_arrow (sr,(a,b)) -> `AST_arrow (sr,(f a, f b))
129: | `AST_longarrow (sr,(a,b)) -> `AST_longarrow (sr,(f a, f b))
130: | `AST_superscript (sr,(a,b)) -> `AST_superscript (sr,(f a, f b))
131:
132: | `AST_literal _ -> e
133: | `AST_deref (sr,x) -> `AST_deref (sr,f x)
134: | `AST_ref (sr,x) -> `AST_ref (sr, f x)
135: | `AST_new (sr,x) -> `AST_new (sr, f x)
136: | `AST_lvalue (sr,x) -> `AST_lvalue (sr, f x)
137: | `AST_lift (sr,x) -> `AST_lift (sr, f x)
138: | `AST_method_apply (sr,(id,x,ts)) -> `AST_method_apply (sr,(id,f x,ts))
139: (*
140: | `AST_dot (sr,(x,id,ts)) -> `AST_dot (sr,(f x,id,ts))
141: *)
142: | `AST_dot (sr,(x,x2)) -> `AST_dot (sr,(f x,f x2))
143:
144: (* GIVE UP ON LAMBDAS FOR THE MOMENT .. NEEDS STATEMENT MAPPING TOO *)
145: (* | `AST_lambda of range_srcref * (vs_list_t * params_t list * typecode_t * statement_t list) *)
146: | `AST_lambda _ -> e
147:
148: | `AST_match_ctor (sr,(qn,x)) -> `AST_match_ctor (sr,(qn,f x))
149: | `AST_match_case (sr,(j,x)) -> `AST_match_case (sr,(j, f x))
150:
151: | `AST_ctor_arg (sr,(qn,x)) -> `AST_ctor_arg (sr,(qn,f x))
152: | `AST_case_arg (sr,(j,x)) -> `AST_case_arg (sr,(j, f x))
153: | `AST_case_index (sr,x) -> `AST_case_index (sr,f x)
154:
155: | `AST_letin (sr,(pat,a,b)) -> `AST_letin (sr,(pat,f a, f b))
156:
157: | `AST_get_n (sr,(j,x)) -> `AST_get_n (sr,(j,f x))
158: | `AST_get_named_variable (sr,(j,x)) -> `AST_get_named_variable (sr,(j,f x))
159: | `AST_get_named_method (sr,(j,k,ts,x)) -> `AST_get_named_method (sr,(j,k,ts,f x))
160: | `AST_as (sr,(x,s)) -> `AST_as (sr,(f x, s))
161: | `AST_match (sr,(a,pes)) ->
162: `AST_match (sr, (f a, map (fun (pat,x) -> pat, f x) pes))
163:
164: (* GIVE UP ON NASTY STUFF FOR THE MOMENT *)
165: (*
166: | `AST_parse of range_srcref * expr_t * (range_srcref * production_t * expr_t) list
167: | `AST_sparse of range_srcref * expr_t * string * int list
168: | `AST_regmatch of range_srcref * (expr_t * expr_t * (regexp_t * expr_t) list)
169: | `AST_reglex of range_srcref * (expr_t * expr_t * (regexp_t * expr_t) list)
170: *)
171: | `AST_parse _
172: | `AST_sparse _
173: | `AST_regmatch _
174: | `AST_string_regmatch _
175: | `AST_reglex _ -> e
176:
177: | `AST_typeof (sr,x) -> `AST_typeof (sr,f x)
178: | `AST_cond (sr,(a,b,c)) -> `AST_cond (sr, (f a, f b, f c))
179:
180: | `AST_expr _ -> e
181: | `AST_type_match _ -> e
182: | `AST_macro_ctor _ -> e
183: | `AST_macro_statements _ -> e
184: | `AST_case (sr,e1,ls,e2) -> `AST_case (sr,f e1, ls, f e2)
185:
186: let iter_expr f (e:expr_t) =
187: f e;
188: match e with
189: | `AST_patvar _
190: | `AST_patany _
191: | `AST_vsprintf _
192: | `AST_interpolate _
193: | `AST_name _
194: | `AST_callback _
195: | `AST_the _
196: | `AST_index _
197: | `AST_case_tag _
198: | `AST_typed_case _
199: | `AST_record_type _
200: | `AST_variant_type _
201: | `AST_void _
202: | `AST_ellipsis _
203: | `AST_noexpand _
204: | `AST_suffix _
205: | `AST_literal _
206: | `AST_lambda _
207: | `AST_parse _
208: | `AST_sparse _
209: | `AST_regmatch _
210: | `AST_string_regmatch _
211: | `AST_reglex _
212: | `AST_expr _
213: | `AST_type_match _
214: | `AST_macro_ctor _
215: | `AST_macro_statements _
216: -> ()
217:
218: | `AST_variant (_,(_,x))
219: | `AST_typeof (_,x)
220: | `AST_as (_,(x,_))
221: | `AST_get_named_method (_,(_,_,_,x))
222: | `AST_get_n (_,(_,x))
223: | `AST_get_named_variable (_,(_,x))
224: | `AST_ctor_arg (_,(_,x))
225: | `AST_case_arg (_,(_,x))
226: | `AST_case_index (_,x)
227: | `AST_match_ctor (_,(_,x))
228: | `AST_match_case (_,(_,x))
229: | `AST_method_apply (_,(_,x,_))
230: | `AST_deref (_,x)
231: | `AST_ref (_,x)
232: | `AST_new (_,x)
233: | `AST_lvalue (_,x)
234: | `AST_lookup (_,(x,_,_))
235: | `AST_coercion (_, (x,_))
236: | `AST_lift (_,x)
237: -> f x
238:
239: | `AST_case (_,a,_,b)
240: | `AST_letin (_,(_,a,b))
241: | `AST_dot (_,(a,b))
242: | `AST_longarrow (_,(a,b))
243: | `AST_superscript (_,(a,b))
244: | `AST_arrow (_,(a,b))
245: | `AST_map (_,a,b)
246: | `AST_apply (_,(a,b))
247: -> f a; f b
248:
249: | `AST_tuple (_,es)
250: | `AST_product (_,es)
251: | `AST_sum (_,es)
252: | `AST_setunion (_,es)
253: | `AST_setintersection (_,es)
254: | `AST_orlist (_,es)
255: | `AST_andlist (_,es)
256: | `AST_arrayof (_, es) ->
257: iter f es
258:
259: | `AST_record (sr,es) -> iter (fun (s,e) -> f e) es
260:
261: | `AST_match (sr,(a,pes)) ->
262: f a; iter (fun (pat,x) -> f x) pes
263:
264: | `AST_cond (sr,(a,b,c)) -> f a; f b; f c
265:
266: let scan_expr e =
267: let ls = ref [] in
268: let add x = ls := Flx_srcref.src_of_expr x :: !ls in
269: iter_expr add e;
270: Flx_util.uniq_list !ls
271:
272: let all_units' ts =
273: try
274: iter (function
275: | `BTYP_tuple [] -> ()
276: | _ -> raise Not_found
277: )
278: ts;
279: true
280: with Not_found -> false
281:
282: let map_b0type f = function
283: | `BTYP_inst (i,ts) -> `BTYP_inst (i, map f ts)
284: | `BTYP_tuple ts -> `BTYP_tuple (map f ts)
285: | `BTYP_record ts -> `BTYP_record (map (fun (s,t) -> s,f t) ts)
286: | `BTYP_variant ts -> `BTYP_variant (map (fun (s,t) -> s,f t) ts)
287:
288: | `BTYP_unitsum k ->
289: if k>0 then
290: let mapped_unit = f (`BTYP_tuple []) in
291: match mapped_unit with
292: | `BTYP_tuple [] ->
293: `BTYP_unitsum k
294: | _ -> `BTYP_tuple ( list_of_n_things mapped_unit [] k)
295: else `BTYP_unitsum k
296:
297: | `BTYP_intersect ts -> `BTYP_intersect (map f ts)
298:
299: | `BTYP_sum ts ->
300: let ts = map f ts in
301: if all_units' ts then
302: `BTYP_unitsum (length ts)
303: else
304: `BTYP_sum ts
305:
306: | `BTYP_function (a,b) -> `BTYP_function (f a, f b)
307: | `BTYP_cfunction (a,b) -> `BTYP_cfunction (f a, f b)
308: | `BTYP_pointer t-> `BTYP_pointer (f t)
309: | `BTYP_lvalue t-> `BTYP_lvalue (f t)
310: | `BTYP_array (t1,t2)-> `BTYP_array (f t1, f t2)
311: | x -> x
312:
313: let map_btype f = function
314: | `BTYP_apply (a,b) -> `BTYP_apply (f a, f b)
315: | `BTYP_typefun (its, a, b) ->
316: `BTYP_typefun (map (fun (i,t) -> i, f t) its, f a , f b)
317: | `BTYP_type_tuple ts -> `BTYP_type_tuple (map f ts)
318: | `BTYP_type_match (t,ps) ->
319: (* this may be wrong .. hard to know .. *)
320: let g (tp,t) = {tp with pattern=f tp.pattern},f t in
321: `BTYP_type_match (f t, map g ps)
322:
323: | `BTYP_typeset ts ->
324: let g acc elt =
325: (* SHOULD USE UNIFICATIION! *)
326: let elt = f elt in
327: if mem elt acc then acc else elt::acc
328: in
329: let ts = rev(fold_left g [] ts) in
330: if length ts = 1 then hd ts else
331: `BTYP_typeset ts
332:
333: | `BTYP_typesetunion ls -> `BTYP_typesetunion (map f ls)
334: | `BTYP_typesetintersection ls -> `BTYP_typesetintersection (map f ls)
335:
336: | `BTYP_type i -> `BTYP_type i
337: | x -> map_b0type f x
338:
339: let iter_b0type f = function
340: | `BTYP_inst (i,ts) -> iter f ts
341: | `BTYP_tuple ts -> iter f ts
342: | `BTYP_record ts -> iter (fun (s,t) -> f t) ts
343: | `BTYP_variant ts -> iter (fun (s,t) -> f t) ts
344: | `BTYP_unitsum k ->
345: let unitrep = `BTYP_tuple [] in
346: for i = 1 to k do f unitrep done
347:
348: | `BTYP_sum ts -> iter f ts
349: | `BTYP_function (a,b) -> f a; f b
350: | `BTYP_cfunction (a,b) -> f a; f b
351: | `BTYP_pointer t-> f t
352: | `BTYP_lvalue t-> f t
353: | `BTYP_array (t1,t2)-> f t1; f t2
354: | x -> ()
355:
356: let iter_btype f = function
357: | `BTYP_apply (a,b) -> f a; f b
358: | `BTYP_typefun (its, a, b) ->
359: iter (fun (i,t) -> f t) its; f a; f b
360: | `BTYP_type_match (t,ps) ->
361: let g (tp,t) = f tp.pattern; f t in
362: f t;
363: iter g ps
364:
365: | `BTYP_type_tuple ts -> iter f ts
366: | `BTYP_typeset ts -> iter f ts
367: | `BTYP_typesetunion ts -> iter f ts
368: | `BTYP_typesetintersection ts -> iter f ts
369:
370: | x -> iter_b0type f x
371:
372: (* type invariant mapping *)
373:
374: let rec iter_tbexpr fi fe ft ((x,t) as e) =
375: fe e; ft t;
376: let fe e = iter_tbexpr fi fe ft e in
377: match x with
378: | `BEXPR_parse (e,iis) -> fe e; iter fi iis
379: | `BEXPR_deref e -> fe e
380: | `BEXPR_ref (i,ts) -> fi i; iter ft ts
381: | `BEXPR_new e -> fe e
382:
383: | `BEXPR_apply (e1,e2) -> fe e1; fe e2
384:
385: | `BEXPR_apply_prim (i,ts,e2) -> fi i; iter ft ts; fe e2
386: | `BEXPR_apply_direct (i,ts,e2) -> fi i; iter ft ts; fe e2
387: | `BEXPR_apply_method_direct (e1,i,ts,e2) -> fe e1; fi i; iter ft ts; fe e2
388: | `BEXPR_apply_struct (i,ts,e2) -> fi i; iter ft ts; fe e2
389: | `BEXPR_apply_stack (i,ts,e2) -> fi i; iter ft ts; fe e2
390: | `BEXPR_apply_method_stack (e1,i,ts,e2) -> fe e1; fi i; iter ft ts; fe e2
391: | `BEXPR_tuple es -> iter fe es
392: | `BEXPR_record es -> iter (fun (s,e) -> fe e) es
393: | `BEXPR_variant (s,e) -> fe e
394:
395: | `BEXPR_get_n (i,e) -> fe e
396: | `BEXPR_get_named (i,e) -> fi i; fe e
397:
398: | `BEXPR_closure (i,ts) -> fi i; iter ft ts
399: | `BEXPR_method_closure (e,i,ts) -> fe e; fi i; iter ft ts
400: | `BEXPR_name (i,ts) -> fi i; iter ft ts
401: | `BEXPR_case (i,t') -> ft t'
402: | `BEXPR_match_case (i,e) -> fe e
403: | `BEXPR_case_arg (i,e) -> fe e
404: | `BEXPR_case_index e -> fe e
405:
406: | `BEXPR_literal x -> ft t
407: | `BEXPR_expr (s,t1) -> ft t1
408: | `BEXPR_range_check (e1,e2,e3) -> fe e1; fe e2; fe e3
409: | `BEXPR_coerce (e,t) -> fe e; ft t
410:
411: let map_tbexpr fi fe ft e = match e with
412: | `BEXPR_parse (e,iis),t -> `BEXPR_parse (fe e,map fi iis), ft t
413: | `BEXPR_deref e,t -> `BEXPR_deref (fe e),ft t
414: | `BEXPR_ref (i,ts),t -> `BEXPR_ref (fi i, map ft ts), ft t
415: | `BEXPR_new e,t -> `BEXPR_new (fe e), ft t
416:
417: | `BEXPR_apply (e1,e2),t -> `BEXPR_apply (fe e1, fe e2), ft t
418:
419: | `BEXPR_apply_prim (i,ts,e2),t -> `BEXPR_apply_prim (fi i, map ft ts, fe e2),ft t
420: | `BEXPR_apply_direct (i,ts,e2),t -> `BEXPR_apply_direct (fi i, map ft ts, fe e2),ft t
421: | `BEXPR_apply_method_direct (e1,i,ts,e2),t -> `BEXPR_apply_method_direct (fe e1,fi i, map ft ts, fe e2),ft t
422: | `BEXPR_apply_struct (i,ts,e2),t -> `BEXPR_apply_struct (fi i, map ft ts, fe e2),ft t
423: | `BEXPR_apply_stack (i,ts,e2),t -> `BEXPR_apply_stack (fi i, map ft ts, fe e2),ft t
424: | `BEXPR_apply_method_stack (e1,i,ts,e2),t -> `BEXPR_apply_method_stack (fe e1,fi i, map ft ts, fe e2),ft t
425:
426: | `BEXPR_tuple es,t -> `BEXPR_tuple (map fe es),ft t
427: | `BEXPR_record es,t -> `BEXPR_record (map (fun (s,e) -> s, fe e) es),ft t
428: | `BEXPR_variant (s,e),t -> `BEXPR_variant (s, fe e),ft t
429:
430: | `BEXPR_get_n (i,e),t -> `BEXPR_get_n (i, fe e),ft t
431: | `BEXPR_get_named (i,e),t -> `BEXPR_get_named (fi i, fe e),ft t
432:
433: | `BEXPR_closure (i,ts),t -> `BEXPR_closure (fi i, map ft ts),ft t
434: | `BEXPR_method_closure (e,i,ts),t -> `BEXPR_method_closure (fe e, fi i, map ft ts),ft t
435: | `BEXPR_name (i,ts),t -> `BEXPR_name (fi i, map ft ts), ft t
436: | `BEXPR_case (i,t'),t -> `BEXPR_case (i, ft t'),ft t
437: | `BEXPR_match_case (i,e),t -> `BEXPR_match_case (i, fe e),ft t
438: | `BEXPR_case_arg (i,e),t -> `BEXPR_case_arg (i, fe e),ft t
439: | `BEXPR_case_index e,t -> `BEXPR_case_index (fe e),ft t
440:
441: | `BEXPR_literal x,t -> `BEXPR_literal x, ft t
442: | `BEXPR_expr (s,t1),t2 -> `BEXPR_expr (s, ft t1), ft t2
443: | `BEXPR_range_check (e1,e2,e3),t -> `BEXPR_range_check (fe e1,fe e2, fe e3), ft t
444: | `BEXPR_coerce (e,t'),t -> `BEXPR_coerce (fe e, ft t'), ft t
445:
446: let iter_bexe fi fe ft fl fldef exe =
447: match exe with
448: | `BEXE_call_prim (sr,i,ts,e2)
449: | `BEXE_call_stack (sr,i,ts,e2)
450: | `BEXE_call_direct (sr,i,ts,e2)
451: | `BEXE_jump_direct (sr,i,ts,e2)
452: -> fi i; iter ft ts; fe e2
453:
454: | `BEXE_call_method_direct (sr,e1,i,ts,e2)
455: -> fe e1; fi i; iter ft ts; fe e2
456:
457: | `BEXE_call_method_stack (sr,e1,i,ts,e2)
458: -> fe e1; fi i; iter ft ts; fe e2
459:
460: | `BEXE_assign (sr,e1,e2)
461: | `BEXE_call (sr,e1,e2)
462: | `BEXE_jump (sr,e1,e2)
463: -> fe e1; fe e2
464:
465: | `BEXE_apply_ctor (sr,i0, i1,ts,i2,e2)
466: -> fi i0; fi i1; iter ft ts; fi i2; fe e2
467:
468: | `BEXE_apply_ctor_stack (sr,i0, i1,ts,i2,e2)
469: -> fi i0; fi i1; iter ft ts; fi i2; fe e2
470:
471: | `BEXE_loop (sr,i,e)
472: -> fi i; fe e
473:
474: | `BEXE_ifgoto (sr,e,lab)
475: | `BEXE_ifnotgoto (sr,e,lab)
476: -> fe e; fl lab
477:
478: | `BEXE_label (sr,lab)
479: -> fldef lab
480:
481: | `BEXE_goto (sr,lab)
482: -> fl lab
483:
484: | `BEXE_fun_return (sr,e)
485: -> fe e
486:
487: | `BEXE_yield (sr,e)
488: -> fe e
489:
490: | `BEXE_axiom_check (_,e)
491: -> fe e
492:
493: | `BEXE_assert2 (_,_,e1,e2)
494: -> (match e1 with Some e -> fe e | None->()); fe e2
495:
496: | `BEXE_assert (_,e)
497: -> fe e
498:
499: | `BEXE_init (sr,i,e)
500: -> fi i; fe e
501:
502: | `BEXE_svc (sr,i)
503: -> fi i
504:
505: | `BEXE_halt _
506: | `BEXE_code _
507: | `BEXE_nonreturn_code _
508: | `BEXE_proc_return _
509: | `BEXE_comment _
510: | `BEXE_nop _
511: | `BEXE_begin
512: | `BEXE_end
513: -> ()
514:
515:
516: let map_bexe fi fe ft fl fldef (exe:bexe_t):bexe_t =
517: match exe with
518: | `BEXE_call_prim (sr,i,ts,e2) ->
519: `BEXE_call_prim (sr,fi i,map ft ts, fe e2)
520:
521: | `BEXE_call_stack (sr,i,ts,e2) ->
522: `BEXE_call_stack (sr,fi i, map ft ts, fe e2)
523:
524: | `BEXE_call_direct (sr,i,ts,e2) ->
525: `BEXE_call_direct (sr,fi i,map ft ts,fe e2)
526:
527: | `BEXE_call_method_direct (sr,e1,i,ts,e2) ->
528: `BEXE_call_method_direct (sr,fe e1,fi i,map ft ts,fe e2)
529:
530: | `BEXE_call_method_stack (sr,e1,i,ts,e2) ->
531: `BEXE_call_method_stack (sr,fe e1,fi i,map ft ts,fe e2)
532:
533: | `BEXE_jump_direct (sr,i,ts,e2) ->
534: `BEXE_jump_direct (sr,fi i,map ft ts,fe e2)
535:
536: | `BEXE_assign (sr,e1,e2) ->
537: `BEXE_assign (sr,fe e1,fe e2)
538:
539: | `BEXE_call (sr,e1,e2) ->
540: `BEXE_call (sr,fe e1, fe e2)
541:
542: | `BEXE_apply_ctor (sr,i1,i2,ts,i3,e2) ->
543: `BEXE_apply_ctor (sr,fi i1,fi i2, map ft ts, fi i3,fe e2)
544:
545: | `BEXE_apply_ctor_stack (sr,i1,i2,ts,i3,e2) ->
546: `BEXE_apply_ctor_stack (sr,fi i1,fi i2, map ft ts, fi i3,fe e2)
547:
548: | `BEXE_jump (sr,e1,e2) ->
549: `BEXE_jump (sr,fe e1, fe e2)
550:
551: | `BEXE_loop (sr,i,e) ->
552: `BEXE_loop (sr,fi i,fe e)
553:
554: | `BEXE_ifgoto (sr,e,lab) ->
555: `BEXE_ifgoto (sr,fe e,fl lab)
556:
557: | `BEXE_ifnotgoto (sr,e,lab) ->
558: `BEXE_ifnotgoto (sr,fe e,fl lab)
559:
560: | `BEXE_label (sr,lab) ->
561: `BEXE_label (sr,fldef lab)
562:
563: | `BEXE_goto (sr,lab) ->
564: `BEXE_goto (sr,fl lab)
565:
566: | `BEXE_fun_return (sr,e) ->
567: `BEXE_fun_return (sr,fe e)
568:
569: | `BEXE_yield (sr,e) ->
570: `BEXE_yield (sr,fe e)
571:
572: | `BEXE_assert (sr,e) ->
573: `BEXE_assert (sr, fe e)
574:
575: | `BEXE_assert2 (sr,sr2,e1, e2) ->
576: let e1 = match e1 with Some e1 -> Some (fe e1) | None -> None in
577: `BEXE_assert2 (sr, sr2,e1, fe e2)
578:
579: | `BEXE_axiom_check (sr,e) ->
580: `BEXE_axiom_check (sr, fe e)
581:
582: | `BEXE_init (sr,i,e) ->
583: `BEXE_init (sr,fi i,fe e)
584:
585: | `BEXE_svc (sr,i) ->
586: `BEXE_svc (sr,fi i)
587:
588: | `BEXE_halt _
589: | `BEXE_code _
590: | `BEXE_nonreturn_code _
591: | `BEXE_proc_return _
592: | `BEXE_comment _
593: | `BEXE_nop _
594: | `BEXE_begin
595: | `BEXE_end
596: -> exe
597:
598: let ident x = x
599: let reduce_tbexpr bbdfns e =
600: let rec aux e =
601: match map_tbexpr ident aux ident e with
602: | `BEXPR_apply((`BEXPR_closure (i,ts),_),a),t ->
603: `BEXPR_apply_direct (i,ts,a),t
604:
605: | `BEXPR_apply((`BEXPR_method_closure (obj,i,ts),_),a),t ->
606: `BEXPR_apply_method_direct (obj,i,ts,a),t
607:
608: | `BEXPR_get_n (n,((`BEXPR_tuple ls),_)),_ ->
609: List.nth ls n
610:
611: | `BEXPR_deref (`BEXPR_ref (i,ts),_),t ->
612: `BEXPR_name (i,ts),t
613:
614: | x -> x
615: in aux e
616:
617: let reduce_bexe bbdfns exe =
618: match map_bexe ident (reduce_tbexpr bbdfns) ident ident ident exe with
619: | `BEXE_call (sr,(`BEXPR_closure (i,ts),_),a) ->
620: `BEXE_call_direct (sr,i,ts,a)
621:
622: | `BEXE_call (sr,(`BEXPR_method_closure (obj,meth,ts),_),a) ->
623: `BEXE_call_method_direct (sr,obj,meth,ts,a)
624:
625: | x -> x
626:
627: let rec reduce_type t =
628: match map_btype reduce_type t with
629: | `BTYP_record ts ->
630: begin match ts with
631: | [] -> `BTYP_tuple []
632: | _ ->
633: let rcmp (s1,_) (s2,_) = compare s1 s2 in
634: let ts = sort compare ts in
635: let ss,ts = split ts in
636: let ts = combine ss (map reduce_type ts) in
637: `BTYP_record ts
638: end
639: | `BTYP_variant ts ->
640: begin match ts with
641: | [] -> `BTYP_void
642: | _ ->
643: let rcmp (s1,_) (s2,_) = compare s1 s2 in
644: let ts = sort compare ts in
645: let ss,ts = split ts in
646: let ts = combine ss (map reduce_type ts) in
647: `BTYP_variant ts
648: end
649: | `BTYP_tuple ts -> typeoflist ts
650: | `BTYP_array (t',`BTYP_unitsum 0) -> `BTYP_tuple []
651: | `BTYP_array (t',`BTYP_unitsum 1) -> t'
652: | t -> t
653: