Project

General

Profile

« Previous | Next » 

Revision 1ed1c8b8

Added by Guillaume DAVY almost 3 years ago

Ada: Corrections of some bugs discovered with lustrec-tests

View differences:

src/backends/Ada/ada_backend_ads.ml
135 135
      let ident = (fst instance) in
136 136
      get_substitution m ident submachine, ident, submachine)
137 137
    m.minstances submachines in
138
  let extract_identifier (subst, _, submachine) =
139
    submachine.mname.node_id^"####"^(String.concat "####" (List.map (function (_, typ) -> (asprintf "%a" pp_type typ)) subst))
140
  in
141
  let identifiers = List.map extract_identifier typed_submachines in
142
  let typed_submachines_identified = List.combine identifiers typed_submachines in
143
  let typed_submachines_identified_set = List.fold_left (fun l x -> if List.mem_assoc (fst x) l then l else x::l) [] typed_submachines_identified in
144
  let submachines_set = List.map (function (_, (_, _, machine)) -> machine) typed_submachines_identified_set in
145
  let typed_submachines_set = snd (List.split typed_submachines_identified_set) in
138 146
  let pp_record fmt =
139 147
    pp_state_record_definition fmt (var_list, typed_submachines) in
140 148
  let typed_submachines_filtered =
141
    List.filter (function (l, _, _) -> l != []) typed_submachines in
149
    List.filter (function (l, _, _) -> l != []) typed_submachines_set in
142 150
  let polymorphic_types = find_all_polymorphic_type m in
143 151
  fprintf fmt "@[<v>%a%t%a%a@,  @[<v>@,%a;@,@,%t;@,@,%a;@,@,private@,@,%a%t%a;@,@]@,%a;@.@]"
144 152
    
145 153
    (* Include all the subinstance*)
146
    (Utils.fprintf_list ~sep:";@," pp_with_machine) submachines
147
    (Utils.pp_final_char_if_non_empty ";@,@," submachines)
154
    (Utils.fprintf_list ~sep:";@," pp_with_machine) submachines_set
155
    (Utils.pp_final_char_if_non_empty ";@,@," submachines_set)
148 156
    
149 157
    pp_generic polymorphic_types
150 158
    
src/backends/Ada/ada_backend_common.ml
17 17
    underscore and must not contain a double underscore
18 18
   @param var name to be cleaned*)
19 19
let pp_clean_ada_identifier fmt name =
20
  let reserved_words = ["out"] in
20
  let reserved_words = ["abort"; "else"; "new"; "return";
21
                        "abs"; "elsif"; "not"; "reverse"; "abstract"; "end";
22
                        "null"; "accept"; "entry"; "select"; "access";
23
                        "exception"; "of"; "separate"; "aliased"; "exit";
24
                        "or"; "some"; "all"; "others"; "subtype"; "and";
25
                        "for"; "out"; "synchronized"; "array"; "function";
26
                        "overriding"; "at"; "tagged"; "generic"; "package";
27
                        "task"; "begin"; "goto"; "pragma"; "terminate";
28
                        "body"; "private"; "then"; "if"; "procedure"; "type";
29
                        "case"; "in"; "protected"; "constant"; "interface";
30
                        "until"; "is"; "raise"; "use"; "declare"; "	range";
31
                        "delay"; "limited"; "record"; "when"; "delta"; "loop";
32
                        "rem"; "while"; "digits"; "renames"; "with"; "do";
33
                        "mod"; "requeue"; "xor"] in
21 34
  let base_size = String.length name in
22 35
  assert(base_size > 0);
23 36
  let rec remove_double_underscore s = function
......
26 39
        remove_double_underscore (sprintf "%s%s" (String.sub s 0 i) (String.sub s (i+1) (String.length s-i-1))) i
27 40
    | i -> remove_double_underscore s (i+1)
28 41
  in
42
  let name = if String.get name (base_size-1) == '_' then name^"ada" else name in
29 43
  let name = remove_double_underscore name 0 in
30 44
  let prefix = if String.length name != base_size
31 45
                  || String.get name 0 == '_' 
32
                  || List.exists (String.equal name) reserved_words then
46
                  || List.exists (String.equal (String.lowercase_ascii name)) reserved_words then
33 47
                  "ada"
34 48
               else
35 49
                  ""
......
110 124
   @param fmt the formater to print on
111 125
**)
112 126
let pp_main_procedure_name fmt =
113
  fprintf fmt "main"
127
  fprintf fmt "ada_main"
114 128

  
115 129
(** Print a with statement to include a package.
116 130
   @param fmt the formater to print on
......
580 594
   **)
581 595
  let pp_ada_tag fmt t =
582 596
    pp_print_string fmt
583
      (if t = tag_true then "True" else if t = tag_false then "Flase" else t)
597
      (if t = tag_true then "True" else if t = tag_false then "False" else t)
584 598

  
585 599
  (** Printing function for machine type constants. For the moment,
586 600
      arrays are not supported.
......
661 675
    | "equi", [v1; v2] ->
662 676
      Format.fprintf fmt "((not %a) = (not %a))" pp_value v1 pp_value v2
663 677
    | "xor", [v1; v2]  ->
664
      Format.fprintf fmt "((not %a) \\= (not %a))" pp_value v1 pp_value v2
678
      Format.fprintf fmt "((not %a) /= (not %a))" pp_value v1 pp_value v2
665 679
    | "/", [v1; v2]    -> pp_div pp_value v1 v2 fmt
680
    | "&&", [v1; v2]    ->
681
      Format.fprintf fmt "(%a %s %a)" pp_value v1 "and then" pp_value v2
682
    | "||", [v1; v2]    ->
683
      Format.fprintf fmt "(%a %s %a)" pp_value v1 "or else" pp_value v2
684
    | "!=", [v1; v2]    ->
685
      Format.fprintf fmt "(%a %s %a)" pp_value v1 "/=" pp_value v2
666 686
    | op, [v1; v2]     ->
667 687
      Format.fprintf fmt "(%a %s %a)" pp_value v1 op pp_value v2
668 688
    | fun_name, _      ->

Also available in: Unified diff