1------------------------------------------------------------------------------ 2-- -- 3-- GNAT SYSTEM UTILITIES -- 4-- -- 5-- X T R E E P R S -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1992-2010, 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-- Program to construct the spec of the Treeprs package 27 28-- Input files: 29 30-- sinfo.ads Spec of Sinfo package 31-- treeprs.adt Template for Treeprs package 32 33-- Output files: 34 35-- treeprs.ads Spec of Treeprs package 36 37-- Note: this program assumes that sinfo.ads has passed the error checks which 38-- are carried out by the CSinfo utility so it does not duplicate these checks 39 40-- An optional argument allows the specification of an output file name to 41-- override the default treeprs.ads file name for the generated output file. 42 43with Ada.Command_Line; use Ada.Command_Line; 44with Ada.Strings.Unbounded; use Ada.Strings.Unbounded; 45with Ada.Strings.Unbounded.Text_IO; use Ada.Strings.Unbounded.Text_IO; 46with Ada.Text_IO; use Ada.Text_IO; 47with Ada.Streams.Stream_IO; use Ada.Streams.Stream_IO; 48 49with GNAT.Spitbol; use GNAT.Spitbol; 50with GNAT.Spitbol.Patterns; use GNAT.Spitbol.Patterns; 51with GNAT.Spitbol.Table_Boolean; use GNAT.Spitbol.Table_Boolean; 52with GNAT.Spitbol.Table_VString; use GNAT.Spitbol.Table_VString; 53 54procedure XTreeprs is 55 56 package TB renames GNAT.Spitbol.Table_Boolean; 57 package TV renames GNAT.Spitbol.Table_VString; 58 59 Err : exception; 60 -- Raised on fatal error 61 62 A : VString := Nul; 63 Ffield : VString := Nul; 64 Field : VString := Nul; 65 Fieldno : VString := Nul; 66 Flagno : VString := Nul; 67 Line : VString := Nul; 68 Name : VString := Nul; 69 Node : VString := Nul; 70 Outstring : VString := Nul; 71 Prefix : VString := Nul; 72 S : VString := Nul; 73 S1 : VString := Nul; 74 Syn : VString := Nul; 75 Synonym : VString := Nul; 76 Term : VString := Nul; 77 78 subtype Sfile is Ada.Streams.Stream_IO.File_Type; 79 80 OutS : Sfile; 81 -- Output file 82 83 InS : Ada.Text_IO.File_Type; 84 -- Read sinfo.ads 85 86 InT : Ada.Text_IO.File_Type; 87 -- Read treeprs.adt 88 89 Special : TB.Table (20); 90 -- Table of special fields. These fields are not included in the table 91 -- constructed by Xtreeprs, since they are specially handled in treeprs. 92 -- This means these field definitions are completely ignored. 93 94 Names : array (1 .. 500) of VString; 95 -- Table of names of synonyms 96 97 Positions : array (1 .. 500) of Natural; 98 -- Table of starting positions in Pchars string for synonyms 99 100 Strings : TV.Table (300); 101 -- Contribution of each synonym to Pchars string, indexed by name 102 103 Count : Natural := 0; 104 -- Number of synonyms processed so far 105 106 Curpos : Natural := 1; 107 -- Number of characters generated in Pchars string so far 108 109 Lineno : Natural := 0; 110 -- Line number in sinfo.ads 111 112 Field_Base : constant := Character'Pos ('#'); 113 -- Fields 1-5 are represented by the characters #$%&' (i.e. by five 114 -- contiguous characters starting at # (16#23#)). 115 116 Flag_Base : constant := Character'Pos ('('); 117 -- Flags 1-18 are represented by the characters ()*+,-./0123456789 118 -- (i.e. by 18 contiguous characters starting at (16#28#)). 119 120 Fieldch : Character; 121 -- Field character, as per above tables 122 123 Sp : aliased Natural; 124 -- Space left on line for Pchars output 125 126 wsp : constant Pattern := Span (' ' & ASCII.HT); 127 Is_Temp : constant Pattern := BreakX ('T') * A & "T e m p l a t e"; 128 Get_Node : constant Pattern := wsp & "-- N_" & Rest * Node; 129 Tst_Punc : constant Pattern := Break (" ,."); 130 Get_Syn : constant Pattern := Span (' ') & "-- " & Break (' ') * Synonym 131 & " (" & Break (')') * Field; 132 Brk_Min : constant Pattern := Break ('-') * Ffield; 133 Is_Flag : constant Pattern := "Flag" & Rest * Flagno; 134 Is_Field : constant Pattern := Rtab (1) & Len (1) * Fieldno; 135 Is_Syn : constant Pattern := wsp & "N_" & Break (",)") * Syn 136 & Len (1) * Term; 137 Brk_Node : constant Pattern := Break (' ') * Node & ' '; 138 Chop_SP : constant Pattern := Len (Sp'Unrestricted_Access) * S1; 139 140 M : Match_Result; 141 142 procedure Put_Line (F : Sfile; S : String); 143 procedure Put_Line (F : Sfile; S : VString); 144 -- Local version of Put_Line ensures Unix style line endings 145 146 procedure Put_Line (F : Sfile; S : String) is 147 begin 148 String'Write (Stream (F), S); 149 Character'Write (Stream (F), ASCII.LF); 150 end Put_Line; 151 152 procedure Put_Line (F : Sfile; S : VString) is 153 begin 154 Put_Line (F, To_String (S)); 155 end Put_Line; 156 157-- Start of processing for XTreeprs 158 159begin 160 Anchored_Mode := True; 161 162 if Argument_Count > 0 then 163 Create (OutS, Out_File, Argument (1)); 164 else 165 Create (OutS, Out_File, "treeprs.ads"); 166 end if; 167 168 Open (InS, In_File, "sinfo.ads"); 169 Open (InT, In_File, "treeprs.adt"); 170 171 -- Initialize special fields table 172 173 Set (Special, "Analyzed", True); 174 Set (Special, "Cannot_Be_Constant", True); 175 Set (Special, "Chars", True); 176 Set (Special, "Comes_From_Source", True); 177 Set (Special, "Error_Posted", True); 178 Set (Special, "Etype", True); 179 Set (Special, "Has_No_Side_Effects", True); 180 Set (Special, "Is_Controlling_Actual", True); 181 Set (Special, "Is_Overloaded", True); 182 Set (Special, "Is_Static_Expression", True); 183 Set (Special, "Left_Opnd", True); 184 Set (Special, "Must_Check_Expr", True); 185 Set (Special, "No_Overflow_Expr", True); 186 Set (Special, "Paren_Count", True); 187 Set (Special, "Raises_Constraint_Error", True); 188 Set (Special, "Right_Opnd", True); 189 190 -- Read template header and generate new header 191 192 loop 193 Line := Get_Line (InT); 194 195 -- Skip lines describing the template 196 197 if Match (Line, "-- This file is a template") then 198 loop 199 Line := Get_Line (InT); 200 exit when Line = ""; 201 end loop; 202 end if; 203 204 exit when Match (Line, "package"); 205 206 if Match (Line, Is_Temp, M) then 207 Replace (M, A & " S p e c "); 208 end if; 209 210 Put_Line (OutS, Line); 211 end loop; 212 213 Put_Line (OutS, Line); 214 215 -- Copy rest of comments up to template insert point to spec 216 217 loop 218 Line := Get_Line (InT); 219 exit when Match (Line, "!!TEMPLATE INSERTION POINT"); 220 Put_Line (OutS, Line); 221 end loop; 222 223 -- Here we are doing the actual insertions 224 225 Put_Line (OutS, " Pchars : constant String :="); 226 227 -- Loop through comments describing nodes, picking up fields 228 229 loop 230 Line := Get_Line (InS); 231 Lineno := Lineno + 1; 232 exit when Match (Line, " type Node_Kind"); 233 234 if Match (Line, Get_Node) 235 and then not Match (Node, Tst_Punc) 236 then 237 Outstring := Node & ' '; 238 239 loop 240 Line := Get_Line (InS); 241 exit when Line = ""; 242 243 if Match (Line, Get_Syn) 244 and then not Match (Synonym, "plus") 245 and then not Present (Special, Synonym) 246 then 247 -- Convert this field into the character used to 248 -- represent the field according to the table: 249 250 -- Field1 '#' 251 -- Field2 '$' 252 -- Field3 '%' 253 -- Field4 '&' 254 -- Field5 "'" 255 -- Flag4 '+' 256 -- Flag5 ',' 257 -- Flag6 '-' 258 -- Flag7 '.' 259 -- Flag8 '/' 260 -- Flag9 '0' 261 -- Flag10 '1' 262 -- Flag11 '2' 263 -- Flag12 '3' 264 -- Flag13 '4' 265 -- Flag14 '5' 266 -- Flag15 '6' 267 -- Flag16 '7' 268 -- Flag17 '8' 269 -- Flag18 '9' 270 271 if Match (Field, Brk_Min) then 272 Field := Ffield; 273 end if; 274 275 if Match (Field, Is_Flag) then 276 Fieldch := Char (Flag_Base - 1 + N (Flagno)); 277 278 elsif Match (Field, Is_Field) then 279 Fieldch := Char (Field_Base - 1 + N (Fieldno)); 280 281 else 282 Put_Line 283 (Standard_Error, 284 "*** Line " & 285 Lineno & 286 " has unrecognized field name " & 287 Field); 288 raise Err; 289 end if; 290 291 Append (Outstring, Fieldch & Synonym); 292 end if; 293 end loop; 294 295 Set (Strings, Node, Outstring); 296 end if; 297 end loop; 298 299 -- Loop through actual definitions of node kind enumeration literals 300 301 loop 302 loop 303 Line := Get_Line (InS); 304 Lineno := Lineno + 1; 305 exit when Match (Line, Is_Syn); 306 end loop; 307 308 S := Get (Strings, Syn); 309 Match (S, Brk_Node, ""); 310 Count := Count + 1; 311 Names (Count) := Syn; 312 Positions (Count) := Curpos; 313 Curpos := Curpos + Length (S); 314 Put_Line (OutS, " -- " & Node); 315 Prefix := V (" "); 316 exit when Term = ")"; 317 318 -- Loop to output the string literal for Pchars 319 320 loop 321 Sp := 79 - 4 - Length (Prefix); 322 exit when Size (S) <= Sp; 323 Match (S, Chop_SP, ""); 324 Put_Line (OutS, Prefix & '"' & S1 & """ &"); 325 Prefix := V (" "); 326 end loop; 327 328 Put_Line (OutS, Prefix & '"' & S & """ &"); 329 end loop; 330 331 Put_Line (OutS, " """";"); 332 Put_Line (OutS, ""); 333 Put_Line 334 (OutS, " type Pchar_Pos_Array is array (Node_Kind) of Positive;"); 335 Put_Line 336 (OutS, 337 " Pchar_Pos : constant Pchar_Pos_Array := Pchar_Pos_Array'("); 338 339 -- Output lines for Pchar_Pos_Array values 340 341 for M in 1 .. Count - 1 loop 342 Name := Rpad ("N_" & Names (M), 40); 343 Put_Line (OutS, " " & Name & " => " & Positions (M) & ','); 344 end loop; 345 346 Name := Rpad ("N_" & Names (Count), 40); 347 Put_Line (OutS, " " & Name & " => " & Positions (Count) & ");"); 348 349 Put_Line (OutS, ""); 350 Put_Line (OutS, "end Treeprs;"); 351 352exception 353 when Err => 354 Put_Line (Standard_Error, "*** fatal error"); 355 Set_Exit_Status (1); 356 357end XTreeprs; 358