## lustrec / src / basic_library.ml @ 22fe1c93

History | View | Annotate | Download (6.93 KB)

1 | 22fe1c93 | ploc | (* ---------------------------------------------------------------------------- |
---|---|---|---|

2 | * SchedMCore - A MultiCore Scheduling Framework |
||

3 | * Copyright (C) 2009-2013, ONERA, Toulouse, FRANCE - LIFL, Lille, FRANCE |
||

4 | * Copyright (C) 2012-2013, INPT, Toulouse, FRANCE |
||

5 | * |
||

6 | * This file is part of Prelude |
||

7 | * |
||

8 | * Prelude is free software; you can redistribute it and/or |
||

9 | * modify it under the terms of the GNU Lesser General Public License |
||

10 | * as published by the Free Software Foundation ; either version 2 of |
||

11 | * the License, or (at your option) any later version. |
||

12 | * |
||

13 | * Prelude is distributed in the hope that it will be useful, but |
||

14 | * WITHOUT ANY WARRANTY ; without even the implied warranty of |
||

15 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU |
||

16 | * Lesser General Public License for more details. |
||

17 | * |
||

18 | * You should have received a copy of the GNU Lesser General Public |
||

19 | * License along with this program ; if not, write to the Free Software |
||

20 | * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 |
||

21 | * USA |
||

22 | *---------------------------------------------------------------------------- *) |
||

23 | |||

24 | (* This module is used for the lustre to C compiler *) |
||

25 | |||

26 | open LustreSpec |
||

27 | open Type_predef |
||

28 | open Clock_predef |
||

29 | open Delay_predef |
||

30 | open Dimension |
||

31 | |||

32 | module TE = Env |
||

33 | |||

34 | let static_op ty = |
||

35 | type_static (mkdim_var ()) ty |
||

36 | |||

37 | let type_env = |
||

38 | let init_env = TE.initial in |
||

39 | let env' = TE.add_value init_env "+" (static_op type_bin_poly_op) in |
||

40 | let env' = TE.add_value env' "uminus" (static_op type_unary_poly_op) in |
||

41 | let env' = TE.add_value env' "-" (static_op type_bin_poly_op) in |
||

42 | let env' = TE.add_value env' "*" (static_op type_bin_poly_op) in |
||

43 | let env' = TE.add_value env' "/" (static_op type_bin_poly_op) in |
||

44 | let env' = TE.add_value env' "mod" (static_op type_bin_int_op) in |
||

45 | let env' = TE.add_value env' "&&" (static_op type_bin_bool_op) in |
||

46 | let env' = TE.add_value env' "||" (static_op type_bin_bool_op) in |
||

47 | let env' = TE.add_value env' "xor" (static_op type_bin_bool_op) in |
||

48 | let env' = TE.add_value env' "impl" (static_op type_bin_bool_op) in |
||

49 | let env' = TE.add_value env' "<" (static_op type_bin_comp_op) in |
||

50 | let env' = TE.add_value env' "<=" (static_op type_bin_comp_op) in |
||

51 | let env' = TE.add_value env' ">" (static_op type_bin_comp_op) in |
||

52 | let env' = TE.add_value env' ">=" (static_op type_bin_comp_op) in |
||

53 | let env' = TE.add_value env' "!=" (static_op type_bin_comp_op) in |
||

54 | let env' = TE.add_value env' "=" (static_op type_bin_comp_op) in |
||

55 | let env' = TE.add_value env' "not" (static_op type_unary_bool_op) in |
||

56 | env' |
||

57 | |||

58 | module CE = Env |
||

59 | |||

60 | let clock_env = |
||

61 | let init_env = CE.initial in |
||

62 | let env' = |
||

63 | List.fold_right (fun op env -> CE.add_value env op ck_unary_univ) |
||

64 | ["uminus"; "not"] init_env in |
||

65 | let env' = |
||

66 | List.fold_right (fun op env -> CE.add_value env op ck_bin_univ) |
||

67 | ["+"; "-"; "*"; "/"; "mod"; "&&"; "||"; "xor"; "impl"; "<"; "<="; ">"; ">="; "!="; "="] env' in |
||

68 | env' |
||

69 | |||

70 | module DE = Env |
||

71 | |||

72 | let delay_env = |
||

73 | let init_env = DE.initial in |
||

74 | let env' = |
||

75 | List.fold_right (fun op env -> DE.add_value env op delay_unary_poly_op) |
||

76 | ["uminus"; "not"] init_env in |
||

77 | let env' = |
||

78 | List.fold_right (fun op env -> DE.add_value env op delay_binary_poly_op) |
||

79 | ["+"; "-"; "*"; "/"; "mod"; "&&"; "||"; "xor"; "impl"; "<"; "<="; ">"; ">="; "!="; "="] env' in |
||

80 | let env' = |
||

81 | List.fold_right (fun op env -> DE.add_value env op delay_ternary_poly_op) |
||

82 | [] env' in |
||

83 | env' |
||

84 | |||

85 | module VE = Env |
||

86 | |||

87 | let eval_env = |
||

88 | let init_env = VE.initial in |
||

89 | let env' = VE.add_value init_env "uminus" (fun [Dint a] -> Dint (-a)) in |
||

90 | let env' = VE.add_value env' "not" (fun [Dbool b] -> Dbool (not b)) in |
||

91 | let env' = VE.add_value env' "+" (fun [Dint a; Dint b] -> Dint (a+b)) in |
||

92 | let env' = VE.add_value env' "-" (fun [Dint a; Dint b] -> Dint (a-b)) in |
||

93 | let env' = VE.add_value env' "*" (fun [Dint a; Dint b] -> Dint (a*b)) in |
||

94 | let env' = VE.add_value env' "/" (fun [Dint a; Dint b] -> Dint (a/b)) in |
||

95 | let env' = VE.add_value env' "mod" (fun [Dint a; Dint b] -> Dint (a mod b)) in |
||

96 | let env' = VE.add_value env' "&&" (fun [Dbool a; Dbool b] -> Dbool (a&&b)) in |
||

97 | let env' = VE.add_value env' "||" (fun [Dbool a; Dbool b] -> Dbool (a||b)) in |
||

98 | let env' = VE.add_value env' "xor" (fun [Dbool a; Dbool b] -> Dbool (a<>b)) in |
||

99 | let env' = VE.add_value env' "impl" (fun [Dbool a; Dbool b] -> Dbool (a<=b)) in |
||

100 | let env' = VE.add_value env' "<" (fun [Dint a; Dint b] -> Dbool (a<b)) in |
||

101 | let env' = VE.add_value env' ">" (fun [Dint a; Dint b] -> Dbool (a>b)) in |
||

102 | let env' = VE.add_value env' "<=" (fun [Dint a; Dint b] -> Dbool (a<=b)) in |
||

103 | let env' = VE.add_value env' ">=" (fun [Dint a; Dint b] -> Dbool (a>=b)) in |
||

104 | let env' = VE.add_value env' "!=" (fun [a; b] -> Dbool (a<>b)) in |
||

105 | let env' = VE.add_value env' "=" (fun [a; b] -> Dbool (a=b)) in |
||

106 | env' |
||

107 | |||

108 | let internal_funs = ["+";"-";"*";"/";"mod";"&&";"||";"xor";"impl";"<";">";"<=";">=";"!=";"=";"uminus";"not"] |
||

109 | |||

110 | let is_internal_fun x = |
||

111 | List.mem x internal_funs |
||

112 | |||

113 | (* |
||

114 | let imported_node name inputs outputs sl spec = |
||

115 | mktop_decl Location.dummy_loc |
||

116 | ( |
||

117 | ImportedNode |
||

118 | {nodei_id = name; |
||

119 | nodei_type = Types.new_var (); |
||

120 | nodei_clock = Clocks.new_var true; |
||

121 | nodei_inputs = inputs; |
||

122 | nodei_outputs = outputs; |
||

123 | nodei_stateless = sl; |
||

124 | nodei_spec = spec}) |
||

125 | |||

126 | let mk_new_var id = |
||

127 | let loc = Location.dummy_loc in |
||

128 | mkvar_decl loc (id, mktyp loc Tydec_any, mkclock loc Ckdec_any, false) |
||

129 | |||

130 | let _ = |
||

131 | let binary_fun id = id, [mk_new_var "x"; mk_new_var "y"], [mk_new_var "z"] in |
||

132 | let unary_fun id = id, [mk_new_var "x"], [mk_new_var "y"] in |
||

133 | (* All following functions are stateless *) |
||

134 | let st = true in |
||

135 | List.iter (fun (n,i,o) -> Hashtbl.add node_table n (imported_node n i o st None)) |
||

136 | ( |
||

137 | (*("ite", [mk_new_var "g"; mk_new_var "x"; mk_new_var "y"], [mk_new_var "z"])::*) |
||

138 | (List.map binary_fun |
||

139 | ["+";"-";"*";"/";"mod";"&&";"||";"xor";"impl";"<";">";"<=";">=";"!=";"="]) |
||

140 | @(List.map unary_fun ["uminus";"not"])) |
||

141 | *) |
||

142 | let pp_c i pp_val fmt vl = |
||

143 | match i, vl with |
||

144 | (* | "ite", [v1; v2; v3] -> Format.fprintf fmt "(%a?(%a):(%a))" pp_val v1 pp_val v2 pp_val v3 *) |
||

145 | | "uminus", [v] -> Format.fprintf fmt "(- %a)" pp_val v |
||

146 | | "not", [v] -> Format.fprintf fmt "(!%a)" pp_val v |
||

147 | | "impl", [v1; v2] -> Format.fprintf fmt "(!%a || %a)" pp_val v1 pp_val v2 |
||

148 | | "=", [v1; v2] -> Format.fprintf fmt "(%a == %a)" pp_val v1 pp_val v2 |
||

149 | | "mod", [v1; v2] -> Format.fprintf fmt "(%a %% %a)" pp_val v1 pp_val v2 |
||

150 | | _, [v1; v2] -> Format.fprintf fmt "(%a %s %a)" pp_val v1 i pp_val v2 |
||

151 | | _ -> assert false |
||

152 | |||

153 | let pp_java i pp_val fmt vl = |
||

154 | match i, vl with |
||

155 | (* | "ite", [v1; v2; v3] -> Format.fprintf fmt "(%a?(%a):(%a))" pp_val v1 pp_val v2 pp_val v3 *) |
||

156 | | "uminus", [v] -> Format.fprintf fmt "(- %a)" pp_val v |
||

157 | | "not", [v] -> Format.fprintf fmt "(!%a)" pp_val v |
||

158 | | "impl", [v1; v2] -> Format.fprintf fmt "(!%a || %a)" pp_val v1 pp_val v2 |
||

159 | | "=", [v1; v2] -> Format.fprintf fmt "(%a == %a)" pp_val v1 pp_val v2 |
||

160 | | _, [v1; v2] -> Format.fprintf fmt "(%a %s %a)" pp_val v1 i pp_val v2 |
||

161 | | _ -> assert false |
||

162 | |||

163 | |||

164 | (* Local Variables: *) |
||

165 | (* compile-command:"make -C .." *) |
||

166 | (* End: *) |