xgnatugn.adb

理解和实践操作系统的一本好书

   end Process_Source_File;

   ---------------------------
   -- Initialize_Extensions --
   ---------------------------

   procedure Initialize_Extensions is

      procedure Add (Extension : String);
      --  Adds an extension which is replaced with itself (in upper
      --  case).

      procedure Add (Extension, Replacement : String);
      --  Adds an extension with a custom replacement

      ---------
      -- Add --
      ---------

      procedure Add (Extension : String) is
      begin
         Add (Extension, Translate (Extension, Upper_Case_Map));
      end Add;

      procedure Add (Extension, Replacement : String) is
      begin
         Set (Extensions, Extension, V (Replacement));
      end Add;

   --  Start of processing for Initialize_Extensions

   begin
      --  To avoid performance degradation, increase the constant in the
      --  definition of Extensions above if you add more extensions here.

      Add ("o", "OBJ");
      Add ("ads");
      Add ("adb");
      Add ("ali");
      Add ("ada");
      Add ("atb");
      Add ("ats");
      Add ("adc");
      Add ("c");
   end Initialize_Extensions;

   ------------------
   -- Is_Extension --
   ------------------

   function Is_Extension (Extension : String) return Boolean is
   begin
      return Present (Extensions, Extension);
   end Is_Extension;

   -------------------------------
   -- Get_Replacement_Extension --
   -------------------------------

   function Get_Replacement_Extension (Extension : String) return String is
   begin
      return S (Get (Extensions, Extension));
   end Get_Replacement_Extension;

   -------------------
   -- Is_Known_Word --
   -------------------

   function Is_Known_Word (Word : String) return Boolean is
   begin
      return Present (Ug_Words, Word);
   end Is_Known_Word;

   --------------------------
   -- Get_Replacement_Word --
   --------------------------

   function Get_Replacement_Word (Word : String) return String is
   begin
      return S (Get (Ug_Words, Word));
   end Get_Replacement_Word;

   ----------------------
   -- Push_Conditional --
   ----------------------

   procedure Push_Conditional (Cond : Conditional; Flag : Target_Type) is
      Will_Exclude : Boolean;

   begin
      --  If we are already in an excluding context, inherit this property,
      --  otherwise calculate it from scratch.

      if Conditional_TOS > 0
        and then Conditional_Stack (Conditional_TOS).Excluding
      then
         Will_Exclude := True;
      else
         case Cond is
            when Set =>
               Will_Exclude := Flag /= Target;
            when Clear =>
               Will_Exclude := Flag = Target;
         end case;
      end if;

      --  Check if the current directive is pointless because of a previous,
      --  enclosing directive.

      for J in 1 .. Conditional_TOS loop
         if Conditional_Stack (J).Flag = Flag then
            Warning (Source_File, "directive without effect because of line"
                     & Integer'Image (Conditional_Stack (J).Starting_Line));
         end if;
      end loop;

      Conditional_TOS := Conditional_TOS + 1;
      Conditional_Stack (Conditional_TOS) :=
        (Starting_Line => Source_File.Line,
         Cond          => Cond,
         Flag          => Flag,
         Excluding     => Will_Exclude);
   end Push_Conditional;

   ---------------------
   -- Pop_Conditional --
   ---------------------

   procedure Pop_Conditional (Cond : Conditional) is
   begin
      if Conditional_TOS > 0 then
         case Cond is
            when Set =>
               if Conditional_Stack (Conditional_TOS).Cond /= Set then
                  Error (Source_File,
                         "'@end ifset' does not match '@ifclear' at line"
                         & Integer'Image (Conditional_Stack
                                          (Conditional_TOS).Starting_Line));
               end if;

            when Clear =>
               if Conditional_Stack (Conditional_TOS).Cond /= Clear then
                  Error (Source_File,
                         "'@end ifclear' does not match '@ifset' at line"
                         & Integer'Image (Conditional_Stack
                                          (Conditional_TOS).Starting_Line));
               end if;
         end case;

         Conditional_TOS := Conditional_TOS - 1;

      else
         case Cond is
            when Set =>
               Error (Source_File,
                      "'@end ifset' without corresponding '@ifset'");

            when Clear =>
               Error (Source_File,
                      "'@end ifclear' without corresponding '@ifclear'");
         end case;
      end if;
   end Pop_Conditional;

   -------------------------
   -- Currently_Excluding --
   -------------------------

   function Currently_Excluding return Boolean is
   begin
      return Conditional_TOS > 0
        and then Conditional_Stack (Conditional_TOS).Excluding;
   end Currently_Excluding;

   ----------------------------
   -- VMS_Context_Determined --
   ----------------------------

   function VMS_Context_Determined return Boolean is
   begin
      for J in 1 .. Conditional_TOS loop
         if Conditional_Stack (J).Flag = VMS then
            return True;
         end if;
      end loop;

      return False;
   end VMS_Context_Determined;

   --------------------
   -- In_VMS_Section --
   --------------------

   function In_VMS_Section return Boolean is
   begin
      for J in 1 .. Conditional_TOS loop
         if Conditional_Stack (J).Flag = VMS then
            return Conditional_Stack (J).Cond = Set;
         end if;
      end loop;

      return False;
   end In_VMS_Section;

   ----------------------------------
   -- Check_No_Pending_Conditional --
   ----------------------------------

   procedure Check_No_Pending_Conditional is
   begin
      for J in 1 .. Conditional_TOS loop
         case Conditional_Stack (J).Cond is
            when Set =>
               Error (Source_File, "Missing '@end ifset' for '@ifset' at line"
                      & Integer'Image (Conditional_Stack (J).Starting_Line));

            when Clear =>
               Error (Source_File,
                      "Missing '@end ifclear' for '@ifclear' at line"
                      & Integer'Image (Conditional_Stack (J).Starting_Line));
         end case;
      end loop;
   end Check_No_Pending_Conditional;

--  Start of processing for Xgnatugn

   Valid_Command_Line : Boolean;
   Output_File_Name   : VString;

begin
   Initialize_Extensions;
   Valid_Command_Line := Argument_Count in 3 .. 5;

   --  First argument: Target

   if Valid_Command_Line then
      begin
         Target := Flag_Type'Value (Argument (1));

         if not Target'Valid then
            Valid_Command_Line := False;
         end if;

      exception
         when Constraint_Error =>
            Valid_Command_Line := False;
      end;
   end if;

   --  Second argument: Source_File

   if Valid_Command_Line then
      begin
         Source_File.Name := V (Argument (2));
         Open (Source_File.Data, In_File, Argument (2));

      exception
         when Name_Error =>
            Valid_Command_Line := False;
      end;
   end if;

   --  Third argument: Dictionary_File

   if Valid_Command_Line then
      begin
         Dictionary_File.Name := V (Argument (3));
         Open (Dictionary_File.Data, In_File, Argument (3));

      exception
         when Name_Error =>
            Valid_Command_Line := False;
      end;
   end if;

   --  Fourth argument: Output_File

   if Valid_Command_Line then
      if Argument_Count in 4 .. 5 then
         Output_File_Name := V (Argument (4));
      else
         case Target is
            when UNW =>
               Output_File_Name := V ("gnat_ugn_unw.texi");
            when VMS =>
               Output_File_Name := V ("gnat_ugn_vms.texi");
         end case;
      end if;

      Warnings_Enabled := Argument_Count = 5;

      begin
         Create (Output_File, Out_File, S (Output_File_Name));

      exception
         when Name_Error | Use_Error =>
            Valid_Command_Line := False;
      end;
   end if;

   if not Valid_Command_Line then
      Usage;
      Set_Exit_Status (Failure);

   else
      Read_Dictionary_File;
      Close (Dictionary_File.Data);

      --  Main processing starts here

      Process_Source_File;
      Close (Output_File);
      Close (Source_File.Data);

      New_Line (Standard_Error);

      if Number_Of_Warnings = 0 then
         Put_Line (Standard_Error, " NO Warnings");

      else
         Put (Standard_Error, Integer'Image (Number_Of_Warnings));
         Put (Standard_Error, " Warning");

         if Number_Of_Warnings > 1 then
            Put (Standard_Error, "s");
         end if;

         New_Line (Standard_Error);
      end if;

      if Number_Of_Errors = 0 then
         Put_Line (Standard_Error, " NO Errors");

      else
         Put (Standard_Error, Integer'Image (Number_Of_Errors));
         Put (Standard_Error, " Error");

         if Number_Of_Errors > 1 then
            Put (Standard_Error, "s");
         end if;

         New_Line (Standard_Error);
      end if;

      if Number_Of_Errors /= 0  then
         Set_Exit_Status (Failure);
      else
         Set_Exit_Status (Success);
      end if;
   end if;
end Xgnatugn;