1------------------------------------------------------------------------------ 2-- -- 3-- GNAT SYSTEM UTILITIES -- 4-- -- 5-- X S I N F O -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1992-2019, 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 C header file sinfo.h (C version of sinfo.ads spec, 27-- for use by Gigi, contains all definitions and access functions, but does 28-- not contain set procedures, since Gigi never modifies the GNAT tree) 29 30-- Input files: 31 32-- sinfo.ads Spec of Sinfo package 33 34-- Output files: 35 36-- sinfo.h Corresponding c header file 37 38-- An optional argument allows the specification of an output file name to 39-- override the default sinfo.h file name for the generated output file. 40 41with Ada.Command_Line; use Ada.Command_Line; 42with Ada.Strings.Unbounded; use Ada.Strings.Unbounded; 43with Ada.Strings.Unbounded.Text_IO; use Ada.Strings.Unbounded.Text_IO; 44with Ada.Text_IO; use Ada.Text_IO; 45 46with GNAT.Spitbol; use GNAT.Spitbol; 47with GNAT.Spitbol.Patterns; use GNAT.Spitbol.Patterns; 48 49with CSinfo; 50 51procedure XSinfo is 52 53 Done : exception; 54 Err : exception; 55 56 A : VString := Nul; 57 Arg : VString := Nul; 58 Comment : VString := Nul; 59 Line : VString := Nul; 60 N : VString := Nul; 61 N1, N2 : VString := Nul; 62 Nam : VString := Nul; 63 Rtn : VString := Nul; 64 Term : VString := Nul; 65 66 InS : File_Type; 67 Ofile : File_Type; 68 69 wsp : constant Pattern := Span (' ' & ASCII.HT); 70 Wsp_For : constant Pattern := wsp & "for"; 71 Is_Cmnt : constant Pattern := wsp & "--"; 72 Typ_Nod : constant Pattern := wsp * A & "type Node_Kind is"; 73 Get_Nam : constant Pattern := wsp * A & "N_" & Break (",)") * Nam 74 & Len (1) * Term; 75 Sub_Typ : constant Pattern := wsp * A & "subtype " & Break (' ') * N; 76 No_Cont : constant Pattern := wsp & Break (' ') * N1 77 & " .. " & Break (';') * N2; 78 Cont_N1 : constant Pattern := wsp & Break (' ') * N1 & " .." & Rpos (0); 79 Cont_N2 : constant Pattern := Span (' ') & Break (';') * N2; 80 Is_Func : constant Pattern := wsp * A & "function " & Rest * Nam; 81 Get_Arg : constant Pattern := wsp & "(N : " & Break (')') * Arg 82 & ") return " & Break (';') * Rtn 83 & ';' & wsp & "--" & wsp & Rest * Comment; 84 85 NKV : Natural; 86 87 M : Match_Result; 88 89 procedure Getline; 90 -- Get non-comment, non-blank line. Also skips "for " rep clauses 91 92 ------------- 93 -- Getline -- 94 ------------- 95 96 procedure Getline is 97 begin 98 loop 99 Line := Get_Line (InS); 100 101 if Line /= "" 102 and then not Match (Line, Wsp_For) 103 and then not Match (Line, Is_Cmnt) 104 then 105 return; 106 107 elsif Match (Line, " -- End functions (note") then 108 raise Done; 109 end if; 110 end loop; 111 end Getline; 112 113-- Start of processing for XSinfo 114 115begin 116 -- First run CSinfo to check for errors. Note that CSinfo is also a 117 -- stand-alone program that can be run separately. 118 119 CSinfo; 120 121 Set_Exit_Status (1); 122 Anchored_Mode := True; 123 124 if Argument_Count > 0 then 125 Create (Ofile, Out_File, Argument (1)); 126 else 127 Create (Ofile, Out_File, "sinfo.h"); 128 end if; 129 130 Open (InS, In_File, "sinfo.ads"); 131 132 -- Write header to output file 133 134 loop 135 Line := Get_Line (InS); 136 exit when Line = ""; 137 138 Match 139 (Line, 140 "-- S p e c ", 141 "-- C Header File "); 142 143 Match (Line, "--", "/*"); 144 Match (Line, Rtab (2) * A & "--", M); 145 Replace (M, A & "*/"); 146 Put_Line (Ofile, Line); 147 end loop; 148 149 -- Skip to package line 150 151 loop 152 Getline; 153 exit when Match (Line, "package"); 154 end loop; 155 156 -- Skip to first node kind line 157 158 loop 159 Getline; 160 exit when Match (Line, Typ_Nod); 161 Put_Line (Ofile, Line); 162 end loop; 163 164 Put_Line (Ofile, ""); 165 166 Put_Line (Ofile, "#ifdef __cplusplus"); 167 Put_Line (Ofile, "extern ""C"" {"); 168 Put_Line (Ofile, "#endif"); 169 170 NKV := 0; 171 172 -- Loop through node kind codes 173 174 loop 175 Getline; 176 177 if Match (Line, Get_Nam) then 178 Put_Line (Ofile, A & "#define N_" & Nam & ' ' & NKV); 179 NKV := NKV + 1; 180 exit when not Match (Term, ","); 181 182 else 183 Put_Line (Ofile, Line); 184 end if; 185 end loop; 186 187 Put_Line (Ofile, ""); 188 Put_Line (Ofile, A & "#define Number_Node_Kinds " & NKV); 189 190 -- Loop through subtype declarations 191 192 loop 193 Getline; 194 195 if not Match (Line, Sub_Typ) then 196 exit when Match (Line, " function"); 197 Put_Line (Ofile, Line); 198 199 else 200 Put_Line (Ofile, A & "SUBTYPE (" & N & ", Node_Kind, "); 201 Getline; 202 203 -- Normal case 204 205 if Match (Line, No_Cont) then 206 Put_Line (Ofile, A & " " & N1 & ", " & N2 & ')'); 207 208 -- Continuation case 209 210 else 211 if not Match (Line, Cont_N1) then 212 raise Err; 213 end if; 214 215 Getline; 216 217 if not Match (Line, Cont_N2) then 218 raise Err; 219 end if; 220 221 Put_Line (Ofile, A & " " & N1 & ','); 222 Put_Line (Ofile, A & " " & N2 & ')'); 223 end if; 224 end if; 225 end loop; 226 227 -- Loop through functions. Note that this loop is terminated by 228 -- the call to Getfile encountering the end of functions sentinel 229 230 loop 231 if Match (Line, Is_Func) then 232 Getline; 233 if not Match (Line, Get_Arg) then 234 raise Err; 235 end if; 236 Put_Line 237 (Ofile, 238 A & "INLINE " & Rpad (Rtn, 9) 239 & ' ' & Rpad (Nam, 30) & " (" & Arg & " N)"); 240 241 Put_Line (Ofile, A & " { return " & Comment & " (N); }"); 242 243 else 244 Put_Line (Ofile, Line); 245 end if; 246 247 Getline; 248 end loop; 249 250 -- Can't get here since above loop only left via raise 251 252exception 253 when Done => 254 Close (InS); 255 Put_Line (Ofile, ""); 256 Put_Line (Ofile, "#ifdef __cplusplus"); 257 Put_Line (Ofile, "}"); 258 Put_Line (Ofile, "#endif"); 259 Close (Ofile); 260 Set_Exit_Status (0); 261 262end XSinfo; 263