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