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 ISet.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 vset >

162

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

163

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

164

(ISet.elements vset)

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 rec bottom =

177

{ tdesc = Tlink bottom; tid = 666 }

178


179

let new_ty desc =

180

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

181


182

let new_var () =

183

new_ty Tvar

184


185

let new_univar () =

186

new_ty Tunivar

187


188

let rec repr =

189

function

190

{tdesc = Tlink t'} >

191

repr t'

192

 t > t

193


194

let get_static_value ty =

195

match (repr ty).tdesc with

196

 Tstatic (d, _) > Some d

197

 _ > None

198


199

let get_field_type ty label =

200

match (repr ty).tdesc with

201

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

202

 _ > None

203


204

let rec is_scalar_type ty =

205

match (repr ty).tdesc with

206

 Tstatic (_, ty) > is_scalar_type ty

207

 Tbool

208

 Tint

209

 Treal > true

210

 _ > false

211


212

let rec is_numeric_type ty =

213

match (repr ty).tdesc with

214

 Tstatic (_, ty) > is_numeric_type ty

215

 Tint

216

 Treal > true

217

 _ > false

218


219

let rec is_real_type ty =

220

match (repr ty).tdesc with

221

 Tstatic (_, ty) > is_real_type ty

222

 Treal > true

223

 _ > false

224


225

let rec is_bool_type ty =

226

match (repr ty).tdesc with

227

 Tstatic (_, ty) > is_bool_type ty

228

 Tbool > true

229

 _ > false

230


231

let get_clock_base_type ty =

232

match (repr ty).tdesc with

233

 Tclock ty > Some ty

234

 _ > None

235


236

let unclock_type ty =

237

let ty = repr ty in

238

match ty.tdesc with

239

 Tclock ty' > ty'

240

 _ > ty

241


242

let rec is_dimension_type ty =

243

match (repr ty).tdesc with

244

 Tint

245

 Tbool > true

246

 Tclock ty'

247

 Tstatic (_, ty') > is_dimension_type ty'

248

 _ > false

249


250

let dynamic_type ty =

251

let ty = repr ty in

252

match ty.tdesc with

253

 Tstatic (_, ty') > ty'

254

 _ > ty

255


256

let is_tuple_type ty =

257

match (repr ty).tdesc with

258

 Ttuple _ > true

259

 _ > false

260


261

let map_tuple_type f ty =

262

let ty = dynamic_type ty in

263

match ty.tdesc with

264

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

265

 _ > f ty

266


267

let rec is_struct_type ty =

268

match (repr ty).tdesc with

269

 Tstruct _ > true

270

 Tstatic (_, ty') > is_struct_type ty'

271

 _ > false

272


273

let struct_field_type ty field =

274

match (dynamic_type ty).tdesc with

275

 Tstruct fields >

276

(try

277

List.assoc field fields

278

with Not_found > assert false)

279

 _ > assert false

280


281

let rec is_array_type ty =

282

match (repr ty).tdesc with

283

 Tarray _ > true

284

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

285

 _ > false

286


287

let array_type_dimension ty =

288

match (dynamic_type ty).tdesc with

289

 Tarray (d, _) > d

290

 _ > (Format.eprintf "internal error: Types.array_type_dimension %a@." print_ty ty; assert false)

291


292

let rec array_type_multi_dimension ty =

293

match (dynamic_type ty).tdesc with

294

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

295

 _ > []

296


297

let array_element_type ty =

298

match (dynamic_type ty).tdesc with

299

 Tarray (_, ty') > ty'

300

 _ > (Format.eprintf "internal error: Types.array_element_type %a@." print_ty ty; assert false)

301


302

let rec array_base_type ty =

303

let ty = repr ty in

304

match ty.tdesc with

305

 Tarray (_, ty')

306

 Tstatic (_, ty') > array_base_type ty'

307

 _ > ty

308


309

let is_address_type ty =

310

is_array_type ty  is_struct_type ty  (is_real_type ty && !Options.mpfr)

311


312

let rec is_generic_type ty =

313

match (dynamic_type ty).tdesc with

314

 Tarray (d, ty') >

315

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

316

 _ > false

317


318

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

319

(ensured by language syntax) *)

320

let rec split_arrow ty =

321

match (repr ty).tdesc with

322

 Tarrow (tin,tout) > tin,tout

323

 Tstatic (_, ty') > split_arrow ty'

324

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

325

needs to be considered here *)

326

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

327


328

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

329

let type_of_type_list tyl =

330

if (List.length tyl) > 1 then

331

new_ty (Ttuple tyl)

332

else

333

List.hd tyl

334


335

let rec type_list_of_type ty =

336

match (repr ty).tdesc with

337

 Tstatic (_, ty) > type_list_of_type ty

338

 Ttuple tl > tl

339

 _ > [ty]

340


341

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

342

let rec is_polymorphic ty =

343

match ty.tdesc with

344

 Tenum _  Tvar  Tint  Treal  Tbool  Trat  Tconst _ > false

345

 Tclock ty > is_polymorphic ty

346

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

347

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

348

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

349

 Tlink t' > is_polymorphic t'

350

 Tarray (d, ty)

351

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

352

 Tunivar > true

353


354


355

let mktyptuple nb typ =

356

let array = Array.make nb typ in

357

Ttuple (Array.to_list array)

358


359


360


361

(* Local Variables: *)

362

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

363

(* End: *)
