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 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 unclock_type ty =

218

let ty = repr ty in

219

match ty.tdesc with

220

 Tclock ty' > ty'

221

 _ > ty

222


223

let rec is_dimension_type ty =

224

match (repr ty).tdesc with

225

 Tint

226

 Tbool > true

227

 Tclock ty'

228

 Tstatic (_, ty') > is_dimension_type ty'

229

 _ > false

230


231

let dynamic_type ty =

232

let ty = repr ty in

233

match ty.tdesc with

234

 Tstatic (_, ty') > ty'

235

 _ > ty

236


237

let is_tuple_type ty =

238

match (repr ty).tdesc with

239

 Ttuple _ > true

240

 _ > false

241


242

let map_tuple_type f ty =

243

let ty = dynamic_type ty in

244

match ty.tdesc with

245

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

246

 _ > f ty

247


248

let rec is_struct_type ty =

249

match (repr ty).tdesc with

250

 Tstruct _ > true

251

 Tstatic (_, ty') > is_struct_type ty'

252

 _ > false

253


254

let struct_field_type ty field =

255

match (dynamic_type ty).tdesc with

256

 Tstruct fields >

257

(try

258

List.assoc field fields

259

with Not_found > assert false)

260

 _ > assert false

261


262

let rec is_array_type ty =

263

match (repr ty).tdesc with

264

 Tarray _ > true

265

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

266

 _ > false

267


268

let array_type_dimension ty =

269

match (dynamic_type ty).tdesc with

270

 Tarray (d, _) > d

271

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

272


273

let rec array_type_multi_dimension ty =

274

match (dynamic_type ty).tdesc with

275

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

276

 _ > []

277


278

let array_element_type ty =

279

match (dynamic_type ty).tdesc with

280

 Tarray (_, ty') > ty'

281

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

282


283

let rec array_base_type ty =

284

let ty = repr ty in

285

match ty.tdesc with

286

 Tarray (_, ty')

287

 Tstatic (_, ty') > array_base_type ty'

288

 _ > ty

289


290

let is_address_type ty =

291

is_array_type ty  is_struct_type ty

292


293

let rec is_generic_type ty =

294

match (dynamic_type ty).tdesc with

295

 Tarray (d, ty') >

296

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

297

 _ > false

298


299

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

300

(ensured by language syntax) *)

301

let rec split_arrow ty =

302

match (repr ty).tdesc with

303

 Tarrow (tin,tout) > tin,tout

304

 Tstatic (_, ty') > split_arrow ty'

305

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

306

needs to be considered here *)

307

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

308


309

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

310

let type_of_type_list tyl =

311

if (List.length tyl) > 1 then

312

new_ty (Ttuple tyl)

313

else

314

List.hd tyl

315


316

let type_list_of_type ty =

317

match (repr ty).tdesc with

318

 Ttuple tl > tl

319

 _ > [ty]

320


321

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

322

let rec is_polymorphic ty =

323

match ty.tdesc with

324

 Tenum _  Tvar  Tint  Treal  Tbool  Trat  Tconst _ > false

325

 Tclock ty > is_polymorphic ty

326

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

327

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

328

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

329

 Tlink t' > is_polymorphic t'

330

 Tarray (d, ty)

331

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

332

 Tunivar > true

333


334


335

let mktyptuple nb typ =

336

let array = Array.make nb typ in

337

Ttuple (Array.to_list array)

338


339


340

(* Local Variables: *)

341

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

342

(* End: *)
