+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT SYSTEM UTILITIES --
--- --
--- X T R E E P R S --
--- --
--- B o d y --
--- --
--- $Revision: 1.1.16.2 $
--- --
--- Copyright (C) 1992-2001 Free Software Foundation, Inc.
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 2, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
--- for more details. You should have received a copy of the GNU General --
--- Public License distributed with GNAT; see file COPYING. If not, write --
--- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
--- MA 02111-1307, USA. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
--- Program to construct the spec of the Treeprs package
-
--- Input files:
-
--- sinfo.ads Spec of Sinfo package
--- treeprs.adt Template for Treeprs package
-
--- Output files:
-
--- treeprs.ads Spec of Treeprs package
-
--- Note: this program assumes that sinfo.ads has passed the error checks which
--- are carried out by the CSinfo utility so it does not duplicate these checks
-
--- An optional argument allows the specification of an output file name to
--- override the default treeprs.ads file name for the generated output file.
-
-with Ada.Command_Line; use Ada.Command_Line;
-with Ada.Strings.Unbounded; use Ada.Strings.Unbounded;
-with Ada.Strings.Unbounded.Text_IO; use Ada.Strings.Unbounded.Text_IO;
-with Ada.Text_IO; use Ada.Text_IO;
-
-with GNAT.Spitbol; use GNAT.Spitbol;
-with GNAT.Spitbol.Patterns; use GNAT.Spitbol.Patterns;
-with GNAT.Spitbol.Table_Boolean; use GNAT.Spitbol.Table_Boolean;
-with GNAT.Spitbol.Table_VString; use GNAT.Spitbol.Table_VString;
-
-procedure XTreeprs is
-
- package TB renames GNAT.Spitbol.Table_Boolean;
- package TV renames GNAT.Spitbol.Table_VString;
-
- Err : exception;
- -- Raised on fatal error
-
- A : VString := Nul;
- Ffield : VString := Nul;
- Field : VString := Nul;
- Fieldno : VString := Nul;
- Flagno : VString := Nul;
- Line : VString := Nul;
- Name : VString := Nul;
- Node : VString := Nul;
- Outstring : VString := Nul;
- Prefix : VString := Nul;
- S : VString := Nul;
- S1 : VString := Nul;
- Sinforev : VString := Nul;
- Syn : VString := Nul;
- Synonym : VString := Nul;
- Temprev : VString := Nul;
- Term : VString := Nul;
- Treeprsrev : VString := Nul;
-
- OutS : File_Type;
- -- Output file
-
- InS : File_Type;
- -- Read sinfo.ads
-
- InT : File_Type;
- -- Read treeprs.adt
-
- Special : TB.Table (20);
- -- Table of special fields. These fields are not included in the table
- -- constructed by Xtreeprs, since they are specially handled in treeprs.
- -- This means these field definitions are completely ignored.
-
- Names : array (1 .. 500) of VString;
- -- Table of names of synonyms
-
- Positions : array (1 .. 500) of Natural;
- -- Table of starting positions in Pchars string for synonyms
-
- Strings : TV.Table (300);
- -- Contribution of each synonym to Pchars string, indexed by name
-
- Count : Natural := 0;
- -- Number of synonyms processed so far
-
- Curpos : Natural := 1;
- -- Number of characters generated in Pchars string so far
-
- Lineno : Natural := 0;
- -- Line number in sinfo.ads
-
- Field_Base : constant := Character'Pos ('#');
- -- Fields 1-5 are represented by the characters #$%&' (i.e. by five
- -- contiguous characters starting at # (16#23#)).
-
- Flag_Base : constant := Character'Pos ('(');
- -- Flags 1-18 are represented by the characters ()*+,-./0123456789
- -- (i.e. by 18 contiguous characters starting at (16#28#)).
-
- Fieldch : Character;
- -- Field character, as per above tables
-
- Sp : aliased Natural;
- -- Space left on line for Pchars output
-
- wsp : Pattern := Span (' ' & ASCII.HT);
-
- Get_SRev : Pattern := BreakX ('$') & "$Rev" & "ision: "
- & Break (' ') * Sinforev;
- Get_TRev : Pattern := BreakX ('$') & "$Rev" & "ision: "
- & Break (' ') * Temprev;
- Is_Temp : Pattern := BreakX ('T') * A & "T e m p l a t e";
- Get_Node : Pattern := wsp & "-- N_" & Rest * Node;
- Tst_Punc : Pattern := Break (" ,.");
- Get_Syn : Pattern := Span (' ') & "-- " & Break (' ') * Synonym
- & " (" & Break (')') * Field;
- Brk_Min : Pattern := Break ('-') * Ffield;
- Is_Flag : Pattern := "Flag" & Rest * Flagno;
- Is_Field : Pattern := Rtab (1) & Len (1) * Fieldno;
- Is_Syn : Pattern := wsp & "N_" & Break (",)") * Syn & Len (1) * Term;
- Brk_Node : Pattern := Break (' ') * Node & ' ';
- Chop_SP : Pattern := Len (Sp'Unrestricted_Access) * S1;
-
- M : Match_Result;
-
-begin
- Anchored_Mode := True;
-
- Match ("$Revision: 1.1.16.2 $",
- "$Rev" & "ision: " & Break (' ') * Treeprsrev);
-
- if Argument_Count > 0 then
- Create (OutS, Out_File, Argument (1));
- else
- Create (OutS, Out_File, "treeprs.ads");
- end if;
-
- Open (InS, In_File, "sinfo.ads");
- Open (InT, In_File, "treeprs.adt");
-
- -- Initialize special fields table
-
- Set (Special, "Analyzed", True);
- Set (Special, "Cannot_Be_Constant", True);
- Set (Special, "Chars", True);
- Set (Special, "Comes_From_Source", True);
- Set (Special, "Error_Posted", True);
- Set (Special, "Etype", True);
- Set (Special, "Has_No_Side_Effects", True);
- Set (Special, "Is_Controlling_Actual", True);
- Set (Special, "Is_Overloaded", True);
- Set (Special, "Is_Static_Expression", True);
- Set (Special, "Left_Opnd", True);
- Set (Special, "Must_Check_Expr", True);
- Set (Special, "No_Overflow_Expr", True);
- Set (Special, "Paren_Count", True);
- Set (Special, "Raises_Constraint_Error", True);
- Set (Special, "Right_Opnd", True);
-
- -- Get sinfo revs and write header to output file
-
- loop
- Line := Get_Line (InS);
- Lineno := Lineno + 1;
-
- if Line = "" then
- raise Err;
- end if;
-
- exit when Match (Line, Get_SRev);
- end loop;
-
- -- Read template header and generate new header
-
- loop
- Line := Get_Line (InT);
-
- if Match (Line, Get_TRev) then
- Put_Line
- (OutS,
- "-- Generated by xtreeprs revision " &
- Treeprsrev & " using");
-
- Put_Line
- (OutS,
- "-- sinfo.ads revision " &
- Sinforev);
-
- Put_Line
- (OutS,
- "-- treeprs.adt revision "
- & Temprev);
-
- else
- -- Skip lines describing the template
-
- if Match (Line, "-- This file is a template") then
- loop
- Line := Get_Line (InT);
- exit when Line = "";
- end loop;
- end if;
-
- exit when Match (Line, "package");
-
- if Match (Line, Is_Temp, M) then
- Replace (M, A & " S p e c ");
- end if;
-
- Put_Line (OutS, Line);
- end if;
- end loop;
-
- Put_Line (OutS, Line);
-
- -- Copy rest of comments up to template insert point to spec
-
- loop
- Line := Get_Line (InT);
- exit when Match (Line, "!!TEMPLATE INSERTION POINT");
- Put_Line (OutS, Line);
- end loop;
-
- -- Here we are doing the actual insertions
-
- Put_Line (OutS, " Pchars : constant String :=");
-
- -- Loop through comments describing nodes, picking up fields
-
- loop
- Line := Get_Line (InS);
- Lineno := Lineno + 1;
- exit when Match (Line, " type Node_Kind");
-
- if Match (Line, Get_Node)
- and then not Match (Node, Tst_Punc)
- then
- Outstring := Node & ' ';
-
- loop
- Line := Get_Line (InS);
- exit when Line = "";
-
- if Match (Line, Get_Syn)
- and then not Match (Synonym, "plus")
- and then not Present (Special, Synonym)
- then
- -- Convert this field into the character used to
- -- represent the field according to the table:
-
- -- Field1 '#'
- -- Field2 '$'
- -- Field3 '%'
- -- Field4 '&'
- -- Field5 "'"
- -- Flag1 "("
- -- Flag2 ")"
- -- Flag3 '*'
- -- Flag4 '+'
- -- Flag5 ','
- -- Flag6 '-'
- -- Flag7 '.'
- -- Flag8 '/'
- -- Flag9 '0'
- -- Flag10 '1'
- -- Flag11 '2'
- -- Flag12 '3'
- -- Flag13 '4'
- -- Flag14 '5'
- -- Flag15 '6'
- -- Flag16 '7'
- -- Flag17 '8'
- -- Flag18 '9'
-
- if Match (Field, Brk_Min) then
- Field := Ffield;
- end if;
-
- if Match (Field, Is_Flag) then
- Fieldch := Char (Flag_Base - 1 + N (Flagno));
-
- elsif Match (Field, Is_Field) then
- Fieldch := Char (Field_Base - 1 + N (Fieldno));
-
- else
- Put_Line
- (Standard_Error,
- "*** Line " &
- Lineno &
- " has unrecognized field name " &
- Field);
- raise Err;
- end if;
-
- Append (Outstring, Fieldch & Synonym);
- end if;
- end loop;
-
- Set (Strings, Node, Outstring);
- end if;
- end loop;
-
- -- Loop through actual definitions of node kind enumeration literals
-
- loop
- loop
- Line := Get_Line (InS);
- Lineno := Lineno + 1;
- exit when Match (Line, Is_Syn);
- end loop;
-
- S := Get (Strings, Syn);
- Match (S, Brk_Node, "");
- Count := Count + 1;
- Names (Count) := Syn;
- Positions (Count) := Curpos;
- Curpos := Curpos + Length (S);
- Put_Line (OutS, " -- " & Node);
- Prefix := V (" ");
- exit when Term = ")";
-
- -- Loop to output the string literal for Pchars
-
- loop
- Sp := 79 - 4 - Length (Prefix);
- exit when (Size (S) <= Sp);
- Match (S, Chop_SP, "");
- Put_Line (OutS, Prefix & '"' & S1 & """ &");
- Prefix := V (" ");
- end loop;
-
- Put_Line (OutS, Prefix & '"' & S & """ &");
- end loop;
-
- Put_Line (OutS, " """";");
- Put_Line (OutS, "");
- Put_Line
- (OutS, " type Pchar_Pos_Array is array (Node_Kind) of Positive;");
- Put_Line
- (OutS,
- " Pchar_Pos : constant Pchar_Pos_Array := Pchar_Pos_Array'(");
-
- -- Output lines for Pchar_Pos_Array values
-
- for M in 1 .. Count - 1 loop
- Name := Rpad ("N_" & Names (M), 40);
- Put_Line (OutS, " " & Name & " => " & Positions (M) & ',');
- end loop;
-
- Name := Rpad ("N_" & Names (Count), 40);
- Put_Line (OutS, " " & Name & " => " & Positions (Count) & ");");
-
- Put_Line (OutS, "");
- Put_Line (OutS, "end Treeprs;");
-
-exception
- when Err =>
- Put_Line (Standard_Error, "*** fatal error");
- Set_Exit_Status (1);
-
-end XTreeprs;
projects / msp430-gcc.git / blobdiff