1------------------------------------------------------------------------------ 2-- -- 3-- GNAT SYSTEM UTILITIES -- 4-- -- 5-- X S N A M E S T -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1992-2020, 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 26-- This utility is used to make a new version of the Snames package when new 27-- names are added. This version reads a template file from snames.ads-tmpl in 28-- which the numbers are all written as $, and generates a new version of the 29-- spec file snames.ads (written to snames.ns). It also reads snames.adb-tmpl 30-- and generates an updated body (written to snames.nb), and snames.h-tmpl and 31-- generates an updated C header file (written to snames.nh). 32 33with Ada.Strings.Unbounded; use Ada.Strings.Unbounded; 34with Ada.Strings.Unbounded.Text_IO; use Ada.Strings.Unbounded.Text_IO; 35with Ada.Strings.Maps; use Ada.Strings.Maps; 36with Ada.Strings.Maps.Constants; use Ada.Strings.Maps.Constants; 37with Ada.Text_IO; use Ada.Text_IO; 38with Ada.Streams.Stream_IO; use Ada.Streams.Stream_IO; 39 40with GNAT.Spitbol; use GNAT.Spitbol; 41with GNAT.Spitbol.Patterns; use GNAT.Spitbol.Patterns; 42 43with XUtil; use XUtil; 44 45procedure XSnamesT is 46 47 subtype VString is GNAT.Spitbol.VString; 48 49 InS : Ada.Text_IO.File_Type; 50 InB : Ada.Text_IO.File_Type; 51 InH : Ada.Text_IO.File_Type; 52 53 OutS : Ada.Streams.Stream_IO.File_Type; 54 OutB : Ada.Streams.Stream_IO.File_Type; 55 OutH : Ada.Streams.Stream_IO.File_Type; 56 57 A, B : VString := Nul; 58 Line : VString := Nul; 59 Name0 : VString := Nul; 60 Name1 : VString := Nul; 61 Name2 : VString := Nul; 62 Oval : VString := Nul; 63 Restl : VString := Nul; 64 65 Name_Ref : constant Pattern := Span (' ') * A & Break (' ') * Name0 66 & Span (' ') * B 67 & ": constant Name_Id := N + $;" 68 & Rest * Restl; 69 70 Get_Name : constant Pattern := "Name_" & Rest * Name1; 71 Chk_Low : constant Pattern := Pos (0) & Any (Lower_Set) & Rest & Pos (1); 72 Findu : constant Pattern := Span ('u') * A; 73 Is_Conv : constant Pattern := "Convention_" & Rest; 74 75 Val : Natural; 76 77 Xlate_U_Und : constant Character_Mapping := To_Mapping ("u", "_"); 78 79 M : Match_Result; 80 81 type Header_Symbol is (None, Name, Attr, Conv, Prag); 82 -- A symbol in the header file 83 84 procedure Output_Header_Line (S : Header_Symbol); 85 -- Output header line 86 87 Header_Name : aliased String := "Name"; 88 Header_Attr : aliased String := "Attr"; 89 Header_Conv : aliased String := "Convention"; 90 Header_Prag : aliased String := "Pragma"; 91 -- Prefixes used in the header file 92 93 type String_Ptr is access all String; 94 Header_Prefix : constant array (Header_Symbol) of String_Ptr := 95 (null, 96 Header_Name'Access, 97 Header_Attr'Access, 98 Header_Conv'Access, 99 Header_Prag'Access); 100 101 -- Patterns used in the spec file 102 103 Get_Attr : constant Pattern := Span (' ') & "Attribute_" 104 & Break (",)") * Name1; 105 Get_Conv : constant Pattern := Span (' ') & "Convention_" 106 & Break (",)") * Name1; 107 Get_Prag : constant Pattern := Span (' ') & "Pragma_" 108 & Break (",)") * Name1; 109 Get_Subt1 : constant Pattern := Span (' ') & "subtype " 110 & Break (' ') * Name1 111 & " is " & Rest * Name2; 112 Get_Subt2 : constant Pattern := Span (' ') & "range " 113 & Break (' ') * Name1 114 & " .. " & Break (";") * Name2; 115 116 type Header_Symbol_Counter is array (Header_Symbol) of Natural; 117 Header_Counter : Header_Symbol_Counter := (0, 0, 0, 0, 0); 118 119 Header_Current_Symbol : Header_Symbol := None; 120 Header_Pending_Line : VString := Nul; 121 122 ------------------------ 123 -- Output_Header_Line -- 124 ------------------------ 125 126 procedure Output_Header_Line (S : Header_Symbol) is 127 function Make_Value (V : Integer) return String; 128 -- Build the definition for the current macro (Names are integers 129 -- offset to N, while other items are enumeration values). 130 131 ---------------- 132 -- Make_Value -- 133 ---------------- 134 135 function Make_Value (V : Integer) return String is 136 begin 137 if S = Name then 138 return "(First_Name_Id + 256 + " & V & ")"; 139 else 140 return "" & V; 141 end if; 142 end Make_Value; 143 144 -- Start of processing for Output_Header_Line 145 146 begin 147 -- Skip all the #define for S-prefixed symbols in the header. 148 -- Of course we are making implicit assumptions: 149 -- (1) No newline between symbols with the same prefix. 150 -- (2) Prefix order is the same as in snames.ads. 151 152 if Header_Current_Symbol /= S then 153 declare 154 Pat : constant Pattern := "#define " 155 & Header_Prefix (S).all 156 & Break (' ') * Name2; 157 In_Pat : Boolean := False; 158 159 begin 160 if Header_Current_Symbol /= None then 161 Put_Line (OutH, Header_Pending_Line); 162 end if; 163 164 loop 165 Line := Get_Line (InH); 166 167 if Match (Line, Pat) then 168 In_Pat := True; 169 elsif In_Pat then 170 Header_Pending_Line := Line; 171 exit; 172 else 173 Put_Line (OutH, Line); 174 end if; 175 end loop; 176 177 Header_Current_Symbol := S; 178 end; 179 end if; 180 181 -- Now output the line 182 183 -- Note that we must ensure at least one space between macro name and 184 -- parens, otherwise the parenthesized value gets treated as an argument 185 -- specification. 186 187 Put_Line (OutH, "#define " & Header_Prefix (S).all 188 & "_" & Name1 189 & (30 - Natural'Min (29, Length (Name1))) * ' ' 190 & Make_Value (Header_Counter (S))); 191 Header_Counter (S) := Header_Counter (S) + 1; 192 end Output_Header_Line; 193 194-- Start of processing for XSnames 195 196begin 197 Open (InS, In_File, "snames.ads-tmpl"); 198 Open (InB, In_File, "snames.adb-tmpl"); 199 Open (InH, In_File, "snames.h-tmpl"); 200 201 -- Note that we do not generate snames.{ads,adb,h} directly. Instead 202 -- we output them to snames.n{s,b,h} so that Makefiles can use 203 -- move-if-change to not touch previously generated files if the 204 -- new ones are identical. 205 206 Create (OutS, Out_File, "snames.ns"); 207 Create (OutB, Out_File, "snames.nb"); 208 Create (OutH, Out_File, "snames.nh"); 209 210 Put_Line (OutH, "#ifdef __cplusplus"); 211 Put_Line (OutH, "extern ""C"" {"); 212 Put_Line (OutH, "#endif"); 213 214 Anchored_Mode := True; 215 Val := 0; 216 217 loop 218 Line := Get_Line (InB); 219 exit when Match (Line, " Preset_Names"); 220 Put_Line (OutB, Line); 221 end loop; 222 223 Put_Line (OutB, Line); 224 225 LoopN : while not End_Of_File (InS) loop 226 Line := Get_Line (InS); 227 228 if not Match (Line, Name_Ref) then 229 Put_Line (OutS, Line); 230 231 if Match (Line, Get_Attr) then 232 Output_Header_Line (Attr); 233 elsif Match (Line, Get_Conv) then 234 Output_Header_Line (Conv); 235 elsif Match (Line, Get_Prag) then 236 Output_Header_Line (Prag); 237 elsif Match (Line, Get_Subt1) and then Match (Name2, Is_Conv) then 238 New_Line (OutH); 239 Put_Line (OutH, "SUBTYPE (" & Name1 & ", " & Name2 & ", "); 240 elsif Match (Line, Get_Subt2) and then Match (Name1, Is_Conv) then 241 Put_Line (OutH, " " & Name1 & ", " & Name2 & ')'); 242 end if; 243 else 244 245 if Match (Name0, "Last_") then 246 Oval := Lpad (V (Val - 1), 3, '0'); 247 else 248 Oval := Lpad (V (Val), 3, '0'); 249 end if; 250 251 Put_Line 252 (OutS, A & Name0 & B & ": constant Name_Id := N + " 253 & Oval & ';' & Restl); 254 255 if Match (Name0, Get_Name) then 256 Name0 := Name1; 257 Val := Val + 1; 258 259 if Match (Name0, Findu, M) then 260 Replace (M, Translate (A, Xlate_U_Und)); 261 Translate (Name0, Lower_Case_Map); 262 263 elsif Match (Name0, "UP_", "") then 264 Translate (Name0, Upper_Case_Map); 265 266 elsif Match (Name0, "Op_", "") then 267 Name0 := 'O' & Translate (Name0, Lower_Case_Map); 268 269 else 270 Translate (Name0, Lower_Case_Map); 271 end if; 272 273 if not Match (Name0, Chk_Low) then 274 Put_Line (OutB, " """ & Name0 & "#"" &"); 275 end if; 276 277 Output_Header_Line (Name); 278 end if; 279 end if; 280 end loop LoopN; 281 282 loop 283 Line := Get_Line (InB); 284 exit when Match (Line, " ""#"";"); 285 end loop; 286 287 Put_Line (OutB, Line); 288 289 while not End_Of_File (InB) loop 290 Line := Get_Line (InB); 291 Put_Line (OutB, Line); 292 end loop; 293 294 Put_Line (OutH, Header_Pending_Line); 295 while not End_Of_File (InH) loop 296 Line := Get_Line (InH); 297 Put_Line (OutH, Line); 298 end loop; 299 300 Put_Line (OutH, "#ifdef __cplusplus"); 301 Put_Line (OutH, "}"); 302 Put_Line (OutH, "#endif"); 303end XSnamesT; 304