source: Deliverables/D2.2/8051/src/clight/clightFold.ml @ 619

Last change on this file since 619 was 619, checked in by ayache, 9 years ago

Update of D2.2 from Paris.

File size: 3.8 KB
Line 
1
2(** This module provides folding functions over the constructors of the
3    [Clight]'s AST. *)
4
5
6let ctype_subs = function
7  | Clight.Tvoid | Clight.Tint _ | Clight.Tfloat _ | Clight.Tcomp_ptr _ -> []
8  | Clight.Tpointer ctype | Clight.Tarray (ctype, _) -> [ctype]
9  | Clight.Tfunction (args, res) -> args @ [res]
10  | Clight.Tstruct (_, fields) | Clight.Tunion (_, fields) ->
11    List.map snd fields
12
13let ctype_fill_subs ctype sub_ctypes = match ctype, sub_ctypes with
14  | Clight.Tvoid, _ | Clight.Tint _, _ | Clight.Tfloat _, _
15  | Clight.Tcomp_ptr _, _ -> ctype
16  | Clight.Tpointer _, ctype :: _ -> Clight.Tpointer ctype
17  | Clight.Tarray (_, size), ctype :: _ -> Clight.Tarray (ctype, size)
18  | Clight.Tfunction _, _ ->
19    let (args, res) = MiscPottier.split_last sub_ctypes in
20    Clight.Tfunction (args, res)
21  | Clight.Tstruct (name, fields), _ ->
22    let fields = List.map2 (fun (x, _) ctype -> (x, ctype)) fields sub_ctypes in
23    Clight.Tstruct (name, fields)
24  | Clight.Tunion (name, fields), _ ->
25    let fields = List.map2 (fun (x, _) ctype -> (x, ctype)) fields sub_ctypes in
26    Clight.Tunion (name, fields)
27  | _ -> assert false (* wrong arguments, do not use on these values *)
28
29let rec ctype f t =
30  let sub_ctypes_res = List.map (ctype f) (ctype_subs t) in
31  f t sub_ctypes_res
32
33
34let expr_subs = function
35  | Clight.Expr (expr_descr, ctype) -> ([expr_descr], [ctype])
36
37let expr_descr_subs = function
38  | Clight.Econst_int _ | Clight.Econst_float _ | Clight.Evar _ -> ([], [])
39  | Clight.Ederef e | Clight.Eaddrof e | Clight.Eunop (_, e)
40  | Clight.Efield (e, _) -> ([], [e])
41  | Clight.Ebinop (_, e1, e2) | Clight.Eandbool (e1, e2)
42  | Clight.Eorbool (e1, e2) -> ([], [e1 ; e2])
43  | Clight.Ecast (ctype, e) -> ([ctype], [e])
44  | Clight.Econdition (e1, e2, e3) -> ([], [e1 ; e2 ; e3])
45  | Clight.Esizeof ctype -> ([ctype], [])
46  | Clight.Ecost (_, e) -> ([], [e])
47  | Clight.Ecall (_, e1, e2) -> ([], [e1 ; e2])
48
49let expr_fill_subs e sub_expr_descrs sub_ctypes =
50  match e, sub_expr_descrs, sub_ctypes with
51  | Clight.Expr _, expr_descr :: _, ctype :: _ ->
52    Clight.Expr (expr_descr, ctype)
53  | _ -> assert false (* wrong arguments, do not use on these values *)
54
55let expr_descr_fill_subs e sub_ctypes sub_exprs = 
56  match e, sub_ctypes, sub_exprs with
57  | Clight.Econst_int _, _, _ | Clight.Econst_float _, _, _
58  | Clight.Evar _, _, _ -> e
59  | Clight.Ederef _, _, e :: _ -> Clight.Ederef e
60  | Clight.Eaddrof _, _, e :: _ -> Clight.Eaddrof e
61  | Clight.Eunop (unop, _), _, e :: _ -> Clight.Eunop (unop, e)
62  | Clight.Ebinop (binop, _, _), _, e1 :: e2 :: _ ->
63    Clight.Ebinop (binop, e1, e2)
64  | Clight.Ecast _, ctype :: _, e :: _ -> Clight.Ecast (ctype, e)
65  | Clight.Econdition _, _, e1 :: e2 :: e3 :: _ ->
66    Clight.Econdition (e1, e2, e3)
67  | Clight.Efield (_, field_name), _, e :: _ -> Clight.Efield (e, field_name)
68  | _ -> assert false (* TODO *)
69(*
70  | _ -> assert false (* wrong arguments, do not use on these values *)
71  | Clight.Ebinop (_, e1, e2) | Clight.Eandbool (e1, e2)
72  | Clight.Eorbool (e1, e2) -> ([], [e1 ; e2])
73  | Clight.Ecast (ctype, e) -> ([ctype], [e])
74  | Clight.Econdition (e1, e2, e3) -> ([], [e1 ; e2 ; e3])
75  | Clight.Esizeof ctype -> ([ctype], [])
76  | Clight.Ecost (_, e) -> ([], [e])
77  | Clight.Ecall (_, e1, e2) -> ([], [e1 ; e2])
78*)
79
80let rec expr f_expr_descr f_ctype f_expr e =
81  let (sub_expr_descrs, sub_ctypes) = expr_subs e in
82  let sub_expr_descrs_res =
83    List.map (expr_descr f_ctype f_expr f_expr_descr) sub_expr_descrs in
84  let sub_ctypes_res = List.map (ctype f_ctype) sub_ctypes in
85  f_expr e sub_expr_descrs_res sub_ctypes_res
86
87and expr_descr f_ctype f_expr f_expr_descr e =
88  let (sub_ctypes, sub_exprs) = expr_descr_subs e in
89  let sub_exprs_res =
90    List.map (expr f_expr_descr f_ctype f_expr) sub_exprs in
91  let sub_ctypes_res = List.map (ctype f_ctype) sub_ctypes in
92  f_expr_descr e sub_ctypes_res sub_exprs_res
Note: See TracBrowser for help on using the repository browser.