Project

General

Profile

« Previous | Next » 

Revision 525eebd1

Added by Guillaume DAVY about 4 years ago

Ada: Correct branch exporting to handle boolean match(using an ada if)

View differences:

src/backends/Ada/ada_backend_adb.ml
93 93 
    in
94 94 
    (* Print a when branch of a case *)
95 95 
    let pp_when fmt (cond, instrs) =
96 
      fprintf fmt "when %s =>@,  @[<v>%a@]"
97 
        cond
98 
        (Utils.fprintf_list ~sep:";@," pp_instr) instrs
96 
      fprintf fmt "when %s =>@,%a" cond (pp_block pp_instr) instrs
99 97 
    in
100 98 
    (* Print a case *)
101 
    let pp_case fmt (g, hl) = fprintf fmt "case %a is@,  @[<v>%a;@]@,end case"
102 
      (pp_value machine) g
103 
      (Utils.fprintf_list ~sep:";@," pp_when) hl
99 
    let pp_case fmt (g, hl) =
100 
      fprintf fmt "case %a is@,%aend case"
101 
        (pp_value machine) g
102 
        (pp_block pp_when) hl
103 
    in
104 
    (* Print a if *)
105 
    (* If neg is true the we must test for the negation of the condition. It
106 
       first check that we don't have a negation and a else case, if so it
107 
       inverses the two branch and remove the negation doing a recursive
108 
       call. *)
109 
    let rec pp_if neg fmt (g, instrs1, instrs2) =
110 
      match neg, instrs2 with
111 
        | true, Some x -> pp_if false fmt (g, x, Some instrs1)
112 
        | _ ->
113 
          let pp_cond =
114 
            if neg then
115 
              fun fmt x -> fprintf fmt "! (%a)" (pp_value machine) x
116 
            else
117 
              pp_value machine
118 
          in
119 
          let pp_else = match instrs2 with
120 
            | None -> fun fmt -> fprintf fmt ""
121 
            | Some i2 -> fun fmt ->
122 
                fprintf fmt "else@,%a" (pp_block pp_instr) i2
123 
          in
124 
          fprintf fmt "if %a then@,%a%tend if"
125 
            pp_cond g
126 
            (pp_block pp_instr) instrs1
127 
            pp_else
104 128 
    in
105 129 
    match get_instr_desc instr with
106 130 
      (* no reset *)
......
126 150 
            fmt
127 151 
            (i, Some (pp_args vl il))
128 152 
      | MBranch (_, []) -> assert false
153 
      | MBranch (g, (c1, i1)::tl) when c1=tag_false || c1=tag_true ->
154 
          let neg = c1=tag_false in
155 
          let other = match tl with
156 
            | []         -> None
157 
            | [(c2, i2)] -> Some i2
158 
            | _          -> assert false
159 
          in
160 
          pp_if neg fmt (g, i1, other)
129 161 
      | MBranch (g, hl) -> pp_case fmt (g, hl)
130 162 
      | MComment s  ->
131 163 
          let lines = String.split_on_char '\n' s in
src/backends/Ada/ada_backend_common.ml
502 502 
  assert (not (String.contains s '\n'));
503 503 
  fprintf fmt "-- %s@," s
504 504 

  		




  505
  
  
    
(* Functions which computes the substitution for polymorphic type *)


  		




  506
  505
  
    

  		




  
  506
  
    
(* Functions which computes the substitution for polymorphic type *)


  		




  507
  507
  
    

  		




  508
  508
  
    
(** Check if a submachine is statefull.


  		




  509
  509
  
    
    @param submachine a submachine


  		




  ......




  640
  640
  
    

  		




  641
  641
  
    
(* Procedure pretty print functions *)


  		




  642
  642
  
    

  		




  
  643
  
    
let pp_block pp_item fmt items =


  		




  
  644
  
    
  fprintf fmt "  @[<v>%a%t@]@,"


  		




  
  645
  
    
    (Utils.fprintf_list ~sep:";@," pp_item) items


  		




  
  646
  
    
    (Utils.pp_final_char_if_non_empty ";" items)


  		




  
  647
  
    

  		




  643
  648
  
    
(** Print the definition of a procedure


  		




  644
  649
  
    
   @param pp_name the procedure name printer


  		




  645
  650
  
    
   @param pp_prototype the prototype printer


  		




  ......




  650
  655
  
    
   @param instrs instructions list


  		




  651
  656
  
    
**)


  		




  652
  657
  
    
let pp_procedure_definition pp_name pp_prototype pp_local pp_instr fmt (locals, instrs) =


  		




  653
  
  
    
  fprintf fmt "@[<v>%t is%t@[<v>%a%t@]@,begin@,  @[<v>%a%t@]@,end %t@]"


  		




  
  658
  
    
  fprintf fmt "@[<v>%t is@,%abegin@,%aend %t@]"


  		




  654
  659
  
    
    pp_prototype


  		




  655
  
  
    
    (Utils.pp_final_char_if_non_empty "@,  " locals)


  		




  656
  
  
    
    (Utils.fprintf_list ~sep:";@," pp_local) locals


  		




  657
  
  
    
    (Utils.pp_final_char_if_non_empty ";" locals)


  		




  658
  
  
    
    (Utils.fprintf_list ~sep:";@," pp_instr) instrs


  		




  659
  
  
    
    (Utils.pp_final_char_if_non_empty ";" instrs)


  		




  
  660
  
    
    (pp_block pp_local) locals


  		




  
  661
  
    
    (pp_block pp_instr) instrs


  		




  660
  662
  
    
    pp_name


  		




  661
  663
  
    

  		




  662
  664
  
    

  		












Also available in:  Unified diff