(**************************************************************************)
(*                                                                        *)
(*  This file is part of Frama-C.                                         *)
(*                                                                        *)
(*  Copyright (C) 2007-2020                                               *)
(*    CEA   (Commissariat à l'énergie atomique et aux énergies            *)
(*           alternatives)                                                *)
(*    INRIA (Institut National de Recherche en Informatique et en         *)
(*           Automatique)                                                 *)
(*                                                                        *)
(*  you can redistribute it and/or modify it under the terms of the GNU   *)
(*  Lesser General Public License as published by the Free Software       *)
(*  Foundation, version 2.1.                                              *)
(*                                                                        *)
(*  It is distributed in the hope that it will be useful,                 *)
(*  but WITHOUT ANY WARRANTY; without even the implied warranty of        *)
(*  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the         *)
(*  GNU Lesser General Public License for more details.                   *)
(*                                                                        *)
(*  See the GNU Lesser General Public License version 2.1                 *)
(*  for more details (enclosed in the file licenses/LGPLv2.1).            *)
(*                                                                        *)
(**************************************************************************)

open Format
open Pretty_utils
open Logic_ptree

let print_array_size fmt = function
  | ASidentifier s
  | ASinteger s -> pp_print_string fmt s
  | ASnone -> ()

let print_constant fmt = function
  | IntConstant s -> pp_print_string fmt s
  | FloatConstant s -> pp_print_string fmt s
  | StringConstant s -> fprintf fmt "\"%s\"" s
  | WStringConstant s -> fprintf fmt "\"%s\"" s

let rec print_logic_type name fmt typ =
  let pname = match name with
    | Some d -> (fun fmt -> fprintf fmt "@ %t" d)
    | None -> (fun _ -> ())
  in
  match typ with
  | LTattribute (t,attr) ->
    let pname fmt =
      fprintf fmt "%a" Cil_printer.pp_attribute attr
    in
    print_logic_type (Some pname) fmt t
  | LTvoid -> fprintf fmt "void%t" pname
  | LTinteger ->
    fprintf fmt "%s%t"
      (if Kernel.Unicode.get () then Utf8_logic.integer else "integer")
      pname
  | LTreal ->
    fprintf fmt "%s%t"
      (if Kernel.Unicode.get () then Utf8_logic.real else "real")
      pname
  | LTint i -> fprintf fmt "%a%t" Cil_printer.pp_ikind i pname
  | LTfloat f -> fprintf fmt "%a%t" Cil_printer.pp_fkind f pname
  | LTarray (t,c) ->
    let pname fmt =
      fprintf fmt "%t[@[%a@]]" pname print_array_size c
    in
    print_logic_type (Some pname) fmt t
  | LTpointer t ->
    let needs_paren = match t with LTarray _ -> true | _ -> false in
    let pname fmt =
      Format.fprintf fmt "%a*%t%a"
        (pp_cond needs_paren) "(" pname (pp_cond needs_paren) ")"
    in
    print_logic_type (Some pname) fmt t
  | LTunion s -> fprintf fmt "union@ %s%t" s pname
  | LTenum s -> fprintf fmt "enum@ %s%t" s pname
  | LTstruct s -> fprintf fmt "struct@ %s%t" s pname
  | LTnamed (s,l) ->
    fprintf fmt "%s%a%t"
      s
      (pp_list ~pre:"<@[" ~sep:",@ " ~suf:"@]>"
         (print_logic_type None)) l
      pname
  | LTarrow(args,ret) ->
    let pname fmt =
      fprintf fmt "%t(@[%a@])" pname
        (pp_list ~sep:",@ " (print_logic_type None)) args
    in
    print_logic_type (Some pname) fmt ret

let print_typed_ident fmt (t,s) =
  print_logic_type (Some (fun fmt -> pp_print_string fmt s)) fmt t

let print_quantifiers fmt l = pp_list ~sep:",@ " print_typed_ident fmt l

let get_relation_string = function
    Lt -> "<" | Gt -> ">" | Le -> "<=" | Ge -> ">=" | Eq -> "==" | Neq -> "!="

let get_binop_string = function
    Badd -> "+"
  | Bsub -> "-"
  | Bmul -> "*"
  | Bdiv -> "/"
  | Bmod -> "%"
  | Bbw_and -> "&"
  | Bbw_or -> "|"
  | Bbw_xor -> "^"
  | Blshift -> "<<"
  | Brshift -> ">>"

let get_unop_string = function
    Uminus -> "-" | Ustar -> "*" | Uamp -> "&" | Ubw_not -> "~"

let getParenthLevel e =
  match e.lexpr_node with
  | PLnamed _ -> 95
  | PLlambda _ | PLlet _ | PLrange _ -> 90
  | PLforall _ | PLexists _ -> 87
  | PLimplies _ | PLiff _ -> 85
  | PLand _ | PLor _ | PLxor _ -> 80
  | PLif _ -> 77
  | PLbinop (_,(Bbw_and | Bbw_or | Bbw_xor),_) -> 75
  | PLrepeat _ -> 72
  | PLrel _ -> 70
  | PLbinop (_,(Badd|Bsub|Blshift|Brshift),_) -> 60
  | PLbinop (_,(Bmul|Bdiv|Bmod),_) -> 40
  | PLunop ((Uamp|Uminus|Ubw_not),_) | PLcast _ | PLnot _ -> 30
  | PLunop (Ustar,_) | PLdot _ | PLarrow _ | PLarrget _
  | PLsizeof _ | PLsizeofE _ -> 20
  | PLapp _ | PLold _ | PLat _
  | PLoffset _ | PLbase_addr _ | PLblock_length _
  | PLupdate _  | PLinitField _ | PLinitIndex _
  | PLvalid _ | PLvalid_read _ | PLobject_pointer _ | PLvalid_function _
  | PLinitialized _ | PLdangling _
  | PLallocable _ | PLfreeable _ | PLfresh _
  | PLseparated _ | PLunion _ | PLinter _ -> 10
  | PLvar _ | PLconstant _ | PLresult | PLnull | PLtypeof _ | PLtype _
  | PLfalse | PLtrue | PLcomprehension _ | PLempty | PLset _ | PLlist _ -> 0

let rec print_path_elt fmt = function
  | PLpathField s -> fprintf fmt ".%s" s
  | PLpathIndex i -> fprintf fmt "[@[%a@]]" print_lexpr i

and print_path_val fmt (path, v) =
  match v with
  | PLupdateTerm e ->
    fprintf fmt "@[%a@ =@ %a@]"
      (pp_list ~sep:"@;" print_path_elt) path print_lexpr e
  | PLupdateCont path_val_list ->
    fprintf fmt "{ \\with %a@ }"
      (pp_list ~sep:",@ " print_path_val) path_val_list

and print_init_index fmt (i,v) =
  print_path_val fmt ([PLpathIndex i], PLupdateTerm v)

and print_init_field fmt (s,v) =
  print_path_val fmt ([PLpathField s], PLupdateTerm v)

and print_lexpr fmt e = print_lexpr_level 100 fmt e

and print_label_1 fmt l =
  match l with
  | None -> ()
  | Some s -> fprintf fmt "{%s}" s

and print_label_2 fmt l =
  match l with
  | None -> ()
  | Some (s1,s2) -> fprintf fmt "{%s,%s}" s1 s2

and print_lexpr_level n fmt e =
  let n' = getParenthLevel e in
  let print_lexpr fmt e = print_lexpr_level n' fmt e in
  let print_lexpr_plain fmt e = print_lexpr_level 100 fmt e in
  let aux fmt e =
    match e.lexpr_node with
      PLvar s -> pp_print_string fmt s
    | PLapp(s,tv,args) ->
      fprintf fmt "%s@;%a@;(@[%a@])"
        s
        (pp_list ~pre:"<@[" ~sep:",@ " ~suf:"@]>" pp_print_string) tv
        (pp_list ~sep:",@ " print_lexpr_plain) args
    | PLlambda (quant,e) ->
      fprintf fmt "@[<2>\\lambda@ @[%a@];@ %a@]"
        print_quantifiers quant print_lexpr e
    | PLlet (n,def,body) ->
      fprintf fmt "@[@[<2>\\let@ %s@ =@ %a;@]@\n%a@]"
        n print_lexpr def  print_lexpr body
    | PLconstant c -> print_constant fmt c
    | PLunop(op,e) -> fprintf fmt "%s%a" (get_unop_string op) print_lexpr e
    | PLbinop(e1,op,e2) ->
      fprintf fmt "%a@ %s@ %a"
        print_lexpr e1 (get_binop_string op) print_lexpr e2
    | PLdot(e,f) -> fprintf fmt "%a.%s" print_lexpr e f
    | PLarrow(e,f) -> fprintf fmt "%a->%s" print_lexpr e f
    | PLarrget(b,i) ->
      fprintf fmt "%a[@;@[%a@]@;]" print_lexpr b print_lexpr i
    | PLlist(args) ->
      fprintf fmt "[@[%a@]]"
        (pp_list ~sep:",@ " print_lexpr_plain) args
    | PLrepeat(e1,e2) ->
      fprintf fmt "%a@ *^@ %a"
        print_lexpr e1 print_lexpr e2
    | PLold(e) -> fprintf fmt "\\old(@;@[%a@]@;)" print_lexpr_plain e
    | PLat(e,s) -> fprintf fmt "\\at(@;@[%a,@ %s@]@;)" print_lexpr_plain e s
    | PLbase_addr (l,e) -> fprintf fmt "\\base_addr%a(@;@[%a@])" print_label_1 l print_lexpr_plain e
    | PLblock_length (l,e) ->
      fprintf fmt "\\block_length%a(@;@[%a@])" print_label_1 l print_lexpr_plain e
    | PLoffset (l,e) ->
      fprintf fmt "\\offset%a(@;@[%a@])" print_label_1 l print_lexpr_plain e
    | PLresult -> pp_print_string fmt "\\result"
    | PLnull -> pp_print_string fmt "\\null"
    | PLcast (t,e) -> fprintf fmt "(@[%a@])@;%a"
                        (print_logic_type None) t print_lexpr e
    | PLrange(e1,e2) ->
      fprintf fmt "%a@;..@;%a"
        (pp_opt print_lexpr) e1 (pp_opt print_lexpr) e2
    | PLsizeof t -> fprintf fmt "sizeof(@;@[%a@]@;)" (print_logic_type None) t
    | PLsizeofE e -> fprintf fmt "sizeof(@;@[%a@]@;)" print_lexpr_plain e
    | PLupdate(e1,path,e2) ->
      fprintf fmt "{@ @[%a@ \\with@ %a@]}"
        print_lexpr_plain e1 print_path_val (path, e2)
    | PLinitField(init_field_list) ->
      fprintf fmt "{@ %a@}"
        (pp_list ~sep:",@ " print_init_field) init_field_list
    | PLinitIndex(init_index_list) ->
      fprintf fmt "{@ %a@}"
        (pp_list ~sep:",@ " print_init_index) init_index_list
    | PLtypeof e -> fprintf fmt "typeof(@;@[%a@]@;)" print_lexpr_plain e
    | PLtype t -> fprintf fmt "\\type(@;@[%a@]@;" (print_logic_type None) t
    | PLfalse -> pp_print_string fmt "\\false"
    | PLtrue -> pp_print_string fmt "\\true"
    | PLrel (e1,rel,e2) ->
      fprintf fmt "%a@ %s@ %a"
        print_lexpr e1 (get_relation_string rel) print_lexpr e2
    | PLand(e1,e2) -> fprintf fmt "%a@ &&@ %a" print_lexpr e1 print_lexpr e2
    | PLor(e1,e2) -> fprintf fmt "%a@ ||@ %a" print_lexpr e1 print_lexpr e2
    | PLxor(e1,e2) -> fprintf fmt "%a@ ^^@ %a" print_lexpr e1 print_lexpr e2
    | PLimplies(e1,e2) ->
      fprintf fmt "%a@ ==>@ %a" print_lexpr e1 print_lexpr e2
    | PLiff(e1,e2) ->
      fprintf fmt "%a@ <==>@ %a" print_lexpr e1 print_lexpr e2
    | PLnot e -> fprintf fmt "!@;%a" print_lexpr e
    | PLif (e1,e2,e3) ->
      fprintf fmt "%a@ ?@ %a@ :@ %a"
        print_lexpr e1 print_lexpr e2 print_lexpr e3
    | PLforall(q,e) ->
      fprintf fmt "@[\\forall@ @[%a@];@ %a@]"
        print_quantifiers q print_lexpr e
    | PLexists(q,e) ->
      fprintf fmt "@[\\exists@ @[%a@];@ %a@]"
        print_quantifiers q print_lexpr e
    | PLvalid (l,e) ->
      fprintf fmt "\\valid%a(@;@[%a@]@;)" print_label_1 l print_lexpr_plain e
    | PLvalid_read (l,e) ->
      fprintf fmt "\\valid_read%a(@;@[%a@]@;)" print_label_1 l print_lexpr_plain e
    | PLobject_pointer (l,e) ->
      fprintf fmt "\\object_pointer%a(@;@[%a@]@;)" print_label_1 l print_lexpr_plain e
    | PLvalid_function e ->
      fprintf fmt "\\valid_function(@;@[%a@]@;)" print_lexpr_plain e
    | PLinitialized (l,e) ->
      fprintf fmt "\\initialized%a(@;@[%a@]@;)" print_label_1 l print_lexpr_plain e
    | PLdangling (l,e) ->
      fprintf fmt "\\dangling%a(@;@[%a@]@;)"
        print_label_1 l print_lexpr_plain e
    | PLseparated l ->
      fprintf fmt "\\separated(@;@[%a@]@;)"
        (pp_list ~sep:",@ " print_lexpr_plain) l
    | PLfreeable (l,e) ->
      fprintf fmt "\\freeable%a(@;@[%a@]@;)" print_label_1 l print_lexpr_plain e
    | PLallocable (l,e) ->
      fprintf fmt "\\allocable%a(@;@[%a@]@;)" print_label_1 l print_lexpr_plain e
    | PLfresh (l2,e1,e2) ->
      fprintf fmt "\\fresh%a(@;@[%a@],@[%a@]@;)" print_label_2 l2 print_lexpr_plain e1 print_lexpr_plain e2
    | PLnamed(s,e) -> fprintf fmt "%s:@ %a" s print_lexpr e
    | PLcomprehension(e,q,p) ->
      fprintf fmt "{@ @[%a;@ %a%a@]@ }"
        print_lexpr e print_quantifiers q
        (pp_opt ~pre:"@ |@ " print_lexpr) p
    | PLset l ->
      fprintf fmt "{@ @[%a@]@ }"
        (pp_list ~pre:"@;@[" ~sep:",@ " ~suf:"@]@;" print_lexpr_plain) l
    | PLempty -> pp_print_string fmt "\\empty"
    | PLunion l->
      fprintf fmt "\\union(%a)"
        (pp_list ~pre:"@;@[" ~sep:",@ " ~suf:"@]@;" print_lexpr_plain) l
    | PLinter l->
      fprintf fmt "\\inter(%a)"
        (pp_list ~pre:"@;@[" ~sep:",@ " ~suf:"@]@;" print_lexpr_plain) l
  in
  if n <= n' then fprintf fmt "(@[%a@])" aux e else aux fmt e

let print_typedef fmt = function
  | TDsum l ->
    let print_const fmt (s,args) =
      fprintf fmt "%s%a" s
        (pp_list ~pre:"@ (@[" ~sep:",@ " ~suf:"@])"
           (print_logic_type None))
        args
    in
    pp_list ~sep:"@ |@ " print_const fmt l
  | TDsyn t -> print_logic_type None fmt t

let print_type_annot fmt ty =
  fprintf fmt "@[type@ invariant@ %s(@;@[%a@ %s]@;)@ =@ %a;@]"
    ty.inv_name (print_logic_type None) ty.this_type ty.this_name
    print_lexpr ty.inv

let print_model_annot fmt ty =
  fprintf fmt "@[model@ %a {@;@[%a@ %s]@;}@ @]"
    (print_logic_type None) ty.model_for_type
    (print_logic_type None) ty.model_type
    ty.model_name

let rec print_extended_decl fmt d =
  let aux fmt d = print_extended_decl fmt d.extended_node in
  match d with
  | Ext_lexpr(name,d) ->
    fprintf fmt "@[<2>%s@ %a@]" name (pp_list ~sep:",@ " print_lexpr) d
  | Ext_extension(name,id,d) ->
    fprintf fmt "@[<2>%s@ %s@ {@\n%a@]@\n}" name id
      (pp_list ~sep:"@\n" aux) d

let rec print_decl fmt d =
  match d.decl_node with
  | LDlogic_def(name,labels,tvar,rt,prms,body) ->
    fprintf fmt "@[<2>logic@ %a@ %s%a%a%a@ =@ %a;@]"
      (print_logic_type None) rt name
      (pp_list ~pre:"{@[" ~sep:",@ " ~suf:"@]}" pp_print_string) labels
      (pp_list ~pre:"<@[" ~sep:",@ " ~suf:"@>}" pp_print_string) tvar
      (pp_list ~pre:"(@[" ~sep:",@ " ~suf:"@])" print_typed_ident) prms
      print_lexpr body
  | LDlogic_reads(name,labels,tvar,rt,prms,reads) ->
    fprintf fmt "@[<2>logic@ %a@ %s%a%a%a@ =@ %a;@]"
      (print_logic_type None) rt name
      (pp_list ~pre:"{@[" ~sep:",@ " ~suf:"@]}" pp_print_string) labels
      (pp_list ~pre:"<@[" ~sep:",@ " ~suf:"@>}" pp_print_string) tvar
      (pp_list ~pre:"(@[" ~sep:",@ " ~suf:"@])" print_typed_ident) prms
      (pp_opt ~pre:"@[<2>reads@ " (pp_list ~sep:",@ " print_lexpr)) reads
  | LDtype(name,tvar,def) ->
    fprintf fmt "@[<2>type@ %s%a%a;@]" name
      (pp_list ~pre:"<@[" ~sep:",@ " ~suf:"@>}" pp_print_string) tvar
      (pp_opt ~pre:"@ =@ " print_typedef) def
  | LDpredicate_reads(name,labels,tvar,prms,reads) ->
    fprintf fmt "@[<2>predicate@ %s%a%a%a@ =@ %a;@]" name
      (pp_list ~pre:"{@[" ~sep:",@ " ~suf:"@]}" pp_print_string) labels
      (pp_list ~pre:"<@[" ~sep:",@ " ~suf:"@>}" pp_print_string) tvar
      (pp_list ~pre:"(@[" ~sep:",@ " ~suf:"@])" print_typed_ident) prms
      (pp_opt ~pre:"@[<2>reads@ " (pp_list ~sep:",@ " print_lexpr)) reads
  | LDpredicate_def(name,labels,tvar,prms,body) ->
    fprintf fmt "@[<2>predicate@ %s%a%a%a@ =@ %a;@]" name
      (pp_list ~pre:"{@[" ~sep:",@ " ~suf:"@]}" pp_print_string) labels
      (pp_list ~pre:"<@[" ~sep:",@ " ~suf:"@>}" pp_print_string) tvar
      (pp_list ~pre:"(@[" ~sep:",@ " ~suf:"@])" print_typed_ident) prms
      print_lexpr body
  | LDinductive_def(name,labels,tvar,prms,cases) ->
    let print_case fmt (name,labels,tvar,body) =
      fprintf fmt "@[<2>case@ %s%a%a:@ %a;@]" name
        (pp_list ~pre:"{@[" ~sep:",@ " ~suf:"@]}" pp_print_string) labels
        (pp_list ~pre:"<@[" ~sep:",@ " ~suf:"@>}" pp_print_string) tvar
        print_lexpr body
    in
    fprintf fmt "@[<2>inductive@ %s%a%a@;(%a)@ {@\n%a@]@\n}" name
      (pp_list ~pre:"{@[" ~sep:",@ " ~suf:"@]}" pp_print_string) labels
      (pp_list ~pre:"<@[" ~sep:",@ " ~suf:"@>}" pp_print_string) tvar
      (pp_list ~sep:",@ " print_typed_ident) prms
      (pp_list ~sep:"@\n" print_case) cases
  | LDlemma(name,is_axiom,labels,tvar,body) ->
    fprintf fmt "@[<2>%s%a@ %s%a%a:@ %a;@]"
      (if body.tp_only_check then "check " else "")
      (pp_cond ~pr_false:"lemma" is_axiom) "axiom" name
      (pp_list ~pre:"{@[" ~sep:",@ " ~suf:"@]}" pp_print_string) labels
      (pp_list ~pre:"<@[" ~sep:",@ " ~suf:"@>}" pp_print_string) tvar
      print_lexpr body.tp_statement
  | LDaxiomatic (s,d) ->
    fprintf fmt "@[<2>axiomatic@ %s@ {@\n%a@]@\n}" s
      (pp_list ~sep:"@\n" print_decl) d
  | LDinvariant (s,e) ->
    fprintf fmt "@[<2>invariant@ %s:@ %a;@]" s print_lexpr e
  | LDtype_annot ty -> print_type_annot fmt ty
  | LDmodel_annot ty -> print_model_annot fmt ty
  | LDvolatile(tsets,(read,write)) ->
    fprintf fmt "@[<2>volatile@ %a%a%a;@]"
      (pp_list ~pre:"@[" ~sep:",@ " ~suf:"@]" print_lexpr) tsets
      (pp_opt ~pre:"@ reads@ " pp_print_string) read
      (pp_opt ~pre:"@ writes@ " pp_print_string) write
  | LDextended d -> print_extended_decl fmt d

let print_deps fmt deps =
  match deps with
    FromAny -> ()
  | From l ->
    pp_list ~pre:"@ @[<2>\\from@ " ~sep:",@ " ~suf:"@]" print_lexpr fmt l

let print_assigns fmt a =
  match a with
    WritesAny -> ()
  | Writes l ->
    pp_list ~pre:"" ~sep:"" ~suf:""
      (fun fmt (loc,deps) ->
         fprintf fmt "@\nassigns@ %a%a;"
           print_lexpr loc
           print_deps deps)
      fmt l

let print_allocation ~isloop fmt fa =
  match fa with
  | FreeAllocAny -> ()
  | FreeAlloc([],[]) ->
    let prefix = if isloop then "loop " else "" in
    fprintf fmt "@\n%sallocates@ \\nothing;" prefix
  | FreeAlloc(f,a) ->
    let prefix = if isloop then "loop " else "" in
    let pFreeAlloc kw fmt af =
      match af with
      | [] -> ()
      | _ -> fprintf fmt "@\n%s%s@ %a;" prefix kw (pp_list ~sep:",@ " print_lexpr) a
    in fprintf fmt "%a%a" (pFreeAlloc "frees") f (pFreeAlloc "allocates") a

let print_clause name fmt e = fprintf fmt "@\n%s@ %a;" name print_lexpr e

let print_tp_clause name fmt e =
  let name = if e.tp_only_check then "check " ^ name else name in
  print_clause name fmt e.tp_statement

let print_post fmt (k,e) =
  print_tp_clause (Cil_printer.get_termination_kind_name k) fmt e

let print_behavior fmt bhv =
  fprintf fmt "@[<2>behavior@ %s:%a%a%a%a%a@]"
    bhv.b_name
    (pp_list ~pre:"" ~suf:"" (print_clause "assumes")) bhv.b_assumes
    (pp_list ~pre:"" ~suf:"" (print_tp_clause "requires")) bhv.b_requires
    (pp_list ~pre:"" ~suf:"" print_post) bhv.b_post_cond
    (print_allocation ~isloop:false) bhv.b_allocation
    print_assigns bhv.b_assigns
(* TODO: prints extensions *)

let print_variant fmt (v,cmp) =
  fprintf fmt "%a%a;" print_lexpr v
    (pp_opt ~pre:"@ for@ " pp_print_string) cmp

let print_spec fmt spec =
  fprintf fmt "@[%a%a%a%a%a@]"
    (pp_list ~sep:"@\n" ~suf:"@\n" print_behavior) spec.spec_behavior
    (pp_opt ~pre:"decreases@ " ~suf:"@\n" print_variant) spec.spec_variant
    (pp_opt ~pre:"terminates@ " ~suf:"@\n" print_lexpr) spec.spec_terminates
    (pp_list ~pre:"complete@ behaviors@ "
       ~sep:"@\n" ~suf:"@\n" (pp_list ~sep:",@ " pp_print_string))
    spec.spec_complete_behaviors
    (pp_list ~pre:"disjoint@ behaviors@ "
       ~sep:"@\n" ~suf:"@\n" (pp_list ~sep:",@ " pp_print_string))
    spec.spec_disjoint_behaviors

let print_loop_pragma fmt p =
  match p with
    Unroll_specs l -> fprintf fmt "UNROLL@ %a" (pp_list ~sep:",@ " print_lexpr) l
  | Widen_hints l ->
    fprintf fmt "WIDEN_HINTS@ %a" (pp_list ~sep:",@ " print_lexpr) l
  | Widen_variables l ->
    fprintf fmt "WIDEN_VARIABLES@ %a" (pp_list ~sep:",@ " print_lexpr) l

let print_slice_pragma fmt p =
  match p with
  | SPexpr e -> fprintf fmt "expr@ %a" print_lexpr e
  | SPctrl -> pp_print_string fmt "ctrl"
  | SPstmt -> pp_print_string fmt "stmt"

let print_impact_pragma fmt p =
  match p with
  | IPexpr e -> fprintf fmt "expr@ %a" print_lexpr e
  | IPstmt -> pp_print_string fmt "stmt"

let print_pragma fmt p =
  match p with
    Loop_pragma p -> fprintf fmt "loop@ pragma@ %a;" print_loop_pragma p
  | Slice_pragma p -> fprintf fmt "slice@ pragma@ %a;" print_slice_pragma p
  | Impact_pragma p -> fprintf fmt "impact@ pragma@ %a;" print_impact_pragma p

let print_extension fmt (name, ext) =
  fprintf fmt "%s %a" name (pp_list ~sep:",@ " print_lexpr) ext

let print_code_annot fmt ca =
  let print_behaviors fmt bhvs =
    (pp_list ~pre:"for@ " ~sep:",@ " ~suf:":@ " pp_print_string) fmt bhvs
  in
  match ca with
    AAssert(bhvs,e) ->
    fprintf fmt "%a%s@ %a;"
      print_behaviors bhvs
      (if e.tp_only_check then "check" else "assert")
      print_lexpr e.tp_statement
  | AStmtSpec (bhvs,s) ->
    fprintf fmt "%a%a"
      print_behaviors bhvs
      print_spec s
  | AInvariant (bhvs,loop,e) ->
    fprintf fmt "%a%a%ainvariant@ %a;"
      print_behaviors bhvs
      (pp_cond e.tp_only_check) "check @"
      (pp_cond loop) "loop@ "
      print_lexpr e.tp_statement
  | AVariant e -> fprintf fmt "loop@ variant@ %a;" print_variant e
  | AAssigns (bhvs,a) ->
    fprintf fmt "%aloop@ %a" print_behaviors bhvs print_assigns a
  | AAllocation (bhvs,fa) ->
    fprintf fmt "%a%a" print_behaviors bhvs (print_allocation ~isloop:true) fa
  | APragma p -> print_pragma fmt p
  | AExtended (bhvs, is_loop, e) ->
    fprintf fmt "%a%s%a"
      print_behaviors bhvs
      (if is_loop then " loop " else "")
      print_extension e
(*
Local Variables:
compile-command: "make -C ../../.."
End:
*)
