Commit | Line | Data |
---|---|---|
485bce71 | 1 | (* Copyright (C) 2007, 2008 Yoann Padioleau |
34e49164 C |
2 | * |
3 | * This program is free software; you can redistribute it and/or | |
4 | * modify it under the terms of the GNU General Public License (GPL) | |
5 | * version 2 as published by the Free Software Foundation. | |
6 | * | |
7 | * This program is distributed in the hope that it will be useful, | |
8 | * but WITHOUT ANY WARRANTY; without even the implied warranty of | |
9 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
10 | * file license.txt for more details. | |
11 | *) | |
12 | open Common | |
13 | ||
14 | open Ast_c | |
15 | ||
16 | module Lib = Lib_parsing_c | |
17 | ||
18 | (*****************************************************************************) | |
19 | (* can either: | |
20 | * | |
21 | * - do a kind of inferer | |
22 | * * can first do a simple inferer, that just pass context | |
23 | * * then a real inferer, managing partial info. | |
24 | * type context = fullType option | |
25 | * | |
26 | * - extract the information from the .h files | |
27 | * (so no inference at all needed) | |
28 | * | |
29 | * todo: expression contain types, and statements, which in turn can contain | |
30 | * expression, so need recurse. Need define an annote_statement and | |
31 | * annotate_type. | |
32 | ||
33 | * todo: how deal with typedef isomorphisms ? How store them in Ast_c ? | |
34 | * store all posible variations in ast_c ? a list of type instead of just | |
35 | * the type ? | |
36 | * | |
37 | * todo: define a new type ? like type_cocci ? where have a bool ? | |
38 | * | |
39 | * How handle scope ? When search for type of field, we return | |
40 | * a type, but this type makes sense only in a certain scope. | |
41 | * We could add a tag to each typedef, structUnionName to differentiate | |
42 | * them and also associate in ast_c to the type the scope | |
43 | * of this type, the env that were used to define this type. | |
44 | *) | |
45 | ||
46 | (*****************************************************************************) | |
47 | (* Wrappers *) | |
48 | (*****************************************************************************) | |
49 | let pr2 s = | |
50 | if !Flag_parsing_c.verbose_type | |
51 | then Common.pr2 s | |
52 | ||
53 | (*****************************************************************************) | |
54 | (* Environment *) | |
55 | (*****************************************************************************) | |
56 | ||
57 | (* the different namespaces from stdC manual: | |
58 | * | |
59 | * You introduce two new name spaces with every block that you write. | |
60 | * One name space includes all functions, objects, type definitions, | |
61 | * and enumeration constants that you declare or define within the | |
62 | * block. The other name space includes all enumeration, structure, and | |
63 | * union tags that you define within the block. | |
64 | * | |
65 | * You introduce a new member name space with every structure or union | |
66 | * whose content you define. You identify a member name space by the | |
67 | * type of left operand that you write for a member selection | |
68 | * operator, as in x.y or p->y. A member name space ends with the end | |
69 | * of the block in which you declare it. | |
70 | * | |
71 | * You introduce a new goto label name space with every function | |
72 | * definition you write. Each goto label name space ends with its | |
73 | * function definition. | |
74 | *) | |
75 | ||
76 | (* But I don't try to do a type-checker, I try to "resolve" type of var | |
77 | * so don't need make difference between namespaces here. | |
78 | * | |
79 | * But, why not make simply a (string, kindstring) assoc ? | |
80 | * Because we dont want that a variable shadow a struct definition, because | |
81 | * they are still in 2 different namespace. But could for typedef, | |
82 | * because VarOrFunc and Typedef are in the same namespace. | |
83 | * But could do a record as in c_info.ml | |
84 | *) | |
85 | ||
86 | ||
87 | (* the wrap for StructUnionNameDef contain the whole ii, the i for | |
88 | * the string, the structUnion and the structType | |
89 | *) | |
90 | type namedef = | |
91 | | VarOrFunc of string * Ast_c.exp_type | |
92 | | TypeDef of string * fullType | |
93 | | StructUnionNameDef of string * (structUnion * structType) wrap | |
94 | (* todo: EnumConstant *) | |
95 | (* todo: EnumDef *) | |
96 | ||
97 | (* because have nested scope, have nested list, hence the list list *) | |
98 | type environment = namedef list list | |
99 | ||
100 | let initial_env = [ | |
101 | [VarOrFunc("NULL",(Lib.al_type (Parse_c.type_of_string "void *"), | |
102 | Ast_c.NotLocalVar))] | |
103 | ] | |
104 | ||
105 | ||
106 | let rec lookup_env f env = | |
107 | match env with | |
108 | | [] -> raise Not_found | |
109 | | []::zs -> lookup_env f zs | |
110 | | (x::xs)::zs -> | |
111 | match f x with | |
112 | | None -> lookup_env f (xs::zs) | |
113 | | Some y -> y, xs::zs | |
114 | ||
115 | ||
116 | ||
117 | let lookup_var s env = | |
118 | let f = function | |
119 | | VarOrFunc (s2, typ) -> if s2 = s then Some typ else None | |
120 | | _ -> None | |
121 | in | |
122 | lookup_env f env | |
123 | ||
124 | let lookup_typedef s env = | |
125 | let f = function | |
126 | | TypeDef (s2, typ) -> if s2 = s then Some typ else None | |
127 | | _ -> None | |
128 | in | |
129 | lookup_env f env | |
130 | ||
131 | let lookup_structunion (_su, s) env = | |
132 | let f = function | |
133 | | StructUnionNameDef (s2, typ) -> if s2 = s then Some typ else None | |
134 | | _ -> None | |
135 | in | |
136 | lookup_env f env | |
137 | ||
138 | let member_env lookupf env = | |
139 | try | |
140 | let _ = lookupf env in | |
141 | true | |
142 | with Not_found -> false | |
143 | ||
144 | (*****************************************************************************) | |
145 | (* "type-lookup" *) | |
146 | (*****************************************************************************) | |
147 | ||
148 | (* find_final_type is used to know to what type a field correspond in | |
149 | * x.foo. Sometimes the type of x is a typedef or a structName in which | |
150 | * case we must look in environment to find the complete type, here | |
151 | * structUnion that contains the information. | |
152 | * | |
153 | * Because in C one can redefine in nested blocks some typedefs, | |
154 | * struct, or variables, we have a static scoping resolving process. | |
155 | * So, when we look for the type of a var, if this var is in an | |
156 | * enclosing block, then maybe its type refer to a typdef of this | |
157 | * enclosing block, so must restart the "type-resolving" of this | |
158 | * typedef from this enclosing block, not from the bottom. So our | |
159 | * "resolving-type functions" take an env and also return an env from | |
160 | * where the next search must be performed. *) | |
161 | ||
162 | (* | |
163 | let rec find_final_type ty env = | |
164 | ||
165 | match Ast_c.unwrap_typeC ty with | |
166 | | BaseType x -> (BaseType x) +> Ast_c.rewrap_typeC ty | |
167 | ||
168 | | Pointer t -> (Pointer (find_final_type t env)) +> Ast_c.rewrap_typeC ty | |
169 | | Array (e, t) -> Array (e, find_final_type t env) +> Ast_c.rewrap_typeC ty | |
170 | ||
171 | | StructUnion (sopt, su) -> StructUnion (sopt, su) +> Ast_c.rewrap_typeC ty | |
172 | ||
173 | | FunctionType t -> (FunctionType t) (* todo ? *) +> Ast_c.rewrap_typeC ty | |
174 | | Enum (s, enumt) -> (Enum (s, enumt)) (* todo? *) +> Ast_c.rewrap_typeC ty | |
175 | | EnumName s -> (EnumName s) (* todo? *) +> Ast_c.rewrap_typeC ty | |
176 | ||
177 | | StructUnionName (su, s) -> | |
178 | (try | |
179 | let ((structtyp,ii), env') = lookup_structunion (su, s) env in | |
180 | Ast_c.nQ, (StructUnion (Some s, structtyp), ii) | |
181 | (* old: +> Ast_c.rewrap_typeC ty | |
182 | * but must wrap with good ii, otherwise pretty_print_c | |
183 | * will be lost and raise some Impossible | |
184 | *) | |
185 | with Not_found -> | |
186 | ty | |
187 | ) | |
188 | ||
189 | | TypeName s -> | |
190 | (try | |
191 | let (t', env') = lookup_typedef s env in | |
192 | find_final_type t' env' | |
193 | with Not_found -> | |
194 | ty | |
195 | ) | |
196 | ||
197 | | ParenType t -> find_final_type t env | |
198 | | Typeof e -> failwith "typeof" | |
199 | *) | |
200 | ||
201 | ||
202 | ||
203 | ||
204 | let rec type_unfold_one_step ty env = | |
205 | ||
206 | match Ast_c.unwrap_typeC ty with | |
207 | | BaseType x -> ty | |
208 | | Pointer t -> ty | |
209 | | Array (e, t) -> ty | |
210 | | StructUnion (sopt, su, fields) -> ty | |
211 | ||
212 | | FunctionType t -> ty | |
213 | | Enum (s, enumt) -> ty | |
214 | | EnumName s -> ty | |
215 | ||
216 | | StructUnionName (su, s) -> | |
217 | (try | |
218 | let (((su,fields),ii), env') = lookup_structunion (su, s) env in | |
219 | Ast_c.nQ, (StructUnion (su, Some s, fields), ii) | |
220 | (* old: +> Ast_c.rewrap_typeC ty | |
221 | * but must wrap with good ii, otherwise pretty_print_c | |
222 | * will be lost and raise some Impossible | |
223 | *) | |
224 | with Not_found -> | |
225 | ty | |
226 | ) | |
227 | ||
228 | | TypeName (s,_typ) -> | |
229 | (try | |
230 | let (t', env') = lookup_typedef s env in | |
231 | type_unfold_one_step t' env' | |
232 | with Not_found -> | |
233 | ty | |
234 | ) | |
235 | ||
236 | | ParenType t -> type_unfold_one_step t env | |
237 | | TypeOfExpr e -> | |
238 | pr2_once ("Type_annoter: not handling typeof"); | |
239 | ty | |
240 | | TypeOfType t -> type_unfold_one_step t env | |
241 | ||
242 | ||
243 | ||
244 | let (type_field: | |
245 | string -> (Ast_c.structUnion * Ast_c.structType) -> Ast_c.fullType) = | |
246 | fun fld (su, fields) -> | |
247 | fields +> Common.find_some (fun x -> | |
248 | match Ast_c.unwrap x with | |
485bce71 | 249 | | DeclarationField (FieldDeclList (onefield_multivars, iiptvirg)) -> |
34e49164 C |
250 | Common.optionise (fun () -> |
251 | onefield_multivars +> Common.find_some (fun fieldkind -> | |
252 | ||
253 | match Ast_c.unwrap (Ast_c.unwrap fieldkind) with | |
254 | | Simple (Some s, t) | BitField (Some s, t, _) -> | |
255 | if s = fld then Some t else None | |
256 | | _ -> None | |
257 | ) | |
258 | ) | |
259 | | EmptyField -> None | |
485bce71 C |
260 | | MacroStructDeclTodo -> pr2 "DeclTodo"; None |
261 | | CppDirectiveStruct _ | |
262 | | IfdefStruct _ -> pr2 "StructCpp"; None | |
34e49164 C |
263 | ) |
264 | ||
265 | ||
266 | ||
267 | ||
268 | let structdef_to_struct_name ty = | |
269 | match ty with | |
270 | | qu, (StructUnion (su, sopt, fields), iis) -> | |
271 | (match sopt,iis with | |
272 | | Some s , [i1;i2;i3;i4] -> | |
273 | qu, (StructUnionName (su, s), [i1;i2]) | |
274 | | None, _ -> | |
275 | ty | |
276 | ||
277 | | x -> raise Impossible | |
278 | ) | |
279 | | _ -> raise Impossible | |
280 | ||
281 | ||
282 | ||
283 | let rec typedef_fix ty env = | |
284 | ||
285 | match Ast_c.unwrap_typeC ty with | |
286 | | BaseType x -> ty | |
287 | | Pointer t -> Pointer (typedef_fix t env) +> Ast_c.rewrap_typeC ty | |
288 | | Array (e, t) -> Array (e, typedef_fix t env) +> Ast_c.rewrap_typeC ty | |
289 | | StructUnion (su, sopt, fields) -> structdef_to_struct_name ty | |
290 | | FunctionType ft -> | |
291 | (FunctionType ft) (* todo ? *) +> Ast_c.rewrap_typeC ty | |
292 | | Enum (s, enumt) -> | |
293 | (Enum (s, enumt)) (* todo? *) +> Ast_c.rewrap_typeC ty | |
294 | | EnumName s -> | |
295 | (EnumName s) (* todo? *) +> Ast_c.rewrap_typeC ty | |
296 | ||
297 | (* we prefer StructUnionName to StructUnion when it comes to typed metavar *) | |
298 | | StructUnionName (su, s) -> ty | |
299 | ||
300 | | TypeName (s, _typ) -> | |
301 | (try | |
302 | let (t', env') = lookup_typedef s env in | |
303 | TypeName (s, Some (typedef_fix t' env)) +> Ast_c.rewrap_typeC ty | |
304 | with Not_found -> | |
305 | ty | |
306 | ) | |
307 | ||
308 | | ParenType t -> typedef_fix t env | |
309 | | TypeOfExpr e -> | |
310 | pr2_once ("Type_annoter: not handling typeof"); | |
311 | ty | |
312 | ||
313 | | TypeOfType t -> typedef_fix t env | |
314 | ||
315 | (*****************************************************************************) | |
316 | (* (Semi) Globals, Julia's style *) | |
317 | (*****************************************************************************) | |
318 | ||
319 | (* opti: cache ? use hash ? *) | |
320 | let _scoped_env = ref initial_env | |
321 | ||
322 | (* memoise unnanoted var, to avoid too much warning messages *) | |
323 | let _notyped_var = ref (Hashtbl.create 100) | |
324 | ||
325 | let new_scope() = _scoped_env := []::!_scoped_env | |
326 | let del_scope() = _scoped_env := List.tl !_scoped_env | |
327 | ||
328 | let do_in_new_scope f = | |
329 | begin | |
330 | new_scope(); | |
331 | let res = f() in | |
332 | del_scope(); | |
333 | res | |
334 | end | |
335 | ||
336 | let add_in_scope namedef = | |
337 | let (current, older) = Common.uncons !_scoped_env in | |
338 | _scoped_env := (namedef::current)::older | |
339 | ||
340 | (* sort of hackish... *) | |
341 | let islocal info = | |
342 | if List.length (!_scoped_env) = List.length initial_env | |
343 | then Ast_c.NotLocalVar | |
344 | else Ast_c.LocalVar info | |
345 | ||
346 | (* the warning argument is here to allow some binding to overwrite an | |
347 | * existing one. With function, we first have the protype and then the def | |
348 | * and the def binding the same string is not an error. | |
349 | * todo?: but if we define two times the same function, then we will not | |
350 | * detect it :( would require to make a diff between adding a binding | |
351 | * from a prototype and from a definition. | |
352 | *) | |
353 | let add_binding namedef warning = | |
354 | let (current_scope, _older_scope) = Common.uncons !_scoped_env in | |
355 | ||
356 | (match namedef with | |
357 | | VarOrFunc (s, typ) -> | |
358 | if Hashtbl.mem !_notyped_var s | |
359 | then pr2 ("warning: found typing information for a variable that was" ^ | |
360 | "previously unknown:" ^ s); | |
361 | | _ -> () | |
362 | ); | |
363 | ||
364 | let (memberf, s) = | |
365 | (match namedef with | |
366 | | VarOrFunc (s, typ) -> member_env (lookup_var s), s | |
367 | | TypeDef (s, typ) -> member_env (lookup_typedef s), s | |
368 | | StructUnionNameDef (s, (su, typ)) -> | |
369 | member_env (lookup_structunion (su, s)), s | |
370 | ) in | |
371 | ||
372 | if memberf [current_scope] && warning | |
373 | then pr2 ("Type_annoter: warning, " ^ s ^ | |
374 | " is already in current binding" ^ "\n" ^ | |
375 | " so there is a wierd shadowing"); | |
376 | add_in_scope namedef | |
377 | ||
378 | ||
379 | (*****************************************************************************) | |
380 | (* Helpers *) | |
381 | (*****************************************************************************) | |
382 | ||
383 | let make_info t = (Some t,Ast_c.NotTest) | |
384 | ||
385 | let type_of_s s = | |
386 | (Lib.al_type (Parse_c.type_of_string s), Ast_c.NotLocalVar) | |
387 | ||
388 | let noTypeHere = (None,Ast_c.NotTest) | |
389 | ||
390 | let do_with_type f (t,_test) = | |
391 | match t with | |
392 | | None -> noTypeHere | |
393 | | Some (t,_local) -> f t | |
394 | ||
395 | ||
396 | (*****************************************************************************) | |
397 | (* Entry point *) | |
398 | (*****************************************************************************) | |
399 | (* catch all the decl to grow the environment *) | |
400 | ||
401 | let rec (annotate_program2 : | |
402 | environment -> toplevel list -> (toplevel * environment Common.pair) list | |
403 | ) = fun env prog -> | |
404 | ||
405 | (* globals (re)initialialisation *) | |
406 | _scoped_env := env; | |
407 | _notyped_var := (Hashtbl.create 100); | |
408 | ||
409 | ||
410 | let bigf = { Visitor_c.default_visitor_c with | |
411 | ||
412 | Visitor_c.kexpr = (fun (k,bigf) expr -> | |
413 | k expr; (* recurse to set the types-ref of sub expressions *) | |
414 | let ty = | |
415 | match Ast_c.unwrap_expr expr with | |
416 | (* todo: should analyse the 's' for int to know if unsigned or not *) | |
417 | | Constant (String (s,kind)) -> make_info (type_of_s "char *") | |
418 | | Constant (Char (s,kind)) -> make_info (type_of_s "char") | |
419 | | Constant (Int (s)) -> make_info (type_of_s "int") | |
420 | | Constant (Float (s,kind)) -> | |
421 | let iinull = [] in | |
422 | make_info | |
423 | ((Ast_c.nQ, (BaseType (FloatType kind), iinull)), | |
424 | Ast_c.NotLocalVar) | |
425 | ||
426 | (* don't want a warning on the Ident that are a FunCall *) | |
427 | | FunCall (((Ident f, typ), ii), args) -> | |
428 | args +> List.iter (fun (e,ii) -> | |
429 | Visitor_c.vk_argument bigf e | |
430 | ); | |
431 | noTypeHere | |
432 | ||
433 | | Ident (s) -> | |
434 | (match (Common.optionise (fun () -> lookup_var s !_scoped_env)) with | |
435 | | Some ((typ,local),_nextenv) -> | |
436 | make_info ((typedef_fix typ !_scoped_env),local) | |
437 | | None -> | |
438 | if not (s =~ "[A-Z_]+") (* if macro then no warning *) | |
439 | then | |
440 | if not (Hashtbl.mem !_notyped_var s) | |
441 | then begin | |
442 | pr2 ("Type_annoter: not finding type for " ^ s); | |
443 | Hashtbl.add !_notyped_var s true; | |
444 | end; | |
445 | noTypeHere | |
446 | ) | |
447 | | Unary (e, UnMinus) | Unary (e, UnPlus) -> make_info (type_of_s "int") | |
448 | | Unary (e, DeRef) | |
449 | | ArrayAccess (e, _) -> | |
450 | (Ast_c.get_type_expr e) +> do_with_type (fun t -> | |
451 | (* todo: maybe not good env !! *) | |
452 | match Ast_c.unwrap_typeC (type_unfold_one_step t !_scoped_env) with | |
453 | | Pointer x | |
454 | | Array (_, x) -> | |
455 | make_info ((typedef_fix x !_scoped_env),Ast_c.NotLocalVar) | |
456 | | _ -> noTypeHere | |
457 | ) | |
458 | ||
459 | | RecordAccess (e, fld) -> | |
460 | (Ast_c.get_type_expr e) +> do_with_type (fun t -> | |
461 | match Ast_c.unwrap_typeC (type_unfold_one_step t !_scoped_env) with | |
462 | | StructUnion (su, sopt, fields) -> | |
463 | (try | |
464 | (* todo: which env ? *) | |
465 | make_info | |
466 | ((typedef_fix (type_field fld (su, fields)) !_scoped_env), | |
467 | Ast_c.NotLocalVar) | |
468 | with Not_found -> | |
469 | pr2 | |
470 | ("TYPE-ERROR: field '" ^ fld ^ "' does not belong in" ^ | |
471 | " struct '"^(match sopt with Some s -> s |_ -> "<anon>")^ | |
472 | "'"); | |
473 | noTypeHere | |
474 | ) | |
475 | | _ -> noTypeHere | |
476 | ) | |
477 | ||
478 | | RecordPtAccess (e, fld) -> | |
479 | (Ast_c.get_type_expr e) +> do_with_type (fun t -> | |
480 | match Ast_c.unwrap_typeC (type_unfold_one_step t !_scoped_env) with | |
481 | | Pointer (t) -> | |
482 | (match Ast_c.unwrap_typeC (type_unfold_one_step t !_scoped_env) | |
483 | with | |
484 | | StructUnion (su, sopt, fields) -> | |
485 | (try | |
486 | (* todo: which env ? *) | |
487 | make_info | |
488 | ((typedef_fix (type_field fld (su, fields)) !_scoped_env), | |
489 | Ast_c.NotLocalVar) | |
490 | with Not_found -> | |
491 | pr2 | |
492 | ("TYPE-ERROR: field '" ^ fld ^ "' does not belong in" ^ | |
493 | " struct '"^(match sopt with Some s -> s |_ -> "<anon>")^ | |
494 | "'"); | |
495 | noTypeHere | |
496 | ) | |
497 | ||
498 | | _ -> noTypeHere | |
499 | ) | |
500 | | _ -> noTypeHere | |
501 | ) | |
502 | | Cast (t, e) -> | |
503 | (* todo: add_types_expr [t] e ? *) | |
504 | make_info | |
505 | ((typedef_fix (Lib.al_type t) !_scoped_env),Ast_c.NotLocalVar) | |
506 | ||
507 | (* todo: check e2 ? *) | |
508 | | Assignment (e1, op, e2) -> | |
509 | Ast_c.get_type_expr e1 | |
510 | | ParenExpr e -> | |
511 | Ast_c.get_type_expr e | |
512 | ||
513 | | _ -> noTypeHere | |
514 | in | |
515 | Ast_c.set_type_expr expr ty | |
516 | ||
517 | ); | |
518 | ||
519 | Visitor_c.kstatement = (fun (k, bigf) st -> | |
520 | match st with | |
521 | | Compound statxs, ii -> do_in_new_scope (fun () -> k st); | |
522 | | _ -> k st | |
523 | ||
524 | ); | |
525 | Visitor_c.kdecl = (fun (k, bigf) d -> | |
526 | (match d with | |
527 | | (DeclList (xs, ii)) -> | |
485bce71 C |
528 | xs +> List.iter (fun ({v_namei = var; v_type = t; |
529 | v_storage = sto; v_local = local}, iicomma) -> | |
530 | ||
34e49164 C |
531 | let local = |
532 | match local with | |
533 | Ast_c.NotLocalDecl -> Ast_c.NotLocalVar | |
534 | | Ast_c.LocalDecl -> Ast_c.LocalVar (offset t) in | |
535 | ||
536 | (* to add possible definition in type found in Decl *) | |
537 | Visitor_c.vk_type bigf t; | |
538 | ||
539 | var +> do_option (fun ((s, ini), ii_s_ini) -> | |
540 | match sto with | |
541 | | StoTypedef, _inline -> | |
542 | add_binding (TypeDef (s,Lib.al_type t)) true; | |
543 | | _ -> | |
544 | add_binding (VarOrFunc (s, (Lib.al_type t, local))) true; | |
545 | (* int x = sizeof(x) is legal so need process ini *) | |
546 | ini +> Common.do_option (fun ini -> | |
547 | Visitor_c.vk_ini bigf ini); | |
548 | ); | |
549 | ); | |
550 | | _ -> k d | |
551 | ); | |
552 | ||
553 | ); | |
554 | ||
555 | Visitor_c.ktype = (fun (k, bigf) typ -> | |
556 | let (q, t) = Lib.al_type typ in | |
557 | match t with | |
558 | | StructUnion (su, Some s, structType),ii -> | |
559 | add_binding (StructUnionNameDef (s, ((su, structType),ii))) true; | |
560 | k typ (* todo: restrict ? new scope so use do_in_scope ? *) | |
561 | ||
562 | ||
563 | (* TODO: if have a TypeName, then maybe can fill the option | |
564 | * information. | |
565 | *) | |
566 | | _ -> k typ | |
567 | ||
568 | ); | |
569 | ||
570 | Visitor_c.ktoplevel = (fun (k, bigf) elem -> | |
571 | _notyped_var := Hashtbl.create 100; | |
572 | match elem with | |
573 | | Definition def -> | |
485bce71 C |
574 | let {f_name = funcs; |
575 | f_type = ((returnt, (paramst, b)) as ftyp); | |
576 | f_storage = sto; | |
577 | f_body = statxs},ii = def | |
34e49164 C |
578 | in |
579 | let (i1, i2) = | |
580 | match ii with | |
581 | | is::iifunc1::iifunc2::ibrace1::ibrace2::ifakestart::isto -> | |
582 | iifunc1, iifunc2 | |
583 | | _ -> raise Impossible | |
584 | in | |
585 | let typ' = Lib.al_type (Ast_c.nQ, (FunctionType ftyp, [i1;i2])) in | |
586 | ||
587 | add_binding (VarOrFunc (funcs, (typ',islocal i1.Ast_c.pinfo))) false; | |
588 | do_in_new_scope (fun () -> | |
589 | paramst +> List.iter (fun (((b, s, t), _),_) -> | |
590 | match s with | |
591 | | Some s -> | |
592 | let local = Ast_c.LocalVar (offset t) in | |
593 | add_binding (VarOrFunc (s,(Lib.al_type t,local))) true | |
594 | | None -> pr2 "no type, certainly because Void type ?" | |
595 | ); | |
596 | k elem | |
597 | ); | |
598 | | _ -> k elem | |
599 | ); | |
600 | } | |
601 | in | |
602 | ||
603 | prog +> List.map (fun elem -> | |
604 | let beforeenv = !_scoped_env in | |
605 | Visitor_c.vk_toplevel bigf elem; | |
606 | let afterenv = !_scoped_env in | |
607 | (elem, (beforeenv, afterenv)) | |
608 | ) | |
609 | ||
610 | and offset (_,(ty,iis)) = | |
611 | match iis with | |
612 | ii::_ -> ii.Ast_c.pinfo | |
613 | | _ -> failwith "type has no text; need to think again" | |
614 | ||
615 | ||
616 | let annotate_test_expressions prog = | |
617 | let rec propagate_test e = | |
618 | let ((e_term,info),_) = e in | |
619 | let (ty,_) = !info in | |
620 | info := (ty,Test); | |
621 | match e_term with | |
622 | Binary(e1,Logical(AndLog),e2) | |
623 | | Binary(e1,Logical(OrLog),e2) -> propagate_test e1; propagate_test e2 | |
624 | | Unary(e1,Not) -> propagate_test e1 | |
625 | | ParenExpr(e) -> propagate_test e | |
626 | | _ -> () in | |
627 | ||
628 | let bigf = { Visitor_c.default_visitor_c with | |
629 | Visitor_c.kexpr = (fun (k,bigf) expr -> | |
630 | (match unwrap expr with | |
631 | (CondExpr(e,_,_),_) -> propagate_test e | |
632 | | _ -> ()); | |
633 | k expr); | |
634 | Visitor_c.kstatement = (fun (k, bigf) st -> | |
635 | match unwrap st with | |
636 | Selection(s) -> | |
637 | (match s with If(e1,s1,s2) -> propagate_test e1 | _ -> ()); | |
638 | k st; | |
639 | | Iteration(i) -> | |
640 | (match i with | |
641 | While(e,s) -> propagate_test e | |
642 | | DoWhile(s,e) -> propagate_test e | |
643 | | For(_,es,_,_) -> | |
644 | (match unwrap es with Some e -> propagate_test e | None -> ()) | |
645 | | _ -> ()); | |
646 | k st | |
647 | | _ -> k st) } in | |
648 | (prog +> List.iter (fun elem -> | |
649 | Visitor_c.vk_toplevel bigf elem | |
650 | )) | |
651 | ||
652 | let annotate_program a types_needed = | |
653 | Common.profile_code "annotate_type" | |
654 | (fun () prog -> | |
655 | let res = | |
656 | if true (*types_needed*) | |
657 | then annotate_program2 a prog | |
658 | else prog +> List.map (fun c -> c, (initial_env, initial_env)) in | |
659 | annotate_test_expressions prog; | |
660 | res) |