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 rec is_array_type ty =

255

match (repr ty).tdesc with

256

 Tarray _ > true

257

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

258

 _ > false

259


260

let array_type_dimension ty =

261

match (dynamic_type ty).tdesc with

262

 Tarray (d, _) > d

263

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

264


265

let rec array_type_multi_dimension ty =

266

match (dynamic_type ty).tdesc with

267

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

268

 _ > []

269


270

let array_element_type ty =

271

match (dynamic_type ty).tdesc with

272

 Tarray (_, ty') > ty'

273

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

274


275

let rec array_base_type ty =

276

let ty = repr ty in

277

match ty.tdesc with

278

 Tarray (_, ty')

279

 Tstatic (_, ty') > array_base_type ty'

280

 _ > ty

281


282

let is_address_type ty =

283

is_array_type ty  is_struct_type ty

284


285

let rec is_generic_type ty =

286

match (dynamic_type ty).tdesc with

287

 Tarray (d, ty') >

288

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

289

 _ > false

290


291

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

292

(ensured by language syntax) *)

293

let rec split_arrow ty =

294

match (repr ty).tdesc with

295

 Tarrow (tin,tout) > tin,tout

296

 Tstatic (_, ty') > split_arrow ty'

297

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

298

needs to be considered here *)

299

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

300


301

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

302

let type_of_type_list tyl =

303

if (List.length tyl) > 1 then

304

new_ty (Ttuple tyl)

305

else

306

List.hd tyl

307


308

let type_list_of_type ty =

309

match (repr ty).tdesc with

310

 Ttuple tl > tl

311

 _ > [ty]

312


313

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

314

let rec is_polymorphic ty =

315

match ty.tdesc with

316

 Tenum _  Tvar  Tint  Treal  Tbool  Trat  Tconst _ > false

317

 Tclock ty > is_polymorphic ty

318

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

319

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

320

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

321

 Tlink t' > is_polymorphic t'

322

 Tarray (d, ty)

323

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

324

 Tunivar > true

325


326


327

let mktyptuple nb typ =

328

let array = Array.make nb typ in

329

Ttuple (Array.to_list array)

330


331


332

(* Local Variables: *)

333

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

334

(* End: *)
