1------------------------------------------------------------------------------
2--                                                                          --
3--                         GNAT COMPILER COMPONENTS                         --
4--                                                                          --
5--                             S I N P U T . P                              --
6--                                                                          --
7--                                 B o d y                                  --
8--                                                                          --
9--          Copyright (C) 1992-2012, Free Software Foundation, Inc.         --
10--                                                                          --
11-- GNAT is free software;  you can  redistribute it  and/or modify it under --
12-- terms of the  GNU General Public License as published  by the Free Soft- --
13-- ware  Foundation;  either version 3,  or (at your option) any later ver- --
14-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
15-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
16-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
17-- for  more details.  You should have  received  a copy of the GNU General --
18-- Public License  distributed with GNAT; see file COPYING3.  If not, go to --
19-- http://www.gnu.org/licenses for a complete copy of the license.          --
20--                                                                          --
21-- GNAT was originally developed  by the GNAT team at  New York University. --
22-- Extensive contributions were provided by Ada Core Technologies Inc.      --
23--                                                                          --
24------------------------------------------------------------------------------
25
26with Ada.Unchecked_Conversion;
27with Ada.Unchecked_Deallocation;
28
29with Prj.Err;
30with Sinput.C;
31
32with System;
33
34package body Sinput.P is
35
36   First : Boolean := True;
37   --  Flag used when Load_Project_File is called the first time,
38   --  to set Main_Source_File.
39   --  The flag is reset to False at the first call to Load_Project_File.
40   --  Calling Reset_First sets it back to True.
41
42   procedure Free is new Ada.Unchecked_Deallocation
43     (Lines_Table_Type, Lines_Table_Ptr);
44
45   procedure Free is new Ada.Unchecked_Deallocation
46     (Logical_Lines_Table_Type, Logical_Lines_Table_Ptr);
47
48   -----------------------------
49   -- Clear_Source_File_Table --
50   -----------------------------
51
52   procedure Clear_Source_File_Table is
53      use System;
54
55   begin
56      for X in 1 .. Source_File.Last loop
57         declare
58            S  : Source_File_Record renames Source_File.Table (X);
59            Lo : constant Source_Ptr := S.Source_First;
60            Hi : constant Source_Ptr := S.Source_Last;
61            subtype Actual_Source_Buffer is Source_Buffer (Lo .. Hi);
62            --  Physical buffer allocated
63
64            type Actual_Source_Ptr is access Actual_Source_Buffer;
65            --  This is the pointer type for the physical buffer allocated
66
67            procedure Free is new Ada.Unchecked_Deallocation
68              (Actual_Source_Buffer, Actual_Source_Ptr);
69
70            pragma Suppress (All_Checks);
71
72            pragma Warnings (Off);
73            --  The following unchecked conversion is aliased safe, since it
74            --  is not used to create improperly aliased pointer values.
75
76            function To_Actual_Source_Ptr is new
77              Ada.Unchecked_Conversion (Address, Actual_Source_Ptr);
78
79            pragma Warnings (On);
80
81            Actual_Ptr : Actual_Source_Ptr :=
82                           To_Actual_Source_Ptr (S.Source_Text (Lo)'Address);
83
84         begin
85            Free (Actual_Ptr);
86            Free (S.Lines_Table);
87            Free (S.Logical_Lines_Table);
88         end;
89      end loop;
90
91      Source_File.Free;
92      Sinput.Initialize;
93   end Clear_Source_File_Table;
94
95   -----------------------
96   -- Load_Project_File --
97   -----------------------
98
99   function Load_Project_File (Path : String) return Source_File_Index is
100      X : Source_File_Index;
101
102   begin
103      X := Sinput.C.Load_File (Path);
104
105      if First then
106         Main_Source_File := X;
107         First := False;
108      end if;
109
110      return X;
111   end Load_Project_File;
112
113   -----------------
114   -- Reset_First --
115   -----------------
116
117   procedure Reset_First is
118   begin
119      First := True;
120   end Reset_First;
121
122   --------------------------------
123   -- Restore_Project_Scan_State --
124   --------------------------------
125
126   procedure Restore_Project_Scan_State
127     (Saved_State : Saved_Project_Scan_State)
128   is
129   begin
130      Restore_Scan_State (Saved_State.Scan_State);
131      Source              := Saved_State.Source;
132      Current_Source_File := Saved_State.Current_Source_File;
133   end Restore_Project_Scan_State;
134
135   -----------------------------
136   -- Save_Project_Scan_State --
137   -----------------------------
138
139   procedure Save_Project_Scan_State
140     (Saved_State : out Saved_Project_Scan_State)
141   is
142   begin
143      Save_Scan_State (Saved_State.Scan_State);
144      Saved_State.Source              := Source;
145      Saved_State.Current_Source_File := Current_Source_File;
146   end Save_Project_Scan_State;
147
148   ----------------------------
149   -- Source_File_Is_Subunit --
150   ----------------------------
151
152   function Source_File_Is_Subunit (X : Source_File_Index) return Boolean is
153   begin
154      --  Nothing to do if X is no source file, so simply return False
155
156      if X = No_Source_File then
157         return False;
158      end if;
159
160      Prj.Err.Scanner.Initialize_Scanner (X);
161
162      --  No error for special characters that are used for preprocessing
163
164      Prj.Err.Scanner.Set_Special_Character ('#');
165      Prj.Err.Scanner.Set_Special_Character ('$');
166
167      Check_For_BOM;
168
169      --  We scan past junk to the first interesting compilation unit token, to
170      --  see if it is SEPARATE. We ignore WITH keywords during this and also
171      --  PRIVATE. The reason for ignoring PRIVATE is that it handles some
172      --  error situations, and also to handle PRIVATE WITH in Ada 2005 mode.
173
174      while Token = Tok_With
175        or else Token = Tok_Private
176        or else (Token not in Token_Class_Cunit and then Token /= Tok_EOF)
177      loop
178         Prj.Err.Scanner.Scan;
179      end loop;
180
181      Prj.Err.Scanner.Reset_Special_Characters;
182
183      return Token = Tok_Separate;
184   end Source_File_Is_Subunit;
185
186end Sinput.P;
187