1

(********************************************************************)

2

(* *)

3

(* The LustreC compiler toolset / The LustreC Development Team *)

4

(* Copyright 2012   ONERA  CNRS  INPT  LIFL *)

5

(* *)

6

(* LustreC is free software, distributed WITHOUT ANY WARRANTY *)

7

(* under the terms of the GNU Lesser General Public License *)

8

(* version 2.1. *)

9

(* *)

10

(* This file was originally from the Prelude compiler *)

11

(* *)

12

(********************************************************************)

13


14

(** Types definitions and a few utility functions on types. *)

15

open Utils

16

open Dimension

17


18

type type_expr =

19

{mutable tdesc: type_desc;

20

tid: int}

21


22

and type_desc =

23

 Tconst of ident (* type constant *)

24

 Tint

25

 Treal

26

 Tbool

27

 Trat (* Actually unused for now. Only place where it can appear is

28

in a clock declaration *)

29

 Tclock of type_expr (* A type expression explicitely tagged as carrying a clock *)

30

 Tarrow of type_expr * type_expr

31

 Ttuple of type_expr list

32

 Tenum of ident list

33

 Tstruct of (ident * type_expr) list

34

 Tarray of dim_expr * type_expr

35

 Tstatic of dim_expr * type_expr (* a type carried by a dimension expression *)

36

 Tlink of type_expr (* During unification, make links instead of substitutions *)

37

 Tvar (* Monomorphic type variable *)

38

 Tunivar (* Polymorphic type variable *)

39


40

type error =

41

Unbound_value of ident

42

 Already_bound of ident

43

 Already_defined of ident

44

 Undefined_var of (unit IMap.t)

45

 Declared_but_undefined of ident

46

 Unbound_type of ident

47

 Not_a_dimension

48

 Not_a_constant

49

 Assigned_constant of ident

50

 WrongArity of int * int

51

 WrongMorphism of int * int

52

 Type_mismatch of ident

53

 Type_clash of type_expr * type_expr

54

 Poly_imported_node of ident

55


56

exception Unify of type_expr * type_expr

57

exception Error of Location.t * error

58


59

(* Prettyprint*)

60

open Format

61


62

let rec print_struct_ty_field fmt (label, ty) =

63

fprintf fmt "%a : %a" pp_print_string label print_ty ty

64

and print_ty fmt ty =

65

match ty.tdesc with

66

 Tvar >

67

fprintf fmt "_%s" (name_of_type ty.tid)

68

 Tint >

69

fprintf fmt "int"

70

 Treal >

71

fprintf fmt "real"

72

 Tbool >

73

fprintf fmt "bool"

74

 Tclock t >

75

fprintf fmt "%a clock" print_ty t

76

 Tstatic (d, t) >

77

fprintf fmt "(%a:%a)" Dimension.pp_dimension d print_ty t

78

 Tconst t >

79

fprintf fmt "%s" t

80

 Trat >

81

fprintf fmt "rat"

82

 Tarrow (ty1,ty2) >

83

fprintf fmt "%a > %a" print_ty ty1 print_ty ty2

84

 Ttuple tylist >

85

fprintf fmt "(%a)"

86

(Utils.fprintf_list ~sep:"*" print_ty) tylist

87

 Tenum taglist >

88

fprintf fmt "enum {%a }"

89

(Utils.fprintf_list ~sep:", " pp_print_string) taglist

90

 Tstruct fieldlist >

91

fprintf fmt "struct {%a }"

92

(Utils.fprintf_list ~sep:"; " print_struct_ty_field) fieldlist

93

 Tarray (e, ty) >

94

fprintf fmt "%a^%a" print_ty ty Dimension.pp_dimension e

95

 Tlink ty >

96

print_ty fmt ty

97

 Tunivar >

98

fprintf fmt "'%s" (name_of_type ty.tid)

99


100

let rec print_node_struct_ty_field fmt (label, ty) =

101

fprintf fmt "%a : %a" pp_print_string label print_node_ty ty

102

and print_node_ty fmt ty =

103

match ty.tdesc with

104

 Tvar > begin

105

(*Format.eprintf "DEBUG:Types.print_node@.";*)

106

fprintf fmt "_%s" (name_of_type ty.tid)

107

end

108

 Tint >

109

fprintf fmt "int"

110

 Treal >

111

fprintf fmt "real"

112

 Tbool >

113

fprintf fmt "bool"

114

 Tclock t >

115

fprintf fmt "%a clock" print_node_ty t

116

 Tstatic (_, t) >

117

fprintf fmt "%a" print_node_ty t

118

 Tconst t >

119

fprintf fmt "%s" t

120

 Trat >

121

fprintf fmt "rat"

122

 Tarrow (ty1,ty2) >

123

fprintf fmt "%a > %a" print_node_ty ty1 print_node_ty ty2

124

 Ttuple tylist >

125

fprintf fmt "(%a)"

126

(Utils.fprintf_list ~sep:"*" print_node_ty) tylist

127

 Tenum taglist >

128

fprintf fmt "enum {%a }"

129

(Utils.fprintf_list ~sep:", " pp_print_string) taglist

130

 Tstruct fieldlist >

131

fprintf fmt "struct {%a }"

132

(Utils.fprintf_list ~sep:"; " print_node_struct_ty_field) fieldlist

133

 Tarray (e, ty) >

134

fprintf fmt "%a^%a" print_node_ty ty Dimension.pp_dimension e

135

 Tlink ty >

136

print_node_ty fmt ty

137

 Tunivar >

138

fprintf fmt "'%s" (name_of_type ty.tid)

139


140

let pp_error fmt = function

141

 Unbound_value id >

142

fprintf fmt "Unknown value %s@." id

143

 Unbound_type id >

144

fprintf fmt "Unknown type %s@." id

145

 Already_bound id >

146

fprintf fmt "%s is already declared@." id

147

 Already_defined id >

148

fprintf fmt "Multiple definitions of variable %s@." id

149

 Not_a_constant >

150

fprintf fmt "This expression is not a constant@."

151

 Assigned_constant id >

152

fprintf fmt "The constant %s cannot be assigned@." id

153

 Not_a_dimension >

154

fprintf fmt "This expression is not a valid dimension@."

155

 WrongArity (ar1, ar2) >

156

fprintf fmt "Expecting %d argument(s), found %d@." ar1 ar2

157

 WrongMorphism (ar1, ar2) >

158

fprintf fmt "Expecting %d argument(s) for homomorphic extension, found %d@." ar1 ar2

159

 Type_mismatch id >

160

fprintf fmt "Definition and declaration of type %s don't agree@." id

161

 Undefined_var vmap >

162

fprintf fmt "No definition provided for variable(s): %a@."

163

(Utils.fprintf_list ~sep:"," pp_print_string)

164

(fst (Utils.list_of_imap vmap))

165

 Declared_but_undefined id >

166

fprintf fmt "%s is declared but not defined@." id

167

 Type_clash (ty1,ty2) >

168

Utils.reset_names ();

169

fprintf fmt "Expected type %a, got type %a@." print_ty ty1 print_ty ty2

170

 Poly_imported_node id >

171

fprintf fmt "Imported nodes cannot have a polymorphic type@."

172


173


174

let new_id = ref (1)

175


176

let new_ty desc =

177

incr new_id; {tdesc = desc; tid = !new_id }

178


179

let new_var () =

180

new_ty Tvar

181


182

let new_univar () =

183

new_ty Tunivar

184


185

let rec repr =

186

function

187

{tdesc = Tlink t'} >

188

repr t'

189

 t > t

190


191

let get_static_value ty =

192

match (repr ty).tdesc with

193

 Tstatic (d, _) > Some d

194

 _ > None

195


196

let get_field_type ty label =

197

match (repr ty).tdesc with

198

 Tstruct fl > (try Some (List.assoc label fl) with Not_found > None)

199

 _ > None

200


201

let is_numeric_type ty =

202

match (repr ty).tdesc with

203

 Tint

204

 Treal > true

205

 _ > false

206


207

let is_bool_type ty =

208

match (repr ty).tdesc with

209

 Tbool > true

210

 _ > false

211


212

let get_clock_base_type ty =

213

match (repr ty).tdesc with

214

 Tclock ty > Some ty

215

 _ > None

216


217

let rec is_dimension_type ty =

218

match (repr ty).tdesc with

219

 Tint

220

 Tbool > true

221

 Tclock ty'

222

 Tstatic (_, ty') > is_dimension_type ty'

223

 _ > false

224


225

let dynamic_type ty =

226

let ty = repr ty in

227

match ty.tdesc with

228

 Tstatic (_, ty') > ty'

229

 _ > ty

230


231

let is_tuple_type ty =

232

match (repr ty).tdesc with

233

 Ttuple _ > true

234

 _ > false

235


236

let map_tuple_type f ty =

237

let ty = dynamic_type ty in

238

match ty.tdesc with

239

 (Ttuple ty_list) > { ty with tdesc = Ttuple (List.map f ty_list) }

240

 _ > f ty

241


242

let rec is_struct_type ty =

243

match (repr ty).tdesc with

244

 Tstruct _ > true

245

 Tstatic (_, ty') > is_struct_type ty'

246

 _ > false

247


248

let rec is_array_type ty =

249

match (repr ty).tdesc with

250

 Tarray _ > true

251

 Tstatic (_, ty') > is_array_type ty' (* looks strange !? *)

252

 _ > false

253


254

let array_type_dimension ty =

255

match (dynamic_type ty).tdesc with

256

 Tarray (d, _) > d

257

 _ > assert false

258


259

let rec array_type_multi_dimension ty =

260

match (dynamic_type ty).tdesc with

261

 Tarray (d, ty') > d :: array_type_multi_dimension ty'

262

 _ > []

263


264

let array_element_type ty =

265

match (dynamic_type ty).tdesc with

266

 Tarray (_, ty') > ty'

267

 _ > assert false

268


269

let rec array_base_type ty =

270

let ty = repr ty in

271

match ty.tdesc with

272

 Tarray (_, ty')

273

 Tstatic (_, ty') > array_base_type ty'

274

 _ > ty

275


276

let is_address_type ty =

277

is_array_type ty  is_struct_type ty

278


279

let rec is_generic_type ty =

280

match (dynamic_type ty).tdesc with

281

 Tarray (d, ty') >

282

(not (Dimension.is_dimension_const d))  (is_generic_type ty')

283

 _ > false

284


285

(** Splits [ty] into the [lhs,rhs] of an arrow type. Expects an arrow type

286

(ensured by language syntax) *)

287

let rec split_arrow ty =

288

match (repr ty).tdesc with

289

 Tarrow (tin,tout) > tin,tout

290

 Tstatic (_, ty') > split_arrow ty'

291

(* Functions are not first order, I don't think the var case

292

needs to be considered here *)

293

 _ > Format.eprintf "type %a is not a map@.Unable to split@.@?" print_ty ty; assert false

294


295

(** Returns the type corresponding to a type list. *)

296

let type_of_type_list tyl =

297

if (List.length tyl) > 1 then

298

new_ty (Ttuple tyl)

299

else

300

List.hd tyl

301


302

let type_list_of_type ty =

303

match (repr ty).tdesc with

304

 Ttuple tl > tl

305

 _ > [ty]

306


307

(** [is_polymorphic ty] returns true if [ty] is polymorphic. *)

308

let rec is_polymorphic ty =

309

match ty.tdesc with

310

 Tenum _  Tvar  Tint  Treal  Tbool  Trat  Tconst _ > false

311

 Tclock ty > is_polymorphic ty

312

 Tarrow (ty1,ty2) > (is_polymorphic ty1)  (is_polymorphic ty2)

313

 Ttuple tl > List.exists (fun t > is_polymorphic t) tl

314

 Tstruct fl > List.exists (fun (_, t) > is_polymorphic t) fl

315

 Tlink t' > is_polymorphic t'

316

 Tarray (d, ty)

317

 Tstatic (d, ty) > Dimension.is_polymorphic d  is_polymorphic ty

318

 Tunivar > true

319


320


321

let mktyptuple nb typ =

322

let array = Array.make nb typ in

323

Ttuple (Array.to_list array)

324


325


326

(* Local Variables: *)

327

(* compilecommand:"make C .." *)

328

(* End: *)
