-------------------------------------------------------------------------------
-- (C) Altran Praxis Limited
-------------------------------------------------------------------------------
--
-- The SPARK toolset is free software; you can redistribute it and/or modify it
-- under terms of the GNU General Public License as published by the Free
-- Software Foundation; either version 3, or (at your option) any later
-- version. The SPARK toolset 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 General
-- Public License for more details. You should have received a copy of the GNU
-- General Public License distributed with the SPARK toolset; see file
-- COPYING3. If not, go to http://www.gnu.org/licenses for a complete copy of
-- the license.
--
--=============================================================================

with AdjustFDL_RWs;
with Cell_Storage;
with Clists;
with CommandLineData;
with CStacks;
with E_Strings;
with LexTokenManager;
with Maths;
with SP_Symbols;
with SystemErrors;

use type SP_Symbols.SP_Symbol;
use type LexTokenManager.Str_Comp_Result;
use type Maths.ErrorCode;

package body DAG_IO is

   type Expn_Type is (Conclusion, Condition, Hypothesis);

   ----------------------------------------------------------------------------

   procedure Put_Examiner_String (File : in SPARK_IO.File_Type;
                                  Item : in E_Strings.T)
   --# global in out SPARK_IO.File_Sys;
   --# derives SPARK_IO.File_Sys from *,
   --#                                File,
   --#                                Item;
   is
   begin
      E_Strings.Put_String (File  => File,
                            E_Str => E_Strings.Lower_Case (E_Str => Item));
   end Put_Examiner_String;

   ----------------------------------------------------------------------------

   procedure Print_Cell_Contents
     (Heap          : in     Cells.Heap_Record;
      Output_File   : in     SPARK_IO.File_Type;
      Cell_Name     : in     Cells.Cell;
      Suppress_Wrap : in out Boolean;
      Scope         : in     Dictionary.Scopes;
      Wrap_Limit    : in     Positive;
      Escape_DOT    : in     Boolean)
   is

      This_Cell_Sym_Value    : Dictionary.Symbol;
      This_Cell_Kind         : Cells.Cell_Kind;
      This_Cell_String_Value : LexTokenManager.Lex_String;
      This_Cell_Op           : SP_Symbols.SP_Symbol;
      E_String               : E_Strings.T;

      -------------------------------------------------------

      procedure Check_Wrap (Width : in Integer)
      --# global in     Output_File;
      --#        in     Wrap_Limit;
      --#        in out SPARK_IO.File_Sys;
      --#        in out Suppress_Wrap;
      --# derives SPARK_IO.File_Sys from *,
      --#                                Output_File,
      --#                                Suppress_Wrap,
      --#                                Width,
      --#                                Wrap_Limit &
      --#         Suppress_Wrap     from *;
      is
      begin
         if Suppress_Wrap then
            Suppress_Wrap := False;
         else
            if SPARK_IO.Col (Output_File) + Width > Wrap_Limit then
               SPARK_IO.New_Line (Output_File, 1);
               SPARK_IO.Put_String (Output_File, "           ", 0);
            end if;
         end if;
      end Check_Wrap;

      -------------------------------------------------------

      procedure VCG_Put_String (Str : in E_Strings.T)
      --# global in     Output_File;
      --#        in     Wrap_Limit;
      --#        in out SPARK_IO.File_Sys;
      --#        in out Suppress_Wrap;
      --# derives SPARK_IO.File_Sys from *,
      --#                                Output_File,
      --#                                Str,
      --#                                Suppress_Wrap,
      --#                                Wrap_Limit &
      --#         Suppress_Wrap     from *;
      is
      begin
         Check_Wrap (Width => E_Strings.Get_Length (E_Str => Str));
         Put_Examiner_String (File => Output_File,
                              Item => Str);
      end VCG_Put_String;

      -------------------------------------------------------

      procedure VCG_Put_String_With_Prefix (Prefix : in String;
                                            Str    : in E_Strings.T)
      --# global in     Output_File;
      --#        in     Wrap_Limit;
      --#        in out SPARK_IO.File_Sys;
      --#        in out Suppress_Wrap;
      --# derives SPARK_IO.File_Sys from *,
      --#                                Output_File,
      --#                                Prefix,
      --#                                Str,
      --#                                Suppress_Wrap,
      --#                                Wrap_Limit &
      --#         Suppress_Wrap     from *;
      is
         Str_To_Put : E_Strings.T;
      begin
         Str_To_Put := E_Strings.Copy_String (Str => Prefix);
         E_Strings.Append_Examiner_String (E_Str1 => Str_To_Put,
                                           E_Str2 => Str);
         VCG_Put_String (Str => Str_To_Put);
      end VCG_Put_String_With_Prefix;

      -------------------------------------------------------

      procedure VCG_Put_Integer (Value : in Integer)
      --# global in     Output_File;
      --#        in     Wrap_Limit;
      --#        in out SPARK_IO.File_Sys;
      --#        in out Suppress_Wrap;
      --# derives SPARK_IO.File_Sys from *,
      --#                                Output_File,
      --#                                Suppress_Wrap,
      --#                                Value,
      --#                                Wrap_Limit &
      --#         Suppress_Wrap     from *;
      is

         function Width (N : Natural) return Natural is
            Num, Wid : Natural;
         begin
            Num := N;
            Wid := 0;
            loop
               Num := Num / 10;
               Wid := Wid + 1;
               exit when Num = 0;
            end loop;
            return Wid;
         end Width;

      begin --VCG_Put_Integer
         Check_Wrap (Width => Width (Value));
         SPARK_IO.Put_Integer (Output_File, Value, 0, 10);
      end VCG_Put_Integer;

      -------------------------------------------------------

      procedure Print_Symbol
        (File  : in SPARK_IO.File_Type;
         Scope : in Dictionary.Scopes;
         Sym   : in Dictionary.Symbol;
         Kind  : in Cells.Cell_Kind)
      --# global in     CommandLineData.Content;
      --#        in     Dictionary.Dict;
      --#        in     LexTokenManager.State;
      --#        in     Wrap_Limit;
      --#        in out SPARK_IO.File_Sys;
      --# derives SPARK_IO.File_Sys from *,
      --#                                CommandLineData.Content,
      --#                                Dictionary.Dict,
      --#                                File,
      --#                                Kind,
      --#                                LexTokenManager.State,
      --#                                Scope,
      --#                                Sym,
      --#                                Wrap_Limit;
      is
         Prefix_Fn_Length : Natural;
         Package_Ex_Str   : E_Strings.T;
         Ex_Str           : E_Strings.T;

         procedure Possibly_Print_Underbar (S : in E_Strings.T)
         --# global in     File;
         --#        in out SPARK_IO.File_Sys;
         --# derives SPARK_IO.File_Sys from *,
         --#                                File,
         --#                                S;
         is
            --This horrible kludge is to add a trailing underbar to user-declared
            --quantifiers to prevent any capture by local variables of the same name.
            --The kludge is that we don't want to add one to quantifiers that have been
            --added by the Examiner for RTC purposes. These are characterized by
            --having names of the form xxxxx__nn where x are any chars and n are digits.
            --We add a trailing underbar if the terminal characters are not digits or
            --if the are not preceded by a double underbar

            subtype Numerals is Character range '0' .. '9';
            I               : E_Strings.Lengths;
            Underbar_Wanted : Boolean := True;

         begin
            --can't be the kind we are interested in unless last char is a numeral
            if E_Strings.Get_Element (E_Str => S,
                                      Pos   => E_Strings.Get_Length (E_Str => S)) in Numerals then
               --now consume any other numerals that might be there
               I := E_Strings.Get_Length (E_Str => S) - 1; --penultimate char
               while I > 2
                 and then --2 is the lowest index that could be ok e.g. "x__"
                 E_Strings.Get_Element (E_Str => S,
                                        Pos   => I) in Numerals loop
                  I := I - 1;
               end loop;
               --I now points at the first non-numeral from the back of the string
               --we don't need an underbar if Ith and (I-1)th characters are underbars
               if E_Strings.Get_Element (E_Str => S,
                                         Pos   => I) = '_'
                 and then E_Strings.Get_Element (E_Str => S,
                                                 Pos   => I - 1) = '_' then
                  Underbar_Wanted := False;
               end if;
            end if;

            --print an underbar unless the above search has shown we don't want one
            if Underbar_Wanted then
               SPARK_IO.Put_Char (File, '_');
            end if;
         end Possibly_Print_Underbar;

      begin -- Print_Symbol
         if Dictionary.Is_Null_Symbol (Sym) then
            SPARK_IO.Put_String (File, "unexpected_null_symbol", 0);
         elsif Dictionary.IsTypeMark (Sym) and then Dictionary.IsUnknownTypeMark (Sym) then
            SPARK_IO.Put_String (File, "unknown_type", 0);
         else
            case Kind is
               when Cell_Storage.Mk_Aggregate =>
                  Prefix_Fn_Length := 4;
               when others =>
                  Prefix_Fn_Length := 0;
            end case;

            if Dictionary.IsRecordComponent (Sym) then
               Package_Ex_Str := E_Strings.Empty_String;
            else
               Package_Ex_Str := Dictionary.GetAnyPrefixNeeded (Sym       => Sym,
                                                                Scope     => Scope,
                                                                Separator => "__");
            end if;

            Ex_Str := Dictionary.GenerateSimpleName (Item      => Sym,
                                                     Separator => "__");

            if ((((SPARK_IO.Col (File) + Prefix_Fn_Length) + E_Strings.Get_Length (E_Str => Package_Ex_Str)) +
                   E_Strings.Get_Length (E_Str => Ex_Str)) +
                  12) >
              Wrap_Limit then

               SPARK_IO.New_Line (File, 1);
               SPARK_IO.Put_String (File, "           ", 0);
            end if;

            case Kind is
               when Cell_Storage.Mk_Aggregate =>
                  SPARK_IO.Put_String (File, "mk__", 0);
               when others =>
                  null;
            end case;

            if E_Strings.Get_Length (E_Str => Package_Ex_Str) > 0 then
               Put_Examiner_String (File => File,
                                    Item => Package_Ex_Str);
               SPARK_IO.Put_String (File, "__", 0);
            elsif not E_Strings.Is_Empty (E_Str => CommandLineData.Content.FDL_Mangle) then
               AdjustFDL_RWs.Possibly_Adjust (E_Str  => Ex_Str,
                                              Prefix => CommandLineData.Content.FDL_Mangle);
            end if;

            Put_Examiner_String (File => File,
                                 Item => Ex_Str);
            if Dictionary.IsQuantifiedVariable (Sym) then
               Possibly_Print_Underbar (S => Ex_Str);
            end if;
         end if;
      end Print_Symbol;

      -------------------------------------------------------

      procedure Print_Procedure_Export (Cell_Name : in Cells.Cell;
                                        Scope     : in Dictionary.Scopes)
      --# global in     CommandLineData.Content;
      --#        in     Dictionary.Dict;
      --#        in     Heap;
      --#        in     LexTokenManager.State;
      --#        in     Output_File;
      --#        in     Wrap_Limit;
      --#        in out SPARK_IO.File_Sys;
      --#        in out Suppress_Wrap;
      --# derives SPARK_IO.File_Sys from *,
      --#                                Cell_Name,
      --#                                CommandLineData.Content,
      --#                                Dictionary.Dict,
      --#                                Heap,
      --#                                LexTokenManager.State,
      --#                                Output_File,
      --#                                Scope,
      --#                                Suppress_Wrap,
      --#                                Wrap_Limit &
      --#         Suppress_Wrap     from *;
      is
         Pack_Ex_Str, Export_String : E_Strings.T;
         Var_Sym                    : Dictionary.Symbol;
      begin
         -- Get the exported variable symbol from the dictionary
         -- and convert its name to an E_String.
         Var_Sym := Cells.Get_Symbol_Value (Heap, Cell_Name);

         -- Determine whether there is a prefix required for the variable name.
         Pack_Ex_Str := Dictionary.GetAnyPrefixNeeded (Sym       => Var_Sym,
                                                       Scope     => Scope,
                                                       Separator => "__");
         if E_Strings.Get_Length (E_Str => Pack_Ex_Str) > 0 then
            -- There is a prefix and so prepend "<prefix>__" to the exported variable.
            Export_String := Pack_Ex_Str;
            E_Strings.Append_String (E_Str => Export_String,
                                     Str   => "__");
            E_Strings.Append_Examiner_String
              (E_Str1 => Export_String,
               E_Str2 => Dictionary.GenerateSimpleName (Item      => Var_Sym,
                                                        Separator => "_"));
         else
            Export_String := Dictionary.GenerateSimpleName (Item      => Var_Sym,
                                                            Separator => "_");

            -- It is a simple name and may be an FDL reserved identifier
            -- so check whether the name has to be mangled.
            if not E_Strings.Is_Empty (E_Str => CommandLineData.Content.FDL_Mangle) then
               AdjustFDL_RWs.Possibly_Adjust (E_Str  => Export_String,
                                              Prefix => CommandLineData.Content.FDL_Mangle);
            end if;

         end if;

         -- The export name needs to be extended with its instance number
         -- e.g., export_var__1, export_var__2, etc.
         E_Strings.Append_String (E_Str => Export_String,
                                  Str   => "__");

         -- The instance number is contained within the cell representing the
         -- exported variable (Cell_Name).
         E_Strings.Append_Examiner_String
           (E_Str1 => Export_String,
            E_Str2 => LexTokenManager.Lex_String_To_String (Lex_Str => Cells.Get_Lex_Str (Heap, Cell_Name)));

         -- Now the exported variable name can be output.
         VCG_Put_String (Str => Export_String);

      end Print_Procedure_Export;

      procedure Print_Manifest_Constant_Cell (Cell_Name : in Cells.Cell)
      --# global in     Heap;
      --#        in     LexTokenManager.State;
      --#        in     Output_File;
      --#        in     Wrap_Limit;
      --#        in out SPARK_IO.File_Sys;
      --#        in out Suppress_Wrap;
      --# derives SPARK_IO.File_Sys from *,
      --#                                Cell_Name,
      --#                                Heap,
      --#                                LexTokenManager.State,
      --#                                Output_File,
      --#                                Suppress_Wrap,
      --#                                Wrap_Limit &
      --#         Suppress_Wrap     from *,
      --#                                Cell_Name,
      --#                                Heap,
      --#                                LexTokenManager.State;
      is
         E_Str : E_Strings.T;
         Value : Maths.Value;
         Err   : Maths.ErrorCode;
         L_Str : LexTokenManager.Lex_String;

         procedure Print_String_Literal
         --# global in     E_Str;
         --#        in     Output_File;
         --#        in     Wrap_Limit;
         --#        in out SPARK_IO.File_Sys;
         --#        in out Suppress_Wrap;
         --# derives SPARK_IO.File_Sys from *,
         --#                                E_Str,
         --#                                Output_File,
         --#                                Suppress_Wrap,
         --#                                Wrap_Limit &
         --#         Suppress_Wrap     from *,
         --#                                E_Str;
         is
            Separator : Character;
            Position  : Positive;

            procedure Print_One_Element (Char_Code : in Integer)
            --# global in     Output_File;
            --#        in     Position;
            --#        in     Separator;
            --#        in     Wrap_Limit;
            --#        in out SPARK_IO.File_Sys;
            --#        in out Suppress_Wrap;
            --# derives SPARK_IO.File_Sys from *,
            --#                                Char_Code,
            --#                                Output_File,
            --#                                Position,
            --#                                Separator,
            --#                                Suppress_Wrap,
            --#                                Wrap_Limit &
            --#         Suppress_Wrap     from *;
            is
            begin
               SPARK_IO.Put_Char (Output_File, Separator);
               SPARK_IO.Put_Char (Output_File, ' ');
               Check_Wrap (Width => 5);
               SPARK_IO.Put_Char (Output_File, '[');
               VCG_Put_Integer (Value => Position);
               SPARK_IO.Put_Char (Output_File, ']');
               Check_Wrap (Width => 4);
               SPARK_IO.Put_String (Output_File, " := ", 0);
               VCG_Put_Integer (Value => Char_Code);
            end Print_One_Element;

         begin -- Print_String_Literal
            case E_Strings.Get_Length (E_Str => E_Str) is
               when 0 | 1 =>
                  SystemErrors.Fatal_Error
                    (Sys_Err => SystemErrors.Precondition_Failure,
                     Msg     => "Mal-formed string literal in VCG Print_String_Literal");
               when 2 =>
                  -- Must be "" - the null string literal.
                  SystemErrors.RT_Assert
                    (C       => E_Strings.Eq1_String (E_Str => E_Str,
                                                      Str   => """"""),
                     Sys_Err => SystemErrors.Precondition_Failure,
                     Msg     => "Mal-formed NULL string literal in VCG Print_String_Literal");
                  Check_Wrap (Width => 9);
                  SPARK_IO.Put_String (Output_File, Null_String_Literal_Name, 0);
               when others =>
                  Check_Wrap (Width => 9);
                  SPARK_IO.Put_String (Output_File, "mk__string", 0);
                  Separator := '(';
                  Position  := 1;
                  for I in E_Strings.Positions range 2 .. E_Strings.Get_Length (E_Str => E_Str) - 1 loop
                     Print_One_Element (Char_Code => Character'Pos (E_Strings.Get_Element (E_Str => E_Str,
                                                                                           Pos   => I)));
                     Separator := ',';
                     Position  := Position + 1;
                  end loop;
                  SPARK_IO.Put_Char (Output_File, ')');
            end case;
         end Print_String_Literal;

      begin -- Print_Manifest_Constant_Cell
         L_Str := Cells.Get_Lex_Str (Heap, Cell_Name);
         E_Str := LexTokenManager.Lex_String_To_String (Lex_Str => L_Str);
         if E_Strings.Get_Element (E_Str => E_Str,
                                   Pos   => 1) = ''' then --character literal
            VCG_Put_Integer (Value => Character'Pos (E_Strings.Get_Element (E_Str => E_Str,
                                                                            Pos   => 2)));

         elsif E_Strings.Get_Element (E_Str => E_Str,
                                      Pos   => 1) = '"' then --string literal
            Print_String_Literal;
         else -- should be a numeric
            Maths.LiteralToValue (L_Str, Value, Err);
            if Err = Maths.NoError then
               E_Str := Maths.ValueToString (Value);
            end if;
            VCG_Put_String (Str => E_Str);
         end if;
      end Print_Manifest_Constant_Cell;

   begin -- Print_Cell_Contents
      case Cells.Get_Kind (Heap, Cell_Name) is
         when Cell_Storage.Manifest_Const =>
            Print_Manifest_Constant_Cell (Cell_Name => Cell_Name);
         when Cell_Storage.Attrib_Value | Cell_Storage.Attrib_Function =>
            Put_Examiner_String
              (File => Output_File,
               Item => LexTokenManager.Lex_String_To_String (Lex_Str => Cells.Get_Lex_Str (Heap, Cell_Name)));
         when Cell_Storage.Field_Access_Function =>
            E_String := LexTokenManager.Lex_String_To_String (Lex_Str => Cells.Get_Lex_Str (Heap, Cell_Name));
            if not E_Strings.Is_Empty (E_Str => CommandLineData.Content.FDL_Mangle) then
               AdjustFDL_RWs.Possibly_Adjust (E_Str  => E_String,
                                              Prefix => CommandLineData.Content.FDL_Mangle);
            end if;
            VCG_Put_String_With_Prefix (Prefix => "fld_",
                                        Str    => E_String);
         when Cell_Storage.Field_Update_Function =>
            E_String := LexTokenManager.Lex_String_To_String (Lex_Str => Cells.Get_Lex_Str (Heap, Cell_Name));
            if not E_Strings.Is_Empty (E_Str => CommandLineData.Content.FDL_Mangle) then
               AdjustFDL_RWs.Possibly_Adjust (E_Str  => E_String,
                                              Prefix => CommandLineData.Content.FDL_Mangle);
            end if;
            VCG_Put_String_With_Prefix (Prefix => "upf_",
                                        Str    => E_String);
         when Cell_Storage.Element_Function =>
            SPARK_IO.Put_String (Output_File, "element", 0);
         when Cell_Storage.Update_Function =>
            SPARK_IO.Put_String (Output_File, "update", 0);
         when Cell_Storage.Pred_Function =>
            SPARK_IO.Put_String (Output_File, "pred", 0);
         when Cell_Storage.Succ_Function =>
            SPARK_IO.Put_String (Output_File, "succ", 0);
         when Cell_Storage.Abs_Function =>
            SPARK_IO.Put_String (Output_File, "abs", 0);
         when Cell_Storage.Trunc_Function =>
            SPARK_IO.Put_String (Output_File, "round__", 0);
         when Cell_Storage.List_Function =>
            null;
         when Cell_Storage.FDL_Div_Op =>
            SPARK_IO.Put_String (Output_File, " div ", 0);
         when Cell_Storage.Op =>

            if SPARK_IO.Col (Output_File) > (Wrap_Limit + 3)
              and then Cells.Get_Op_Symbol (Heap, Cell_Name) /= SP_Symbols.apostrophe then

               SPARK_IO.New_Line (Output_File, 1);
               SPARK_IO.Put_String (Output_File, "          ", 0);
            end if;

            case Cells.Get_Op_Symbol (Heap, Cell_Name) is
               when SP_Symbols.colon =>
                  SPARK_IO.Put_String (Output_File, ": ", 0);
               when SP_Symbols.comma =>
                  SPARK_IO.Put_String (Output_File, ", ", 0);
               when SP_Symbols.RWand | SP_Symbols.RWandthen =>
                  SPARK_IO.Put_String (Output_File, " and ", 0);
               when SP_Symbols.RWor | SP_Symbols.RWorelse =>
                  SPARK_IO.Put_String (Output_File, " or ", 0);
               when SP_Symbols.equals =>
                  SPARK_IO.Put_String (Output_File, " = ", 0);
               when SP_Symbols.not_equal =>
                  if Escape_DOT then
                     SPARK_IO.Put_String (Output_File, " \<\> ", 0);
                  else
                     SPARK_IO.Put_String (Output_File, " <> ", 0);
                  end if;
               when SP_Symbols.less_than =>
                  if Escape_DOT then
                     SPARK_IO.Put_String (Output_File, " \< ", 0);
                  else
                     SPARK_IO.Put_String (Output_File, " < ", 0);
                  end if;
               when SP_Symbols.less_or_equal =>
                  if Escape_DOT then
                     SPARK_IO.Put_String (Output_File, " \<= ", 0);
                  else
                     SPARK_IO.Put_String (Output_File, " <= ", 0);
                  end if;
               when SP_Symbols.greater_than =>
                  if Escape_DOT then
                     SPARK_IO.Put_String (Output_File, " \> ", 0);
                  else
                     SPARK_IO.Put_String (Output_File, " > ", 0);
                  end if;
               when SP_Symbols.greater_or_equal =>
                  if Escape_DOT then
                     SPARK_IO.Put_String (Output_File, " \>= ", 0);
                  else
                     SPARK_IO.Put_String (Output_File, " >= ", 0);
                  end if;
               when SP_Symbols.implies =>
                  if Escape_DOT then
                     SPARK_IO.Put_String (Output_File, " -\> ", 0);
                  else
                     SPARK_IO.Put_String (Output_File, " -> ", 0);
                  end if;
               when SP_Symbols.is_equivalent_to =>
                  if Escape_DOT then
                     SPARK_IO.Put_String (Output_File, " \<-\> ", 0);
                  else
                     SPARK_IO.Put_String (Output_File, " <-> ", 0);
                  end if;
               when SP_Symbols.plus =>
                  if Cells.Is_Null_Cell (Cells.Get_A_Ptr (Heap, Cell_Name)) then
                     -- Unary + is semantically meaningless, so no point
                     -- printing it.
                     Suppress_Wrap := True;
                  else
                     SPARK_IO.Put_String (Output_File, " + ", 0); -- Binary
                  end if;

               when SP_Symbols.minus =>
                  if Cells.Is_Null_Cell (Cells.Get_A_Ptr (Heap, Cell_Name)) then
                     SPARK_IO.Put_String (Output_File, " -", 0);  -- Unary
                     Suppress_Wrap := True;
                  else
                     SPARK_IO.Put_String (Output_File, " - ", 0); -- Binary
                  end if;

               when SP_Symbols.multiply =>
                  SPARK_IO.Put_String (Output_File, " * ", 0);
               when SP_Symbols.divide =>
                  SPARK_IO.Put_String (Output_File, " / ", 0);
               when SP_Symbols.RWmod =>
                  SPARK_IO.Put_String (Output_File, " mod ", 0);
               when SP_Symbols.double_star =>
                  SPARK_IO.Put_String (Output_File, " ** ", 0);
               when SP_Symbols.RWnot =>
                  SPARK_IO.Put_String (Output_File, "not ", 0);

               when SP_Symbols.apostrophe =>
                  ---------------------------------
                  -- apostrophe becomes "__" in FDL
                  ---------------------------------
                  SPARK_IO.Put_String (Output_File, "__", 0);

               when SP_Symbols.ampersand =>
                  SPARK_IO.Put_String (Output_File, " & ", 0);
               when SP_Symbols.becomes =>
                  SPARK_IO.Put_String (Output_File, " := ", 0);
               when SP_Symbols.double_dot =>
                  SPARK_IO.Put_String (Output_File, " .. ", 0);
               when SP_Symbols.RWforall =>
                  SPARK_IO.Put_String (Output_File, "for_all", 0);
               when SP_Symbols.RWforsome =>
                  SPARK_IO.Put_String (Output_File, "for_some", 0);
                  --------------------------------------------------------------------
               when SP_Symbols.right_paren =>
                  SPARK_IO.Put_String (Output_File, " Parenthesis_Requested", 0);
               when others =>
                  SPARK_IO.Put_String (Output_File, " undef_op_value ", 0);
            end case;

         when Cell_Storage.Internal_Natural =>
            SPARK_IO.Put_Integer
              (File  => Output_File,
               Item  => Cells.Get_Natural_Value (Heap, Cell_Name),
               Width => Natural'First,
               Base  => 10);

         when Cell_Storage.Internal_Scope =>
            SPARK_IO.Put_String (Output_File, "(Dictionary.Scopes in Internal_Scope)", 0);

         when Cell_Storage.Named_Const                    |
           Cell_Storage.Declared_Function              |
           Cell_Storage.Proof_Function                 |
           Cell_Storage.Modified_Op                    |
           Cell_Storage.Reference                      |
           Cell_Storage.Constraining_Index             |
           Cell_Storage.Fixed_Var                      |
           Cell_Storage.Unconstrained_Attribute_Prefix |
           Cell_Storage.Mk_Aggregate                   =>

            This_Cell_Sym_Value    := Cells.Get_Symbol_Value (Heap, Cell_Name);
            This_Cell_Kind         := Cells.Get_Kind (Heap, Cell_Name);
            This_Cell_String_Value := Cells.Get_Lex_Str (Heap, Cell_Name);
            This_Cell_Op           := Cells.Get_Op_Symbol (Heap, Cell_Name);

            if This_Cell_Kind = Cell_Storage.Mk_Aggregate and then Dictionary.IsSubtype (This_Cell_Sym_Value) then
               This_Cell_Sym_Value := Dictionary.GetRootType (This_Cell_Sym_Value);
            end if;

            Print_Symbol (File  => Output_File,
                          Scope => Scope,
                          Sym   => This_Cell_Sym_Value,
                          Kind  => This_Cell_Kind);

            -- An unconstrained attribute prefix _might_ have a tilde,
            -- such as O~'First.  This is allowed by the grammar,
            -- but removed here, since the attributes of an unconstrained
            -- array parameter cannot change during the lifetime of the
            -- object.  Essentially, we know that O~'First = O'First,
            -- so we just print the latter.
            if This_Cell_Op = SP_Symbols.tilde and This_Cell_Kind /= Cell_Storage.Unconstrained_Attribute_Prefix then
               SPARK_IO.Put_String (Output_File, "~", 0);
            end if;

            -- Only print numeric suffix if number present in string field.
            if This_Cell_Kind = Cell_Storage.Declared_Function
              and then LexTokenManager.Lex_String_Case_Insensitive_Compare
              (Lex_Str1 => This_Cell_String_Value,
               Lex_Str2 => LexTokenManager.Null_String) /=
              LexTokenManager.Str_Eq then
               SPARK_IO.Put_String (Output_File, "__", 0);
               Put_Examiner_String
                 (File => Output_File,
                  Item => LexTokenManager.Lex_String_To_String (Lex_Str => This_Cell_String_Value));
            end if;

         when Cell_Storage.Procedure_Export =>
            Print_Procedure_Export (Cell_Name => Cell_Name,
                                    Scope     => Scope);

         when Cell_Storage.Procedure_Name | Cell_Storage.Call_Counter =>
            null;

         when Cell_Storage.Pending_Function =>
            SPARK_IO.Put_String (Output_File, " Incomplete_Function", 0);
         when Cell_Storage.Aggregate_Counter | Cell_Storage.Incomplete_Aggregate =>
            SPARK_IO.Put_String (Output_File, " Incomplete_Aggregate", 0);

         when Cell_Storage.Return_Var =>
            SPARK_IO.Put_String (Output_File, "return", 0);

         when Cell_Storage.Root_Integer =>
            SPARK_IO.Put_String (Output_File, "system__", 0);
            -- Put out min or max
            Put_Examiner_String
              (File => Output_File,
               Item => LexTokenManager.Lex_String_To_String (Lex_Str => Cells.Get_Lex_Str (Heap, Cell_Name)));
            -- and complete with _int.
            SPARK_IO.Put_String (Output_File, "_int", 0);

         when Cell_Storage.Bitwise_Op =>
            if Dictionary.TypeIsArray (Cells.Get_Symbol_Value (Heap, Cell_Name)) then
               Print_Symbol
                 (File  => Output_File,
                  Scope => Scope,
                  Sym   => Cells.Get_Symbol_Value (Heap, Cell_Name),
                  Kind  => Cells.Get_Kind (Heap, Cell_Name));
               SPARK_IO.Put_String (Output_File, "__", 0);
               case Cells.Get_Op_Symbol (Heap, Cell_Name) is
                  when SP_Symbols.RWand =>
                     SPARK_IO.Put_String (Output_File, "and", 0);
                  when SP_Symbols.RWor =>
                     SPARK_IO.Put_String (Output_File, "or", 0);
                  when SP_Symbols.RWxor =>
                     SPARK_IO.Put_String (Output_File, "xor", 0);
                  when SP_Symbols.RWnot =>
                     SPARK_IO.Put_String (Output_File, "not", 0);
                  when others =>
                     SPARK_IO.Put_String (Output_File, "undef_op_value", 0);
               end case;
            elsif Dictionary.TypeIsModular (Cells.Get_Symbol_Value (Heap, Cell_Name)) then

               case Cells.Get_Op_Symbol (Heap, Cell_Name) is
                  -- Note bitwise "not" for modular types is expanded in the
                  -- VCG.ProduceVCs.BuildGraph, and so should never appear here.
                  when SP_Symbols.RWand =>
                     SPARK_IO.Put_String (Output_File, "bit__and", 0);
                  when SP_Symbols.RWor =>
                     SPARK_IO.Put_String (Output_File, "bit__or", 0);
                  when SP_Symbols.RWxor =>
                     SPARK_IO.Put_String (Output_File, "bit__xor", 0);
                  when others =>
                     SPARK_IO.Put_String (Output_File, "undef_op_value", 0);
               end case;

            end if;

         when Cell_Storage.Function_Call_In_Proof_Context =>
            SPARK_IO.Put_String (Output_File, "Function_Call_In_Proof_Context", 0);

         when Cell_Storage.Proof_Function_Obtain_Precondition =>
            SPARK_IO.Put_String (Output_File, "Proof_Function_Obtain_Precondition", 0);

         when Cell_Storage.Proof_Function_Obtain_Return =>
            SPARK_IO.Put_String (Output_File, "Proof_Function_Obtain_Return", 0);

         when Cell_Storage.Proof_Function_Syntax_Node =>
            SPARK_IO.Put_String (Output_File, "Syntax_Node", 0);

         when Cell_Storage.Quantifier =>
            SPARK_IO.Put_String (Output_File, "Quantifier", 0);

         when Cell_Storage.Unknown_Kind =>
            SPARK_IO.Put_String (Output_File, " unknown_cell_kind ", 0);
      end case;
   end Print_Cell_Contents;

   -------------------------------------------------------------------------

   function IsLeaf (Node : Cells.Cell;
                    Heap : Cells.Heap_Record) return Boolean is
   begin
      return Cells.Is_Null_Cell (Cells.Get_B_Ptr (Heap, Node));
   end IsLeaf;

   --------------------------------------------------------------

   procedure PrintDagLocal
     (Heap        : in out Cells.Heap_Record;
      Output_File : in     SPARK_IO.File_Type;
      Root        : in     Cells.Cell;
      Scope       : in     Dictionary.Scopes;
      Wrap_Limit  : in     Positive)
   --# global in     CommandLineData.Content;
   --#        in     Dictionary.Dict;
   --#        in     LexTokenManager.State;
   --#        in out SPARK_IO.File_Sys;
   --#        in out Statistics.TableUsage;
   --# derives Heap,
   --#         Statistics.TableUsage from *,
   --#                                    Heap,
   --#                                    Root &
   --#         SPARK_IO.File_Sys     from *,
   --#                                    CommandLineData.Content,
   --#                                    Dictionary.Dict,
   --#                                    Heap,
   --#                                    LexTokenManager.State,
   --#                                    Output_File,
   --#                                    Root,
   --#                                    Scope,
   --#                                    Wrap_Limit;
   is
      P, ParenthesisCell, SqBracketCell : Cells.Cell;
      ParenthesisForm                   : SP_Symbols.SP_Symbol;
      ParReqd                           : Boolean;
      S                                 : CStacks.Stack;
      Suppress_Wrap                     : Boolean;

      --------------------------------------------------------------

      procedure Parenthesise
        (V               : in     Cells.Cell;
         LeftTree        : in     Boolean;
         ParReqd         :    out Boolean;
         ParenthesisForm :    out SP_Symbols.SP_Symbol)
      --# global in Heap;
      --# derives ParenthesisForm from Heap,
      --#                              V &
      --#         ParReqd         from Heap,
      --#                              LeftTree,
      --#                              V;
      is

         VPrecedence, WPrecedence : Natural;
         Operand, W               : Cells.Cell;
         V_Kind                   : Cells.Cell_Kind;

         --------------------------------------------

         function PrecedenceValue (C : Cells.Cell) return Natural
         --# global in Heap;
         is
            PrecVal : Natural;
         begin
            if Cells.Get_Kind (Heap, C) = Cell_Storage.FDL_Div_Op then
               PrecVal := 5;
            else
               case Cells.Get_Op_Symbol (Heap, C) is
                  when SP_Symbols.RWand            |
                    SP_Symbols.RWor             |
                    SP_Symbols.RWandthen        |
                    SP_Symbols.RWorelse         |
                    SP_Symbols.implies          |
                    SP_Symbols.RWnot            |
                    SP_Symbols.is_equivalent_to =>
                     PrecVal := 1;
                  when SP_Symbols.equals           |
                    SP_Symbols.not_equal        |
                    SP_Symbols.less_than        |
                    SP_Symbols.less_or_equal    |
                    SP_Symbols.greater_than     |
                    SP_Symbols.greater_or_equal =>
                     PrecVal := 2;
                  when SP_Symbols.plus | SP_Symbols.minus | SP_Symbols.ampersand =>
                     PrecVal := 3;

                     -- arity is taken into account by examining node degrees of operator nodes
                     -- (see body of procedure Parenthesise).
                     --        when SP_Symbols.unary_plus      |
                     --             SP_Symbols.unary_minus       => PrecVal := 4;

                  when SP_Symbols.multiply | SP_Symbols.divide | SP_Symbols.RWmod =>
                     PrecVal := 5;
                  when SP_Symbols.double_star =>
                     PrecVal := 6;
                  when others =>
                     PrecVal := 7;
               end case;
            end if;
            return PrecVal;
         end PrecedenceValue;

         --------------------------------------------------------------------

      begin -- Parenthesise;
         ParReqd         := False;
         ParenthesisForm := SP_Symbols.left_paren;
         V_Kind          := Cells.Get_Kind (Heap, V);
         if (V_Kind = Cell_Storage.Declared_Function) or
           (V_Kind = Cell_Storage.Proof_Function) or
           (V_Kind = Cell_Storage.Attrib_Function) or
           (V_Kind = Cell_Storage.Field_Access_Function) or
           (V_Kind = Cell_Storage.Mk_Aggregate) or
           (V_Kind = Cell_Storage.List_Function) or
           (V_Kind = Cell_Storage.Element_Function) or
           (V_Kind = Cell_Storage.Update_Function) or
           (V_Kind = Cell_Storage.Pred_Function) or
           (V_Kind = Cell_Storage.Succ_Function) or
           (V_Kind = Cell_Storage.Abs_Function) or
           (V_Kind = Cell_Storage.Trunc_Function) or
           (V_Kind = Cell_Storage.Field_Update_Function) or
           (V_Kind = Cell_Storage.Bitwise_Op) then
            ParReqd := True;
            if (V_Kind = Cell_Storage.List_Function) then
               ParenthesisForm := SP_Symbols.square_open;
            end if;
         elsif ((V_Kind = Cell_Storage.Op)
                -- TEMPORARY FIX until right_paren given its own kind
                and then ((Cells.Get_Op_Symbol (Heap, V) /= SP_Symbols.right_paren)
                          -- END OF TEMPORARY FIX.
                          and
                            (Cells.Get_Op_Symbol (Heap, V) /= SP_Symbols.comma)))
           or else (V_Kind = Cell_Storage.FDL_Div_Op) then

            if Cells.Is_Null_Cell (Cells.Get_A_Ptr (Heap, V)) then
               -- V is a monadic operator;
               Operand := Cells.Get_B_Ptr (Heap, V);
               if not IsLeaf (Operand, Heap) then
                  ParReqd := True;
               end if;
            else
               if LeftTree then
                  W := Cells.Get_A_Ptr (Heap, V);
               else
                  W := Cells.Get_B_Ptr (Heap, V);
               end if;
               if not Cells.Is_Null_Cell (W) then
                  if (Cells.Get_Kind (Heap, W) = Cell_Storage.Op)
                    or else (Cells.Get_Kind (Heap, W) = Cell_Storage.FDL_Div_Op) then

                     VPrecedence := PrecedenceValue (V);
                     WPrecedence := PrecedenceValue (W);

                     -- general rule for constructing unambiguous expressions:
                     ParReqd := (VPrecedence > WPrecedence) or ((VPrecedence = WPrecedence) and not LeftTree);

                     -- supplementary rules, to improve clarity:
                     -- 1) if the outer op is logical op OR
                     -- 2)    the inner op is a relational op (such as "<=") OR
                     -- 3)    both the inner and outer ops are "**"
                     --    then add parentheses
                     if (VPrecedence = 1) or -- V is a logical operation;
                       (WPrecedence = 2) or  -- subtree W is a relation;
                       (VPrecedence = 6 and WPrecedence = 6) then -- both "**"
                        ParReqd := True;
                     end if;
                  end if;
               end if;
            end if;
         end if;
      end Parenthesise;

      -----------------------------------------------------------------------

   begin -- PrintDagLocal

      -- Algorithm of D.E. Knuth, Fundamental Algorithms, p.317;
      Suppress_Wrap := False;
      CStacks.CreateStack (S);
      Cells.Create_Cell (Heap, ParenthesisCell);
      Cells.Set_Kind (Heap, ParenthesisCell, Cell_Storage.Op);
      Cells.Set_Op_Symbol (Heap, ParenthesisCell, SP_Symbols.left_paren);
      Cells.Create_Cell (Heap, SqBracketCell);
      Cells.Set_Kind (Heap, SqBracketCell, Cell_Storage.Op);
      Cells.Set_Op_Symbol (Heap, SqBracketCell, SP_Symbols.square_open);
      P := Root;
      loop
         loop
            exit when Cells.Is_Null_Cell (P);
            CStacks.Push (Heap, P, S);
            if IsLeaf (P, Heap) then
               P := Cells.Null_Cell;
            else
               if (not Cells.Is_Null_Cell (Cells.Get_A_Ptr (Heap, P))) then
                  Parenthesise (P, True, ParReqd, ParenthesisForm);
                  if ParReqd then
                     if ParenthesisForm = SP_Symbols.left_paren then
                        SPARK_IO.Put_String (Output_File, "(", 0);
                        CStacks.Push (Heap, ParenthesisCell, S);
                     else
                        CStacks.Push (Heap, SqBracketCell, S);
                     end if;
                  end if;
               end if;
               P := Cells.Get_A_Ptr (Heap, P);
            end if;
         end loop;
         exit when CStacks.IsEmpty (S);
         P := CStacks.Top (Heap, S);
         CStacks.Pop (Heap, S);
         Print_Cell_Contents
           (Heap          => Heap,
            Output_File   => Output_File,
            Cell_Name     => P,
            Suppress_Wrap => Suppress_Wrap,
            Scope         => Scope,
            Wrap_Limit    => Wrap_Limit,
            Escape_DOT    => False);
         if IsLeaf (P, Heap) then
            P := Cells.Null_Cell;
            loop
               exit when not ((Cells.Are_Identical (CStacks.Top (Heap, S), ParenthesisCell)) or
                                (Cells.Are_Identical (CStacks.Top (Heap, S), SqBracketCell)));
               if (Cells.Are_Identical (CStacks.Top (Heap, S), ParenthesisCell)) then
                  SPARK_IO.Put_String (Output_File, ")", 0);
               else
                  SPARK_IO.Put_String (Output_File, "]", 0);
               end if;
               CStacks.Pop (Heap, S);
            end loop;
         else
            Parenthesise (P, False, ParReqd, ParenthesisForm);
            if ParReqd then
               if ParenthesisForm = SP_Symbols.left_paren then
                  SPARK_IO.Put_String (Output_File, "(", 0);
                  CStacks.Push (Heap, ParenthesisCell, S);
               else
                  SPARK_IO.Put_String (Output_File, "[", 0);
                  CStacks.Push (Heap, SqBracketCell, S);
               end if;
            end if;
            P := Cells.Get_B_Ptr (Heap, P);
         end if;
      end loop;
   end PrintDagLocal;

   -------------------------------------------------------------------------

   procedure PrintDag
     (Heap        : in out Cells.Heap_Record;
      Output_File : in     SPARK_IO.File_Type;
      Root        : in     Cells.Cell;
      Scope       : in     Dictionary.Scopes;
      Wrap_Limit  : in     Positive)
   is
   begin
      PrintDagLocal (Heap, Output_File, Root, Scope, Wrap_Limit);
   end PrintDag;

   -------------------------------------------------------------------------

   procedure Partition (Root        : in     Cells.Cell;
                        SubExpnList : in     Cells.Cell;
                        Heap        : in out Cells.Heap_Record) is
      P, SubExpn : Cells.Cell;
      S          : CStacks.Stack;
   begin
      CStacks.CreateStack (S);
      P := Root;
      loop
         loop
            exit when Cells.Is_Null_Cell (P);
            CStacks.Push (Heap, P, S);
            if (Cells.Get_Kind (Heap, P) = Cell_Storage.Op)
              and then ((Cells.Get_Op_Symbol (Heap, P) = SP_Symbols.RWand) or
                          (Cells.Get_Op_Symbol (Heap, P) = SP_Symbols.RWandthen)) then
               P := Cells.Get_A_Ptr (Heap, P);
            else
               Cells.Create_Cell (Heap, SubExpn);
               Cells.Set_B_Ptr (Heap, SubExpn, P);
               Clists.AppendCell (Heap, SubExpn, SubExpnList);
               P := Cells.Null_Cell;
            end if;
         end loop;
         exit when CStacks.IsEmpty (S);
         P := CStacks.Top (Heap, S);
         CStacks.Pop (Heap, S);
         if (Cells.Get_Kind (Heap, P) = Cell_Storage.Op)
           and then ((Cells.Get_Op_Symbol (Heap, P) = SP_Symbols.RWand) or
                       (Cells.Get_Op_Symbol (Heap, P) = SP_Symbols.RWandthen)) then
            P := Cells.Get_B_Ptr (Heap, P);
         else
            P := Cells.Null_Cell;
         end if;
      end loop;
   end Partition;

   -------------------------------------------------------------------------

   procedure PrintLogicalExpn
     (Heap        : in out Cells.Heap_Record;
      Output_File : in     SPARK_IO.File_Type;
      Scope       : in     Dictionary.Scopes;
      Root        : in     Cells.Cell;
      TypeOfExpn  : in     Expn_Type;
      Wrap_Limit  : in     Positive)
   --# global in     CommandLineData.Content;
   --#        in     Dictionary.Dict;
   --#        in     LexTokenManager.State;
   --#        in out SPARK_IO.File_Sys;
   --#        in out Statistics.TableUsage;
   --# derives Heap,
   --#         Statistics.TableUsage from *,
   --#                                    Heap,
   --#                                    Root &
   --#         SPARK_IO.File_Sys     from *,
   --#                                    CommandLineData.Content,
   --#                                    Dictionary.Dict,
   --#                                    Heap,
   --#                                    LexTokenManager.State,
   --#                                    Output_File,
   --#                                    Root,
   --#                                    Scope,
   --#                                    TypeOfExpn,
   --#                                    Wrap_Limit;
   is
      SubExpnList : Cells.Cell;

      procedure PrintListOfExpns
      --# global in     CommandLineData.Content;
      --#        in     Dictionary.Dict;
      --#        in     LexTokenManager.State;
      --#        in     Output_File;
      --#        in     Scope;
      --#        in     SubExpnList;
      --#        in     TypeOfExpn;
      --#        in     Wrap_Limit;
      --#        in out Heap;
      --#        in out SPARK_IO.File_Sys;
      --#        in out Statistics.TableUsage;
      --# derives Heap,
      --#         Statistics.TableUsage from *,
      --#                                    Heap,
      --#                                    SubExpnList &
      --#         SPARK_IO.File_Sys     from *,
      --#                                    CommandLineData.Content,
      --#                                    Dictionary.Dict,
      --#                                    Heap,
      --#                                    LexTokenManager.State,
      --#                                    Output_File,
      --#                                    Scope,
      --#                                    SubExpnList,
      --#                                    TypeOfExpn,
      --#                                    Wrap_Limit;
      is
         ClauseNmbr : Natural;
         ListMember : Cells.Cell;

         procedure PrintTypeOfExpn
         --# global in     Output_File;
         --#        in     TypeOfExpn;
         --#        in out SPARK_IO.File_Sys;
         --# derives SPARK_IO.File_Sys from *,
         --#                                Output_File,
         --#                                TypeOfExpn;
         is
         begin
            case TypeOfExpn is
               when Conclusion =>
                  SPARK_IO.Put_String (Output_File, "C", 0);
               when Condition =>
                  SPARK_IO.Put_String (Output_File, " ", 0);
               when Hypothesis =>
                  SPARK_IO.Put_String (Output_File, "H", 0);
            end case;
         end PrintTypeOfExpn;

      begin

         -- This looks like the place to suppress multiple Trues in hypotheses
         -- and do something with trues in conclusions.

         ClauseNmbr := 0;
         ListMember := Clists.FirstCell (Heap, SubExpnList);
         loop
            PrintTypeOfExpn;
            ClauseNmbr := ClauseNmbr + 1;
            SPARK_IO.Put_Integer (Output_File, ClauseNmbr, 0, 10);
            SPARK_IO.Put_String (Output_File, ":", 0);
            SPARK_IO.Set_Col (Output_File, 8);
            PrintDag (Heap, Output_File, Cells.Get_B_Ptr (Heap, ListMember), Scope, Wrap_Limit);
            SPARK_IO.Put_Line (Output_File, " .", 0);
            ListMember := Clists.NextCell (Heap, ListMember);
            exit when Cells.Is_Null_Cell (ListMember);
         end loop;
      end PrintListOfExpns;

   begin -- PrintLogicalExpn
      Clists.CreateList (Heap, SubExpnList);
      Partition (Root, SubExpnList, Heap);
      PrintListOfExpns;
      Clists.DisposeOfList (Heap, SubExpnList);
   end PrintLogicalExpn;

   -------------------------------------------------------------------------

   procedure PrintLabel
     (Heap        : in out Cells.Heap_Record;
      Output_File : in     SPARK_IO.File_Type;
      LabelName   : in     Labels.Label;
      Scope       : in     Dictionary.Scopes;
      Wrap_Limit  : in     Positive)
   is
      PairCount   : Natural;
      CurrentPair : Pairs.Pair;

      -------------------------------------------------------

      procedure PrintPair (Output_File : in SPARK_IO.File_Type;
                           PairName    : in Pairs.Pair)
      --# global in     CommandLineData.Content;
      --#        in     Dictionary.Dict;
      --#        in     LexTokenManager.State;
      --#        in     Scope;
      --#        in     Wrap_Limit;
      --#        in out Heap;
      --#        in out SPARK_IO.File_Sys;
      --#        in out Statistics.TableUsage;
      --# derives Heap,
      --#         Statistics.TableUsage from *,
      --#                                    Heap,
      --#                                    PairName &
      --#         SPARK_IO.File_Sys     from *,
      --#                                    CommandLineData.Content,
      --#                                    Dictionary.Dict,
      --#                                    Heap,
      --#                                    LexTokenManager.State,
      --#                                    Output_File,
      --#                                    PairName,
      --#                                    Scope,
      --#                                    Wrap_Limit;
      -- prints a predicate-action pair;
      is
         Action, ModCell, Predicate : Cells.Cell;
         Suppress_Wrap              : Boolean;
      begin -- PrintPair
         Suppress_Wrap := False;
         SPARK_IO.Put_Line (Output_File, "      Traversal condition:", 0);
         if Pairs.IsTrue (Heap, PairName) then
            SPARK_IO.Put_Line (Output_File, " 1:     true .", 0);
         else
            Predicate := Cells.Get_B_Ptr (Heap, Pairs.PairHead (PairName));
            PrintLogicalExpn (Heap, Output_File, Scope, Predicate, Condition, Wrap_Limit);
         end if;
         SPARK_IO.Put_Line (Output_File, "      Action:", 0);
         if Pairs.IsUnitAction (Heap, PairName) then
            SPARK_IO.Put_Line (Output_File, "        null .", 0);
         else
            -- print action;
            Action  := Cells.Get_C_Ptr (Heap, Pairs.PairHead (PairName));
            ModCell := Clists.FirstCell (Heap, Action);

            SPARK_IO.Put_String (Output_File, "        ", 0);
            Print_Cell_Contents
              (Heap          => Heap,
               Output_File   => Output_File,
               Cell_Name     => ModCell,
               Suppress_Wrap => Suppress_Wrap,
               Scope         => Scope,
               Wrap_Limit    => Wrap_Limit,
               Escape_DOT    => False);
            SPARK_IO.Put_String (Output_File, " := ", 0);
            PrintDag (Heap, Output_File, Cells.Get_B_Ptr (Heap, ModCell), Scope, Wrap_Limit);
            ModCell := Clists.NextCell (Heap, ModCell);

            loop
               exit when Cells.Is_Null_Cell (ModCell);

               SPARK_IO.Put_Line (Output_File, " &", 0);
               SPARK_IO.Put_String (Output_File, "        ", 0);
               Print_Cell_Contents
                 (Heap          => Heap,
                  Output_File   => Output_File,
                  Cell_Name     => ModCell,
                  Suppress_Wrap => Suppress_Wrap,
                  Scope         => Scope,
                  Wrap_Limit    => Wrap_Limit,
                  Escape_DOT    => False);
               SPARK_IO.Put_String (Output_File, " := ", 0);
               PrintDag (Heap, Output_File, Cells.Get_B_Ptr (Heap, ModCell), Scope, Wrap_Limit);
               ModCell := Clists.NextCell (Heap, ModCell);
            end loop;
            SPARK_IO.Put_Line (Output_File, " .", 0);
         end if;
      end PrintPair;

   begin -- PrintLabel
      PairCount   := 1;
      CurrentPair := Labels.FirstPair (Heap, LabelName);
      loop
         exit when Pairs.IsNullPair (CurrentPair);
         SPARK_IO.Put_String (Output_File, "    Path ", 0);
         SPARK_IO.Put_Integer (Output_File, PairCount, 2, 10);
         SPARK_IO.New_Line (Output_File, 1);
         PrintPair (Output_File, CurrentPair);
         PairCount   := PairCount + 1;
         CurrentPair := Labels.NextPair (Heap, CurrentPair);
      end loop;
   end PrintLabel;

   -------------------------------------------------------------------------

   procedure PrintVCFormula
     (Heap          : in out Cells.Heap_Record;
      Output_File   : in     SPARK_IO.File_Type;
      PredicatePair : in     Pairs.Pair;
      Scope         : in     Dictionary.Scopes;
      Wrap_Limit    : in     Positive)
   is
      ConclusionRoot, HypothesisRoot : Cells.Cell;

      -- GAA duplicated code from DECLARATIONS.ADB
      function IsTriviallyTrue (DAG : Cells.Cell) return Boolean
      --# global in Dictionary.Dict;
      --#        in Heap;
      is
         CurrentCell : Cells.Cell;
         Result      : Boolean := True;

         function IsTrueCell (TheCell : Cells.Cell) return Boolean
         --# global in Dictionary.Dict;
         --#        in Heap;
         is
         begin
            return Cells.Get_Kind (Heap, TheCell) = Cell_Storage.Named_Const
              and then Dictionary.IsEnumerationLiteral (Cells.Get_Symbol_Value (Heap, TheCell))
              and then Dictionary.Enumeration_Literals_Are_Equal
              (Left_Symbol  => Cells.Get_Symbol_Value (Heap, TheCell),
               Right_Symbol => Dictionary.GetTrue);
         end IsTrueCell;

         function AppropriateBinaryOperator (OpSym : SP_Symbols.SP_Symbol) return Boolean is
         begin
            return OpSym = SP_Symbols.RWand
              or else OpSym = SP_Symbols.RWandthen
              or else OpSym = SP_Symbols.RWor
              or else OpSym = SP_Symbols.RWorelse
              or else OpSym = SP_Symbols.equals
              or else OpSym = SP_Symbols.implies
              or else OpSym = SP_Symbols.is_equivalent_to;
         end AppropriateBinaryOperator;

      begin --IsTriviallyTrue
         CurrentCell := DAG;
         loop
            exit when IsTrueCell (CurrentCell); --success condition

            --some expression other than an operator - fail
            if Cells.Get_Kind (Heap, CurrentCell) /= Cell_Storage.Op then
               Result := False;
               exit;
            end if;

            --inappropriate operator - fail
            if not AppropriateBinaryOperator (Cells.Get_Op_Symbol (Heap, CurrentCell)) then
               Result := False;
               exit;
            end if;

            --thing on left of operator is not true - fail
            if not IsTrueCell (Cells.Get_A_Ptr (Heap, CurrentCell)) then
               Result := False;
               exit;
            end if;

            --move down right hand chain of tree to get next sub-expression
            CurrentCell := Cells.Get_B_Ptr (Heap, CurrentCell);

            --fallen off the end - fail - (I think this check is redundant but safe)
            if Cells.Is_Null_Cell (CurrentCell) then
               Result := False;
               exit;
            end if;

         end loop;
         return Result;
      end IsTriviallyTrue;

   begin --PrintVCFormula
      HypothesisRoot := Cells.Get_B_Ptr (Heap, Pairs.PairHead (PredicatePair));
      ConclusionRoot := Cells.Get_C_Ptr (Heap, Pairs.PairHead (PredicatePair));

      if IsTriviallyTrue (ConclusionRoot) then
         SPARK_IO.Put_Line (Output_File, "*** true .          /* trivially true VC removed by Examiner */", 0);
         SPARK_IO.New_Line (Output_File, 1);

      else
         PrintLogicalExpn (Heap, Output_File, Scope, HypothesisRoot, Hypothesis, Wrap_Limit);
         SPARK_IO.Put_Line (Output_File, "        ->", 0);
         PrintLogicalExpn (Heap, Output_File, Scope, ConclusionRoot, Conclusion, Wrap_Limit);
         SPARK_IO.Put_Line (Output_File, " ", 0);
      end if;
   end PrintVCFormula;

   -------------------------------------------------------------------------

   procedure PrintDPC
     (Heap          : in out Cells.Heap_Record;
      Output_File   : in     SPARK_IO.File_Type;
      PredicatePair : in     Pairs.Pair;
      Scope         : in     Dictionary.Scopes;
      Wrap_Limit    : in     Positive)
   is
      HypothesisRoot : Cells.Cell;
   begin -- PrintDPC
      HypothesisRoot := Cells.Get_B_Ptr (Heap, Pairs.PairHead (PredicatePair));

      PrintLogicalExpn (Heap, Output_File, Scope, HypothesisRoot, Hypothesis, Wrap_Limit);
      SPARK_IO.Put_Line (Output_File, "        ->", 0);
      SPARK_IO.Put_Line (Output_File, "C1:    false .", 0);
      SPARK_IO.Put_Line (Output_File, " ", 0);
   end PrintDPC;

   -------------------------------------------------------------------------

   procedure Print_DAG_Dot
     (Heap        : in out Cells.Heap_Record;
      Output_File : in     SPARK_IO.File_Type;
      Root        : in     Cells.Cell;
      Scope       : in     Dictionary.Scopes;
      Wrap_Limit  : in     Positive)
   is
      -- This procedure uses a recursive DAG traversal, so is not
      -- SPARK.

      --# hide Print_DAG_Dot;

      type Edge_Class is (A, B);

      function Cell_Kind_Image (K : in Cells.Cell_Kind) return String is
         --# hide Cell_Kind_Image;
      begin
         case K is
            when Cell_Storage.Manifest_Const =>
               return "Manifest_Const";
            when Cell_Storage.Attrib_Value =>
               return "Attrib_Value";
            when Cell_Storage.Attrib_Function =>
               return "Attrib_Function";
            when Cell_Storage.Field_Access_Function =>
               return "Field_Access_Function";
            when Cell_Storage.Field_Update_Function =>
               return "Field_Update_Function";
            when Cell_Storage.Element_Function =>
               return "Element_Function";
            when Cell_Storage.Update_Function =>
               return "Update_Function";
            when Cell_Storage.Pred_Function =>
               return "Pred_Function";
            when Cell_Storage.Succ_Function =>
               return "Succ_Function";
            when Cell_Storage.Abs_Function =>
               return "Abs_Function";
            when Cell_Storage.Trunc_Function =>
               return "Trunc_Function";
            when Cell_Storage.List_Function =>
               return "List_Function";
            when Cell_Storage.FDL_Div_Op =>
               return "FDL_Div_Op";
            when Cell_Storage.Op =>
               return "Op";
            when Cell_Storage.Named_Const =>
               return "Named_Const";
            when Cell_Storage.Declared_Function =>
               return "Declared_Function";
            when Cell_Storage.Proof_Function =>
               return "Proof_Function";
            when Cell_Storage.Modified_Op =>
               return "Modified";
            when Cell_Storage.Reference =>
               return "Reference";
            when Cell_Storage.Constraining_Index =>
               return "Constraining_Index";
            when Cell_Storage.Fixed_Var =>
               return "Fixed_Var";
            when Cell_Storage.Unconstrained_Attribute_Prefix =>
               return "Uncon_Attribute_Prefix";
            when Cell_Storage.Mk_Aggregate =>
               return "Mk_Aggregate";
            when Cell_Storage.Procedure_Export =>
               return "Procedure_Export";
            when Cell_Storage.Procedure_Name =>
               return "Procedure_Name";
            when Cell_Storage.Pending_Function =>
               return "Pending_Function";
            when Cell_Storage.Aggregate_Counter =>
               return "Aggregate_Counter";
            when Cell_Storage.Call_Counter =>
               return "Call_Counter";
            when Cell_Storage.Incomplete_Aggregate =>
               return "Incomplete_Aggregate";
            when Cell_Storage.Return_Var =>
               return "Return_Var";
            when Cell_Storage.Root_Integer =>
               return "Root_Integer";
            when Cell_Storage.Bitwise_Op =>
               return "Bitwise_Op";
            when Cell_Storage.Function_Call_In_Proof_Context =>
               return "Function_Call_In_Proof_Context";
            when Cell_Storage.Proof_Function_Obtain_Precondition =>
               return "Proof_Function_Obtain_Precondition";
            when Cell_Storage.Proof_Function_Obtain_Return =>
               return "Proof_Function_Obtain_Return";
            when Cell_Storage.Proof_Function_Syntax_Node =>
               return "Proof_Function_Syntax_Node";
            when Cell_Storage.Quantifier =>
               return "Quantifier";
            when Cell_Storage.Internal_Natural =>
               return "Internal_Natural";
            when Cell_Storage.Internal_Scope =>
               return "Internal_Scope";
            when Cell_Storage.Unknown_Kind =>
               return "Unknown";
         end case;
      end Cell_Kind_Image;

      procedure Print_Node (Root : in Cells.Cell;
                            Rank : in Natural) is
         pragma Unreferenced (Rank);
         Suppress_Wrap : Boolean := False;
      begin
         SPARK_IO.Put_String (Output_File, Natural'Image (Cells.Cell_Ref (Root)) & " [shape=record,label=""{{", 0);
         SPARK_IO.Put_String
           (Output_File,
            Cell_Kind_Image (Cells.Get_Kind (Heap, Root)) & "\l|" & Natural'Image (Cells.Cell_Ref (Root)) & "\r}|",
            0);

         Print_Cell_Contents
           (Heap          => Heap,
            Output_File   => Output_File,
            Cell_Name     => Root,
            Suppress_Wrap => Suppress_Wrap,
            Scope         => Scope,
            Wrap_Limit    => Wrap_Limit,
            Escape_DOT    => True);
         SPARK_IO.Put_Line (Output_File, "}""];", 0);
      end Print_Node;

      procedure Print_Edge (Head, Tail : in Cells.Cell;
                            Class      : in Edge_Class) is
      begin
         if not Cells.Is_Null_Cell (Tail) then
            SPARK_IO.Put_String
              (Output_File,
               Natural'Image (Cells.Cell_Ref (Head)) & " ->" & Natural'Image (Cells.Cell_Ref (Tail)) & "[style=solid,label=",
               0);
            SPARK_IO.Put_String (Output_File, Edge_Class'Image (Class), 0);
            SPARK_IO.Put_Line (Output_File, "];", 0);
         end if;
      end Print_Edge;

      procedure Traverse_DAG (Root : in Cells.Cell;
                              Rank : in Natural) is
         A_Child : Cells.Cell;
         B_Child : Cells.Cell;
      begin
         if Cells.Is_Null_Cell (Root) then
            null;
         else
            Print_Node (Root, Rank);

            A_Child := Cells.Get_A_Ptr (Heap, Root);
            B_Child := Cells.Get_B_Ptr (Heap, Root);

            -- If the A_Child is not null and not pointing
            -- at itself, then print the edge and that sub-dag.
            if (not Cells.Is_Null_Cell (A_Child)) and then (A_Child /= Root) then
               Print_Edge (Root, A_Child, A);
               Traverse_DAG (A_Child, Rank + 1);
            end if;

            -- If the B_Child is not null and not pointing
            -- at itself, then print the edge and that sub-dag.
            if (not Cells.Is_Null_Cell (B_Child)) and then (B_Child /= Root) then
               Print_Edge (Root, B_Child, B);
               Traverse_DAG (B_Child, Rank + 1);
            end if;
         end if;

      end Traverse_DAG;
   begin
      SPARK_IO.Put_Line (Output_File, "digraph DAG {", 0);
      SPARK_IO.Put_Line (Output_File, "ranksep=""1.0 equally"";", 0);
      SPARK_IO.Put_Line (Output_File, "nodesep=1.0;", 0);
      SPARK_IO.Put_Line (Output_File, "node [shape=box,fontname=helvetica];", 0);
      SPARK_IO.Put_Line (Output_File, "edge [labelfontname=helvetica,labelfontsize=10];", 0);

      Traverse_DAG (Root, 0);

      SPARK_IO.Put_Line (Output_File, "}", 0);
   end Print_DAG_Dot;

   procedure Print_Heap_Dot (Heap        : in out Cells.Heap_Record;
                             Output_File : in     SPARK_IO.File_Type) is
      --# hide Print_Heap_Dot;

      type Edge_Class is (A, B);

      function Cell_Kind_Image (K : in Cells.Cell_Kind) return String is
         --# hide Cell_Kind_Image;
      begin
         case K is
            when Cell_Storage.Manifest_Const =>
               return "Manifest_Const";
            when Cell_Storage.Attrib_Value =>
               return "Attrib_Value";
            when Cell_Storage.Attrib_Function =>
               return "Attrib_Function";
            when Cell_Storage.Field_Access_Function =>
               return "Field_Access_Function";
            when Cell_Storage.Field_Update_Function =>
               return "Field_Update_Function";
            when Cell_Storage.Element_Function =>
               return "Element_Function";
            when Cell_Storage.Update_Function =>
               return "Update_Function";
            when Cell_Storage.Pred_Function =>
               return "Pred_Function";
            when Cell_Storage.Succ_Function =>
               return "Succ_Function";
            when Cell_Storage.Abs_Function =>
               return "Abs_Function";
            when Cell_Storage.Trunc_Function =>
               return "Trunc_Function";
            when Cell_Storage.List_Function =>
               return "List_Function";
            when Cell_Storage.FDL_Div_Op =>
               return "FDL_Div_Op";
            when Cell_Storage.Op =>
               return "Op";
            when Cell_Storage.Named_Const =>
               return "Named_Const";
            when Cell_Storage.Declared_Function =>
               return "Declared_Function";
            when Cell_Storage.Proof_Function =>
               return "Proof_Function";
            when Cell_Storage.Modified_Op =>
               return "Modified";
            when Cell_Storage.Reference =>
               return "Reference";
            when Cell_Storage.Constraining_Index =>
               return "Constraining_Index";
            when Cell_Storage.Fixed_Var =>
               return "Fixed_Var";
            when Cell_Storage.Unconstrained_Attribute_Prefix =>
               return "Uncon_Attribute_Prefix";
            when Cell_Storage.Mk_Aggregate =>
               return "Mk_Aggregate";
            when Cell_Storage.Procedure_Export =>
               return "Procedure_Export";
            when Cell_Storage.Procedure_Name =>
               return "Procedure_Name";
            when Cell_Storage.Pending_Function =>
               return "Pending_Function";
            when Cell_Storage.Aggregate_Counter =>
               return "Aggregate_Counter";
            when Cell_Storage.Call_Counter =>
               return "Call_Counter";
            when Cell_Storage.Incomplete_Aggregate =>
               return "Incomplete_Aggregate";
            when Cell_Storage.Return_Var =>
               return "Return_Var";
            when Cell_Storage.Root_Integer =>
               return "Root_Integer";
            when Cell_Storage.Bitwise_Op =>
               return "Bitwise_Op";
            when Cell_Storage.Function_Call_In_Proof_Context =>
               return "Function_Call_In_Proof_Context";
            when Cell_Storage.Proof_Function_Obtain_Precondition =>
               return "Proof_Function_Obtain_Precondition";
            when Cell_Storage.Proof_Function_Obtain_Return =>
               return "Proof_Function_Obtain_Return";
            when Cell_Storage.Proof_Function_Syntax_Node =>
               return "Proof_Function_Syntax_Node";
            when Cell_Storage.Quantifier =>
               return "Quantifier";
            when Cell_Storage.Internal_Natural =>
               return "Internal_Natural";
            when Cell_Storage.Internal_Scope =>
               return "Internal_Scope";
            when Cell_Storage.Unknown_Kind =>
               return "Unknown";
         end case;
      end Cell_Kind_Image;

      procedure Print_Node (Root : in Cells.Cell) is
         Suppress_Wrap : Boolean := True;
      begin
         SPARK_IO.Put_String (Output_File, Natural'Image (Cells.Cell_Ref (Root)) & " [shape=record,label=""{{", 0);
         SPARK_IO.Put_String
           (Output_File,
            Cell_Kind_Image (Cells.Get_Kind (Heap, Root)) & "\l|" & Natural'Image (Cells.Cell_Ref (Root)) & "\r}|",
            0);

         Print_Cell_Contents
           (Heap          => Heap,
            Output_File   => Output_File,
            Cell_Name     => Root,
            Suppress_Wrap => Suppress_Wrap,
            Scope         => Dictionary.GlobalScope,
            Wrap_Limit    => No_Wrap,
            Escape_DOT    => True);
         SPARK_IO.Put_Line (Output_File, "}""];", 0);
      end Print_Node;

      procedure Print_Edge (Head, Tail : in Cells.Cell;
                            Class      : in Edge_Class) is
      begin
         if not Cells.Is_Null_Cell (Tail) then
            SPARK_IO.Put_String
              (Output_File,
               Natural'Image (Cells.Cell_Ref (Head)) & " ->" & Natural'Image (Cells.Cell_Ref (Tail)) & "[style=solid,label=",
               0);
            SPARK_IO.Put_String (Output_File, Edge_Class'Image (Class), 0);
            SPARK_IO.Put_Line (Output_File, "];", 0);
         end if;
      end Print_Edge;

      procedure Print_Node_And_Edge (Root : in Cells.Cell) is
         A_Child : Cells.Cell;
         B_Child : Cells.Cell;
      begin
         if Cells.Is_Null_Cell (Root) then
            null;
         else
            Print_Node (Root);

            A_Child := Cells.Get_A_Ptr (Heap, Root);
            B_Child := Cells.Get_B_Ptr (Heap, Root);

            -- If the A_Child is not null and not pointing
            -- at itself, then print the edge and that sub-dag.
            if (not Cells.Is_Null_Cell (A_Child)) and then (A_Child /= Root) then
               Print_Edge (Root, A_Child, A);
            end if;

            -- If the B_Child is not null and not pointing
            -- at itself, then print the edge and that sub-dag.
            if (not Cells.Is_Null_Cell (B_Child)) and then (B_Child /= Root) then
               Print_Edge (Root, B_Child, B);
            end if;
         end if;

      end Print_Node_And_Edge;

   begin
      SPARK_IO.Put_Line (Output_File, "digraph DAG {", 0);
      SPARK_IO.Put_Line (Output_File, "ranksep=""1.0 equally"";", 0);
      SPARK_IO.Put_Line (Output_File, "nodesep=1.0;", 0);
      SPARK_IO.Put_Line (Output_File, "node [shape=box,fontname=helvetica];", 0);
      SPARK_IO.Put_Line (Output_File, "edge [labelfontname=helvetica,labelfontsize=10];", 0);

      for C in Cell_Storage.Cell range 0 .. Cells.Get_Heap_Size (Heap) loop
         if not Cells.Is_Free (Heap, C) then
            Print_Node_And_Edge (C);
         end if;
      end loop;

      SPARK_IO.Put_Line (Output_File, "}", 0);
   end Print_Heap_Dot;

end DAG_IO;
