← Back to branch summary

~ubuntu-branches/debian/sid/frama-c/sid

« back to all changes in this revision

Viewing changes to cil/src/cil.ml

  • Committer: Bazaar Package Importer
  • Author(s): Mehdi Dogguy
  • Date: 2009-06-03 08:19:25 UTC
  • Revision ID: james.westby@ubuntu.com-20090603081925-kihvxvt0wy3zc4ar
Tags: upstream-20081201.dfsg
Import upstream version 20081201.dfsg

Show diffs side-by-side

added added

removed removed

Lines of Context:
cil/src/cil.ml
 
1
(**************************************************************************)
 
2
(*                                                                        *)
 
3
(*  Copyright (C) 2001-2003,                                              *)
 
4
(*   George C. Necula    <necula@cs.berkeley.edu>                         *)
 
5
(*   Scott McPeak        <smcpeak@cs.berkeley.edu>                        *)
 
6
(*   Wes Weimer          <weimer@cs.berkeley.edu>                         *)
 
7
(*   Ben Liblit          <liblit@cs.berkeley.edu>                         *)
 
8
(*  All rights reserved.                                                  *)
 
9
(*                                                                        *)
 
10
(*  Redistribution and use in source and binary forms, with or without    *)
 
11
(*  modification, are permitted provided that the following conditions    *)
 
12
(*  are met:                                                              *)
 
13
(*                                                                        *)
 
14
(*  1. Redistributions of source code must retain the above copyright     *)
 
15
(*  notice, this list of conditions and the following disclaimer.         *)
 
16
(*                                                                        *)
 
17
(*  2. Redistributions in binary form must reproduce the above copyright  *)
 
18
(*  notice, this list of conditions and the following disclaimer in the   *)
 
19
(*  documentation and/or other materials provided with the distribution.  *)
 
20
(*                                                                        *)
 
21
(*  3. The names of the contributors may not be used to endorse or        *)
 
22
(*  promote products derived from this software without specific prior    *)
 
23
(*  written permission.                                                   *)
 
24
(*                                                                        *)
 
25
(*  THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS   *)
 
26
(*  "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT     *)
 
27
(*  LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS     *)
 
28
(*  FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE        *)
 
29
(*  COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,   *)
 
30
(*  INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,  *)
 
31
(*  BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;      *)
 
32
(*  LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER      *)
 
33
(*  CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT    *)
 
34
(*  LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN     *)
 
35
(*  ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE       *)
 
36
(*  POSSIBILITY OF SUCH DAMAGE.                                           *)
 
37
(*                                                                        *)
 
38
(*  File modified by CEA (Commissariat � l'�nergie Atomique).             *)
 
39
(**************************************************************************)
 
40
 
 
41
  (*
 
42
 * CIL: An intermediate language for analyzing C progams.
 
43
 *
 
44
 * Version Tue Dec 12 15:21:52 PST 2000
 
45
 * Scott McPeak, George Necula, Wes Weimer
 
46
 *
 
47
 *)
 
48
 
 
49
open Escape
 
50
module S = Stack
 
51
open Cilutil
 
52
module Stack = S
 
53
open Format
 
54
open Trace      (* sm: 'trace' function *)
 
55
module C = Cilutil
 
56
module E = Errormsg
 
57
module H = Hashtbl
 
58
module IH = Inthash
 
59
 
 
60
(* ************************************************************************* *)
 
61
(* Reporting messages *)
 
62
(* ************************************************************************* *)
 
63
 
 
64
(* A reference to the current location *)
 
65
module CurrentLoc = Logic_env.CurrentLoc
 
66
 
 
67
(* Some error reporting functions *)
 
68
let d_loc fmt loc =
 
69
  fprintf fmt "%s:%d" (fst loc).Lexing.pos_fname (fst loc).Lexing.pos_lnum
 
70
(*  fprintf fmt "File %S, line %d, characters %d-%d"
 
71
    (fst loc).Lexing.pos_fname (fst loc).Lexing.pos_lnum
 
72
    ((fst loc).Lexing.pos_cnum - (fst loc).Lexing.pos_bol)
 
73
    ((snd loc).Lexing.pos_cnum - (fst loc).Lexing.pos_bol)
 
74
*)
 
75
let rec fprintfList ~sep (f:formatter -> 'a -> unit) fmt l =
 
76
  match l with
 
77
  | [] -> ()
 
78
  | [e] -> f fmt e
 
79
  | x::r -> fprintf fmt ("%a" ^^ sep ^^ "%a") f x (fprintfList ~sep f) r
 
80
 
 
81
(*Ok for ocaml >= 3.09.3 : fprintf fmt "%a%(%)%a" f x sep (fprintfList ~sep f) r *)
 
82
 
 
83
let d_thisloc (fmt: formatter) : unit = d_loc fmt (CurrentLoc.get ())
 
84
 
 
85
let generic_report_error msg fmt =
 
86
  let f fmt fstring =
 
87
    E.hadErrors := true;
 
88
    fprintf fmt (fstring ^^ "@]@.")
 
89
  in
 
90
  kfprintf f fmt "@[%t: %s: " d_thisloc msg
 
91
 
 
92
let error_loc (file,line,start_byte,stop_byte) msg =
 
93
  let f fmt fstring =
 
94
    fprintf fmt (fstring ^^ "@]@.")
 
95
  in
 
96
  kfprintf f err_formatter "@[File %S, line %d, characters %d-%d: "  file line start_byte stop_byte msg
 
97
 
 
98
let error fstring = generic_report_error "Error" err_formatter fstring
 
99
 
 
100
let unimp fstring = generic_report_error "Unimplemented" err_formatter fstring
 
101
 
 
102
let generic_bug s fstring =
 
103
  let f fmt =
 
104
    E.hadErrors := true;
 
105
    kfprintf (fun _ -> E.showContext (); raise E.Error) fmt (fstring ^^ "@]@.")
 
106
  in
 
107
  kfprintf f err_formatter "@[%t: %s: " d_thisloc s
 
108
 
 
109
let bug fstring = generic_bug "Bug" fstring
 
110
let fatal_error fstring = generic_bug "Fatal error" fstring
 
111
let fatal_unimp fstring = generic_bug "Fatal unimplemented" fstring
 
112
 
 
113
let errorLoc loc fstring =
 
114
  let f fmt =
 
115
    E.hadErrors := true;
 
116
    kfprintf (fun _ -> E.showContext ()) fmt (fstring ^^ "@]@.")
 
117
  in
 
118
  kfprintf f err_formatter "@[%a: Error: " d_loc loc
 
119
 
 
120
let do_not_fprintf fstring =
 
121
    kfprintf (fun _ -> ()) (Format.make_formatter (fun _ _ _ -> ()) (fun _ -> ())) fstring
 
122
 
 
123
let fprintf_to_string fstring =
 
124
  let b = Buffer.create 17 in
 
125
  let fmt = formatter_of_buffer b in
 
126
  kfprintf (fun fmt -> pp_print_flush fmt ();
 
127
              Buffer.contents b) fmt fstring
 
128
 
 
129
let warn fstring = Messages_manager.emit (CurrentLoc.get ()) `Warning fstring
 
130
 
 
131
let warnOpt fstring =
 
132
  if !E.warnFlag then
 
133
    warn fstring
 
134
  else
 
135
    do_not_fprintf fstring
 
136
 
 
137
let warnContext fstring =
 
138
  let f fmt =
 
139
    kfprintf (fun _ -> E.showContext ()) fmt (fstring ^^ "@]@.")
 
140
  in
 
141
  kfprintf f err_formatter "@[%t: Warning: " d_thisloc
 
142
 
 
143
let warnContextOpt fstring =
 
144
  if !E.warnFlag then
 
145
    warn fstring
 
146
  else
 
147
    do_not_fprintf fstring
 
148
 
 
149
let warnLoc loc fstring =  Messages_manager.emit loc `Warning fstring
 
150
 
 
151
let logLoc loc fstring = Messages_manager.emit loc `Info fstring
 
152
 
 
153
(*let log fstring = Messages_manager.emit (CurrentLoc.get()) `Info fstring*)
 
154
let log fstring = Format.eprintf ("@[" ^^ fstring ^^ "@]@.")
 
155
 
 
156
(* ************************************************************************* *)
 
157
(* ************************************************************************* *)
 
158
(* ************************************************************************* *)
 
159
 
 
160
let print_utf8 = ref true
 
161
 
 
162
let () =
 
163
  pp_set_margin err_formatter max_int
 
164
 
 
165
(* The module Cilversion is generated automatically by Makefile from
 
166
 * information in configure.in *)
 
167
let cilVersion         = Cilversion.cilVersion
 
168
let cilVersionMajor    = Cilversion.cilVersionMajor
 
169
let cilVersionMinor    = Cilversion.cilVersionMinor
 
170
let cilVersionRevision = Cilversion.cilVersionRev
 
171
(*
 
172
module Build_BoolRef(X:sig val default:bool val name:string end) =
 
173
  Computation.Ref
 
174
    (struct include Datatype.Bool let default = X.default end)
 
175
    (struct
 
176
       let name = Project.Computation.Name.make X.name
 
177
       let dependencies = []
 
178
     end)
 
179
 
 
180
module Build_False
 
181
*)
 
182
 
 
183
open Cil_types
 
184
 
 
185
let voidType = TVoid([])
 
186
let intType = TInt(IInt,[])
 
187
let uintType = TInt(IUInt,[])
 
188
let longType = TInt(ILong,[])
 
189
let ulongType = TInt(IULong,[])
 
190
let charType = TInt(IChar, [])
 
191
 
 
192
let charPtrType = TPtr(charType,[])
 
193
let charConstPtrType = TPtr(TInt(IChar, [Attr("const", [])]),[])
 
194
 
 
195
let voidPtrType = TPtr(voidType, [])
 
196
let intPtrType = TPtr(intType, [])
 
197
let uintPtrType = TPtr(uintType, [])
 
198
 
 
199
let doubleType = TFloat(FDouble, [])
 
200
 
 
201
type theMachine =
 
202
    { mutable msvcMode: bool; (** Whether the pretty printer should
 
203
                                  print output for the MS VC
 
204
                                  compiler. Default is GCC *)
 
205
      mutable useLogicalOperators: bool;
 
206
      mutable theMachine: mach;
 
207
      (** Cil.initCil will set this to the current machine description. *)
 
208
      mutable lowerConstants: bool; (** Do lower constants (default true) *)
 
209
      mutable insertImplicitCasts: bool; (** Do insert implicit casts
 
210
                                             (default true) *)
 
211
      mutable little_endian: bool;
 
212
      mutable char_is_unsigned: bool;
 
213
      mutable underscore_name: bool;
 
214
      mutable enum_are_signed: bool;
 
215
      mutable stringLiteralType: typ;
 
216
      mutable upointType: typ;
 
217
      mutable wcharKind: ikind; (** An integer type that fits wchar_t. *)
 
218
      mutable wcharType: typ;
 
219
      mutable ptrdiffKind: ikind; (** An integer type that fits ptrdiff_t. *)
 
220
      mutable ptrdiffType: typ;
 
221
      mutable typeOfSizeOf: typ; (** An integer type that is the type of
 
222
                                      sizeof. *)
 
223
      mutable kindOfSizeOf: ikind }
 
224
 
 
225
type lineDirectiveStyle =
 
226
  | LineComment                (** Before every element, print the line
 
227
                                * number in comments. This is ignored by
 
228
                                * processing tools (thus errors are reproted
 
229
                                * in the CIL output), but useful for
 
230
                                * visual inspection *)
 
231
  | LineCommentSparse          (** Like LineComment but only print a line
 
232
                                * directive for a new source line *)
 
233
  | LinePreprocessorInput      (** Use #line directives *)
 
234
  | LinePreprocessorOutput     (** Use # nnn directives (in gcc mode) *)
 
235
 
 
236
type miscState =
 
237
    { mutable lineDirectiveStyle: lineDirectiveStyle option;
 
238
      mutable print_CIL_Input: bool;
 
239
      mutable printCilAsIs: bool;
 
240
      mutable lineLength: int;
 
241
      mutable warnTruncate: bool }
 
242
 
 
243
let createMachine () =
 
244
  { msvcMode = false;
 
245
    useLogicalOperators = false;
 
246
    theMachine = Machdep.state.Machdep.gcc;
 
247
    lowerConstants = false(*true*);
 
248
    insertImplicitCasts = true;
 
249
    little_endian = true;
 
250
    char_is_unsigned = false;
 
251
    underscore_name = true;
 
252
    enum_are_signed = true;
 
253
    stringLiteralType = charPtrType;
 
254
    upointType = voidType;
 
255
    wcharKind = IChar;
 
256
    wcharType = voidType;
 
257
    ptrdiffKind = IChar;
 
258
    ptrdiffType = voidType;
 
259
    typeOfSizeOf = voidType;
 
260
    kindOfSizeOf = IUInt }
 
261
 
 
262
let copyMachine src dst =
 
263
  dst.msvcMode <- src.msvcMode;
 
264
  dst.useLogicalOperators <- src.useLogicalOperators;
 
265
  dst.theMachine <- src.theMachine;
 
266
  dst.lowerConstants <- src.lowerConstants;
 
267
  dst.insertImplicitCasts <- src.insertImplicitCasts;
 
268
  dst.little_endian <- src.little_endian;
 
269
  dst.char_is_unsigned <- src.char_is_unsigned;
 
270
  dst.underscore_name <- src.underscore_name;
 
271
  dst.enum_are_signed <- src.enum_are_signed;
 
272
  dst.stringLiteralType <- src.stringLiteralType;
 
273
  dst.upointType <- src.upointType;
 
274
  dst.wcharKind <- src.wcharKind;
 
275
  dst.wcharType <- src.wcharType;
 
276
  dst.ptrdiffKind <- src.ptrdiffKind;
 
277
  dst.ptrdiffType <- src.ptrdiffType;
 
278
  dst.typeOfSizeOf <- src.typeOfSizeOf;
 
279
  dst.kindOfSizeOf <- src.kindOfSizeOf
 
280
 
 
281
(* A few globals that control the interpretation of C source *)
 
282
let theMachine = createMachine ()
 
283
 
 
284
let theMachineProject = ref (createMachine ())
 
285
module TheMachine =
 
286
  Project.Computation.Register
 
287
    (Project.Datatype.Imperative
 
288
       (struct
 
289
          type t = theMachine
 
290
          let copy x =
 
291
            let m = createMachine () in
 
292
            copyMachine x m;
 
293
            m
 
294
          let name = "theMachine"
 
295
        end))
 
296
    (struct
 
297
       type t = theMachine
 
298
       let create = createMachine
 
299
       let get () = !theMachineProject
 
300
       let set m =
 
301
         theMachineProject := m;
 
302
         copyMachine !theMachineProject theMachine
 
303
       let clear m = copyMachine (createMachine ()) m
 
304
     end)
 
305
    (struct
 
306
       let name = "theMachine"
 
307
       let dependencies = []
 
308
     end)
 
309
let () =
 
310
  Project.Selection.iter
 
311
    (fun k _ -> Project.Computation.add_dependency k TheMachine.self)
 
312
    Logic_env.builtin_states
 
313
 
 
314
let selfMachine = TheMachine.self
 
315
 
 
316
let set_msvcMode b = theMachine.msvcMode <- b
 
317
 
 
318
let miscState =
 
319
  { lineDirectiveStyle = Some LinePreprocessorInput;
 
320
    print_CIL_Input = false;
 
321
    printCilAsIs = false;
 
322
    lineLength = 80;
 
323
    warnTruncate = true }
 
324
 
 
325
(* sm: return the string 's' if we're printing output for gcc, suppres
 
326
 * it if we're printing for CIL to parse back in.  the purpose is to
 
327
 * hide things from gcc that it complains about, but still be able
 
328
 * to do lossless transformations when CIL is the consumer *)
 
329
let forgcc (s: string) : string = if miscState.print_CIL_Input then "" else s
 
330
 
 
331
 
 
332
let debugConstFold = false
 
333
 
 
334
module Build_Counter(Name:sig val name:string end) : sig
 
335
  val next: unit -> int
 
336
  val reset: unit -> unit
 
337
  val get: unit -> int
 
338
end = struct
 
339
  include Computation.Ref
 
340
    (struct include Datatype.Int let default () = 0 end)
 
341
    (struct
 
342
       let dependencies = []
 
343
       let name = Name.name
 
344
     end)
 
345
  let next () =
 
346
    let n = get () in
 
347
    if n = -1 then
 
348
      bug "Too many values for counter %s. Please report.@." Name.name;
 
349
    set (succ n);
 
350
    get ()
 
351
  let reset = clear
 
352
end
 
353
 
 
354
module Sid = Build_Counter(struct let name = "sid" end)
 
355
 
 
356
(** The Abstract Syntax of CIL *)
 
357
 
 
358
(** To be able to add/remove features easily, each feature should be packaged
 
359
   * as an interface with the following interface. These features should be *)
 
360
type featureDescr = {
 
361
    fd_enabled: bool ref;
 
362
    (** The enable flag. Set to default value  *)
 
363
 
 
364
    fd_name: string;
 
365
    (** This is used to construct an option "--doxxx" and "--dontxxx" that
 
366
     * enable and disable the feature  *)
 
367
 
 
368
    fd_description: string;
 
369
    (* A longer name that can be used to document the new options  *)
 
370
 
 
371
    fd_extraopt: (string * Arg.spec * string) list;
 
372
    (** Additional command line options.  The description strings should
 
373
        usually start with a space for Arg.align to print the --help nicely. *)
 
374
 
 
375
    fd_doit: (file -> unit);
 
376
    (** This performs the transformation *)
 
377
 
 
378
    fd_post_check: bool;
 
379
    (* Whether to perform a CIL consistency checking after this stage, if
 
380
     * checking is enabled (--check is passed to cilly) *)
 
381
}
 
382
 
 
383
(* A reference to the current global being visited *)
 
384
let currentGlobal: global ref = ref (GText "dummy")
 
385
 
 
386
 
 
387
let compareLoc (a: location) (b: location) : int = Pervasives.compare a b
 
388
(*   let namecmp = compare a.file b.file in *)
 
389
(*   if namecmp != 0 *)
 
390
(*   then namecmp *)
 
391
(*   else *)
 
392
(*     let linecmp = a.line - b.line in *)
 
393
(*     if linecmp != 0 *)
 
394
(*     then linecmp *)
 
395
(*     else a.byte - b.byte *)
 
396
 
 
397
let argsToList : (string * typ * attributes) list option
 
398
                  -> (string * typ * attributes) list
 
399
    = function
 
400
    None -> []
 
401
  | Some al -> al
 
402
 
 
403
 
 
404
(* A hack to allow forward reference of d_exp *)
 
405
let pd_exp : (formatter -> exp -> unit) ref =
 
406
  ref (fun _ -> E.s (E.bug "pd_exp not initialized"))
 
407
let pd_global : (formatter -> global -> unit) ref =
 
408
  ref (fun _ -> E.s (E.bug "pd_global not initialized"))
 
409
(*
 
410
let d_annotation =
 
411
  ref (fun _ _ -> E.s (E.bug "d_annotation not initialized"))
 
412
let d_code_annotation =
 
413
  ref (fun _ _ -> E.s (E.bug "d_code_annotation not initialized"))
 
414
let d_loop_annotation =
 
415
  ref (fun _ _ -> E.s (E.bug "d_loop_annotation not initialized"))
 
416
let d_funspec =
 
417
  ref (fun _ _ -> E.s (E.bug "d_funspec not initialized"))
 
418
*)
 
419
 
 
420
(** Different visiting actions. 'a will be instantiated with [exp], [instr],
 
421
    etc. *)
 
422
type 'a visitAction =
 
423
    SkipChildren                        (** Do not visit the children. Return
 
424
                                            the node as it is. *)
 
425
  | DoChildren                          (** Continue with the children of this
 
426
                                            node. Rebuild the node on return
 
427
                                            if any of the children changes
 
428
                                            (use == test) *)
 
429
  | ChangeTo of 'a                      (** Replace the expression with the
 
430
                                            given one *)
 
431
  | ChangeToPost of 'a * ('a -> 'a)
 
432
 
 
433
  | ChangeDoChildrenPost of 'a * ('a -> 'a) (** First consider that the entire
 
434
                                           exp is replaced by the first
 
435
                                           parameter. Then continue with
 
436
                                           the children. On return rebuild
 
437
                                           the node if any of the children
 
438
                                           has changed and then apply the
 
439
                                           function on the node *)
 
440
 
 
441
type visitor_behavior =
 
442
    {
 
443
      (* copy mutable structure which are not shared across the AST*)
 
444
      cfile: file -> file;
 
445
      cinitinfo: initinfo -> initinfo;
 
446
      cfundec: fundec -> fundec;
 
447
      cblock: block -> block;
 
448
      cfunspec: funspec -> funspec;
 
449
      cfunbehavior: funbehavior -> funbehavior;
 
450
      (* get the copy of a shared value *)
 
451
      get_stmt: stmt -> stmt;
 
452
      get_compinfo: compinfo -> compinfo;
 
453
      get_fieldinfo: fieldinfo -> fieldinfo;
 
454
      get_enuminfo: enuminfo -> enuminfo;
 
455
      get_enumitem: enumitem -> enumitem;
 
456
      get_typeinfo: typeinfo -> typeinfo;
 
457
      get_varinfo: varinfo -> varinfo;
 
458
      get_logic_info: logic_info -> logic_info;
 
459
(*
 
460
      get_predicate_info: predicate_info -> predicate_info;
 
461
*)
 
462
      get_logic_var: logic_var -> logic_var;
 
463
      (* get the original value tied to a copy *)
 
464
      get_original_stmt: stmt -> stmt;
 
465
      get_original_compinfo: compinfo -> compinfo;
 
466
      get_original_fieldinfo: fieldinfo -> fieldinfo;
 
467
      get_original_enuminfo: enuminfo -> enuminfo;
 
468
      get_original_enumitem: enumitem -> enumitem;
 
469
      get_original_typeinfo: typeinfo -> typeinfo;
 
470
      get_original_varinfo: varinfo -> varinfo;
 
471
      get_original_logic_info: logic_info -> logic_info;
 
472
(*
 
473
      get_original_predicate_info: predicate_info -> predicate_info;
 
474
*)
 
475
      get_original_logic_var: logic_var -> logic_var;
 
476
      (* change a binding... use with care *)
 
477
      set_stmt: stmt -> stmt -> unit;
 
478
      set_compinfo: compinfo -> compinfo -> unit;
 
479
      set_fieldinfo: fieldinfo -> fieldinfo -> unit;
 
480
      set_enuminfo: enuminfo -> enuminfo -> unit;
 
481
      set_enumitem: enumitem -> enumitem -> unit;
 
482
      set_typeinfo: typeinfo -> typeinfo -> unit;
 
483
      set_varinfo: varinfo -> varinfo -> unit;
 
484
      set_logic_info: logic_info -> logic_info -> unit;
 
485
(*
 
486
      set_predicate_info: predicate_info -> predicate_info -> unit;
 
487
*)
 
488
      set_logic_var: logic_var -> logic_var -> unit;
 
489
      (* change a reference... use with care *)
 
490
      set_orig_stmt: stmt -> stmt -> unit;
 
491
      set_orig_compinfo: compinfo -> compinfo -> unit;
 
492
      set_orig_fieldinfo: fieldinfo -> fieldinfo -> unit;
 
493
      set_orig_enuminfo: enuminfo -> enuminfo -> unit;
 
494
      set_orig_enumitem: enumitem -> enumitem -> unit;
 
495
      set_orig_typeinfo: typeinfo -> typeinfo -> unit;
 
496
      set_orig_varinfo: varinfo -> varinfo -> unit;
 
497
      set_orig_logic_info: logic_info -> logic_info -> unit;
 
498
(*
 
499
      set_orig_predicate_info: predicate_info -> predicate_info -> unit;
 
500
*)
 
501
      set_orig_logic_var: logic_var -> logic_var -> unit;
 
502
      (* copy fields that can referenced in other places of the AST*)
 
503
      memo_stmt: stmt -> stmt;
 
504
      memo_varinfo: varinfo -> varinfo;
 
505
      memo_compinfo: compinfo -> compinfo;
 
506
      memo_enuminfo: enuminfo -> enuminfo;
 
507
      memo_enumitem: enumitem -> enumitem;
 
508
      memo_typeinfo: typeinfo -> typeinfo;
 
509
      memo_logic_info: logic_info -> logic_info;
 
510
(*
 
511
      memo_predicate_info: predicate_info -> predicate_info;
 
512
*)
 
513
      memo_fieldinfo: fieldinfo -> fieldinfo;
 
514
      memo_logic_var: logic_var -> logic_var;
 
515
      (* is the behavior a copy behavior *)
 
516
      is_copy_behavior: bool;
 
517
      (* reset memoizing tables *)
 
518
      reset_behavior_varinfo: unit -> unit;
 
519
      reset_behavior_compinfo: unit -> unit;
 
520
      reset_behavior_enuminfo: unit -> unit;
 
521
      reset_behavior_enumitem: unit -> unit;
 
522
      reset_behavior_typeinfo: unit -> unit;
 
523
      reset_behavior_logic_info: unit -> unit;
 
524
(*
 
525
      reset_behavior_predicate_info: unit -> unit;
 
526
*)
 
527
      reset_behavior_fieldinfo: unit -> unit;
 
528
      reset_behavior_stmt: unit -> unit;
 
529
      reset_logic_var: unit -> unit;
 
530
    }
 
531
 
 
532
let is_copy_behavior b = b.is_copy_behavior
 
533
 
 
534
let reset_behavior_varinfo b = b.reset_behavior_varinfo ()
 
535
let reset_behavior_compinfo b = b.reset_behavior_compinfo ()
 
536
let reset_behavior_enuminfo b = b.reset_behavior_enuminfo ()
 
537
let reset_behavior_enumitem b = b.reset_behavior_enumitem ()
 
538
let reset_behavior_typeinfo b = b.reset_behavior_typeinfo ()
 
539
let reset_behavior_logic_info b = b.reset_behavior_logic_info ()
 
540
(*
 
541
let reset_behavior_predicate_info b = b.reset_behavior_predicate_info ()
 
542
*)
 
543
let reset_behavior_fieldinfo b = b.reset_behavior_fieldinfo ()
 
544
let reset_behavior_stmt b = b.reset_behavior_stmt ()
 
545
let reset_logic_var b = b.reset_logic_var ()
 
546
 
 
547
let get_varinfo b = b.get_varinfo
 
548
let get_compinfo b = b.get_compinfo
 
549
let get_fieldinfo b = b.get_fieldinfo
 
550
let get_enuminfo b = b.get_enuminfo
 
551
let get_enumitem b = b.get_enumitem
 
552
let get_stmt b = b.get_stmt
 
553
let get_typeinfo b = b.get_typeinfo
 
554
let get_logic_info b = b.get_logic_info
 
555
(*
 
556
let get_predicate_info b = b.get_predicate_info
 
557
*)
 
558
let get_logic_var b = b.get_logic_var
 
559
 
 
560
let get_original_varinfo b = b.get_original_varinfo
 
561
let get_original_compinfo b = b.get_original_compinfo
 
562
let get_original_fieldinfo b = b.get_original_fieldinfo
 
563
let get_original_enuminfo b = b.get_original_enuminfo
 
564
let get_original_enumitem b = b.get_original_enumitem
 
565
let get_original_stmt b = b.get_original_stmt
 
566
let get_original_typeinfo b = b.get_original_typeinfo
 
567
let get_original_logic_info b = b.get_original_logic_info
 
568
(*
 
569
let get_original_predicate_info b = b.get_original_predicate_info
 
570
*)
 
571
let get_original_logic_var b = b.get_original_logic_var
 
572
 
 
573
let set_varinfo b = b.set_varinfo
 
574
let set_compinfo b = b.set_compinfo
 
575
let set_fieldinfo b = b.set_fieldinfo
 
576
let set_enuminfo b = b.set_enuminfo
 
577
let set_enumitem b = b.set_enumitem
 
578
let set_stmt b = b.set_stmt
 
579
let set_typeinfo b = b.set_typeinfo
 
580
let set_logic_info b = b.set_logic_info
 
581
(*
 
582
let set_predicate_info b = b.set_predicate_info
 
583
*)
 
584
let set_logic_var b = b.set_logic_var
 
585
 
 
586
let set_orig_varinfo b = b.set_orig_varinfo
 
587
let set_orig_compinfo b = b.set_orig_compinfo
 
588
let set_orig_fieldinfo b = b.set_orig_fieldinfo
 
589
let set_orig_enuminfo b = b.set_orig_enuminfo
 
590
let set_orig_enumitem b = b.set_orig_enumitem
 
591
let set_orig_stmt b = b.set_orig_stmt
 
592
let set_orig_typeinfo b = b.set_orig_typeinfo
 
593
let set_orig_logic_info b = b.set_orig_logic_info
 
594
(*
 
595
let set_orig_predicate_info b = b.set_orig_predicate_info
 
596
*)
 
597
let set_orig_logic_var b = b.set_orig_logic_var
 
598
 
 
599
let inplace_visit () =
 
600
  { cfile = (fun x -> x);
 
601
    get_compinfo = (fun x -> x);
 
602
    get_fieldinfo = (fun x -> x);
 
603
    get_enuminfo = (fun x -> x);
 
604
    get_enumitem = (fun x -> x);
 
605
    get_typeinfo = (fun x -> x);
 
606
    get_varinfo = (fun x -> x);
 
607
    get_logic_var = (fun x -> x);
 
608
    get_stmt = (fun x -> x);
 
609
    get_logic_info = (fun x -> x);
 
610
(*
 
611
    get_predicate_info = (fun x -> x);
 
612
*)
 
613
    get_original_compinfo = (fun x -> x);
 
614
    get_original_fieldinfo = (fun x -> x);
 
615
    get_original_enuminfo = (fun x -> x);
 
616
    get_original_enumitem = (fun x -> x);
 
617
    get_original_typeinfo = (fun x -> x);
 
618
    get_original_varinfo = (fun x -> x);
 
619
    get_original_logic_var = (fun x -> x);
 
620
    get_original_stmt = (fun x -> x);
 
621
    get_original_logic_info = (fun x -> x);
 
622
(*
 
623
    get_original_predicate_info = (fun x -> x);
 
624
*)
 
625
    cinitinfo = (fun x -> x);
 
626
    cfundec = (fun x -> x);
 
627
    cblock = (fun x -> x);
 
628
    cfunspec = (fun x -> x);
 
629
    cfunbehavior = (fun x -> x);
 
630
    is_copy_behavior = false;
 
631
    memo_varinfo = (fun x -> x);
 
632
    memo_compinfo = (fun x -> x);
 
633
    memo_enuminfo = (fun x -> x);
 
634
    memo_enumitem = (fun x -> x);
 
635
    memo_typeinfo = (fun x -> x);
 
636
    memo_logic_info = (fun x -> x);
 
637
(*
 
638
    memo_predicate_info = (fun x -> x);
 
639
*)
 
640
    memo_stmt = (fun x -> x);
 
641
    memo_fieldinfo = (fun x -> x);
 
642
    memo_logic_var = (fun x -> x);
 
643
    set_varinfo = (fun _ _ -> ());
 
644
    set_compinfo = (fun _ _ -> ());
 
645
    set_enuminfo = (fun _ _ -> ());
 
646
    set_enumitem = (fun _ _ -> ());
 
647
    set_typeinfo = (fun _ _ -> ());
 
648
    set_logic_info = (fun _ _ -> ());
 
649
(*
 
650
    set_predicate_info = (fun _ _ -> ());
 
651
*)
 
652
    set_stmt = (fun _ _ -> ());
 
653
    set_fieldinfo = (fun _ _ -> ());
 
654
    set_logic_var = (fun _ _ -> ());
 
655
    set_orig_varinfo = (fun _ _ -> ());
 
656
    set_orig_compinfo = (fun _ _ -> ());
 
657
    set_orig_enuminfo = (fun _ _ -> ());
 
658
    set_orig_enumitem = (fun _ _ -> ());
 
659
    set_orig_typeinfo = (fun _ _ -> ());
 
660
    set_orig_logic_info = (fun _ _ -> ());
 
661
(*
 
662
    set_orig_predicate_info = (fun _ _ -> ());
 
663
*)
 
664
    set_orig_stmt = (fun _ _ -> ());
 
665
    set_orig_fieldinfo = (fun _ _ -> ());
 
666
    set_orig_logic_var = (fun _ _ -> ());
 
667
    reset_behavior_varinfo = (fun () -> ());
 
668
    reset_behavior_compinfo = (fun () -> ());
 
669
    reset_behavior_enuminfo = (fun () -> ());
 
670
    reset_behavior_enumitem = (fun () -> ());
 
671
    reset_behavior_typeinfo = (fun () -> ());
 
672
    reset_behavior_logic_info = (fun () -> ());
 
673
(*
 
674
    reset_behavior_predicate_info = (fun () -> ());
 
675
*)
 
676
    reset_behavior_fieldinfo = (fun () -> ());
 
677
    reset_behavior_stmt = (fun () -> ());
 
678
    reset_logic_var = (fun () -> ());
 
679
  }
 
680
 
 
681
let copy_visit () =
 
682
  let varinfos = Inthash.create 103 in
 
683
  let compinfos = Inthash.create 17 in
 
684
  let enuminfos = Hashtbl.create 17 in
 
685
  let enumitems = Hashtbl.create 17 in
 
686
  let typeinfos = Hashtbl.create 17 in
 
687
  let logic_infos = Hashtbl.create 17 in
 
688
(*
 
689
  let predicate_infos = Hashtbl.create 17 in
 
690
*)
 
691
  let fieldinfos = Hashtbl.create 17 in
 
692
  let stmts = Inthash.create 103 in
 
693
  let logic_vars = Inthash.create 17 in
 
694
  let orig_varinfos = Inthash.create 103 in
 
695
  let orig_compinfos = Inthash.create 17 in
 
696
  let orig_enuminfos = Hashtbl.create 17 in
 
697
  let orig_enumitems = Hashtbl.create 17 in
 
698
  let orig_typeinfos = Hashtbl.create 17 in
 
699
  let orig_logic_infos = Hashtbl.create 17 in
 
700
(*
 
701
  let orig_predicate_infos = Hashtbl.create 17 in
 
702
*)
 
703
  let orig_fieldinfos = Hashtbl.create 17 in
 
704
  let orig_stmts = Inthash.create 103 in
 
705
  let orig_logic_vars = Inthash.create 17 in
 
706
  { cfile = (fun x -> { x with fileName = x.fileName });
 
707
    get_compinfo =
 
708
      (fun x -> try Inthash.find compinfos x.ckey with Not_found -> x);
 
709
    get_fieldinfo =
 
710
      (fun x -> try Hashtbl.find fieldinfos (x.fname,x.fcomp.ckey)
 
711
       with Not_found -> x);
 
712
    get_enuminfo =
 
713
      (fun x -> try Hashtbl.find enuminfos x.ename with Not_found -> x);
 
714
    get_enumitem =
 
715
      (fun x -> try Hashtbl.find enumitems x.einame with Not_found -> x);
 
716
    get_typeinfo =
 
717
      (fun x -> try Hashtbl.find typeinfos x.tname with Not_found -> x);
 
718
    get_varinfo =
 
719
      (fun x -> try Inthash.find varinfos x.vid with Not_found -> x);
 
720
    get_stmt = (fun x -> try Inthash.find stmts x.sid with Not_found -> x);
 
721
    get_logic_info =
 
722
      (fun x -> try Hashtbl.find logic_infos x.l_name with Not_found -> x);
 
723
(*
 
724
    get_predicate_info =
 
725
      (fun x -> try Hashtbl.find predicate_infos x.p_name with Not_found -> x);
 
726
*)
 
727
    get_logic_var = (fun x -> try Inthash.find logic_vars x.lv_id
 
728
                     with Not_found -> x);
 
729
    get_original_compinfo =
 
730
      (fun x -> try Inthash.find orig_compinfos x.ckey with Not_found -> x);
 
731
    get_original_fieldinfo =
 
732
      (fun x -> try Hashtbl.find orig_fieldinfos (x.fname,x.fcomp.ckey)
 
733
       with Not_found -> x);
 
734
    get_original_enuminfo =
 
735
      (fun x -> try Hashtbl.find orig_enuminfos x.ename with Not_found -> x);
 
736
    get_original_enumitem =
 
737
      (fun x -> try Hashtbl.find orig_enumitems x.einame with Not_found -> x);
 
738
    get_original_typeinfo =
 
739
      (fun x -> try Hashtbl.find orig_typeinfos x.tname with Not_found -> x);
 
740
    get_original_varinfo =
 
741
      (fun x -> try Inthash.find orig_varinfos x.vid with Not_found -> x);
 
742
    get_original_stmt =
 
743
      (fun x -> try Inthash.find orig_stmts x.sid with Not_found -> x);
 
744
    get_original_logic_var =
 
745
      (fun x -> try Inthash.find orig_logic_vars x.lv_id with Not_found -> x);
 
746
    get_original_logic_info =
 
747
      (fun x -> try Hashtbl.find orig_logic_infos x.l_name with Not_found -> x);
 
748
(*
 
749
    get_original_predicate_info =
 
750
      (fun x ->
 
751
         try Hashtbl.find orig_predicate_infos x.p_name with Not_found -> x);
 
752
*)
 
753
    cinitinfo = (fun x -> { init = x.init });
 
754
    cfundec = ( fun x -> { x with svar = x.svar });
 
755
    cblock = (fun x -> { x with battrs = x.battrs });
 
756
    cfunspec = (fun x -> { x with spec_requires = x.spec_requires});
 
757
    cfunbehavior = (fun x -> { x with b_name = x.b_name});
 
758
    is_copy_behavior = true;
 
759
    reset_behavior_varinfo =
 
760
      (fun () ->  Inthash.clear varinfos; Inthash.clear orig_varinfos);
 
761
    reset_behavior_compinfo =
 
762
      (fun () -> Inthash.clear compinfos; Inthash.clear orig_compinfos);
 
763
    reset_behavior_enuminfo =
 
764
      (fun () -> Hashtbl.clear enuminfos; Hashtbl.clear orig_enuminfos);
 
765
    reset_behavior_enumitem =
 
766
      (fun () -> Hashtbl.clear enumitems; Hashtbl.clear orig_enumitems);
 
767
    reset_behavior_typeinfo =
 
768
      (fun () -> Hashtbl.clear typeinfos; Hashtbl.clear orig_typeinfos);
 
769
    reset_behavior_logic_info =
 
770
      (fun () -> Hashtbl.clear logic_infos; Hashtbl.clear orig_logic_infos);
 
771
(*
 
772
    reset_behavior_predicate_info =
 
773
      (fun () ->
 
774
         Hashtbl.clear predicate_infos; Hashtbl.clear orig_predicate_infos);
 
775
*)
 
776
    reset_behavior_fieldinfo =
 
777
      (fun () ->Hashtbl.clear fieldinfos; Hashtbl.clear orig_fieldinfos);
 
778
    reset_behavior_stmt =
 
779
      (fun () -> Inthash.clear stmts; Inthash.clear orig_stmts);
 
780
    reset_logic_var =
 
781
      (fun () -> Inthash.clear logic_vars; Inthash.clear orig_logic_vars);
 
782
    memo_varinfo =
 
783
      (fun x ->
 
784
         try Inthash.find varinfos x.vid
 
785
         with Not_found ->
 
786
           let new_x = { x with vid = x.vid } in
 
787
           Inthash.add varinfos x.vid new_x;
 
788
           Inthash.add orig_varinfos new_x.vid x;
 
789
           new_x);
 
790
    memo_compinfo =
 
791
      (fun x ->
 
792
         try Inthash.find compinfos x.ckey
 
793
         with Not_found ->
 
794
           let new_x = { x with ckey = x.ckey } in
 
795
           Inthash.add compinfos x.ckey new_x;
 
796
           Inthash.add orig_compinfos new_x.ckey x;
 
797
           new_x);
 
798
    memo_enuminfo =
 
799
      (fun x ->
 
800
         try Hashtbl.find enuminfos x.ename
 
801
         with Not_found ->
 
802
           let new_x = { x with ename = x.ename } in
 
803
           Hashtbl.add enuminfos x.ename new_x;
 
804
           Hashtbl.add orig_enuminfos new_x.ename x;
 
805
           new_x);
 
806
    memo_enumitem =
 
807
      (fun x ->
 
808
         try Hashtbl.find enumitems x.einame
 
809
         with Not_found ->
 
810
           let new_x = { x with einame = x.einame } in
 
811
           Hashtbl.add enumitems x.einame new_x;
 
812
           Hashtbl.add orig_enumitems new_x.einame x;
 
813
           new_x);
 
814
    memo_typeinfo =
 
815
      (fun x ->
 
816
         try Hashtbl.find typeinfos x.tname
 
817
         with Not_found ->
 
818
           let new_x = { x with tname = x.tname } in
 
819
           Hashtbl.add typeinfos x.tname new_x;
 
820
           Hashtbl.add orig_typeinfos new_x.tname x;
 
821
           new_x);
 
822
    memo_logic_info =
 
823
      (fun x ->
 
824
         try Hashtbl.find logic_infos x.l_name
 
825
         with Not_found ->
 
826
           let new_x = { x with l_name = x.l_name } in
 
827
           Hashtbl.add logic_infos x.l_name new_x; new_x);
 
828
(*
 
829
    memo_predicate_info =
 
830
      (fun x ->
 
831
         try Hashtbl.find predicate_infos x.p_name
 
832
         with Not_found ->
 
833
           let new_x = { x with p_name = x.p_name } in
 
834
           Hashtbl.add predicate_infos x.p_name new_x;
 
835
           Hashtbl.add orig_predicate_infos new_x.p_name x;
 
836
           new_x);
 
837
*)
 
838
    memo_stmt =
 
839
      (fun x ->
 
840
         try Inthash.find stmts x.sid
 
841
         with Not_found ->
 
842
           let new_x = { x with sid = x.sid } in
 
843
           Inthash.add stmts x.sid new_x;
 
844
           Inthash.add orig_stmts new_x.sid x;
 
845
           new_x);
 
846
    memo_fieldinfo =
 
847
      (fun x ->
 
848
         try Hashtbl.find fieldinfos (x.fname,x.fcomp.ckey)
 
849
         with Not_found ->
 
850
           let new_x = { x with fname = x.fname } in
 
851
           Hashtbl.add fieldinfos (x.fname, x.fcomp.ckey) new_x;
 
852
           Hashtbl.add orig_fieldinfos (new_x.fname, new_x.fcomp.ckey) x;
 
853
           new_x);
 
854
    memo_logic_var =
 
855
      (fun x ->
 
856
         try Inthash.find logic_vars x.lv_id
 
857
         with Not_found ->
 
858
           let new_x = { x with lv_id = x.lv_id } in
 
859
           Inthash.add logic_vars x.lv_id new_x;
 
860
           Inthash.add orig_logic_vars new_x.lv_id x;
 
861
           new_x);
 
862
    set_varinfo = (fun x y -> Inthash.replace varinfos x.vid y);
 
863
    set_compinfo = (fun x y -> Inthash.replace compinfos x.ckey y);
 
864
    set_enuminfo = (fun x y -> Hashtbl.replace enuminfos x.ename y);
 
865
    set_enumitem = (fun x y -> Hashtbl.replace enumitems x.einame y);
 
866
    set_typeinfo = (fun x y -> Hashtbl.replace typeinfos x.tname y);
 
867
    set_logic_info = (fun x y -> Hashtbl.replace logic_infos x.l_name y);
 
868
(*
 
869
    set_predicate_info = (fun x y ->Hashtbl.replace predicate_infos x.p_name y);
 
870
*)
 
871
    set_stmt = (fun x y -> Inthash.replace stmts x.sid y);
 
872
    set_fieldinfo =
 
873
      (fun x y -> Hashtbl.replace fieldinfos (x.fname,x.fcomp.ckey) y);
 
874
    set_logic_var = (fun x y -> Inthash.replace logic_vars x.lv_id y);
 
875
    set_orig_varinfo = (fun x y -> Inthash.replace orig_varinfos x.vid y);
 
876
    set_orig_compinfo = (fun x y -> Inthash.replace orig_compinfos x.ckey y);
 
877
    set_orig_enuminfo = (fun x y -> Hashtbl.replace orig_enuminfos x.ename y);
 
878
    set_orig_enumitem = (fun x y -> Hashtbl.replace orig_enumitems x.einame y);
 
879
    set_orig_typeinfo = (fun x y -> Hashtbl.replace orig_typeinfos x.tname y);
 
880
    set_orig_logic_info =
 
881
      (fun x y -> Hashtbl.replace orig_logic_infos x.l_name y);
 
882
(*
 
883
    set_orig_predicate_info =
 
884
      (fun x y -> Hashtbl.replace orig_predicate_infos x.p_name y);
 
885
*)
 
886
    set_orig_stmt = (fun x y -> Inthash.replace orig_stmts x.sid y);
 
887
    set_orig_fieldinfo =
 
888
      (fun x y -> Hashtbl.replace orig_fieldinfos (x.fname,x.fcomp.ckey) y);
 
889
    set_orig_logic_var = (fun x y -> Inthash.replace orig_logic_vars x.lv_id y);
 
890
  }
 
891
 
 
892
(* sm/gn: cil visitor interface for traversing Cil trees. *)
 
893
(* Use visitCilStmt and/or visitCilFile to use this. *)
 
894
(* Some of the nodes are changed in place if the children are changed. Use
 
895
 * one of Change... actions if you want to copy the node *)
 
896
 
 
897
(** A visitor interface for traversing CIL trees. Create instantiations of
 
898
 * this type by specializing the class {!Cil.nopCilVisitor}. *)
 
899
class type cilVisitor = object
 
900
 
 
901
  method behavior: visitor_behavior
 
902
 
 
903
  method vfile: file -> file visitAction
 
904
    (** visit a file. *)
 
905
 
 
906
  method vvdec: varinfo -> varinfo visitAction
 
907
    (** Invoked for each variable declaration. The subtrees to be traversed
 
908
     * are those corresponding to the type and attributes of the variable.
 
909
     * Note that variable declarations are all the [GVar], [GVarDecl], [GFun],
 
910
     * all the [varinfo] in formals of function types, and the formals and
 
911
     * locals for function definitions. This means that the list of formals
 
912
     * in a function definition will be traversed twice, once as part of the
 
913
     * function type and second as part of the formals in a function
 
914
     * definition. *)
 
915
 
 
916
  method vvrbl: varinfo -> varinfo visitAction
 
917
    (** Invoked on each variable use. Here only the [SkipChildren] and
 
918
     * [ChangeTo] actions make sense since there are no subtrees. Note that
 
919
     * the type and attributes of the variable are not traversed for a
 
920
     * variable use *)
 
921
 
 
922
  method vexpr: exp -> exp visitAction
 
923
    (** Invoked on each expression occurence. The subtrees are the
 
924
     * subexpressions, the types (for a [Cast] or [SizeOf] expression) or the
 
925
     * variable use. *)
 
926
 
 
927
  method vlval: lval -> lval visitAction
 
928
    (** Invoked on each lvalue occurence *)
 
929
 
 
930
  method voffs: offset -> offset visitAction
 
931
    (** Invoked on each offset occurrence that is *not* as part
 
932
      * of an initializer list specification, i.e. in an lval or
 
933
      * recursively inside an offset. *)
 
934
 
 
935
  method vinitoffs: offset -> offset visitAction
 
936
    (** Invoked on each offset appearing in the list of a
 
937
      * CompoundInit initializer.  *)
 
938
 
 
939
  method vinst: instr -> instr list visitAction
 
940
    (** Invoked on each instruction occurrence. The [ChangeTo] action can
 
941
     * replace this instruction with a list of instructions *)
 
942
 
 
943
  method vstmt: stmt -> stmt visitAction
 
944
    (** Control-flow statement. *)
 
945
 
 
946
  method vblock: block -> block visitAction     (** Block. Replaced in
 
947
                                                    place. *)
 
948
  method vfunc: fundec -> fundec visitAction    (** Function definition.
 
949
                                                    Replaced in place. *)
 
950
  method vglob: global -> global list visitAction (** Global (vars, types,
 
951
                                                      etc.)  *)
 
952
  method vinit: varinfo -> offset -> init -> init visitAction
 
953
                                                (** Initializers for globals,
 
954
                                                 * pass the global where this
 
955
                                                 * occurs, and the offset *)
 
956
  method vtype: typ -> typ visitAction          (** Use of some type. Note
 
957
                                                 * that for structure/union
 
958
                                                 * and enumeration types the
 
959
                                                 * definition of the
 
960
                                                 * composite type is not
 
961
                                                 * visited. Use [vglob] to
 
962
                                                 * visit it.  *)
 
963
 
 
964
  method vcompinfo: compinfo -> compinfo visitAction
 
965
 
 
966
  method venuminfo: enuminfo -> enuminfo visitAction
 
967
 
 
968
  method vfieldinfo: fieldinfo -> fieldinfo visitAction
 
969
 
 
970
  method venumitem: enumitem -> enumitem visitAction
 
971
 
 
972
  method vattr: attribute -> attribute list visitAction
 
973
    (** Attribute. Each attribute can be replaced by a list *)
 
974
  method vattrparam: attrparam -> attrparam visitAction
 
975
    (** Attribute parameters. *)
 
976
 
 
977
    (** Add here instructions while visiting to queue them to
 
978
     * preceede the current statement or instruction being processed *)
 
979
  method queueInstr: instr list -> unit
 
980
 
 
981
    (** Gets the queue of instructions and resets the queue *)
 
982
  method unqueueInstr: unit -> instr list
 
983
 
 
984
  val current_stmt : stmt Stack.t
 
985
  method push_stmt: stmt -> unit
 
986
  method  pop_stmt: stmt -> unit
 
987
  method current_stmt: stmt option
 
988
 
 
989
  method current_func: fundec option
 
990
  method set_current_func: fundec -> unit
 
991
  method reset_current_func: unit -> unit
 
992
 
 
993
  (*VP: annotation visitor. *)
 
994
 
 
995
  method vlogic_type: logic_type -> logic_type visitAction
 
996
 
 
997
  method vtsets_elem: tsets_elem -> tsets_elem visitAction
 
998
 
 
999
  method vtsets_lval: tsets_lval -> tsets_lval visitAction
 
1000
 
 
1001
  method vtsets_lhost: tsets_lhost -> tsets_lhost visitAction
 
1002
 
 
1003
  method vtsets_offset: tsets_offset -> tsets_offset visitAction
 
1004
 
 
1005
  method vtsets: tsets -> tsets visitAction
 
1006
 
 
1007
  method vterm: term -> term visitAction
 
1008
 
 
1009
  method vterm_node: term_node -> term_node visitAction
 
1010
 
 
1011
  method vterm_lval: term_lval -> term_lval visitAction
 
1012
 
 
1013
  method vterm_lhost: term_lhost -> term_lhost visitAction
 
1014
 
 
1015
  method vterm_offset: term_offset -> term_offset visitAction
 
1016
 
 
1017
  method vlogic_info_decl: logic_info -> logic_info visitAction
 
1018
 
 
1019
  method vlogic_info_use: logic_info -> logic_info visitAction
 
1020
 
 
1021
  method vlogic_var_use: logic_var -> logic_var visitAction
 
1022
 
 
1023
  method vlogic_var_decl: logic_var -> logic_var visitAction
 
1024
 
 
1025
  method vquantifiers: quantifiers -> quantifiers visitAction
 
1026
 
 
1027
  method vpredicate: predicate -> predicate visitAction
 
1028
 
 
1029
  method vpredicate_named: predicate named -> predicate named visitAction
 
1030
 
 
1031
(*
 
1032
  method vpredicate_info_decl: predicate_info -> predicate_info visitAction
 
1033
 
 
1034
  method vpredicate_info_use: predicate_info -> predicate_info visitAction
 
1035
*)
 
1036
 
 
1037
  method vbehavior: funbehavior -> funbehavior visitAction
 
1038
 
 
1039
  method vspec: funspec -> funspec visitAction
 
1040
 
 
1041
  method vassigns:
 
1042
    identified_tsets assigns -> identified_tsets assigns visitAction
 
1043
 
 
1044
  method vloop_pragma: term loop_pragma -> term loop_pragma visitAction
 
1045
 
 
1046
  method vslice_pragma: term slice_pragma -> term slice_pragma visitAction
 
1047
  method vimpact_pragma: term impact_pragma -> term impact_pragma visitAction
 
1048
 
 
1049
  method vzone:
 
1050
    identified_tsets zone -> identified_tsets zone visitAction
 
1051
 
 
1052
  method vcode_annot: code_annotation -> code_annotation visitAction
 
1053
 
 
1054
  method vannotation: global_annotation -> global_annotation visitAction
 
1055
  method fill_global_tables: unit
 
1056
  method get_filling_actions: (unit -> unit) Queue.t
 
1057
  method set_logic_tables: unit -> unit
 
1058
end
 
1059
 
 
1060
(* the default visitor does nothing at each node, but does *)
 
1061
(* not stop; hence they return true *)
 
1062
class genericCilVisitor ?prj behavior: cilVisitor =
 
1063
object(self)
 
1064
  method behavior = behavior
 
1065
 
 
1066
  (* list of things to perform on the new project. Done at the end
 
1067
     of the analysis in order to minimize the number of project changes.
 
1068
  *)
 
1069
  val global_tables_action = Queue.create ()
 
1070
 
 
1071
  method fill_global_tables =
 
1072
    let prj = match prj with None -> Project.current () | Some prj -> prj in
 
1073
    Project.on prj
 
1074
      (fun () -> Queue.iter (fun f -> f()) global_tables_action) ();
 
1075
    Queue.clear global_tables_action
 
1076
 
 
1077
  method get_filling_actions = global_tables_action
 
1078
 
 
1079
  method set_logic_tables () =
 
1080
    if is_copy_behavior self#behavior then begin
 
1081
      Queue.add Logic_env.LogicInfo.clear global_tables_action;
 
1082
(*
 
1083
      Queue.add Logic_env.PredicateInfo.clear global_tables_action;
 
1084
*)
 
1085
      Logic_env.LogicInfo.iter
 
1086
        (fun _ x ->
 
1087
           let x' = self#behavior.memo_logic_info x in
 
1088
           Queue.add (fun () -> Logic_env.add_logic_function x')
 
1089
             global_tables_action);
 
1090
(*
 
1091
      Logic_env.PredicateInfo.iter
 
1092
        (fun _ x ->
 
1093
           let x' = self#behavior.memo_predicate_info x in
 
1094
           Queue.add (fun () -> Logic_env.add_predicate x')
 
1095
             global_tables_action);
 
1096
*)
 
1097
    end
 
1098
 
 
1099
  method vfile _f = DoChildren
 
1100
  val current_stmt = Stack.create ()
 
1101
  method private push_stmt s = Stack.push s current_stmt
 
1102
  method private pop_stmt _s = ignore (Stack.pop current_stmt)
 
1103
  method current_stmt =
 
1104
    try Some (Stack.top current_stmt) with Stack.Empty -> None
 
1105
 
 
1106
  val mutable current_func = None
 
1107
  method current_func = current_func
 
1108
  method set_current_func f = current_func <- Some f
 
1109
  method reset_current_func () = current_func <- None
 
1110
 
 
1111
  method vvrbl (_v:varinfo) = DoChildren
 
1112
  method vvdec (_v:varinfo) = DoChildren
 
1113
  method vexpr (_e:exp) = DoChildren
 
1114
  method vlval (_l:lval) = DoChildren
 
1115
  method voffs (_o:offset) = DoChildren
 
1116
  method vinitoffs (_o:offset) = DoChildren
 
1117
  method vinst (_i:instr) = DoChildren
 
1118
  method vstmt (_s:stmt) = DoChildren
 
1119
  method vblock (_b: block) = DoChildren
 
1120
  method vfunc (_f:fundec) = DoChildren
 
1121
  method vglob (_g:global) = DoChildren
 
1122
  method vinit (_forg: varinfo) (_off: offset) (_i:init) = DoChildren
 
1123
  method vtype (_t:typ) = DoChildren
 
1124
  method vcompinfo _ = DoChildren
 
1125
  method venuminfo _ = DoChildren
 
1126
  method vfieldinfo _ = DoChildren
 
1127
  method venumitem _ = DoChildren
 
1128
  method vattr (_a: attribute) = DoChildren
 
1129
  method vattrparam (_a: attrparam) = DoChildren
 
1130
 
 
1131
  val mutable instrQueue = []
 
1132
 
 
1133
  method queueInstr (il: instr list) =
 
1134
    List.iter (fun i -> instrQueue <- i :: instrQueue) il
 
1135
 
 
1136
  method unqueueInstr () =
 
1137
    let res = List.rev instrQueue in
 
1138
    instrQueue <- [];
 
1139
    res
 
1140
 
 
1141
  method vlogic_type _lt = DoChildren
 
1142
 
 
1143
  method vtsets_lhost _ = DoChildren
 
1144
 
 
1145
  method vtsets_elem _ = DoChildren
 
1146
 
 
1147
  method vtsets_lval _ = DoChildren
 
1148
 
 
1149
  method vtsets_offset _ = DoChildren
 
1150
 
 
1151
  method vtsets _l = DoChildren
 
1152
 
 
1153
  method vterm _t = DoChildren
 
1154
 
 
1155
  method vterm_node _tn = DoChildren
 
1156
 
 
1157
  method vterm_lval _tl = DoChildren
 
1158
 
 
1159
  method vterm_lhost _tl = DoChildren
 
1160
 
 
1161
  method vterm_offset _vo = DoChildren
 
1162
 
 
1163
  method vlogic_info_decl _li = DoChildren
 
1164
 
 
1165
  method vlogic_info_use _li = DoChildren
 
1166
 
 
1167
  method vlogic_var_decl _lv = DoChildren
 
1168
 
 
1169
  method vlogic_var_use _lv = DoChildren
 
1170
 
 
1171
  method vquantifiers _q = DoChildren
 
1172
 
 
1173
  method vpredicate _p = DoChildren
 
1174
 
 
1175
  method vpredicate_named _p = DoChildren
 
1176
 
 
1177
(*
 
1178
  method vpredicate_info_decl _pi = DoChildren
 
1179
 
 
1180
  method vpredicate_info_use _pi = DoChildren
 
1181
*)
 
1182
 
 
1183
  method vbehavior _b = DoChildren
 
1184
 
 
1185
  method vspec _s = DoChildren
 
1186
 
 
1187
  method vassigns _s = DoChildren
 
1188
 
 
1189
  method vloop_pragma _ = DoChildren
 
1190
 
 
1191
  method vslice_pragma _ = DoChildren
 
1192
  method vimpact_pragma _ = DoChildren
 
1193
 
 
1194
  method vzone _ = DoChildren
 
1195
 
 
1196
  method vcode_annot _ca = DoChildren
 
1197
 
 
1198
  method vannotation _a = DoChildren
 
1199
 
 
1200
end
 
1201
 
 
1202
class nopCilVisitor = object
 
1203
  inherit genericCilVisitor (inplace_visit ())
 
1204
end
 
1205
 
 
1206
let assertEmptyQueue vis =
 
1207
  if vis#unqueueInstr () <> [] then
 
1208
    (* Either a visitor inserted an instruction somewhere that it shouldn't
 
1209
       have (i.e. at the top level rather than inside of a statement), or
 
1210
       there's a bug in the visitor engine. *)
 
1211
    E.s (E.bug "Visitor's instruction queue is not empty.\n  You should only use queueInstr inside a function body!");
 
1212
  ()
 
1213
 
 
1214
(* sm: utility *)
 
1215
let startsWith prefix s =
 
1216
  let prefixLen = String.length prefix in
 
1217
  String.length s >= prefixLen && String.sub s 0 prefixLen = prefix
 
1218
 
 
1219
module VarInfos =
 
1220
  Computation.Make_Hashtbl
 
1221
    (Inthash)
 
1222
    (Cil_datatype.Varinfo)
 
1223
    (struct
 
1224
       let name = "VarInfos"
 
1225
       let dependencies = []
 
1226
       let size = 17
 
1227
     end)
 
1228
 
 
1229
let varinfos_self = VarInfos.self
 
1230
let varinfo_from_vid = VarInfos.find
 
1231
 
 
1232
let set_vid, copy_with_new_vid, copy_with_new_lvid, new_raw_id =
 
1233
  (* [new_vid] should never be used by foreign functions *)
 
1234
  let new_vid =
 
1235
    let module M = Build_Counter(struct let name = "vid" end) in
 
1236
    M.next
 
1237
  in
 
1238
  (fun v ->
 
1239
     let n = new_vid () in
 
1240
     v.vid <- n;
 
1241
     ignore (VarInfos.memo ~change:(fun _ -> assert false) (fun _ -> v) n)),
 
1242
  (fun v ->
 
1243
     let n = new_vid () in
 
1244
     let v' = { v with vid = n } in
 
1245
     VarInfos.memo ~change:(fun _ -> assert false) (fun _ -> v') n),
 
1246
  (fun lv -> { lv with lv_id = new_vid () }),
 
1247
  new_vid
 
1248
 
 
1249
(* The next compindo identifier to use. Counts up. *)
 
1250
let nextCompinfoKey =
 
1251
  let module M = Build_Counter(struct let name = "compinfokey" end) in
 
1252
  M.next
 
1253
 
 
1254
let bytesSizeOfInt (ik: ikind): int =
 
1255
  match ik with
 
1256
  | IChar | ISChar | IUChar -> 1
 
1257
  | IBool | IInt | IUInt -> theMachine.theMachine.sizeof_int
 
1258
  | IShort | IUShort -> theMachine.theMachine.sizeof_short
 
1259
  | ILong | IULong -> theMachine.theMachine.sizeof_long
 
1260
  | ILongLong | IULongLong -> theMachine.theMachine.sizeof_longlong
 
1261
 
 
1262
(** Returns true if and only if the given integer type is signed. *)
 
1263
let isSigned = function
 
1264
  | IUChar | IBool
 
1265
  | IUShort
 
1266
  | IUInt
 
1267
  | IULong
 
1268
  | IULongLong ->
 
1269
      false
 
1270
  | ISChar
 
1271
  | IShort
 
1272
  | IInt
 
1273
  | ILong
 
1274
  | ILongLong ->
 
1275
      true
 
1276
  | IChar ->
 
1277
      not theMachine.theMachine.Cil_types.char_is_unsigned
 
1278
 
 
1279
(* Represents an integer as for a given kind.
 
1280
   Returns a flag saying whether the value was changed
 
1281
   during truncation (because it was too large to fit in k). *)
 
1282
let truncateInteger64 (k: ikind) (i: int64) : int64 * bool =
 
1283
   let nrBits = 8 * (bytesSizeOfInt k) in
 
1284
  let signed = isSigned k in
 
1285
    if nrBits = 64 then
 
1286
    i, false
 
1287
  else begin
 
1288
    let i1 = Int64.shift_left i (64 - nrBits) in
 
1289
    let i2 =
 
1290
      if signed then Int64.shift_right i1 (64 - nrBits)
 
1291
      else Int64.shift_right_logical i1 (64 - nrBits)
 
1292
    in
 
1293
    let truncated =
 
1294
      if i2 = i then false
 
1295
      else
 
1296
        (* Examine the bits that we chopped off.  If they are all zero, then
 
1297
         * any difference between i2 and i is due to a simple sign-extension.
 
1298
         *   e.g. casting the constant 0x80000000 to int makes it
 
1299
         *        0xffffffff80000000.
 
1300
         * Suppress the truncation warning in this case.      *)
 
1301
        let chopped = Int64.shift_right_logical i (64 - nrBits)
 
1302
        in chopped <> Int64.zero
 
1303
    in
 
1304
    i2, truncated
 
1305
  end
 
1306
 
 
1307
(* Construct an integer constant with possible truncation *)
 
1308
let kinteger64 (k: ikind) (i: int64) : exp =
 
1309
  let i', truncated = truncateInteger64 k i in
 
1310
  if truncated then
 
1311
    ignore (warnOpt "Truncating integer %s to %s\n"
 
1312
              (Int64.format "0x%x" i) (Int64.format "0x%x" i'));
 
1313
(*  Format.printf "kint64:%Lx %Ld@\n" i' i';*)
 
1314
  Const (CInt64(i' , k,  None))
 
1315
 
 
1316
(* Construct an integer of a given kind. *)
 
1317
let kinteger (k: ikind) (i: int) = kinteger64 k (Int64.of_int i)
 
1318
 
 
1319
(* Construct an integer. Use only for values that fit on 31 bits *)
 
1320
let integer (i: int) = Const (CInt64(Int64.of_int i, IInt, None))
 
1321
 
 
1322
let zero      = integer 0
 
1323
let one       = integer 1
 
1324
let mone      = integer (-1)
 
1325
 
 
1326
let lconstant ?(loc=locUnknown) v =
 
1327
  { term_node = TConst (CInt64(v, IInt, None)); term_loc = loc;
 
1328
    term_name = []; term_type = Ctype (TInt (IInt,[]));}
 
1329
 
 
1330
let lzero ?(loc=locUnknown) () = lconstant ~loc Int64.zero
 
1331
let lone  ?(loc=locUnknown) () = lconstant ~loc Int64.one
 
1332
let lmone ?(loc=locUnknown) () = lconstant ~loc (Int64.minus_one)
 
1333
 
 
1334
(** Given the character c in a (CChr c), sign-extend it to 32 bits.
 
1335
  (This is the official way of interpreting character constants, according to
 
1336
  ISO C 6.4.4.4.10, which says that character constants are chars cast to ints)
 
1337
  Returns CInt64(sign-extened c, IInt, None) *)
 
1338
let charConstToInt (c: char) : constant =
 
1339
  let c' = Char.code c in
 
1340
  let value =
 
1341
    if c' < 128
 
1342
    then Int64.of_int c'
 
1343
    else Int64.of_int (c' - 256)
 
1344
  in
 
1345
  CInt64(value, IInt, None)
 
1346
 
 
1347
 
 
1348
let rec isInteger : exp -> int64 option = function
 
1349
  | Const(CInt64 (n,_,_)) -> Some n
 
1350
  | Const(CChr c) -> isInteger (Const (charConstToInt c))  (* sign-extend *)
 
1351
  | Const(CEnum {eival = v}) -> isInteger v
 
1352
  | CastE(_, e) -> isInteger e
 
1353
  | _ -> None
 
1354
 
 
1355
(** Convert a 64-bit int to an OCaml int, or raise an exception if that
 
1356
    can't be done. *)
 
1357
let i64_to_int (i: int64) : int =
 
1358
  let i': int = Int64.to_int i in (* i.e. i' = i mod 2^31 *)
 
1359
  if i = Int64.of_int i' then i'
 
1360
  else E.s (E.error "Int constant too large: %Ld\n" i)
 
1361
 
 
1362
 
 
1363
let rec isZero (e: exp) : bool = isInteger e = Some Int64.zero
 
1364
 
 
1365
let rec isLogicZero t = match t.term_node with
 
1366
  | TConst (CInt64 (n,_,_)) -> n = 0L
 
1367
  | TConst (CChr c) -> Char.code c = 0
 
1368
  | TCastE(_, t) -> isLogicZero t
 
1369
  | _ -> false
 
1370
 
 
1371
let isLogicNull t =
 
1372
  isLogicZero t ||
 
1373
    (let rec aux t = match t.term_node with
 
1374
       | Tnull -> true
 
1375
       | TCastE(_, t) -> aux t
 
1376
       | _ -> false
 
1377
     in aux t)
 
1378
 
 
1379
let parseInt (str: string) : exp =
 
1380
  let hasSuffix str =
 
1381
    let l = String.length str in
 
1382
    fun s ->
 
1383
      let ls = String.length s in
 
1384
      l >= ls && s = String.uppercase (String.sub str (l - ls) ls)
 
1385
  in
 
1386
  let l = String.length str in
 
1387
  (* See if it is octal or hex *)
 
1388
  let octalhex = (l >= 1 && String.get str 0 = '0') in
 
1389
  (* The length of the suffix and a list of possible kinds. See ISO
 
1390
  * 6.4.4.1 *)
 
1391
  let hasSuffix = hasSuffix str in
 
1392
  let suffixlen, kinds =
 
1393
    if hasSuffix "ULL" || hasSuffix "LLU" then
 
1394
      3, [IULongLong]
 
1395
    else if hasSuffix "LL" then
 
1396
      2, if octalhex then [ILongLong; IULongLong] else [ILongLong]
 
1397
    else if hasSuffix "UL" || hasSuffix "LU" then
 
1398
      2, [IULong; IULongLong]
 
1399
    else if hasSuffix "L" then
 
1400
      1, if octalhex then [ILong; IULong; ILongLong; IULongLong]
 
1401
      else [ILong; ILongLong]
 
1402
    else if hasSuffix "U" then
 
1403
      1, [IUInt; IULong; IULongLong]
 
1404
    else
 
1405
      0, if octalhex || true (* !!! This is against the ISO but it
 
1406
        * is what GCC and MSVC do !!! *)
 
1407
      then [IInt; IUInt; ILong; IULong; ILongLong; IULongLong]
 
1408
      else [IInt; ILong; IUInt; ILongLong]
 
1409
  in
 
1410
  (* Convert to integer. To prevent overflow we do the arithmetic
 
1411
  * on Int64 and we take care of overflow. We work only with
 
1412
  * positive integers since the lexer takes care of the sign *)
 
1413
  let rec toInt (base: int64) (acc: int64) (idx: int) : int64 =
 
1414
    (*Format.printf "toInt base=%Ld acc=%Ld idx=%d@." base acc idx;*)
 
1415
    let doAcc (what: int) =
 
1416
      let acc' =
 
1417
        Int64.add (Int64.mul base acc)  (Int64.of_int what) in
 
1418
      if acc < Int64.zero || (* We clearly overflow since base >= 2
 
1419
      * *)
 
1420
      (acc' > Int64.zero && acc' < acc) then
 
1421
        E.s (unimp "Cannot represent on 64 bits the integer %s\n"
 
1422
               str)
 
1423
      else
 
1424
        toInt base acc' (idx + 1)
 
1425
    in
 
1426
    if idx >= l - suffixlen then begin
 
1427
      acc
 
1428
    end else
 
1429
      let ch = String.get str idx in
 
1430
      if ch >= '0' && ch <= '9' then
 
1431
        doAcc (Char.code ch - Char.code '0')
 
1432
      else if  ch >= 'a' && ch <= 'f'  then
 
1433
        doAcc (10 + Char.code ch - Char.code 'a')
 
1434
      else if  ch >= 'A' && ch <= 'F'  then
 
1435
        doAcc (10 + Char.code ch - Char.code 'A')
 
1436
      else
 
1437
        E.s (bug "Invalid integer constant: %s" str)
 
1438
  in
 
1439
  try
 
1440
    let i =
 
1441
      if octalhex then
 
1442
        if l >= 2 &&
 
1443
          (let c = String.get str 1 in c = 'x' || c = 'X') then
 
1444
          toInt (Int64.of_int 16) Int64.zero 2
 
1445
        else
 
1446
          toInt (Int64.of_int 8) Int64.zero 1
 
1447
      else
 
1448
        toInt (Int64.of_int 10) Int64.zero 0
 
1449
    in
 
1450
(*    Format.printf "Got i =%Ld@." i;*)
 
1451
    (* Construct an integer of the first kinds that fits. i must be
 
1452
    * POSITIVE  *)
 
1453
(*    assert (Int64.zero <= i);*)
 
1454
    let res =
 
1455
            let rec loop = function
 
1456
          k::rest ->
 
1457
            let nrBits =
 
1458
              let unsignedbits = 8 * (bytesSizeOfInt k) in
 
1459
              if isSigned k then
 
1460
                unsignedbits-1
 
1461
              else
 
1462
                unsignedbits
 
1463
            in
 
1464
            (* Will i fit in nrBits bits? *)
 
1465
            let bound : int64 = Int64.shift_left 1L nrBits in
 
1466
            (* toInt has ensured that 0 <= i < 263.
 
1467
               So if nrBits >=63, i fits *)
 
1468
            if (nrBits >= 63) || (i < bound) then
 
1469
              kinteger64 k i
 
1470
            else
 
1471
              loop rest
 
1472
        | [] -> E.s (E.unimp "Cannot represent the integer %s\n"
 
1473
                       (Int64.to_string i))
 
1474
      in
 
1475
(*
 
1476
let rec loop = function
 
1477
        | ((IInt | ILong) as k) :: _
 
1478
                  when i < Int64.shift_left (Int64.of_int 1) 31 ->
 
1479
                    kinteger64 k i
 
1480
        | ((IUInt | IULong) as k) :: _
 
1481
                  when i < Int64.shift_left (Int64.of_int 1) 32
 
1482
          ->  kinteger64 k i
 
1483
        | (ILongLong as k) :: _
 
1484
                 when i  <= Int64.sub (Int64.shift_left
 
1485
                                              (Int64.of_int 1) 63)
 
1486
                                          (Int64.of_int 1)
 
1487
          ->
 
1488
            kinteger64 k i
 
1489
        | (IULongLong as k) :: _ -> kinteger64 k i
 
1490
        | _ :: rest -> loop rest
 
1491
        | [] -> E.s (E.unimp "Cannot represent the integer %s\n"
 
1492
                       (Int64.to_string i))
 
1493
      in
 
1494
*)
 
1495
      loop kinds
 
1496
    in
 
1497
    res
 
1498
  with Failure _ as e -> begin
 
1499
    ignore (log "int_of_string %s (%s)\n" str
 
1500
              (Printexc.to_string e));
 
1501
    zero
 
1502
  end
 
1503
 
 
1504
let mkStmt ?(valid_sid=false) (sk: stmtkind) : stmt =
 
1505
  { skind = sk;
 
1506
    labels = [];
 
1507
    (* It is better to create statements with a valid sid, so that they can
 
1508
       be safely be used in tables. I only do it when performing Jessie
 
1509
       analysis, as other plugins rely on specific sid values for their tests
 
1510
       (e.g. slicing). *)
 
1511
    sid = if valid_sid then Sid.next () else -1;
 
1512
    succs = []; preds = [];
 
1513
    ghost = false}
 
1514
 
 
1515
let mkStmtCfg ~before ~(new_stmtkind:stmtkind) ~(ref_stmt:stmt) : stmt =
 
1516
  let new_ = { skind = new_stmtkind;
 
1517
               labels = [];
 
1518
               sid = -1; succs = []; preds = []; ghost = false }
 
1519
  in
 
1520
  new_.sid <- Sid.next ();
 
1521
  if before then begin
 
1522
    new_.succs <- [ref_stmt];
 
1523
    let old_preds = ref_stmt.preds in
 
1524
    ref_stmt.preds <- [new_];
 
1525
    new_.preds <- old_preds;
 
1526
    List.iter
 
1527
      (fun pred_stmt ->
 
1528
         pred_stmt.succs <-
 
1529
           (List.map
 
1530
              (fun a_succ -> if a_succ.sid = ref_stmt.sid then new_ else a_succ)
 
1531
              pred_stmt.succs))
 
1532
      old_preds
 
1533
  end else begin
 
1534
    let old_succs = ref_stmt.succs in
 
1535
    ref_stmt.succs <- [new_];
 
1536
    new_.preds <- [ref_stmt];
 
1537
    new_.succs <- old_succs;
 
1538
    List.iter
 
1539
      (fun succ_stmt ->
 
1540
         succ_stmt.preds <-
 
1541
           (List.map
 
1542
              (fun a_pred -> if a_pred.sid = ref_stmt.sid then new_ else a_pred)
 
1543
              succ_stmt.preds))
 
1544
      old_succs
 
1545
  end;
 
1546
  new_
 
1547
 
 
1548
 
 
1549
let mkBlock (slst: stmt list) : block =
 
1550
  let slst = List.filter
 
1551
    (fun st -> match st.skind with
 
1552
     | Instr (Skip _) when st.labels = [] -> false
 
1553
     | _ ->true)
 
1554
    slst
 
1555
  in
 
1556
  { battrs = []; bstmts = slst; }
 
1557
 
 
1558
let mkStmtCfgBlock sl =
 
1559
  let sid = Sid.next () in
 
1560
  let n = mkStmt (Block (mkBlock sl)) in
 
1561
  n.sid <- sid;
 
1562
  match sl with
 
1563
    | [] -> n
 
1564
    | s::_ ->
 
1565
        let old_preds = s.preds in
 
1566
        n.succs <- [s];
 
1567
        n.preds <- s.preds;
 
1568
        List.iter
 
1569
          (fun pred_stmt ->
 
1570
             pred_stmt.succs <-
 
1571
               (List.map
 
1572
                  (fun a_succ -> if a_succ.sid = s.sid then
 
1573
                     n
 
1574
                   else a_succ)
 
1575
                  pred_stmt.succs))
 
1576
          old_preds;
 
1577
        n
 
1578
 
 
1579
let stmt_of_instr_list ?(loc=locUnknown) = function
 
1580
  | [] -> Instr (Skip loc)
 
1581
  | [i] -> Instr i
 
1582
  | il ->
 
1583
      let b = mkBlock (List.map (fun i -> mkStmt (Instr i)) il) in
 
1584
      match b.bstmts with
 
1585
      | [] -> Instr (Skip loc)
 
1586
      | [s] when b.battrs = [] -> s.skind
 
1587
      | _ -> Block b
 
1588
 
 
1589
let mkEmptyStmt ?(loc=locUnknown) () = mkStmt (Instr (Skip loc))
 
1590
let mkStmtOneInstr (i: instr) = mkStmt (Instr i)
 
1591
 
 
1592
let dummyInstr = Asm([], ["dummy statement!!"], [], [], [], locUnknown)
 
1593
let dummyStmt = mkStmt (Instr dummyInstr)
 
1594
 
 
1595
(***
 
1596
let compactStmts (b: stmt list) : stmt list =
 
1597
      (* Try to compress statements. Scan the list of statements and remember
 
1598
       * the last instrunction statement encountered, along with a Clist of
 
1599
       * instructions in it. *)
 
1600
  let rec compress (lastinstrstmt: stmt) (* Might be dummStmt *)
 
1601
                   (lastinstrs: instr Clist.clist)
 
1602
                   (body: stmt list) =
 
1603
    let finishLast (tail: stmt list) : stmt list =
 
1604
      if lastinstrstmt == dummyStmt then tail
 
1605
      else begin
 
1606
        lastinstrstmt.skind <- Instr (Clist.toList lastinstrs);
 
1607
        lastinstrstmt :: tail
 
1608
      end
 
1609
    in
 
1610
    match body with
 
1611
      [] -> finishLast []
 
1612
    | ({skind=Instr il} as s) :: rest ->
 
1613
        let ils = Clist.fromList il in
 
1614
        if lastinstrstmt != dummyStmt && s.labels == [] then
 
1615
          compress lastinstrstmt (Clist.append lastinstrs ils) rest
 
1616
        else
 
1617
          finishLast (compress s ils rest)
 
1618
 
 
1619
    | s :: rest ->
 
1620
        let res = s :: compress dummyStmt Clist.empty rest in
 
1621
        finishLast res
 
1622
  in
 
1623
  compress dummyStmt Clist.empty b
 
1624
***)
 
1625
 
 
1626
(**** ATTRIBUTES ****)
 
1627
 
 
1628
 
 
1629
(* JS: build an attribute annotation from [s]. *)
 
1630
let mkAttrAnnot s = "/*@ " ^ s ^ " */"
 
1631
 
 
1632
(* JS: *)
 
1633
let attributeName = function Attr(a, _) | AttrAnnot a -> a
 
1634
 
 
1635
(* Internal attributes. Won't be pretty-printed *)
 
1636
let reserved_attributes = ["FRAMA_C_KEEP_BLOCK"]
 
1637
 
 
1638
(** Construct sorted lists of attributes ***)
 
1639
let rec addAttribute
 
1640
    (Attr(an, _) | AttrAnnot an as a: attribute) (al: attributes) =
 
1641
  let rec insertSorted = function
 
1642
      [] -> [a]
 
1643
    | ((Attr(an0, _) | AttrAnnot an0 as a0) :: rest) as l ->
 
1644
        if an < an0 then a :: l
 
1645
        else if equals a a0 then l (* Do not add if already in there *)
 
1646
        else a0 :: insertSorted rest (* Make sure we see all attributes with
 
1647
                                      * this name *)
 
1648
  in
 
1649
  insertSorted al
 
1650
 
 
1651
(** The second attribute list is sorted *)
 
1652
and addAttributes al0 (al: attributes) : attributes =
 
1653
    if al0 == [] then al else
 
1654
    List.fold_left (fun acc a -> addAttribute a acc) al al0
 
1655
 
 
1656
and dropAttribute (an: string) (al: attributes) =
 
1657
  List.filter (fun a -> attributeName a <> an) al
 
1658
 
 
1659
and dropAttributes (anl: string list) (al: attributes) =
 
1660
  List.fold_left (fun acc an -> dropAttribute an acc) al anl
 
1661
 
 
1662
and filterAttributes (s: string) (al: attribute list) : attribute list =
 
1663
  List.filter (fun a -> attributeName a = s) al
 
1664
 
 
1665
and findAttribute (s: string) (al: attribute list) : attrparam list =
 
1666
  List.fold_left
 
1667
    (fun acc -> function
 
1668
     | Attr (an, param) when an = s -> param @ acc
 
1669
     | _ -> acc)
 
1670
    [] al
 
1671
 
 
1672
(* sm: *)
 
1673
let hasAttribute s al =
 
1674
  (filterAttributes s al <> [])
 
1675
 
 
1676
type attributeClass =
 
1677
  | AttrName of bool
 
1678
        (* Attribute of a name. If argument is true and we are on MSVC then
 
1679
         * the attribute is printed using __declspec as part of the storage
 
1680
         * specifier  *)
 
1681
  | AttrFunType of bool
 
1682
        (* Attribute of a function type. If argument is true and we are on
 
1683
         * MSVC then the attribute is printed just before the function name *)
 
1684
 
 
1685
  | AttrType  (* Attribute of a type *)
 
1686
 
 
1687
(* This table contains the mapping of predefined attributes to classes.
 
1688
 * Extend this table with more attributes as you need. This table is used to
 
1689
 * determine how to associate attributes with names or type during cabs2cil
 
1690
 * conversion *)
 
1691
let attributeHash: (string, attributeClass) H.t =
 
1692
  let table = H.create 13 in
 
1693
  List.iter (fun a -> H.add table a (AttrName false))
 
1694
    [ "section"; "constructor"; "destructor"; "unused"; "used"; "weak";
 
1695
      "no_instrument_function"; "alias"; "no_check_memory_usage";
 
1696
      "exception"; "model"; (* "restrict"; *)
 
1697
      "aconst"; "__asm__" (* Gcc uses this to specifiy the name to be used in
 
1698
                           * assembly for a global  *)];
 
1699
  (* Now come the MSVC declspec attributes *)
 
1700
  List.iter (fun a -> H.add table a (AttrName true))
 
1701
    [ "thread"; "naked"; "dllimport"; "dllexport";
 
1702
      "selectany"; "allocate"; "nothrow"; "novtable"; "property";  "noreturn";
 
1703
      "uuid"; "align" ];
 
1704
  List.iter (fun a -> H.add table a (AttrFunType false))
 
1705
    [ "format"; "regparm"; "longcall"; "noinline"; "always_inline" ];
 
1706
  List.iter (fun a -> H.add table a (AttrFunType true))
 
1707
    [ "stdcall";"cdecl"; "fastcall" ];
 
1708
  List.iter (fun a -> H.add table a AttrType)
 
1709
    [ "const"; "volatile"; "restrict"; "mode" ];
 
1710
  table
 
1711
 
 
1712
let attributeClass = H.find attributeHash
 
1713
 
 
1714
let registerAttribute = H.add attributeHash
 
1715
let removeAttribute = H.remove attributeHash
 
1716
 
 
1717
(** Partition the attributes into classes *)
 
1718
let partitionAttributes
 
1719
    ~(default:attributeClass)
 
1720
    (attrs:  attribute list) :
 
1721
    attribute list * attribute list * attribute list =
 
1722
  let rec loop (n,f,t) = function
 
1723
      [] -> n, f, t
 
1724
    | (Attr(an, _) | AttrAnnot an as a) :: rest ->
 
1725
        match (try H.find attributeHash an with Not_found -> default) with
 
1726
          AttrName _ -> loop (addAttribute a n, f, t) rest
 
1727
        | AttrFunType _ ->
 
1728
            loop (n, addAttribute a f, t) rest
 
1729
        | AttrType -> loop (n, f, addAttribute a t) rest
 
1730
  in
 
1731
  loop ([], [], []) attrs
 
1732
 
 
1733
 
 
1734
(** Get the full name of a comp *)
 
1735
let compFullName comp =
 
1736
  (if comp.cstruct then "struct " else "union ") ^ comp.cname
 
1737
 
 
1738
 
 
1739
let missingFieldName = "_" (* "___missing_field_name"*)
 
1740
 
 
1741
(** Creates a (potentially recursive) composite type. Make sure you add a
 
1742
  * GTag for it to the file! **)
 
1743
let mkCompInfo
 
1744
      (isstruct: bool)
 
1745
      (n: string)
 
1746
      (* fspec is a function that when given a forward
 
1747
       * representation of the structure type constructs the type of
 
1748
       * the fields. The function can ignore this argument if not
 
1749
       * constructing a recursive type.  *)
 
1750
       (mkfspec: compinfo -> (string * typ * int option * attribute list *
 
1751
                             location) list)
 
1752
       (a: attribute list) : compinfo =
 
1753
 
 
1754
  (* make a new name for anonymous structs *)
 
1755
   if n = "" then
 
1756
     E.s (E.bug "mkCompInfo: missing structure name\n");
 
1757
   (* Make a new self cell and a forward reference *)
 
1758
   let comp =
 
1759
     { cstruct = isstruct; cname = ""; ckey = 0; cfields = [];
 
1760
       cattr = a; creferenced = false;
 
1761
       (* Make this compinfo undefined by default *)
 
1762
       cdefined = false; }
 
1763
   in
 
1764
   comp.cname <- n;
 
1765
   comp.ckey <- nextCompinfoKey ();
 
1766
   let flds =
 
1767
       List.map (fun (fn, ft, fb, fa, fl) ->
 
1768
          { fcomp = comp;
 
1769
            ftype = ft;
 
1770
            fname = fn;
 
1771
            fbitfield = fb;
 
1772
            fattr = fa;
 
1773
            floc = fl;
 
1774
            faddrof = false;
 
1775
            fsize_in_bits = None;
 
1776
            foffset_in_bits = None;
 
1777
            fpadding_in_bits = None;
 
1778
          }) (mkfspec comp) in
 
1779
   comp.cfields <- flds;
 
1780
   if flds <> [] then comp.cdefined <- true;
 
1781
   comp
 
1782
 
 
1783
(** Make a copy of a compinfo, changing the name and the key *)
 
1784
let copyCompInfo (ci: compinfo) (n: string) : compinfo =
 
1785
  let ci' = {ci with cname = n; ckey = nextCompinfoKey (); } in
 
1786
  (* Copy the fields and set the new pointers to parents *)
 
1787
  ci'.cfields <- List.map (fun f -> {f with fcomp = ci'}) ci'.cfields;
 
1788
  ci'
 
1789
 
 
1790
(**** Utility functions ******)
 
1791
 
 
1792
let rec typeAttrs = function
 
1793
    TVoid a -> a
 
1794
  | TInt (_, a) -> a
 
1795
  | TFloat (_, a) -> a
 
1796
  | TNamed (t, a) -> addAttributes a (typeAttrs t.ttype)
 
1797
  | TPtr (_, a) -> a
 
1798
  | TArray (_, _, a) -> a
 
1799
  | TComp (comp, a) -> addAttributes comp.cattr a
 
1800
  | TEnum (enum, a) -> addAttributes enum.eattr a
 
1801
  | TFun (_, _, _, a) -> a
 
1802
  | TBuiltin_va_list a -> a
 
1803
 
 
1804
 
 
1805
let typeAttr = function
 
1806
  | TVoid a
 
1807
  | TInt (_, a)
 
1808
  | TFloat (_, a)
 
1809
  | TNamed (_, a)
 
1810
  | TPtr (_, a)
 
1811
  | TArray (_, _, a)
 
1812
  | TComp (_, a)
 
1813
  | TEnum (_, a)
 
1814
  | TFun (_, _, _, a)
 
1815
  | TBuiltin_va_list a -> a
 
1816
 
 
1817
 
 
1818
let setTypeAttrs t a =
 
1819
  match t with
 
1820
    TVoid _ -> TVoid a
 
1821
  | TInt (i, _) -> TInt (i, a)
 
1822
  | TFloat (f, _) -> TFloat (f, a)
 
1823
  | TNamed (t, _) -> TNamed(t, a)
 
1824
  | TPtr (t', _) -> TPtr(t', a)
 
1825
  | TArray (t', l, _) -> TArray(t', l, a)
 
1826
  | TComp (comp, _) -> TComp (comp, a)
 
1827
  | TEnum (enum, _) -> TEnum (enum, a)
 
1828
  | TFun (r, args, v, _) -> TFun(r,args,v,a)
 
1829
  | TBuiltin_va_list _ -> TBuiltin_va_list a
 
1830
 
 
1831
 
 
1832
let typeAddAttributes a0 t =
 
1833
begin
 
1834
  match a0 with
 
1835
  | [] ->
 
1836
      (* no attributes, keep same type *)
 
1837
      t
 
1838
  | _ ->
 
1839
      (* anything else: add a0 to existing attributes *)
 
1840
      let add (a: attributes) = addAttributes a0 a in
 
1841
      match t with
 
1842
        TVoid a -> TVoid (add a)
 
1843
      | TInt (ik, a) -> TInt (ik, add a)
 
1844
      | TFloat (fk, a) -> TFloat (fk, add a)
 
1845
      | TEnum (enum, a) -> TEnum (enum, add a)
 
1846
      | TPtr (t, a) -> TPtr (t, add a)
 
1847
      | TArray (t, l, a) -> TArray (t, l, add a)
 
1848
      | TFun (t, args, isva, a) -> TFun(t, args, isva, add a)
 
1849
      | TComp (comp, a) -> TComp (comp, add a)
 
1850
      | TNamed (t, a) -> TNamed (t, add a)
 
1851
      | TBuiltin_va_list a -> TBuiltin_va_list (add a)
 
1852
end
 
1853
 
 
1854
let typeRemoveAttributes (anl: string list) t =
 
1855
  let drop (al: attributes) = dropAttributes anl al in
 
1856
  match t with
 
1857
    TVoid a -> TVoid (drop a)
 
1858
  | TInt (ik, a) -> TInt (ik, drop a)
 
1859
  | TFloat (fk, a) -> TFloat (fk, drop a)
 
1860
  | TEnum (enum, a) -> TEnum (enum, drop a)
 
1861
  | TPtr (t, a) -> TPtr (t, drop a)
 
1862
  | TArray (t, l, a) -> TArray (t, l, drop a)
 
1863
  | TFun (t, args, isva, a) -> TFun(t, args, isva, drop a)
 
1864
  | TComp (comp, a) -> TComp (comp, drop a)
 
1865
  | TNamed (t, a) -> TNamed (t, drop a)
 
1866
  | TBuiltin_va_list a -> TBuiltin_va_list (drop a)
 
1867
 
 
1868
let unrollType (t: typ) : typ =
 
1869
  let rec withAttrs (al: attributes) (t: typ) : typ =
 
1870
    match t with
 
1871
      TNamed (r, a') -> withAttrs (addAttributes al a') r.ttype
 
1872
    | x -> typeAddAttributes al x
 
1873
  in
 
1874
  withAttrs [] t
 
1875
 
 
1876
let rec unrollTypeDeep (t: typ) : typ =
 
1877
  let rec withAttrs (al: attributes) (t: typ) : typ =
 
1878
    match t with
 
1879
      TNamed (r, a') -> withAttrs (addAttributes al a') r.ttype
 
1880
    | TPtr(t, a') -> TPtr(unrollTypeDeep t, addAttributes al a')
 
1881
    | TArray(t, l, a') -> TArray(unrollTypeDeep t, l, addAttributes al a')
 
1882
    | TFun(rt, args, isva, a') ->
 
1883
        TFun (unrollTypeDeep rt,
 
1884
              (match args with
 
1885
                None -> None
 
1886
              | Some argl ->
 
1887
                  Some (List.map (fun (an,at,aa) ->
 
1888
                  (an, unrollTypeDeep at, aa)) argl)),
 
1889
              isva,
 
1890
              addAttributes al a')
 
1891
    | x -> typeAddAttributes al x
 
1892
  in
 
1893
  withAttrs [] t
 
1894
 
 
1895
let isVoidType t =
 
1896
  match unrollType t with
 
1897
    TVoid _ -> true
 
1898
  | _ -> false
 
1899
let isVoidPtrType t =
 
1900
  match unrollType t with
 
1901
    TPtr(tau,_) when isVoidType tau -> true
 
1902
  | _ -> false
 
1903
 
 
1904
let isSignedInteger ty =
 
1905
  match unrollType ty with
 
1906
    | TInt(ik,_attr) -> isSigned ik
 
1907
    | TEnum _ -> theMachine.theMachine.Cil_types.enum_are_signed
 
1908
    | _ -> false
 
1909
 
 
1910
let var vi : lval = (Var vi, NoOffset)
 
1911
(* let assign vi e = Instrs(Set (var vi, e), lu) *)
 
1912
 
 
1913
let mkString s = Const(CStr s)
 
1914
 
 
1915
let mkWhile ~(guard:exp) ~(body: stmt list) : stmt list =
 
1916
  (* Do it like this so that the pretty printer recognizes it *)
 
1917
  [ mkStmt
 
1918
      (Loop ([],
 
1919
             mkBlock
 
1920
               (mkStmt
 
1921
                  (If(guard,
 
1922
                      mkBlock [ mkEmptyStmt () ],
 
1923
                      mkBlock [ mkStmt (Break locUnknown)], locUnknown)) ::
 
1924
                  body), locUnknown, None, None)) ]
 
1925
 
 
1926
 
 
1927
 
 
1928
let mkFor ~(start: stmt list) ~(guard: exp) ~(next: stmt list)
 
1929
          ~(body: stmt list) : stmt list =
 
1930
  (start @
 
1931
     (mkWhile guard (body @ next)))
 
1932
 
 
1933
 
 
1934
let mkForIncr ~(iter : varinfo) ~(first: exp) ~stopat:(past: exp) ~(incr: exp)
 
1935
    ~(body: stmt list) : stmt list =
 
1936
      (* See what kind of operator we need *)
 
1937
  let compop, nextop =
 
1938
    match unrollType iter.vtype with
 
1939
      TPtr _ -> Lt, PlusPI
 
1940
    | _ -> Lt, PlusA
 
1941
  in
 
1942
  mkFor
 
1943
    [ mkStmt (Instr (Set (var iter, first, locUnknown))) ]
 
1944
    (BinOp(compop, Lval(var iter), past, intType))
 
1945
    [ mkStmt (Instr (Set (var iter,
 
1946
                           (BinOp(nextop, Lval(var iter), incr, iter.vtype)),
 
1947
                           locUnknown)))]
 
1948
    body
 
1949
 
 
1950
let block_from_unspecified_sequence us =
 
1951
  { battrs = []; bstmts = List.map (fun (x,_,_) ->x) us }
 
1952
 
 
1953
let rec stripCasts (e: exp) =
 
1954
  match e with CastE(_, e') -> stripCasts e' | _ -> e
 
1955
 
 
1956
let rec stripInfo (e: exp) =
 
1957
  match e with Info(e',_) -> stripInfo e' | _ -> e
 
1958
 
 
1959
let rec stripCastsAndInfo (e: exp) =
 
1960
  match e with Info(e',_) | CastE(_,e') -> stripCastsAndInfo e' | _ -> e
 
1961
 
 
1962
let rec stripCastsButLastInfo (e: exp) =
 
1963
  match e with
 
1964
      Info((Info _ | CastE _ as e'),_) | CastE(_,e') -> stripCastsButLastInfo e'
 
1965
    | _ -> e
 
1966
 
 
1967
let rec stripTermCasts (t: term) =
 
1968
  match t.term_node with TCastE(_, t') -> stripTermCasts t' | _ -> t
 
1969
 
 
1970
let rec stripTsetsCasts (ts: tsets_elem) =
 
1971
  match ts with TSCastE(_ty,ts') -> stripTsetsCasts ts' | _ -> ts
 
1972
 
 
1973
let exp_info_of_term t =
 
1974
  {
 
1975
    exp_loc = t.term_loc;
 
1976
    exp_type = t.term_type;
 
1977
    exp_name = t.term_name;
 
1978
  }
 
1979
 
 
1980
let term_of_exp_info tnode einfo =
 
1981
  {
 
1982
    term_node = tnode;
 
1983
    term_loc = einfo.exp_loc;
 
1984
    term_type = einfo.exp_type;
 
1985
    term_name = einfo.exp_name;
 
1986
  }
 
1987
 
 
1988
let map_under_info f = function
 
1989
  | Info(e,einfo) -> Info(f e,einfo)
 
1990
  | e -> f e
 
1991
 
 
1992
let app_under_info f = function
 
1993
  | Info(e,_) | e -> f e
 
1994
 
 
1995
(* the name of the C function we call to get ccgr ASTs
 
1996
external parse : string -> file = "cil_main"
 
1997
*)
 
1998
(*
 
1999
  Pretty Printing
 
2000
 *)
 
2001
 
 
2002
let d_ikind fmt c =
 
2003
  fprintf fmt "%s"
 
2004
    ( match c with
 
2005
      | IChar -> "char"
 
2006
      | IBool -> "_Bool"
 
2007
      | ISChar -> "signed char"
 
2008
      | IUChar -> "unsigned char"
 
2009
      | IInt -> "int"
 
2010
      | IUInt -> "unsigned int"
 
2011
      | IShort -> "short"
 
2012
      | IUShort -> "unsigned short"
 
2013
      | ILong -> "long"
 
2014
      | IULong -> "unsigned long"
 
2015
      | ILongLong ->
 
2016
          if theMachine.msvcMode then "__int64" else "long long"
 
2017
      | IULongLong ->
 
2018
          if theMachine.msvcMode then "unsigned __int64"
 
2019
          else "unsigned long long")
 
2020
 
 
2021
let d_fkind fmt = function
 
2022
    FFloat -> fprintf fmt "float"
 
2023
  | FDouble -> fprintf fmt "double"
 
2024
  | FLongDouble -> fprintf fmt "long double"
 
2025
 
 
2026
let d_storage fmt c =
 
2027
  fprintf fmt "%s"
 
2028
    ( match c with
 
2029
      | NoStorage -> ""
 
2030
      | Static ->  "static "
 
2031
      | Extern -> "extern "
 
2032
      | Register -> "register ")
 
2033
 
 
2034
(* sm: need this value below *)
 
2035
let mostNeg32BitInt : int64 = (Int64.of_string "-0x80000000")
 
2036
let mostNeg64BitInt : int64 = (Int64.of_string "-0x8000000000000000")
 
2037
 
 
2038
(* constant *)
 
2039
let d_const fmt c =
 
2040
  match c with
 
2041
    CInt64(_, _, Some s) -> fprintf fmt "%s" s (* Always print the text if there is one *)
 
2042
  | CInt64(i, ik, None) ->
 
2043
      (*fprintf fmt "/* %Lx */" i;*)
 
2044
      (** We must make sure to capture the type of the constant. For some
 
2045
          * constants this is done with a suffix, for others with a cast prefix.*)
 
2046
      let suffix : string =
 
2047
        match ik with
 
2048
          IUInt -> "U"
 
2049
        | ILong -> "L"
 
2050
        | IULong -> "UL"
 
2051
        | ILongLong -> if theMachine.msvcMode then "L" else "LL"
 
2052
        | IULongLong -> if theMachine.msvcMode then "UL" else "ULL"
 
2053
        | _ -> ""
 
2054
      in
 
2055
      let prefix : string =
 
2056
        if suffix <> "" then ""
 
2057
        else if ik = IInt then ""
 
2058
        else fprintf_to_string "(%a)" d_ikind ik
 
2059
      in
 
2060
      (* Watch out here for negative integers that we should be printing as
 
2061
       * large positive ones *)
 
2062
      fprintf fmt "%s"
 
2063
        (if i < Int64.zero
 
2064
           && (match ik with
 
2065
                 IUInt | IULong | IULongLong | IUChar | IUShort -> true | _ -> false) then
 
2066
             let high = Int64.shift_right i 32 in
 
2067
             if ik <> IULongLong && ik <> ILongLong && high = Int64.of_int (-1) then
 
2068
               (* Print only the low order 32 bits *)
 
2069
               (prefix ^ "0x" ^
 
2070
                  (Int64.format "%x"
 
2071
                     (Int64.logand i (Int64.shift_right_logical high 32))
 
2072
                   ^ suffix))
 
2073
             else
 
2074
               (prefix ^ "0x" ^ Int64.format "%x" i ^ suffix)
 
2075
         else (
 
2076
           if (i = mostNeg32BitInt) then
 
2077
             (* sm: quirk here: if you print -2147483648 then this is two tokens *)
 
2078
             (* in C, and the second one is too large to represent in a signed *)
 
2079
             (* int.. so we do what's done in limits.h, and print (-2147483467-1); *)
 
2080
             (* in gcc this avoids a warning, but it might avoid a real problem *)
 
2081
             (* on another compiler or a 64-bit architecture *)
 
2082
             (prefix ^ "(-0x7FFFFFFF-1)")
 
2083
           else if (i = mostNeg64BitInt) then
 
2084
             (* The same is true of the largest 64-bit negative. *)
 
2085
             (prefix ^ "(-0x7FFFFFFFFFFFFFFF-1)")
 
2086
           else
 
2087
             (prefix ^ (Int64.to_string i ^ suffix))
 
2088
         ))
 
2089
 
 
2090
  | CStr(s) -> fprintf fmt "\"%s\"" (escape_string s)
 
2091
  | CWStr(s) ->
 
2092
      (* text ("L\"" ^ escape_string s ^ "\"")  *)
 
2093
      fprintf fmt "L";
 
2094
      List.iter
 
2095
        (fun elt ->
 
2096
           if (elt >= Int64.zero &&
 
2097
                 elt <= (Int64.of_int 255)) then
 
2098
             fprintf fmt "%S" (escape_char (Char.chr (Int64.to_int elt)))
 
2099
           else
 
2100
             fprintf fmt "\"\\x%LX\"" elt;
 
2101
           fprintf fmt "@ ")
 
2102
        s;
 
2103
        (* we cannot print L"\xabcd" "feedme" as L"\xabcdfeedme" --
 
2104
         * the former has 7 wide characters and the later has 3. *)
 
2105
 
 
2106
  | CChr(c) -> fprintf fmt "'%s'" (escape_char c)
 
2107
  | CReal(_, _, Some s) -> fprintf fmt "%s" s
 
2108
  | CReal(f, fsize, None) ->
 
2109
      fprintf fmt "%s%s" (string_of_float f)
 
2110
        (match fsize with
 
2111
           FFloat -> "f"
 
2112
         | FDouble -> ""
 
2113
         | FLongDouble -> "L")
 
2114
  | CEnum {einame = s} -> fprintf fmt "%s" s
 
2115
 
 
2116
 
 
2117
(* Parentheses/precedence level. An expression "a op b" is printed
 
2118
 * parenthesized if its parentheses level is >= that that of its context.
 
2119
 * Identifiers have the lowest level and weakly binding operators (e.g. |)
 
2120
 * have the largest level. The correctness criterion is that a smaller level
 
2121
 * MUST correspond to a stronger precedence! *)
 
2122
 
 
2123
let derefStarLevel = 20
 
2124
let indexLevel = 20
 
2125
let arrowLevel = 20
 
2126
let addrOfLevel = 30
 
2127
let additiveLevel = 60
 
2128
let comparativeLevel = 70
 
2129
let bitwiseLevel = 75
 
2130
let questionLevel = 100
 
2131
 
 
2132
let logic_level = 77
 
2133
 
 
2134
let getParenthLevel e = match stripInfo e with
 
2135
  | Info _ -> assert false
 
2136
  | BinOp((LAnd | LOr), _,_,_) -> 80
 
2137
                                        (* Bit operations. *)
 
2138
  | BinOp((BOr|BXor|BAnd),_,_,_) -> bitwiseLevel (* 75 *)
 
2139
 
 
2140
                                        (* Comparisons *)
 
2141
  | BinOp((Eq|Ne|Gt|Lt|Ge|Le),_,_,_) ->
 
2142
      comparativeLevel (* 70 *)
 
2143
                                        (* Additive. Shifts can have higher
 
2144
                                         * level than + or - but I want
 
2145
                                         * parentheses around them *)
 
2146
  | BinOp((MinusA|MinusPP|MinusPI|PlusA|
 
2147
           PlusPI|IndexPI|Shiftlt|Shiftrt),_,_,_)
 
2148
    -> additiveLevel (* 60 *)
 
2149
 
 
2150
                                        (* Multiplicative *)
 
2151
  | BinOp((Div|Mod|Mult),_,_,_) -> 40
 
2152
 
 
2153
                                        (* Unary *)
 
2154
  | CastE(_,_) -> 30
 
2155
  | AddrOf(_) -> 30
 
2156
  | StartOf(_) -> 30
 
2157
  | UnOp((Neg|BNot|LNot),_,_) -> 30
 
2158
 
 
2159
                                        (* Lvals *)
 
2160
  | Lval(Mem _ , _) -> derefStarLevel (* 20 *)
 
2161
  | Lval(Var _, (Field _|Index _)) -> indexLevel (* 20 *)
 
2162
  | SizeOf _ | SizeOfE _ | SizeOfStr _ -> 20
 
2163
  | AlignOf _ | AlignOfE _ -> 20
 
2164
 
 
2165
  | Lval(Var _, NoOffset) -> 0        (* Plain variables *)
 
2166
  | Const _ -> 0                        (* Constants *)
 
2167
 
 
2168
let getParenthLevelLogic = function
 
2169
  | Tlambda _ -> 90
 
2170
  (* TODO: remove spurious parentheses with prec mechanism
 
2171
                         for tsets *)
 
2172
  | Ttsets _ -> 90
 
2173
  | TBinOp((LAnd | LOr), _,_) -> 80
 
2174
                                        (* Bit operations. *)
 
2175
  | TBinOp((BOr|BXor|BAnd),_,_) -> bitwiseLevel (* 75 *)
 
2176
 
 
2177
                                        (* Comparisons *)
 
2178
  | TBinOp((Eq|Ne|Gt|Lt|Ge|Le),_,_) ->
 
2179
      comparativeLevel (* 70 *)
 
2180
                                        (* Additive. Shifts can have higher
 
2181
                                         * level than + or - but I want
 
2182
                                         * parentheses around them *)
 
2183
  | TBinOp((MinusA|MinusPP|MinusPI|PlusA|
 
2184
           PlusPI|IndexPI|Shiftlt|Shiftrt),_,_)
 
2185
    -> additiveLevel (* 60 *)
 
2186
 
 
2187
                                        (* Multiplicative *)
 
2188
  | TBinOp((Div|Mod|Mult),_,_) -> 40
 
2189
 
 
2190
                                        (* Unary *)
 
2191
  | TCastE(_,_) -> 30
 
2192
  | TAddrOf(_) -> addrOfLevel
 
2193
  | TStartOf(_) -> addrOfLevel
 
2194
  | TUnOp((Neg|BNot|LNot),_) -> 30
 
2195
                                        (* Unary post *)
 
2196
  | TCoerce _ | TCoerceE _ -> 25
 
2197
 
 
2198
                                        (* Lvals *)
 
2199
  | TLval(TMem _ , _) -> derefStarLevel
 
2200
  | TLval(TVar _, (TField _|TIndex _)) -> indexLevel
 
2201
  | TLval(TResult,(TField _|TIndex _)) -> indexLevel
 
2202
  | TSizeOf _ | TSizeOfE _ | TSizeOfStr _ -> 20
 
2203
  | TAlignOf _ | TAlignOfE _ -> 20
 
2204
      (* VP: I'm not sure I understand why sizeof(x) and f(x) should
 
2205
         have a separated treatment wrt parentheses. *)
 
2206
      (* application and applications-like constructions *)
 
2207
  | Tapp (_, _,_)|TDataCons _
 
2208
  | Tblock_length _ | Tbase_addr _ | Tat (_, _) | Told _
 
2209
  | TUpdate _ | Ttypeof _ | Ttype _ -> 10
 
2210
  | TLval(TVar _, TNoOffset) -> 0        (* Plain variables *)
 
2211
      (* Constructions that do not require parentheses *)
 
2212
  | TConst _
 
2213
  | Tnull | TLval (TResult,TNoOffset) -> 0
 
2214
  | Tif (_, _, _)  -> logic_level
 
2215
 
 
2216
 
 
2217
let getParenthLevelTsetsElem = function
 
2218
    TSLval(TSMem _,_) -> derefStarLevel
 
2219
  | TSLval((TSVar _ | TSResult) , (TSField _ | TSIndex _ | TSRange _)) ->
 
2220
      indexLevel
 
2221
  | TSAdd_range _ | TSAdd_index _ -> additiveLevel
 
2222
  | TSCastE _ -> 30
 
2223
  | TSStartOf _ | TSAddrOf _ -> addrOfLevel
 
2224
  | TSConst _ | TSLval _ | TSat _ | TSapp _ -> 0
 
2225
 
 
2226
let getParenthLevelAttrParam (a: attrparam) =
 
2227
  (* Create an expression of the same shape, and use {!getParenthLevel} *)
 
2228
  match a with
 
2229
    AInt _ | AStr _ | ACons _ -> 0
 
2230
  | ASizeOf _ | ASizeOfE _ | ASizeOfS _ -> 20
 
2231
  | AAlignOf _ | AAlignOfE _ | AAlignOfS _ -> 20
 
2232
  | AUnOp (uo, _) -> getParenthLevel (UnOp(uo, zero, intType))
 
2233
  | ABinOp (bo, _, _) -> getParenthLevel (BinOp(bo, zero, zero, intType))
 
2234
  | AAddrOf _ -> 30
 
2235
  | ADot _ | AIndex _ | AStar _ -> 20
 
2236
  | AQuestion _ -> questionLevel
 
2237
 
 
2238
 
 
2239
(* Separate out the storage-modifier name attributes *)
 
2240
let separateStorageModifiers (al: attribute list) =
 
2241
  let isstoragemod (Attr(an, _) | AttrAnnot an : attribute) : bool =
 
2242
    try
 
2243
      match H.find attributeHash an with
 
2244
        AttrName issm -> issm
 
2245
      | _ -> false
 
2246
    with Not_found -> false
 
2247
  in
 
2248
    let stom, rest = List.partition isstoragemod al in
 
2249
    if not theMachine.msvcMode then
 
2250
      stom, rest
 
2251
    else
 
2252
      (* Put back the declspec. Put it without the leading __ since these will
 
2253
       * be added later *)
 
2254
      let stom' =
 
2255
        List.map
 
2256
          (function
 
2257
           | Attr(an, args) -> Attr("declspec", [ACons(an, args)])
 
2258
           | AttrAnnot _ -> assert false)
 
2259
          stom
 
2260
      in
 
2261
      stom', rest
 
2262
 
 
2263
 
 
2264
let isCharType t =
 
2265
  match unrollType t with
 
2266
    | TInt((IChar|ISChar|IUChar),_) -> true
 
2267
    | _ -> false
 
2268
 
 
2269
let isCharPtrType t =
 
2270
  match unrollType t with
 
2271
    TPtr(tau,_) when isCharType tau -> true
 
2272
  | _ -> false
 
2273
 
 
2274
let isIntegralType t =
 
2275
  match unrollType t with
 
2276
    (TInt _ | TEnum _) -> true
 
2277
  | _ -> false
 
2278
 
 
2279
let isLogicIntegralType t =
 
2280
  match t with
 
2281
    | Ctype t -> isIntegralType t
 
2282
    | Linteger -> true
 
2283
    | Lreal -> false
 
2284
    | Lvar _ | Ltype _ | Larrow _ -> false
 
2285
 
 
2286
let isFloatingType t =
 
2287
  match unrollType t with
 
2288
    TFloat _ -> true
 
2289
  | _ -> false
 
2290
 
 
2291
let isLogicFloatType t =
 
2292
  match t with
 
2293
    | Ctype t -> isFloatingType t
 
2294
    | Linteger -> false
 
2295
    | Lreal -> false
 
2296
    | Lvar _ | Ltype _ | Larrow _ -> false
 
2297
 
 
2298
let isLogicRealOrFloatType t =
 
2299
  match t with
 
2300
    | Ctype t -> isFloatingType t
 
2301
    | Linteger -> false
 
2302
    | Lreal -> true
 
2303
    | Lvar _ | Ltype _ | Larrow _ -> false
 
2304
 
 
2305
let isArithmeticType t =
 
2306
  match unrollType t with
 
2307
    (TInt _ | TEnum _ | TFloat _) -> true
 
2308
  | _ -> false
 
2309
 
 
2310
let isLogicArithmeticType t =
 
2311
  match t with
 
2312
    | Ctype t -> isArithmeticType t
 
2313
    | Linteger | Lreal -> true
 
2314
    | Lvar _ | Ltype _ | Larrow _ -> false
 
2315
 
 
2316
let isPointerType t =
 
2317
  match unrollType t with
 
2318
    TPtr _ -> true
 
2319
  | _ -> false
 
2320
 
 
2321
let isTypeTagType t =
 
2322
  match t with
 
2323
      Ltype("typetag",[]) -> true
 
2324
    | _ -> false
 
2325
 
 
2326
let isFunctionType t =
 
2327
  match unrollType t with
 
2328
    TFun _ -> true
 
2329
  | _ -> false
 
2330
 
 
2331
let getReturnType t =
 
2332
  match unrollType t with
 
2333
    | TFun(rt,_,_,_) -> rt
 
2334
    | _ -> E.s (E.bug "getReturnType: not a function type")
 
2335
 
 
2336
let setReturnTypeVI (v: varinfo) (t: typ) =
 
2337
  match unrollType v.vtype with
 
2338
    | TFun (_, args, va, a) ->
 
2339
        v.vtype <- TFun (t, args, va, a)
 
2340
    | _ -> E.s (E.bug "setReturnType: not a function type")
 
2341
 
 
2342
let setReturnType (f:fundec) (t:typ) =
 
2343
  setReturnTypeVI f.svar t
 
2344
 
 
2345
(** Returns the type pointed by the given type. Asserts it is a pointer type *)
 
2346
let typeOf_pointed typ =
 
2347
  match unrollType typ with
 
2348
  | TPtr (typ,_) -> typ
 
2349
  | _ -> assert false
 
2350
 
 
2351
(**** Compute the type of an expression ****)
 
2352
let rec typeOf (e: exp) : typ =
 
2353
  match stripInfo e with
 
2354
  | Info _ -> assert false
 
2355
  | Const(CInt64 (_, ik, _)) -> TInt(ik, [])
 
2356
 
 
2357
    (* Character constants have type int.  ISO/IEC 9899:1999 (E),
 
2358
     * section 6.4.4.4 [Character constants], paragraph 10, if you
 
2359
     * don't believe me. *)
 
2360
  | Const(CChr _) -> intType
 
2361
 
 
2362
    (* The type of a string is a pointer to characters ! The only case when
 
2363
     * you would want it to be an array is as an argument to sizeof, but we
 
2364
     * have SizeOfStr for that *)
 
2365
  | Const(CStr _s) -> theMachine.stringLiteralType
 
2366
 
 
2367
  | Const(CWStr _s) -> TPtr(theMachine.wcharType,[])
 
2368
 
 
2369
  | Const(CReal (_, fk, _)) -> TFloat(fk, [])
 
2370
 
 
2371
  | Const(CEnum {eihost = ei}) -> TEnum(ei, [])
 
2372
 
 
2373
  | Lval(lv) -> typeOfLval lv
 
2374
  | SizeOf _ | SizeOfE _ | SizeOfStr _ -> theMachine.typeOfSizeOf
 
2375
  | AlignOf _ | AlignOfE _ -> theMachine.typeOfSizeOf
 
2376
  | UnOp (_, _, t) -> t
 
2377
  | BinOp (_, _, _, t) -> t
 
2378
  | CastE (t, _) -> t
 
2379
  | AddrOf (lv) -> TPtr(typeOfLval lv, [])
 
2380
  | StartOf (lv) -> begin
 
2381
      match unrollType (typeOfLval lv) with
 
2382
        TArray (t,_, _) -> TPtr(t, [])
 
2383
     | _ -> E.s (E.bug "typeOf: StartOf on a non-array")
 
2384
  end
 
2385
 
 
2386
and typeOfInit (i: init) : typ =
 
2387
  match i with
 
2388
    SingleInit e -> typeOf e
 
2389
  | CompoundInit (t, _) -> t
 
2390
 
 
2391
and typeOfLval = function
 
2392
    Var vi, off -> typeOffset vi.vtype off
 
2393
  | Mem addr, off -> begin
 
2394
      match unrollType (typeOf addr) with
 
2395
        TPtr (t, _) -> typeOffset t off
 
2396
      | _ -> E.s (bug "typeOfLval: Mem on a non-pointer (%a)" !pd_exp addr)
 
2397
  end
 
2398
 
 
2399
and typeOffset basetyp =
 
2400
  let blendAttributes baseAttrs =
 
2401
    let (_, _, contageous) =
 
2402
      partitionAttributes ~default:(AttrName false) baseAttrs in
 
2403
    typeAddAttributes contageous
 
2404
  in
 
2405
  function
 
2406
    NoOffset -> basetyp
 
2407
  | Index (_, o) -> begin
 
2408
      match unrollType basetyp with
 
2409
        TArray (t, _, baseAttrs) ->
 
2410
          let elementType = typeOffset t o in
 
2411
          blendAttributes baseAttrs elementType
 
2412
      | _ -> E.s (E.bug "typeOffset: Index on a non-array")
 
2413
  end
 
2414
  | Field (fi, o) ->
 
2415
      match unrollType basetyp with
 
2416
        TComp (_, baseAttrs) ->
 
2417
          let fieldType = typeOffset fi.ftype o in
 
2418
          let typ = blendAttributes baseAttrs fieldType in
 
2419
          (match fi.fbitfield with
 
2420
           | Some s ->
 
2421
               typeAddAttributes [Attr ("FRAMA_C_BITFIELD_SIZE", [AInt s])] typ
 
2422
           | None -> typ)
 
2423
      | _ -> E.s (bug "typeOffset: Field on a non-compound")
 
2424
 
 
2425
(**** Compute the type of a term lval ****)
 
2426
let rec typeOfTermLval = function
 
2427
    TVar vi, off ->
 
2428
      let ty = match vi.lv_origin with
 
2429
        | Some v -> Ctype v.vtype
 
2430
        | None -> vi.lv_type
 
2431
      in
 
2432
      typeTermOffset ty off
 
2433
  | TResult,_ ->
 
2434
      begin match !currentGlobal with
 
2435
        | GFun(f,_loc) -> Ctype (getReturnType f.svar.vtype)
 
2436
        | _ -> E.s (bug "typeOfTermLval: Can not compute type of result")
 
2437
      end
 
2438
  | TMem addr, off -> begin
 
2439
      match addr.term_type with
 
2440
        | Ctype typ ->
 
2441
            begin match unrollType typ with
 
2442
                TPtr (t, _) -> typeTermOffset (Ctype t) off
 
2443
              | _ -> E.s (bug "typeOfTermLval: Mem on a non-pointer")
 
2444
            end
 
2445
        | Linteger | Lreal ->
 
2446
            E.s (bug "typeOfTermLval: Mem on a logic type")
 
2447
        | Ltype (s,_) -> E.s (bug "typeOfTermLval: Mem on a non-C type (%s)" s)
 
2448
        | Lvar s -> E.s (bug "typeOfTermLval: Mem on a non-C type ('%s)" s)
 
2449
        | Larrow _ -> E.s (bug "typeOfTermLval: Mem on a function type")
 
2450
  end
 
2451
 
 
2452
and typeTermOffset basetyp =
 
2453
  let blendAttributes baseAttrs =
 
2454
    let (_, _, contageous) =
 
2455
      partitionAttributes ~default:(AttrName false) baseAttrs in
 
2456
    function
 
2457
      | Ctype typ ->
 
2458
          Ctype (typeAddAttributes contageous typ)
 
2459
      | Linteger | Lreal ->
 
2460
          E.s (bug "typeTermOffset: Attribute on a logic type")
 
2461
      | Ltype (s,_) ->
 
2462
          E.s (bug "typeTermOffset: Attribute on a non-C type (%s)" s)
 
2463
      | Lvar s ->
 
2464
          E.s (bug "typeTermOffset: Attribute on a non-C type ('%s)" s)
 
2465
      | Larrow _ ->
 
2466
          E.s (bug "typeTermOffset: Attribute on a function type")
 
2467
  in
 
2468
  function
 
2469
    TNoOffset -> basetyp
 
2470
  | TIndex (_, o) -> begin
 
2471
      match basetyp with
 
2472
        | Ctype typ ->
 
2473
            begin match unrollType typ with
 
2474
                TArray (t, _, baseAttrs) ->
 
2475
                  let elementType = typeTermOffset (Ctype t) o in
 
2476
                  blendAttributes baseAttrs elementType
 
2477
              | _ -> E.s (E.bug "typeTermOffset: Index on a non-array")
 
2478
            end
 
2479
         | Linteger | Lreal ->
 
2480
             E.s (bug "typeTermOffset: Index on a logic type")
 
2481
         | Ltype (s,_) ->
 
2482
            E.s (bug "typeTermOffset: Index on a non-C type (%s)" s)
 
2483
         | Lvar s ->
 
2484
            E.s (bug "typeTermOffset: Index on a non-C type ('%s)" s)
 
2485
         | Larrow _ ->
 
2486
             E.s (bug "typeTermOffset: Index on a function type")
 
2487
  end
 
2488
  | TField (fi, o) ->
 
2489
      match basetyp with
 
2490
        | Ctype typ ->
 
2491
            begin match unrollType typ with
 
2492
                TComp (_, baseAttrs) ->
 
2493
                  let fieldType = typeTermOffset (Ctype fi.ftype) o in
 
2494
                  blendAttributes baseAttrs fieldType
 
2495
              | _ -> E.s (bug "typeTermOffset: Field on a non-compound")
 
2496
            end
 
2497
        | Linteger | Lreal ->
 
2498
            E.s (bug "typeTermOffset: Field on a logic type")
 
2499
        | Ltype (s,_) ->
 
2500
            E.s (bug "typeTermOffset: Field on a non-C type (%s)" s)
 
2501
        | Lvar s -> E.s (bug "typeTermOffset: Field on a non-C type ('%s)" s)
 
2502
        | Larrow _ -> E.s (bug "typeTermOffset: Field on a function type")
 
2503
 
 
2504
let rec typeOfTsetsLval = function
 
2505
    TSVar vi, off ->
 
2506
      let ty = match vi.lv_origin with
 
2507
        | Some v -> Ctype v.vtype
 
2508
        | None -> vi.lv_type
 
2509
      in
 
2510
      typeTsetsOffset ty off
 
2511
  | TSResult,_ ->
 
2512
      begin match !currentGlobal with
 
2513
        | GFun(f,_loc) -> Ctype (getReturnType f.svar.vtype)
 
2514
        | _ -> E.s (bug "typeOfTsetsLval: Can not compute type of result")
 
2515
      end
 
2516
  | TSMem addr, off -> begin
 
2517
      match typeOfTsetsElem addr with
 
2518
        | Ctype typ ->
 
2519
            begin match unrollType typ with
 
2520
                TPtr (t, _) -> typeTsetsOffset (Ctype t) off
 
2521
              | _ -> E.s (bug "typeOfTsetsLval: Mem on a non-pointer")
 
2522
            end
 
2523
        | Linteger | Lreal ->
 
2524
            E.s (bug "typeOfTsetsLval: Mem on a logic type")
 
2525
        | Ltype (s,_) -> E.s (bug "typeOfTsetsLval: Mem on a non-C type (%s)" s)
 
2526
        | Lvar s -> E.s (bug "typeOfTsetsLval: Mem on a non-C type ('%s)" s)
 
2527
        | Larrow _ -> E.s (bug "typeOfTsetsLval: Mem on a function type")
 
2528
  end
 
2529
 
 
2530
and typeTsetsOffset basetyp =
 
2531
  let blendAttributes baseAttrs =
 
2532
    let (_, _, contageous) =
 
2533
      partitionAttributes ~default:(AttrName false) baseAttrs in
 
2534
    function
 
2535
      | Ctype typ ->
 
2536
          Ctype (typeAddAttributes contageous typ)
 
2537
      | Linteger | Lreal ->
 
2538
          E.s (bug "typeTsetsOffset: Attribute on a logic type")
 
2539
      | Ltype (s,_) ->
 
2540
          E.s (bug "typeTsetsOffset: Attribute on a non-C type (%s)" s)
 
2541
      | Lvar s ->
 
2542
          E.s (bug "typeTsetsOffset: Attribute on a non-C type ('%s)" s)
 
2543
      | Larrow _ ->
 
2544
          E.s (bug "typeTsetsOffset: Attribute on a function type")
 
2545
  in
 
2546
  function
 
2547
    TSNoOffset -> basetyp
 
2548
  | TSIndex (_, o) | TSRange(_,_,o) -> begin
 
2549
      match basetyp with
 
2550
        | Ctype typ ->
 
2551
            begin match unrollType typ with
 
2552
                TArray (t, _, baseAttrs) ->
 
2553
                  let elementType = typeTsetsOffset (Ctype t) o in
 
2554
                  blendAttributes baseAttrs elementType
 
2555
              | _ -> E.s (E.bug "typeTsetsOffset: Index on a non-array")
 
2556
            end
 
2557
         | Linteger | Lreal ->
 
2558
             E.s (bug "typeTsetsOffset: Index on a logic type")
 
2559
         | Ltype (s,_) ->
 
2560
            E.s (bug "typeTsetsOffset: Index on a non-C type (%s)" s)
 
2561
         | Lvar s ->
 
2562
            E.s (bug "typeTsetsOffset: Index on a non-C type ('%s)" s)
 
2563
         | Larrow _ ->
 
2564
             E.s (bug "typeTsetsOffset: Index on a function type")
 
2565
  end
 
2566
  | TSField (fi, o) ->
 
2567
      match basetyp with
 
2568
        | Ctype typ ->
 
2569
            begin match unrollType typ with
 
2570
                TComp (_, baseAttrs) ->
 
2571
                  let fieldType = typeTsetsOffset (Ctype fi.ftype) o in
 
2572
                  blendAttributes baseAttrs fieldType
 
2573
              | _ -> E.s (bug "typeTsetsOffset: Field on a non-compound")
 
2574
            end
 
2575
        | Linteger | Lreal ->
 
2576
            E.s (bug "typeTsetsOffset: Field on a logic type")
 
2577
        | Ltype (s,_) ->
 
2578
            E.s (bug "typeTsetsOffset: Field on a non-C type (%s)" s)
 
2579
        | Lvar s -> E.s (bug "typeTsetsOffset: Field on a non-C type ('%s)" s)
 
2580
        | Larrow _ -> E.s (bug "typeTsetsOffset: Field on a function type")
 
2581
 
 
2582
and typeOfTsetsElem = function
 
2583
    TSLval lv -> typeOfTsetsLval lv
 
2584
  | TSStartOf lv ->
 
2585
      (match typeOfTsetsLval lv with
 
2586
           Ctype t ->
 
2587
             (match unrollType t with
 
2588
                | TArray(t,_,attrs) ->
 
2589
                    Ctype (TPtr(t,attrs))
 
2590
                | _ -> E.s (bug "typeOfTsetsElem: TStartOf on non array type"))
 
2591
         | _ -> E.s (bug "typeOfTsetsElem: TStartOf on non array type"))
 
2592
  | TSAddrOf lv ->
 
2593
      (match typeOfTsetsLval lv with
 
2594
           Ctype t -> Ctype(TPtr(t,[]))
 
2595
         | _ -> E.s (bug "typeOfTsetsElem: TAddrOf on logical type"))
 
2596
  | TSConst (CInt64 _ ) -> Linteger
 
2597
  | TSConst _ -> assert false (* cannot appear in tsets *)
 
2598
  | TSAdd_index (t,_) | TSAdd_range(t,_,_) -> typeOfTsetsElem t
 
2599
  | TSCastE(typ,_) -> Ctype typ
 
2600
  | TSat(elem,_) -> typeOfTsetsElem elem
 
2601
  | TSapp(f,_,_) ->
 
2602
      begin
 
2603
        (* until now, we only have complete applications*)
 
2604
        match f.l_type with
 
2605
          | Some t -> t
 
2606
          | None -> assert false (* cannot appear in tsets *)
 
2607
      end
 
2608
 
 
2609
(**
 
2610
 **
 
2611
 ** MACHINE DEPENDENT PART
 
2612
 **
 
2613
 **)
 
2614
exception SizeOfError of string * typ
 
2615
 
 
2616
 
 
2617
(* Get the minimum aligment in bytes for a given type *)
 
2618
let rec alignOf_int = function
 
2619
  | TInt((IChar|ISChar|IUChar|IBool), _) -> 1
 
2620
  | TInt((IShort|IUShort), _) -> theMachine.theMachine.alignof_short
 
2621
  | TInt((IInt|IUInt), _) -> theMachine.theMachine.alignof_int
 
2622
  | TInt((ILong|IULong), _) -> theMachine.theMachine.alignof_long
 
2623
  | TInt((ILongLong|IULongLong), _) ->
 
2624
      theMachine.theMachine.alignof_longlong
 
2625
  | TEnum _ -> theMachine.theMachine.alignof_enum
 
2626
  | TFloat(FFloat, _) -> theMachine.theMachine.alignof_float
 
2627
  | TFloat(FDouble, _) -> theMachine.theMachine.alignof_double
 
2628
  | TFloat(FLongDouble, _) ->
 
2629
      theMachine.theMachine.alignof_longdouble
 
2630
  | TNamed (t, _) -> alignOf_int t.ttype
 
2631
  | TArray (t, _, _) -> (* Be careful for char[] of Diab-C like compilers. *)
 
2632
      begin
 
2633
        match unrollType t with
 
2634
        | TInt((IChar|ISChar|IUChar),_) ->
 
2635
            theMachine.theMachine.alignof_char_array
 
2636
        | _ -> alignOf_int t
 
2637
      end
 
2638
 
 
2639
  | TPtr _ | TBuiltin_va_list _ ->
 
2640
      theMachine.theMachine.alignof_ptr
 
2641
 
 
2642
        (* For composite types get the maximum alignment of any field inside *)
 
2643
  | TComp (c, _) ->
 
2644
      (* On GCC the zero-width fields do not contribute to the alignment. On
 
2645
       * MSVC only those zero-width that _do_ appear after other
 
2646
       * bitfields contribute to the alignment. So we drop those that
 
2647
       * do not occur after othe bitfields *)
 
2648
      (* This is not correct for Diab-C compiler. *)
 
2649
      let rec dropZeros (afterbitfield: bool) = function
 
2650
        | f :: rest when f.fbitfield = Some 0 && not afterbitfield ->
 
2651
            dropZeros afterbitfield rest
 
2652
        | f :: rest -> f :: dropZeros (f.fbitfield <> None) rest
 
2653
        | [] -> []
 
2654
      in
 
2655
      let fields = dropZeros false c.cfields in
 
2656
      List.fold_left
 
2657
        (fun sofar f ->
 
2658
          (* Bitfields with zero width do not contribute to the alignment in
 
2659
           * GCC *)
 
2660
          if not theMachine.msvcMode && f.fbitfield = Some 0 then sofar else
 
2661
          max sofar (alignOf_int f.ftype)) 1 fields
 
2662
        (* These are some error cases *)
 
2663
  | TFun _ when not theMachine.msvcMode ->
 
2664
      theMachine.theMachine.alignof_fun
 
2665
  | TFun _ as t -> raise (SizeOfError ("function", t))
 
2666
  | TVoid _ as t -> raise (SizeOfError ("void", t))
 
2667
 
 
2668
 
 
2669
let bitsSizeOfInt (ik: ikind): int =
 
2670
  match ik with
 
2671
  | IBool | IChar | ISChar | IUChar -> 8
 
2672
  | IInt | IUInt -> 8 * theMachine.theMachine.sizeof_int
 
2673
  | IShort | IUShort -> 8 * theMachine.theMachine.sizeof_short
 
2674
  | ILong | IULong -> 8 * theMachine.theMachine.sizeof_long
 
2675
  | ILongLong | IULongLong ->
 
2676
      8 * theMachine.theMachine.sizeof_longlong
 
2677
 
 
2678
let unsignedVersionOf (ik:ikind): ikind =
 
2679
  match ik with
 
2680
  | ISChar | IChar -> IUChar
 
2681
  | IShort -> IUShort
 
2682
  | IInt -> IUInt
 
2683
  | ILong -> IULong
 
2684
  | ILongLong -> IULongLong
 
2685
  | _ -> ik
 
2686
 
 
2687
(* Represents an integer as for a given kind.
 
2688
   Returns a flag saying whether the value was changed
 
2689
   during truncation (because it was too large to fit in k). *)
 
2690
let truncateInteger64 (k: ikind) (i: int64) : int64 * bool =
 
2691
  let nrBits = bitsSizeOfInt k in
 
2692
  let signed = isSigned k in
 
2693
  if nrBits = 64 then
 
2694
    i, false
 
2695
  else begin
 
2696
    let i1 = Int64.shift_left i (64 - nrBits) in
 
2697
    let i2 =
 
2698
      if signed then Int64.shift_right i1 (64 - nrBits)
 
2699
      else Int64.shift_right_logical i1 (64 - nrBits)
 
2700
    in
 
2701
    let truncated =
 
2702
      if i2 = i then false
 
2703
      else
 
2704
        (* Examine the bits that we chopped off.  If they are all zero, then
 
2705
         * any difference between i2 and i is due to a simple sign-extension.
 
2706
         *   e.g. casting the constant 0x80000000 to int makes it
 
2707
         *        0xffffffff80000000.
 
2708
         * Suppress the truncation warning in this case.      *)
 
2709
        let chopped = Int64.shift_right_logical i (64 - nrBits)
 
2710
        in chopped <> Int64.zero
 
2711
    in
 
2712
    i2, truncated
 
2713
  end
 
2714
 
 
2715
(* Construct an integer constant with possible truncation *)
 
2716
let kinteger64 (k: ikind) (i: int64) : exp =
 
2717
  let i', truncated = truncateInteger64 k i in
 
2718
  if truncated && miscState.warnTruncate then
 
2719
    ignore (warnOpt "Truncating integer %s to %s\n"
 
2720
              (Int64.format "0x%x" i) (Int64.format "0x%x" i'));
 
2721
  Const (CInt64(i', k,  None))
 
2722
 
 
2723
(* Construct an integer of a given kind. *)
 
2724
let kinteger (k: ikind) (i: int) = kinteger64 k (Int64.of_int i)
 
2725
 
 
2726
(* Convert 2 integer constants to integers with the same type, in preparation
 
2727
   for a binary operation.   See ISO C 6.3.1.8p1 *)
 
2728
let convertInts (i1:int64) (ik1:ikind) (i2:int64) (ik2:ikind)
 
2729
  : int64 * int64 * ikind =
 
2730
  if ik1 = ik2 then (* nothing to do *)
 
2731
    i1, i2, ik1
 
2732
  else begin
 
2733
    let rank : ikind -> int = function
 
2734
        (* these are just unique numbers representing the integer
 
2735
           conversion rank. *)
 
2736
      | IBool | IChar | ISChar | IUChar -> 1
 
2737
      | IShort | IUShort -> 2
 
2738
      | IInt | IUInt -> 3
 
2739
      | ILong | IULong -> 4
 
2740
      | ILongLong | IULongLong -> 5
 
2741
    in
 
2742
    let r1 = rank ik1 in
 
2743
    let r2 = rank ik2 in
 
2744
    let ik' =
 
2745
      if (isSigned ik1) = (isSigned ik2) then begin
 
2746
        (* Both signed or both unsigned. *)
 
2747
        if r1 > r2 then ik1 else ik2
 
2748
      end
 
2749
      else begin
 
2750
        let signedKind, unsignedKind, signedRank, unsignedRank =
 
2751
          if isSigned ik1 then ik1, ik2, r1, r2 else ik2, ik1, r2, r1
 
2752
        in
 
2753
        (* The rules for signed + unsigned get hairy.
 
2754
           (unsigned short + long) is converted to signed long,
 
2755
           but (unsigned int + long) is converted to unsigned long.*)
 
2756
        if unsignedRank >= signedRank then unsignedKind
 
2757
        else if (bytesSizeOfInt signedKind) > (bytesSizeOfInt unsignedKind) then
 
2758
          signedKind
 
2759
        else
 
2760
          unsignedVersionOf signedKind
 
2761
      end
 
2762
    in
 
2763
    let i1',_ = truncateInteger64 ik' i1 in
 
2764
    let i2',_ = truncateInteger64 ik' i2 in
 
2765
    i1', i2', ik'
 
2766
  end
 
2767
 
 
2768
type offsetAcc =
 
2769
    { oaFirstFree: int;        (* The first free bit *)
 
2770
      oaLastFieldStart: int;   (* Where the previous field started *)
 
2771
      oaLastFieldWidth: int;   (* The width of the previous field. Might not
 
2772
                                * be same as FirstFree - FieldStart because
 
2773
                                * of internal padding *)
 
2774
      oaPrevBitPack: (int * ikind * int) option; (* If the previous fields
 
2775
                                                   * were packed bitfields,
 
2776
                                                   * the bit where packing
 
2777
                                                   * has started, the ikind
 
2778
                                                   * of the bitfield and the
 
2779
                                                   * width of the ikind *)
 
2780
    }
 
2781
 
 
2782
 
 
2783
(* GCC version *)
 
2784
(* Does not use the sofar.oaPrevBitPack *)
 
2785
let rec offsetOfFieldAcc_GCC (fi: fieldinfo)
 
2786
                             (sofar: offsetAcc) : offsetAcc =
 
2787
  (* field type *)
 
2788
  let ftype = unrollType fi.ftype in
 
2789
  let ftypeAlign = 8 * alignOf_int ftype in
 
2790
  let ftypeBits = bitsSizeOf ftype in
 
2791
(*
 
2792
  if fi.fcomp.cname = "comp2468" ||
 
2793
     fi.fcomp.cname = "comp2469" ||
 
2794
     fi.fcomp.cname = "comp2470" ||
 
2795
     fi.fcomp.cname = "comp2471" ||
 
2796
     fi.fcomp.cname = "comp2472" ||
 
2797
     fi.fcomp.cname = "comp2473" ||
 
2798
     fi.fcomp.cname = "comp2474" ||
 
2799
     fi.fcomp.cname = "comp2475" ||
 
2800
     fi.fcomp.cname = "comp2476" ||
 
2801
     fi.fcomp.cname = "comp2477" ||
 
2802
     fi.fcomp.cname = "comp2478" then
 
2803
 
 
2804
    ignore (E.log "offsetOfFieldAcc_GCC(%s of %s:%a%a,firstFree=%d,pack=%a)\n"
 
2805
              fi.fname fi.fcomp.cname
 
2806
              d_type ftype
 
2807
              insert
 
2808
              (match fi.fbitfield with
 
2809
                None -> nil
 
2810
              | Some wdthis -> dprintf ":%d" wdthis)
 
2811
              sofar.oaFirstFree
 
2812
              insert
 
2813
              (match sofar.oaPrevBitPack with
 
2814
                None -> text "None"
 
2815
              | Some (packstart, _, wdpack) ->
 
2816
                  dprintf "Some(packstart=%d,wd=%d)"
 
2817
                    packstart wdpack));
 
2818
*)
 
2819
  match ftype, fi.fbitfield with
 
2820
    (* A width of 0 means that we must end the current packing. It seems that
 
2821
     * GCC pads only up to the alignment boundary for the type of this field.
 
2822
     * *)
 
2823
  | _, Some 0 ->
 
2824
      let firstFree      = addTrailing sofar.oaFirstFree ftypeAlign in
 
2825
      { oaFirstFree      = firstFree;
 
2826
        oaLastFieldStart = firstFree;
 
2827
        oaLastFieldWidth = 0;
 
2828
        oaPrevBitPack    = None }
 
2829
 
 
2830
    (* A bitfield cannot span more alignment boundaries of its type than the
 
2831
     * type itself *)
 
2832
  | _, Some wdthis
 
2833
      when (sofar.oaFirstFree + wdthis + ftypeAlign - 1) / ftypeAlign
 
2834
            - sofar.oaFirstFree / ftypeAlign > ftypeBits / ftypeAlign ->
 
2835
          let start = addTrailing sofar.oaFirstFree ftypeAlign in
 
2836
          { oaFirstFree      = start + wdthis;
 
2837
            oaLastFieldStart = start;
 
2838
            oaLastFieldWidth = wdthis;
 
2839
            oaPrevBitPack    = None }
 
2840
 
 
2841
   (* Try a simple method. Just put the field down *)
 
2842
  | _, Some wdthis ->
 
2843
      { oaFirstFree      = sofar.oaFirstFree + wdthis;
 
2844
        oaLastFieldStart = sofar.oaFirstFree;
 
2845
        oaLastFieldWidth = wdthis;
 
2846
        oaPrevBitPack    = None
 
2847
      }
 
2848
 
 
2849
     (* Non-bitfield *)
 
2850
  | _, None ->
 
2851
      (* Align this field *)
 
2852
      let newStart = addTrailing sofar.oaFirstFree ftypeAlign  in
 
2853
      { oaFirstFree = newStart + ftypeBits;
 
2854
        oaLastFieldStart = newStart;
 
2855
        oaLastFieldWidth = ftypeBits;
 
2856
        oaPrevBitPack = None;
 
2857
      }
 
2858
 
 
2859
(* MSVC version *)
 
2860
and offsetOfFieldAcc_MSVC (fi: fieldinfo)
 
2861
                              (sofar: offsetAcc) : offsetAcc =
 
2862
  (* field type *)
 
2863
  let ftype = unrollType fi.ftype in
 
2864
  let ftypeAlign = 8 * alignOf_int ftype in
 
2865
  let ftypeBits = bitsSizeOf ftype in
 
2866
(*
 
2867
  ignore (E.log "offsetOfFieldAcc_MSVC(%s of %s:%a%a,firstFree=%d, pack=%a)\n"
 
2868
            fi.fname fi.fcomp.cname
 
2869
            d_type ftype
 
2870
            insert
 
2871
            (match fi.fbitfield with
 
2872
              None -> nil
 
2873
            | Some wdthis -> dprintf ":%d" wdthis)
 
2874
            sofar.oaFirstFree
 
2875
            insert
 
2876
            (match sofar.oaPrevBitPack with
 
2877
              None -> text "None"
 
2878
            | Some (prevpack, _, wdpack) -> dprintf "Some(prev=%d,wd=%d)"
 
2879
                  prevpack wdpack));
 
2880
*)
 
2881
  match ftype, fi.fbitfield, sofar.oaPrevBitPack with
 
2882
    (* Ignore zero-width bitfields that come after non-bitfields *)
 
2883
  | TInt (_ikthis, _), Some 0, None ->
 
2884
      let firstFree      = sofar.oaFirstFree in
 
2885
      { oaFirstFree      = firstFree;
 
2886
        oaLastFieldStart = firstFree;
 
2887
        oaLastFieldWidth = 0;
 
2888
        oaPrevBitPack    = None }
 
2889
 
 
2890
    (* If we are in a bitpack and we see a bitfield for a type with the
 
2891
     * different width than the pack, then we finish the pack and retry *)
 
2892
  | _, Some _, Some (packstart, _, wdpack) when wdpack != ftypeBits ->
 
2893
      let firstFree =
 
2894
        if sofar.oaFirstFree = packstart then packstart else
 
2895
        packstart + wdpack
 
2896
      in
 
2897
      offsetOfFieldAcc_MSVC fi
 
2898
        { oaFirstFree      = addTrailing firstFree ftypeAlign;
 
2899
          oaLastFieldStart = sofar.oaLastFieldStart;
 
2900
          oaLastFieldWidth = sofar.oaLastFieldWidth;
 
2901
          oaPrevBitPack    = None }
 
2902
 
 
2903
    (* A width of 0 means that we must end the current packing. *)
 
2904
  | TInt (ikthis, _), Some 0, Some (packstart, _, wdpack) ->
 
2905
      let firstFree =
 
2906
        if sofar.oaFirstFree = packstart then packstart else
 
2907
        packstart + wdpack
 
2908
      in
 
2909
      let firstFree      = addTrailing firstFree ftypeAlign in
 
2910
      { oaFirstFree      = firstFree;
 
2911
        oaLastFieldStart = firstFree;
 
2912
        oaLastFieldWidth = 0;
 
2913
        oaPrevBitPack    = Some (firstFree, ikthis, ftypeBits) }
 
2914
 
 
2915
   (* Check for a bitfield that fits in the current pack after some other
 
2916
    * bitfields *)
 
2917
  | TInt(_ikthis, _), Some wdthis, Some (packstart, _ikprev, wdpack)
 
2918
      when  packstart + wdpack >= sofar.oaFirstFree + wdthis ->
 
2919
              { oaFirstFree = sofar.oaFirstFree + wdthis;
 
2920
                oaLastFieldStart = sofar.oaFirstFree;
 
2921
                oaLastFieldWidth = wdthis;
 
2922
                oaPrevBitPack = sofar.oaPrevBitPack
 
2923
              }
 
2924
 
 
2925
 
 
2926
  | _, _, Some (packstart, _, wdpack) -> (* Finish up the bitfield pack and
 
2927
                                          * restart. *)
 
2928
      let firstFree =
 
2929
        if sofar.oaFirstFree = packstart then packstart else
 
2930
        packstart + wdpack
 
2931
      in
 
2932
      offsetOfFieldAcc_MSVC fi
 
2933
        { oaFirstFree      = addTrailing firstFree ftypeAlign;
 
2934
          oaLastFieldStart = sofar.oaLastFieldStart;
 
2935
          oaLastFieldWidth = sofar.oaLastFieldWidth;
 
2936
          oaPrevBitPack    = None }
 
2937
 
 
2938
        (* No active bitfield pack. But we are seeing a bitfield. *)
 
2939
  | TInt(ikthis, _), Some wdthis, None ->
 
2940
      let firstFree     = addTrailing sofar.oaFirstFree ftypeAlign in
 
2941
      { oaFirstFree     = firstFree + wdthis;
 
2942
        oaLastFieldStart = firstFree;
 
2943
        oaLastFieldWidth = wdthis;
 
2944
        oaPrevBitPack = Some (firstFree, ikthis, ftypeBits); }
 
2945
 
 
2946
     (* No active bitfield pack. Non-bitfield *)
 
2947
  | _, None, None ->
 
2948
      (* Align this field *)
 
2949
      let firstFree = addTrailing sofar.oaFirstFree ftypeAlign  in
 
2950
      { oaFirstFree = firstFree + ftypeBits;
 
2951
        oaLastFieldStart = firstFree;
 
2952
        oaLastFieldWidth = ftypeBits;
 
2953
        oaPrevBitPack = None;
 
2954
      }
 
2955
 
 
2956
  | _, Some _, None -> E.s (E.bug "offsetAcc")
 
2957
 
 
2958
 
 
2959
and offsetOfFieldAcc ~(fi: fieldinfo)
 
2960
                     ~(sofar: offsetAcc) : offsetAcc =
 
2961
  if theMachine.msvcMode then offsetOfFieldAcc_MSVC fi sofar
 
2962
  else offsetOfFieldAcc_GCC fi sofar
 
2963
 
 
2964
(* The size of a type, in bits. If struct or array then trailing padding is
 
2965
 * added *)
 
2966
and bitsSizeOf t =
 
2967
  if not (TheMachine.is_computed ()) then
 
2968
    E.s (E.error "You did not call Cil.initCIL before using the CIL library");
 
2969
  match t with
 
2970
  | TInt (ik,_) -> 8 * (bytesSizeOfInt ik)
 
2971
  | TFloat(FDouble, _) -> 8 * theMachine.theMachine.sizeof_double
 
2972
  | TFloat(FLongDouble, _) ->
 
2973
      8 * theMachine.theMachine.sizeof_longdouble
 
2974
  | TFloat _ -> 8 * theMachine.theMachine.sizeof_float
 
2975
  | TEnum _ -> 8 * theMachine.theMachine.sizeof_enum
 
2976
  | TPtr _ -> 8 * theMachine.theMachine.sizeof_ptr
 
2977
  | TBuiltin_va_list _ -> 8 * theMachine.theMachine.sizeof_ptr
 
2978
  | TNamed (t, _) -> bitsSizeOf t.ttype
 
2979
  | TComp (comp, _) when comp.cfields == [] -> begin
 
2980
      (* Empty structs are allowed in msvc mode *)
 
2981
      if not comp.cdefined && not theMachine.msvcMode then
 
2982
        raise
 
2983
          (SizeOfError
 
2984
             (Format.sprintf
 
2985
                "abstract type: empty struct exist only with MSVC (comp %s)"
 
2986
                (compFullName comp),
 
2987
              t)) (*abstract type*)
 
2988
      else
 
2989
        0
 
2990
  end
 
2991
 
 
2992
  | TComp (comp, _) when comp.cstruct -> (* Struct *)
 
2993
        (* Go and get the last offset *)
 
2994
      let startAcc =
 
2995
        { oaFirstFree = 0;
 
2996
          oaLastFieldStart = 0;
 
2997
          oaLastFieldWidth = 0;
 
2998
          oaPrevBitPack = None;
 
2999
        } in
 
3000
      let lastoff =
 
3001
        List.fold_left (fun acc fi -> offsetOfFieldAcc ~fi ~sofar:acc)
 
3002
          startAcc comp.cfields
 
3003
      in
 
3004
      if theMachine.msvcMode && lastoff.oaFirstFree = 0 && comp.cfields <> []
 
3005
      then
 
3006
          (* On MSVC if we have just a zero-width bitfields then the length
 
3007
           * is 32 and is not padded  *)
 
3008
        32
 
3009
      else
 
3010
        addTrailing lastoff.oaFirstFree (8 * alignOf_int t)
 
3011
 
 
3012
  | TComp (comp, _) -> (* when not comp.cstruct *)
 
3013
        (* Get the maximum of all fields *)
 
3014
      let startAcc =
 
3015
        { oaFirstFree = 0;
 
3016
          oaLastFieldStart = 0;
 
3017
          oaLastFieldWidth = 0;
 
3018
          oaPrevBitPack = None;
 
3019
        } in
 
3020
      let max =
 
3021
        List.fold_left (fun acc fi ->
 
3022
          let lastoff = offsetOfFieldAcc ~fi ~sofar:startAcc in
 
3023
          if lastoff.oaFirstFree > acc then
 
3024
            lastoff.oaFirstFree else acc) 0 comp.cfields in
 
3025
        (* Add trailing by simulating adding an extra field *)
 
3026
      addTrailing max (8 * alignOf_int t)
 
3027
 
 
3028
   | TArray(bt, Some len, _) -> begin
 
3029
      match constFold true len with
 
3030
        Const(CInt64(l,_,_)) ->
 
3031
          let sz = Int64.mul (Int64.of_int (bitsSizeOf bt)) l in
 
3032
          let sz' = Int64.to_int sz in
 
3033
          (* Check for overflow.
 
3034
             There are other places in these cil.ml that overflow can occur,
 
3035
             but this multiplication is the most likely to be a problem. *)
 
3036
          if (Int64.of_int sz') <> sz then
 
3037
            raise (SizeOfError ("Array is so long that its size can't be "
 
3038
                                  ^"represented with an OCaml int.", t))
 
3039
          else
 
3040
            begin
 
3041
              sz' (*WAS: addTrailing sz' (8 * alignOf_int t)*)
 
3042
            end
 
3043
      | _ -> raise (SizeOfError ("array non-constant length", t))
 
3044
     end
 
3045
 
 
3046
  | TVoid _ -> 8 * theMachine.theMachine.sizeof_void
 
3047
  | TFun _ when not theMachine.msvcMode ->
 
3048
      (* On GCC the size of a function is defined *)
 
3049
      8 * theMachine.theMachine.sizeof_fun
 
3050
 
 
3051
  | TArray (_, None, _) -> (* it seems that on GCC the size of such an
 
3052
                            * array is 0 *)
 
3053
      0
 
3054
 
 
3055
  | TFun _ -> raise (SizeOfError ("function", t))
 
3056
 
 
3057
 
 
3058
and addTrailing nrbits roundto =
 
3059
    (nrbits + roundto - 1) land (lnot (roundto - 1))
 
3060
 
 
3061
and sizeOf_int t = (bitsSizeOf t) lsr 3
 
3062
 
 
3063
and sizeOf t =
 
3064
  try
 
3065
    integer ((bitsSizeOf t) lsr 3)
 
3066
  with SizeOfError _ -> SizeOf(t)
 
3067
 
 
3068
 
 
3069
and bitsOffset (baset: typ) (off: offset) : int * int =
 
3070
  let rec loopOff (baset: typ) (width: int) (start: int) = function
 
3071
      NoOffset -> start, width
 
3072
    | Index(e, off) -> begin
 
3073
        let ei =
 
3074
          match isInteger e with
 
3075
            Some i64 -> Int64.to_int i64
 
3076
          | None -> raise (SizeOfError ("index not constant", baset))
 
3077
        in
 
3078
        let bt =
 
3079
          match unrollType baset with
 
3080
            TArray(bt, _, _) -> bt
 
3081
          | _ -> E.s (E.bug "bitsOffset: Index on a non-array")
 
3082
        in
 
3083
        let bitsbt = bitsSizeOf bt in
 
3084
        loopOff bt bitsbt (start + ei * bitsbt) off
 
3085
    end
 
3086
    | Field(f, off) when not f.fcomp.cstruct ->
 
3087
        (* All union fields start at offset 0 *)
 
3088
        loopOff f.ftype (bitsSizeOf f.ftype) start off
 
3089
 
 
3090
    | Field(f, off) ->
 
3091
        (* Construct a list of fields preceeding and including this one *)
 
3092
        let prevflds =
 
3093
          let rec loop = function
 
3094
              [] -> E.s (E.bug "bitsOffset: Cannot find field %s in %s\n"
 
3095
                           f.fname f.fcomp.cname)
 
3096
            | fi' :: _ when fi' == f -> [fi']
 
3097
            | fi' :: rest -> fi' :: loop rest
 
3098
          in
 
3099
          loop f.fcomp.cfields
 
3100
        in
 
3101
        let lastoff =
 
3102
          List.fold_left (fun acc fi' -> offsetOfFieldAcc ~fi:fi' ~sofar:acc)
 
3103
            { oaFirstFree      = 0; (* Start at 0 because each struct is done
 
3104
                                     * separately *)
 
3105
              oaLastFieldStart = 0;
 
3106
              oaLastFieldWidth = 0;
 
3107
              oaPrevBitPack    = None } prevflds
 
3108
        in
 
3109
        (* ignore (E.log "Field %s of %s: start=%d, lastFieldStart=%d\n"
 
3110
                  f.fname f.fcomp.cname start lastoff.oaLastFieldStart); *)
 
3111
        loopOff f.ftype lastoff.oaLastFieldWidth
 
3112
               (start + lastoff.oaLastFieldStart) off
 
3113
  in
 
3114
  loopOff baset (bitsSizeOf baset) 0 off
 
3115
 
 
3116
 
 
3117
 
 
3118
 
 
3119
(** Do constant folding on an expression. If the first argument is true then
 
3120
    will also compute compiler-dependent expressions such as sizeof.
 
3121
    See also {!Cil.constFoldVisitor}, which will run constFold on all
 
3122
    expressions in a given AST node.*)
 
3123
and constFold (machdep: bool) (e: exp) : exp =
 
3124
  match e with
 
3125
    BinOp(bop, e1, e2, tres) -> constFoldBinOp machdep bop e1 e2 tres
 
3126
  | UnOp(unop, e1, tres) -> begin
 
3127
      try
 
3128
        let tk =
 
3129
          match unrollType tres with
 
3130
            TInt(ik, _) -> ik
 
3131
          | TEnum _ -> IInt
 
3132
          | _ -> raise Not_found (* probably a float *)
 
3133
        in
 
3134
        match constFold machdep e1 with
 
3135
          Const(CInt64(i,_ik,_)) -> begin
 
3136
            match unop with
 
3137
              Neg -> kinteger64 tk (Int64.neg i)
 
3138
            | BNot -> kinteger64 tk (Int64.lognot i)
 
3139
            | LNot -> if i = Int64.zero then one else zero
 
3140
            end
 
3141
        | e1c -> UnOp(unop, e1c, tres)
 
3142
      with Not_found -> e
 
3143
  end
 
3144
        (* Characters are integers *)
 
3145
  | Const(CChr c) -> Const(charConstToInt c)
 
3146
  | Const(CEnum {eival = v}) -> constFold machdep v
 
3147
  | SizeOf t when machdep -> begin
 
3148
      try
 
3149
        let bs = bitsSizeOf t in
 
3150
        kinteger theMachine.kindOfSizeOf (bs / 8)
 
3151
      with SizeOfError _ -> e
 
3152
  end
 
3153
  | SizeOfE e when machdep -> constFold machdep (SizeOf (typeOf e))
 
3154
  | SizeOfStr s when machdep ->
 
3155
      kinteger theMachine.kindOfSizeOf (1 + String.length s)
 
3156
  | AlignOf t when machdep -> kinteger theMachine.kindOfSizeOf (alignOf_int t)
 
3157
  | AlignOfE e when machdep -> begin
 
3158
      (* The alignment of an expression is not always the alignment of its
 
3159
       * type. I know that for strings this is not true *)
 
3160
      match e with
 
3161
        Const (CStr _) when not theMachine.msvcMode ->
 
3162
          kinteger theMachine.kindOfSizeOf theMachine.theMachine.alignof_str
 
3163
            (* For an array, it is the alignment of the array ! *)
 
3164
      | _ -> constFold machdep (AlignOf (typeOf e))
 
3165
  end
 
3166
 
 
3167
  | CastE(it,
 
3168
          AddrOf (Mem (CastE(TPtr(bt, _), z)), off))
 
3169
    when machdep && isZero z -> begin
 
3170
      try
 
3171
        let start, _width = bitsOffset bt off in
 
3172
        if start mod 8 <> 0 then
 
3173
          E.s (error "Using offset of bitfield\n");
 
3174
        constFold machdep (CastE(it, (integer (start / 8))))
 
3175
      with SizeOfError _ -> e
 
3176
  end
 
3177
 
 
3178
 
 
3179
  | CastE (t, e) -> begin
 
3180
      match constFold machdep e, unrollType t with
 
3181
        (* Might truncate silently *)
 
3182
        Const(CInt64(i,_k,_)), TInt(nk,a)
 
3183
          (* It's okay to drop a cast to const.
 
3184
             If the cast has any other attributes, leave the cast alone. *)
 
3185
          when (dropAttributes ["const"] a) = [] ->
 
3186
          let i', _ = truncateInteger64 nk i in
 
3187
          Const(CInt64(i', nk, None))
 
3188
      | e', _ -> CastE (t, e')
 
3189
  end
 
3190
  | Lval lv -> Lval (constFoldLval machdep lv)
 
3191
  | AddrOf lv -> AddrOf (constFoldLval machdep lv)
 
3192
  | StartOf lv -> StartOf (constFoldLval machdep lv)
 
3193
  | _ -> e
 
3194
 
 
3195
and constFoldLval machdep (host,offset) =
 
3196
  let newhost =
 
3197
    match host with
 
3198
    | Mem e -> Mem (constFold machdep e)
 
3199
    | Var _ -> host
 
3200
  in
 
3201
  let rec constFoldOffset machdep = function
 
3202
    | NoOffset -> NoOffset
 
3203
    | Field (fi,offset) -> Field (fi, constFoldOffset machdep offset)
 
3204
    | Index (exp,offset) -> Index (constFold machdep exp,
 
3205
                                   constFoldOffset machdep offset)
 
3206
  in
 
3207
  (newhost, constFoldOffset machdep offset)
 
3208
 
 
3209
and constFoldBinOp (machdep: bool) bop e1 e2 tres =
 
3210
  let e1' = constFold machdep e1 in
 
3211
  let e2' = constFold machdep e2 in
 
3212
  if isIntegralType tres then begin
 
3213
    let newe =
 
3214
      let rec mkInt = function
 
3215
          Const(CChr c) -> Const(charConstToInt c)
 
3216
        | Const(CEnum {eival = v}) -> mkInt v
 
3217
        | CastE(TInt (ik, ta), e) -> begin
 
3218
            match mkInt e with
 
3219
              Const(CInt64(i, _, _)) ->
 
3220
                let i', _ = truncateInteger64 ik i in
 
3221
                Const(CInt64(i', ik, None))
 
3222
 
 
3223
            | e' -> CastE(TInt(ik, ta), e')
 
3224
        end
 
3225
        | e -> e
 
3226
      in
 
3227
      let tk =
 
3228
        match unrollType tres with
 
3229
          TInt(ik, _) -> ik
 
3230
        | TEnum _ -> IInt
 
3231
        | _ -> E.s (bug "constFoldBinOp")
 
3232
      in
 
3233
      (* See if the result is unsigned *)
 
3234
      let isunsigned typ = not (isSigned typ) in
 
3235
      let ge (unsigned: bool) (i1: int64) (i2: int64) : bool =
 
3236
        if unsigned then
 
3237
          let l1 = Int64.shift_right_logical i1 1 in
 
3238
          let l2 = Int64.shift_right_logical i2 1 in (* Both positive now *)
 
3239
          (l1 > l2) || (l1 = l2 &&
 
3240
                        Int64.logand i1 Int64.one >= Int64.logand i2 Int64.one)
 
3241
        else i1 >= i2
 
3242
      in
 
3243
      let shiftInBounds i2 =
 
3244
        (* We only try to fold shifts if the second arg is positive and
 
3245
           less than the size of the type of the first argument.
 
3246
           Otherwise, the semantics are processor-dependent, so let the compiler sort it out. *)
 
3247
            (* We only try to fold shifts if the second arg is positive and
 
3248
            less than the size of the type of the first argument.
 
3249
            Otherwise, the semantics are processor-dependent, so let the
 
3250
            compiler sort it out. *)
 
3251
        if machdep then
 
3252
          try
 
3253
            i2 >= Int64.zero && i2 < (Int64.of_int (bitsSizeOf (typeOf e1')))
 
3254
          with SizeOfError _ -> false
 
3255
        else false
 
3256
      in
 
3257
      (* Assume that the necessary promotions have been done *)
 
3258
      match bop, mkInt e1', mkInt e2' with
 
3259
      | PlusA, Const(CInt64(z,_,_)), e2'' when z = Int64.zero -> e2''
 
3260
      | PlusA, e1'', Const(CInt64(z,_,_)) when z = Int64.zero -> e1''
 
3261
      | PlusPI, e1'', Const(CInt64(z,_,_)) when z = Int64.zero -> e1''
 
3262
      | IndexPI, e1'', Const(CInt64(z,_,_)) when z = Int64.zero -> e1''
 
3263
      | MinusPI, e1'', Const(CInt64(z,_,_)) when z = Int64.zero -> e1''
 
3264
      | PlusA, Const(CInt64(i1,ik1,_)),Const(CInt64(i2,ik2,_)) when ik1 = ik2 ->
 
3265
          kinteger64 tk (Int64.add i1 i2)
 
3266
      | MinusA, Const(CInt64(i1,ik1,_)),Const(CInt64(i2,ik2,_)) when ik1 = ik2 ->
 
3267
          kinteger64 tk (Int64.sub i1 i2)
 
3268
      | Mult, Const(CInt64(i1,ik1,_)), Const(CInt64(i2,ik2,_)) when ik1 = ik2 ->
 
3269
          kinteger64 tk (Int64.mul i1 i2)
 
3270
      | Mult, Const(CInt64(0L,_,_)), _ -> zero
 
3271
      | Mult, Const(CInt64(1L,_,_)), e2'' -> e2''
 
3272
      | Mult, _,    Const(CInt64(0L,_,_)) -> zero
 
3273
      | Mult, e1'', Const(CInt64(1L,_,_)) -> e1''
 
3274
      | Div, Const(CInt64(i1,ik1,_)),Const(CInt64(i2,ik2,_)) when ik1 = ik2 -> begin
 
3275
          try kinteger64 tk (Int64.div i1 i2)
 
3276
          with Division_by_zero -> BinOp(bop, e1', e2', tres)
 
3277
      end
 
3278
      | Div, Const(CInt64(i1,ik1,_)),Const(CInt64(i2,ik2,_))
 
3279
          when bytesSizeOfInt ik1 = bytesSizeOfInt ik2 -> begin
 
3280
          try kinteger64 tk (Int64.div i1 i2)
 
3281
          with Division_by_zero -> BinOp(bop, e1', e2', tres)
 
3282
        end
 
3283
      | Div, e1'', Const(CInt64(1L,_,_)) -> e1''
 
3284
 
 
3285
      | Mod, Const(CInt64(i1,ik1,_)),Const(CInt64(i2,ik2,_)) when ik1 = ik2 -> begin
 
3286
          try kinteger64 tk (Int64.rem i1 i2)
 
3287
          with Division_by_zero -> BinOp(bop, e1', e2', tres)
 
3288
      end
 
3289
      | BAnd, Const(CInt64(i1,ik1,_)),Const(CInt64(i2,ik2,_)) when ik1 = ik2 ->
 
3290
          kinteger64 tk (Int64.logand i1 i2)
 
3291
      | BAnd, Const(CInt64(0L,_,_)), _ -> zero
 
3292
      | BAnd, _, Const(CInt64(0L,_,_)) -> zero
 
3293
      | BOr, Const(CInt64(i1,ik1,_)),Const(CInt64(i2,ik2,_)) when ik1 = ik2 ->
 
3294
          kinteger64 tk (Int64.logor i1 i2)
 
3295
      | BOr, _, _ when isZero e1' -> e2'
 
3296
      | BOr, _, _ when isZero e2' -> e1'
 
3297
      | BXor, Const(CInt64(i1,ik1,_)),Const(CInt64(i2,ik2,_)) when ik1 = ik2 ->
 
3298
          kinteger64 tk (Int64.logxor i1 i2)
 
3299
 
 
3300
      | Shiftlt, Const(CInt64(i1,_ik1,_)),Const(CInt64(i2,_,_)) when shiftInBounds i2 ->
 
3301
          kinteger64 tk (Int64.shift_left i1 (Int64.to_int i2))
 
3302
      | Shiftlt, Const(CInt64(0L,_,_)), _ -> zero
 
3303
      | Shiftlt, e1'', Const(CInt64(0L,_,_)) -> e1''
 
3304
 
 
3305
      | Shiftrt, Const(CInt64(i1,ik1,_)),Const(CInt64(i2,_,_)) when shiftInBounds i2 ->
 
3306
          if isunsigned ik1 then
 
3307
            kinteger64 tk (Int64.shift_right_logical i1 (Int64.to_int i2))
 
3308
          else
 
3309
            kinteger64 tk (Int64.shift_right i1 (Int64.to_int i2))
 
3310
      | Shiftrt, Const(CInt64(0L,_,_)), _ -> zero
 
3311
      | Shiftrt, e1'', Const(CInt64(0L,_,_)) -> e1''
 
3312
 
 
3313
      | Eq, Const(CInt64(i1,ik1,_)),Const(CInt64(i2,ik2,_)) ->
 
3314
          let i1', i2', _ = convertInts i1 ik1 i2 ik2 in
 
3315
          if i1' = i2' then one else zero
 
3316
      | Ne, Const(CInt64(i1,ik1,_)),Const(CInt64(i2,ik2,_)) ->
 
3317
          let i1', i2', _ = convertInts i1 ik1 i2 ik2 in
 
3318
          if i1' <> i2' then one else zero
 
3319
      | Le, Const(CInt64(i1,ik1,_)),Const(CInt64(i2,ik2,_)) ->
 
3320
          let i1', i2', ik' = convertInts i1 ik1 i2 ik2 in
 
3321
          if ge (isunsigned ik') i2' i1' then one else zero
 
3322
 
 
3323
      | Ge, Const(CInt64(i1,ik1,_)),Const(CInt64(i2,ik2,_)) ->
 
3324
          let i1', i2', ik' = convertInts i1 ik1 i2 ik2 in
 
3325
          if ge (isunsigned ik') i1' i2' then one else zero
 
3326
 
 
3327
      | Lt, Const(CInt64(i1,ik1,_)),Const(CInt64(i2,ik2,_)) ->
 
3328
          let i1', i2', ik' = convertInts i1 ik1 i2 ik2 in
 
3329
          if i1' <> i2' && ge (isunsigned ik') i2' i1' then one else zero
 
3330
 
 
3331
      | Gt, Const(CInt64(i1,ik1,_)),Const(CInt64(i2,ik2,_)) ->
 
3332
          let i1', i2', ik' = convertInts i1 ik1 i2 ik2 in
 
3333
          if i1 <> i2 && ge (isunsigned ik') i1' i2' then one else zero
 
3334
 
 
3335
      (* We rely on the fact that LAnd/LOr appear in global initializers
 
3336
         and should not have side effects. *)
 
3337
      | LAnd, _, _ when isZero e1' || isZero e2' -> zero
 
3338
      | LAnd, _, _ when isInteger e1' <> None -> e2'  (* e1' is TRUE *)
 
3339
      | LAnd, _, _ when isInteger e2' <> None -> e1'  (* e2' is TRUE *)
 
3340
      | LOr, _, _ when isZero e1' -> e2'
 
3341
      | LOr, _, _ when isZero e2' -> e1'
 
3342
      | LOr, _, _ when isInteger e1' <> None || isInteger e2' <> None ->
 
3343
          (* One of e1' or e2' is a nonzero constant *)
 
3344
          one
 
3345
      | _ -> BinOp(bop, e1', e2', tres)
 
3346
    in
 
3347
    if debugConstFold then
 
3348
      ignore (log "Folded %a to %a\n"
 
3349
                (!pd_exp) (BinOp(bop, e1', e2', tres)) (!pd_exp) newe);
 
3350
    newe
 
3351
  end else
 
3352
    BinOp(bop, e1', e2', tres)
 
3353
 
 
3354
(* CEA: moved from cabs2cil.ml. See cil.mli for infos *)
 
3355
(* Weimer
 
3356
 * multi-character character constants
 
3357
 * In MSCV, this code works:
 
3358
 *
 
3359
 * long l1 = 'abcd';  // note single quotes
 
3360
 * char * s = "dcba";
 
3361
 * long * lptr = ( long * )s;
 
3362
 * long l2 = *lptr;
 
3363
 * assert(l1 == l2);
 
3364
 *
 
3365
 * We need to change a multi-character character literal into the
 
3366
 * appropriate integer constant. However, the plot sickens: we
 
3367
 * must also be able to handle things like 'ab\nd' (value = * "d\nba")
 
3368
 * and 'abc' (vale = *"cba").
 
3369
 *
 
3370
 * First we convert 'AB\nD' into the list [ 65 ; 66 ; 10 ; 68 ], then we
 
3371
 * multiply and add to get the desired value.
 
3372
 *)
 
3373
 
 
3374
(* Given a character constant (like 'a' or 'abc') as a list of 64-bit
 
3375
 * values, turn it into a CIL constant.  Multi-character constants are
 
3376
 * treated as multi-digit numbers with radix given by the bit width of
 
3377
 * the specified type (either char or wchar_t). *)
 
3378
let reduce_multichar typ : int64 list -> int64 =
 
3379
  let radix = bitsSizeOf typ in
 
3380
  List.fold_left
 
3381
    (fun acc -> Int64.add (Int64.shift_left acc radix))
 
3382
    Int64.zero
 
3383
 
 
3384
let interpret_character_constant char_list =
 
3385
  let value = reduce_multichar charType char_list in
 
3386
  if value < (Int64.of_int 256) then
 
3387
    (* ISO C 6.4.4.4.10: single-character constants have type int *)
 
3388
    (CChr(Char.chr (Int64.to_int value))), intType
 
3389
  else begin
 
3390
    let orig_rep = None (* Some("'" ^ (String.escaped str) ^ "'") *) in
 
3391
    if value <= (Int64.of_int32 Int32.max_int) then
 
3392
      (CInt64(value,IULong,orig_rep)),(TInt(IULong,[]))
 
3393
    else
 
3394
      (CInt64(value,IULongLong,orig_rep)),(TInt(IULongLong,[]))
 
3395
  end
 
3396
 
 
3397
(*/CEA*)
 
3398
 
 
3399
 
 
3400
let d_unop fmt u =
 
3401
  fprintf fmt "%s"
 
3402
    (match u with
 
3403
       Neg -> "-"
 
3404
     | BNot -> "~"
 
3405
     | LNot -> "!")
 
3406
 
 
3407
let d_binop fmt b =
 
3408
  fprintf fmt "%s"
 
3409
  (match b with
 
3410
     PlusA | PlusPI | IndexPI -> "+"
 
3411
   | MinusA | MinusPP | MinusPI -> "-"
 
3412
   | Mult -> "*"
 
3413
   | Div -> "/"
 
3414
   | Mod -> "%"
 
3415
   | Shiftlt -> "<<"
 
3416
   | Shiftrt -> ">>"
 
3417
   | Lt -> "<"
 
3418
   | Gt -> ">"
 
3419
   | Le -> "<="
 
3420
   | Ge -> ">="
 
3421
   | Eq -> "=="
 
3422
   | Ne -> "!="
 
3423
   | BAnd -> "&"
 
3424
   | BXor -> "^"
 
3425
   | BOr -> "|"
 
3426
   | LAnd -> "&&"
 
3427
   | LOr -> "||")
 
3428
 
 
3429
let d_term_binop fmt b =
 
3430
  fprintf fmt "%s"
 
3431
  (match b with
 
3432
     PlusA | PlusPI | IndexPI -> "+"
 
3433
   | MinusA | MinusPP | MinusPI -> "-"
 
3434
   | Mult -> "*"
 
3435
   | Div -> "/"
 
3436
   | Mod -> "%"
 
3437
   | Shiftlt -> "<<"
 
3438
   | Shiftrt -> ">>"
 
3439
   | Lt -> "<"
 
3440
   | Gt -> ">"
 
3441
   | Le ->  if !print_utf8 then Utf8_logic.le else "<="
 
3442
   | Ge -> if !print_utf8 then Utf8_logic.ge else ">="
 
3443
   | Eq -> if !print_utf8 then Utf8_logic.eq else "=="
 
3444
   | Ne -> if !print_utf8 then Utf8_logic.neq else "!="
 
3445
   | BAnd -> "&"
 
3446
   | BXor -> "^"
 
3447
   | BOr -> "|"
 
3448
   | LAnd -> if !print_utf8 then Utf8_logic.conj else "&&"
 
3449
   | LOr -> if !print_utf8 then Utf8_logic.disj else "||")
 
3450
 
 
3451
let d_relation fmt b =
 
3452
  fprintf fmt "%s"
 
3453
    (match b with
 
3454
     | Rlt -> "<"
 
3455
     | Rgt -> ">"
 
3456
     | Rle -> if !print_utf8 then Utf8_logic.le else "<="
 
3457
     | Rge -> if !print_utf8 then Utf8_logic.ge else ">="
 
3458
     | Req -> if !print_utf8 then Utf8_logic.eq else "=="
 
3459
     | Rneq -> if !print_utf8 then Utf8_logic.neq else "!=")
 
3460
 
 
3461
let invalidStmt = mkStmt (Instr (Skip locUnknown))
 
3462
 
 
3463
module BuiltinFunctions =
 
3464
  Computation.Hashtbl
 
3465
    (struct type t = string let equal = (=) let hash = Hashtbl.hash end)
 
3466
    (Project.Datatype.Imperative
 
3467
       (struct
 
3468
          type t = typ * typ list * bool
 
3469
          let copy _ = assert false (* TODO *)
 
3470
          let name = "builtinFunctions"
 
3471
        end))
 
3472
    (struct
 
3473
       let name = "BuiltinFunctions"
 
3474
       let dependencies = [ TheMachine.self ]
 
3475
       let size = 49
 
3476
     end)
 
3477
 
 
3478
(* Initialize the builtin functions after the machine has been initialized. *)
 
3479
let initGccBuiltins () : unit =
 
3480
  if not (TheMachine.is_computed ()) then
 
3481
    E.s (bug "Call initCIL before initGccBuiltins");
 
3482
  if BuiltinFunctions.length () <> 0 then
 
3483
    E.s (bug "builtins already initialized.");
 
3484
  (* See if we have builtin_va_list *)
 
3485
  let hasbva = Machdep.state.Machdep.gccHas__builtin_va_list in
 
3486
  let ulongLongType = TInt(IULongLong, []) in
 
3487
  let floatType = TFloat(FFloat, []) in
 
3488
  let longDoubleType = TFloat (FLongDouble, []) in
 
3489
  let voidConstPtrType = TPtr(TVoid [Attr ("const", [])], []) in
 
3490
  let sizeType = theMachine.upointType in
 
3491
 
 
3492
  BuiltinFunctions.add "__builtin___fprintf_chk" (intType, [ voidPtrType; intType; charConstPtrType ], true) (* first argument is really FILE*, not void*, but we don't want to build in the definition for FILE *);
 
3493
  BuiltinFunctions.add "__builtin___memcpy_chk" (voidPtrType, [ voidPtrType; voidConstPtrType; sizeType; sizeType ], false);
 
3494
  BuiltinFunctions.add "__builtin___memmove_chk" (voidPtrType, [ voidPtrType; voidConstPtrType; sizeType; sizeType ], false);
 
3495
  BuiltinFunctions.add "__builtin___mempcpy_chk" (voidPtrType, [ voidPtrType; voidConstPtrType; sizeType; sizeType ], false);
 
3496
  BuiltinFunctions.add "__builtin___memset_chk" (voidPtrType, [ voidPtrType; intType; sizeType; sizeType ], false);
 
3497
  BuiltinFunctions.add "__builtin___printf_chk" (intType, [ intType; charConstPtrType ], true);
 
3498
  BuiltinFunctions.add "__builtin___snprintf_chk" (intType, [ charPtrType; sizeType; intType; sizeType; charConstPtrType ], true);
 
3499
  BuiltinFunctions.add "__builtin___sprintf_chk" (intType, [ charPtrType; intType; sizeType; charConstPtrType ], true);
 
3500
  BuiltinFunctions.add "__builtin___stpcpy_chk" (charPtrType, [ charPtrType; charConstPtrType; sizeType ], false);
 
3501
  BuiltinFunctions.add "__builtin___strcat_chk" (charPtrType, [ charPtrType; charConstPtrType; sizeType ], false);
 
3502
  BuiltinFunctions.add "__builtin___strcpy_chk" (charPtrType, [ charPtrType; charConstPtrType; sizeType ], false);
 
3503
  BuiltinFunctions.add "__builtin___strncat_chk" (charPtrType, [ charPtrType; charConstPtrType; sizeType; sizeType ], false);
 
3504
  BuiltinFunctions.add "__builtin___strncpy_chk" (charPtrType, [ charPtrType; charConstPtrType; sizeType; sizeType ], false);
 
3505
  BuiltinFunctions.add "__builtin___vfprintf_chk" (intType, [ voidPtrType; intType; charConstPtrType; TBuiltin_va_list [] ], false) (* first argument is really FILE*, not void*, but we don't want to build in the definition for FILE *);
 
3506
  BuiltinFunctions.add "__builtin___vprintf_chk" (intType, [ intType; charConstPtrType; TBuiltin_va_list [] ], false);
 
3507
  BuiltinFunctions.add "__builtin___vsnprintf_chk" (intType, [ charPtrType; sizeType; intType; sizeType; charConstPtrType; TBuiltin_va_list [] ], false);
 
3508
  BuiltinFunctions.add "__builtin___vsprintf_chk" (intType, [ charPtrType; intType; sizeType; charConstPtrType; TBuiltin_va_list [] ], false);
 
3509
 
 
3510
  BuiltinFunctions.add "__builtin_acos" (doubleType, [ doubleType ], false);
 
3511
  BuiltinFunctions.add "__builtin_acosf" (floatType, [ floatType ], false);
 
3512
  BuiltinFunctions.add "__builtin_acosl" (longDoubleType, [ longDoubleType ], false);
 
3513
 
 
3514
  BuiltinFunctions.add "__builtin_alloca" (voidPtrType, [ sizeType ], false);
 
3515
 
 
3516
  BuiltinFunctions.add "__builtin_asin" (doubleType, [ doubleType ], false);
 
3517
  BuiltinFunctions.add "__builtin_asinf" (floatType, [ floatType ], false);
 
3518
  BuiltinFunctions.add "__builtin_asinl" (longDoubleType, [ longDoubleType ], false);
 
3519
 
 
3520
  BuiltinFunctions.add "__builtin_atan" (doubleType, [ doubleType ], false);
 
3521
  BuiltinFunctions.add "__builtin_atanf" (floatType, [ floatType ], false);
 
3522
  BuiltinFunctions.add "__builtin_atanl" (longDoubleType, [ longDoubleType ], false);
 
3523
 
 
3524
  BuiltinFunctions.add "__builtin_atan2" (doubleType, [ doubleType; doubleType ], false);
 
3525
  BuiltinFunctions.add "__builtin_atan2f" (floatType, [ floatType; floatType ], false);
 
3526
  BuiltinFunctions.add "__builtin_atan2l" (longDoubleType, [ longDoubleType;
 
3527
                                                longDoubleType ], false);
 
3528
 
 
3529
  BuiltinFunctions.add "__builtin_ceil" (doubleType, [ doubleType ], false);
 
3530
  BuiltinFunctions.add "__builtin_ceilf" (floatType, [ floatType ], false);
 
3531
  BuiltinFunctions.add "__builtin_ceill" (longDoubleType, [ longDoubleType ], false);
 
3532
 
 
3533
  BuiltinFunctions.add "__builtin_cos" (doubleType, [ doubleType ], false);
 
3534
  BuiltinFunctions.add "__builtin_cosf" (floatType, [ floatType ], false);
 
3535
  BuiltinFunctions.add "__builtin_cosl" (longDoubleType, [ longDoubleType ], false);
 
3536
 
 
3537
  BuiltinFunctions.add "__builtin_cosh" (doubleType, [ doubleType ], false);
 
3538
  BuiltinFunctions.add "__builtin_coshf" (floatType, [ floatType ], false);
 
3539
  BuiltinFunctions.add "__builtin_coshl" (longDoubleType, [ longDoubleType ], false);
 
3540
 
 
3541
  BuiltinFunctions.add "__builtin_clz" (intType, [ uintType ], false);
 
3542
  BuiltinFunctions.add "__builtin_clzl" (intType, [ ulongType ], false);
 
3543
  BuiltinFunctions.add "__builtin_clzll" (intType, [ ulongLongType ], false);
 
3544
  BuiltinFunctions.add "__builtin_constant_p" (intType, [ intType ], false);
 
3545
  BuiltinFunctions.add "__builtin_ctz" (intType, [ uintType ], false);
 
3546
  BuiltinFunctions.add "__builtin_ctzl" (intType, [ ulongType ], false);
 
3547
  BuiltinFunctions.add "__builtin_ctzll" (intType, [ ulongLongType ], false);
 
3548
 
 
3549
  BuiltinFunctions.add "__builtin_exp" (doubleType, [ doubleType ], false);
 
3550
  BuiltinFunctions.add "__builtin_expf" (floatType, [ floatType ], false);
 
3551
  BuiltinFunctions.add "__builtin_expl" (longDoubleType, [ longDoubleType ], false);
 
3552
 
 
3553
  BuiltinFunctions.add "__builtin_expect" (longType, [ longType; longType ], false);
 
3554
 
 
3555
  BuiltinFunctions.add "__builtin_fabs" (doubleType, [ doubleType ], false);
 
3556
  BuiltinFunctions.add "__builtin_fabsf" (floatType, [ floatType ], false);
 
3557
  BuiltinFunctions.add "__builtin_fabsl" (longDoubleType, [ longDoubleType ], false);
 
3558
 
 
3559
  BuiltinFunctions.add "__builtin_ffs" (intType, [ uintType ], false);
 
3560
  BuiltinFunctions.add "__builtin_ffsl" (intType, [ ulongType ], false);
 
3561
  BuiltinFunctions.add "__builtin_ffsll" (intType, [ ulongLongType ], false);
 
3562
  BuiltinFunctions.add "__builtin_frame_address" (voidPtrType, [ uintType ], false);
 
3563
 
 
3564
  BuiltinFunctions.add "__builtin_floor" (doubleType, [ doubleType ], false);
 
3565
  BuiltinFunctions.add "__builtin_floorf" (floatType, [ floatType ], false);
 
3566
  BuiltinFunctions.add "__builtin_floorl" (longDoubleType, [ longDoubleType ], false);
 
3567
 
 
3568
  BuiltinFunctions.add "__builtin_huge_val" (doubleType, [], false);
 
3569
  BuiltinFunctions.add "__builtin_huge_valf" (floatType, [], false);
 
3570
  BuiltinFunctions.add "__builtin_huge_vall" (longDoubleType, [], false);
 
3571
  BuiltinFunctions.add "__builtin_inf" (doubleType, [], false);
 
3572
  BuiltinFunctions.add "__builtin_inff" (floatType, [], false);
 
3573
  BuiltinFunctions.add "__builtin_infl" (longDoubleType, [], false);
 
3574
  BuiltinFunctions.add "__builtin_memcpy" (voidPtrType, [ voidPtrType; voidConstPtrType; sizeType ], false);
 
3575
  BuiltinFunctions.add "__builtin_mempcpy" (voidPtrType, [ voidPtrType; voidConstPtrType; sizeType ], false);
 
3576
  BuiltinFunctions.add "__builtin_memset" (voidPtrType,
 
3577
                              [ voidPtrType; intType; intType ], false);
 
3578
 
 
3579
  BuiltinFunctions.add "__builtin_fmod" (doubleType, [ doubleType ], false);
 
3580
  BuiltinFunctions.add "__builtin_fmodf" (floatType, [ floatType ], false);
 
3581
  BuiltinFunctions.add "__builtin_fmodl" (longDoubleType, [ longDoubleType ], false);
 
3582
 
 
3583
  BuiltinFunctions.add "__builtin_frexp" (doubleType, [ doubleType; intPtrType ], false);
 
3584
  BuiltinFunctions.add "__builtin_frexpf" (floatType, [ floatType; intPtrType  ], false);
 
3585
  BuiltinFunctions.add "__builtin_frexpl" (longDoubleType, [ longDoubleType;
 
3586
                                                intPtrType  ], false);
 
3587
 
 
3588
  BuiltinFunctions.add "__builtin_ldexp" (doubleType, [ doubleType; intType ], false);
 
3589
  BuiltinFunctions.add "__builtin_ldexpf" (floatType, [ floatType; intType  ], false);
 
3590
  BuiltinFunctions.add "__builtin_ldexpl" (longDoubleType, [ longDoubleType;
 
3591
                                                intType  ], false);
 
3592
 
 
3593
  BuiltinFunctions.add "__builtin_log" (doubleType, [ doubleType ], false);
 
3594
  BuiltinFunctions.add "__builtin_logf" (floatType, [ floatType ], false);
 
3595
  BuiltinFunctions.add "__builtin_logl" (longDoubleType, [ longDoubleType ], false);
 
3596
 
 
3597
  BuiltinFunctions.add "__builtin_log10" (doubleType, [ doubleType ], false);
 
3598
  BuiltinFunctions.add "__builtin_log10f" (floatType, [ floatType ], false);
 
3599
  BuiltinFunctions.add "__builtin_log10l" (longDoubleType, [ longDoubleType ], false);
 
3600
 
 
3601
  BuiltinFunctions.add "__builtin_modff" (floatType, [ floatType;
 
3602
                                          TPtr(floatType,[]) ], false);
 
3603
  BuiltinFunctions.add "__builtin_modfl" (longDoubleType, [ longDoubleType;
 
3604
                                               TPtr(longDoubleType, []) ],
 
3605
                             false);
 
3606
 
 
3607
  BuiltinFunctions.add "__builtin_nan" (doubleType, [ charConstPtrType ], false);
 
3608
  BuiltinFunctions.add "__builtin_nanf" (floatType, [ charConstPtrType ], false);
 
3609
  BuiltinFunctions.add "__builtin_nanl" (longDoubleType, [ charConstPtrType ], false);
 
3610
  BuiltinFunctions.add "__builtin_nans" (doubleType, [ charConstPtrType ], false);
 
3611
  BuiltinFunctions.add "__builtin_nansf" (floatType, [ charConstPtrType ], false);
 
3612
  BuiltinFunctions.add "__builtin_nansl" (longDoubleType, [ charConstPtrType ], false);
 
3613
  BuiltinFunctions.add "__builtin_next_arg" ((if hasbva then TBuiltin_va_list [] else voidPtrType), [], false) (* When we parse builtin_next_arg we drop the second argument *);
 
3614
  BuiltinFunctions.add "__builtin_object_size" (sizeType, [ voidPtrType; intType ], false);
 
3615
 
 
3616
  BuiltinFunctions.add "__builtin_parity" (intType, [ uintType ], false);
 
3617
  BuiltinFunctions.add "__builtin_parityl" (intType, [ ulongType ], false);
 
3618
  BuiltinFunctions.add "__builtin_parityll" (intType, [ ulongLongType ], false);
 
3619
 
 
3620
  BuiltinFunctions.add "__builtin_popcount" (intType, [ uintType ], false);
 
3621
  BuiltinFunctions.add "__builtin_popcountl" (intType, [ ulongType ], false);
 
3622
  BuiltinFunctions.add "__builtin_popcountll" (intType, [ ulongLongType ], false);
 
3623
 
 
3624
  BuiltinFunctions.add "__builtin_powi" (doubleType, [ doubleType; intType ], false);
 
3625
  BuiltinFunctions.add "__builtin_powif" (floatType, [ floatType; intType ], false);
 
3626
  BuiltinFunctions.add "__builtin_powil" (longDoubleType, [ longDoubleType; intType ], false);
 
3627
  BuiltinFunctions.add "__builtin_prefetch" (voidType, [ voidConstPtrType ], true);
 
3628
  BuiltinFunctions.add "__builtin_return" (voidType, [ voidConstPtrType ], false);
 
3629
  BuiltinFunctions.add "__builtin_return_address" (voidPtrType, [ uintType ], false);
 
3630
 
 
3631
  BuiltinFunctions.add "__builtin_sin" (doubleType, [ doubleType ], false);
 
3632
  BuiltinFunctions.add "__builtin_sinf" (floatType, [ floatType ], false);
 
3633
  BuiltinFunctions.add "__builtin_sinl" (longDoubleType, [ longDoubleType ], false);
 
3634
 
 
3635
  BuiltinFunctions.add "__builtin_sinh" (doubleType, [ doubleType ], false);
 
3636
  BuiltinFunctions.add "__builtin_sinhf" (floatType, [ floatType ], false);
 
3637
  BuiltinFunctions.add "__builtin_sinhl" (longDoubleType, [ longDoubleType ], false);
 
3638
 
 
3639
  BuiltinFunctions.add "__builtin_sqrt" (doubleType, [ doubleType ], false);
 
3640
  BuiltinFunctions.add "__builtin_sqrtf" (floatType, [ floatType ], false);
 
3641
  BuiltinFunctions.add "__builtin_sqrtl" (longDoubleType, [ longDoubleType ], false);
 
3642
 
 
3643
  BuiltinFunctions.add "__builtin_stpcpy" (charPtrType, [ charPtrType; charConstPtrType ], false);
 
3644
  BuiltinFunctions.add "__builtin_strchr" (charPtrType, [ charPtrType; intType ], false);
 
3645
  BuiltinFunctions.add "__builtin_strcmp" (intType, [ charConstPtrType; charConstPtrType ], false);
 
3646
  BuiltinFunctions.add "__builtin_strcpy" (charPtrType, [ charPtrType; charConstPtrType ], false);
 
3647
  BuiltinFunctions.add "__builtin_strcspn" (sizeType, [ charConstPtrType; charConstPtrType ], false);
 
3648
  BuiltinFunctions.add "__builtin_strncat" (charPtrType, [ charPtrType; charConstPtrType; sizeType ], false);
 
3649
  BuiltinFunctions.add "__builtin_strncmp" (intType, [ charConstPtrType; charConstPtrType; sizeType ], false);
 
3650
  BuiltinFunctions.add "__builtin_strncpy" (charPtrType, [ charPtrType; charConstPtrType; sizeType ], false);
 
3651
  BuiltinFunctions.add "__builtin_strspn" (sizeType, [ charConstPtrType; charConstPtrType ], false);
 
3652
  BuiltinFunctions.add "__builtin_strpbrk" (charPtrType, [ charConstPtrType; charConstPtrType ], false);
 
3653
  (* When we parse builtin_types_compatible_p, we change its interface *)
 
3654
  BuiltinFunctions.add "__builtin_types_compatible_p"
 
3655
    (intType, [ theMachine.typeOfSizeOf;(* Sizeof the type *)
 
3656
                theMachine.typeOfSizeOf (* Sizeof the type *) ],
 
3657
                             false);
 
3658
  BuiltinFunctions.add "__builtin_tan" (doubleType, [ doubleType ], false);
 
3659
  BuiltinFunctions.add "__builtin_tanf" (floatType, [ floatType ], false);
 
3660
  BuiltinFunctions.add "__builtin_tanl" (longDoubleType, [ longDoubleType ], false);
 
3661
 
 
3662
  BuiltinFunctions.add "__builtin_tanh" (doubleType, [ doubleType ], false);
 
3663
  BuiltinFunctions.add "__builtin_tanhf" (floatType, [ floatType ], false);
 
3664
  BuiltinFunctions.add "__builtin_tanhl" (longDoubleType, [ longDoubleType ], false);
 
3665
 
 
3666
 
 
3667
  if hasbva then begin
 
3668
    BuiltinFunctions.add "__builtin_va_end" (voidType, [ TBuiltin_va_list [] ], false);
 
3669
    BuiltinFunctions.add "__builtin_varargs_start"
 
3670
      (voidType, [ TBuiltin_va_list [] ], false);
 
3671
    (* When we parse builtin_{va,stdarg}_start, we drop the second argument *)
 
3672
    BuiltinFunctions.add "__builtin_va_start" (voidType, [ TBuiltin_va_list [] ], false);
 
3673
    BuiltinFunctions.add "__builtin_stdarg_start" (voidType, [ TBuiltin_va_list []; ],
 
3674
                                      false);
 
3675
    (* When we parse builtin_va_arg we change its interface *)
 
3676
    BuiltinFunctions.add "__builtin_va_arg"
 
3677
      (voidType, [ TBuiltin_va_list [];
 
3678
                   theMachine.typeOfSizeOf;(* Sizeof the type *)
 
3679
                   voidPtrType; (* Ptr to res *) ],
 
3680
                               false);
 
3681
    BuiltinFunctions.add "__builtin_va_copy" (voidType, [ TBuiltin_va_list [];
 
3682
                                             TBuiltin_va_list [] ],
 
3683
                                false);
 
3684
  end;
 
3685
  ()
 
3686
 
 
3687
(** Construct a hash with the builtins *)
 
3688
let initMsvcBuiltins () : unit =
 
3689
  if not (TheMachine.is_computed ()) then
 
3690
    E.s (bug "Call initCIL before initGccBuiltins");
 
3691
  if BuiltinFunctions.length () <> 0 then
 
3692
    E.s (bug "builtins already initialized.");
 
3693
  (** Take a number of wide string literals *)
 
3694
  BuiltinFunctions.add "__annotation" (voidType, [ ], true);
 
3695
  ()
 
3696
 
 
3697
(** This is used as the location of the prototypes of builtin functions. *)
 
3698
let builtinLoc: location = locUnknown
 
3699
 
 
3700
let range_loc loc1 loc2 = fst loc1, snd loc2
 
3701
 
 
3702
let pred_body = function
 
3703
  | LBpred a -> a
 
3704
  | LBreads _
 
3705
  | LBinductive _
 
3706
  | LBterm _ ->
 
3707
      bug "definition expected in Cil.pred_body"
 
3708
 
 
3709
 
 
3710
 
 
3711
(** A printer interface for CIL trees. Create instantiations of
 
3712
 * this type by specializing the class {!Cil.defaultCilPrinter}. *)
 
3713
class type cilPrinter = object
 
3714
 
 
3715
  (** Local logical annotation (function specifications and code annotations
 
3716
      are printed only if [logic_printer_enabled] is set to true
 
3717
   *)
 
3718
  val mutable logic_printer_enabled : bool
 
3719
 
 
3720
  (** more info is displayed on verbose mode. *)
 
3721
  val mutable verbose: bool
 
3722
 
 
3723
  method current_function: varinfo option
 
3724
    (** Returns the [varinfo] corresponding to the function being printed *)
 
3725
 
 
3726
  method current_stmt: stmt option
 
3727
    (** Returns the stmt being printed *)
 
3728
 
 
3729
  method may_be_skipped: stmt -> bool
 
3730
 
 
3731
  method setPrintInstrTerminator : string -> unit
 
3732
  method getPrintInstrTerminator : unit -> string
 
3733
 
 
3734
  method pVarName: Format.formatter -> string -> unit
 
3735
    (** Invoked each time an identifier name is to be printed. Allows for
 
3736
        various manipulation of the name, such as unmangling. *)
 
3737
 
 
3738
  method pVDecl: Format.formatter -> varinfo -> unit
 
3739
    (** Invoked for each variable declaration. Note that variable
 
3740
     * declarations are all the [GVar], [GVarDecl], [GFun], all the [varinfo]
 
3741
     * in formals of function types, and the formals and locals for function
 
3742
     * definitions. *)
 
3743
 
 
3744
  method pVar: Format.formatter -> varinfo -> unit
 
3745
    (** Invoked on each variable use. *)
 
3746
 
 
3747
  method pLval: Format.formatter -> lval -> unit
 
3748
    (** Invoked on each lvalue occurence *)
 
3749
 
 
3750
  method pOffset: Format.formatter -> offset -> unit
 
3751
    (** Invoked on each offset occurence. The second argument is the base. *)
 
3752
 
 
3753
  method pInstr: Format.formatter -> instr -> unit
 
3754
    (** Invoked on each instruction occurrence. *)
 
3755
 
 
3756
  method pStmt: Format.formatter -> stmt -> unit
 
3757
    (** Control-flow statement. This is used by
 
3758
     * {!Cil.printGlobal} and by [Cil.dumpGlobal]. *)
 
3759
 
 
3760
  method pStmtNext : stmt -> Format.formatter -> stmt -> unit
 
3761
 
 
3762
  method pBlock: ?toplevel:bool -> Format.formatter -> block -> unit
 
3763
    (** Print a block. *)
 
3764
 
 
3765
  method pGlobal: Format.formatter -> global -> unit
 
3766
    (** Global (vars, types, etc.). This can be slow and is used only by
 
3767
     * {!Cil.printGlobal} but by {!Cil.dumpGlobal} for everything else except
 
3768
     * [GVar] and [GFun]. *)
 
3769
 
 
3770
  method pFieldDecl: Format.formatter -> fieldinfo -> unit
 
3771
    (** A field declaration *)
 
3772
 
 
3773
  method pType: (Format.formatter -> unit) option -> Format.formatter -> typ -> unit
 
3774
  (** Use of some type in some declaration. The first argument is used to print
 
3775
    the declared element, or is None if we are just printing a type with no
 
3776
    name being declared. Note that for structure/union and enumeration types
 
3777
    the definition of the composite type is not visited. Use [vglob] to
 
3778
    visit it.  *)
 
3779
 
 
3780
  method pAttr: Format.formatter -> attribute -> bool
 
3781
    (** Attribute. Also return an indication whether this attribute must be
 
3782
      * printed inside the __attribute__ list or not. *)
 
3783
 
 
3784
  method pAttrParam:  Format.formatter -> attrparam -> unit
 
3785
    (** Attribute paramter *)
 
3786
 
 
3787
  method pAttrs:  Format.formatter -> attributes -> unit
 
3788
    (** Attribute lists *)
 
3789
 
 
3790
  method pLabel:  Format.formatter -> label -> unit
 
3791
    (** Label *)
 
3792
 
 
3793
  method pLineDirective: ?forcefile:bool ->  Format.formatter -> location -> unit
 
3794
    (** Print a line-number. This is assumed to come always on an empty line.
 
3795
     * If the forcefile argument is present and is true then the file name
 
3796
     * will be printed always. Otherwise the file name is printed only if it
 
3797
     * is different from the last time time this function is called. The last
 
3798
     * file name is stored in a private field inside the cilPrinter object. *)
 
3799
 
 
3800
  method pAnnotatedStmt : stmt ->  Format.formatter -> stmt -> unit
 
3801
    (** Print an annotated statement. The code to be printed is given in the
 
3802
     * last {!stmt} argument.  The initial {!stmt} argument
 
3803
     * records the statement which follows the one being printed;
 
3804
     * {!Cil.defaultCilPrinterClass} uses this information to prettify
 
3805
     * statement printing in certain special cases. *)
 
3806
 
 
3807
  method pStmtKind : stmt ->  Format.formatter -> stmtkind -> unit
 
3808
    (** Print a statement kind. The code to be printed is given in the
 
3809
     * {!stmtkind} argument.  The initial {!Cil.stmt} argument
 
3810
     * records the statement which follows the one being printed;
 
3811
     * {!Cil.defaultCilPrinterClass} uses this information to prettify
 
3812
     * statement printing in certain special cases.
 
3813
     *)
 
3814
 
 
3815
  method pExp:  Format.formatter -> exp -> unit
 
3816
    (** Print expressions *)
 
3817
 
 
3818
  method pInit:  Format.formatter -> init -> unit
 
3819
    (** Print initializers. This can be slow and is used by
 
3820
     * {!Cil.printGlobal} but not by {!Cil.dumpGlobal}. *)
 
3821
 
 
3822
  method pLogic_type: Format.formatter -> logic_type -> unit
 
3823
 
 
3824
  method pTsets_elem: Format.formatter -> tsets_elem -> unit
 
3825
 
 
3826
  method pTsets_lhost: Format.formatter -> tsets_lhost -> unit
 
3827
 
 
3828
  method pTsets_offset: Format.formatter -> tsets_offset -> unit
 
3829
 
 
3830
  method pTsets_lval: Format.formatter -> tsets_lval -> unit
 
3831
 
 
3832
  method pTsets: Format.formatter -> tsets -> unit
 
3833
 
 
3834
  method pTerm: Format.formatter -> term -> unit
 
3835
 
 
3836
  method pTerm_node: Format.formatter -> term -> unit
 
3837
 
 
3838
  method pTerm_lval: Format.formatter -> term_lval -> unit
 
3839
 
 
3840
  method pTerm_offset: Format.formatter -> term_offset -> unit
 
3841
 
 
3842
  method pLogic_info_use: Format.formatter -> logic_info -> unit
 
3843
 
 
3844
  method pLogic_var: Format.formatter -> logic_var -> unit
 
3845
 
 
3846
  method pQuantifiers: Format.formatter -> quantifiers -> unit
 
3847
 
 
3848
  method pPredicate: Format.formatter -> predicate -> unit
 
3849
 
 
3850
  method pPredicate_named: Format.formatter -> predicate named -> unit
 
3851
 
 
3852
(*
 
3853
  method pPredicate_info_use: Format.formatter -> predicate_info -> unit
 
3854
*)
 
3855
 
 
3856
  method pBehavior: Format.formatter -> funbehavior -> unit
 
3857
 
 
3858
  method pSpec: Format.formatter -> funspec -> unit
 
3859
 
 
3860
  method pZone: Format.formatter -> identified_tsets zone -> unit
 
3861
 
 
3862
  method pAssigns:
 
3863
    string -> Format.formatter -> identified_tsets assigns -> unit
 
3864
 
 
3865
  method pStatus : Format.formatter -> Cil_types.annot_status -> unit
 
3866
 
 
3867
  method pCode_annot: Format.formatter -> code_annotation -> unit
 
3868
 
 
3869
  method pAnnotation: Format.formatter -> global_annotation -> unit
 
3870
end
 
3871
 
 
3872
 
 
3873
let is_skip = function Instr (Skip _) -> true | _ -> false
 
3874
 
 
3875
let empty_funspec () =
 
3876
  {spec_requires = [];
 
3877
   spec_behavior = [];
 
3878
   spec_variant = None;
 
3879
   spec_terminates = None;
 
3880
   spec_complete_behaviors = [];
 
3881
   spec_disjoint_behaviors = [];
 
3882
}
 
3883
 
 
3884
let is_empty_funspec spec =
 
3885
  spec.spec_requires = [] && spec.spec_behavior = [] &&
 
3886
  spec.spec_variant = None && spec.spec_terminates = None &&
 
3887
  spec.spec_complete_behaviors = [] && spec.spec_disjoint_behaviors = []
 
3888
 
 
3889
 
 
3890
class defaultCilPrinterClass : cilPrinter = object (self)
 
3891
  val mutable logic_printer_enabled = true
 
3892
  val mutable verbose = false
 
3893
 
 
3894
  val current_stmt = Stack.create ()
 
3895
  val mutable current_function = None
 
3896
 
 
3897
  method private in_current_function vi =
 
3898
    assert (current_function = None);
 
3899
    current_function <- Some vi
 
3900
  method private out_current_function =
 
3901
    assert (current_function <> None);
 
3902
    current_function <- None
 
3903
 
 
3904
  method current_function = current_function
 
3905
  method private push_stmt s = Stack.push s current_stmt
 
3906
  method private pop_stmt s = ignore (Stack.pop current_stmt); s
 
3907
  method current_stmt =
 
3908
    try Some (Stack.top current_stmt) with Stack.Empty -> None
 
3909
 
 
3910
  method may_be_skipped s = s.labels = []
 
3911
 
 
3912
  (** Returns the stmt being printed *)
 
3913
 
 
3914
  val mutable currentFormals : varinfo list = []
 
3915
  method private getLastNamedArgument (s: string) : exp =
 
3916
    match List.rev currentFormals with
 
3917
      f :: _ -> Lval (var f)
 
3918
    | [] ->
 
3919
        E.s (warn "Cannot find the last named argument when printing call to %s\n" s)
 
3920
 
 
3921
  (*** VARIABLES ***)
 
3922
  method pVarName fmt v = pp_print_string fmt v
 
3923
 
 
3924
  method private pVarString v =
 
3925
    fprintf_to_string "%a" self#pVar v
 
3926
 
 
3927
  (* variable use *)
 
3928
  method pVar fmt (v:varinfo) = Format.fprintf fmt "%a" self#pVarName v.vname
 
3929
 
 
3930
  (* variable declaration *)
 
3931
  method pVDecl fmt (v:varinfo) =
 
3932
    let stom, rest = separateStorageModifiers v.vattr in
 
3933
    (* First the storage modifiers *)
 
3934
    fprintf fmt "%s%a%a%a %a"
 
3935
      (if v.vinline then "__inline " else "")
 
3936
      d_storage v.vstorage
 
3937
      self#pAttrs stom
 
3938
      (self#pType (Some (fun fmt -> self#pVar fmt v))) v.vtype
 
3939
      self#pAttrs rest
 
3940
 
 
3941
  (*** L-VALUES ***)
 
3942
  method pLval fmt (lv:lval) =  (* lval (base is 1st field)  *)
 
3943
    match lv with
 
3944
      Var vi, o -> fprintf fmt "%a%a" self#pVar vi self#pOffset o
 
3945
    | Mem e, Field(fi, o) ->
 
3946
        fprintf fmt "%a->%a%a"
 
3947
          (self#pExpPrec arrowLevel)  e
 
3948
          self#pVarName fi.fname
 
3949
          self#pOffset o
 
3950
    | Mem e, NoOffset ->
 
3951
        fprintf fmt "*%a"
 
3952
          (self#pExpPrec derefStarLevel) e
 
3953
    | Mem e, o ->
 
3954
        fprintf fmt "(*%a)%a"
 
3955
          (self#pExpPrec derefStarLevel) e
 
3956
          self#pOffset o
 
3957
 
 
3958
  (** Offsets **)
 
3959
  method pOffset fmt = function
 
3960
    | NoOffset -> ()
 
3961
    | Field (fi, o) ->
 
3962
        fprintf fmt ".%a%a"
 
3963
          self#pVarName fi.fname
 
3964
          self#pOffset o
 
3965
    | Index (e, o) ->
 
3966
        fprintf fmt "[%a]%a"
 
3967
          self#pExp e
 
3968
          self#pOffset o
 
3969
 
 
3970
  method private pLvalPrec (contextprec: int) fmt lv =
 
3971
    if getParenthLevel (Lval(lv)) >= contextprec then
 
3972
      fprintf fmt "(%a)" self#pLval lv
 
3973
    else
 
3974
      self#pLval fmt lv
 
3975
 
 
3976
  (*** EXPRESSIONS ***)
 
3977
  method pExp fmt (e: exp) =
 
3978
    let level = getParenthLevel e in
 
3979
    match stripInfo e with
 
3980
    | Info _ -> assert false
 
3981
    | Const(c) -> d_const fmt c
 
3982
    | Lval(l) -> self#pLval fmt l
 
3983
    | UnOp(u,e1,_) ->
 
3984
        fprintf fmt "%a %a"
 
3985
          d_unop u
 
3986
          (self#pExpPrec level) e1
 
3987
 
 
3988
    | BinOp(b,e1,e2,_) ->
 
3989
        fprintf fmt "@[%a %a %a@]"
 
3990
          (self#pExpPrec level) e1
 
3991
          d_binop b
 
3992
          (self#pExpPrec level) e2
 
3993
 
 
3994
    | CastE(t,e) ->
 
3995
        fprintf fmt "(%a)%a"
 
3996
          (self#pType None) t
 
3997
          (self#pExpPrec level) e
 
3998
 
 
3999
    | SizeOf (t) ->
 
4000
        fprintf fmt "sizeof(%a)"
 
4001
          (self#pType None) t
 
4002
 
 
4003
    | SizeOfE (e) ->
 
4004
        fprintf fmt "sizeof(%a)"
 
4005
          self#pExp e
 
4006
 
 
4007
    | SizeOfStr s ->
 
4008
        fprintf fmt "sizeof(%a)"
 
4009
          d_const (CStr s)
 
4010
 
 
4011
    | AlignOf (t) ->
 
4012
        fprintf fmt "__alignof__(%a)"
 
4013
          (self#pType None) t
 
4014
    | AlignOfE (e) ->
 
4015
        fprintf fmt "__alignof__(%a)"
 
4016
          self#pExp e
 
4017
    | AddrOf(lv) ->
 
4018
        fprintf fmt "& %a"
 
4019
          (self#pLvalPrec addrOfLevel) lv
 
4020
 
 
4021
    | StartOf(lv) -> self#pLval fmt lv
 
4022
 
 
4023
  (* Print an expression, given the precedence of the context in which it
 
4024
   * appears. *)
 
4025
  method private pExpPrec (contextprec: int) fmt (e: exp) =
 
4026
    let thisLevel = getParenthLevel e in
 
4027
    let needParens =
 
4028
      if thisLevel >= contextprec then
 
4029
        true
 
4030
      else if contextprec == bitwiseLevel then
 
4031
        (* quiet down some GCC warnings *)
 
4032
        thisLevel == additiveLevel || thisLevel == comparativeLevel
 
4033
      else
 
4034
        false
 
4035
    in
 
4036
    if needParens then
 
4037
      fprintf fmt "(%a)" self#pExp e
 
4038
    else
 
4039
      self#pExp fmt e
 
4040
 
 
4041
  method pInit fmt = function
 
4042
      SingleInit e -> self#pExp fmt e
 
4043
    | CompoundInit (t, initl) ->
 
4044
        (* We do not print the type of the Compound *)
 
4045
        (*
 
4046
          let dinit e = d_init () e in
 
4047
          dprintf "{@[%a@]}"
 
4048
          (docList ~sep:(chr ',' ++ break) dinit) initl
 
4049
        *)
 
4050
        let printDesignator =
 
4051
          if not theMachine.msvcMode then begin
 
4052
            (* Print only for union when we do not initialize the first field *)
 
4053
            match unrollType t, initl with
 
4054
              TComp(ci, _), [(Field(f, NoOffset), _)] ->
 
4055
                if not (ci.cstruct) && ci.cfields != [] &&
 
4056
                  (List.hd ci.cfields) != f then
 
4057
                    true
 
4058
                else
 
4059
                  false
 
4060
            | _ -> false
 
4061
          end else
 
4062
            false
 
4063
        in
 
4064
        let d_oneInit fmt = function
 
4065
            Field(f, NoOffset), i ->
 
4066
              if printDesignator then
 
4067
                fprintf fmt ".%a = "
 
4068
                  self#pVarName f.fname;
 
4069
              self#pInit fmt i
 
4070
          | Index(e, NoOffset), i ->
 
4071
              if printDesignator then
 
4072
                fprintf fmt "[%a] = "
 
4073
                  self#pExp e;
 
4074
              self#pInit fmt i
 
4075
          | _ -> E.s (unimp "Trying to print malformed initializer")
 
4076
        in
 
4077
        fprintf fmt  "{@[%a@]}"
 
4078
          (fprintfList ~sep:",@ " d_oneInit) initl
 
4079
 
 
4080
 
 
4081
  (** What terminator to print after an instruction. sometimes we want to
 
4082
      * print sequences of instructions separated by comma *)
 
4083
  val mutable printInstrTerminator = ";"
 
4084
 
 
4085
  method private setPrintInstrTerminator (term : string) =
 
4086
    printInstrTerminator <- term
 
4087
 
 
4088
  method private getPrintInstrTerminator () = printInstrTerminator
 
4089
 
 
4090
  (*** INSTRUCTIONS ****)
 
4091
  method pInstr fmt (i:instr) =       (* imperative instruction *)
 
4092
    fprintf fmt "%a" (self#pLineDirective ~forcefile:false) (get_instrLoc i);
 
4093
    match i with
 
4094
    | Skip _ -> fprintf fmt ";"
 
4095
    | Set(lv,e,_) -> begin
 
4096
        (* Be nice to some special cases *)
 
4097
        match e with
 
4098
          BinOp((PlusA|PlusPI|IndexPI),Lval(lv'),Const(CInt64(one,_,_)),_)
 
4099
            when equals lv lv' && one = Int64.one
 
4100
              && not miscState.printCilAsIs ->
 
4101
                fprintf fmt "%a ++%s"
 
4102
                  (self#pLvalPrec indexLevel) lv
 
4103
                  printInstrTerminator
 
4104
        | BinOp((MinusA|MinusPI),Lval(lv'),
 
4105
                Const(CInt64(one,_,_)), _)
 
4106
            when equals lv lv' && one = Int64.one
 
4107
              && not miscState.printCilAsIs ->
 
4108
            fprintf fmt "%a --%s"
 
4109
              (self#pLvalPrec indexLevel) lv
 
4110
              printInstrTerminator
 
4111
 
 
4112
        | BinOp((PlusA|PlusPI|IndexPI),Lval(lv'),Const(CInt64(mone,_,_)),_)
 
4113
            when equals lv lv' && mone = Int64.minus_one
 
4114
              && not miscState.printCilAsIs ->
 
4115
            fprintf fmt "%a --%s"
 
4116
              (self#pLvalPrec indexLevel) lv
 
4117
              printInstrTerminator
 
4118
 
 
4119
        | BinOp((PlusA|PlusPI|IndexPI|MinusA|MinusPP|MinusPI|BAnd|BOr|BXor|
 
4120
                     Mult|Div|Mod|Shiftlt|Shiftrt) as bop,
 
4121
                Lval(lv'),e,_) when equals lv lv' ->
 
4122
            fprintf fmt "%a %a= %a%s"
 
4123
              self#pLval  lv
 
4124
              d_binop bop
 
4125
              self#pExp e
 
4126
              printInstrTerminator
 
4127
 
 
4128
        | _ ->
 
4129
            fprintf fmt "%a = %a%s"
 
4130
              self#pLval lv
 
4131
              self#pExp e
 
4132
              printInstrTerminator
 
4133
 
 
4134
      end
 
4135
        (* In cabs2cil we have turned the call to builtin_va_arg into a
 
4136
         * three-argument call: the last argument is the address of the
 
4137
         * destination *)
 
4138
    | Call(None, Lval(Var vi, NoOffset), [dest; SizeOf t; adest], l)
 
4139
        when vi.vname = "__builtin_va_arg" && not miscState.printCilAsIs ->
 
4140
        let destlv = match stripCasts adest with
 
4141
          AddrOf destlv -> destlv
 
4142
            (* If this fails, it's likely that an extension interfered
 
4143
               with the AddrOf *)
 
4144
        | _ -> E.s (bug
 
4145
                      "%a: Encountered unexpected call to %s with dest %a\n"
 
4146
                      d_loc l vi.vname self#pExp adest)
 
4147
        in
 
4148
        fprintf fmt "%a = __builtin_va_arg (@[%a,@ %a@])%s"
 
4149
          self#pLval destlv
 
4150
          (* Now the arguments *)
 
4151
          self#pExp dest
 
4152
          (self#pType None)  t
 
4153
          printInstrTerminator
 
4154
 
 
4155
    (* In cabs2cil we have dropped the last argument in the call to
 
4156
     * __builtin_va_start and __builtin_stdarg_start. *)
 
4157
    | Call(None, Lval(Var vi, NoOffset), [marker], l)
 
4158
        when ((vi.vname = "__builtin_stdarg_start" ||
 
4159
                  vi.vname = "__builtin_va_start")
 
4160
              && not miscState.printCilAsIs) ->
 
4161
        begin
 
4162
          let last = self#getLastNamedArgument vi.vname in
 
4163
          self#pInstr fmt (Call(None,Lval(Var vi,NoOffset),[marker; last],l))
 
4164
        end
 
4165
 
 
4166
    (* In cabs2cil we have dropped the last argument in the call to
 
4167
     * __builtin_next_arg. *)
 
4168
    | Call(res, Lval(Var vi, NoOffset), [ ], l)
 
4169
        when vi.vname = "__builtin_next_arg" && not miscState.printCilAsIs ->
 
4170
        begin
 
4171
          let last = self#getLastNamedArgument vi.vname in
 
4172
          self#pInstr fmt (Call(res,Lval(Var vi,NoOffset),[last],l))
 
4173
        end
 
4174
 
 
4175
    (* In cparser we have turned the call to
 
4176
     * __builtin_types_compatible_p(t1, t2) into
 
4177
     * __builtin_types_compatible_p(sizeof t1, sizeof t2), so that we can
 
4178
     * represent the types as expressions.
 
4179
     * Remove the sizeofs when printing. *)
 
4180
    | Call(dest, Lval(Var vi, NoOffset), [SizeOf t1; SizeOf t2], _)
 
4181
        when vi.vname = "__builtin_types_compatible_p"
 
4182
          && not miscState.printCilAsIs ->
 
4183
        (* Print the destination *)
 
4184
        (match dest with
 
4185
           None -> ()
 
4186
         | Some lv -> fprintf fmt "%a = " self#pLval lv );
 
4187
          (* Now the call itself *)
 
4188
          fprintf fmt "%a(%a, %a)%s"
 
4189
            self#pVarName vi.vname
 
4190
            (self#pType None) t1
 
4191
            (self#pType None) t2
 
4192
            printInstrTerminator
 
4193
    | Call(_, Lval(Var vi, NoOffset), _, _)
 
4194
        when vi.vname = "__builtin_types_compatible_p"
 
4195
          && not miscState.printCilAsIs ->
 
4196
        E.s (bug "__builtin_types_compatible_p: cabs2cil should have added sizeof to the arguments.")
 
4197
 
 
4198
    | Call(dest,e,args,_) ->
 
4199
        (match dest with
 
4200
           None -> ()
 
4201
         | Some lv ->
 
4202
             fprintf fmt "%a = "
 
4203
               self#pLval lv;
 
4204
             (* Maybe we need to print a cast *)
 
4205
             (let destt = typeOfLval lv in
 
4206
              match unrollType (typeOf e) with
 
4207
                TFun (rt, _, _, _)
 
4208
                  when not (equals (!pTypeSig rt)
 
4209
                              (!pTypeSig destt)) ->
 
4210
                    fprintf fmt "(%a)"
 
4211
                      (self#pType None) destt
 
4212
              | _ -> ()));
 
4213
        (* Now the function name *)
 
4214
        (match e with
 
4215
           Lval(Var _, _) -> self#pExp fmt e
 
4216
         | _ -> fprintf fmt "(%a)"  self#pExp e);
 
4217
        fprintf fmt "(@[%a@])%s"
 
4218
          (* Now the arguments *)
 
4219
          (fprintfList ~sep:",@ " self#pExp)
 
4220
          args
 
4221
          printInstrTerminator
 
4222
 
 
4223
 
 
4224
    | Asm(attrs, tmpls, outs, ins, clobs, l) ->
 
4225
        self#pLineDirective fmt l;
 
4226
        if theMachine.msvcMode then
 
4227
          fprintf fmt "__asm {@[%a@]}%s"
 
4228
            (fprintfList ~sep:"@\n" (fun fmt s -> fprintf fmt "%s" s)) tmpls
 
4229
            printInstrTerminator
 
4230
        else begin
 
4231
          fprintf fmt "__asm__ %a (@[%a"
 
4232
            self#pAttrs attrs
 
4233
            (fprintfList ~sep:"@\n" (fun fmt x -> fprintf fmt "\"%s\"" (escape_string x))) tmpls;
 
4234
 
 
4235
          if outs = [] && ins = [] && clobs = [] then
 
4236
            fprintf fmt ":"
 
4237
          else
 
4238
            fprintf fmt ": %a"
 
4239
              (fprintfList ~sep:",@ "
 
4240
                 (fun fmt (idopt, c, lv) ->
 
4241
                    fprintf fmt "%s\"%s\" (%a)"
 
4242
                      (match idopt with
 
4243
                         None -> ""
 
4244
                       | Some id -> "[" ^ id ^ "] "
 
4245
                      )
 
4246
                      (escape_string c)
 
4247
                      self#pLval lv
 
4248
                 )) outs;
 
4249
 
 
4250
          if ins = [] && clobs = [] then
 
4251
            ()
 
4252
          else
 
4253
            fprintf fmt ": %a"
 
4254
              (fprintfList ~sep:",@ "
 
4255
                 (fun fmt (idopt, c, e) ->
 
4256
                    fprintf fmt "%s\"%s\"(%a)"
 
4257
                      (match idopt with
 
4258
                         None -> ""
 
4259
                       | Some id -> "[" ^ id ^ "] "
 
4260
                      )
 
4261
                      (escape_string c)
 
4262
                      self#pExp e))
 
4263
              ins;
 
4264
 
 
4265
 
 
4266
          if clobs = [] then ()
 
4267
          else
 
4268
            fprintf fmt ": %a"
 
4269
              (fprintfList ~sep:",@ "
 
4270
                 (fun fmt c -> fprintf fmt "\"%s\"" (escape_string c)))
 
4271
              clobs;
 
4272
 
 
4273
          fprintf fmt "@])%s" printInstrTerminator
 
4274
        end
 
4275
    | Code_annot (annot, l) ->
 
4276
        if logic_printer_enabled then
 
4277
          fprintf fmt "%a@[/*@@ %a*/@]"
 
4278
            (self#pLineDirective ~forcefile:false) l
 
4279
            self#pCode_annot annot
 
4280
 
 
4281
  (**** STATEMENTS ****)
 
4282
  method pStmt fmt (s:stmt) =        (* control-flow statement *)
 
4283
    self#push_stmt s;
 
4284
    self#pop_stmt (self#pStmtNext invalidStmt fmt s)
 
4285
 
 
4286
  method pStmtNext (next: stmt) fmt (s: stmt) =
 
4287
    self#push_stmt s;
 
4288
    self#pop_stmt (self#pAnnotatedStmt next fmt s)
 
4289
 
 
4290
  method pAnnotatedStmt (next: stmt) fmt (s: stmt) =
 
4291
    if false then (* CEA: to debug location setting *)
 
4292
      (let loc = fst (get_stmtLoc s.skind) in
 
4293
       fprintf fmt "/*Loc=%s:%d*/" loc.Lexing.pos_fname loc.Lexing.pos_lnum);
 
4294
    (* print the labels *)
 
4295
    fprintfList ~sep:"@\n" (fun fmt l -> self#pLabel fmt l) fmt s.labels;
 
4296
 
 
4297
    (* print the statement itself. If the labels are non-empty and the
 
4298
     * statement is empty, print a semicolon  *)
 
4299
    if is_skip s.skind && not s.ghost then
 
4300
      (if verbose || s.labels <> [] then fprintf fmt ";")
 
4301
    else
 
4302
      (if s.labels <> [] then fprintf fmt "@\n";
 
4303
       if s.ghost then fprintf fmt "@[/*@@ @[ghost ";
 
4304
       self#pStmtKind next fmt s.skind ;
 
4305
       if s.ghost then fprintf fmt "@]*/@]";)
 
4306
        (* OLD value : if is_skip s.skind && s.labels <> [] then
 
4307
           text ";" else (if s.labels <> [] then line else nil) ++
 
4308
           self#pStmtKind next () s.skind *);
 
4309
    if s.ghost then fprintf fmt "@]*/@]"
 
4310
 
 
4311
  method private pLabel fmt = function
 
4312
      Label (s, _, true) -> fprintf fmt "%s: " s
 
4313
    | Label (s, _, false) -> fprintf fmt "%s: /* CIL Label */ " s
 
4314
    | Case (e, _) -> fprintf fmt "case %a: " self#pExp e
 
4315
    | Default _ -> fprintf fmt "default: "
 
4316
 
 
4317
  (* The pBlock will put the unalign itself *)
 
4318
  method pBlock ?(toplevel=true) fmt (blk: block) =
 
4319
    let force_paren =
 
4320
      toplevel ||
 
4321
        match blk.bstmts with
 
4322
        | [_] | [] ->
 
4323
            blk.battrs <> []
 
4324
        | _ -> true
 
4325
    in
 
4326
    let rec dofirst () = function
 
4327
        [] -> ()
 
4328
      | [x] -> self#pStmtNext invalidStmt fmt x
 
4329
      | x :: rest -> dorest x rest
 
4330
    and dorest prev = function
 
4331
        [] -> self#pStmtNext invalidStmt fmt prev
 
4332
      | x :: rest ->
 
4333
          fprintf fmt "%a@\n" (self#pStmtNext x) prev;
 
4334
          dorest x rest
 
4335
    in
 
4336
    (* Let the host of the block decide on the alignment. The d_block will
 
4337
     * pop the alignment as well  *)
 
4338
    if force_paren then fprintf fmt "{";
 
4339
    if blk.battrs <> [] then
 
4340
      self#pAttrsGen true fmt blk.battrs;
 
4341
    dofirst () blk.bstmts;
 
4342
    if force_paren then fprintf fmt "}";
 
4343
     fprintf fmt "@]@\n"
 
4344
 
 
4345
 
 
4346
  (* Store here the name of the last file printed in a line number. This is
 
4347
   * private to the object *)
 
4348
  val mutable lastFileName = ""
 
4349
  val mutable lastLineNumber = -1
 
4350
 
 
4351
  (* Make sure that you only call self#pLineDirective on an empty line *)
 
4352
  method pLineDirective ?(forcefile=false) fmt l =
 
4353
    CurrentLoc.set l;
 
4354
    match miscState.lineDirectiveStyle with
 
4355
    | None -> ()
 
4356
    | Some _ when (fst l).Lexing.pos_lnum <= 0 -> ()
 
4357
 
 
4358
    (* Do not print lineComment if the same line as above *)
 
4359
    | Some LineCommentSparse when (fst l).Lexing.pos_lnum = lastLineNumber -> ()
 
4360
 
 
4361
    | Some style  ->
 
4362
        let directive =
 
4363
          match style with
 
4364
          | LineComment | LineCommentSparse -> "//#line "
 
4365
          | LinePreprocessorOutput when not theMachine.msvcMode -> "#"
 
4366
          | LinePreprocessorOutput | LinePreprocessorInput -> "#line"
 
4367
        in
 
4368
        lastLineNumber <- (fst l).Lexing.pos_lnum;
 
4369
        let filename =
 
4370
          if forcefile || (fst l).Lexing.pos_fname <> lastFileName then
 
4371
            begin
 
4372
              lastFileName <- (fst l).Lexing.pos_fname;
 
4373
              " \"" ^ (fst l).Lexing.pos_fname ^ "\""
 
4374
            end
 
4375
          else
 
4376
            ""
 
4377
        in
 
4378
        fprintf fmt "@<0>\n@<0>%s@<0> @<0>%d@<0> @<0>%s@\n" directive (fst l).Lexing.pos_lnum filename
 
4379
 
 
4380
 
 
4381
  method pStmtKind (next: stmt) fmt kind =
 
4382
    match kind with
 
4383
    | UnspecifiedSequence seq ->
 
4384
        let print_stmt pstmt fmt (stmt, writes, reads) =
 
4385
          fprintf fmt "%a%a"
 
4386
            pstmt stmt
 
4387
            (print_if verbose)
 
4388
            (fun fmt () ->
 
4389
               Format.fprintf fmt "/*@ @[%a@ <-@ %a@]*/"
 
4390
                 (pretty_list (space_sep ",") self#pLval) writes
 
4391
                 (pretty_list (space_sep ",") self#pLval) reads)
 
4392
 
 
4393
        in
 
4394
        let rec dofirst () = function
 
4395
            [] -> ()
 
4396
          | [x] -> print_stmt (self#pStmtNext invalidStmt) fmt x
 
4397
          | x :: rest -> dorest x rest
 
4398
        and dorest ((p,_,_) as prev) = function
 
4399
            [] -> print_stmt (self#pStmtNext invalidStmt) fmt prev
 
4400
          | (s,_,_) as x :: rest ->
 
4401
              let newline_cond =
 
4402
                verbose ||
 
4403
                  not (is_skip p.skind) || p.ghost || p.labels <> []
 
4404
              in
 
4405
              fprintf fmt "%a%a" (print_stmt (self#pStmtNext s)) prev
 
4406
                (print_if newline_cond) newline;
 
4407
              dorest x rest
 
4408
        in
 
4409
        fprintf fmt "@[<1>{%a"
 
4410
          (print_if verbose)
 
4411
          (fun fmt () -> fprintf fmt "/*unspecified sequence*/@\n");
 
4412
        dofirst () seq;
 
4413
        fprintf fmt "@]}"
 
4414
    | Return(None, l) ->
 
4415
        self#pLineDirective fmt l;
 
4416
        fprintf fmt "return;"
 
4417
 
 
4418
    | Return(Some e, l) ->
 
4419
        self#pLineDirective fmt l;
 
4420
        fprintf fmt "return (%a);"
 
4421
          self#pExp  e
 
4422
 
 
4423
    | Goto (sref, _) -> begin
 
4424
        (* Grab one of the labels *)
 
4425
        let rec pickLabel = function
 
4426
            [] -> None
 
4427
          | Label (l, _, _) :: _ -> Some l
 
4428
          | _ :: rest -> pickLabel rest
 
4429
        in
 
4430
        match pickLabel !sref.labels with
 
4431
          Some l -> fprintf fmt "goto %s;" l
 
4432
        | None ->
 
4433
            ignore (error "Cannot find label for target of goto\n");
 
4434
            fprintf fmt "goto __invalid_label;"
 
4435
      end
 
4436
 
 
4437
    | Break l ->
 
4438
        self#pLineDirective fmt l;
 
4439
        fprintf fmt "break;"
 
4440
 
 
4441
    | Continue l ->
 
4442
        self#pLineDirective fmt l;
 
4443
        fprintf fmt "continue;"
 
4444
 
 
4445
    | Instr i ->
 
4446
        fprintf fmt "@[%a@]"
 
4447
          self#pInstr i
 
4448
 
 
4449
    | If(be,t,{bstmts=[];battrs=[]},l) when not miscState.printCilAsIs ->
 
4450
        fprintf fmt "%aif@[ (%a) %a"
 
4451
          (self#pLineDirective ~forcefile:false) l
 
4452
          self#pExp be
 
4453
          (self#pBlock ~toplevel:true) t
 
4454
 
 
4455
    | If(be,t,{bstmts=[{skind=Goto(gref,_);labels=[]}];
 
4456
               battrs=[]},l)
 
4457
        when !gref == next && not miscState.printCilAsIs ->
 
4458
        fprintf fmt "%aif@[ (%a) %a"
 
4459
          (self#pLineDirective ~forcefile:false) l
 
4460
          self#pExp be
 
4461
          (self#pBlock ~toplevel:true) t
 
4462
 
 
4463
    | If(be,{bstmts=[];battrs=[]},e,l) when not miscState.printCilAsIs ->
 
4464
        fprintf fmt "%aif@[ (%a) %a"
 
4465
          (self#pLineDirective ~forcefile:false) l
 
4466
          self#pExp (UnOp(LNot,be,intType))
 
4467
          (self#pBlock ~toplevel:true) e
 
4468
 
 
4469
    | If(be,{bstmts=[{skind=Goto(gref,_);labels=[]}];
 
4470
             battrs=[]},e,l)
 
4471
        when !gref == next && not miscState.printCilAsIs ->
 
4472
        fprintf fmt "%aif@[ (%a) %a"
 
4473
          (self#pLineDirective ~forcefile:false) l
 
4474
          self#pExp (UnOp(LNot,be,intType))
 
4475
          (self#pBlock ~toplevel:true) e
 
4476
 
 
4477
    | If(be,t,e,l) ->
 
4478
        fprintf fmt "%a@[@[if (%a)@ %aelse %a"
 
4479
          (self#pLineDirective ~forcefile:false) l
 
4480
          self#pExp be
 
4481
          (self#pBlock ~toplevel:true) t
 
4482
          (self#pBlock ~toplevel:true) e
 
4483
 
 
4484
    | Switch(e,b,_,l) ->
 
4485
        fprintf fmt "%a@[switch (%a) %a"
 
4486
          (self#pLineDirective ~forcefile:false) l
 
4487
          self#pExp e
 
4488
          (self#pBlock ~toplevel:true) b
 
4489
 
 
4490
    | Loop(annot, b, l, _, _) ->
 
4491
        if logic_printer_enabled then
 
4492
          pretty_list_del
 
4493
            (swap fprintf "@[@[<4>/*@@@ ")
 
4494
            (swap fprintf "@\n@]@ */@]@\n")
 
4495
            nl_sep self#pCode_annot fmt annot;
 
4496
        begin
 
4497
          (* Maybe the first thing is a conditional. Turn it into a WHILE *)
 
4498
          try
 
4499
            let term, bodystmts =
 
4500
              let rec skipEmpty = function
 
4501
                  [] -> []
 
4502
                | {skind=Instr (Skip _);labels=[]} :: rest -> skipEmpty rest
 
4503
                | x -> x
 
4504
              in
 
4505
              (* Bill McCloskey: Do not remove the If if it has labels *)
 
4506
              match skipEmpty b.bstmts with
 
4507
                {skind=If(e,tb,fb,_)} as to_skip :: rest
 
4508
                  when
 
4509
                    not miscState.printCilAsIs && self#may_be_skipped to_skip ->
 
4510
                      begin
 
4511
                        match skipEmpty tb.bstmts, skipEmpty fb.bstmts with
 
4512
                          [], {skind=Break _; labels=[]} :: _  -> e, rest
 
4513
                        | {skind=Break _; labels=[]} :: _, []
 
4514
                            -> UnOp(LNot, e, intType), rest
 
4515
                        | _ -> raise Not_found
 
4516
                      end
 
4517
              | _ -> raise Not_found
 
4518
            in
 
4519
            self#pLineDirective fmt l;
 
4520
            fprintf fmt "@[<2>while (%a) %a"
 
4521
              self#pExp term
 
4522
              (self#pBlock ~toplevel:true) {bstmts=bodystmts; battrs=b.battrs}
 
4523
 
 
4524
          with Not_found ->
 
4525
            self#pLineDirective fmt l;
 
4526
            fprintf fmt "@[<2>while (1) %a"
 
4527
              (self#pBlock ~toplevel:true) b
 
4528
        end
 
4529
 
 
4530
    | Block b -> fprintf fmt "@[%a" (self#pBlock ~toplevel:false) b
 
4531
 
 
4532
    | TryFinally (b, h, l) ->
 
4533
        self#pLineDirective fmt l;
 
4534
        fprintf fmt "__try @[%a @[<5>__finally%a"
 
4535
          (self#pBlock ~toplevel:true) b
 
4536
          (self#pBlock ~toplevel:true) h
 
4537
 
 
4538
    | TryExcept (b, (il, e), h, l) ->
 
4539
        self#pLineDirective fmt l;
 
4540
        fprintf fmt "__try @[%a __except(@\n@["
 
4541
          (self#pBlock ~toplevel:true) b;
 
4542
 
 
4543
        (* Print the instructions but with a comma at the end, instead of
 
4544
         * semicolon *)
 
4545
        printInstrTerminator <- ",";
 
4546
        fprintfList ~sep:"@\n" self#pInstr fmt il;
 
4547
        printInstrTerminator <- ";";
 
4548
        fprintf fmt "%a) @]%a"
 
4549
          self#pExp e
 
4550
          (self#pBlock ~toplevel:true) h
 
4551
 
 
4552
  (*** GLOBALS ***)
 
4553
  method pGlobal fmt (g:global) =       (* global (vars, types, etc.) *)
 
4554
    match g with
 
4555
    | GFun (fundec, l) ->
 
4556
        self#in_current_function fundec.svar;
 
4557
        (* If the function has attributes then print a prototype because
 
4558
         * GCC cannot accept function attributes in a definition *)
 
4559
        let oldattr = fundec.svar.vattr in
 
4560
        (* Always pring the file name before function declarations *)
 
4561
        (* Prototype first *)
 
4562
        if oldattr <> [] then
 
4563
          (self#pLineDirective fmt l;
 
4564
           fprintf fmt "%a;@\n"
 
4565
             self#pVDecl fundec.svar);
 
4566
        (* Temporarily remove the function attributes *)
 
4567
        fundec.svar.vattr <- [];
 
4568
        (* Body now *)
 
4569
        self#pLineDirective ~forcefile:true fmt l;
 
4570
        self#pFunDecl fmt fundec;
 
4571
        fundec.svar.vattr <- oldattr;
 
4572
        fprintf fmt "@\n";
 
4573
        self#out_current_function
 
4574
 
 
4575
 
 
4576
    | GType (typ, l) ->
 
4577
        self#pLineDirective ~forcefile:true fmt l;
 
4578
        fprintf fmt "typedef %a;@\n"
 
4579
          (self#pType (Some (fun fmt -> fprintf fmt "%s" typ.tname))) typ.ttype
 
4580
 
 
4581
    | GEnumTag (enum, l) ->
 
4582
        self#pLineDirective fmt l;
 
4583
        fprintf fmt "enum@[ %a {@\n%a@]@\n} %a;@\n"
 
4584
          self#pVarName enum.ename
 
4585
          (fprintfList ~sep:",@\n"
 
4586
             (fun fmt item ->
 
4587
                fprintf fmt "%s = %a"
 
4588
                  item.einame
 
4589
                  self#pExp item.eival))
 
4590
          enum.eitems
 
4591
          self#pAttrs enum.eattr
 
4592
 
 
4593
    | GEnumTagDecl (enum, l) -> (* This is a declaration of a tag *)
 
4594
        self#pLineDirective fmt l;
 
4595
        fprintf fmt "enum %a;@\n" self#pVarName enum.ename
 
4596
 
 
4597
    | GCompTag (comp, l) -> (* This is a definition of a tag *)
 
4598
        let n = comp.cname in
 
4599
        let su =
 
4600
          if comp.cstruct then "struct"
 
4601
          else "union"
 
4602
        in
 
4603
        let sto_mod, rest_attr = separateStorageModifiers comp.cattr in
 
4604
        self#pLineDirective ~forcefile:true fmt l;
 
4605
        fprintf fmt "@[<3>%s %a%a {@\n%a@]@\n}%a;@\n"
 
4606
          su
 
4607
          self#pAttrs sto_mod
 
4608
          self#pVarName n
 
4609
          (fprintfList ~sep:"@\n" self#pFieldDecl)
 
4610
          comp.cfields
 
4611
          self#pAttrs rest_attr
 
4612
 
 
4613
    | GCompTagDecl (comp, l) -> (* This is a declaration of a tag *)
 
4614
        self#pLineDirective fmt l;
 
4615
        fprintf fmt "%s;@\n" (compFullName comp)
 
4616
 
 
4617
    | GVar (vi, io, l) ->
 
4618
        self#pLineDirective ~forcefile:true fmt l;
 
4619
        fprintf fmt "%a"
 
4620
          self#pVDecl  vi;
 
4621
        (match io.init with
 
4622
           None -> ()
 
4623
         | Some i ->
 
4624
             fprintf fmt " = ";
 
4625
             let islong =
 
4626
               match i with
 
4627
                 CompoundInit (_, il) when List.length il >= 8 -> true
 
4628
               | _ -> false
 
4629
             in
 
4630
             if islong then
 
4631
               begin self#pLineDirective fmt l;
 
4632
                 fprintf fmt "  @[@\n"
 
4633
               end;
 
4634
             self#pInit fmt i;
 
4635
             if islong then
 
4636
               fprintf fmt "@]");
 
4637
        fprintf fmt ";@\n"
 
4638
 
 
4639
    (* print global variable 'extern' declarations, and function prototypes *)
 
4640
    | GVarDecl (funspec, vi, l) ->
 
4641
        self#opt_funspec fmt funspec;
 
4642
        if isFunctionType vi.vtype then self#in_current_function vi;
 
4643
        if not miscState.printCilAsIs && BuiltinFunctions.mem vi.vname then
 
4644
          begin
 
4645
          (* Compiler builtins need no prototypes. Just print them in
 
4646
             comments. *)
 
4647
          fprintf fmt "/* compiler builtin: @\n   %a;   */@\n"
 
4648
            self#pVDecl vi
 
4649
        end else begin
 
4650
          self#pLineDirective fmt l;
 
4651
          fprintf fmt "%a;@\n" self#pVDecl vi
 
4652
        end;
 
4653
        if isFunctionType vi.vtype then self#out_current_function
 
4654
 
 
4655
 
 
4656
    | GAsm (s, l) ->
 
4657
        self#pLineDirective fmt l;
 
4658
        fprintf fmt "__asm__(\"%s\");@\n" (escape_string s)
 
4659
 
 
4660
    | GPragma (Attr(an, args), l) ->
 
4661
        (* sm: suppress printing pragmas that gcc does not understand *)
 
4662
        (* assume anything starting with "ccured" is ours *)
 
4663
        (* also don't print the 'combiner' pragma *)
 
4664
        (* nor 'cilnoremove' *)
 
4665
        let suppress =
 
4666
          not miscState.print_CIL_Input &&
 
4667
            not theMachine.msvcMode &&
 
4668
            ((startsWith "box" an) ||
 
4669
               (startsWith "ccured" an) ||
 
4670
               (an = "merger") ||
 
4671
               (an = "cilnoremove"))
 
4672
        in
 
4673
        self#pLineDirective fmt l;
 
4674
        if suppress then fprintf fmt "/* ";
 
4675
        fprintf fmt "#pragma ";
 
4676
        begin
 
4677
          match an, args with
 
4678
          | _, [] ->
 
4679
              fprintf fmt "%s" an
 
4680
          | "weak", [ACons (varinfo, [])] ->
 
4681
              fprintf fmt "weak %s" varinfo
 
4682
          | _ ->
 
4683
              fprintf fmt "%s(%a)"
 
4684
                an
 
4685
                (fprintfList ~sep:"," self#pAttrParam) args
 
4686
 
 
4687
        end;
 
4688
        if suppress then  fprintf fmt " */@\n" else fprintf fmt "@\n"
 
4689
 
 
4690
    | GPragma (AttrAnnot _, _) ->
 
4691
        assert false
 
4692
          (*        self#pLineDirective fmt l;
 
4693
                    fprintf fmt "/* #pragma %s */@\n" a*)
 
4694
 
 
4695
    | GAnnot (decl,l) ->
 
4696
        (*if logic_printer_enabled then*)
 
4697
        begin
 
4698
          self#pLineDirective fmt l;
 
4699
          fprintf fmt "/*@@@ %a@ */@\n"
 
4700
            self#pAnnotation decl
 
4701
        end
 
4702
 
 
4703
    | GText s  ->
 
4704
        if s <> "//" then
 
4705
          fprintf fmt "%s@\n" s
 
4706
 
 
4707
  method pFieldDecl fmt fi =
 
4708
    fprintf fmt "%a %s%a;"
 
4709
      (self#pType
 
4710
         (Some (fun fmt -> if fi.fname <> missingFieldName then fprintf fmt "%s" fi.fname)))
 
4711
      fi.ftype
 
4712
      (match fi.fbitfield with
 
4713
       | None -> ""
 
4714
       | Some i -> ": " ^ string_of_int i ^ " ")
 
4715
      self#pAttrs fi.fattr
 
4716
 
 
4717
 
 
4718
  method private opt_funspec fmt funspec =
 
4719
    if logic_printer_enabled && not (is_empty_funspec funspec) then
 
4720
       fprintf fmt "/*@[@@ %a@]@\n*/@\n" self#pSpec funspec
 
4721
 
 
4722
  method private pFunDecl fmt f =
 
4723
    fprintf fmt "%a%a@\n{ @[%a@\n@\n"
 
4724
      self#opt_funspec f.sspec
 
4725
      self#pVDecl f.svar
 
4726
      (* locals. *)
 
4727
      (fprintfList ~sep:"@\n" (fun fmt vi -> fprintf fmt "%a;" self#pVDecl  vi))
 
4728
      f.slocals;
 
4729
    (* the body *)
 
4730
    (* remember the declaration *)
 
4731
    currentFormals <- f.sformals;
 
4732
    self#pBlock ~toplevel:false fmt f.sbody;
 
4733
    currentFormals <- [];
 
4734
    fprintf fmt "@\n}"
 
4735
 
 
4736
 
 
4737
  (***** PRINTING DECLARATIONS and TYPES ****)
 
4738
 
 
4739
  method pType nameOpt (* Whether we are declaring a name or
 
4740
                        * we are just printing a type *)
 
4741
    fmt (t:typ) =       (* use of some type *)
 
4742
    let name = match nameOpt with None -> (fun _ -> ()) | Some d -> d in
 
4743
    let printAttributes fmt (a: attributes) =
 
4744
      match nameOpt with
 
4745
      | None when not miscState.print_CIL_Input && not theMachine.msvcMode ->
 
4746
          (* Cannot print the attributes in this case because gcc does not
 
4747
           * like them here, except if we are printing for CIL, or for MSVC.
 
4748
           * In fact, for MSVC we MUST print attributes such as __stdcall *)
 
4749
          (* if pa = nil then nil else
 
4750
             text "/*" ++ pa ++ text "*/"*) ()
 
4751
      | _ ->  self#pAttrs fmt a
 
4752
    in
 
4753
    match t with
 
4754
      TVoid a ->
 
4755
        fprintf fmt "void%a %t"
 
4756
          self#pAttrs a
 
4757
          name
 
4758
 
 
4759
    | TInt (ikind,a) ->
 
4760
        fprintf fmt "%a%a %t"
 
4761
          d_ikind ikind
 
4762
          self#pAttrs a
 
4763
          name
 
4764
 
 
4765
    | TFloat(fkind, a) ->
 
4766
        fprintf fmt "%a%a %t"
 
4767
          d_fkind fkind
 
4768
          self#pAttrs a
 
4769
          name
 
4770
 
 
4771
    | TComp (comp, a) -> (* A reference to a struct *)
 
4772
        fprintf fmt
 
4773
          "%s %a %a%t"
 
4774
          (if comp.cstruct then "struct" else "union")
 
4775
          self#pVarName comp.cname
 
4776
          self#pAttrs a
 
4777
          name
 
4778
 
 
4779
    | TEnum (enum, a) ->
 
4780
        fprintf fmt "enum %a %a%t"
 
4781
          self#pVarName enum.ename
 
4782
          self#pAttrs a
 
4783
          name
 
4784
 
 
4785
    | TPtr (bt, a) ->
 
4786
        (* Parenthesize the ( * attr name) if a pointer to a function or an
 
4787
         * array. However, on MSVC the __stdcall modifier must appear right
 
4788
         * before the pointer constructor "(__stdcall *f)". We push them into
 
4789
         * the parenthesis. *)
 
4790
        let (paren: (formatter -> unit) option), (bt': typ) =
 
4791
          match bt with
 
4792
            TFun(rt, args, isva, fa) when theMachine.msvcMode ->
 
4793
              let an, af', at = partitionAttributes ~default:AttrType fa in
 
4794
              (* We take the af' and we put them into the parentheses *)
 
4795
              Some
 
4796
                (fun fmt ->
 
4797
                   fprintf fmt
 
4798
                     "(%a"
 
4799
                     printAttributes af'),
 
4800
              TFun(rt, args, isva, addAttributes an at)
 
4801
 
 
4802
          | TFun _ | TArray _ -> (Some (fun fmt -> fprintf fmt "(")), bt
 
4803
 
 
4804
          | _ -> None, bt
 
4805
        in
 
4806
        let name' = fun fmt ->
 
4807
          fprintf fmt "*%a%t"
 
4808
            printAttributes a
 
4809
            name
 
4810
        in
 
4811
        let name'' =
 
4812
          fun fmt ->
 
4813
            (* Put the parenthesis *)
 
4814
            match paren with
 
4815
              Some p -> fprintf fmt "%t%t)" p name'
 
4816
            | _ -> fprintf fmt "%t" name'
 
4817
        in
 
4818
        self#pType
 
4819
          (Some name'')
 
4820
          fmt
 
4821
          bt'
 
4822
 
 
4823
    | TArray (elemt, lo, a) ->
 
4824
        (* ignore the const attribute for arrays *)
 
4825
        let a' = dropAttributes [ "const" ] a in
 
4826
        let name' = fun fmt ->
 
4827
          if a' == [] then name fmt else
 
4828
            if nameOpt == None then
 
4829
              fprintf fmt
 
4830
                "%a"
 
4831
                printAttributes a'
 
4832
            else
 
4833
              fprintf fmt
 
4834
                "(%a%t)"
 
4835
                printAttributes a'
 
4836
                name
 
4837
        in
 
4838
        self#pType
 
4839
          (Some (fun fmt ->
 
4840
                   fprintf fmt "%t[%t]"
 
4841
                     name'
 
4842
                     (fun fmt ->
 
4843
                        match lo with
 
4844
                        | None -> ()
 
4845
                        | Some e ->
 
4846
                            fprintf fmt
 
4847
                              "%a"
 
4848
                              self#pExp e)
 
4849
                ))
 
4850
          fmt
 
4851
          elemt
 
4852
 
 
4853
    | TFun (restyp, args, isvararg, a) ->
 
4854
        let name' fmt =
 
4855
          if a == [] then name fmt else
 
4856
            if nameOpt == None then
 
4857
              fprintf fmt
 
4858
                "%a"
 
4859
                printAttributes a
 
4860
            else
 
4861
              fprintf fmt
 
4862
                "(%a%t)"
 
4863
                printAttributes a
 
4864
                name
 
4865
        in
 
4866
        self#pType
 
4867
          (Some
 
4868
             (fun fmt ->
 
4869
                fprintf fmt
 
4870
                  "%t(@[%t@])"
 
4871
                  name'
 
4872
                  (fun fmt -> if args = Some [] && isvararg then
 
4873
                     fprintf fmt "..."
 
4874
                   else
 
4875
                     (if args = None then ()
 
4876
                      else if args = Some [] then fprintf fmt "void"
 
4877
                      else
 
4878
                        let pArg fmt (aname, atype, aattr) =
 
4879
                          let stom, rest = separateStorageModifiers aattr in
 
4880
                          (* First the storage modifiers *)
 
4881
                          fprintf fmt
 
4882
                            "%a%a %a"
 
4883
                            self#pAttrs stom
 
4884
                            (self#pType (Some (fun fmt -> fprintf fmt "%s" aname))) atype
 
4885
                            self#pAttrs rest
 
4886
                        in
 
4887
                        (fprintfList ~sep:",@ " pArg)
 
4888
                          fmt
 
4889
                          (argsToList args) ;
 
4890
                        if isvararg then fprintf fmt "@ , ...";
 
4891
                     ))))
 
4892
          fmt
 
4893
          restyp
 
4894
 
 
4895
    | TNamed (t, a) ->
 
4896
        fprintf fmt "%a%a %t"
 
4897
          self#pVarName t.tname
 
4898
          self#pAttrs a
 
4899
          name
 
4900
 
 
4901
    | TBuiltin_va_list a ->
 
4902
        fprintf fmt "__builtin_va_list%a %t"
 
4903
          self#pAttrs a
 
4904
          name
 
4905
 
 
4906
 
 
4907
  (**** PRINTING ATTRIBUTES *********)
 
4908
  method pAttrs fmt (a: attributes) =
 
4909
    self#pAttrsGen false fmt a
 
4910
 
 
4911
 
 
4912
  (* Print one attribute. Return also an indication whether this attribute
 
4913
   * should be printed inside the __attribute__ list *)
 
4914
  method pAttr fmt = function
 
4915
      Attr(an, args) ->
 
4916
        (* Recognize and take care of some known cases *)
 
4917
        (match an, args with
 
4918
           "const", [] -> fprintf fmt "const"; false
 
4919
             (* Put the aconst inside the attribute list *)
 
4920
         | "aconst", [] when not theMachine.msvcMode ->
 
4921
             fprintf fmt "__const__"; true
 
4922
         | "thread", [] when not theMachine.msvcMode ->
 
4923
             fprintf fmt "__thread"; false
 
4924
             (*
 
4925
               | "used", [] when not !msvcMode -> text "__attribute_used__", false
 
4926
             *)
 
4927
         | "volatile", [] -> fprintf fmt "volatile"; false
 
4928
         | "restrict", [] -> fprintf fmt "__restrict"; false
 
4929
         | "missingproto", [] -> fprintf fmt "/* missing proto */"; false
 
4930
         | "cdecl", [] when theMachine.msvcMode -> fprintf fmt "__cdecl"; false
 
4931
         | "stdcall", [] when theMachine.msvcMode ->
 
4932
             fprintf fmt "__stdcall"; false
 
4933
         | "fastcall", [] when theMachine.msvcMode -> fprintf fmt "__fastcall"; false
 
4934
         | "declspec", args when theMachine.msvcMode ->
 
4935
             fprintf fmt "__declspec(%a)"
 
4936
               (fprintfList ~sep:"" self#pAttrParam) args;
 
4937
             false
 
4938
         | "w64", [] when theMachine.msvcMode -> fprintf fmt "__w64"; false
 
4939
         | "asm", args ->
 
4940
             fprintf fmt "__asm__(%a)"
 
4941
               (fprintfList ~sep:"" self#pAttrParam) args;
 
4942
             false
 
4943
               (* we suppress printing mode(__si__) because it triggers an *)
 
4944
               (* internal compiler error in all current gcc versions *)
 
4945
               (* sm: I've now encountered a problem with mode(__hi__)... *)
 
4946
               (* I don't know what's going on, but let's try disabling all "mode"..*)
 
4947
         | "mode", [ACons(tag,[])] ->
 
4948
             fprintf fmt "/* mode(%s) */" tag;
 
4949
             false
 
4950
 
 
4951
         (* sm: also suppress "format" because we seem to print it in *)
 
4952
         (* a way gcc does not like *)
 
4953
         | "format", _ -> fprintf fmt "/* format attribute */";
 
4954
             false
 
4955
 
 
4956
         (* sm: here's another one I don't want to see gcc warnings about.. *)
 
4957
         | "mayPointToStack", _ when not miscState.print_CIL_Input
 
4958
             (* [matth: may be inside another comment.]
 
4959
                -> text "/*mayPointToStack*/", false
 
4960
             *)
 
4961
             -> fprintf fmt ""; false
 
4962
 
 
4963
         | "arraylen", [a] ->
 
4964
             fprintf fmt "/*[%a]*/" self#pAttrParam a;
 
4965
             false
 
4966
 
 
4967
         | _ -> (* This is the dafault case *)
 
4968
             (* Add underscores to the name *)
 
4969
             let an' =
 
4970
               if theMachine.msvcMode then "__" ^ an else "__" ^ an ^ "__"
 
4971
             in
 
4972
             if args = [] then
 
4973
               (fprintf fmt "%s" an';
 
4974
                true)
 
4975
             else
 
4976
               (fprintf fmt "%s(%a)"
 
4977
                  an'
 
4978
                  (fprintfList ~sep:"," self#pAttrParam) args;
 
4979
                true))
 
4980
    | AttrAnnot s ->
 
4981
        fprintf fmt "%s" (mkAttrAnnot s); false
 
4982
 
 
4983
  method private pAttrPrec (contextprec: int) fmt (a: attrparam) =
 
4984
    let thisLevel = getParenthLevelAttrParam a in
 
4985
    let needParens =
 
4986
      if thisLevel >= contextprec then
 
4987
        true
 
4988
      else if contextprec == bitwiseLevel then
 
4989
        (* quiet down some GCC warnings *)
 
4990
        thisLevel == additiveLevel || thisLevel == comparativeLevel
 
4991
      else
 
4992
        false
 
4993
    in
 
4994
    if needParens then
 
4995
      fprintf fmt "(%a)" self#pAttrParam a
 
4996
    else
 
4997
      self#pAttrParam fmt a
 
4998
 
 
4999
 
 
5000
  method pAttrParam fmt a =
 
5001
    let level = getParenthLevelAttrParam a in
 
5002
    match a with
 
5003
    | AInt n -> fprintf fmt "%d" n
 
5004
    | AStr s -> fprintf fmt "\"%s\"" (escape_string s)
 
5005
    | ACons(s, []) -> fprintf fmt "%s" s
 
5006
    | ACons(s,al) ->
 
5007
        fprintf fmt "%s(%a)"
 
5008
          s
 
5009
          (fprintfList ~sep:"" self#pAttrParam) al
 
5010
    | ASizeOfE a -> fprintf fmt "sizeof(%a)" self#pAttrParam a
 
5011
    | ASizeOf t -> fprintf fmt "sizeof(%a)" (self#pType None) t
 
5012
    | ASizeOfS _ts -> fprintf fmt "sizeof(<typsig>)"
 
5013
    | AAlignOfE a -> fprintf fmt "__alignof__(%a)" self#pAttrParam a
 
5014
    | AAlignOf t -> fprintf fmt "__alignof__(%a)" (self#pType None) t
 
5015
    | AAlignOfS _ts -> fprintf fmt "__alignof__(<typsig>)"
 
5016
    | AUnOp(u,a1) ->
 
5017
        fprintf fmt "%a %a"
 
5018
          d_unop u
 
5019
          (self#pAttrPrec level) a1
 
5020
 
 
5021
    | ABinOp(b,a1,a2) ->
 
5022
        fprintf fmt "@[(%a)%a@  (%a) @]"
 
5023
          (self#pAttrPrec level) a1
 
5024
          d_binop b
 
5025
          (self#pAttrPrec level) a2
 
5026
 
 
5027
    | ADot (ap, s) ->
 
5028
        fprintf fmt "%a.%s"
 
5029
          self#pAttrParam ap
 
5030
          s
 
5031
    | AStar a1 ->
 
5032
        fprintf fmt "(*%a)"
 
5033
          (self#pAttrPrec derefStarLevel) a1
 
5034
    | AAddrOf a1 ->
 
5035
        fprintf fmt "& %a" (self#pAttrPrec addrOfLevel) a1
 
5036
    | AIndex (a1, a2) ->
 
5037
        fprintf fmt "%a[%a]"
 
5038
          self#pAttrParam a1
 
5039
          self#pAttrParam a2
 
5040
    | AQuestion (a1, a2, a3) ->
 
5041
        fprintf fmt "%a ? %a : %a"
 
5042
          self#pAttrParam a1
 
5043
          self#pAttrParam a2
 
5044
          self#pAttrParam a3
 
5045
 
 
5046
 
 
5047
  (* A general way of printing lists of attributes *)
 
5048
  method private pAttrsGen (block: bool) fmt (a: attributes) =
 
5049
    (* Scan all the attributes and separate those that must be printed inside
 
5050
     * the __attribute__ list *)
 
5051
    let rec loop (in__attr__: string list) = function
 
5052
        [] -> begin
 
5053
          match in__attr__ with
 
5054
            [] -> ()
 
5055
          | _ :: _->
 
5056
              (* sm: added 'forgcc' calls to not comment things out
 
5057
               * if CIL is the consumer; this is to address a case
 
5058
               * Daniel ran into where blockattribute(nobox) was being
 
5059
               * dropped by the merger
 
5060
               *)
 
5061
              (if block then
 
5062
                 fprintf fmt " %s __blockattribute__("
 
5063
                   (forgcc "/*")
 
5064
               else
 
5065
                 fprintf fmt "__attribute__((");
 
5066
              fprintfList ~sep:",@ "
 
5067
                (fun fmt a -> fprintf fmt "%s" a)
 
5068
                fmt
 
5069
                in__attr__;
 
5070
              fprintf fmt ")%s"
 
5071
                (if block then forgcc "*/" else ")")
 
5072
        end
 
5073
      | x :: rest ->
 
5074
          let buff = Buffer.create 17 in
 
5075
          let local_fmt = formatter_of_buffer buff in
 
5076
          let ina = self#pAttr local_fmt x in
 
5077
          pp_print_flush local_fmt ();
 
5078
          let dx = Buffer.contents buff in
 
5079
          if ina then
 
5080
            loop (dx :: in__attr__) rest
 
5081
          else if dx = "" then
 
5082
            loop in__attr__ rest
 
5083
          else
 
5084
            (fprintf fmt "%s " dx;
 
5085
             loop in__attr__ rest)
 
5086
    in
 
5087
    let a =
 
5088
      List.filter (function Attr (s,_) -> not (List.mem s reserved_attributes)
 
5089
                     | AttrAnnot _ -> true) a
 
5090
    in
 
5091
    if a <> [] then
 
5092
      begin
 
5093
        fprintf fmt " ";
 
5094
        loop [] a;
 
5095
        fprintf fmt " "
 
5096
      end
 
5097
 
 
5098
  (* Logic annotations printer *)
 
5099
 
 
5100
  method pLogic_type fmt = function
 
5101
    | Ctype typ -> self#pType None fmt typ
 
5102
    | Linteger -> pp_print_string fmt "integer"
 
5103
    | Lreal -> pp_print_string fmt "real"
 
5104
    | Ltype (s,l) ->
 
5105
        fprintf fmt "%a%a" self#pVarName s
 
5106
          (pretty_list_del (fun fmt -> fprintf fmt "<@[")
 
5107
             (fun fmt -> fprintf fmt "@]>@ ")
 
5108
             (* the space avoids the issue of list<list<int>> where the double >
 
5109
                would be read as a shift. It could be optimized away in most of
 
5110
                the cases.
 
5111
             *)
 
5112
             (space_sep ",") self#pLogic_type) l
 
5113
    | Larrow (args,rt) ->
 
5114
        fprintf fmt "@[@[<2>{@ %a@]@}@]%a"
 
5115
          (pretty_list (space_sep ",") self#pLogic_type) args
 
5116
          self#pLogic_type rt
 
5117
    | Lvar s -> fprintf fmt "%a" self#pVarName s
 
5118
 
 
5119
  method pTsets_lval fmt (h,o) =
 
5120
    match h,o with
 
5121
        TSMem t, TSField (f,o) ->
 
5122
          fprintf fmt "%a->@,%a@,%a"
 
5123
            (self#pTsets_elemPrec arrowLevel) t
 
5124
             self#pVarName f.fname self#pTsets_offset o
 
5125
      | _ -> fprintf fmt "@[%a%a@]" self#pTsets_lhost h self#pTsets_offset o
 
5126
 
 
5127
  method private pTsets_elemPrec contextprec fmt e =
 
5128
    let thisLevel = getParenthLevelTsetsElem e in
 
5129
    let needParens =
 
5130
      if thisLevel >= contextprec then true
 
5131
      else if contextprec == bitwiseLevel then
 
5132
        (* quiet down some GCC warnings *)
 
5133
        thisLevel == additiveLevel || thisLevel == comparativeLevel
 
5134
      else
 
5135
        false
 
5136
    in
 
5137
    if needParens then
 
5138
      fprintf fmt "@[<hov 1>(%a)@]" self#pTsets_elem e
 
5139
    else
 
5140
      self#pTsets_elem fmt e
 
5141
 
 
5142
  method pTsets_elem fmt lv =
 
5143
    let level = getParenthLevelTsetsElem lv in
 
5144
    match lv with
 
5145
        TSLval lv | TSStartOf lv -> self#pTsets_lval fmt lv
 
5146
          (*TODO: take into account priority in ts_lvals *)
 
5147
      | TSAddrOf lv -> fprintf fmt "&%a" self#pTsets_lval lv
 
5148
      | TSConst s ->  d_const fmt s
 
5149
      | TSAdd_range(t,low,high) ->
 
5150
          fprintf fmt "@[%a@ +@ (@[%a..@,%a@])@]"
 
5151
            (self#pTsets_elemPrec level) t
 
5152
            (pretty_opt
 
5153
               (fun fmt t -> fprintf fmt "%a@ " self#pTerm t)) low
 
5154
            (pretty_opt
 
5155
               (fun fmt t ->fprintf fmt "@ %a" self#pTerm t)) high
 
5156
      | TSAdd_index(t,i) ->
 
5157
          fprintf fmt "@[%a@ +@ %a@]"
 
5158
            (self#pTsets_elemPrec level) t
 
5159
            (self#pTermPrec level) i
 
5160
      | TSCastE(typ,elem) ->
 
5161
          fprintf fmt "@[(%a)@,%a@]"
 
5162
            (self#pType None) typ (self#pTsets_elemPrec level) elem
 
5163
      | TSat(l,lab) ->
 
5164
          fprintf fmt "@[<hov 2>\\at(%a,%a)@]"
 
5165
            self#pTsets_elem l self#pLogicLabel lab
 
5166
      | TSapp(f,labs,args) ->
 
5167
          fprintf fmt "@[<hov 2>%a@,%a@,%a@]"
 
5168
            self#pLogic_info_use f
 
5169
            (pretty_list_del
 
5170
               (fun fmt -> pp_print_string fmt "<")
 
5171
               (fun fmt -> pp_print_string fmt ">")
 
5172
               (space_sep ",")
 
5173
               (fun fmt (_,y) -> self#pLogicLabel fmt y)) labs
 
5174
            (pretty_list_del
 
5175
               (fun fmt -> pp_print_string fmt "(")
 
5176
               (fun fmt -> pp_print_string fmt ")")
 
5177
               (space_sep ",") self#pTerm) args
 
5178
 
 
5179
  method pTsets_lhost fmt h =
 
5180
    match h with
 
5181
      | TSVar lv -> self#pLogic_var fmt lv
 
5182
      | TSResult -> pp_print_string fmt "\\result"
 
5183
      | TSMem (TSAdd_index(t,i)) ->
 
5184
          fprintf fmt "@[<2>%a[%a]@]"
 
5185
            (self#pTsets_elemPrec derefStarLevel) t
 
5186
            self#pTerm i
 
5187
      | TSMem (TSAdd_range(t,low,high)) ->
 
5188
          fprintf fmt "@[<2>%a[%a..%a]@]"
 
5189
            (self#pTsets_elemPrec derefStarLevel) t
 
5190
            (pretty_opt self#pTerm) low
 
5191
            (pretty_opt self#pTerm) high
 
5192
      | TSMem t -> fprintf fmt "@[<1>*%a@]"
 
5193
          (self#pTsets_elemPrec derefStarLevel) t
 
5194
 
 
5195
  method pTsets_offset fmt o =
 
5196
    match o with
 
5197
      | TSNoOffset -> ()
 
5198
      | TSIndex (t,o) ->
 
5199
          fprintf fmt "@,@[<1>[%a]@]%a" self#pTerm t self#pTsets_offset o
 
5200
      | TSRange (t1,t2,o) ->
 
5201
          fprintf fmt "@,@[<1>[%a..%a]@]%a"
 
5202
            (pretty_opt self#pTerm) t1
 
5203
            (pretty_opt self#pTerm) t2
 
5204
            self#pTsets_offset o
 
5205
      | TSField(f,o) ->
 
5206
          fprintf fmt "@,@[<1>.%a@]%a"
 
5207
            self#pVarName f.fname self#pTsets_offset o
 
5208
 
 
5209
  method pTsets fmt loc = (* to be rewritten *)
 
5210
    match loc with
 
5211
    | TSSingleton t -> self#pTsets_elem fmt t
 
5212
    | TSUnion locs ->
 
5213
        fprintf fmt "@[<hov 2>\\union(@,%a)@]"
 
5214
          (pretty_list (space_sep ",") self#pTsets) locs
 
5215
    | TSInter locs ->
 
5216
        fprintf fmt "@[<hov 2>\\inter(@,%a)@]"
 
5217
          (pretty_list (space_sep ",") self#pTsets) locs
 
5218
    | TSEmpty -> pp_print_string fmt "\\empty"
 
5219
    | TSComprehension(lv,quant,pred) ->
 
5220
        fprintf fmt "{@[%a@ |@ %a%a@]}"
 
5221
          self#pTsets lv self#pQuantifiers quant
 
5222
          (pretty_opt (fun fmt p -> fprintf fmt ";@ %a"
 
5223
                                 self#pPredicate_named p))
 
5224
          pred
 
5225
 
 
5226
  method private pTermPrec contextprec fmt e =
 
5227
    let thisLevel = getParenthLevelLogic e.term_node in
 
5228
    let needParens =
 
5229
      if thisLevel >= contextprec then
 
5230
        true
 
5231
      else if contextprec == bitwiseLevel then
 
5232
        (* quiet down some GCC warnings *)
 
5233
        thisLevel == additiveLevel || thisLevel == comparativeLevel
 
5234
      else
 
5235
        false
 
5236
    in
 
5237
    if needParens then
 
5238
      fprintf fmt "@[<hov 2>(%a)@]" self#pTerm e
 
5239
    else
 
5240
      self#pTerm fmt e
 
5241
 
 
5242
  method pTerm fmt t =
 
5243
    match t.term_name with
 
5244
      [] -> self#pTerm_node fmt t
 
5245
    | _ ->
 
5246
        fprintf fmt "(@[%a:@ %a@])"
 
5247
          (pretty_list (swap fprintf ":@ ") pp_print_string) t.term_name
 
5248
          self#pTerm_node t
 
5249
 
 
5250
  method pTerm_node fmt t =
 
5251
    let current_level = getParenthLevelLogic t.term_node in
 
5252
     match t.term_node with
 
5253
    | TConst s -> fprintf fmt "%a" d_const s
 
5254
    | TDataCons(ci,args) ->
 
5255
        fprintf fmt "%a%a" self#pVarName ci.ctor_name
 
5256
          (pretty_list_del (swap fprintf "(@[") (swap fprintf "@])")
 
5257
             (space_sep ",") self#pTerm) args
 
5258
    | TLval lv -> fprintf fmt "%a" (self#pTerm_lvalPrec current_level) lv
 
5259
    | TSizeOf t -> fprintf fmt "sizeof(%a)" (self#pType None) t
 
5260
    | TSizeOfE e -> fprintf fmt "sizeof(%a)" self#pTerm e
 
5261
    | TSizeOfStr s -> fprintf fmt "sizeof(%S)" s
 
5262
    | TAlignOf e -> fprintf fmt "alignof(%a)" (self#pType None) e
 
5263
    | TAlignOfE e -> fprintf fmt "alignof(%a)" self#pTerm e
 
5264
    | TUnOp (op,e) -> fprintf fmt "%a%a"
 
5265
        d_unop op (self#pTermPrec current_level) e
 
5266
    | TBinOp (op,l,r) ->
 
5267
        fprintf fmt "%a%a%a"
 
5268
          (self#pTermPrec current_level) l
 
5269
          d_term_binop op
 
5270
          (self#pTermPrec current_level) r
 
5271
    | TCastE (ty,e) ->
 
5272
        fprintf fmt "(%a)%a" (self#pType None) ty
 
5273
          (self#pTermPrec current_level) e
 
5274
    | TAddrOf lv -> fprintf fmt "&%a" (self#pTerm_lvalPrec addrOfLevel) lv
 
5275
    | TStartOf lv -> fprintf fmt "%a" (self#pTerm_lvalPrec current_level) lv
 
5276
    | Tapp (f, labels, tl) -> fprintf fmt "%a%a%a"
 
5277
        self#pLogic_info_use f
 
5278
          self#pLabels (List.map snd labels)
 
5279
          (pretty_list_del
 
5280
             (fun fmt -> Format.fprintf fmt "@[(")
 
5281
             (fun fmt -> Format.fprintf fmt ")@]")
 
5282
             (space_sep ",") self#pTerm) tl
 
5283
    | Tif (cond,th,el) ->
 
5284
        fprintf fmt "@[<2>%a?@;%a:@;%a@]"
 
5285
          (self#pTermPrec current_level) cond
 
5286
          (self#pTermPrec current_level) th
 
5287
          (self#pTermPrec current_level) el
 
5288
    | Told e -> fprintf fmt "\\old(%a)" self#pTerm e
 
5289
    | Tat (t,lab) ->
 
5290
        begin
 
5291
          let rec pickLabel = function
 
5292
            | [] -> None
 
5293
            | Label (l, _, _) :: _ -> Some l
 
5294
            | _ :: rest -> pickLabel rest
 
5295
          in
 
5296
          let l = match lab with
 
5297
            | LogicLabel s -> s
 
5298
            | StmtLabel sref ->
 
5299
                match pickLabel !sref.labels with
 
5300
                    Some l -> l
 
5301
                  | None ->
 
5302
                      error "Cannot find label for \\at@.";
 
5303
                      "__invalid_label__"
 
5304
          in
 
5305
          fprintf fmt "@[\\at(@[@[%a@],@,@[%s@]@])@]" self#pTerm t l
 
5306
        end
 
5307
    | Tbase_addr t -> fprintf fmt "\\base_addr(%a)" self#pTerm t
 
5308
    | Tblock_length t -> fprintf fmt "\\block_length(%a)" self#pTerm t
 
5309
    | Tnull -> fprintf fmt "\\null"
 
5310
    | TCoerce (e,ty) ->
 
5311
        fprintf fmt "%a@ :>@ %a"
 
5312
          (self#pTermPrec current_level) e (self#pType None) ty
 
5313
    | TCoerceE (e,ce) ->
 
5314
        fprintf fmt "%a :> %a"
 
5315
          (self#pTermPrec current_level) e (self#pTermPrec current_level) ce
 
5316
    | TUpdate (t,f,v) ->
 
5317
        fprintf fmt "{%a for %s = %a}"
 
5318
          self#pTerm t
 
5319
          f.fname
 
5320
          self#pTerm v
 
5321
    | Tlambda(prms,expr) ->
 
5322
        fprintf fmt "@[<2>\\lambda@ %a;@ %a@]"
 
5323
          self#pQuantifiers prms (self#pTermPrec current_level) expr
 
5324
    | Ttypeof t -> fprintf fmt "\\typeof(%a)" self#pTerm t
 
5325
    | Ttype ty -> fprintf fmt "\\type(%a)" (self#pType None) ty
 
5326
    | Ttsets tsets ->
 
5327
        self#pTsets fmt tsets
 
5328
 
 
5329
  method private pTerm_lvalPrec contextprec fmt lv =
 
5330
    if getParenthLevelLogic (TLval lv) > contextprec then
 
5331
      fprintf fmt "(%a)" self#pTerm_lval lv
 
5332
    else
 
5333
      fprintf fmt "%a" self#pTerm_lval lv
 
5334
 
 
5335
  method pTerm_lval fmt lv = match lv with
 
5336
  | TVar vi, o -> fprintf fmt "%a%a" self#pLogic_var vi self#pTerm_offset o
 
5337
  | TResult, o -> fprintf fmt "\\result%a" self#pTerm_offset o
 
5338
  | TMem ({term_node=TBinOp((PlusPI|IndexPI),base,off)}), o ->
 
5339
      fprintf fmt "%a[%a]%a"
 
5340
        (self#pTermPrec derefStarLevel) base
 
5341
        self#pTerm off
 
5342
        self#pTerm_offset o
 
5343
  | TMem e, TField(fi,o) ->
 
5344
      fprintf fmt "%a->%a%a" (self#pTermPrec arrowLevel) e
 
5345
        self#pVarName fi.fname self#pTerm_offset o
 
5346
  | TMem e, TNoOffset ->
 
5347
      fprintf fmt "*%a" (self#pTermPrec derefStarLevel) e
 
5348
  | TMem e, o ->
 
5349
      fprintf fmt "(*%a)%a"
 
5350
        (self#pTermPrec derefStarLevel) e self#pTerm_offset o
 
5351
 
 
5352
  method pTerm_offset fmt o = match o with
 
5353
  | TNoOffset -> ()
 
5354
  | TField (fi,o) ->
 
5355
      fprintf fmt ".%a%a" self#pVarName fi.fname self#pTerm_offset o
 
5356
  | TIndex(e,o) -> fprintf fmt "[%a]%a" self#pTerm e self#pTerm_offset o
 
5357
 
 
5358
  method pLogic_info_use fmt li = self#pVarName fmt li.l_name
 
5359
 
 
5360
  method pLogic_var fmt v = self#pVarName fmt v.lv_name
 
5361
 
 
5362
  method pQuantifiers fmt l =
 
5363
    pretty_list (space_sep ",")
 
5364
      (fun fmt lv ->
 
5365
         fprintf fmt "%a@ %a" self#pLogic_type lv.lv_type self#pLogic_var lv)
 
5366
      fmt l
 
5367
 
 
5368
  method pPredicate fmt p =
 
5369
    (* TODO: get a real priority level for predicates and use it to
 
5370
       pretty_print subterms.
 
5371
    *)
 
5372
    let term = self#pTermPrec logic_level in
 
5373
    match p with
 
5374
    | Pfalse -> fprintf fmt "\\false"
 
5375
    | Ptrue -> fprintf fmt "\\true"
 
5376
    | Papp (p,labels,l) -> fprintf fmt "@[%a%a%a@]"
 
5377
        self#pLogic_info_use p
 
5378
          self#pLabels (List.map snd labels)
 
5379
          (pretty_list_del
 
5380
             (fun fmt -> Format.fprintf fmt "@[(")
 
5381
             (fun fmt -> Format.fprintf fmt ")@]")
 
5382
             (space_sep ",") self#pTerm) l
 
5383
    | Prel (rel,l,r) ->
 
5384
        fprintf fmt "@[(@[%a@]@ %a@ @[%a@])@]" term l d_relation rel term r
 
5385
    | Pand (p1, p2) ->
 
5386
        fprintf fmt "@[(@[%a@]@ %a@ @[%a@])@]"
 
5387
          self#pPredicate_named p1
 
5388
          d_term_binop LAnd
 
5389
          self#pPredicate_named p2
 
5390
    | Por (p1, p2) ->
 
5391
        fprintf fmt "@[(@[%a@]@ %a@ @[%a@])@]"
 
5392
          self#pPredicate_named p1
 
5393
          d_term_binop LOr
 
5394
          self#pPredicate_named p2
 
5395
    | Pxor (p1, p2) ->
 
5396
        fprintf fmt "@[(@[%a@]@ %s@ @[%a@])@]"
 
5397
          self#pPredicate_named p1
 
5398
          (if !print_utf8 then Utf8_logic.x_or else "^^")
 
5399
          self#pPredicate_named p2
 
5400
    | Pimplies (p1,p2) ->
 
5401
        fprintf fmt "@[(@[%a@]@ %s@ @[%a@])@]"
 
5402
          self#pPredicate_named p1
 
5403
          (if !print_utf8 then Utf8_logic.implies else "==>")
 
5404
          self#pPredicate_named p2
 
5405
    | Piff (p1,p2) ->
 
5406
        fprintf fmt "@[(@[%a@]@ %s@ @[%a@])@]"
 
5407
          self#pPredicate_named p1
 
5408
          (if !print_utf8 then Utf8_logic.iff else "<==>")
 
5409
          self#pPredicate_named p2
 
5410
    | Pnot a -> fprintf fmt "@[%s(@[%a@])@]"
 
5411
        (if !print_utf8 then Utf8_logic.neg else "!")
 
5412
          self#pPredicate_named a
 
5413
    | Pif (e, p1, p2) ->
 
5414
        fprintf fmt "@[<2>(%a?@ %a:@ %a)@]"
 
5415
          term e self#pPredicate_named p1 self#pPredicate_named p2
 
5416
    | Plet (v, t, p) ->
 
5417
        fprintf fmt "@[(@[let %a =@]@ @[%a@]@ @[in %a@])@]"
 
5418
          self#pLogic_var v term t self#pPredicate_named p
 
5419
    | Pforall (quant,pred) ->
 
5420
        fprintf fmt "@[(@[%s %a;@]@ %a)@]"
 
5421
          (if !print_utf8 then Utf8_logic.forall else "\\forall")
 
5422
          self#pQuantifiers quant self#pPredicate_named pred
 
5423
    | Pexists (quant,pred) ->
 
5424
        fprintf fmt "@[(@[%s %a;@]@ %a)@]"
 
5425
          (if !print_utf8 then  Utf8_logic.exists else "\\exists")
 
5426
          self#pQuantifiers quant self#pPredicate_named pred
 
5427
    | Pold a ->  fprintf fmt "@[\\old(@[%a@])@]" self#pPredicate_named a
 
5428
    | Pvalid p ->  fprintf fmt "@[\\valid(@[%a@])@]" self#pTsets p
 
5429
    | Pseparated seps ->
 
5430
        fprintf fmt "@[<2>\\separated(@,%a@,)@]"
 
5431
          (pretty_list (space_sep ",") self#pTsets) seps
 
5432
    | Pat (p,StmtLabel sref) ->
 
5433
        begin
 
5434
          let rec pickLabel = function
 
5435
            | [] -> None
 
5436
            | Label (l, _, _) :: _ -> Some l
 
5437
            | _ :: rest -> pickLabel rest
 
5438
          in
 
5439
          let l = match pickLabel !sref.labels with
 
5440
            Some l -> l
 
5441
          | None ->
 
5442
              error "Cannot find label for \\at@.";
 
5443
              assert false
 
5444
 
 
5445
          in
 
5446
          fprintf fmt "@[\\at(@[@[%a@],@,@[%s@]@])@]"
 
5447
            self#pPredicate_named p l
 
5448
        end
 
5449
    | Pat(p,LogicLabel s) ->
 
5450
        fprintf fmt "@[\\at(@[@[%a@],@,%s@])@]"
 
5451
          self#pPredicate_named p s
 
5452
    | Pfresh e -> fprintf fmt "@[\\fresh(@[%a@])@]" self#pTerm e
 
5453
    | Pvalid_index (e1,e2) ->
 
5454
        fprintf fmt "@[\\valid_index(@[@[%a@],@,@[%a@]@])@]"
 
5455
          self#pTerm e1 self#pTerm e2
 
5456
    | Pvalid_range (e1,e2,e3) ->
 
5457
        fprintf fmt "@[\\valid_range(@[@[%a@],@,@[%a@],@,@[%a@]@])@]"
 
5458
          self#pTerm e1 self#pTerm e2 self#pTerm e3
 
5459
    | Psubtype (e,ce) ->
 
5460
        fprintf fmt "%a <: %a" term e term ce
 
5461
 
 
5462
  method pPredicate_named fmt p =
 
5463
    match p.name with
 
5464
      [] -> self#pPredicate fmt p.content
 
5465
    | _ ->
 
5466
        fprintf fmt "(@[%a:@ %a@])"
 
5467
          (pretty_list (swap fprintf ":@ ") pp_print_string) p.name
 
5468
          self#pPredicate p.content
 
5469
 
 
5470
(*
 
5471
  method pPredicate_info_use fmt pi = self#pVarName fmt pi.p_name
 
5472
*)
 
5473
 
 
5474
  method private preds kw fmt l =
 
5475
    pretty_list_del ignore nl_sep nl_sep
 
5476
      (fun fmt p ->
 
5477
         fprintf fmt "@[%s @[%a@];@]" kw
 
5478
           self#pPredicate_named
 
5479
           ({name = p.ip_name; loc = p.ip_loc; content = p.ip_content})) fmt l
 
5480
 
 
5481
  method private pDecrement kw fmt (t, rel) =
 
5482
    match rel with
 
5483
      None -> fprintf fmt "@[<2>%s@ %a;@]@\n" kw self#pTerm t
 
5484
    | Some str ->
 
5485
        (*TODO: replace this string with an interpreted variable*)
 
5486
        fprintf fmt "@[<2>%s@ %a@ for@ %s;@]@\n" kw self#pTerm t str
 
5487
 
 
5488
  method pBehavior fmt b =
 
5489
    fprintf fmt "@[behavior %s:@\n  @[%a%a%a@]@]"
 
5490
      b.b_name (self#preds "assumes") b.b_assumes
 
5491
      (self#preds "ensures") b.b_ensures
 
5492
      (pretty_list (fun _ -> ()) (self#pAssigns "assigns")) b.b_assigns
 
5493
 
 
5494
  method pSpec fmt { spec_requires = requires;
 
5495
                     spec_behavior = behaviors;
 
5496
                     spec_variant = variant;
 
5497
                     spec_terminates = terminates;
 
5498
                     spec_complete_behaviors = complete;
 
5499
                     spec_disjoint_behaviors = disjoint;
 
5500
                   } =
 
5501
    fprintf fmt "@[%a%a%a%a%a%a@]"
 
5502
      (self#preds "requires") requires
 
5503
      (pretty_opt
 
5504
         (fun fmt p -> fprintf fmt "@[<2>terminates@ %a;@]@\n"
 
5505
            self#pPredicate_named {name = p.ip_name; loc = p.ip_loc;
 
5506
                                   content = p.ip_content})) terminates
 
5507
      (pretty_list nl_sep self#pBehavior) behaviors
 
5508
      (pretty_list_del nl_sep nl_sep nl_sep
 
5509
         (pretty_list_del
 
5510
            (space_sep "complete behaviors")
 
5511
            (space_sep ";")
 
5512
            (space_sep ",")
 
5513
            Format.pp_print_string)) complete
 
5514
      (pretty_list_del nl_sep nl_sep nl_sep
 
5515
         (pretty_list_del
 
5516
            (space_sep "disjoint behaviors")
 
5517
            (space_sep ";")
 
5518
            (space_sep ",")
 
5519
            Format.pp_print_string)) disjoint
 
5520
      (pretty_opt (self#pDecrement "decreases")) variant
 
5521
 
 
5522
  method private pAssigns kw fmt (base,deps) =
 
5523
    fprintf fmt "@[%s@ %a%a;@]@\n" kw self#pZone base
 
5524
      (pretty_list_del (swap fprintf "@ \\from@ ") (fun _ -> ())
 
5525
         (space_sep ",") self#pZone) deps
 
5526
 
 
5527
  method pZone fmt locs =
 
5528
    match locs with
 
5529
    | Nothing ->
 
5530
        pp_print_string fmt "\\nothing"
 
5531
    | Location loc -> self#pTsets fmt loc.its_content
 
5532
 
 
5533
  method private pLoop_pragma fmt = function
 
5534
      | Widen_hints terms -> fprintf fmt "WIDEN_HINTS @[%a@]"
 
5535
          (pretty_list_del
 
5536
             (fun _ -> ()) (fun _ -> ())
 
5537
             (space_sep ",") self#pTerm) terms
 
5538
      | Widen_variables terms -> fprintf fmt "WIDEN_VARIABLES @[%a@]"
 
5539
          (pretty_list_del
 
5540
             (fun _ -> ()) (fun _ -> ())
 
5541
             (space_sep ",") self#pTerm) terms
 
5542
      | Unroll_level t -> fprintf fmt "UNROLL @[%a@]" self#pTerm t
 
5543
 
 
5544
  method private pSlice_pragma fmt = function
 
5545
      SPexpr t ->
 
5546
        fprintf fmt "expr @[%a@]" self#pTerm t
 
5547
    | SPctrl -> pp_print_string fmt "ctrl"
 
5548
    | SPstmt -> pp_print_string fmt "stmt"
 
5549
 
 
5550
  method private pImpact_pragma fmt = function
 
5551
  | IPexpr t -> fprintf fmt "expr @[%a@]" self#pTerm t
 
5552
  | IPstmt -> pp_print_string fmt "stmt"
 
5553
 
 
5554
  method pStatus fmt s =
 
5555
    match s.status with
 
5556
    | Unknown -> fprintf fmt "No proof attempted@\n"
 
5557
    | Checked {emitter=s; valid=True} ->
 
5558
        fprintf fmt "Valid according to %s@\n" s
 
5559
    | Checked {emitter=s; valid=False} ->
 
5560
        fprintf fmt "NOT valid according to %s@\n" s
 
5561
    | Checked {emitter=s; valid=Maybe} ->
 
5562
        fprintf fmt "Unknown (%s could not decide the status for this property)@\n" s
 
5563
 
 
5564
  (* TODO: add the annot ID in debug mode?*)
 
5565
  method pCode_annot fmt ca =
 
5566
    match ca.annot_content with
 
5567
    | AAssert (behav,p,_status) -> fprintf fmt "@[%aassert@ %a;@]@\n"
 
5568
        (pretty_list_del
 
5569
           (fun fmt -> fprintf fmt "for ") (fun fmt -> fprintf fmt ": ")
 
5570
           (space_sep ",") pp_print_string)
 
5571
          behav
 
5572
          self#pPredicate_named p
 
5573
    | AAssume p -> fprintf fmt "@[assume@ %a;@]@\n"
 
5574
        self#pPredicate_named p
 
5575
    | APragma (Slice_pragma sp) ->
 
5576
        fprintf fmt "@[slice pragma@ %a;@]@\n" self#pSlice_pragma sp
 
5577
    | APragma (Impact_pragma sp) ->
 
5578
        fprintf fmt "@[impact pragma@ %a;@]@\n" self#pImpact_pragma sp
 
5579
    | APragma (Loop_pragma lp) ->
 
5580
        fprintf fmt "@[loop pragma@ %a;@]@\n" self#pLoop_pragma lp
 
5581
    | AStmtSpec sp -> self#pSpec fmt sp
 
5582
    | AAssigns a -> self#pAssigns "loop assigns" fmt a
 
5583
    | AInvariant(behav,true, i) -> fprintf fmt "@[<2>%aloop invariant@ %a;@]@\n"
 
5584
        (pretty_list_del
 
5585
           (fun fmt -> fprintf fmt "for ") (fun fmt -> fprintf fmt ": ")
 
5586
           (space_sep ",") pp_print_string)
 
5587
          behav
 
5588
          self#pPredicate_named i
 
5589
    | AInvariant(behav,false,i) -> fprintf fmt "@[<2>%ainvariant@ %a;@]@\n"
 
5590
        (pretty_list_del
 
5591
           (fun fmt -> fprintf fmt "for ") (fun fmt -> fprintf fmt ": ")
 
5592
           (space_sep ",") pp_print_string)
 
5593
          behav
 
5594
          self#pPredicate_named i
 
5595
    | AVariant v -> self#pDecrement "loop variant" fmt v
 
5596
 
 
5597
  method private pLogicPrms fmt arg =
 
5598
    fprintf fmt "%a@ %a" self#pLogic_type arg.lv_type self#pLogic_var arg
 
5599
 
 
5600
  method private pTypeParameters fmt tvars =
 
5601
    pretty_list_del
 
5602
      (fun fmt -> fprintf fmt "<@[") (fun fmt -> fprintf fmt "@]>")
 
5603
      (space_sep ",") pp_print_string fmt tvars
 
5604
 
 
5605
  method private pLogicLabel fmt lab =
 
5606
    let s =
 
5607
      match lab with
 
5608
        | LogicLabel s -> s
 
5609
        | StmtLabel sref ->
 
5610
            let rec pickLabel = function
 
5611
                [] -> None
 
5612
              | Label (l, _, _) :: _ -> Some l
 
5613
              | _ :: rest -> pickLabel rest
 
5614
            in
 
5615
            match pickLabel !sref.labels with
 
5616
                Some l -> l
 
5617
              | None -> "__invalid_label"
 
5618
    in pp_print_string fmt s
 
5619
 
 
5620
  method private pLabels fmt labels =
 
5621
    pretty_list_del
 
5622
      (fun fmt -> fprintf fmt "{@[") (fun fmt -> fprintf fmt "@]}")
 
5623
      (space_sep ",") self#pLogicLabel fmt labels
 
5624
 
 
5625
  method pAnnotation fmt = function
 
5626
    | Dtype_annot a ->
 
5627
        fprintf fmt "@[type invariant @[%a%a=@ %a@,;@]@]@\n"
 
5628
          self#pVarName a.l_name
 
5629
          (pretty_list_del
 
5630
             (fun fmt -> Format.fprintf fmt "@[(")
 
5631
             (fun fmt -> Format.fprintf fmt ")@]@ ")
 
5632
             (space_sep ",") self#pLogicPrms) a.l_profile
 
5633
          self#pPredicate_named (pred_body a.l_body)
 
5634
    | Dinvariant pred ->
 
5635
        fprintf fmt "@[global@ invariant %a:@[@ %a;@]@]@\n"
 
5636
          self#pVarName pred.l_name
 
5637
          self#pPredicate_named (pred_body pred.l_body)
 
5638
    | Dlemma(name, is_axiom, labels, tvars, pred) ->
 
5639
        fprintf fmt "@[%s@ %a%a%a:@[@ %a;@]@]@\n"
 
5640
          (if is_axiom then "axiom" else "lemma")
 
5641
          self#pVarName name
 
5642
          self#pLabels labels
 
5643
          self#pTypeParameters tvars
 
5644
          self#pPredicate_named pred
 
5645
    | Dtype(name,prms) ->
 
5646
        fprintf fmt "@[logic@ type@ %a%a;@]@\n"
 
5647
          self#pVarName name self#pTypeParameters prms
 
5648
    | Dfun_or_pred li ->
 
5649
        begin
 
5650
          match li.l_type with
 
5651
            | Some rt ->
 
5652
                fprintf fmt "@[<hov 2>logic %a"
 
5653
                  self#pLogic_type rt
 
5654
            | None ->
 
5655
                fprintf fmt "@[<hov 2>predicate"
 
5656
        end;
 
5657
        fprintf fmt " %a%a%a%a"
 
5658
          self#pVarName li.l_name
 
5659
          self#pLabels li.l_labels
 
5660
          self#pTypeParameters li.l_tparams
 
5661
          (pretty_list_del
 
5662
             (fun fmt -> Format.fprintf fmt "@[(")
 
5663
             (fun fmt -> Format.fprintf fmt ")@]@ ")
 
5664
             (space_sep ",") self#pLogicPrms) li.l_profile;
 
5665
        begin
 
5666
          match li.l_body with
 
5667
            | LBreads reads ->
 
5668
                fprintf fmt "%a;"
 
5669
                  (pretty_list_del
 
5670
                     (fun fmt -> Format.fprintf fmt "@\n@[reads@ ")
 
5671
                     (fun fmt -> Format.fprintf fmt "@]")
 
5672
                     (space_sep ",") self#pTsets) reads
 
5673
            | LBpred def ->
 
5674
                fprintf fmt "=@ %a;"
 
5675
                  self#pPredicate_named def
 
5676
(*
 
5677
            | LBaxiomatic axioms ->
 
5678
                fprintf fmt "{@ %a}"
 
5679
                  (pretty_list_del
 
5680
                     (fun fmt -> Format.fprintf fmt "@[<v 0>")
 
5681
                     (fun fmt -> Format.fprintf fmt "@]@\n")
 
5682
                     nl_sep
 
5683
                     (fun fmt (id,p) ->
 
5684
                        Format.fprintf fmt "axiom %s: %a;" id
 
5685
                          self#pPredicate_named p)) axioms
 
5686
*)
 
5687
            | LBinductive indcases ->
 
5688
                fprintf fmt "{@ %a}"
 
5689
                  (pretty_list_del
 
5690
                     (fun fmt -> Format.fprintf fmt "@[<v 0>")
 
5691
                     (fun fmt -> Format.fprintf fmt "@]@\n")
 
5692
                     nl_sep
 
5693
                     (fun fmt (id,labels,tvars,p) ->
 
5694
                        Format.fprintf fmt "case %s%a%a: %a;" id
 
5695
                          self#pLabels labels
 
5696
                          self#pTypeParameters tvars
 
5697
                          self#pPredicate_named p)) indcases
 
5698
            | LBterm def ->
 
5699
                fprintf fmt "=@ %a;"
 
5700
                  self#pTerm def
 
5701
        end;
 
5702
        fprintf fmt "@]@\n"
 
5703
    | Daxiomatic(id,decls) ->
 
5704
(*
 
5705
        Format.eprintf "cil.pAnnotation on axiomatic %s@." id;
 
5706
*)
 
5707
        fprintf fmt "@[<v 2>axiomatic@ %s {@\n%a@]}@]@\n" id
 
5708
          (pretty_list_del
 
5709
             (fun fmt -> Format.fprintf fmt "@[<v 0>")
 
5710
             (fun fmt -> Format.fprintf fmt "@]@\n")
 
5711
             nl_sep
 
5712
             self#pAnnotation)
 
5713
          decls
 
5714
 
 
5715
 
 
5716
(*
 
5717
    | Dlogic_reads (name, tvars, args, rt, reads) ->
 
5718
        fprintf fmt "@[logic %a %a%a%a%a%a;@]@\n"
 
5719
          self#pLogic_type rt self#pVarName name.l_name
 
5720
          self#pLabels name.l_labels
 
5721
          self#pTypeParameters tvars
 
5722
          (pretty_list_del
 
5723
             (fun fmt -> Format.fprintf fmt "@[(")
 
5724
             (fun fmt -> Format.fprintf fmt ")@]@ ")
 
5725
             (space_sep ",") self#pLogicPrms) args
 
5726
          (pretty_list_del
 
5727
             (fun fmt -> Format.fprintf fmt "@[reads@ ")
 
5728
             (fun fmt -> Format.fprintf fmt "@]")
 
5729
             (space_sep ",") self#pTsets) reads
 
5730
    | Dlogic_def (name, tvars, args, rt, def) ->
 
5731
        fprintf fmt "@[logic@[ %a %a%a%a%a=@ %a;@]@]@\n"
 
5732
          self#pLogic_type rt self#pVarName name.l_name
 
5733
          self#pLabels name.l_labels
 
5734
          self#pTypeParameters tvars
 
5735
          (pretty_list_del
 
5736
             (fun fmt -> Format.fprintf fmt "@[(")
 
5737
             (fun fmt -> Format.fprintf fmt ")@]@ ")
 
5738
             (space_sep ",")
 
5739
             self#pLogicPrms) args
 
5740
          self#pTerm def
 
5741
    | Dlogic_axiomatic (name, tvars, args, rt, axioms) ->
 
5742
        fprintf fmt "@[logic@[ %a %a%a%a%a{@ %a}@]@]@\n"
 
5743
          self#pLogic_type rt self#pVarName name.l_name
 
5744
          self#pLabels name.l_labels
 
5745
          self#pTypeParameters tvars
 
5746
          (pretty_list_del
 
5747
             (fun fmt -> Format.fprintf fmt "@[(")
 
5748
             (fun fmt -> Format.fprintf fmt ")@]@ ")
 
5749
             (space_sep ",")
 
5750
             self#pLogicPrms) args
 
5751
          (pretty_list_del
 
5752
             (fun fmt -> Format.fprintf fmt "@[<v 0>")
 
5753
             (fun fmt -> Format.fprintf fmt "@]@\n")
 
5754
             nl_sep
 
5755
             (fun fmt (id,p) ->
 
5756
                Format.fprintf fmt "axiom %s: %a;" id
 
5757
                self#pPredicate_named p)) axioms
 
5758
    | Dinductive_def (name, tvars, args, indcases) ->
 
5759
        fprintf fmt "@[predicate@[ %a%a%a%a{@ %a}@]@]@\n"
 
5760
          self#pVarName name.p_name
 
5761
          self#pLabels name.p_labels
 
5762
          self#pTypeParameters tvars
 
5763
          (pretty_list_del
 
5764
             (fun fmt -> Format.fprintf fmt "@[(")
 
5765
             (fun fmt -> Format.fprintf fmt ")@]@ ")
 
5766
             (space_sep ",")
 
5767
             self#pLogicPrms) args
 
5768
          (pretty_list_del
 
5769
             (fun fmt -> Format.fprintf fmt "@[<v 0>")
 
5770
             (fun fmt -> Format.fprintf fmt "@]@\n")
 
5771
             nl_sep
 
5772
             (fun fmt (id,p) ->
 
5773
                Format.fprintf fmt "case %s: %a;" id
 
5774
                self#pPredicate_named p)) indcases
 
5775
    | Dpredicate_def (info, tvars, args, def) ->
 
5776
        fprintf fmt "@[predicate@[ %a%a%a%a=@ %a;@]@]@\n"
 
5777
          self#pVarName info.p_name
 
5778
          self#pLabels info.p_labels
 
5779
          self#pTypeParameters tvars
 
5780
          (pretty_list_del
 
5781
             (fun fmt -> Format.fprintf fmt "@[(")
 
5782
             (fun fmt -> Format.fprintf fmt ")@]@ ")
 
5783
             (space_sep ",") self#pLogicPrms) args
 
5784
          self#pPredicate_named def
 
5785
    | Dpredicate_reads (info, tvars, args, reads) ->
 
5786
        fprintf fmt "@[predicate %a%a%a%a%a;@]@\n"
 
5787
          self#pVarName info.p_name
 
5788
          self#pLabels info.p_labels
 
5789
          self#pTypeParameters tvars
 
5790
          (pretty_list_del
 
5791
             (fun fmt -> Format.fprintf fmt "@[(")
 
5792
             (fun fmt -> Format.fprintf fmt ")@]")
 
5793
             (space_sep ",") self#pLogicPrms) args
 
5794
          (pretty_list_del
 
5795
             (fun fmt -> Format.fprintf fmt "@\n  @[reads@ ")
 
5796
             (fun fmt -> Format.fprintf fmt "@]")
 
5797
             (space_sep ",") self#pTsets) reads
 
5798
*)
 
5799
end (* class defaultCilPrinterClass *)
 
5800
 
 
5801
let defaultCilPrinter = new defaultCilPrinterClass
 
5802
 
 
5803
(* Top-level printing functions *)
 
5804
let printType (pp: cilPrinter) fmt (t: typ) =
 
5805
  pp#pType None fmt t
 
5806
 
 
5807
let printExp (pp: cilPrinter) fmt (e: exp) =
 
5808
  pp#pExp fmt e
 
5809
 
 
5810
let printLval (pp: cilPrinter) fmt (lv: lval) =
 
5811
  pp#pLval fmt lv
 
5812
 
 
5813
let printGlobal (pp: cilPrinter) fmt (g: global) =
 
5814
  pp#pGlobal fmt g
 
5815
 
 
5816
let printAttr (pp: cilPrinter) fmt (a: attribute) =
 
5817
  ignore (pp#pAttr fmt a)
 
5818
 
 
5819
let printAttrs (pp: cilPrinter) fmt (a: attributes) =
 
5820
  pp#pAttrs fmt a
 
5821
 
 
5822
let printInstr (pp: cilPrinter) fmt (i: instr) =
 
5823
  pp#pInstr fmt i
 
5824
 
 
5825
let printStmt (pp: cilPrinter) fmt (s: stmt) =
 
5826
  pp#pStmt fmt s
 
5827
 
 
5828
let printBlock (pp: cilPrinter) fmt (b: block) =
 
5829
  (* We must add the alignment ourselves, beucase pBlock will pop it *)
 
5830
  fprintf fmt "@[%a" (pp#pBlock ~toplevel:true) b
 
5831
 
 
5832
let printInit (pp: cilPrinter) fmt (i: init) =
 
5833
  pp#pInit fmt i
 
5834
 
 
5835
let printTerm_lval pp fmt lv = pp#pTerm_lval fmt lv
 
5836
 
 
5837
let printLogic_var pp fmt lv = pp#pLogic_var fmt lv
 
5838
 
 
5839
let printLogic_type pp fmt lv = pp#pLogic_type fmt lv
 
5840
 
 
5841
let printTerm pp fmt t = pp#pTerm fmt t
 
5842
 
 
5843
let printTerm_offset pp fmt o = pp#pTerm_offset fmt o
 
5844
 
 
5845
let printTsets pp fmt o = pp#pTsets fmt o
 
5846
 
 
5847
let printTsets_elem pp fmt o = pp#pTsets_elem fmt o
 
5848
 
 
5849
let printTsets_lhost pp fmt o = pp#pTsets_lhost fmt o
 
5850
 
 
5851
let printTsets_offset pp fmt o = pp#pTsets_offset fmt o
 
5852
 
 
5853
let printTsets_lval pp fmt o = pp#pTsets_lval fmt o
 
5854
 
 
5855
let printPredicate_named pp fmt p = pp#pPredicate_named fmt p
 
5856
 
 
5857
let printCode_annotation pp fmt ca = pp#pCode_annot fmt ca
 
5858
let printStatus pp fmt s = pp#pStatus fmt s
 
5859
 
 
5860
let printFunspec pp fmt s = pp#pSpec fmt s
 
5861
 
 
5862
let printAnnotation pp fmt a = pp#pAnnotation fmt a
 
5863
 
 
5864
(* Now define some short cuts *)
 
5865
let d_exp fmt e = printExp defaultCilPrinter fmt e
 
5866
let _ = pd_exp := d_exp
 
5867
let d_lval fmt lv = printLval defaultCilPrinter fmt lv
 
5868
let d_offset fmt off = defaultCilPrinter#pOffset fmt off
 
5869
let d_init fmt i = printInit defaultCilPrinter fmt i
 
5870
let d_type fmt t = printType defaultCilPrinter fmt t
 
5871
let d_global fmt g = printGlobal defaultCilPrinter fmt g
 
5872
let _ = pd_global := d_global
 
5873
let d_attrlist fmt a = printAttrs defaultCilPrinter fmt a
 
5874
let d_attr fmt a = printAttr defaultCilPrinter fmt a
 
5875
let d_attrparam fmt e = defaultCilPrinter#pAttrParam fmt e
 
5876
let d_label fmt l = defaultCilPrinter#pLabel fmt l
 
5877
let d_stmt fmt s = printStmt defaultCilPrinter fmt s
 
5878
let d_block fmt b = printBlock defaultCilPrinter fmt b
 
5879
let d_instr fmt i = printInstr defaultCilPrinter fmt i
 
5880
 
 
5881
let d_term_lval fmt lv = printTerm_lval defaultCilPrinter fmt lv
 
5882
let d_logic_var fmt lv = printLogic_var defaultCilPrinter fmt lv
 
5883
let d_logic_type fmt lv = printLogic_type defaultCilPrinter fmt lv
 
5884
let d_term fmt lv = printTerm defaultCilPrinter fmt lv
 
5885
let d_term_offset fmt lv = printTerm_offset defaultCilPrinter fmt lv
 
5886
let d_tsets fmt lv = printTsets defaultCilPrinter fmt lv
 
5887
let d_tsets_elem fmt lv = printTsets_elem defaultCilPrinter fmt lv
 
5888
let d_tsets_lhost fmt lv = printTsets_lhost defaultCilPrinter fmt lv
 
5889
let d_tsets_lval fmt lv = printTsets_lval defaultCilPrinter fmt lv
 
5890
let d_tsets_offset fmt lv = printTsets_offset defaultCilPrinter fmt lv
 
5891
 
 
5892
let d_status fmt s = printStatus defaultCilPrinter fmt s
 
5893
let d_predicate_named fmt lv = printPredicate_named defaultCilPrinter fmt lv
 
5894
let d_code_annotation fmt lv = printCode_annotation defaultCilPrinter fmt lv
 
5895
let d_funspec fmt lv = printFunspec defaultCilPrinter fmt lv
 
5896
let d_annotation fmt lv = printAnnotation defaultCilPrinter fmt lv
 
5897
 
 
5898
(* sm: given an ordinary CIL object printer, yield one which
 
5899
 * behaves the same, except it never prints #line directives
 
5900
 * (this is useful for debugging printfs) *)
 
5901
let dn_obj (func: formatter -> 'a -> unit) : (formatter -> 'a -> unit) =
 
5902
begin
 
5903
  (* construct the closure to return *)
 
5904
  let theFunc fmt (obj:'a) =
 
5905
  begin
 
5906
    let prevStyle = miscState.lineDirectiveStyle in
 
5907
    miscState.lineDirectiveStyle <- None;
 
5908
    func fmt obj;    (* call underlying printer *)
 
5909
    miscState.lineDirectiveStyle <- prevStyle
 
5910
  end in
 
5911
  theFunc
 
5912
end
 
5913
 
 
5914
(* now define shortcuts for the non-location-printing versions,
 
5915
 * with the naming prefix "dn_" *)
 
5916
let dn_exp       = (dn_obj d_exp)
 
5917
let dn_lval      = (dn_obj d_lval)
 
5918
(* dn_offset is missing because it has a different interface *)
 
5919
let dn_init      = (dn_obj d_init)
 
5920
let dn_type      = (dn_obj d_type)
 
5921
let dn_global    = (dn_obj d_global)
 
5922
let dn_attrlist  = (dn_obj d_attrlist)
 
5923
let dn_attr      = (dn_obj d_attr)
 
5924
let dn_attrparam = (dn_obj d_attrparam)
 
5925
let dn_stmt      = (dn_obj d_stmt)
 
5926
let dn_instr     = (dn_obj d_instr)
 
5927
 
 
5928
 
 
5929
(*
 
5930
(* Now define a cilPlainPrinter *)
 
5931
class plainCilPrinterClass =
 
5932
  (* We keep track of the composite types that we have done to avoid
 
5933
   * recursion *)
 
5934
  let donecomps : (int, unit) H.t = H.create 13 in
 
5935
  object (self)
 
5936
 
 
5937
  inherit defaultCilPrinterClass as super
 
5938
 
 
5939
  (*** PLAIN TYPES ***)
 
5940
  method pType (dn: doc option) () (t: typ) =
 
5941
    match dn with
 
5942
      None -> self#pOnlyType () t
 
5943
    | Some d -> d ++ text " : " ++ self#pOnlyType () t
 
5944
 
 
5945
 method private pOnlyType () = function
 
5946
     TVoid a -> dprintf "TVoid(@[%a@])" self#pAttrs a
 
5947
   | TInt(ikind, a) -> dprintf "TInt(@[%a,@?%a@])"
 
5948
         d_ikind ikind self#pAttrs a
 
5949
   | TFloat(fkind, a) ->
 
5950
       dprintf "TFloat(@[%a,@?%a@])" d_fkind fkind self#pAttrs a
 
5951
   | TNamed (t, a) ->
 
5952
       dprintf "TNamed(@[%a,@?%a,@?%a@])"
 
5953
         self#pVarName t.tname self#pOnlyType t.ttype self#pAttrs a
 
5954
   | TPtr(t, a) -> dprintf "TPtr(@[%a,@?%a@])" self#pOnlyType t self#pAttrs a
 
5955
   | TArray(t,l,a) ->
 
5956
       let dl = match l with
 
5957
         None -> text "None" | Some l -> dprintf "Some(@[%a@])" self#pExp l in
 
5958
       dprintf "TArray(@[%a,@?%a,@?%a@])"
 
5959
         self#pOnlyType t insert dl self#pAttrs a
 
5960
   | TEnum(enum,a) -> dprintf "Enum(%a,@[%a@])"
 
5961
       self#pVarName enum.ename self#pAttrs a
 
5962
   | TFun(tr,args,isva,a) ->
 
5963
       dprintf "TFun(@[%a,@?%a%s,@?%a@])"
 
5964
         self#pOnlyType tr
 
5965
         insert
 
5966
         (if args = None then text "None"
 
5967
         else (docList ~sep:(chr ',' ++ break)
 
5968
                 (fun (an,at,aa) ->
 
5969
                   dprintf "%s: %a" an self#pOnlyType at))
 
5970
             ()
 
5971
             (argsToList args))
 
5972
         (if isva then "..." else "") self#pAttrs a
 
5973
   | TComp (comp, a) ->
 
5974
       if H.mem donecomps comp.ckey then
 
5975
         dprintf "TCompLoop(%s %a, _, %a)"
 
5976
           (if comp.cstruct then "struct" else "union")
 
5977
           self#pVarName comp.cname self#pAttrs comp.cattr
 
5978
       else begin
 
5979
         H.add donecomps comp.ckey (); (* Add it before we do the fields *)
 
5980
         dprintf "TComp(@[%s %a,@?%a,@?%a,@?%a@])"
 
5981
           (if comp.cstruct then "struct" else "union")
 
5982
           self#pVarName comp.cname
 
5983
           (docList ~sep:(chr ',' ++ break)
 
5984
              (fun f -> dprintf "%a : %a"
 
5985
                 self#pVarName f.fname self#pOnlyType f.ftype))
 
5986
           comp.cfields
 
5987
           self#pAttrs comp.cattr
 
5988
           self#pAttrs a
 
5989
       end
 
5990
   | TBuiltin_va_list a ->
 
5991
       dprintf "TBuiltin_va_list(%a)" self#pAttrs a
 
5992
 
 
5993
 
 
5994
  (* Some plain pretty-printers. Unlike the above these expose all the
 
5995
   * details of the internal representation *)
 
5996
  method pExp () = function
 
5997
    Const(c) ->
 
5998
      let d_plainconst () c =
 
5999
        match c with
 
6000
          CInt64(i, ik, so) ->
 
6001
            dprintf "Int64(%s,%a,%s)"
 
6002
              (Int64.format "%d" i)
 
6003
              d_ikind ik
 
6004
              (match so with Some s -> s | _ -> "None")
 
6005
        | CStr(s) ->
 
6006
            text ("CStr(\"" ^ escape_string s ^ "\")")
 
6007
        | CWStr(s) ->
 
6008
            dprintf "CWStr(%a)" d_const c
 
6009
 
 
6010
        | CChr(c) -> text ("CChr('" ^ escape_char c ^ "')")
 
6011
        | CReal(f, fk, so) ->
 
6012
            dprintf "CReal(%f, %a, %s)"
 
6013
              f
 
6014
              d_fkind fk
 
6015
              (match so with Some s -> s | _ -> "None")
 
6016
        | CEnum(_, s, _) -> text s
 
6017
      in
 
6018
      text "Const(" ++ d_plainconst () c ++ text ")"
 
6019
 
 
6020
 
 
6021
  | Lval(lv) ->
 
6022
      text "Lval("
 
6023
        ++ (align
 
6024
              ++ self#pLval () lv
 
6025
              ++ unalign)
 
6026
        ++ text ")"
 
6027
 
 
6028
  | CastE(t,e) -> dprintf "CastE(@[%a,@?%a@])" self#pOnlyType t self#pExp e
 
6029
 
 
6030
  | UnOp(u,e1,_) ->
 
6031
      dprintf "UnOp(@[%a,@?%a@])"
 
6032
        d_unop u self#pExp e1
 
6033
 
 
6034
  | BinOp(b,e1,e2,_) ->
 
6035
      let d_plainbinop () b =
 
6036
        match b with
 
6037
          PlusA -> text "PlusA"
 
6038
        | PlusPI -> text "PlusPI"
 
6039
        | IndexPI -> text "IndexPI"
 
6040
        | MinusA -> text "MinusA"
 
6041
        | MinusPP -> text "MinusPP"
 
6042
        | MinusPI -> text "MinusPI"
 
6043
        | _ -> d_binop () b
 
6044
      in
 
6045
      dprintf "%a(@[%a,@?%a@])" d_plainbinop b
 
6046
        self#pExp e1 self#pExp e2
 
6047
 
 
6048
  | SizeOf (t) ->
 
6049
      text "sizeof(" ++ self#pType None () t ++ chr ')'
 
6050
  | SizeOfE (e) ->
 
6051
      text "sizeofE(" ++ self#pExp () e ++ chr ')'
 
6052
  | SizeOfStr (s) ->
 
6053
      text "sizeofStr(" ++ d_const () (CStr s) ++ chr ')'
 
6054
  | AlignOf (t) ->
 
6055
      text "__alignof__(" ++ self#pType None () t ++ chr ')'
 
6056
  | AlignOfE (e) ->
 
6057
      text "__alignof__(" ++ self#pExp () e ++ chr ')'
 
6058
 
 
6059
  | StartOf lv -> dprintf "StartOf(%a)" self#pLval lv
 
6060
  | AddrOf (lv) -> dprintf "AddrOf(%a)" self#pLval lv
 
6061
 
 
6062
 
 
6063
 
 
6064
  method private d_plainoffset () = function
 
6065
      NoOffset -> text "NoOffset"
 
6066
    | Field(fi,o) ->
 
6067
        dprintf "Field(@[%a:%a,@?%a@])"
 
6068
          self#pVarName fi.fname self#pOnlyType fi.ftype self#d_plainoffset o
 
6069
     | Index(e, o) ->
 
6070
         dprintf "Index(@[%a,@?%a@])" self#pExp e self#d_plainoffset o
 
6071
 
 
6072
  method pInit () = function
 
6073
      SingleInit e -> dprintf "SI(%a)" d_exp e
 
6074
    | CompoundInit (t, initl) ->
 
6075
        let d_plainoneinit (o, i) =
 
6076
          self#d_plainoffset () o ++ text " = " ++ self#pInit () i
 
6077
        in
 
6078
        dprintf "CI(@[%a,@?%a@])" self#pOnlyType t
 
6079
          (docList ~sep:(chr ',' ++ break) d_plainoneinit) initl
 
6080
(*
 
6081
    | ArrayInit (t, len, initl) ->
 
6082
        let idx = ref (- 1) in
 
6083
        let d_plainoneinit i =
 
6084
          incr idx;
 
6085
          text "[" ++ num !idx ++ text "] = " ++ self#pInit () i
 
6086
        in
 
6087
        dprintf "AI(@[%a,%d,@?%a@])" self#pOnlyType t len
 
6088
          (docList ~sep:(chr ',' ++ break) d_plainoneinit) initl
 
6089
*)
 
6090
  method pLval () (lv: lval) =
 
6091
    match lv with
 
6092
    | Var vi, o -> dprintf "Var(@[%a,@?%a@])"
 
6093
        self#pVarName vi.vname self#d_plainoffset o
 
6094
    | Mem e, o -> dprintf "Mem(@[%a,@?%a@])" self#pExp e self#d_plainoffset o
 
6095
 
 
6096
 
 
6097
end
 
6098
let plainCilPrinter = new plainCilPrinterClass
 
6099
*)
 
6100
(* And now some shortcuts *)
 
6101
let d_plainexp fmt e = defaultCilPrinter#pExp fmt e
 
6102
let d_plaintype fmt t = defaultCilPrinter#pType None fmt t
 
6103
let d_plaininit fmt i = defaultCilPrinter#pInit fmt i
 
6104
let d_plainlval fmt l = defaultCilPrinter#pLval fmt l
 
6105
class type descriptiveCilPrinter = object
 
6106
  inherit cilPrinter
 
6107
 
 
6108
  method startTemps: unit -> unit
 
6109
  method stopTemps: unit -> unit
 
6110
  method pTemps: Format.formatter -> unit
 
6111
end
 
6112
 
 
6113
class descriptiveCilPrinterClass : descriptiveCilPrinter = object (self)
 
6114
  (** Like defaultCilPrinterClass, but instead of temporary variable
 
6115
      names it prints the description that was provided when the temp was
 
6116
      created.  This is usually better for messages that are printed for end
 
6117
      users, although you may want the temporary names for debugging.  *)
 
6118
  inherit defaultCilPrinterClass as super
 
6119
 
 
6120
  val mutable temps: (varinfo * string * string option) list = []
 
6121
  val mutable useTemps: bool = false
 
6122
 
 
6123
  method startTemps () : unit =
 
6124
    temps <- [];
 
6125
    useTemps <- true
 
6126
 
 
6127
  method stopTemps () : unit =
 
6128
    temps <- [];
 
6129
    useTemps <- false
 
6130
 
 
6131
  method pTemps fmt  =
 
6132
    if temps = [] then
 
6133
      ()
 
6134
    else
 
6135
      fprintf fmt "@\nWhere:@\n  %a"
 
6136
        (fprintfList ~sep:"\n  "
 
6137
        (let f fmt v = match v with
 
6138
         | (_, s, Some d) -> fprintf fmt "%s = %s" s  d
 
6139
         |(_, s, None) -> fprintf fmt  "%s = " s in f))
 
6140
        (List.rev temps)
 
6141
 
 
6142
  method private pVarDescriptive fmt (vi: varinfo) =
 
6143
    match vi.vdescr with
 
6144
    | Some vd ->
 
6145
        if vi.vdescrpure || not useTemps then
 
6146
          fprintf fmt "%s" vd
 
6147
        else begin
 
6148
        try
 
6149
          let _, name, _ = List.find (fun (vi', _, _) -> vi == vi') temps in
 
6150
          fprintf fmt "%s" name
 
6151
        with Not_found ->
 
6152
          let name = "tmp" ^ string_of_int (List.length temps) in
 
6153
          temps <- (vi, name, vi.vdescr) :: temps;
 
6154
          fprintf fmt "%s" name
 
6155
        end
 
6156
    | None ->
 
6157
      super#pVar fmt vi
 
6158
 
 
6159
  (* Only substitute temp vars that appear in expressions.
 
6160
     (Other occurrences of lvalues are the left-hand sides of assignments,
 
6161
      but we shouldn't substitute there since "foo(a,b) = foo(a,b)"
 
6162
      would make no sense to the user.)  *)
 
6163
  method pExp fmt (e:exp) =
 
6164
    match e with
 
6165
      Lval (Var vi, o)
 
6166
    | StartOf (Var vi, o) ->
 
6167
        fprintf fmt "%a%a" self#pVarDescriptive vi self#pOffset o
 
6168
    | AddrOf (Var vi, o) ->
 
6169
        (* No parens needed, since offsets have higher precedence than & *)
 
6170
        fprintf fmt "& %a%a" self#pVarDescriptive vi self#pOffset o
 
6171
    | _ -> super#pExp fmt e
 
6172
end
 
6173
 
 
6174
let descriptiveCilPrinter: descriptiveCilPrinter =
 
6175
  ((new descriptiveCilPrinterClass) :> descriptiveCilPrinter)
 
6176
 
 
6177
let dd_exp = descriptiveCilPrinter#pExp
 
6178
let dd_lval = descriptiveCilPrinter#pLval
 
6179
 
 
6180
(*
 
6181
(* zra: this allows pretty printers not in cil.ml to
 
6182
   be exposed to cilmain.ml *)
 
6183
let printerForMaincil = ref defaultCilPrinter
 
6184
 
 
6185
let rec d_typsig () = function
 
6186
    TSArray (ts, eo, al) ->
 
6187
      dprintf "TSArray(@[%a,@?%a,@?%a@])"
 
6188
        d_typsig ts
 
6189
        insert (text (match eo with None -> "None"
 
6190
                       | Some e -> "Some " ^ Int64.to_string e))
 
6191
        d_attrlist al
 
6192
  | TSPtr (ts, al) ->
 
6193
      dprintf "TSPtr(@[%a,@?%a@])"
 
6194
        d_typsig ts d_attrlist al
 
6195
  | TSComp (iss, name, al) ->
 
6196
      dprintf "TSComp(@[%s %s,@?%a@])"
 
6197
        (if iss then "struct" else "union") name
 
6198
        d_attrlist al
 
6199
  | TSFun (rt, args, isva, al) ->
 
6200
      dprintf "TSFun(@[%a,@?%a,%b,@?%a@])"
 
6201
        d_typsig rt
 
6202
        (docList ~sep:(chr ',' ++ break) (d_typsig ())) args isva
 
6203
        d_attrlist al
 
6204
  | TSEnum (n, al) ->
 
6205
      dprintf "TSEnum(@[%s,@?%a@])"
 
6206
        n d_attrlist al
 
6207
  | TSBase t -> dprintf "TSBase(%a)" d_type t
 
6208
*)
 
6209
 
 
6210
(* Make a varinfo. Used mostly as a helper function below  *)
 
6211
let makeVarinfo ?(logic=false) global formal name typ =
 
6212
  (* Strip const from type for locals *)
 
6213
  let vi =
 
6214
    { vorig_name = name;
 
6215
      vname = name;
 
6216
      vid   = -1;
 
6217
      vglob = global;
 
6218
      vdefined = false;
 
6219
      vformal = formal;
 
6220
      vtype = if formal || global then typ
 
6221
      else typeRemoveAttributes ["const"] typ;
 
6222
      vdecl = locUnknown;
 
6223
      vinline = false;
 
6224
      vattr = [];
 
6225
      vstorage = NoStorage;
 
6226
      vaddrof = false;
 
6227
      vreferenced = false;
 
6228
      vdescr = None;
 
6229
      vdescrpure = true;
 
6230
      vghost = false;
 
6231
      vlogic = logic;
 
6232
      vlogic_var_assoc = None
 
6233
    }
 
6234
  in
 
6235
  set_vid vi;
 
6236
  vi
 
6237
 
 
6238
let cvar_to_lvar vi =
 
6239
  (*Format.printf "Converting cvar %s(%d) to logic var@." vi.vname vi.vid;*)
 
6240
  match vi.vlogic_var_assoc with
 
6241
      None ->
 
6242
        let lv =
 
6243
          { lv_name = vi.vname;
 
6244
            lv_id = vi.vid;
 
6245
            lv_type = Ctype vi.vtype ;
 
6246
            lv_origin = Some vi}
 
6247
        in vi.vlogic_var_assoc <- Some lv; lv
 
6248
    | Some lv -> lv
 
6249
 
 
6250
let copyVarinfo (vi: varinfo) (newname: string) : varinfo =
 
6251
  let vi' = copy_with_new_vid vi in
 
6252
  vi'.vname <- newname;
 
6253
  (match vi.vlogic_var_assoc with
 
6254
       None -> ()
 
6255
     | Some _ ->
 
6256
         vi'.vlogic_var_assoc <- None;
 
6257
         ignore(cvar_to_lvar vi'));
 
6258
  vi'
 
6259
 
 
6260
let makeLocal ?(formal=false) fdec name typ = (* a helper function *)
 
6261
  fdec.smaxid <- 1 + fdec.smaxid;
 
6262
  let vi = makeVarinfo false formal name typ in
 
6263
  vi
 
6264
 
 
6265
(* Make a local variable and add it to a function *)
 
6266
let makeLocalVar fdec ?(insert = true) name typ =
 
6267
  let vi = makeLocal fdec name typ in
 
6268
  if insert then fdec.slocals <- fdec.slocals @ [vi];
 
6269
  vi
 
6270
 
 
6271
let makeTempVar fdec ?(name = "__cil_tmp") ?descr ?(descrpure = true)
 
6272
                typ : varinfo =
 
6273
  let rec findUniqueName () : string=
 
6274
    let n = name ^ (string_of_int (1 + fdec.smaxid)) in
 
6275
    (* Is this check a performance problem?  We could bring the old
 
6276
       unchecked makeTempVar back as a separate function that assumes
 
6277
       the prefix name does not occur in the original program. *)
 
6278
    if (List.exists (fun vi -> vi.vname = n) fdec.slocals)
 
6279
      || (List.exists (fun vi -> vi.vname = n) fdec.sformals) then begin
 
6280
        fdec.smaxid <- 1 + fdec.smaxid;
 
6281
        findUniqueName ()
 
6282
      end else
 
6283
        n
 
6284
  in
 
6285
  let name = findUniqueName () in
 
6286
  let vi = makeLocalVar fdec name typ in
 
6287
  vi.vdescr <- descr;
 
6288
  vi.vdescrpure <- descrpure;
 
6289
  vi
 
6290
 
 
6291
let makePseudoVar =
 
6292
  let counter = ref 0 in
 
6293
  function ty ->
 
6294
    incr counter;
 
6295
    let name = "@" ^ (string_of_int !counter) in
 
6296
    makeVarinfo ~logic:true (* global= *)false (* formal= *)false name ty
 
6297
 
 
6298
(* Set the formals and re-create the function name based on the information*)
 
6299
let setFormals (f: fundec) (forms: varinfo list) =
 
6300
  List.iter (fun v -> v.vformal <- true) forms;
 
6301
  f.sformals <- forms; (* Set the formals *)
 
6302
  match unrollType f.svar.vtype with
 
6303
    TFun(rt, _, isva, fa) ->
 
6304
      f.svar.vtype <-
 
6305
         TFun(rt,
 
6306
              Some (List.map (fun a -> (a.vname, a.vtype, a.vattr)) forms),
 
6307
              isva, fa)
 
6308
  | _ -> E.s (E.bug "Set formals. %s does not have function type\n"
 
6309
                f.svar.vname)
 
6310
 
 
6311
   (* Set the types of arguments and results as given by the function type
 
6312
    * passed as the second argument *)
 
6313
let setFunctionType (f: fundec) (t: typ) =
 
6314
  match unrollType t with
 
6315
    TFun (_rt, Some args, _va, _a) ->
 
6316
      if List.length f.sformals <> List.length args then
 
6317
        E.s (E.bug "setFunctionType: number of arguments differs from the number of formals");
 
6318
      (* Change the function type. *)
 
6319
      f.svar.vtype <- t;
 
6320
      (* Change the sformals and we know that indirectly we'll change the
 
6321
       * function type *)
 
6322
      List.iter2
 
6323
        (fun (_an,at,aa) f ->
 
6324
          f.vtype <- at; f.vattr <- aa)
 
6325
        args f.sformals
 
6326
 
 
6327
  | _ -> E.s (E.bug "setFunctionType: not a function type")
 
6328
 
 
6329
 
 
6330
   (* Set the types of arguments and results as given by the function type
 
6331
    * passed as the second argument *)
 
6332
let setFunctionTypeMakeFormals (f: fundec) (t: typ) =
 
6333
  match unrollType t with
 
6334
    TFun (_rt, Some args, _va, _a) ->
 
6335
      if f.sformals <> [] then
 
6336
        E.s (E.warn "setFunctionTypMakeFormals called on function %s with some formals already"
 
6337
               f.svar.vname);
 
6338
      (* Change the function type. *)
 
6339
      f.svar.vtype <- t;
 
6340
      f.sformals <- [];
 
6341
 
 
6342
      f.sformals <- List.map (fun (n,t,_a) -> makeLocal ~formal:true f n t) args;
 
6343
 
 
6344
      setFunctionType f t
 
6345
 
 
6346
  | _ -> E.s (bug "setFunctionTypeMakeFormals: not a function type: %a"
 
6347
             d_type t)
 
6348
 
 
6349
 
 
6350
let setMaxId (f: fundec) =
 
6351
  f.smaxid <- List.length f.sformals + List.length f.slocals
 
6352
 
 
6353
 
 
6354
  (* Make a formal variable for a function. Insert it in both the sformals
 
6355
   * and the type of the function. You can optionally specify where to insert
 
6356
   * this one. If where = "^" then it is inserted first. If where = "$" then
 
6357
   * it is inserted last. Otherwise where must be the name of a formal after
 
6358
   * which to insert this. By default it is inserted at the end. *)
 
6359
let makeFormalVar fdec ?(where = "$") name typ : varinfo =
 
6360
  (* Search for the insertion place *)
 
6361
  let thenewone = ref fdec.svar in (* Just a placeholder *)
 
6362
  let makeit () : varinfo =
 
6363
    let vi = makeLocal ~formal:true fdec name typ in
 
6364
    thenewone := vi;
 
6365
    vi
 
6366
  in
 
6367
  let rec loopFormals = function
 
6368
      [] ->
 
6369
        if where = "$" then [makeit ()]
 
6370
        else E.s (E.error "makeFormalVar: cannot find insert-after formal %s"
 
6371
                    where)
 
6372
    | f :: rest when f.vname = where -> f :: makeit () :: rest
 
6373
    | f :: rest -> f :: loopFormals rest
 
6374
  in
 
6375
  let newformals =
 
6376
    if where = "^" then makeit () :: fdec.sformals else
 
6377
    loopFormals fdec.sformals in
 
6378
  setFormals fdec newformals;
 
6379
  !thenewone
 
6380
 
 
6381
   (* Make a global variable. Your responsibility to make sure that the name
 
6382
    * is unique *)
 
6383
let makeGlobalVar ?logic name typ =
 
6384
  let vi = makeVarinfo ?logic true false name typ in
 
6385
  vi
 
6386
 
 
6387
module FormalsDecl =
 
6388
  Computation.Make_Hashtbl
 
6389
    (Cilutil.VarinfoHashtbl)
 
6390
    (Datatype.List(Cil_datatype.Varinfo))
 
6391
    (struct
 
6392
       let name = "FormalsDecl"
 
6393
       let dependencies = [] (* depends on file in Frama-C kernel *)
 
6394
       let size = 47
 
6395
     end)
 
6396
 
 
6397
let selfFormalsDecl = FormalsDecl.self
 
6398
 
 
6399
let makeFormalsVarDecl (n,t,a) =
 
6400
  let vi = makeVarinfo false true n t in
 
6401
  vi.vattr <- a;
 
6402
  vi
 
6403
 
 
6404
let setFormalsDecl vi typ =
 
6405
  match unrollType typ with
 
6406
  | TFun(_, Some args, _, _) ->
 
6407
      FormalsDecl.replace vi (List.map makeFormalsVarDecl args)
 
6408
  | TFun(_,None,_,_) -> ()
 
6409
  | _ -> E.bug
 
6410
      "trying to assigns formal parameters to an object which is \
 
6411
       not a function prototype"
 
6412
 
 
6413
let getFormalsDecl vi = FormalsDecl.find vi
 
6414
 
 
6415
let unsafeSetFormalsDecl vi args = FormalsDecl.replace vi args
 
6416
 
 
6417
 
 
6418
(* Make an empty function *)
 
6419
let emptyFunction name =
 
6420
  let r = { svar  = makeGlobalVar name (TFun(voidType, Some [], false,[]));
 
6421
    smaxid = 0;
 
6422
    slocals = [];
 
6423
    sformals = [];
 
6424
    sbody = mkBlock [];
 
6425
    smaxstmtid = None;
 
6426
    sallstmts = [];
 
6427
    sspec =   empty_funspec ()
 
6428
  }
 
6429
  in
 
6430
  setFormalsDecl r.svar r.svar.vtype;
 
6431
  r
 
6432
 
 
6433
let dummyFile =
 
6434
  { globals = [];
 
6435
    fileName = "<dummy>";
 
6436
    globinit = None;
 
6437
    globinitcalled = false;}
 
6438
 
 
6439
 
 
6440
(* Take the name of a file and make a valid varinfo name out of it. There are
 
6441
 * a few characters that are not valid in varinfos *)
 
6442
let makeValidVarinfoName (s: string) =
 
6443
  let s = String.copy s in (* So that we can update in place *)
 
6444
  let l = String.length s in
 
6445
  for i = 0 to l - 1 do
 
6446
    let c = String.get s i in
 
6447
    let isinvalid =
 
6448
      match c with
 
6449
        '-' | '.' -> true
 
6450
      | _ -> false
 
6451
    in
 
6452
    if isinvalid then
 
6453
      String.set s i '_';
 
6454
  done;
 
6455
  s
 
6456
 
 
6457
let rec lastOffset (off: offset) : offset =
 
6458
  match off with
 
6459
  | NoOffset | Field(_,NoOffset) | Index(_,NoOffset) -> off
 
6460
  | Field(_,off) | Index(_,off) -> lastOffset off
 
6461
 
 
6462
let rec lastTermOffset (off: term_offset) : term_offset =
 
6463
  match off with
 
6464
  | TNoOffset | TField(_,TNoOffset) | TIndex(_,TNoOffset) -> off
 
6465
  | TField(_,off) | TIndex(_,off) -> lastTermOffset off
 
6466
 
 
6467
let rec lastTsetsOffset off =
 
6468
  match off with
 
6469
  | TSNoOffset | TSField(_,TSNoOffset) | TSIndex(_,TSNoOffset)
 
6470
  | TSRange(_,_,TSNoOffset) -> off
 
6471
  | TSField(_,off) | TSIndex(_,off) | TSRange(_,_,off) -> lastTsetsOffset off
 
6472
 
 
6473
let rec addOffset (toadd: offset) (off: offset) : offset =
 
6474
  match off with
 
6475
    NoOffset -> toadd
 
6476
  | Field(fid', offset) -> Field(fid', addOffset toadd offset)
 
6477
  | Index(e, offset) -> Index(e, addOffset toadd offset)
 
6478
 
 
6479
let rec addTermOffset (toadd: term_offset) (off: term_offset) : term_offset =
 
6480
  match off with
 
6481
    TNoOffset -> toadd
 
6482
  | TField(fid', offset) -> TField(fid', addTermOffset toadd offset)
 
6483
  | TIndex(t, offset) -> TIndex(t, addTermOffset toadd offset)
 
6484
 
 
6485
let rec addTsetsOffset toadd off =
 
6486
  match off with
 
6487
      TSNoOffset -> toadd
 
6488
    | TSField(fid, offset) -> TSField(fid, addTsetsOffset toadd offset)
 
6489
    | TSIndex(t,offset) -> TSIndex(t,addTsetsOffset toadd offset)
 
6490
    | TSRange(t1,t2,offset) -> TSRange(t1,t2,addTsetsOffset toadd offset)
 
6491
 
 
6492
 (* Add an offset at the end of an lv *)
 
6493
let addOffsetLval toadd (b, off) : lval =
 
6494
 b, addOffset toadd off
 
6495
 
 
6496
let addTermOffsetLval toadd (b, off) : term_lval =
 
6497
 b, addTermOffset toadd off
 
6498
 
 
6499
let addTsetsOffsetLval toadd (b, off) : tsets_lval =
 
6500
 b, addTsetsOffset toadd off
 
6501
 
 
6502
let rec removeOffset (off: offset) : offset * offset =
 
6503
  match off with
 
6504
    NoOffset -> NoOffset, NoOffset
 
6505
  | Field(_f, NoOffset) -> NoOffset, off
 
6506
  | Index(_i, NoOffset) -> NoOffset, off
 
6507
  | Field(f, restoff) ->
 
6508
      let off', last = removeOffset restoff in
 
6509
      Field(f, off'), last
 
6510
  | Index(i, restoff) ->
 
6511
      let off', last = removeOffset restoff in
 
6512
      Index(i, off'), last
 
6513
 
 
6514
let removeOffsetLval ((b, off): lval) : lval * offset =
 
6515
  let off', last = removeOffset off in
 
6516
  (b, off'), last
 
6517
 
 
6518
 
 
6519
(*** Define the visiting engine ****)
 
6520
(* visit all the nodes in a Cil expression *)
 
6521
let doVisit (vis: 'visitor)
 
6522
            (previsit: 'a -> 'a)
 
6523
            (startvisit: 'a -> 'a visitAction)
 
6524
            (children: 'visitor -> 'a -> 'a)
 
6525
            (node: 'a) : 'a =
 
6526
  let node' = previsit node in
 
6527
  let action = startvisit node' in
 
6528
  match action with
 
6529
      SkipChildren -> node'
 
6530
  | ChangeTo node' -> node'
 
6531
  | ChangeToPost (node',f) -> f node'
 
6532
  | _ -> (* DoChildren and ChangeDoChildrenPost *)
 
6533
      let nodepre = match action with
 
6534
        ChangeDoChildrenPost (node', _) -> node'
 
6535
      | _ -> node'
 
6536
      in
 
6537
      let nodepost = children vis nodepre in
 
6538
      match action with
 
6539
        ChangeDoChildrenPost (_, f) -> f nodepost
 
6540
      | _ -> nodepost
 
6541
 
 
6542
let rev_until i l =
 
6543
  let rec aux acc =
 
6544
      function
 
6545
          [] -> acc
 
6546
        | i'::_ when i' == i -> acc
 
6547
        | i'::l -> aux (i'::acc) l
 
6548
  in aux [] l
 
6549
 
 
6550
(* mapNoCopy is like map but avoid copying the list if the function does not
 
6551
 * change the elements. *)
 
6552
let mapNoCopy (f: 'a -> 'a) orig =
 
6553
  let rec aux ((acc,has_changed) as res) l =
 
6554
    match l with
 
6555
        [] -> if has_changed then List.rev acc else orig
 
6556
      | i :: resti ->
 
6557
          let i' = f i in
 
6558
          if has_changed then
 
6559
            aux (i'::acc,true) resti
 
6560
          else if i' != i then
 
6561
            aux (i'::rev_until i orig,true) resti
 
6562
          else
 
6563
            aux res resti
 
6564
  in aux ([],false) orig
 
6565
 
 
6566
let mapNoCopyList (f: 'a -> 'a list) orig =
 
6567
  let rec aux ((acc,has_changed) as res) l =
 
6568
    match l with
 
6569
        [] -> if has_changed then List.rev acc else orig
 
6570
      | i :: resti ->
 
6571
          let l' = f i in
 
6572
          if has_changed then
 
6573
            aux (List.rev_append l' acc,true) resti
 
6574
          else
 
6575
            (match l' with
 
6576
                 [i'] when i' == i -> aux res resti
 
6577
               | _ -> aux (List.rev_append l' (rev_until i orig), true) resti)
 
6578
  in aux ([],false) orig
 
6579
 
 
6580
(* A visitor for lists *)
 
6581
let doVisitList  (vis: 'visit)
 
6582
                 (previsit: 'a -> 'a)
 
6583
                 (startvisit: 'a -> 'a list visitAction)
 
6584
                 (children: 'visit -> 'a -> 'a)
 
6585
                 (node: 'a) : 'a list =
 
6586
  let node' = previsit node in
 
6587
  let action = startvisit node' in
 
6588
  match action with
 
6589
    SkipChildren -> [node']
 
6590
  | ChangeTo nodes' -> nodes'
 
6591
  | ChangeToPost (nodes',f) -> f nodes'
 
6592
  | _ ->
 
6593
      let nodespre = match action with
 
6594
        ChangeDoChildrenPost (nodespre, _) -> nodespre
 
6595
      | _ -> [node']
 
6596
      in
 
6597
      let nodespost = mapNoCopy (children vis) nodespre in
 
6598
      match action with
 
6599
        ChangeDoChildrenPost (_, f) -> f nodespost
 
6600
      | _ -> nodespost
 
6601
 
 
6602
 
 
6603
let opt_map f o =
 
6604
  match o with
 
6605
      None -> o
 
6606
    | Some x ->
 
6607
        let x' = f x in if x' != x then Some x' else o
 
6608
let opt_bind f =
 
6609
  function
 
6610
      None -> None
 
6611
    | Some x as o ->
 
6612
        match f x with
 
6613
            None -> None
 
6614
          | Some x' as o' -> if x != x' then o else o'
 
6615
 
 
6616
let doVisitOption (vis: #cilVisitor as 'visit)
 
6617
                  (previsit: 'a -> 'a)
 
6618
                  (startvisit: 'a -> 'a option visitAction)
 
6619
                  (children: 'visit -> 'a -> 'a)
 
6620
                  (node: 'a) : 'a option =
 
6621
  let node' = previsit node in
 
6622
  let action = startvisit node' in
 
6623
  match action with
 
6624
      SkipChildren -> Some node'
 
6625
    | ChangeTo node' -> node'
 
6626
    | ChangeToPost (node',f) -> f node'
 
6627
    | _ ->
 
6628
        let nodepre = match action with
 
6629
            ChangeDoChildrenPost(nodepre,_) -> nodepre
 
6630
          | _ -> Some node'
 
6631
        in let nodepost = opt_map (children vis) nodepre in
 
6632
        match action with
 
6633
            ChangeDoChildrenPost(_,f) -> f nodepost
 
6634
          | _ -> nodepost
 
6635
 
 
6636
let debugVisit = false
 
6637
 
 
6638
let rec visitCilTerm vis t =
 
6639
  doVisit vis (fun x-> x) vis#vterm childrenTerm t
 
6640
and childrenTerm vis t =
 
6641
  let tn' = visitCilTermNode vis t.term_node in
 
6642
  let tt' = visitCilLogicType vis t.term_type in
 
6643
    if tn' != t.term_node || tt' != t.term_type then
 
6644
      { t with term_node = tn'; term_type = tt' }
 
6645
    else t
 
6646
and visitCilTermNode vis tn =
 
6647
  doVisit vis (fun x -> x) vis#vterm_node childrenTermNode tn
 
6648
and childrenTermNode vis tn =
 
6649
  let vTerm t = visitCilTerm vis t in
 
6650
  let vTermLval tl = visitCilTermLval vis tl in
 
6651
  let vTyp t = visitCilType vis t in
 
6652
  let vLogicInfo li =
 
6653
    doVisit vis vis#behavior.get_logic_info
 
6654
      vis#vlogic_info_use (fun _ x ->x) li
 
6655
  in
 
6656
  match tn with
 
6657
    | TConst _ -> tn (*enum constants are visited at their declaration site*)
 
6658
    | TDataCons (ci,args) ->
 
6659
        let args' = mapNoCopy vTerm args in
 
6660
        if args != args' then TDataCons(ci,args') else tn
 
6661
    | TLval tl ->
 
6662
        let tl' = vTermLval tl in
 
6663
          if tl' != tl then TLval tl' else tn
 
6664
    | TSizeOf t ->
 
6665
        let t' = vTyp t in if t' != t then TSizeOf t' else tn
 
6666
    | TSizeOfE t ->
 
6667
        let t' = vTerm t in if  t' != t then TSizeOfE t' else tn
 
6668
    | TSizeOfStr _ -> tn
 
6669
    | TAlignOf t ->
 
6670
        let t' = vTyp t in if t' != t then TAlignOf t' else tn
 
6671
    | TAlignOfE t ->
 
6672
        let t' = vTerm t in if  t' != t then TAlignOfE t' else tn
 
6673
    | TUnOp (op,t) ->
 
6674
        let t' = vTerm t in if  t' != t then TUnOp (op,t') else tn
 
6675
    | TBinOp(op,t1,t2) ->
 
6676
        let t1' = vTerm t1 in
 
6677
        let t2' = vTerm t2 in
 
6678
        if t1' != t1 || t2' != t2 then TBinOp(op,t1',t2') else tn
 
6679
    | TCastE(ty,te) ->
 
6680
        let ty' = vTyp ty in
 
6681
        let te' = vTerm te in
 
6682
          if ty' != ty || te' != te then TCastE(ty',te') else tn
 
6683
    | TAddrOf tl ->
 
6684
        let tl' = vTermLval tl in
 
6685
          if tl' != tl then TAddrOf tl' else tn
 
6686
    | TStartOf tl ->
 
6687
        let tl' = vTermLval tl in
 
6688
          if tl' != tl then TStartOf tl' else tn
 
6689
    | Tapp(li,labels,args) ->
 
6690
        let li' = vLogicInfo li in
 
6691
        let args' = mapNoCopy vTerm args in
 
6692
          if li' != li || args' != args then Tapp(li',labels,args') else tn
 
6693
    | Tif(test,ttrue,tfalse) ->
 
6694
        let test' = vTerm test in
 
6695
        let ttrue' = vTerm ttrue in
 
6696
        let tfalse' = vTerm tfalse in
 
6697
          if test' != test || ttrue' != ttrue || tfalse' != tfalse then
 
6698
            Tif(test',ttrue',tfalse')
 
6699
          else tn
 
6700
    | Told t ->
 
6701
        let t' = vTerm t in if t' != t then Told t' else tn
 
6702
    | Tat(t,s) ->
 
6703
        let t' = vTerm t in
 
6704
        let s' = visitCilLogicLabel vis s in
 
6705
        if t' != t || s' != s then Tat (t',s') else tn
 
6706
    | Tbase_addr t ->
 
6707
        let t' = vTerm t in if t' != t then Tbase_addr t' else tn
 
6708
    | Tblock_length t ->
 
6709
        let t' = vTerm t in if t' != t then Tblock_length t' else tn
 
6710
    | Tnull -> tn
 
6711
    | TCoerce(te,ty) ->
 
6712
        let ty' = vTyp ty in
 
6713
        let te' = vTerm te in
 
6714
        if ty' != ty || te' != te then TCoerce(te',ty') else tn
 
6715
    | TCoerceE(te,tc) ->
 
6716
        let tc' = vTerm tc in
 
6717
        let te' = vTerm te in
 
6718
        if tc' != tc || te' != te then TCoerceE(te',tc') else tn
 
6719
    | TUpdate (tc,f,te) ->
 
6720
        let tc' = vTerm tc in
 
6721
        let te' = vTerm te in
 
6722
        if tc' != tc || te' != te then TUpdate(tc',f,te') else tn
 
6723
    | Tlambda(prms,te) ->
 
6724
        let prms' = visitCilQuantifiers vis prms in
 
6725
        let te' = vTerm te in
 
6726
        if prms' != prms || te' != te then Tlambda(prms',te') else tn
 
6727
    | Ttypeof t ->
 
6728
        let t' = vTerm t in if t' != t then Ttypeof t' else tn
 
6729
    | Ttype ty ->
 
6730
        let ty' = vTyp ty in if ty' != ty then Ttype ty' else tn
 
6731
    | Ttsets ts ->
 
6732
        let ts' = visitCilTsets vis ts in if ts != ts' then Ttsets ts' else tn
 
6733
 
 
6734
and visitCilLogicLabel vis l =
 
6735
  match l with
 
6736
      StmtLabel s -> s := vis#behavior.get_stmt !s; l
 
6737
    | LogicLabel _ -> l
 
6738
 
 
6739
and visitCilTermLval vis tl =
 
6740
  doVisit vis (fun x -> x) vis#vterm_lval childrenTermLval tl
 
6741
 
 
6742
and childrenTermLval vis ((tlv,toff) as tl)=
 
6743
  let tlv' = visitCilTermLhost vis tlv in
 
6744
  let toff' = visitCilTermOffset vis toff in
 
6745
    if tlv' != tlv || toff' != toff then (tlv',toff') else tl
 
6746
 
 
6747
and visitCilTermLhost vis tl =
 
6748
  doVisit vis (fun x -> x) vis#vterm_lhost childrenTermLhost tl
 
6749
 
 
6750
and childrenTermLhost vis tl = match tl with
 
6751
    TVar v ->
 
6752
      let v' = visitCilLogicVarUse vis v in if v' != v then TVar v' else tl
 
6753
  | TResult -> tl
 
6754
  | TMem t ->
 
6755
      let t' = visitCilTerm vis t in if t' != t then TMem t' else tl
 
6756
 
 
6757
and visitCilTermOffset vis toff =
 
6758
    doVisit vis (fun x -> x)
 
6759
      vis#vterm_offset childrenTermOffset toff
 
6760
 
 
6761
and childrenTermOffset vis toff =
 
6762
  let vOffset o = visitCilTermOffset vis o in
 
6763
  let vTerm t = visitCilTerm vis t in
 
6764
  match toff with
 
6765
      TNoOffset -> toff
 
6766
    | TField (fi, t) ->
 
6767
        let t' = vOffset t in
 
6768
        let fi' = vis#behavior.get_fieldinfo fi in
 
6769
          if t' != t || fi != fi' then TField(fi',t') else toff
 
6770
    | TIndex(t,o) ->
 
6771
        let t' = vTerm t in let o' = vOffset o in
 
6772
        if t' != t || o' != o then TIndex(t',o') else toff
 
6773
 
 
6774
and visitCilTsets vis loc =
 
6775
  doVisit vis (fun x -> x) vis#vtsets childrenTsets loc
 
6776
and childrenTsets vis loc =
 
6777
  match loc with
 
6778
      TSSingleton lval ->
 
6779
        let lval' = visitCilTsetsElem vis lval in
 
6780
        if lval' != lval then TSSingleton lval' else loc
 
6781
    | TSUnion locs ->
 
6782
        let locs' = mapNoCopy (visitCilTsets vis) locs in
 
6783
        if locs != locs' then TSUnion(locs') else loc
 
6784
    | TSInter locs ->
 
6785
        let locs' = mapNoCopy (visitCilTsets vis) locs in
 
6786
        if locs != locs' then TSInter(locs') else loc
 
6787
    | TSComprehension(lval,quant,pred) ->
 
6788
        let quant' = visitCilQuantifiers vis quant in
 
6789
        let lval' = visitCilTsets vis lval in
 
6790
        let pred' = (opt_map (visitCilPredicateNamed vis)) pred in
 
6791
        if lval' != lval || quant' != quant || pred' != pred
 
6792
        then
 
6793
          TSComprehension(lval',quant',pred')
 
6794
        else
 
6795
          loc
 
6796
    | TSEmpty -> loc
 
6797
 
 
6798
and visitCilTsetsLhost vis h =
 
6799
 doVisit vis (fun x -> x) vis#vtsets_lhost childrenTsetsLhost h
 
6800
 
 
6801
and childrenTsetsLhost vis h =
 
6802
  match h with
 
6803
    | TSVar v ->
 
6804
        let v' = visitCilLogicVarUse vis v in if v != v' then TSVar v' else h
 
6805
    | TSResult -> h
 
6806
    | TSMem m ->
 
6807
        let m' = visitCilTsetsElem vis m in if m != m' then TSMem m' else h
 
6808
 
 
6809
and visitCilTsetsElem vis lv =
 
6810
  doVisit vis (fun x->x) vis#vtsets_elem childrenTsetsElem lv
 
6811
 
 
6812
and childrenTsetsElem vis e =
 
6813
  match e with
 
6814
    | TSLval lv ->
 
6815
        let lv' = visitCilTsetsLval vis lv in
 
6816
        if lv' != lv then  TSLval lv' else e
 
6817
    | TSStartOf lv ->
 
6818
        let lv' = visitCilTsetsLval vis lv in
 
6819
        if lv' != lv then TSStartOf lv' else e
 
6820
    | TSAddrOf lv ->
 
6821
        let lv' = visitCilTsetsLval vis lv in
 
6822
        if lv' != lv then TSAddrOf lv' else e
 
6823
    | TSConst _ -> e
 
6824
    | TSCastE(typ,elem) ->
 
6825
        let typ' = visitCilType vis typ in
 
6826
        let elem' = visitCilTsetsElem vis elem in
 
6827
        if typ' != typ || elem' != elem then TSCastE(typ', elem') else e
 
6828
    | TSAdd_range(ts,low,high) ->
 
6829
        let ts' = visitCilTsetsElem vis ts in
 
6830
        let low' = (opt_map (visitCilTerm vis)) low in
 
6831
        let high' = (opt_map (visitCilTerm vis)) high in
 
6832
        if ts' != ts || low' != low || high' != high then
 
6833
          TSAdd_range(ts',low',high')
 
6834
        else e
 
6835
    | TSAdd_index(ts,i) ->
 
6836
        let ts' = visitCilTsetsElem vis ts in
 
6837
        let i' = visitCilTerm vis i in
 
6838
        if ts' != ts || i' != i then TSAdd_index(ts',i') else e
 
6839
    | TSat(locs,lab) ->
 
6840
        let locs' = visitCilTsetsElem vis locs in
 
6841
        let lab' = visitCilLogicLabel vis lab in
 
6842
        if locs != locs' || lab != lab' then TSat(locs',lab') else e
 
6843
    | TSapp(f,labs,args) ->
 
6844
        let f' = visitCilLogicInfo vis f in
 
6845
        let labs' =
 
6846
          mapNoCopy (function (x,y) as orig ->
 
6847
                       let x' = visitCilLogicLabel vis x in
 
6848
                       let y' = visitCilLogicLabel vis y in
 
6849
                       if x' != x || y' != y then (x',y') else orig) labs
 
6850
        in
 
6851
        let args' = mapNoCopy (visitCilTerm vis) args in
 
6852
        if f != f' || labs' != labs || args' != args then
 
6853
          TSapp(f',labs',args')
 
6854
        else e
 
6855
 
 
6856
and visitCilTsetsLval vis lv =
 
6857
  doVisit vis (fun x -> x) vis#vtsets_lval childrenTsetsLval lv
 
6858
and childrenTsetsLval vis (h,o as lv) =
 
6859
  let h' = visitCilTsetsLhost vis h in
 
6860
  let o' = visitCilTsetsOffset vis o in
 
6861
  if h' != h || o' != o then h',o' else  lv
 
6862
 
 
6863
and visitCilTsetsOffset vis o =
 
6864
  doVisit vis (fun x -> x) vis#vtsets_offset childrenTsetsOffset o
 
6865
 
 
6866
and childrenTsetsOffset vis o =
 
6867
  match o with
 
6868
      TSNoOffset -> o
 
6869
    | TSIndex (i,next) ->
 
6870
        let i' = visitCilTerm vis i in
 
6871
        let next' = visitCilTsetsOffset vis next in
 
6872
        if i != i' || next != next' then TSIndex (i',next') else o
 
6873
    | TSRange (i1,i2,next) ->
 
6874
        let i1' = (opt_map (visitCilTerm vis)) i1 in
 
6875
        let i2' = (opt_map (visitCilTerm vis)) i2 in
 
6876
        let next' = visitCilTsetsOffset vis next in
 
6877
        if i1' != i1 || i2' != i2 || next' != next then
 
6878
          TSRange(i1',i2',next')
 
6879
        else o
 
6880
    | TSField (f,next) ->
 
6881
        let next' = visitCilTsetsOffset vis next in
 
6882
        let f' = vis#behavior.get_fieldinfo f in
 
6883
        if next' != next || f != f' then TSField(f',next') else o
 
6884
 
 
6885
and visitCilLogicInfo vis li =
 
6886
  doVisit
 
6887
    vis vis#behavior.memo_logic_info
 
6888
    vis#vlogic_info_decl childrenLogicInfo li
 
6889
 
 
6890
and childrenLogicInfo vis li =
 
6891
  let lt = opt_map (visitCilLogicType vis) li.l_type in
 
6892
  let lp = mapNoCopy (visitCilLogicVarDecl vis) li.l_profile in
 
6893
(*    (fun p ->
 
6894
       let lt' = visitCilLogicType vis p.lv_type in
 
6895
         if lt' != p.lv_type then { p with lv_type = lt'} else p)
 
6896
    li.l_profile
 
6897
 
 
6898
  in
 
6899
*)
 
6900
  li.l_type <- lt;
 
6901
  li.l_profile <- lp;
 
6902
  li.l_body <-
 
6903
    begin
 
6904
      match li.l_body with
 
6905
        | LBreads ol ->
 
6906
            let l = mapNoCopy (visitCilTsets vis) ol in
 
6907
            if l != ol then LBreads l else li.l_body
 
6908
        | LBterm ot ->
 
6909
            let t = visitCilTerm vis ot in
 
6910
            if t != ot then LBterm t else li.l_body
 
6911
        | LBinductive inddef ->
 
6912
            let i =
 
6913
              mapNoCopy 
 
6914
                (fun (id,labs,tvars,p) -> 
 
6915
                   (id, labs, tvars, visitCilPredicateNamed vis p)) 
 
6916
                inddef
 
6917
            in
 
6918
            if i != inddef then LBinductive i else li.l_body
 
6919
        | LBpred odef ->
 
6920
            let def = visitCilPredicateNamed vis odef in
 
6921
            if def != odef then LBpred def else li.l_body
 
6922
    end;
 
6923
  li
 
6924
 
 
6925
and visitCilLogicType vis t =
 
6926
  doVisit vis (fun x -> x) vis#vlogic_type childrenLogicType t
 
6927
 
 
6928
and childrenLogicType vis ty =
 
6929
  match ty with
 
6930
      Ctype t ->
 
6931
        let t' = visitCilType vis t in
 
6932
          if t != t' then Ctype t' else ty
 
6933
    | Linteger | Lreal -> ty
 
6934
    | Ltype (s,l) ->
 
6935
        let l' = mapNoCopy (visitCilLogicType vis) l in
 
6936
        if l' != l then Ltype (s,l') else ty
 
6937
    | Larrow(args,rttyp) ->
 
6938
        let args' = mapNoCopy(visitCilLogicType vis) args in
 
6939
        let rttyp' = visitCilLogicType vis rttyp in
 
6940
        if args' != args || rttyp' != rttyp then Larrow(args',rttyp') else ty
 
6941
    | Lvar _ -> ty
 
6942
 
 
6943
and visitCilLogicVarDecl vis lv =
 
6944
  (* keep names in C and logic worlds in sync *)
 
6945
  (match lv.lv_origin with
 
6946
        None -> ()
 
6947
      | Some cv -> lv.lv_name <- cv.vname);
 
6948
  doVisit vis vis#behavior.memo_logic_var vis#vlogic_var_decl
 
6949
    childrenLogicVarDecl lv
 
6950
 
 
6951
and childrenLogicVarDecl vis lv =
 
6952
  lv.lv_type <- visitCilLogicType vis lv.lv_type;
 
6953
  lv.lv_origin <-
 
6954
    opt_map (visitCilVarUse vis) lv.lv_origin;
 
6955
  lv
 
6956
 
 
6957
and visitCilLogicVarUse vis lv =
 
6958
  doVisit vis vis#behavior.get_logic_var vis#vlogic_var_use
 
6959
    childrenLogicVarUse lv
 
6960
 
 
6961
and childrenLogicVarUse vis lv =
 
6962
  lv.lv_origin <- opt_map (visitCilVarUse vis) lv.lv_origin; lv
 
6963
 
 
6964
and visitCilQuantifiers vis lv =
 
6965
  doVisit vis (fun x -> x) vis#vquantifiers
 
6966
    (fun vis l -> mapNoCopy (visitCilLogicVarDecl vis) l) lv
 
6967
 
 
6968
and visitCilPredicate vis p =
 
6969
  doVisit vis (fun x -> x) vis#vpredicate childrenPredicate p
 
6970
 
 
6971
and visitCilPredicateNamed vis p =
 
6972
  doVisit vis
 
6973
    (fun x -> x) vis#vpredicate_named childrenPredicateNamed p
 
6974
 
 
6975
and childrenPredicateNamed vis p =
 
6976
  let content = visitCilPredicate vis p.content in
 
6977
  if content != p.content then { p with content = content} else p
 
6978
 
 
6979
and childrenPredicate vis p =
 
6980
  let vPred p = visitCilPredicateNamed vis p in
 
6981
  let vLogicInfo li =
 
6982
    doVisit vis vis#behavior.get_logic_info
 
6983
      vis#vlogic_info_use (fun _ x ->x) li
 
6984
  in
 
6985
(*
 
6986
  let vPredInfo p =
 
6987
    doVisit vis
 
6988
      vis#behavior.get_logic_f vis#vpredicate_info_use (fun _ x -> x) p
 
6989
  in
 
6990
*)
 
6991
  let vTerm t = visitCilTerm vis t in
 
6992
  let vTsets t = visitCilTsets vis t in
 
6993
  match p with
 
6994
      Pfalse | Ptrue -> p
 
6995
    | Papp (pred,labels,args) ->
 
6996
        let pred' = vLogicInfo pred in
 
6997
        let args' = mapNoCopy vTerm args in
 
6998
        if pred' != pred || args' != args then
 
6999
          Papp(pred',labels,args')
 
7000
        else p
 
7001
    | Prel(rel,t1,t2) ->
 
7002
        let t1' = vTerm t1 in
 
7003
        let t2' = vTerm t2 in
 
7004
        if t1' != t1 || t2' != t2 then
 
7005
          Prel(rel,t1',t2')
 
7006
        else p
 
7007
    | Pand(p1,p2) ->
 
7008
        let p1' = vPred p1 in
 
7009
        let p2' = vPred p2 in
 
7010
        if p1' != p1 || p2' != p2 then
 
7011
          Pand(p1',p2')
 
7012
        else p
 
7013
    | Por(p1,p2) ->
 
7014
        let p1' = vPred p1 in
 
7015
        let p2' = vPred p2 in
 
7016
        if p1' != p1 || p2' != p2 then
 
7017
          Por(p1',p2')
 
7018
        else p
 
7019
    | Pxor(p1,p2) ->
 
7020
        let p1' = vPred p1 in
 
7021
        let p2' = vPred p2 in
 
7022
        if p1' != p1 || p2' != p2 then
 
7023
          Pxor(p1',p2')
 
7024
        else p
 
7025
    | Pimplies(p1,p2) ->
 
7026
        let p1' = vPred p1 in
 
7027
        let p2' = vPred p2 in
 
7028
        if p1' != p1 || p2' != p2 then
 
7029
          Pimplies(p1',p2')
 
7030
        else p
 
7031
    | Piff(p1,p2) ->
 
7032
        let p1' = vPred p1 in
 
7033
        let p2' = vPred p2 in
 
7034
        if p1' != p1 || p2' != p2 then
 
7035
          Piff(p1',p2')
 
7036
        else p
 
7037
    | Pnot p1 ->
 
7038
        let p1' = vPred p1 in
 
7039
        if p1' != p1 then Pnot p1' else p
 
7040
    | Pif(t,ptrue,pfalse) ->
 
7041
        let t' = vTerm t in
 
7042
        let ptrue' = vPred ptrue in
 
7043
        let pfalse' = vPred pfalse in
 
7044
        if t' != t || ptrue' != ptrue || pfalse' != pfalse then
 
7045
          Pif(t', ptrue',pfalse')
 
7046
        else p
 
7047
    | Plet(var,t,p1) ->
 
7048
        let var' = visitCilLogicVarDecl vis var in
 
7049
        let t' = vTerm t in
 
7050
        let p1' = vPred p1 in
 
7051
        if var' != var || t' != t || p1' != p1 then
 
7052
          Plet(var',t',p1')
 
7053
        else p
 
7054
    | Pforall(quant,p1) ->
 
7055
        let quant' = visitCilQuantifiers vis quant in
 
7056
        let p1' = vPred p1 in
 
7057
        if quant' != quant || p1' != p1 then
 
7058
          Pforall(quant', p1')
 
7059
        else p
 
7060
    | Pexists(quant,p1) ->
 
7061
        let quant' = visitCilQuantifiers vis quant in
 
7062
        let p1' = vPred p1 in
 
7063
        if quant' != quant || p1' != p1 then
 
7064
          Pexists(quant', p1')
 
7065
        else p
 
7066
    | Pold p1 ->
 
7067
        let p1' = vPred p1 in if p1' != p1 then Pold p1' else p
 
7068
    | Pat(p1,s) ->
 
7069
        let p1' = vPred p1 in
 
7070
        let s' = visitCilLogicLabel vis s in
 
7071
        if p1' != p1 then Pat(p1',s') else p
 
7072
    | Pvalid t ->
 
7073
        let t' = vTsets t in if t' != t then Pvalid t' else p
 
7074
    | Pvalid_index (t1,t2) ->
 
7075
        let t1' = vTerm t1 in
 
7076
        let t2' = vTerm t2 in
 
7077
        if t1' != t1 || t2' != t2 then Pvalid_index (t1',t2') else p
 
7078
    | Pvalid_range(t1,t2,t3) ->
 
7079
        let t1' = vTerm t1 in
 
7080
        let t2' = vTerm t2 in
 
7081
        let t3' = vTerm t3 in
 
7082
        if t1' != t1 || t2' != t2 || t3' != t3 then
 
7083
          Pvalid_range (t1',t2',t3') else p
 
7084
    | Pseparated seps ->
 
7085
        let seps' = mapNoCopy vTsets seps in
 
7086
        if seps' != seps then Pseparated seps' else p
 
7087
    | Pfresh t ->
 
7088
        let t' = vTerm t in if t' != t then Pfresh t' else p
 
7089
(*    | Pnamed(s,p1) ->
 
7090
        let p1' = vPred p1 in if p1' != p1 then Pnamed (s,p1') else p *)
 
7091
    | Psubtype(te,tc) ->
 
7092
        let tc' = vTerm tc in
 
7093
        let te' = vTerm te in
 
7094
        if tc' != tc || te' != te then Psubtype(te',tc') else p
 
7095
 
 
7096
(*
 
7097
and visitCilPredicateInfo vis pi =
 
7098
  doVisit vis vis#behavior.memo_predicate_info
 
7099
    vis#vpredicate_info_decl childrenPredicateInfo pi
 
7100
*)
 
7101
 
 
7102
 
 
7103
and visitCilIdLocations vis loc =
 
7104
  let loc' = visitCilTsets vis loc.its_content in
 
7105
  if loc' != loc.its_content then { loc with its_content = loc' } else loc
 
7106
 
 
7107
and visitCilZone vis z =
 
7108
  doVisit vis (fun x -> x) vis#vzone childrenZone z
 
7109
and childrenZone vis z =
 
7110
  match z with
 
7111
      Nothing -> z
 
7112
    | Location loc ->
 
7113
        let loc' = visitCilIdLocations vis loc in
 
7114
        if loc' != loc then Location loc' else z
 
7115
 
 
7116
and visitCilAssigns vis a =
 
7117
  doVisit vis (fun x -> x) vis#vassigns childrenAssigns a
 
7118
and childrenAssigns vis ((z,l) as a)=
 
7119
  let z' = visitCilZone vis z in
 
7120
  let l' = mapNoCopy (visitCilZone vis) l in
 
7121
  if z' != z || l' != l then (z',l') else a
 
7122
 
 
7123
and visitCilBehavior vis b =
 
7124
  doVisit vis vis#behavior.cfunbehavior
 
7125
    vis#vbehavior childrenBehavior b
 
7126
 
 
7127
and childrenBehavior vis b =
 
7128
  b.b_assumes <- visitCilPredicates vis b.b_assumes;
 
7129
  b.b_ensures <- visitCilPredicates vis b.b_ensures;
 
7130
  b.b_assigns <- mapNoCopy (visitCilAssigns vis) b.b_assigns;
 
7131
  b
 
7132
 
 
7133
and visitCilPredicates vis ps = mapNoCopy (visitCilIdPredicate vis) ps
 
7134
 
 
7135
and visitCilIdPredicate vis ps =
 
7136
  let p' = visitCilPredicate vis ps.ip_content in
 
7137
  if p' != ps.ip_content then { ps with ip_content = p' } else ps
 
7138
 
 
7139
and visitCilBehaviors vis bs = mapNoCopy (visitCilBehavior vis) bs
 
7140
 
 
7141
and visitCilFunspec vis s =
 
7142
  doVisit vis vis#behavior.cfunspec vis#vspec childrenSpec s
 
7143
 
 
7144
and childrenSpec vis s =
 
7145
  s.spec_requires <- visitCilPredicates vis s.spec_requires;
 
7146
  s.spec_behavior <- visitCilBehaviors vis s.spec_behavior;
 
7147
  s.spec_variant <-
 
7148
    opt_map (fun x -> (visitCilTerm vis (fst x), snd x)) s.spec_variant;
 
7149
  s.spec_terminates <-
 
7150
    opt_map (visitCilIdPredicate vis) s.spec_terminates;
 
7151
  (* nothing is done now for behaviors names, no need to visit complete and
 
7152
     disjoint behaviors clauses
 
7153
   *)
 
7154
  s
 
7155
 
 
7156
and visitCilSlicePragma vis p =
 
7157
  doVisit vis (fun x -> x) vis#vslice_pragma childrenSlicePragma p
 
7158
 
 
7159
and childrenSlicePragma vis p =
 
7160
  match p with
 
7161
      | SPexpr t ->
 
7162
          let t' = visitCilTerm vis t in if t' != t then SPexpr t' else p
 
7163
      | SPctrl | SPstmt -> p
 
7164
 
 
7165
and visitCilImpactPragma vis p =
 
7166
  doVisit vis (fun x -> x) vis#vimpact_pragma childrenImpactPragma p
 
7167
 
 
7168
and childrenImpactPragma vis p = match p with
 
7169
  | IPexpr t -> let t' = visitCilTerm vis t in if t' != t then IPexpr t' else p
 
7170
  | IPstmt -> p
 
7171
 
 
7172
and visitCilLoopPragma vis p =
 
7173
  doVisit vis
 
7174
    (fun x -> x) vis#vloop_pragma childrenLoopPragma p
 
7175
 
 
7176
and childrenLoopPragma vis p =
 
7177
match p with
 
7178
  | Unroll_level t -> let t' = visitCilTerm vis t in
 
7179
    if t' != t then Unroll_level t' else p
 
7180
  | Widen_hints lt -> let lt' = List.map (visitCilTerm vis) lt in
 
7181
    if lt' != lt then Widen_hints lt' else p
 
7182
  | Widen_variables lt -> let lt' = List.map (visitCilTerm vis) lt in
 
7183
    if lt' != lt then Widen_variables lt' else p
 
7184
 
 
7185
and visitCilAnnotation vis a =
 
7186
  doVisit vis (fun x -> x) vis#vannotation childrenAnnotation a
 
7187
 
 
7188
and visitCilAxiom vis ((id,p) as a) =
 
7189
  let p' = visitCilPredicateNamed vis p in
 
7190
  if p' != p then (id,p') else a
 
7191
 
 
7192
and childrenAnnotation vis a =
 
7193
  match a with
 
7194
    | Dfun_or_pred li ->
 
7195
        let li' = visitCilLogicInfo vis li in
 
7196
        if li' != li then Dfun_or_pred li' else a
 
7197
(*
 
7198
      Dpredicate_reads (s, tvars, args,loc) ->
 
7199
        let s' = visitCilPredicateInfo vis s in
 
7200
        let args' = mapNoCopy (visitCilLogicVarDecl vis) args in
 
7201
        let loc' = mapNoCopy (visitCilTsets vis) loc in
 
7202
        if s'!=s || args' != args || loc' != loc then
 
7203
          Dpredicate_reads(s',tvars,args',loc')
 
7204
        else a
 
7205
    | Dpredicate_def(s,tvars,args,def) ->
 
7206
        let s' = visitCilPredicateInfo vis s in
 
7207
        let args' = mapNoCopy (visitCilLogicVarDecl vis) args in
 
7208
        let def' = visitCilPredicateNamed vis def in
 
7209
        if s' != s || args' != args || def' != def then
 
7210
          Dpredicate_def(s',tvars,args',def')
 
7211
        else a
 
7212
    | Dinductive_def(s,tvars,args,indcases) ->
 
7213
        let s' = visitCilPredicateInfo vis s in
 
7214
        let args' = mapNoCopy (visitCilLogicVarDecl vis) args in
 
7215
        let indcases' = mapNoCopy (visitCilAxiom vis) indcases in
 
7216
        if s' != s || args' != args || indcases' != indcases then
 
7217
          Dinductive_def(s',tvars,args',indcases')
 
7218
        else a
 
7219
*)
 
7220
 
 
7221
    | Dtype _ -> a (* nothing to visit here for now *)
 
7222
(*
 
7223
    | Dlogic_reads(s,tvars,args,rt,loc) ->
 
7224
        let s' = visitCilLogicInfo vis s in
 
7225
        let args' = mapNoCopy (visitCilLogicVarDecl vis) args in
 
7226
        let rt' = visitCilLogicType vis rt in
 
7227
        let loc' = mapNoCopy (visitCilTsets vis) loc in
 
7228
        if s'!= s || args' != args || rt' != rt || loc' != loc then
 
7229
          Dlogic_reads(s',tvars,args',rt',loc')
 
7230
        else a
 
7231
    | Dlogic_def(s,tvars,args,rt,def) ->
 
7232
        let s' = visitCilLogicInfo vis s in
 
7233
        let args' = mapNoCopy (visitCilLogicVarDecl vis) args in
 
7234
        let rt' = visitCilLogicType vis rt in
 
7235
        let def' = visitCilTerm vis def in
 
7236
        if s != s' || args' != args || rt' != rt || def' != def then
 
7237
          Dlogic_def(s',tvars,args',rt',def')
 
7238
        else a
 
7239
    | Dlogic_axiomatic(s,tvars,args,rt,axioms) ->
 
7240
        let s' = visitCilLogicInfo vis s in
 
7241
        let args' = mapNoCopy (visitCilLogicVarDecl vis) args in
 
7242
        let rt' = visitCilLogicType vis rt in
 
7243
        let axioms' = mapNoCopy (visitCilAxiom vis) axioms in
 
7244
        if s != s' || args' != args || rt' != rt || axioms' != axioms then
 
7245
          Dlogic_axiomatic(s',tvars,args',rt',axioms')
 
7246
        else a
 
7247
*)
 
7248
    | Dlemma(s,is_axiom,labels,tvars,p) ->
 
7249
        let p' = visitCilPredicateNamed vis p in
 
7250
        if p' != p then Dlemma(s,is_axiom,labels,tvars,p') else a
 
7251
    | Dinvariant p ->
 
7252
        let p' = visitCilLogicInfo vis p in
 
7253
        if p' != p then Dinvariant p' else a
 
7254
    | Dtype_annot ta ->
 
7255
        let ta' = visitCilLogicInfo vis ta in
 
7256
        if ta' != ta then Dtype_annot ta' else a
 
7257
    | Daxiomatic(id,l) ->
 
7258
(*
 
7259
        Format.eprintf "cil.visitCilAnnotation on axiomatic %s@." id;
 
7260
*)
 
7261
        let l' = mapNoCopy (visitCilAnnotation vis) l in
 
7262
        if l' != l then Daxiomatic(id,l') else a
 
7263
 
 
7264
and visitCilCodeAnnotation vis ca =
 
7265
  doVisit vis (fun x -> x) vis#vcode_annot childrenCodeAnnot ca
 
7266
 
 
7267
and childrenCodeAnnot vis ca =
 
7268
  let vPred p = visitCilPredicateNamed vis p in
 
7269
  let vTerm t = visitCilTerm vis t in
 
7270
  let vSpec s = visitCilFunspec vis s in
 
7271
  let change_content annot = { ca with annot_content = annot } in
 
7272
  match ca.annot_content with
 
7273
      AAssert (behav,p,_status) ->
 
7274
        (* TODO: status is reset to Unkown if the predicate changed but
 
7275
           remain unchanged otherwise. It should be visited. *)
 
7276
        let p' = vPred p in if p' != p then
 
7277
          change_content (AAssert (behav,p',{status=Unknown}))
 
7278
        else ca
 
7279
    | AAssume p ->
 
7280
        let p' = vPred p in if p' != p then change_content (AAssume p') else ca
 
7281
    | APragma (Impact_pragma t) ->
 
7282
        let t' = visitCilImpactPragma vis t in
 
7283
        if t' != t then change_content (APragma (Impact_pragma t')) else ca
 
7284
    | APragma (Slice_pragma t) ->
 
7285
        let t' = visitCilSlicePragma vis t in
 
7286
        if t' != t then change_content (APragma (Slice_pragma t')) else ca
 
7287
    | APragma (Loop_pragma p) ->
 
7288
        let p' = visitCilLoopPragma vis p in
 
7289
        if p' != p then change_content (APragma (Loop_pragma p')) else ca
 
7290
    | AStmtSpec s ->
 
7291
        let s' = vSpec s in
 
7292
        if s' != s then change_content (AStmtSpec s') else ca
 
7293
    | AInvariant(behav,f,p) ->
 
7294
        let p' = vPred p in
 
7295
        if p' != p then change_content (AInvariant (behav,f,p')) else ca
 
7296
    | AVariant ((t,s)) ->
 
7297
        let t' = vTerm t in
 
7298
        if t != t' then change_content (AVariant ((t',s))) else ca
 
7299
    | AAssigns a ->
 
7300
        let a' = visitCilAssigns vis a in
 
7301
        if a != a' then change_content (AAssigns a') else ca
 
7302
 
 
7303
and visitCilExpr (vis: cilVisitor) (e: exp) : exp =
 
7304
  doVisit vis (fun x -> x) vis#vexpr childrenExp e
 
7305
and childrenExp (vis: cilVisitor) (e: exp) : exp =
 
7306
  let vExp e = visitCilExpr vis e in
 
7307
  let vTyp t = visitCilType vis t in
 
7308
  let vLval lv = visitCilLval vis lv in
 
7309
  match stripInfo e with
 
7310
  | Info _ -> assert false
 
7311
  | Const _ -> e (* enum constants are visited at their declaration site *)
 
7312
  | SizeOf t ->
 
7313
      let t'= vTyp t in
 
7314
      if t' != t then SizeOf t' else e
 
7315
  | SizeOfE e1 ->
 
7316
      let e1' = vExp e1 in
 
7317
      if e1' != e1 then SizeOfE e1' else e
 
7318
  | SizeOfStr _s -> e
 
7319
 
 
7320
  | AlignOf t ->
 
7321
      let t' = vTyp t in
 
7322
      if t' != t then AlignOf t' else e
 
7323
  | AlignOfE e1 ->
 
7324
      let e1' = vExp e1 in
 
7325
      if e1' != e1 then AlignOfE e1' else e
 
7326
  | Lval lv ->
 
7327
      let lv' = vLval lv in
 
7328
      if lv' != lv then Lval lv' else e
 
7329
  | UnOp (uo, e1, t) ->
 
7330
      let e1' = vExp e1 in let t' = vTyp t in
 
7331
      if e1' != e1 || t' != t then UnOp(uo, e1', t') else e
 
7332
  | BinOp (bo, e1, e2, t) ->
 
7333
      let e1' = vExp e1 in let e2' = vExp e2 in let t' = vTyp t in
 
7334
      if e1' != e1 || e2' != e2 || t' != t then BinOp(bo, e1',e2',t') else e
 
7335
  | CastE (t, e1) ->
 
7336
      let t' = vTyp t in let e1' = vExp e1 in
 
7337
      if t' != t || e1' != e1 then CastE(t', e1') else e
 
7338
  | AddrOf lv ->
 
7339
      let lv' = vLval lv in
 
7340
      if lv' != lv then AddrOf lv' else e
 
7341
  | StartOf lv ->
 
7342
      let lv' = vLval lv in
 
7343
      if lv' != lv then StartOf lv' else e
 
7344
 
 
7345
and visitCilInit (vis: cilVisitor) (forglob: varinfo)
 
7346
                 (atoff: offset) (i: init) : init =
 
7347
  let rec childrenInit (vis: cilVisitor) (i: init) : init =
 
7348
    let fExp e = visitCilExpr vis e in
 
7349
    let fTyp t = visitCilType vis t in
 
7350
    match i with
 
7351
    | SingleInit e ->
 
7352
        let e' = fExp e in
 
7353
        if e' != e then SingleInit e' else i
 
7354
    | CompoundInit (t, initl) ->
 
7355
        let t' = fTyp t in
 
7356
        (* Collect the new initializer list, in reverse. We prefer two
 
7357
         * traversals to ensure tail-recursion. *)
 
7358
        let newinitl : (offset * init) list ref = ref [] in
 
7359
        (* Keep track whether the list has changed *)
 
7360
        let hasChanged = ref false in
 
7361
        let doOneInit ((o, i) as oi) =
 
7362
          let o' = visitCilInitOffset vis o in    (* use initializer version *)
 
7363
          let i' = visitCilInit vis forglob (addOffset o' atoff) i in
 
7364
          let newio =
 
7365
            if o' != o || i' != i then
 
7366
              begin hasChanged := true; (o', i') end else oi
 
7367
          in
 
7368
          newinitl := newio :: !newinitl
 
7369
        in
 
7370
        List.iter doOneInit initl;
 
7371
        let initl' = if !hasChanged then List.rev !newinitl else initl in
 
7372
        if t' != t || initl' != initl then CompoundInit (t', initl') else i
 
7373
  in
 
7374
  doVisit vis (fun x -> x) (vis#vinit forglob atoff) childrenInit i
 
7375
 
 
7376
and visitCilLval (vis: cilVisitor) (lv: lval) : lval =
 
7377
  doVisit vis (fun x -> x) vis#vlval childrenLval lv
 
7378
and childrenLval (vis: cilVisitor) (lv: lval) : lval =
 
7379
  (* and visit its subexpressions *)
 
7380
  let vExp e = visitCilExpr vis e in
 
7381
  let vOff off = visitCilOffset vis off in
 
7382
  match lv with
 
7383
    Var v, off ->
 
7384
      let v'= visitCilVarUse vis v in
 
7385
      let off' = vOff off in
 
7386
      if v' != v || off' != off then Var v', off' else lv
 
7387
  | Mem e, off ->
 
7388
      let e' = vExp e in
 
7389
      let off' = vOff off in
 
7390
      if e' != e || off' != off then Mem e', off' else lv
 
7391
 
 
7392
and visitCilOffset (vis: cilVisitor) (off: offset) : offset =
 
7393
  doVisit vis (fun x -> x) vis#voffs childrenOffset off
 
7394
and childrenOffset (vis: cilVisitor) (off: offset) : offset =
 
7395
  let vOff off = visitCilOffset vis off in
 
7396
  match off with
 
7397
    Field (f, o) ->
 
7398
      let o' = vOff o in
 
7399
      let f' = vis#behavior.get_fieldinfo f in
 
7400
      if o' != o || f' != f then Field (f', o') else off
 
7401
  | Index (e, o) ->
 
7402
      let e' = visitCilExpr vis e in
 
7403
      let o' = vOff o in
 
7404
      if e' != e || o' != o then Index (e', o') else off
 
7405
  | NoOffset -> off
 
7406
 
 
7407
(* sm: for offsets in initializers, the 'startvisit' will be the
 
7408
 * vinitoffs method, but we can re-use the childrenOffset from
 
7409
 * above since recursive offsets are visited by voffs.  (this point
 
7410
 * is moot according to cil.mli which claims the offsets in
 
7411
 * initializers will never recursively contain offsets)
 
7412
 *)
 
7413
and visitCilInitOffset (vis: cilVisitor) (off: offset) : offset =
 
7414
  doVisit vis (fun x -> x) vis#vinitoffs childrenOffset off
 
7415
 
 
7416
and visitCilInstr (vis: cilVisitor) (i: instr) : instr list =
 
7417
  let oldloc = CurrentLoc.get () in
 
7418
  CurrentLoc.set (get_instrLoc i);
 
7419
  assertEmptyQueue vis;
 
7420
  let res =
 
7421
    doVisitList vis (fun x -> x) vis#vinst childrenInstr i in
 
7422
  CurrentLoc.set oldloc;
 
7423
  (* See if we have accumulated some instructions *)
 
7424
  vis#unqueueInstr () @ res
 
7425
 
 
7426
and childrenInstr (vis: cilVisitor) (i: instr) : instr =
 
7427
  let fExp = visitCilExpr vis in
 
7428
  let fLval = visitCilLval vis in
 
7429
  match i with
 
7430
  | Skip _l ->
 
7431
      i
 
7432
  | Set(lv,e,l) ->
 
7433
      let lv' = fLval lv in let e' = fExp e in
 
7434
      if lv' != lv || e' != e then Set(lv',e',l) else i
 
7435
  | Call(None,f,args,l) ->
 
7436
      let f' = fExp f in let args' = mapNoCopy fExp args in
 
7437
      if f' != f || args' != args then Call(None,f',args',l) else i
 
7438
  | Call(Some lv,fn,args,l) ->
 
7439
      let lv' = fLval lv in let fn' = fExp fn in
 
7440
      let args' = mapNoCopy fExp args in
 
7441
      if lv' != lv || fn' != fn || args' != args
 
7442
      then Call(Some lv', fn', args', l) else i
 
7443
 
 
7444
  | Asm(sl,isvol,outs,ins,clobs,l) ->
 
7445
      let outs' = mapNoCopy (fun ((id,s,lv) as pair) ->
 
7446
                               let lv' = fLval lv in
 
7447
                               if lv' != lv then (id,s,lv') else pair) outs in
 
7448
      let ins'  = mapNoCopy (fun ((id,s,e) as pair) ->
 
7449
                               let e' = fExp e in
 
7450
                               if e' != e then (id,s,e') else pair) ins in
 
7451
      if outs' != outs || ins' != ins then
 
7452
        Asm(sl,isvol,outs',ins',clobs,l) else i
 
7453
  | Code_annot (a,l) ->
 
7454
      let a' = visitCilCodeAnnotation vis a in Code_annot(a',l)
 
7455
 
 
7456
 
 
7457
(* visit all nodes in a Cil statement tree in preorder *)
 
7458
and visitCilStmt (vis:cilVisitor) (s: stmt) : stmt =
 
7459
  let oldloc = CurrentLoc.get () in
 
7460
  CurrentLoc.set (get_stmtLoc s.skind) ;
 
7461
  vis#push_stmt s; (*(vis#behavior.memo_stmt s);*)
 
7462
  assertEmptyQueue vis;
 
7463
  let toPrepend : instr list ref = ref [] in (* childrenStmt may add to this *)
 
7464
  let res =
 
7465
    doVisit vis
 
7466
      vis#behavior.memo_stmt vis#vstmt (childrenStmt toPrepend) s in
 
7467
  (* Now see if we have saved some instructions *)
 
7468
  toPrepend := !toPrepend @ vis#unqueueInstr ();
 
7469
  (match !toPrepend with
 
7470
    [] -> () (* Return the same statement *)
 
7471
  | _ ->
 
7472
      (* Make our statement contain the instructions to prepend *)
 
7473
      res.skind <-
 
7474
        Block { battrs = [];
 
7475
                bstmts = (List.map (fun i -> mkStmt (Instr i)) !toPrepend) @
 
7476
                         [ mkStmt res.skind ] });
 
7477
  CurrentLoc.set oldloc;
 
7478
  vis#pop_stmt s;
 
7479
  res
 
7480
 
 
7481
and childrenStmt (toPrepend: instr list ref) (vis:cilVisitor) (s:stmt): stmt =
 
7482
  let fExp e = (visitCilExpr vis e) in
 
7483
  let fBlock b = visitCilBlock vis b in
 
7484
  let fInst i = visitCilInstr vis i in
 
7485
  let fLoopAnnot a = mapNoCopy (visitCilCodeAnnotation vis) a in
 
7486
  (* Just change the statement kind *)
 
7487
  let skind' =
 
7488
    match s.skind with
 
7489
      Break _ | Continue _ | Return (None, _) -> s.skind
 
7490
    | UnspecifiedSequence seq ->
 
7491
        let seq' =
 
7492
          mapNoCopy
 
7493
            (function (stmt,writes,reads) as orig->
 
7494
               let stmt' = visitCilStmt vis stmt in
 
7495
               let writes' = mapNoCopy (visitCilLval vis) writes in
 
7496
               let reads' = mapNoCopy (visitCilLval vis) reads in
 
7497
               if stmt' != stmt || writes' != writes || reads' != reads then
 
7498
                 (stmt',writes',reads')
 
7499
               else orig)
 
7500
            seq
 
7501
        in
 
7502
        if seq' != seq then UnspecifiedSequence seq' else s.skind
 
7503
    | Goto (sr,l) ->
 
7504
        if vis#behavior.is_copy_behavior then
 
7505
          Goto(ref (vis#behavior.memo_stmt !sr),l)
 
7506
        else s.skind
 
7507
    | Return (Some e, l) ->
 
7508
        let e' = fExp e in
 
7509
        if e' != e then Return (Some e', l) else s.skind
 
7510
    | Loop (a, b, l, s1, s2) ->
 
7511
        let a' = fLoopAnnot a in
 
7512
        let b' = fBlock b in
 
7513
        if a' != a || b' != b then Loop (a', b', l, s1, s2) else s.skind
 
7514
    | If(e, s1, s2, l) ->
 
7515
        let e' = fExp e in
 
7516
        (*if e queued any instructions, pop them here and remember them so that
 
7517
          they are inserted before the If stmt, not in the then block. *)
 
7518
        toPrepend := vis#unqueueInstr ();
 
7519
        let s1'= fBlock s1 in let s2'= fBlock s2 in
 
7520
        (* the stmts in the blocks should have cleaned up after themselves.*)
 
7521
        assertEmptyQueue vis;
 
7522
        if e' != e || s1' != s1 || s2' != s2 then
 
7523
          If(e', s1', s2', l) else s.skind
 
7524
    | Switch (e, b, stmts, l) ->
 
7525
        let e' = fExp e in
 
7526
        toPrepend := vis#unqueueInstr (); (* insert these before the switch *)
 
7527
        let b' = fBlock b in
 
7528
        (* the stmts in b should have cleaned up after themselves.*)
 
7529
        assertEmptyQueue vis;
 
7530
        (* Don't do stmts, but we better not change those *)
 
7531
        if e' != e || b' != b then Switch (e', b', stmts, l) else s.skind
 
7532
    | Instr i ->
 
7533
        begin match fInst i with
 
7534
          | [i'] when i' == i -> s.skind
 
7535
          | il -> stmt_of_instr_list ~loc:(get_instrLoc i) il
 
7536
        end
 
7537
    | Block b ->
 
7538
        let b' = fBlock b in
 
7539
        if b' != b then Block b' else s.skind
 
7540
    | TryFinally (b, h, l) ->
 
7541
        let b' = fBlock b in
 
7542
        let h' = fBlock h in
 
7543
        if b' != b || h' != h then TryFinally(b', h', l) else s.skind
 
7544
    | TryExcept (b, (il, e), h, l) ->
 
7545
        let b' = fBlock b in
 
7546
        assertEmptyQueue vis;
 
7547
        (* visit the instructions *)
 
7548
        let il' = mapNoCopyList fInst il in
 
7549
        (* Visit the expression *)
 
7550
        let e' = fExp e in
 
7551
        let il'' =
 
7552
          let more = vis#unqueueInstr () in
 
7553
          if more != [] then
 
7554
            il' @ more
 
7555
          else
 
7556
            il'
 
7557
        in
 
7558
        let h' = fBlock h in
 
7559
        (* Now collect the instructions *)
 
7560
        if b' != b || il'' != il || e' != e || h' != h then
 
7561
          TryExcept(b', (il'', e'), h', l)
 
7562
        else s.skind
 
7563
  in
 
7564
  if skind' != s.skind then s.skind <- skind';
 
7565
  (* Visit the labels *)
 
7566
  let labels' =
 
7567
    let fLabel = function
 
7568
        Case (e, l) as lb ->
 
7569
          let e' = fExp e in
 
7570
          if e' != e then Case (e', l) else lb
 
7571
        | lb -> lb
 
7572
    in
 
7573
    mapNoCopy fLabel s.labels
 
7574
  in
 
7575
  if labels' != s.labels then s.labels <- labels';
 
7576
  s
 
7577
 
 
7578
 
 
7579
 
 
7580
and visitCilBlock (vis: cilVisitor) (b: block) : block =
 
7581
  doVisit vis vis#behavior.cblock vis#vblock childrenBlock b
 
7582
and childrenBlock (vis: cilVisitor) (b: block) : block =
 
7583
  let fStmt s = visitCilStmt vis s in
 
7584
  let stmts' = mapNoCopy fStmt b.bstmts in
 
7585
  if stmts' != b.bstmts then { battrs = b.battrs; bstmts = stmts'} else b
 
7586
 
 
7587
 
 
7588
and visitCilType (vis : cilVisitor) (t : typ) : typ =
 
7589
  doVisit vis (fun x -> x) vis#vtype childrenType t
 
7590
and childrenType (vis : cilVisitor) (t : typ) : typ =
 
7591
  (* look for types referred to inside t's definition *)
 
7592
  let fTyp t  = visitCilType vis t in
 
7593
  let fAttr a = visitCilAttributes vis a in
 
7594
  match t with
 
7595
    TPtr(t1, a) ->
 
7596
      let t1' = fTyp t1 in
 
7597
      let a' = fAttr a in
 
7598
      if t1' != t || a' != a then TPtr(t1', a') else t
 
7599
  | TArray(t1, None, a) ->
 
7600
      let t1' = fTyp t1 in
 
7601
      let a' = fAttr a in
 
7602
      if t1' != t || a' != a  then TArray(t1', None, a') else t
 
7603
  | TArray(t1, Some e, a) ->
 
7604
      let t1' = fTyp t1 in
 
7605
      let e' = visitCilExpr vis e in
 
7606
      let a' = fAttr a in
 
7607
      if t1' != t || e' != e  || a' != a then TArray(t1', Some e', a') else t
 
7608
 
 
7609
      (* DON'T recurse into the compinfo, this is done in visitCilGlobal.
 
7610
         User can iterate over cinfo.cfields manually, if desired.*)
 
7611
  | TComp(cinfo, a) ->
 
7612
      let cinfo' = vis#behavior.get_compinfo cinfo in
 
7613
      let a' = fAttr a in
 
7614
      if a != a' || cinfo' != cinfo then TComp(cinfo', a') else t
 
7615
 
 
7616
  | TFun(rettype, args, isva, a) ->
 
7617
      let rettype' = fTyp rettype in
 
7618
      (* iterate over formals, as variable declarations *)
 
7619
      let argslist = argsToList args in
 
7620
      let visitArg ((an,at,aa) as arg) =
 
7621
        let at' = fTyp at in
 
7622
        let aa' = fAttr aa in
 
7623
        if at' != at || aa' != aa then (an,at',aa') else arg
 
7624
      in
 
7625
      let argslist' = mapNoCopy visitArg argslist in
 
7626
      let a' = fAttr a in
 
7627
      if rettype' != rettype || argslist' != argslist || a' != a  then
 
7628
        let args' = if argslist' == argslist then args else Some argslist' in
 
7629
        TFun(rettype', args', isva, a') else t
 
7630
 
 
7631
  | TNamed(t1, a) ->
 
7632
      let a' = fAttr a in
 
7633
      let t1' = vis#behavior.get_typeinfo t1 in
 
7634
      if a' != a  || t1' != t1 then TNamed (t1', a') else t
 
7635
  | TEnum(enum,a) ->
 
7636
      let a' = fAttr a in
 
7637
      let enum' = vis#behavior.get_enuminfo enum in
 
7638
      if a' != a || enum' != enum then TEnum(enum',a') else t
 
7639
  | _ ->  (* other types (TVoid, TInt, TFloat, TEnum, and TBuiltin_va_list)
 
7640
             don't contain nested types, but they do have attributes. *)
 
7641
      let a = typeAttrs t in
 
7642
      let a' = fAttr a in
 
7643
      if a' != a  then setTypeAttrs t a' else t
 
7644
 
 
7645
(* for declarations, we visit the types inside; but for uses, *)
 
7646
(* we just visit the varinfo node *)
 
7647
and visitCilVarDecl (vis : cilVisitor) (v : varinfo) : varinfo =
 
7648
  doVisit vis vis#behavior.memo_varinfo
 
7649
    vis#vvdec childrenVarDecl v
 
7650
and childrenVarDecl (vis : cilVisitor) (v : varinfo) : varinfo =
 
7651
  v.vtype <- visitCilType vis v.vtype;
 
7652
  v.vattr <- visitCilAttributes vis v.vattr;
 
7653
  v.vlogic_var_assoc <-
 
7654
    opt_map (visitCilLogicVarDecl vis) v.vlogic_var_assoc;
 
7655
  v
 
7656
 
 
7657
and visitCilVarUse vis v =
 
7658
  doVisit vis vis#behavior.get_varinfo vis#vvrbl (fun _ x -> x) v
 
7659
 
 
7660
and visitCilAttributes (vis: cilVisitor) (al: attribute list) : attribute list=
 
7661
   let al' =
 
7662
     mapNoCopyList
 
7663
       (doVisitList vis
 
7664
          (fun x -> x) vis#vattr childrenAttribute) al in
 
7665
   if al' != al then
 
7666
     (* Must re-sort *)
 
7667
     addAttributes al' []
 
7668
   else
 
7669
     al
 
7670
and childrenAttribute (vis: cilVisitor) (a: attribute) : attribute =
 
7671
  let fAttrP a = visitCilAttrParams vis a in
 
7672
  match a with
 
7673
  | Attr (n, args) ->
 
7674
      let args' = mapNoCopy fAttrP args in
 
7675
      if args' != args then Attr(n, args') else a
 
7676
  | AttrAnnot _ ->
 
7677
      a
 
7678
 
 
7679
and visitCilAttrParams (vis: cilVisitor) (a: attrparam) : attrparam =
 
7680
   doVisit vis (fun x -> x) vis#vattrparam childrenAttrparam a
 
7681
and childrenAttrparam (vis: cilVisitor) (aa: attrparam) : attrparam =
 
7682
  let fTyp t  = visitCilType vis t in
 
7683
  let fAttrP a = visitCilAttrParams vis a in
 
7684
  match aa with
 
7685
      AInt _ | AStr _ -> aa
 
7686
    | ACons(n, args) ->
 
7687
        let args' = mapNoCopy fAttrP args in
 
7688
        if args' != args then ACons(n, args') else aa
 
7689
    | ASizeOf t ->
 
7690
        let t' = fTyp t in
 
7691
        if t' != t then ASizeOf t' else aa
 
7692
    | ASizeOfE e ->
 
7693
        let e' = fAttrP e in
 
7694
        if e' != e then ASizeOfE e' else aa
 
7695
    | AAlignOf t ->
 
7696
        let t' = fTyp t in
 
7697
        if t' != t then AAlignOf t' else aa
 
7698
    | AAlignOfE e ->
 
7699
        let e' = fAttrP e in
 
7700
        if e' != e then AAlignOfE e' else aa
 
7701
    | ASizeOfS _ | AAlignOfS _ ->
 
7702
        ignore (warn "Visitor inside of a type signature.");
 
7703
        aa
 
7704
    | AUnOp (uo, e1) ->
 
7705
        let e1' = fAttrP e1 in
 
7706
        if e1' != e1 then AUnOp (uo, e1') else aa
 
7707
    | ABinOp (bo, e1, e2) ->
 
7708
        let e1' = fAttrP e1 in
 
7709
        let e2' = fAttrP e2 in
 
7710
        if e1' != e1 || e2' != e2 then ABinOp (bo, e1', e2') else aa
 
7711
    | ADot (ap, s) ->
 
7712
        let ap' = fAttrP ap in
 
7713
        if ap' != ap then ADot (ap', s) else aa
 
7714
    | AStar ap ->
 
7715
        let ap' = fAttrP ap in
 
7716
        if ap' != ap then AStar ap' else aa
 
7717
    | AAddrOf ap ->
 
7718
        let ap' = fAttrP ap in
 
7719
        if ap' != ap then AAddrOf ap' else aa
 
7720
    | AIndex (e1, e2) ->
 
7721
        let e1' = fAttrP e1 in
 
7722
        let e2' = fAttrP e2 in
 
7723
        if e1' != e1 || e2' != e2 then AIndex (e1', e2') else aa
 
7724
    | AQuestion (e1, e2, e3) ->
 
7725
        let e1' = fAttrP e1 in
 
7726
        let e2' = fAttrP e2 in
 
7727
        let e3' = fAttrP e3 in
 
7728
        if e1' != e1 || e2' != e2 || e3' != e3
 
7729
        then AQuestion (e1', e2', e3') else aa
 
7730
 
 
7731
 
 
7732
let rec fix_succs_preds_block b block =
 
7733
  List.iter (fix_succs_preds b) block.bstmts
 
7734
and fix_succs_preds b stmt =
 
7735
  stmt.succs <- mapNoCopy b.get_stmt stmt.succs;
 
7736
  stmt.preds <- mapNoCopy b.get_stmt stmt.preds;
 
7737
  match stmt.skind with
 
7738
      If(_,bthen,belse,_) ->
 
7739
        fix_succs_preds_block b bthen;
 
7740
        fix_succs_preds_block b belse
 
7741
    | Switch(e,cases,stmts,l) ->
 
7742
        fix_succs_preds_block b cases;
 
7743
        stmt.skind <- Switch(e,cases,List.map b.get_stmt stmts,l)
 
7744
    | Loop(annot,block,loc,stmt1,stmt2) ->
 
7745
        fix_succs_preds_block b block;
 
7746
        let stmt1' = opt_map b.get_stmt stmt1 in
 
7747
        let stmt2' = opt_map b.get_stmt stmt2 in
 
7748
        stmt.skind <- Loop(annot,block,loc,stmt1',stmt2')
 
7749
    | Block block -> fix_succs_preds_block b block
 
7750
    | TryFinally(block1,block2,_) ->
 
7751
        fix_succs_preds_block b block1;
 
7752
        fix_succs_preds_block b block2
 
7753
    | TryExcept(block1,_,block2,_) ->
 
7754
        fix_succs_preds_block b block1;
 
7755
        fix_succs_preds_block b block2
 
7756
    | _ -> ()
 
7757
 
 
7758
let rec visitCilFunction (vis : cilVisitor) (f : fundec) : fundec =
 
7759
  if debugVisit then ignore
 
7760
    (E.log "Visiting function %s\n" f.svar.vname);
 
7761
  assertEmptyQueue vis;
 
7762
  vis#set_current_func f;
 
7763
  let f = vis#behavior.cfundec f in
 
7764
  f.svar <- vis#behavior.memo_varinfo f.svar; (* hit the function name *)
 
7765
  let f =
 
7766
    doVisit vis (fun x -> x) (* copy has already been done *)
 
7767
      vis#vfunc childrenFunction f
 
7768
  in
 
7769
  let toPrepend = vis#unqueueInstr () in
 
7770
  if toPrepend <> [] then
 
7771
    f.sbody.bstmts <-
 
7772
      (List.map (fun i -> mkStmt (Instr i)) toPrepend) @ f.sbody.bstmts;
 
7773
  if vis#behavior.is_copy_behavior then begin
 
7774
    fix_succs_preds_block vis#behavior f.sbody;
 
7775
    f.sallstmts <- List.map vis#behavior.get_stmt f.sallstmts
 
7776
  end;
 
7777
  vis#reset_current_func ();
 
7778
  f
 
7779
 
 
7780
and childrenFunction (vis : cilVisitor) (f : fundec) : fundec =
 
7781
  f.svar <- visitCilVarDecl vis f.svar; (* hit the function name *)
 
7782
  (* visit local declarations *)
 
7783
  f.slocals <- mapNoCopy (visitCilVarDecl vis) f.slocals;
 
7784
  (* visit the formals *)
 
7785
  let newformals = mapNoCopy (visitCilVarDecl vis) f.sformals in
 
7786
  (* Make sure the type reflects the formals *)
 
7787
  setFormals f newformals;
 
7788
  (* Remember any new instructions that were generated while visiting
 
7789
     variable declarations. *)
 
7790
  let toPrepend = vis#unqueueInstr () in
 
7791
  f.sbody <- visitCilBlock vis f.sbody;        (* visit the body *)
 
7792
  if toPrepend <> [] then
 
7793
    f.sbody.bstmts <- (List.map (fun i -> mkStmt (Instr i)) toPrepend) @ f.sbody.bstmts;
 
7794
  f.sspec <- visitCilFunspec vis f.sspec;
 
7795
  f
 
7796
 
 
7797
let childrenFieldInfo vis fi =
 
7798
  fi.fcomp <- vis#behavior.get_compinfo fi.fcomp;
 
7799
  fi.ftype <- visitCilType vis fi.ftype;
 
7800
  fi.fattr <- visitCilAttributes vis fi.fattr;
 
7801
  fi
 
7802
 
 
7803
let visitCilFieldInfo vis f =
 
7804
  doVisit vis vis#behavior.memo_fieldinfo vis#vfieldinfo childrenFieldInfo f
 
7805
 
 
7806
let childrenCompInfo vis comp =
 
7807
  comp.cfields <- mapNoCopy (visitCilFieldInfo vis) comp.cfields;
 
7808
  comp.cattr <- visitCilAttributes vis comp.cattr;
 
7809
  comp
 
7810
 
 
7811
let visitCilCompInfo vis c =
 
7812
  doVisit vis vis#behavior.memo_compinfo vis#vcompinfo childrenCompInfo c
 
7813
 
 
7814
let childrenEnumItem vis e =
 
7815
  e.eival <- visitCilExpr vis e.eival;
 
7816
  e.eihost <- vis#behavior.get_enuminfo e.eihost;
 
7817
  e
 
7818
 
 
7819
let visitCilEnumItem vis e =
 
7820
  doVisit vis vis#behavior.memo_enumitem vis#venumitem childrenEnumItem e
 
7821
 
 
7822
let childrenEnumInfo vis e =
 
7823
  e.eitems <- mapNoCopy (visitCilEnumItem vis) e.eitems;
 
7824
  e.eattr <- visitCilAttributes vis e.eattr;
 
7825
  e
 
7826
 
 
7827
let visitCilEnumInfo vis e =
 
7828
  doVisit vis vis#behavior.memo_enuminfo vis#venuminfo childrenEnumInfo e
 
7829
 
 
7830
let rec visitCilGlobal (vis: cilVisitor) (g: global) : global list =
 
7831
  (*(trace "visit" (dprintf "visitCilGlobal\n"));*)
 
7832
  let oldloc = CurrentLoc.get () in
 
7833
  CurrentLoc.set (get_globalLoc g) ;
 
7834
  currentGlobal := g;
 
7835
  let res =
 
7836
    doVisitList vis (fun x -> x) vis#vglob childrenGlobal g in
 
7837
  CurrentLoc.set oldloc;
 
7838
  res
 
7839
and childrenGlobal (vis: cilVisitor) (g: global) : global =
 
7840
  match g with
 
7841
  | GFun (f, l) ->
 
7842
      let f' = visitCilFunction vis f in
 
7843
      if f' != f then GFun (f', l) else g
 
7844
  | GType(t, l) ->
 
7845
      let t' = vis#behavior.memo_typeinfo t in
 
7846
      t'.ttype <- visitCilType vis t'.ttype;
 
7847
      if t' != t then GType(t,l) else g
 
7848
  | GEnumTagDecl (enum,l) ->
 
7849
      let enum' = vis#behavior.memo_enuminfo enum in
 
7850
      if enum != enum' then GEnumTagDecl(enum',l) else g
 
7851
        (* real visit'll be done in the definition *)
 
7852
  | GCompTagDecl (comp,l) ->
 
7853
      let comp' = vis#behavior.memo_compinfo comp in
 
7854
      if comp != comp' then GCompTagDecl(comp',l) else g
 
7855
  | GEnumTag (enum, l) ->
 
7856
      let enum' = visitCilEnumInfo vis enum in
 
7857
      if enum != enum' then GEnumTag(enum',l) else g
 
7858
  | GCompTag (comp, l) ->
 
7859
      let comp' = visitCilCompInfo vis comp in
 
7860
      if comp != comp' then GCompTag(comp',l) else g
 
7861
  | GVarDecl(spec, v, l) ->
 
7862
      let form =
 
7863
        try Some (getFormalsDecl v) with Not_found -> None
 
7864
      in
 
7865
      let v' = visitCilVarDecl vis v in
 
7866
      let form' = opt_map (mapNoCopy (visitCilVarDecl vis)) form in
 
7867
      let spec' =
 
7868
        if isFunctionType v.vtype then
 
7869
          visitCilFunspec vis spec
 
7870
        else begin
 
7871
          assert (is_empty_funspec spec);
 
7872
          spec
 
7873
        end
 
7874
      in
 
7875
      if v' != v || spec' != spec || form != form' then
 
7876
        begin
 
7877
          (match form' with None -> ()
 
7878
             | Some form' ->
 
7879
                 Queue.add (fun () -> unsafeSetFormalsDecl v' form')
 
7880
                   vis#get_filling_actions);
 
7881
          GVarDecl (spec', v', l)
 
7882
        end
 
7883
      else g
 
7884
  | GVar (v, inito, l) ->
 
7885
      let v' = visitCilVarDecl vis v in
 
7886
      let inito' = vis#behavior.cinitinfo inito in
 
7887
      (match inito'.init with
 
7888
        None -> ()
 
7889
      | Some i -> let i' = visitCilInit vis v NoOffset i in
 
7890
        if i' != i then inito'.init <- Some i');
 
7891
      if v' != v || inito' != inito then GVar (v', inito', l) else g
 
7892
  | GPragma (a, l) -> begin
 
7893
      match visitCilAttributes vis [a] with
 
7894
        [a'] -> if a' != a then GPragma (a', l) else g
 
7895
      | _ -> E.s (E.unimp "visitCilAttributes returns more than one attribute")
 
7896
  end
 
7897
  | GAnnot (a,l) ->
 
7898
      let a' = visitCilAnnotation vis a in
 
7899
        if a' != a then GAnnot(a',l) else g
 
7900
  | GText _ | GAsm _ -> g
 
7901
 
 
7902
 
 
7903
(** A visitor that does constant folding. If "machdep" is true then we do
 
7904
 * machine dependent simplification (e.g., sizeof) *)
 
7905
class constFoldVisitorClass (machdep: bool) : cilVisitor = object
 
7906
  inherit nopCilVisitor
 
7907
 
 
7908
  method vinst i =
 
7909
    match i with
 
7910
      (* Skip two functions to which we add Sizeof to the type arguments.
 
7911
         See the comments for these above. *)
 
7912
      Call(_,(Lval (Var vi,NoOffset)),_,_)
 
7913
        when ((vi.vname = "__builtin_va_arg")
 
7914
              || (vi.vname = "__builtin_types_compatible_p")) ->
 
7915
          SkipChildren
 
7916
    | _ -> DoChildren
 
7917
  method vexpr (e: exp) =
 
7918
    (* Do it bottom up *)
 
7919
    ChangeDoChildrenPost (e, constFold machdep)
 
7920
 
 
7921
end
 
7922
let constFoldVisitor (machdep: bool) = new constFoldVisitorClass machdep
 
7923
 
 
7924
(* Iterate over all globals, including the global initializer *)
 
7925
let iterGlobals (fl: file)
 
7926
                (doone: global -> unit) : unit =
 
7927
  let doone' g =
 
7928
      CurrentLoc.set (get_globalLoc g);
 
7929
      doone g
 
7930
  in
 
7931
  List.iter doone' fl.globals;
 
7932
  (match fl.globinit with
 
7933
    None -> ()
 
7934
  | Some g -> doone' (GFun(g, locUnknown)))
 
7935
 
 
7936
(* Fold over all globals, including the global initializer *)
 
7937
let foldGlobals (fl: file)
 
7938
                (doone: 'a -> global -> 'a)
 
7939
                (acc: 'a) : 'a =
 
7940
  let doone' acc g =
 
7941
      CurrentLoc.set (get_globalLoc g);
 
7942
      doone acc g
 
7943
  in
 
7944
  let acc' = List.fold_left doone' acc fl.globals in
 
7945
  (match fl.globinit with
 
7946
    None -> acc'
 
7947
  | Some g -> doone' acc' (GFun(g, locUnknown)))
 
7948
 
 
7949
(** Find a function or function prototype with the given name in the file.
 
7950
  * If it does not exist, create a prototype with the given type, and return
 
7951
  * the new varinfo.  This is useful when you need to call a libc function
 
7952
  * whose prototype may or may not already exist in the file.
 
7953
  *
 
7954
  * Because the new prototype is added to the start of the file, you shouldn't
 
7955
  * refer to any struct or union types in the function type.*)
 
7956
let findOrCreateFunc (f:file) (name:string) (t:typ) : varinfo =
 
7957
  let rec search glist =
 
7958
    match glist with
 
7959
        GVarDecl(_,vi,_) :: _rest when vi.vname = name ->
 
7960
          if not (isFunctionType vi.vtype) then
 
7961
            E.s (error ("findOrCreateFunc: can't create %s because another "
 
7962
                        ^^"global exists with that name.") name);
 
7963
          vi
 
7964
      | _ :: rest -> search rest (* tail recursive *)
 
7965
      | [] -> (*not found, so create one *)
 
7966
          let t' = unrollTypeDeep t in
 
7967
          let new_decl = makeGlobalVar name t' in
 
7968
          setFormalsDecl new_decl t';
 
7969
          f.globals <- GVarDecl(empty_funspec (), new_decl, locUnknown) :: f.globals;
 
7970
          new_decl
 
7971
  in
 
7972
  search f.globals
 
7973
 
 
7974
 
 
7975
let childrenFileSameGlobals vis f =
 
7976
  let fGlob g = visitCilGlobal vis g in
 
7977
  iterGlobals f
 
7978
    (fun g ->
 
7979
       match fGlob g with
 
7980
           [g'] when g' == g || equals g' g -> () (* Try to do the pointer check first *)
 
7981
         | gl ->
 
7982
             ignore (log "You used visitCilFileSameGlobals but the global got changed:\n %a\nchanged to %a\n" d_global g (fprintfList ~sep:"@\n" d_global) gl);
 
7983
             ());
 
7984
  f
 
7985
 
 
7986
let post_file vis f =
 
7987
  let res = vis#vfile f in
 
7988
  match res with
 
7989
      SkipChildren -> ChangeToPost(f, fun res -> vis#fill_global_tables; res)
 
7990
    | ChangeTo res -> ChangeToPost(res, fun res -> vis#fill_global_tables; res)
 
7991
    | ChangeToPost (res, f) ->
 
7992
        ChangeToPost(res, fun res -> vis#fill_global_tables; f res)
 
7993
    | DoChildren ->
 
7994
        ChangeDoChildrenPost(f, fun f -> vis#fill_global_tables; f)
 
7995
    | ChangeDoChildrenPost(f,post) ->
 
7996
        ChangeDoChildrenPost
 
7997
          (f,fun f -> let f = post f in vis#fill_global_tables; f)
 
7998
 
 
7999
(* A visitor for the whole file that does not change the globals *)
 
8000
let visitCilFileSameGlobals (vis : cilVisitor) (f : file) : unit =
 
8001
  if vis#behavior.is_copy_behavior then
 
8002
    ignore (log "You used visitCilFileSameGlobals with a copy visitor. \
 
8003
                 This is an error. Nothing is done")
 
8004
  else
 
8005
    ignore
 
8006
      (doVisit vis vis#behavior.cfile (post_file vis) childrenFileSameGlobals f)
 
8007
 
 
8008
let childrenFileCopy vis f =
 
8009
  let fGlob g = visitCilGlobal vis g in
 
8010
  (* Scan the globals. Make sure this is tail recursive. *)
 
8011
  let rec loop (acc: global list) = function
 
8012
      [] -> f.globals <- List.rev acc
 
8013
    | g :: restg ->
 
8014
        loop ((List.rev (fGlob g)) @ acc) restg
 
8015
  in
 
8016
  loop [] f.globals;
 
8017
  (* the global initializer *)
 
8018
  (match f.globinit with
 
8019
    None -> ()
 
8020
  | Some g -> f.globinit <- Some (visitCilFunction vis g));
 
8021
  f
 
8022
 
 
8023
(* Be careful with visiting the whole file because it might be huge. *)
 
8024
let visitCilFileCopy (vis : cilVisitor) (f : file) : file =
 
8025
  vis#set_logic_tables ();
 
8026
  doVisit vis vis#behavior.cfile (post_file vis) childrenFileCopy f
 
8027
 
 
8028
let visitCilFile vis f =
 
8029
  if vis#behavior.is_copy_behavior then
 
8030
    ignore (log "You used visitCilFile with a copy visitor. \
 
8031
                 This is an error. Nothing is done")
 
8032
  else ignore (visitCilFileCopy vis f)
 
8033
 
 
8034
 
 
8035
(** Create or fetch the global initializer. Tries to put a call to the
 
8036
 * function with the main_name into it *)
 
8037
let getGlobInit ?(main_name="main") (fl: file) =
 
8038
  match fl.globinit with
 
8039
    Some f -> f
 
8040
  | None -> begin
 
8041
      (* Sadly, we cannot use the Filename library because it does not like
 
8042
       * function names with multiple . in them *)
 
8043
      let f =
 
8044
        let len = String.length fl.fileName in
 
8045
        (* Find the last path separator and record the first . that we see,
 
8046
        * going backwards *)
 
8047
        let lastDot = ref len in
 
8048
        let rec findLastPathSep i =
 
8049
          if i < 0 then -1 else
 
8050
          let c = String.get fl.fileName i in
 
8051
          if c = '/' || c = '\\' then i
 
8052
          else begin
 
8053
            if c = '.' && !lastDot = len then
 
8054
              lastDot := i;
 
8055
            findLastPathSep (i - 1)
 
8056
          end
 
8057
        in
 
8058
        let lastPathSep = findLastPathSep (len - 1) in
 
8059
        let basenoext =
 
8060
          String.sub fl.fileName (lastPathSep + 1) (!lastDot - lastPathSep - 1)
 
8061
        in
 
8062
        emptyFunction
 
8063
          (makeValidVarinfoName ("__globinit_" ^ basenoext))
 
8064
      in
 
8065
      fl.globinit <- Some f;
 
8066
      (* Now try to add a call to the global initialized at the beginning of
 
8067
       * main *)
 
8068
      let inserted = ref false in
 
8069
      List.iter
 
8070
        (function
 
8071
            GFun(m, lm) when m.svar.vname = main_name ->
 
8072
              (* Prepend a prototype to the global initializer *)
 
8073
              fl.globals <- GVarDecl (empty_funspec (),f.svar, lm) :: fl.globals;
 
8074
              m.sbody.bstmts <-
 
8075
                 mkStmt (Instr (Call(None,
 
8076
                                     Lval(var f.svar),
 
8077
                                     [], locUnknown)))
 
8078
                :: m.sbody.bstmts;
 
8079
              inserted := true;
 
8080
              if !E.verboseFlag then
 
8081
                ignore (E.log "Inserted the globinit\n");
 
8082
              fl.globinitcalled <- true;
 
8083
          | _ -> ())
 
8084
        fl.globals;
 
8085
 
 
8086
(* YMo: remove useless warning that worries users *)
 
8087
(*       if not !inserted then *)
 
8088
(*         ignore (E.warn "Cannot find %s to add global initializer %s" *)
 
8089
(*                   main_name f.svar.vname); *)
 
8090
 
 
8091
      f
 
8092
  end
 
8093
 
 
8094
 
 
8095
 
 
8096
(* Fold over all globals, including the global initializer *)
 
8097
let mapGlobals (fl: file)
 
8098
               (doone: global -> global) : unit =
 
8099
  fl.globals <- List.map doone fl.globals;
 
8100
  (match fl.globinit with
 
8101
    None -> ()
 
8102
  | Some g -> begin
 
8103
      match doone (GFun(g, locUnknown)) with
 
8104
        GFun(g', _) -> fl.globinit <- Some g'
 
8105
      | _ -> E.s (E.bug "mapGlobals: globinit is not a function")
 
8106
  end)
 
8107
 
 
8108
 
 
8109
 
 
8110
let dumpFile (pp: cilPrinter) (out : out_channel) (outfile: string) file =
 
8111
 
 
8112
  let fmt = formatter_of_out_channel out in
 
8113
  pp_set_max_boxes fmt max_int;  (* We don't want ... in the output *)
 
8114
  pp_set_margin fmt 79;
 
8115
 
 
8116
  if !E.verboseFlag then
 
8117
    ignore (log "printing file %s\n" outfile);
 
8118
 
 
8119
  fprintf fmt
 
8120
    "/* Generated by CIL v. %s */@\n/* print_CIL_Input is %b */@\n@\n"
 
8121
    cilVersion
 
8122
    miscState.print_CIL_Input;
 
8123
  iterGlobals file (fun g -> printGlobal pp fmt g);
 
8124
 
 
8125
  (* sm: we have to flush the output channel; if we don't then under *)
 
8126
  (* some circumstances (I haven't figure out exactly when, but it happens *)
 
8127
  (* more often with big inputs), we get a truncated output file *)
 
8128
  pp_print_flush fmt ();
 
8129
  flush out
 
8130
 
 
8131
let d_file (pp: cilPrinter) fmt file =
 
8132
  fprintf fmt
 
8133
    "@[/* Generated by CIL v. %s */@\n/* print_CIL_Input is %b */@\n@\n"
 
8134
    cilVersion
 
8135
    miscState.print_CIL_Input;
 
8136
  iterGlobals file (fun g -> printGlobal pp fmt g);
 
8137
  fprintf fmt "@]@."
 
8138
 
 
8139
 
 
8140
(******************
 
8141
 ******************
 
8142
 ******************)
 
8143
 
 
8144
 
 
8145
(* Convert an expression into an attribute, if possible. Otherwise raise
 
8146
 * NotAnAttrParam *)
 
8147
exception NotAnAttrParam of exp
 
8148
let rec expToAttrParam (e: exp) : attrparam =
 
8149
  match e with
 
8150
    Const(CInt64(i,k,_)) ->
 
8151
      let i', trunc = truncateInteger64 k i in
 
8152
      if trunc then
 
8153
        raise (NotAnAttrParam e);
 
8154
      let i2 = Int64.to_int i' in
 
8155
      if i' <> Int64.of_int i2 then
 
8156
        raise (NotAnAttrParam e);
 
8157
      AInt i2
 
8158
  | Lval (Var v, NoOffset) -> ACons(v.vname, [])
 
8159
  | SizeOf t -> ASizeOf t
 
8160
  | SizeOfE e' -> ASizeOfE (expToAttrParam e')
 
8161
 
 
8162
  | UnOp(uo, e', _)  -> AUnOp (uo, expToAttrParam e')
 
8163
  | BinOp(bo, e1',e2', _)  -> ABinOp (bo, expToAttrParam e1',
 
8164
                                      expToAttrParam e2')
 
8165
  | _ -> raise (NotAnAttrParam e)
 
8166
 
 
8167
 
 
8168
(******************** OPTIMIZATIONS *****)
 
8169
let rec peepHole1 (* Process one statement and possibly replace it *)
 
8170
                  (doone: instr -> instr list option)
 
8171
                  (* Scan a block and recurse inside nested blocks *)
 
8172
                  (ss: stmt list) : unit =
 
8173
  let rec doInstrList (il: instr list) : instr list =
 
8174
    match il with
 
8175
      [] -> []
 
8176
    | i :: rest -> begin
 
8177
        match doone i with
 
8178
          None -> i :: doInstrList rest
 
8179
        | Some sl -> doInstrList (sl @ rest)
 
8180
    end
 
8181
  in
 
8182
 
 
8183
  List.iter
 
8184
    (fun s ->
 
8185
      match s.skind with
 
8186
      | Instr i -> s.skind <- stmt_of_instr_list (doInstrList [i])
 
8187
      | If (_e, tb, eb, _) ->
 
8188
          peepHole1 doone tb.bstmts;
 
8189
          peepHole1 doone eb.bstmts
 
8190
      | Switch (_e, b, _, _) -> peepHole1 doone b.bstmts
 
8191
      | Loop (_, b, _l, _, _) -> peepHole1 doone b.bstmts
 
8192
      | Block b -> peepHole1 doone b.bstmts
 
8193
      | UnspecifiedSequence seq ->
 
8194
          peepHole1 doone (List.map (fun (x,_,_) -> x) seq)
 
8195
      | TryFinally (b, h, _l) ->
 
8196
          peepHole1 doone b.bstmts;
 
8197
          peepHole1 doone h.bstmts
 
8198
      | TryExcept (b, (il, e), h, l) ->
 
8199
          peepHole1 doone b.bstmts;
 
8200
          peepHole1 doone h.bstmts;
 
8201
          s.skind <- TryExcept(b, (doInstrList il, e), h, l);
 
8202
      | Return _ | Goto _ | Break _ | Continue _ -> ())
 
8203
    ss
 
8204
 
 
8205
let rec peepHole2  (* Process two statements and possibly replace them both *)
 
8206
                   (dotwo: stmt * stmt -> stmt list option)
 
8207
                   (ss: stmt list) =
 
8208
  let rec doStmtList (il: stmt list) : stmt list =
 
8209
    match il with
 
8210
      [] -> []
 
8211
    | [i] -> process i; il
 
8212
    | (i1 :: ((i2 :: rest) as rest2)) ->
 
8213
        begin
 
8214
          match dotwo (i1,i2) with
 
8215
            None -> process i1; i1 :: doStmtList rest2
 
8216
          | Some sl -> doStmtList (sl @ rest)
 
8217
        end
 
8218
  and doUnspecifiedStmtList il =
 
8219
    match il with
 
8220
        [] -> []
 
8221
      | [ (s,_,_) ] -> process s; il
 
8222
      | ((i1,w1,r1) as hd)::(((i2,w2,r2)::rest) as rest2) ->
 
8223
          begin
 
8224
            match dotwo (i1,i2) with
 
8225
                None -> process i1; hd :: doUnspecifiedStmtList rest2
 
8226
              | Some [] -> doUnspecifiedStmtList rest
 
8227
              | Some (hd::tl) ->
 
8228
                  let res =
 
8229
                    (hd, w1 @ w2, r1 @ r2) :: (List.map (fun x -> x,[],[]) tl)
 
8230
                  in doUnspecifiedStmtList (res @ rest)
 
8231
          end
 
8232
  and process s =
 
8233
    match s.skind with
 
8234
        Instr _i -> ()
 
8235
      | If (_e, tb, eb, _) ->
 
8236
          tb.bstmts <- peepHole2 dotwo tb.bstmts;
 
8237
          eb.bstmts <- peepHole2 dotwo eb.bstmts
 
8238
      | Switch (_e, b, _, _) -> b.bstmts <- peepHole2 dotwo b.bstmts
 
8239
      | Loop (_, b, _l, _, _) -> b.bstmts <- peepHole2 dotwo b.bstmts
 
8240
      | Block b -> b.bstmts <- doStmtList b.bstmts
 
8241
      | TryFinally (b, h, _l) -> b.bstmts <- peepHole2 dotwo b.bstmts;
 
8242
          b.bstmts <- peepHole2 dotwo h.bstmts
 
8243
      | TryExcept (b, (_il, _e), h, _l) ->
 
8244
          b.bstmts <- peepHole2 dotwo b.bstmts;
 
8245
          h.bstmts <- peepHole2 dotwo h.bstmts;
 
8246
          () (*s.skind <- TryExcept (b, (doInstrList il, e), h, l)*)
 
8247
 
 
8248
      | UnspecifiedSequence seq ->
 
8249
          s.skind <- UnspecifiedSequence (doUnspecifiedStmtList seq)
 
8250
      | Return _ | Goto _ | Break _ | Continue _ -> ()
 
8251
  in List.iter process ss;
 
8252
  doStmtList ss
 
8253
 
 
8254
(*** Type signatures ***)
 
8255
 
 
8256
(* Helper class for typeSig: replace any types in attributes with typsigs *)
 
8257
class typeSigVisitor(typeSigConverter: typ->typsig) = object
 
8258
  inherit nopCilVisitor
 
8259
  method vattrparam ap =
 
8260
    match ap with
 
8261
      | ASizeOf t -> ChangeTo (ASizeOfS (typeSigConverter t))
 
8262
      | AAlignOf t -> ChangeTo (AAlignOfS (typeSigConverter t))
 
8263
      | _ -> DoChildren
 
8264
end
 
8265
 
 
8266
let typeSigAddAttrs a0 t =
 
8267
  if a0 == [] then t else
 
8268
  match t with
 
8269
    TSBase t -> TSBase (typeAddAttributes a0 t)
 
8270
  | TSPtr (ts, a) -> TSPtr (ts, addAttributes a0 a)
 
8271
  | TSArray (ts, l, a) -> TSArray(ts, l, addAttributes a0 a)
 
8272
  | TSComp (iss, n, a) -> TSComp (iss, n, addAttributes a0 a)
 
8273
  | TSEnum (n, a) -> TSEnum (n, addAttributes a0 a)
 
8274
  | TSFun(ts, tsargs, isva, a) -> TSFun(ts, tsargs, isva, addAttributes a0 a)
 
8275
 
 
8276
(* Compute a type signature.
 
8277
    Use ~ignoreSign:true to convert all signed integer types to unsigned,
 
8278
    so that signed and unsigned will compare the same. *)
 
8279
let rec typeSigWithAttrs ?(ignoreSign=false) doattr t =
 
8280
  let typeSig = typeSigWithAttrs ~ignoreSign doattr in
 
8281
  let attrVisitor = new typeSigVisitor typeSig in
 
8282
  let doattr al = visitCilAttributes attrVisitor (doattr al) in
 
8283
  match t with
 
8284
  | TInt (ik, al) ->
 
8285
      let ik' =
 
8286
        if ignoreSign then unsignedVersionOf ik  else ik
 
8287
      in
 
8288
      TSBase (TInt (ik', doattr al))
 
8289
  | TFloat (fk, al) -> TSBase (TFloat (fk, doattr al))
 
8290
  | TVoid al -> TSBase (TVoid (doattr al))
 
8291
  | TEnum (enum, a) -> TSEnum (enum.ename, doattr a)
 
8292
  | TPtr (t, a) -> TSPtr (typeSig t, doattr a)
 
8293
  | TArray (t,l,a) -> (* We do not want fancy expressions in array lengths.
 
8294
                       * So constant fold the lengths *)
 
8295
      let l' =
 
8296
        match l with
 
8297
          Some l -> begin
 
8298
            match constFold true l with
 
8299
              Const(CInt64(i, _, _)) -> Some i
 
8300
            | e -> E.s (bug "Invalid length in array type: %a\n"
 
8301
                          (!pd_exp) e)
 
8302
          end
 
8303
        | None -> None
 
8304
      in
 
8305
      TSArray(typeSig t, l', doattr a)
 
8306
 
 
8307
  | TComp (comp, a) ->
 
8308
      TSComp (comp.cstruct, comp.cname, doattr (addAttributes comp.cattr a))
 
8309
  | TFun(rt,args,isva,a) ->
 
8310
      TSFun(typeSig rt,
 
8311
            List.map (fun (_, atype, _) -> (typeSig atype)) (argsToList args),
 
8312
            isva, doattr a)
 
8313
  | TNamed(t, a) -> typeSigAddAttrs (doattr a) (typeSig t.ttype)
 
8314
  | TBuiltin_va_list al -> TSBase (TBuiltin_va_list (doattr al))
 
8315
 
 
8316
let typeSig t =
 
8317
  typeSigWithAttrs (fun al -> al) t
 
8318
 
 
8319
let _ = pTypeSig := typeSig
 
8320
 
 
8321
(* Remove the attribute from the top-level of the type signature *)
 
8322
let setTypeSigAttrs (a: attribute list) = function
 
8323
    TSBase t -> TSBase (setTypeAttrs t a)
 
8324
  | TSPtr (ts, _) -> TSPtr (ts, a)
 
8325
  | TSArray (ts, l, _) -> TSArray(ts, l, a)
 
8326
  | TSComp (iss, n, _) -> TSComp (iss, n, a)
 
8327
  | TSEnum (n, _) -> TSEnum (n, a)
 
8328
  | TSFun (ts, tsargs, isva, _) -> TSFun (ts, tsargs, isva, a)
 
8329
 
 
8330
 
 
8331
let typeSigAttrs = function
 
8332
    TSBase t -> typeAttrs t
 
8333
  | TSPtr (_ts, a) -> a
 
8334
  | TSArray (_ts, _l, a) -> a
 
8335
  | TSComp (_iss, _n, a) -> a
 
8336
  | TSEnum (_n, a) -> a
 
8337
  | TSFun (_ts, _tsargs, _isva, a) -> a
 
8338
 
 
8339
 
 
8340
 
 
8341
let dExp: string -> exp =
 
8342
  fun d -> Const(CStr(d))
 
8343
 
 
8344
let dInstr: string -> location -> instr =
 
8345
  fun d l -> Asm([], [d], [], [], [], l)
 
8346
 
 
8347
let dGlobal: string -> location -> global =
 
8348
  fun d l -> GAsm(d, l)
 
8349
 
 
8350
  (* Make an AddrOf. Given an lval of type T will give back an expression of
 
8351
   * type ptr(T)  *)
 
8352
let mkAddrOf ((_b, _off) as lval) : exp =
 
8353
  (* Never take the address of a register variable *)
 
8354
  (match lval with
 
8355
    Var vi, _off when vi.vstorage = Register -> vi.vstorage <- NoStorage
 
8356
  | _ -> ());
 
8357
  match lval with
 
8358
    Mem e, NoOffset -> e
 
8359
  | b, Index(z, NoOffset) when isZero z -> StartOf (b, NoOffset)(* array *)
 
8360
  | _ -> AddrOf lval
 
8361
 
 
8362
 
 
8363
let mkAddrOrStartOf (lv: lval) : exp =
 
8364
  match unrollType (typeOfLval lv) with
 
8365
    TArray _ -> StartOf lv
 
8366
  | _ -> mkAddrOf lv
 
8367
 
 
8368
 
 
8369
  (* Make a Mem, while optimizing AddrOf. The type of the addr must be
 
8370
   * TPtr(t) and the type of the resulting lval is t. Note that in CIL the
 
8371
   * implicit conversion between a function and a pointer to a function does
 
8372
   * not apply. You must do the conversion yourself using AddrOf *)
 
8373
let mkMem ~(addr: exp) ~(off: offset) : lval =
 
8374
  let res =
 
8375
    match addr, off with
 
8376
      AddrOf lv, _ -> addOffsetLval off lv
 
8377
    | StartOf lv, _ -> (* Must be an array *)
 
8378
        addOffsetLval (Index(zero, off)) lv
 
8379
    | _, _ -> Mem addr, off
 
8380
  in
 
8381
(*  ignore (E.log "memof : %a:%a\nresult = %a\n"
 
8382
            d_plainexp addr d_plainoffset off d_plainexp res); *)
 
8383
  res
 
8384
 
 
8385
let mkTermMem ~(addr: term) ~(off: term_offset) : term_lval =
 
8386
  let loc = addr.term_loc in
 
8387
  let res =
 
8388
    match addr.term_node, off with
 
8389
      TAddrOf lv, _ -> addTermOffsetLval off lv
 
8390
    | TStartOf lv, _ -> (* Must be an array *)
 
8391
        addTermOffsetLval (TIndex(lzero ~loc (), off)) lv
 
8392
    | _, _ -> TMem addr, off
 
8393
  in
 
8394
(*  ignore (E.log "memof : %a:%a\nresult = %a\n"
 
8395
            d_plainexp addr d_plainoffset off d_plainexp res); *)
 
8396
  res
 
8397
 
 
8398
let splitFunctionType (ftype: typ)
 
8399
    : typ * (string * typ * attributes) list option * bool * attributes =
 
8400
  match unrollType ftype with
 
8401
    TFun (rt, args, isva, a) -> rt, args, isva, a
 
8402
  | _ -> E.s (bug "splitFunctionType invoked on a non function type %a"
 
8403
                d_type ftype)
 
8404
 
 
8405
let splitFunctionTypeVI (fvi: varinfo)
 
8406
    : typ * (string * typ * attributes) list option * bool * attributes =
 
8407
  match unrollType fvi.vtype with
 
8408
    TFun (rt, args, isva, a) -> rt, args, isva, a
 
8409
  | _ -> E.s (bug "Function %s invoked on a non function type" fvi.vname)
 
8410
 
 
8411
let isArrayType t =
 
8412
  match unrollType t with
 
8413
    TArray _ -> true
 
8414
  | _ -> false
 
8415
 
 
8416
let isCharArrayType t =
 
8417
  match unrollType t with
 
8418
    TArray(tau,_,_) when isCharType tau -> true
 
8419
  | _ -> false
 
8420
 
 
8421
let isStructOrUnionType t =
 
8422
  match unrollType t with
 
8423
    TComp _ -> true
 
8424
  | _ -> false
 
8425
 
 
8426
 
 
8427
let rec isConstant e = match stripInfo e with
 
8428
  | Info _ -> assert false
 
8429
  | Const _ -> true
 
8430
  | UnOp (_, e, _) -> isConstant e
 
8431
  | BinOp (_, e1, e2, _) -> isConstant e1 && isConstant e2
 
8432
  | Lval (Var vi, NoOffset) ->
 
8433
      (vi.vglob && isArrayType vi.vtype || isFunctionType vi.vtype)
 
8434
  | Lval _ -> false
 
8435
  | SizeOf _ | SizeOfE _ | SizeOfStr _ | AlignOf _ | AlignOfE _ -> true
 
8436
  | CastE (_, e) -> isConstant e
 
8437
  | AddrOf (Var vi, off) | StartOf (Var vi, off)
 
8438
        -> vi.vglob && isConstantOffset off
 
8439
  | AddrOf (Mem e, off) | StartOf(Mem e, off)
 
8440
        -> isConstant e && isConstantOffset off
 
8441
 
 
8442
and isConstantOffset = function
 
8443
    NoOffset -> true
 
8444
  | Field(_fi, off) -> isConstantOffset off
 
8445
  | Index(e, off) -> isConstant e && isConstantOffset off
 
8446
 
 
8447
let getCompField (cinfo:compinfo) (fieldName:string) : fieldinfo =
 
8448
  (List.find (fun fi -> fi.fname = fieldName) cinfo.cfields)
 
8449
 
 
8450
 
 
8451
let rec mkCastT ~(e: exp) ~(oldt: typ) ~(newt: typ) =
 
8452
  (* Do not remove old casts because they are conversions !!! *)
 
8453
  (* TODO: remove ALL attributes including volatile...*)
 
8454
  if equals
 
8455
    (typeSig (typeRemoveAttributes ["const"; "FRAMA_C_BITFIELD_SIZE"] oldt))
 
8456
    (typeSig (typeRemoveAttributes ["const"; "FRAMA_C_BITFIELD_SIZE"] newt)) then begin
 
8457
    e
 
8458
  end else begin
 
8459
    (* Watch out for constants *)
 
8460
    match newt, e with
 
8461
      TInt(newik, []), Const(CInt64(i, _, _)) -> kinteger64 newik i
 
8462
    | _ -> CastE((typeRemoveAttributes ["FRAMA_C_BITFIELD_SIZE"] newt),e)
 
8463
  end
 
8464
 
 
8465
let mkCast ~(e: exp) ~(newt: typ) =
 
8466
  mkCastT e (typeOf e) newt
 
8467
 
 
8468
type existsAction =
 
8469
    ExistsTrue                          (* We have found it *)
 
8470
  | ExistsFalse                         (* Stop processing this branch *)
 
8471
  | ExistsMaybe                         (* This node is not what we are
 
8472
                                         * looking for but maybe its
 
8473
                                         * successors are *)
 
8474
let existsType (f: typ -> existsAction) (t: typ) : bool =
 
8475
  let memo : (int, unit) H.t = H.create 17 in  (* Memo table *)
 
8476
  let rec loop t =
 
8477
    match f t with
 
8478
      ExistsTrue -> true
 
8479
    | ExistsFalse -> false
 
8480
    | ExistsMaybe ->
 
8481
        (match t with
 
8482
          TNamed (t', _) -> loop t'.ttype
 
8483
        | TComp (c, _) -> loopComp c
 
8484
        | TArray (t', _, _) -> loop t'
 
8485
        | TPtr (t', _) -> loop t'
 
8486
        | TFun (rt, args, _, _) ->
 
8487
            (loop rt || List.exists (fun (_, at, _) -> loop at)
 
8488
              (argsToList args))
 
8489
        | _ -> false)
 
8490
  and loopComp c =
 
8491
    if H.mem memo c.ckey then
 
8492
      (* We are looping, the answer must be false *)
 
8493
      false
 
8494
    else begin
 
8495
      H.add memo c.ckey ();
 
8496
      List.exists (fun f -> loop f.ftype) c.cfields
 
8497
    end
 
8498
  in
 
8499
  loop t
 
8500
 
 
8501
 
 
8502
(* Try to do an increment, with constant folding *)
 
8503
let increm (e: exp) (i: int) =
 
8504
  let et = typeOf e in
 
8505
  let bop = if isPointerType et then PlusPI else PlusA in
 
8506
  constFold false (BinOp(bop, e, integer i, et))
 
8507
 
 
8508
(* Try to do an increment, with constant folding *)
 
8509
let increm64 (e: exp) (i: int64) =
 
8510
  let et = typeOf e in
 
8511
  let bop = if isPointerType et then PlusPI else PlusA in
 
8512
  constFold false (BinOp(bop, e, kinteger64 IULongLong i, et))
 
8513
 
 
8514
exception LenOfArray
 
8515
let lenOfArray64 eo =
 
8516
  match eo with
 
8517
    None -> raise LenOfArray
 
8518
  | Some e -> begin
 
8519
      match constFold true e with
 
8520
      | Const(CInt64(ni, _, _)) when ni >= Int64.zero ->
 
8521
          ni
 
8522
      | _ -> raise LenOfArray
 
8523
    end
 
8524
let lenOfArray eo = Int64.to_int (lenOfArray64 eo)
 
8525
 
 
8526
 
 
8527
(*** Make an initializer for zeroe-ing a data type ***)
 
8528
let rec makeZeroInit (t: typ) : init =
 
8529
  match unrollType t with
 
8530
    TInt (ik, _) -> SingleInit (Const(CInt64(Int64.zero, ik, None)))
 
8531
  | TFloat(fk, _) -> SingleInit(Const(CReal(0.0, fk, None)))
 
8532
  | TEnum _ -> SingleInit zero
 
8533
  | TComp (comp, _) as t' when comp.cstruct ->
 
8534
      let inits =
 
8535
        List.fold_right
 
8536
          (fun f acc ->
 
8537
            if f.fname <> missingFieldName then
 
8538
              (Field(f, NoOffset), makeZeroInit f.ftype) :: acc
 
8539
            else
 
8540
              acc)
 
8541
          comp.cfields []
 
8542
      in
 
8543
      CompoundInit (t', inits)
 
8544
 
 
8545
  | TComp (comp, _) when not comp.cstruct ->
 
8546
      let fstfield, rest =
 
8547
        match comp.cfields with
 
8548
          f :: rest -> f, rest
 
8549
        | [] -> E.s (unimp "Cannot create init for empty union")
 
8550
      in
 
8551
      let fieldToInit =
 
8552
        if theMachine.msvcMode then
 
8553
          (* ISO C99 [6.7.8.10] says that the first field of the union
 
8554
             is the one we should initialize. *)
 
8555
          fstfield
 
8556
        else begin
 
8557
          (* gcc initializes the whole union to zero.  So choose the largest
 
8558
             field, and set that to zero.  Choose the first field if possible.
 
8559
             MSVC also initializes the whole union, but use the ISO behavior
 
8560
             for MSVC because it only allows compound initializers to refer
 
8561
             to the first union field. *)
 
8562
          let fieldSize f = try bitsSizeOf f.ftype with SizeOfError _ -> 0 in
 
8563
          let widestField, _widestFieldWidth =
 
8564
            List.fold_left (fun acc thisField ->
 
8565
                              let _widestField, widestFieldWidth = acc in
 
8566
                              let thisSize = fieldSize thisField in
 
8567
                              if thisSize > widestFieldWidth then
 
8568
                                thisField, thisSize
 
8569
                              else
 
8570
                                acc)
 
8571
              (fstfield, fieldSize fstfield)
 
8572
              rest
 
8573
          in
 
8574
          widestField
 
8575
        end
 
8576
      in
 
8577
      CompoundInit(t, [(Field(fieldToInit, NoOffset),
 
8578
                        makeZeroInit fieldToInit.ftype)])
 
8579
 
 
8580
  | TArray(bt, Some len, _) as t' ->
 
8581
      let n =
 
8582
        match constFold true len with
 
8583
          Const(CInt64(n, _, _)) -> Int64.to_int n
 
8584
        | _ -> E.s (E.unimp "Cannot understand length of array")
 
8585
      in
 
8586
      let initbt = makeZeroInit bt in
 
8587
      let rec loopElems acc i =
 
8588
        if i < 0 then acc
 
8589
        else loopElems ((Index(integer i, NoOffset), initbt) :: acc) (i - 1)
 
8590
      in
 
8591
      CompoundInit(t', loopElems [] (n - 1))
 
8592
 
 
8593
  | TArray (_bt, None, _at) as t' ->
 
8594
      (* Unsized array, allow it and fill it in later
 
8595
       * (see cabs2cil.ml, collectInitializer) *)
 
8596
      CompoundInit (t', [])
 
8597
 
 
8598
  | TPtr _ as t ->
 
8599
      SingleInit(if theMachine.insertImplicitCasts then mkCast zero t else zero)
 
8600
  | x -> E.s (unimp "Cannot initialize type: %a" d_type x)
 
8601
 
 
8602
 
 
8603
(** Fold over the list of initializers in a Compound (not also the nested
 
8604
 * ones). [doinit] is called on every present initializer, even if it is of
 
8605
 * compound type. The parameters of [doinit] are: the offset in the compound
 
8606
 * (this is [Field(f,NoOffset)] or [Index(i,NoOffset)]), the initializer
 
8607
 * value, expected type of the initializer value, accumulator. In the case of
 
8608
 * arrays there might be missing zero-initializers at the end of the list.
 
8609
 * These are scanned only if [implicit] is true. This is much like
 
8610
 * [List.fold_left] except we also pass the type of the initializer. *)
 
8611
let foldLeftCompound
 
8612
    ~(implicit: bool)
 
8613
    ~(doinit: offset -> init -> typ -> 'a -> 'a)
 
8614
    ~(ct: typ)
 
8615
    ~(initl: (offset * init) list)
 
8616
    ~(acc: 'a) : 'a =
 
8617
  match unrollType ct with
 
8618
    TArray(bt, leno, _) -> begin
 
8619
      (* Scan the existing initializer *)
 
8620
      let part =
 
8621
        List.fold_left (fun acc (o, i) -> doinit o i bt acc) acc initl in
 
8622
      (* See how many more we have to do *)
 
8623
      match leno with
 
8624
        Some lene when implicit -> begin
 
8625
          match constFold true lene with
 
8626
            Const(CInt64(i, _, _)) ->
 
8627
              let len_array = Int64.to_int i in
 
8628
              let len_init = List.length initl in
 
8629
              if len_array > len_init then
 
8630
                let zi = makeZeroInit bt in
 
8631
                let rec loop acc i =
 
8632
                  if i >= len_array then acc
 
8633
                  else
 
8634
                    loop (doinit (Index(integer i, NoOffset)) zi bt acc)
 
8635
                         (i + 1)
 
8636
                in
 
8637
                loop part (len_init + 1)
 
8638
              else
 
8639
                part
 
8640
          | _ -> E.s (unimp "foldLeftCompoundAll: array with initializer and non-constant length\n")
 
8641
        end
 
8642
 
 
8643
      | _ when not implicit -> part
 
8644
 
 
8645
      | _ -> E.s (unimp "foldLeftCompoundAll: TArray with initializer and no length")
 
8646
    end
 
8647
 
 
8648
  | TComp (_comp, _) ->
 
8649
      let getTypeOffset = function
 
8650
          Field(f, NoOffset) -> f.ftype
 
8651
        | _ -> E.s (bug "foldLeftCompound: malformed initializer")
 
8652
      in
 
8653
      List.fold_left
 
8654
        (fun acc (o, i) -> doinit o i (getTypeOffset o) acc) acc initl
 
8655
 
 
8656
  | _ -> E.s (E.unimp "Type of Compound is not array or struct or union")
 
8657
 
 
8658
 
 
8659
 
 
8660
 
 
8661
let rec isCompleteType t =
 
8662
  match unrollType t with
 
8663
  | TArray(_t, None, _) -> false
 
8664
  | TArray(_t, Some z, _) when isZero z -> false
 
8665
  | TComp (comp, _) -> (* Struct or union *)
 
8666
      List.for_all (fun fi -> isCompleteType fi.ftype) comp.cfields
 
8667
  | _ -> true
 
8668
 
 
8669
 
 
8670
module A = Alpha
 
8671
 
 
8672
 
 
8673
(** Uniquefy the variable names *)
 
8674
let uniqueVarNames (f: file) : unit =
 
8675
  (* Setup the alpha conversion table for globals *)
 
8676
  let gAlphaTable: (string,
 
8677
                    location A.alphaTableData ref) H.t = H.create 113 in
 
8678
  (* Keep also track of the global names that we have used. Map them to the
 
8679
   * variable ID. We do this only to check that we do not have two globals
 
8680
   * with the same name. *)
 
8681
  let globalNames: (string, int) H.t = H.create 113 in
 
8682
  (* Scan the file and add the global names to the table *)
 
8683
  iterGlobals f
 
8684
    (function
 
8685
        GVarDecl(_,vi, _)
 
8686
      | GVar(vi, _, _)
 
8687
      | GFun({svar = vi}, _) ->
 
8688
          (* See if we have used this name already for something else *)
 
8689
          (try
 
8690
            let oldid = H.find globalNames vi.vname in
 
8691
            if oldid <> vi.vid && not vi.vinline then
 
8692
              ignore (warn "The name %s is used for two distinct globals"
 
8693
                        vi.vname)
 
8694
            (* Here if we have used this name already. Go ahead *)
 
8695
          with Not_found -> begin
 
8696
            (* Here if this is the first time we define a name *)
 
8697
            H.add globalNames vi.vname vi.vid;
 
8698
            (* And register it *)
 
8699
            A.registerAlphaName gAlphaTable None vi.vname (CurrentLoc.get ())
 
8700
          end)
 
8701
      | _ -> ());
 
8702
 
 
8703
  (* Now we must scan the function bodies and rename the locals *)
 
8704
  iterGlobals f
 
8705
    (function
 
8706
        GFun(fdec, l) -> begin
 
8707
          CurrentLoc.set l;
 
8708
          (* Setup an undo list to be able to revert the changes to the
 
8709
           * global alpha table *)
 
8710
          let undolist = ref [] in
 
8711
          (* Process one local variable *)
 
8712
          let processLocal (v: varinfo) =
 
8713
            let newname, oldloc =
 
8714
              A.newAlphaName gAlphaTable (Some undolist) v.vname
 
8715
                (CurrentLoc.get ())
 
8716
            in
 
8717
            if false && newname <> v.vname then (* Disable this warning *)
 
8718
              ignore (warn "uniqueVarNames: Changing the name of local %s in %s to %s (due to duplicate at %a)\n"
 
8719
                        v.vname
 
8720
                        fdec.svar.vname
 
8721
                        newname d_loc oldloc);
 
8722
            v.vname <- newname
 
8723
          in
 
8724
          (* Do the formals first *)
 
8725
          List.iter processLocal fdec.sformals;
 
8726
          (* Fix the type again *)
 
8727
          setFormals fdec fdec.sformals;
 
8728
          (* And now the locals *)
 
8729
          List.iter processLocal fdec.slocals;
 
8730
          (* Undo the changes to the global table *)
 
8731
          A.undoAlphaChanges gAlphaTable !undolist;
 
8732
          ()
 
8733
        end
 
8734
      | _ -> ());
 
8735
  ()
 
8736
 
 
8737
 
 
8738
(* A visitor that makes a deep copy of a function body *)
 
8739
class copyFunctionVisitor (newname: string) = object
 
8740
  inherit nopCilVisitor
 
8741
 
 
8742
      (* Keep here a maping from locals to their copies *)
 
8743
  val map : (string, varinfo) H.t = H.create 113
 
8744
      (* Keep here a maping from statements to their copies *)
 
8745
  val stmtmap : (int, stmt) H.t = H.create 113
 
8746
  (*val sid = ref 0 (* Will have to assign ids to statements *) *)
 
8747
      (* Keep here a list of statements to be patched *)
 
8748
  val patches : stmt list ref = ref []
 
8749
 
 
8750
  val argid = ref 0
 
8751
 
 
8752
      (* This is the main function *)
 
8753
  method vfunc (f: fundec) : fundec visitAction =
 
8754
    (* We need a map from the old locals/formals to the new ones *)
 
8755
    H.clear map;
 
8756
    argid := 0;
 
8757
     (* Make a copy of the fundec. *)
 
8758
    let f' = {f with svar = f.svar} in
 
8759
    let patchfunction (f' : fundec) =
 
8760
      (* Change the name. Only this late to allow the visitor to copy the
 
8761
       * svar  *)
 
8762
      f'.svar.vname <- newname;
 
8763
      let findStmt (i: int) =
 
8764
        try H.find stmtmap i
 
8765
        with Not_found -> E.s (bug "Cannot find the copy of stmt#%d" i)
 
8766
      in
 
8767
      let patchstmt (s: stmt) =
 
8768
        match s.skind with
 
8769
          Goto (sr, l) ->
 
8770
            (* Make a copy of the reference *)
 
8771
            let sr' = ref (findStmt !sr.sid) in
 
8772
            s.skind <- Goto (sr',l)
 
8773
        | Switch (e, body, cases, l) ->
 
8774
            s.skind <- Switch (e, body,
 
8775
                               List.map (fun cs -> findStmt cs.sid) cases, l)
 
8776
        | _ -> ()
 
8777
      in
 
8778
      List.iter patchstmt !patches;
 
8779
      f'
 
8780
    in
 
8781
    patches := [];
 
8782
(*    sid := 0; *)
 
8783
    H.clear stmtmap;
 
8784
    ChangeDoChildrenPost (f', patchfunction)
 
8785
 
 
8786
  (* We must create a new varinfo for each declaration. Memoize to
 
8787
   * maintain sharing *)
 
8788
  method vvdec (v: varinfo) =
 
8789
    (* Some varinfo have empty names. Give them some name *)
 
8790
    if v.vname = "" then begin
 
8791
      v.vname <- "arg" ^ string_of_int !argid; incr argid
 
8792
    end;
 
8793
    try
 
8794
      ChangeTo (H.find map v.vname)
 
8795
    with Not_found -> begin
 
8796
      let v' = copy_with_new_vid v in
 
8797
      H.add map v.vname v';
 
8798
      ChangeDoChildrenPost (v', fun x -> x)
 
8799
    end
 
8800
 
 
8801
  (* We must replace references to local variables *)
 
8802
  method vvrbl (v: varinfo) =
 
8803
    if v.vglob then SkipChildren else
 
8804
    try
 
8805
      ChangeTo (H.find map v.vname)
 
8806
    with Not_found ->
 
8807
      E.s (bug "Cannot find the new copy of local variable %s" v.vname)
 
8808
 
 
8809
 
 
8810
        (* Replace statements. *)
 
8811
  method vstmt (s: stmt) : stmt visitAction =
 
8812
    s.sid <- Sid.next ();
 
8813
    let s' = {s with sid = s.sid} in
 
8814
    H.add stmtmap s.sid s'; (* Remember where we copied this *)
 
8815
    (* if we have a Goto or a Switch remember them to fixup at end *)
 
8816
    (match s'.skind with
 
8817
      (Goto _ | Switch _) -> patches := s' :: !patches
 
8818
    | _ -> ());
 
8819
    (* Do the children *)
 
8820
    ChangeDoChildrenPost (s', fun x -> x)
 
8821
 
 
8822
      (* Copy blocks since they are mutable *)
 
8823
  method vblock (b: block) =
 
8824
    ChangeDoChildrenPost ({b with bstmts = b.bstmts}, fun x -> x)
 
8825
 
 
8826
 
 
8827
  method vglob _ = E.s (bug "copyFunction should not be used on globals")
 
8828
end
 
8829
 
 
8830
(* We need a function that copies a CIL function. *)
 
8831
let copyFunction (f: fundec) (newname: string) : fundec =
 
8832
  visitCilFunction (new copyFunctionVisitor(newname)) f
 
8833
 
 
8834
(********* Compute the CFG ********)
 
8835
 
 
8836
let statements : stmt list ref = ref []
 
8837
(* Clear all info about the CFG in statements *)
 
8838
class clear : cilVisitor = object
 
8839
  inherit nopCilVisitor
 
8840
  method vstmt s = begin
 
8841
    s.sid <- Sid.next ();
 
8842
    statements := s :: !statements;
 
8843
    s.succs <- [] ;
 
8844
    s.preds <- [] ;
 
8845
    DoChildren
 
8846
  end
 
8847
  method vexpr _ = SkipChildren
 
8848
  method vtype _ = SkipChildren
 
8849
  method vinst _ = SkipChildren
 
8850
end
 
8851
 
 
8852
let link source dest = begin
 
8853
  if not (List.mem dest source.succs) then
 
8854
    source.succs <- dest :: source.succs ;
 
8855
  if not (List.mem source dest.preds) then
 
8856
    dest.preds <- source :: dest.preds
 
8857
end
 
8858
let trylink source dest_option = match dest_option with
 
8859
  None -> ()
 
8860
| Some(dest) -> link source dest
 
8861
 
 
8862
 
 
8863
(** Compute the successors and predecessors of a block, given a fallthrough *)
 
8864
let rec succpred_block b fallthrough =
 
8865
  let rec handle sl = match sl with
 
8866
    [] -> ()
 
8867
  | [a] -> succpred_stmt a fallthrough
 
8868
  | hd :: ((next :: _) as tl) ->
 
8869
      succpred_stmt hd (Some next) ;
 
8870
      handle tl
 
8871
  in handle b.bstmts
 
8872
 
 
8873
 
 
8874
and succpred_stmt s fallthrough =
 
8875
  match s.skind with
 
8876
    Instr _ -> trylink s fallthrough
 
8877
  | Return _ -> ()
 
8878
  | Goto(dest,_) -> link s !dest
 
8879
  | Break _
 
8880
  | Continue _
 
8881
  | Switch _ ->
 
8882
    failwith "computeCFGInfo: cannot be called on functions with break, continue or switch statements. Use prepareCFG first to remove them."
 
8883
 
 
8884
  | If(_e1,b1,b2,_) ->
 
8885
      (match b1.bstmts with
 
8886
        [] -> trylink s fallthrough
 
8887
      | hd :: _ -> (link s hd ; succpred_block b1 fallthrough )) ;
 
8888
      (match b2.bstmts with
 
8889
        [] -> trylink s fallthrough
 
8890
      | hd :: _ -> (link s hd ; succpred_block b2 fallthrough ))
 
8891
 
 
8892
  | Loop(_,b,_,_,_) ->
 
8893
      begin match b.bstmts with
 
8894
        [] -> failwith "computeCFGInfo: empty loop"
 
8895
      | hd :: _ ->
 
8896
          link s hd ;
 
8897
          succpred_block b (Some(hd))
 
8898
      end
 
8899
 
 
8900
  | Block(b) -> begin match b.bstmts with
 
8901
                  [] -> trylink s fallthrough
 
8902
                | hd :: _ -> link s hd ;
 
8903
                    succpred_block b fallthrough
 
8904
                end
 
8905
  | UnspecifiedSequence (((s1,_,_)::_) as seq) ->
 
8906
      link s s1;
 
8907
      succpred_block (block_from_unspecified_sequence seq) fallthrough
 
8908
  | UnspecifiedSequence [] ->
 
8909
      trylink s fallthrough
 
8910
  | TryExcept _ | TryFinally _ ->
 
8911
      failwith "computeCFGInfo: structured exception handling not implemented"
 
8912
 
 
8913
(* [weimer] Sun May  5 12:25:24 PDT 2002
 
8914
 * This code was pulled from ext/switch.ml because it looks like we really
 
8915
 * want it to be part of CIL.
 
8916
 *
 
8917
 * Here is the magic handling to
 
8918
 *  (1) replace switch statements with if/goto
 
8919
 *  (2) remove "break"
 
8920
 *  (3) remove "default"
 
8921
 *  (4) remove "continue"
 
8922
 *)
 
8923
let is_case_label l = match l with
 
8924
  | Case _ | Default _ -> true
 
8925
  | _ -> false
 
8926
 
 
8927
let switch_count = ref (-1)
 
8928
let get_switch_count () =
 
8929
  switch_count := 1 + !switch_count ;
 
8930
  !switch_count
 
8931
 
 
8932
let switch_label = ref (-1)
 
8933
 
 
8934
let rec xform_switch_stmt
 
8935
    ?(keepSwitch=false) s break_dest cont_dest label_index = begin
 
8936
  if not keepSwitch then
 
8937
    s.labels <- List.map (fun lab -> match lab with
 
8938
      Label _ -> lab
 
8939
    | Case(e,l) ->
 
8940
        let suffix =
 
8941
          match isInteger e with
 
8942
          | Some value ->
 
8943
              if value < Int64.zero then
 
8944
                "neg_" ^ Int64.to_string (Int64.neg value)
 
8945
              else
 
8946
                Int64.to_string value
 
8947
          | None ->
 
8948
              incr switch_label;
 
8949
              "exp_" ^ string_of_int !switch_label
 
8950
        in
 
8951
        let str = Pretty.sprint miscState.lineLength
 
8952
          (Pretty.dprintf "switch_%d_%s" label_index suffix) in
 
8953
        (Label(str,l,false))
 
8954
    | Default(l) -> (Label(Printf.sprintf
 
8955
        "switch_%d_default" label_index,l,false))
 
8956
    ) s.labels ;
 
8957
  match s.skind with
 
8958
  | Instr _ | Return _ | Goto _  -> ()
 
8959
  | Break(l) -> begin try
 
8960
                  s.skind <- Goto(break_dest (),l)
 
8961
                with e ->
 
8962
                  ignore (error "@[prepareCFG: break: %a@\n@]" d_stmt s) ;
 
8963
                  raise e
 
8964
                end
 
8965
  | Continue(l) -> begin try
 
8966
                  s.skind <- Goto(cont_dest (),l)
 
8967
                with e ->
 
8968
                  ignore (error "@[prepareCFG: continue: %a@\n@]" d_stmt s) ;
 
8969
                  raise e
 
8970
                end
 
8971
  | If(_e,b1,b2,_) ->
 
8972
      xform_switch_block ~keepSwitch b1 break_dest cont_dest label_index ;
 
8973
      xform_switch_block ~keepSwitch b2 break_dest cont_dest label_index
 
8974
  | Switch(e,b,sl,l) ->
 
8975
      if keepSwitch then
 
8976
        let i = get_switch_count () in
 
8977
        let break_stmt = mkStmt (Instr (Skip locUnknown)) in
 
8978
        break_stmt.labels <-
 
8979
          [Label((Printf.sprintf "switch_%d_break" i),l,false)] ;
 
8980
        let switch_stmt = mkStmt s.skind in
 
8981
        let break_block = mkBlock [ switch_stmt; break_stmt ] in
 
8982
        s.skind <- Block break_block;
 
8983
        xform_switch_block ~keepSwitch b (fun () -> ref break_stmt) cont_dest i
 
8984
      else begin
 
8985
      (* change
 
8986
       * switch (se) {
 
8987
       *   case 0: s0 ;
 
8988
       *   case 1: s1 ; break;
 
8989
       *   ...
 
8990
       * }
 
8991
       *
 
8992
       * into:
 
8993
       *
 
8994
       * if (se == 0) goto label_0;
 
8995
       * else if (se == 1) goto label_1;
 
8996
       * ...
 
8997
       * else if (0) { // body_block
 
8998
       *  label_0: s0;
 
8999
       *  label_1: s1; goto label_break;
 
9000
       *  ...
 
9001
       * } else if (0) { // break_block
 
9002
       *  label_break: ; // break_stmt
 
9003
       * }
 
9004
       *)
 
9005
      let i = get_switch_count () in
 
9006
      let break_stmt = mkStmt (Instr (Skip locUnknown)) in
 
9007
      break_stmt.labels <-
 
9008
                                [Label((Printf.sprintf "switch_%d_break" i),l,false)] ;
 
9009
      let break_block = mkBlock [ break_stmt ] in
 
9010
      let body_block = b in
 
9011
      let body_if_stmtkind = (If(zero,body_block,break_block,l)) in
 
9012
 
 
9013
      (* The default case, if present, must be used only if *all*
 
9014
      non-default cases fail [ISO/IEC 9899:1999, �6.8.4.2, �5]. As a
 
9015
      result, we sort the order in which we handle the labels (but not the
 
9016
      order in which we print out the statements, so fall-through still
 
9017
      works as expected). *)
 
9018
      let compare_choices s1 s2 = match s1.labels, s2.labels with
 
9019
      | (Default(_) :: _), _ -> 1
 
9020
      | _, (Default(_) :: _) -> -1
 
9021
      | _, _ -> 0
 
9022
      in
 
9023
 
 
9024
      let rec handle_choices sl = match sl with
 
9025
        [] -> body_if_stmtkind
 
9026
      | stmt_hd :: stmt_tl -> begin
 
9027
        let rec handle_labels lab_list = begin
 
9028
          match lab_list with
 
9029
            [] -> handle_choices stmt_tl
 
9030
          | Case(ce,cl) :: lab_tl ->
 
9031
              let pred = BinOp(Eq,e,ce,intType) in
 
9032
              let then_block = mkBlock [ mkStmt (Goto(ref stmt_hd,cl)) ] in
 
9033
              let else_block = mkBlock [ mkStmt (handle_labels lab_tl) ] in
 
9034
              If(pred,then_block,else_block,cl)
 
9035
          | Default(dl) :: lab_tl ->
 
9036
              (* ww: before this was 'if (1) goto label', but as Ben points
 
9037
              out this might confuse someone down the line who doesn't have
 
9038
              special handling for if(1) into thinking that there are two
 
9039
              paths here. The simpler 'goto label' is what we want. *)
 
9040
              Block(mkBlock [ mkStmt (Goto(ref stmt_hd,dl)) ;
 
9041
                              mkStmt (handle_labels lab_tl) ])
 
9042
          | Label(_,_,_) :: lab_tl -> handle_labels lab_tl
 
9043
        end in
 
9044
        handle_labels stmt_hd.labels
 
9045
      end in
 
9046
      s.skind <- handle_choices (List.sort compare_choices sl) ;
 
9047
      xform_switch_block ~keepSwitch b (fun () -> ref break_stmt) cont_dest i
 
9048
    end
 
9049
  | Loop(a,b,l,_,_) ->
 
9050
          let i = get_switch_count () in
 
9051
          let break_stmt = mkStmt (Instr (Skip locUnknown)) in
 
9052
          break_stmt.labels <-
 
9053
                                                [Label((Printf.sprintf "while_%d_break" i),l,false)] ;
 
9054
          let cont_stmt = mkStmt (Instr (Skip locUnknown)) in
 
9055
          cont_stmt.labels <-
 
9056
                                                [Label((Printf.sprintf "while_%d_continue" i),l,false)] ;
 
9057
          b.bstmts <- cont_stmt :: b.bstmts ;
 
9058
          let this_stmt = mkStmt
 
9059
            (Loop(a,b,l,Some(cont_stmt),Some(break_stmt))) in
 
9060
          let break_dest () = ref break_stmt in
 
9061
          let cont_dest () = ref cont_stmt in
 
9062
          xform_switch_block ~keepSwitch b break_dest cont_dest label_index ;
 
9063
          break_stmt.succs <- s.succs ;
 
9064
          let new_block = mkBlock [ this_stmt ; break_stmt ] in
 
9065
          s.skind <- Block new_block
 
9066
  | Block b ->
 
9067
      xform_switch_block ~keepSwitch b break_dest cont_dest label_index
 
9068
  | UnspecifiedSequence seq ->
 
9069
      xform_switch_block ~keepSwitch
 
9070
        (block_from_unspecified_sequence seq) break_dest cont_dest label_index
 
9071
  | TryExcept _ | TryFinally _ ->
 
9072
      failwith "xform_switch_statement: structured exception handling not implemented"
 
9073
 
 
9074
end and xform_switch_block
 
9075
    ?(keepSwitch=false) b break_dest cont_dest label_index =
 
9076
  try
 
9077
    let rec link_succs sl = match sl with
 
9078
    | [] -> ()
 
9079
    | hd :: tl -> (if hd.succs = [] then hd.succs <- tl) ; link_succs tl
 
9080
    in
 
9081
    link_succs b.bstmts ;
 
9082
    List.iter (fun stmt ->
 
9083
      xform_switch_stmt ~keepSwitch stmt break_dest cont_dest label_index) b.bstmts ;
 
9084
  with e ->
 
9085
    List.iter (fun stmt -> ignore
 
9086
      (warn "prepareCFG: %a@\n" d_stmt stmt)) b.bstmts ;
 
9087
    raise e
 
9088
 
 
9089
(* prepare a function for computeCFGInfo by removing break, continue,
 
9090
 * default and switch statements/labels and replacing them with Ifs and
 
9091
 * Gotos. *)
 
9092
let prepareCFG ?(keepSwitch=false) (fd : fundec) : unit =
 
9093
  xform_switch_block ~keepSwitch fd.sbody
 
9094
      (fun () -> failwith "prepareCFG: break with no enclosing loop")
 
9095
      (fun () -> failwith "prepareCFG: continue with no enclosing loop") (-1)
 
9096
 
 
9097
(* make the cfg and return a list of statements *)
 
9098
let computeCFGInfo (f : fundec) (global_numbering : bool) : unit =
 
9099
  if not global_numbering then Sid.reset ();
 
9100
  statements := [];
 
9101
  let clear_it = new clear in
 
9102
  ignore (visitCilBlock clear_it f.sbody) ;
 
9103
  f.smaxstmtid <- Some (Sid.get ()) ;
 
9104
  succpred_block f.sbody (None);
 
9105
  let res = List.rev !statements in
 
9106
  statements := [];
 
9107
  f.sallstmts <- res;
 
9108
  ()
 
9109
 
 
9110
let make_logic_var x typ =
 
9111
  {lv_name = x; lv_id = new_raw_id(); lv_type = typ; lv_origin = None }
 
9112
 
 
9113
let initLogicBuiltins () =
 
9114
  (* types *)
 
9115
  Logic_env.add_builtin_logic_type "boolean" { nb_params=0 };
 
9116
  Logic_env.add_builtin_logic_type "set" { nb_params=1 };
 
9117
  (* constructors *)
 
9118
  Logic_env.add_builtin_logic_ctor
 
9119
    "\\true" { ctor_name = "\\true";
 
9120
               ctor_type = Ltype("boolean",[]);
 
9121
               ctor_params = []
 
9122
             };
 
9123
  Logic_env.add_builtin_logic_ctor
 
9124
    "\\false"
 
9125
    { ctor_name = "\\false";
 
9126
      ctor_type = Ltype("boolean",[]);
 
9127
      ctor_params = [] };
 
9128
  (* functions *)
 
9129
  let min = make_logic_var "min" Linteger in
 
9130
  let max = make_logic_var "max" Linteger in
 
9131
  let f = make_logic_var "f" (Larrow ([Linteger],Linteger)) in
 
9132
  Logic_env.add_builtin_logic_function
 
9133
    {
 
9134
      l_name = "\\sum";
 
9135
      l_type = Some Linteger;
 
9136
      l_tparams = []; (* FIXME !!! *)
 
9137
      l_profile = [ min; max; f ];
 
9138
      l_labels = [];
 
9139
      l_body = LBreads
 
9140
        [ TSSingleton (TSLval (TSVar min,TSNoOffset));
 
9141
          TSSingleton (TSLval (TSVar max,TSNoOffset));
 
9142
          TSSingleton (TSLval (TSVar f, TSNoOffset)) ];
 
9143
    };
 
9144
  let min = make_logic_var "min" Linteger in
 
9145
  let max = make_logic_var "max" Linteger in
 
9146
  let f = make_logic_var "f" (Larrow ([Linteger],Linteger)) in
 
9147
  Logic_env.add_builtin_logic_function
 
9148
    {
 
9149
      l_name = "\\product";
 
9150
      l_type = Some Linteger;
 
9151
      l_tparams = []; (* FIXME !!! *)
 
9152
      l_profile = [ min; max; f ];
 
9153
      l_labels = [];
 
9154
      l_body = LBreads
 
9155
        [ TSSingleton (TSLval (TSVar min,TSNoOffset));
 
9156
          TSSingleton (TSLval (TSVar max,TSNoOffset));
 
9157
          TSSingleton (TSLval (TSVar f, TSNoOffset)) ];
 
9158
    };
 
9159
  let min = make_logic_var "min" Linteger in
 
9160
  let max = make_logic_var "max" Linteger in
 
9161
  let f = make_logic_var "f" (Larrow ([Linteger],Linteger)) in
 
9162
  Logic_env.add_builtin_logic_function
 
9163
    {
 
9164
      l_name = "\\min";
 
9165
      l_type = Some Linteger;
 
9166
      l_tparams = []; (* FIXME !!! *)
 
9167
      l_profile = [ min; max; f ];
 
9168
      l_labels = [];
 
9169
      l_body = LBreads
 
9170
        [ TSSingleton (TSLval (TSVar min,TSNoOffset));
 
9171
          TSSingleton (TSLval (TSVar max,TSNoOffset));
 
9172
          TSSingleton (TSLval (TSVar f, TSNoOffset)) ];
 
9173
    };
 
9174
  let min = make_logic_var "min" Linteger in
 
9175
  let max = make_logic_var "max" Linteger in
 
9176
  let f = make_logic_var "f" (Larrow ([Linteger],Linteger)) in
 
9177
  Logic_env.add_builtin_logic_function
 
9178
    {
 
9179
      l_name = "\\max";
 
9180
      l_type = Some Linteger;
 
9181
      l_tparams = []; (* FIXME !!! *)
 
9182
      l_profile = [ min; max; f ];
 
9183
      l_labels = [];
 
9184
      l_body = LBreads
 
9185
        [ TSSingleton (TSLval (TSVar min,TSNoOffset));
 
9186
          TSSingleton (TSLval (TSVar max,TSNoOffset));
 
9187
          TSSingleton (TSLval (TSVar f, TSNoOffset)) ];
 
9188
    };
 
9189
  let min = make_logic_var "min" Linteger in
 
9190
  let max = make_logic_var "max" Linteger in
 
9191
  let f =
 
9192
    make_logic_var "f"
 
9193
      (Larrow ([Linteger],Ltype("boolean",[])))
 
9194
  in
 
9195
  Logic_env.add_builtin_logic_function
 
9196
    {
 
9197
      l_name = "\\numof";
 
9198
      l_type = Some Linteger;
 
9199
      l_tparams = []; (* FIXME !! *)
 
9200
      l_profile = [ min; max; f ];
 
9201
      l_labels = [];
 
9202
      l_body = LBreads
 
9203
        [ TSSingleton (TSLval (TSVar min,TSNoOffset));
 
9204
          TSSingleton (TSLval (TSVar max,TSNoOffset));
 
9205
          TSSingleton (TSLval (TSVar f, TSNoOffset)) ];
 
9206
    }
 
9207
 
 
9208
let initCIL () =
 
9209
  if not (TheMachine.is_computed ()) then begin
 
9210
 
 
9211
    (* Set the machine *)
 
9212
    theMachine.theMachine <-
 
9213
      if theMachine.msvcMode then Machdep.state.Machdep.msvc
 
9214
      else Machdep.state.Machdep.gcc;
 
9215
    (* Pick type for string literals *)
 
9216
    theMachine.stringLiteralType <-
 
9217
      if theMachine.theMachine.const_string_literals then
 
9218
      charConstPtrType
 
9219
    else
 
9220
      charPtrType;
 
9221
    (* Find the right ikind given the size *)
 
9222
    let findIkindSz (unsigned: bool) (sz: int) : ikind =
 
9223
      (* Test the most common sizes first *)
 
9224
      if sz = theMachine.theMachine.sizeof_int then
 
9225
        if unsigned then IUInt else IInt
 
9226
      else if sz = theMachine.theMachine.sizeof_long then
 
9227
        if unsigned then IULong else ILong
 
9228
      else if sz = 1 then
 
9229
        if unsigned then IUChar else IChar
 
9230
      else if sz = theMachine.theMachine.sizeof_short then
 
9231
        if unsigned then IUShort else IShort
 
9232
      else if sz = theMachine.theMachine.sizeof_longlong then
 
9233
        if unsigned then IULongLong else ILongLong
 
9234
      else
 
9235
        E.s(E.unimp "initCIL: cannot find the right ikind for size %d\n" sz)
 
9236
    in
 
9237
    (* Find the right ikind given the name *)
 
9238
    let findIkindName (name: string) : ikind =
 
9239
      (* Test the most common sizes first *)
 
9240
      if name = "int" then IInt
 
9241
      else if name = "unsigned int" then IUInt
 
9242
      else if name = "long" then ILong
 
9243
      else if name = "unsigned long" then IULong
 
9244
      else if name = "short" then IShort
 
9245
      else if name = "unsigned short" then IUShort
 
9246
      else if name = "char" then IChar
 
9247
      else if name = "unsigned char" then IUChar
 
9248
      else
 
9249
        E.s(E.unimp "initCIL: cannot find the right ikind for type %s\n" name)
 
9250
    in
 
9251
    theMachine.upointType <-
 
9252
      TInt(findIkindSz true theMachine.theMachine.sizeof_ptr, []);
 
9253
    theMachine.kindOfSizeOf <-
 
9254
      findIkindName theMachine.theMachine.size_t;
 
9255
    theMachine.typeOfSizeOf <- TInt(theMachine.kindOfSizeOf, []);
 
9256
    theMachine.wcharKind <- findIkindName theMachine.theMachine.wchar_t;
 
9257
    theMachine.wcharType <- TInt(theMachine.wcharKind, []);
 
9258
    theMachine.ptrdiffKind <- findIkindName theMachine.theMachine.ptrdiff_t;
 
9259
    theMachine.ptrdiffType <- TInt(theMachine.ptrdiffKind, []);
 
9260
    theMachine.char_is_unsigned <-
 
9261
      theMachine.theMachine.Cil_types.char_is_unsigned;
 
9262
    theMachine.little_endian <- theMachine.theMachine.Cil_types.little_endian;
 
9263
    theMachine.underscore_name <-
 
9264
      theMachine.theMachine.Cil_types.underscore_name;
 
9265
    theMachine.enum_are_signed <-
 
9266
      theMachine.theMachine.Cil_types.enum_are_signed;
 
9267
    (* do not use lazy LAND and LOR *)
 
9268
    theMachine.useLogicalOperators <- false;
 
9269
    (*nextGlobalVID <- 1 ;
 
9270
    nextCompinfoKey <- 1;*)
 
9271
 
 
9272
    (* Have to be mark before calling [init*Builtins] below. *)
 
9273
    TheMachine.mark_as_computed ();
 
9274
 
 
9275
    if theMachine.msvcMode then
 
9276
      initMsvcBuiltins ()
 
9277
    else
 
9278
      initGccBuiltins ();
 
9279
 
 
9280
    Logic_env.Builtins.extend initLogicBuiltins;
 
9281
 
 
9282
    (* projectify theMachine *)
 
9283
    copyMachine theMachine !theMachineProject;
 
9284
 
 
9285
  end
 
9286
 
 
9287
 
 
9288
(* We want to bring all type declarations before the data declarations. This
 
9289
 * is needed for code of the following form:
 
9290
 
 
9291
   int f(); // Prototype without arguments
 
9292
   typedef int FOO;
 
9293
   int f(FOO x) { ... }
 
9294
 
 
9295
   In CIL the prototype also lists the type of the argument as being FOO,
 
9296
   which is undefined.
 
9297
 
 
9298
   There is one catch with this scheme. If the type contains an array whose
 
9299
   length refers to variables then those variables must be declared before
 
9300
   the type *)
 
9301
 
 
9302
let pullTypesForward = true
 
9303
 
 
9304
 
 
9305
    (* Scan a type and collect the variables that are refered *)
 
9306
class getVarsInGlobalClass (pacc: varinfo list ref) = object
 
9307
  inherit nopCilVisitor
 
9308
  method vvrbl (vi: varinfo) =
 
9309
    pacc := vi :: !pacc;
 
9310
    SkipChildren
 
9311
 
 
9312
  method vglob = function
 
9313
      GType _ | GCompTag _ -> DoChildren
 
9314
    | _ -> SkipChildren
 
9315
 
 
9316
end
 
9317
 
 
9318
let getVarsInGlobal (g : global) : varinfo list =
 
9319
  let pacc : varinfo list ref = ref [] in
 
9320
  let v : cilVisitor = new getVarsInGlobalClass pacc in
 
9321
  ignore (visitCilGlobal v g);
 
9322
  !pacc
 
9323
 
 
9324
let hasPrefix p s =
 
9325
  let pl = String.length p in
 
9326
  (String.length s >= pl) && String.sub s 0 pl = p
 
9327
 
 
9328
let pushGlobal (g: global)
 
9329
               ~(types:global list ref)
 
9330
               ~(variables: global list ref) =
 
9331
  if not pullTypesForward then
 
9332
    variables := g :: !variables
 
9333
  else
 
9334
    begin
 
9335
      (* Collect a list of variables that are refered from the type. Return
 
9336
       * Some if the global should go with the types and None if it should go
 
9337
       * to the variables. *)
 
9338
      let varsintype : (varinfo list * location) option =
 
9339
        match g with
 
9340
          GType (_, l) | GCompTag (_, l) -> Some (getVarsInGlobal g, l)
 
9341
        | GEnumTag (_, l) | GPragma (Attr("pack", _), l)
 
9342
        | GCompTagDecl (_, l) | GEnumTagDecl (_, l) -> Some ([], l)
 
9343
          (** Move the warning pragmas early
 
9344
        | GPragma(Attr(s, _), l) when hasPrefix "warning" s -> Some ([], l)
 
9345
          *)
 
9346
        | _ -> None (* Does not go with the types *)
 
9347
      in
 
9348
      match varsintype with
 
9349
      None -> variables := g :: !variables
 
9350
    | Some (vl, loc) ->
 
9351
        types :=
 
9352
           (* insert declarations for referred variables ('vl'), before
 
9353
            * the type definition 'g' itself *)
 
9354
           g :: (List.fold_left (fun acc v -> GVarDecl(empty_funspec (),v, loc) :: acc)
 
9355
                                !types vl)
 
9356
  end
 
9357
 
 
9358
 
 
9359
type formatArg =
 
9360
    Fe of exp
 
9361
  | Feo of exp option  (** For array lengths *)
 
9362
  | Fu of unop
 
9363
  | Fb of binop
 
9364
  | Fk of ikind
 
9365
  | FE of exp list (** For arguments in a function call *)
 
9366
  | Ff of (string * typ * attributes) (** For a formal argument *)
 
9367
  | FF of (string * typ * attributes) list (* For formal argument lists *)
 
9368
  | Fva of bool (** For the ellipsis in a function type *)
 
9369
  | Fv of varinfo
 
9370
  | Fl of lval
 
9371
  | Flo of lval option (** For the result of a function call *)
 
9372
  | Fo of offset
 
9373
  | Fc of compinfo
 
9374
  | Fi of instr
 
9375
  | FI of instr list
 
9376
  | Ft of typ
 
9377
  | Fd of int
 
9378
  | Fg of string
 
9379
  | Fs of stmt
 
9380
  | FS of stmt list
 
9381
  | FA of attributes
 
9382
 
 
9383
  | Fp of attrparam
 
9384
  | FP of attrparam list
 
9385
 
 
9386
  | FX of string
 
9387
 
 
9388
let d_formatarg fmt = function
 
9389
    Fe e -> fprintf fmt "Fe(%a)" d_exp e
 
9390
  | Feo None -> fprintf fmt "Feo(None)"
 
9391
  | Feo (Some e) -> fprintf fmt "Feo(%a)" d_exp e
 
9392
  | FE _ -> fprintf fmt "FE()"
 
9393
  | Fk _ik -> fprintf fmt "Fk()"
 
9394
  | Fva b -> fprintf fmt "Fva(%b)" b
 
9395
  | Ff (an, _, _) -> fprintf fmt "Ff(%s)" an
 
9396
  | FF _ -> fprintf fmt "FF(...)"
 
9397
  | FA _ -> fprintf fmt "FA(...)"
 
9398
  | Fu _uo -> fprintf fmt "Fu()"
 
9399
  | Fb _bo -> fprintf fmt "Fb()"
 
9400
  | Fv v -> fprintf fmt "Fv(%s)" v.vname
 
9401
  | Fl l -> fprintf fmt "Fl(%a)" d_lval l
 
9402
  | Flo None -> fprintf fmt "Flo(None)"
 
9403
  | Flo (Some l) -> fprintf fmt "Flo(%a)" d_lval l
 
9404
  | Fo _o -> fprintf fmt "Fo"
 
9405
  | Fc ci -> fprintf fmt "Fc(%s)" ci.cname
 
9406
  | Fi _i -> fprintf fmt "Fi(...)"
 
9407
  | FI _i -> fprintf fmt "FI(...)"
 
9408
  | Ft t -> fprintf fmt "Ft(%a)" d_type t
 
9409
  | Fd n -> fprintf fmt "Fd(%d)" n
 
9410
  | Fg s -> fprintf fmt "Fg(%s)" s
 
9411
  | Fp _ -> fprintf fmt "Fp(...)"
 
9412
  | FP _n -> fprintf fmt "FP(...)"
 
9413
  | Fs _ -> fprintf fmt "FS"
 
9414
  | FS _ -> fprintf fmt "FS"
 
9415
 
 
9416
  | FX _ -> fprintf fmt "FX()"
 
9417
 
 
9418
let pretty_loc fmt kinstr =
 
9419
  let loc = Instr.loc kinstr in
 
9420
  fprintf fmt "Location: %a" d_loc loc
 
9421
 
 
9422
let pretty_loc_simply fmt kinstr =
 
9423
  let loc = Instr.loc kinstr in
 
9424
  fprintf fmt "%a" d_loc loc
 
9425
 
 
9426
let make_temp_logic_var =
 
9427
  let counter = ref 0 in
 
9428
  function ty ->
 
9429
    incr counter;
 
9430
    let name = "__framac_tmp" ^ (string_of_int !counter) in
 
9431
    make_logic_var name ty
 
9432
 
 
9433
let extract_varinfos_from_exp vexp =
 
9434
  let visitor = object
 
9435
    inherit nopCilVisitor
 
9436
    val mutable varinfos = C.VarinfoSet.empty;
 
9437
    method varinfos = varinfos
 
9438
    method vvrbl (symb:varinfo) =
 
9439
      begin
 
9440
        varinfos <- C.VarinfoSet.add symb varinfos;
 
9441
        SkipChildren
 
9442
      end
 
9443
  end
 
9444
  in ignore (visitCilExpr (visitor :> nopCilVisitor) vexp) ;
 
9445
    visitor#varinfos
 
9446
 
 
9447
let extract_varinfos_from_lval vlval =
 
9448
  let visitor = object
 
9449
    inherit nopCilVisitor
 
9450
    val mutable varinfos = C.VarinfoSet.empty;
 
9451
    method varinfos = varinfos
 
9452
    method vvrbl (symb:varinfo) =
 
9453
      begin
 
9454
        varinfos <- C.VarinfoSet.add symb varinfos;
 
9455
        SkipChildren
 
9456
      end
 
9457
  end
 
9458
  in ignore (visitCilLval (visitor :> nopCilVisitor) vlval) ;
 
9459
    visitor#varinfos
 
9460
 
 
9461
let rec free_vars_term bound_vars t = match t.term_node with
 
9462
  | TConst _   | TSizeOf _
 
9463
  | TSizeOfStr _ | TAlignOf _
 
9464
  | Tnull
 
9465
  | Ttype _
 
9466
    -> C.LogicVarSet.empty
 
9467
  | TLval lv
 
9468
  | TAddrOf lv
 
9469
  | TStartOf lv
 
9470
    -> free_vars_lval bound_vars lv
 
9471
  | TSizeOfE t
 
9472
  | TAlignOfE t
 
9473
  | TUnOp (_,t)
 
9474
  | TCastE (_,t)
 
9475
  | Told t
 
9476
  | Tat (t,_)
 
9477
  | Tbase_addr t
 
9478
  | Tblock_length t
 
9479
  | TCoerce (t,_)
 
9480
  | Ttypeof t
 
9481
    -> free_vars_term bound_vars t
 
9482
  | TBinOp (_,t1,t2)
 
9483
  | TCoerceE (t1,t2)
 
9484
  | TUpdate (t1,_,t2)
 
9485
    -> C.LogicVarSet.union
 
9486
      (free_vars_term bound_vars t1)
 
9487
        (free_vars_term bound_vars t2)
 
9488
  | Tif (t1,t2,t3) ->
 
9489
      C.LogicVarSet.union
 
9490
        (free_vars_term bound_vars t1)
 
9491
        (C.LogicVarSet.union
 
9492
           (free_vars_term bound_vars t2)
 
9493
           (free_vars_term bound_vars t3))
 
9494
  | TDataCons(_,t) | Tapp (_,_,t) ->
 
9495
      List.fold_left
 
9496
        (fun acc t -> C.LogicVarSet.union (free_vars_term bound_vars t) acc)
 
9497
        C.LogicVarSet.empty t
 
9498
  | Tlambda(prms,expr) ->
 
9499
      let bound_vars =
 
9500
        List.fold_left (Extlib.swap C.LogicVarSet.add) bound_vars prms
 
9501
      in free_vars_term bound_vars expr
 
9502
  | Ttsets ts -> free_vars_tsets bound_vars ts
 
9503
and free_vars_lval bv (h,o) =
 
9504
   C.LogicVarSet.union (free_vars_lhost bv h) (free_vars_term_offset bv o)
 
9505
and free_vars_lhost bv = function
 
9506
  | TVar log_v -> if C.LogicVarSet.mem log_v bv then C.LogicVarSet.empty else
 
9507
      C.LogicVarSet.singleton log_v
 
9508
  | TResult -> C.LogicVarSet.empty
 
9509
  | TMem t -> free_vars_term bv t
 
9510
and free_vars_term_offset bv = function
 
9511
  | TNoOffset -> C.LogicVarSet.empty
 
9512
  | TField (_,o) -> free_vars_term_offset bv o
 
9513
  | TIndex (t,o) -> C.LogicVarSet.union (free_vars_term bv t) (free_vars_term_offset bv o)
 
9514
 
 
9515
and free_vars_tsets_offset bv = function
 
9516
    TSNoOffset -> C.LogicVarSet.empty
 
9517
  | TSIndex(t,o) ->
 
9518
      C.LogicVarSet.union (free_vars_term bv t) (free_vars_tsets_offset bv o)
 
9519
  | TSRange(i1,i2,o) ->
 
9520
      let fv =
 
9521
        match i1 with
 
9522
            None -> C.LogicVarSet.empty
 
9523
          | Some i -> free_vars_term bv i
 
9524
      in
 
9525
      let fv =
 
9526
        match i2 with
 
9527
            None -> fv
 
9528
          | Some i -> C.LogicVarSet.union fv (free_vars_term bv i)
 
9529
      in C.LogicVarSet.union fv (free_vars_tsets_offset bv o)
 
9530
  | TSField(_,o) -> free_vars_tsets_offset bv o
 
9531
 
 
9532
and free_vars_tsets_elem bv = function
 
9533
    TSLval lv | TSStartOf lv | TSAddrOf lv -> free_vars_tsets_lval bv lv
 
9534
  | TSConst _ -> C.LogicVarSet.empty
 
9535
  | TSAdd_index(t,i) ->
 
9536
      C.LogicVarSet.union (free_vars_tsets_elem bv t) (free_vars_term bv i)
 
9537
  | TSAdd_range(t,i1,i2) ->
 
9538
      let fv = free_vars_tsets_elem bv t in
 
9539
      let fv =
 
9540
        match i1 with
 
9541
            None -> fv
 
9542
          | Some i -> C.LogicVarSet.union fv (free_vars_term bv i)
 
9543
      in (match i2 with
 
9544
              None -> fv
 
9545
            | Some i -> C.LogicVarSet.union fv (free_vars_term bv i))
 
9546
  | TSCastE(_,t) -> free_vars_tsets_elem bv t
 
9547
  | TSat (t,_) -> free_vars_tsets_elem bv t
 
9548
  | TSapp(_,_,args) ->
 
9549
      List.fold_left
 
9550
        (fun set arg -> C.LogicVarSet.union set (free_vars_term bv arg))
 
9551
        C.LogicVarSet.empty args
 
9552
and free_vars_tsets_lval bv (h,o) =
 
9553
  C.LogicVarSet.union (free_vars_tsets_lhost bv h) (free_vars_tsets_offset bv o)
 
9554
 
 
9555
and free_vars_tsets_lhost bv = function
 
9556
    TSVar v when C.LogicVarSet.mem v bv -> C.LogicVarSet.empty
 
9557
  | TSVar v -> C.LogicVarSet.singleton v
 
9558
  | TSResult -> C.LogicVarSet.empty
 
9559
  | TSMem t -> free_vars_tsets_elem bv t
 
9560
 
 
9561
and free_vars_tsets bound_vars = function
 
9562
    TSSingleton t -> free_vars_tsets_elem bound_vars t
 
9563
  | TSEmpty -> C.LogicVarSet.empty
 
9564
  | TSUnion l | TSInter l ->
 
9565
      List.fold_left
 
9566
        (fun acc t -> C.LogicVarSet.union (free_vars_tsets bound_vars t) acc)
 
9567
        C.LogicVarSet.empty l
 
9568
  | TSComprehension(t,q,p) ->
 
9569
      let new_bv =
 
9570
        List.fold_left (fun acc v -> C.LogicVarSet.add v acc) bound_vars q
 
9571
      in
 
9572
      let fv = free_vars_tsets new_bv t in
 
9573
      match p with
 
9574
          None -> fv
 
9575
        | Some p -> C.LogicVarSet.union fv (free_vars_predicate new_bv p)
 
9576
 
 
9577
and free_vars_predicate bound_vars p = match p.content with
 
9578
  | Pfalse | Ptrue -> C.LogicVarSet.empty
 
9579
 
 
9580
  | Papp (_,_,tl) ->
 
9581
      List.fold_left
 
9582
        (fun acc t -> C.LogicVarSet.union (free_vars_term bound_vars t) acc) C.LogicVarSet.empty tl
 
9583
  | Pfresh t -> free_vars_term bound_vars t
 
9584
  | Pvalid(t) -> free_vars_tsets bound_vars t
 
9585
  | Pseparated seps ->
 
9586
      List.fold_left
 
9587
        (fun free_vars tset ->
 
9588
           C.LogicVarSet.union (free_vars_tsets bound_vars tset) free_vars)
 
9589
        C.LogicVarSet.empty seps
 
9590
  | Prel (_,t1,t2)
 
9591
  | Pvalid_index (t1,t2)
 
9592
  | Psubtype (t1,t2)
 
9593
      ->
 
9594
      C.LogicVarSet.union
 
9595
        (free_vars_term bound_vars t1)
 
9596
        (free_vars_term bound_vars t2)
 
9597
  | Pvalid_range (t1,t2,t3) ->
 
9598
      C.LogicVarSet.union
 
9599
        (C.LogicVarSet.union
 
9600
           (free_vars_term bound_vars t1)
 
9601
           (free_vars_term bound_vars t2))
 
9602
        (free_vars_term bound_vars t3)
 
9603
  | Pand (p1,p2)
 
9604
  | Por (p1,p2)
 
9605
  | Pxor (p1,p2)
 
9606
  | Pimplies (p1,p2)
 
9607
  | Piff (p1,p2) ->
 
9608
      C.LogicVarSet.union
 
9609
        (free_vars_predicate bound_vars p1)
 
9610
        (free_vars_predicate bound_vars p2)
 
9611
  | Pnot p
 
9612
  | Pold p
 
9613
  | Pat (p,_)
 
9614
(*  | Pnamed (_,p) *) ->
 
9615
      free_vars_predicate bound_vars p
 
9616
  | Pif (t,p1,p2) ->
 
9617
      C.LogicVarSet.union
 
9618
        (free_vars_term bound_vars t)
 
9619
        (C.LogicVarSet.union
 
9620
           (free_vars_predicate bound_vars p1)
 
9621
           (free_vars_predicate bound_vars p2))
 
9622
  | Plet (log_v, t, p) ->
 
9623
      let new_bv = C.LogicVarSet.add log_v bound_vars in
 
9624
      C.LogicVarSet.union
 
9625
        (free_vars_term new_bv t)
 
9626
        (free_vars_predicate new_bv p)
 
9627
 
 
9628
  | Pforall (lvs,p)
 
9629
  | Pexists (lvs,p) ->
 
9630
      let new_bv= List.fold_left (Extlib.swap C.LogicVarSet.add) bound_vars lvs in
 
9631
      free_vars_predicate new_bv p
 
9632
 
 
9633
let extract_free_logicvars_from_term t =
 
9634
  free_vars_term C.LogicVarSet.empty t
 
9635
 
 
9636
let extract_free_logicvars_from_predicate p =
 
9637
  free_vars_predicate C.LogicVarSet.empty p
 
9638
 
 
9639
let close_predicate p =
 
9640
  let free_vars = free_vars_predicate C.LogicVarSet.empty p in
 
9641
  if C.LogicVarSet.is_empty free_vars then p
 
9642
  else
 
9643
    {name = []; loc = p.loc;
 
9644
    content = Pforall ((C.LogicVarSet.elements free_vars),p)}
 
9645
 
 
9646
class alpha_conv tbl ltbl =
 
9647
object
 
9648
  inherit nopCilVisitor
 
9649
  method vvrbl v =
 
9650
    try
 
9651
      let v' = Hashtbl.find tbl v.vid in ChangeTo v'
 
9652
    with Not_found -> DoChildren
 
9653
  method vlogic_var_use v =
 
9654
    try let v' = Hashtbl.find ltbl v.lv_id in ChangeTo v'
 
9655
    with Not_found -> DoChildren
 
9656
end
 
9657
 
 
9658
let create_alpha_renaming old_args new_args =
 
9659
  let conversion = Hashtbl.create 7 in
 
9660
  let lconversion = Hashtbl.create 7 in
 
9661
  List.iter2 (fun old_vi new_vi ->
 
9662
                Hashtbl.add conversion old_vi.vid new_vi;
 
9663
                match old_vi.vlogic_var_assoc, new_vi.vlogic_var_assoc with
 
9664
                    None, _ -> () (* nothing to convert in logic spec. *)
 
9665
                  | Some old_lv, Some new_lv ->
 
9666
                      Hashtbl.add lconversion old_lv.lv_id new_lv
 
9667
                  | Some old_lv, None ->
 
9668
                      Hashtbl.add lconversion old_lv.lv_id (cvar_to_lvar new_vi)
 
9669
             )
 
9670
    old_args new_args;
 
9671
  new alpha_conv conversion lconversion
 
9672
 
 
9673
(** Returns [true] whenever the type contains only arithmetic types *)
 
9674
let is_fully_arithmetic ty =
 
9675
  not (existsType
 
9676
         (fun typ -> match typ with
 
9677
            | TNamed _
 
9678
            | TComp _
 
9679
            | TArray _ -> ExistsMaybe
 
9680
            | TPtr _ | TBuiltin_va_list _ | TFun _ | TVoid _ -> ExistsTrue
 
9681
            | TEnum _ |TFloat _ | TInt _ ->  ExistsFalse)
 
9682
         ty)
 
9683
 
 
9684
 
 
9685
exception Got of string list
 
9686
let exists_attribute_deep f typ =
 
9687
  let tbl = Hashtbl.create 7 in
 
9688
  let rec visitor l = object
 
9689
    inherit nopCilVisitor
 
9690
    method vattr a =
 
9691
      if f a then raise (Got l);
 
9692
      DoChildren
 
9693
    method vtype t =
 
9694
      begin
 
9695
        match unrollType t with
 
9696
        | TComp (compinfo,_) ->
 
9697
            (try Hashtbl.find tbl compinfo.ckey
 
9698
            with Not_found ->
 
9699
              Hashtbl.add tbl compinfo.ckey () ;
 
9700
              List.iter
 
9701
                (fun finfo -> ignore (visitCilType (visitor (finfo.fname::l)) finfo.ftype))
 
9702
                compinfo.cfields)
 
9703
        | _ -> ()
 
9704
      end;
 
9705
      DoChildren
 
9706
  end
 
9707
  in
 
9708
  try
 
9709
    ignore (visitCilType (visitor []) typ);
 
9710
    None
 
9711
  with Got l -> Some (List.rev l)
 
9712
 
 
9713
let get_status ca =
 
9714
 match ca.annot_content with
 
9715
 | AAssert (_,_,status) -> status
 
9716
 | _ -> {status=Unknown}
 
9717
 
 
9718
(*
 
9719
Local Variables:
 
9720
compile-command: "LC_ALL=C make -C ../.. -j"
 
9721
End:
 
9722
*)