|
DataMuseum.dkPresents historical artifacts from the history of: Rational R1000/400 Tapes |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about Rational R1000/400 Tapes Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - metrics - downloadIndex: B T
Length: 124229 (0x1e545)
Types: TextFile
Names: »B«
└─⟦180fe333a⟧ Bits:30000405 8mm tape, Rational 1000, SW CATALOG, 10_20_0
└─⟦180fe333a⟧ Bits:30000537 8mm tape, Rational 1000, SW Catalog 10_20_0
└─⟦5cb1d1d7f⟧ »DATA«
└─⟦3b1ee7bd8⟧
└─⟦this⟧
-- packages needed by parsing
with Parsetables;
with Grammar_Constants;
use Grammar_Constants; -- to get visibility on =
with Parserdeclarations;
use Parserdeclarations;
-- packages for abstract data types --
with Unchecked_Deallocation;
with Stack_Pkg;
with String_Pkg;
use String_Pkg;
-- packages needed for source instrumenting --
with Source_Instrumenter_Declarations;
use Source_Instrumenter_Declarations;
with Create_Breakpoint;
with Type_Definitions;
use Type_Definitions;
-- packages needed for source instrumenter output --
with Change_Text;
with Simple_Paginated_Output;
with Buffer_File_Package;
use Buffer_File_Package;
with Text_Io;
package body Source_Instrumenter_Utilities is
--| Utilities for the Source Instrumenter
package Sid renames Source_Instrumenter_Declarations;
package Ct renames Change_Text;
package Po renames Simple_Paginated_Output;
package Pt renames Parsetables;
package Bfp renames Buffer_File_Package;
package Token_Stack_Pkg is new Stack_Pkg (Pd.Parsestackelement);
-----------------------------------------------------------------
-- Local declarations for formatting output
-----------------------------------------------------------------
Identifier_Stack : Token_Stack_Pkg.Stack;
--| Stack of identifiers/designators
Beginning_Of_Line : Boolean := True;
--| Tells whether the current column is at the beginning of a line
Current_Column : Sid.Column_Range := Sid.Column_Range'First;
--| Current column in output file
Current_Indent : Sid.Indentation_Range := 0;
--| Current indentation in output file
Temporary_Indent : Sid.Indentation_Range := 0;
--| Temporary indentation in output file, when statement or declaration
--| with no embedded requests for newlines is too big to fit on one line.
Previous_Indent : Sid.Indentation_Range := 0;
--| Saved indent for returning to after parameters or discriminants are
--| lined up.
Current_Change_Column : Sid.Indentation_Range := 0;
--| Column to change indent to
Unperformed_Indents : Natural := 0;
--| The number of indents "requested" after the RH_Margin has been exceeded
--| for situations where nesting is so deep that it is not
--| worthwhile to further indent.
Empty_Token : Pd.Parsestackelement :=
(Gram_Sym_Val => Pt.Empty_Tokenvalue,
Lexed_Token => (Text => new String'(""),
Srcpos_Line => 0,
Srcpos_Column => 0));
Identifier_Token : Pd.Parsestackelement :=
(Gram_Sym_Val => Pt.Identifiertokenvalue,
Lexed_Token => (Text => new String'(""),
Srcpos_Line => 0,
Srcpos_Column => 0));
Colon_Token : Pd.Parsestackelement :=
(Gram_Sym_Val => Pt.Colon_Tokenvalue,
Lexed_Token => (Text => new String'(":"),
Srcpos_Line => 0,
Srcpos_Column => 0));
Previous_Token : Pd.Parsestackelement := Empty_Token;
--| Previous Token from the input stream
Saved_Token : Pd.Parsestackelement := Empty_Token;
--| Previous identifier or string literal, saved so that it may be stacked
--| and closing identifiers printed.
type Context is (Declarative_Part, Body_Part);
Comment_Context : Context := Declarative_Part;
--| Current Context for formatting comments
type Request_Descriptor is
record
New_Lines : Natural := 0;
--| Number of times New_Line was called before printing new lines.
Increases : Natural := 0;
--| Number of times Increase_Indent was called before processing
--| any of these requests.
Decreases : Natural := 0;
--| Number of times Decrease_Indent was called before processing
--| any of these requests.
Changes : Natural := 0;
--| Number of times Change_Indent was called before processing
--| any of these requests.
Resumes : Natural := 0;
--| Number of times Resume_Normal_Indentation was called before
--| processing any of these requests
end record;
Requests : Request_Descriptor;
type Token_Descriptor is
record
Token : Pd.Parsestackelement;
Comments : Comment_Lists.List;
Requests : Request_Descriptor;
Current_Change_Column : Sid.Indentation_Range := 0;
-- for lining up parameter/discriminant lists
Left_Side_Length : Natural := 0; -- for lining up colons
end record;
Token_To_Buffer : Token_Descriptor;
Current_Buffered_Token : Token_Descriptor;
package Token_Lists is new Lists (Token_Descriptor);
Token_Buffer : Token_Lists.List;
--| The buffer used when buffering colon declarations.
Buffered_Tokens : Token_Lists.List;
--| The buffer used when buffering ambiguous statements. For example,
--| when processing a procedure call we don't know if it needs a
--| breakpont until the whole statement is processed.
Buffering_Colon_Declarations : Boolean := False;
--| Whether or not to save declarations in order to line up the colons.
Buffering_Tokens : Boolean := True;
--| Whether not we are currently buffering an ambiguous statement.
Current_Block_Number : Natural := 0;
--| The number of current block(within the compilation unit). Used to
--| assign an unique ID for unnamed blocks.
Current_Nesting_Level : Natural := 0;
--| The current level of nesting.
Subprogram_Unit_Type : Program_Unit_Type;
--| Saves the type of the current subprogram.
Create_Subunit : Boolean := False;
--| Whether or not a subunit containing a unit_information call should
--| be created for the current compilation unit.
Separate_Unit : Boolean := False;
--| Whether or not the current compilation unit is a subunit.
Current_Trace_Level : Trace_Level := Decision_Point;
--| The statement trace level of the current unit.
type Scope_Descriptor is
record
Scope_Name : Ada_Name;
Qualified_Name : Ada_Name;
Type_Of_Scope : Scope_Type;
Putvar_Name : Ada_Name;
In_Private_Part : Boolean := False;
Scope_Trace_Level : Trace_Level := Decision_Point;
end record;
--| Maintains the information about a unit.
package Scope_Stack_Pkg is new Stack_Pkg (Scope_Descriptor);
Scope_Stack : Scope_Stack_Pkg.Stack;
--| Used to maintain the information about units when nesting occurs.
--| When a nested unit is encountered the enclosing units descriptor
--| is pushed onto the stack. When a nested unit is exited the stack
--| is popped to retrieve the enclosing units information.
Current_Scope : Scope_Descriptor;
--| Contains the information about the current unit.
Current_Outer_Scope : Scope_Descriptor;
--| Contains the information about the enclosing unit(if any).
Current_Scope_Qualified_Name : String_Type;
--| Maintains the full dot notated name of the current unit.
Current_Scope_Simple_Name : String_Type;
--| Contains the simple name of the current unit. It is set in
--| pop identifier and then retrieved in increment_scope when a
--| unit body is found.
-----------------------------------------------------------------
-- Declarations for type and identifier tracing
-----------------------------------------------------------------
Output_Source : Boolean := True;
--| The user may set this flag to False if he does not want the
--| source for top level package specs included in the instrumented
--| source file. If the source is not included, then the package
--| spec itself won't get re-compiled when the instrumented source
--| is compiled. This allows for instrumenting a package spec
--| without changing it.
Expanded_Name : String_Type;
--| An Expanded_Name is a qualified name, as in X.Y.Z
--| Expanded_Name is a string_type collection of the tokens
--| which make up the complete qualified name. This is used
--| in various places when a name which needs to be saved is
--| not a simple identifier.
Saving_Expanded_Name : Boolean := False;
--| This is set to true by applyactions at the start of an
--| expanded name. The text of all following tokens is
--| appened to Expanded_Name until Saving_Expanded_Name is
--| again set to false.
Generate_Tracevar_Spec : Boolean := False;
--| This is set to true when the instrumenter is creating a
--| a procedure body for tracing a type declaration. The
--| corresponding procedure declaration must be added to the
--| instrumented source.
Current_Type_Identifier : String_Type;
--| Save the last "Expanded_Name" that was built. It is
--| the name of the current type being declared, and will
--| be needed to generate the tracing procedure.
Tracevar_Header : array (1 .. 4) of String_Type :=
((Create ("Procedure Source_Instrumenter_Added_Tracevar")),
(Create (" (Current_Unit: Program_Unit_Unique_Identifier;")),
(Create (" Variable_Name: String;")),
(Create (" Current_Value:"))); -- the rest of this depends on
-- the current type definition
--| This is the invariant part of the tracevar procedure
--| declaration.
--| Note: It is declared as an array of variable length strings
--| rather than as one string with imbedded "ascii.cr" characters
--| so that a "put_line" may be done on each array element,
--| without regard to whether some systems need a line feed
--| character before or after the carriage return.
type Name_Record is
--| for each identifier in an identifier list, save its name
--| and its mode (Read_Only, Write_Only, Both, or None)
record
Object_Name : Ada_Name;
Object_Mode : Identifier_Mode;
end record;
package Name_Lists is new Lists (Name_Record);
--| A list of name records for collecting identifier lists.
package List_Stack_Pkg is new Stack_Pkg (Name_Lists.List);
--| A stack of lists of Name_Records.
Visible_List_Stack : List_Stack_Pkg.Stack;
--| The list of visible variables for the current scope
--| is stacked when a nested scope is entered.
package String_Stack_Pkg is new Stack_Pkg (String_List);
--| A stack of lists of String_Type.
Vars_To_Trace_Stack : String_Stack_Pkg.Stack;
--| The list of variables to be traced in this scope is
--| stacked when a new scope is entered;
Package_List_Stack : String_Stack_Pkg.Stack;
--| The list of names of packages declared in the current
--| scope is stacked when a new scope is entered.
Param_List : Name_Lists.List;
--| A list of formal parameters and their mode (in, out, or
--| in out)
Visible_List : Name_Lists.List;
--| A list of local variables and their mode (constant
--| or variable)
Current_List : Name_Lists.List;
--| A temporary list to collect identifiers until the type
--| of identifier list is known.
Vars_To_Trace : String_List;
--| A list of the variables the user wants to have traced
--| in the current scope.
Package_List : String_List;
--| A list of packages declared in the current scope
With_List : String_List;
--| A list of instrumented library units from the current
--| context clause.
Current_Mode : Identifier_Mode := None;
--| This is set by a call from applyactions when the mode
--| of the current identifier list is known (following the
--| colon in "identifer_list : ....". Parsing has not
--| reached the end of the list yet, so the mode must
--| be saved.
-----------------------------------------------------------------
-- Local subprogram specifications for pretty printing
-----------------------------------------------------------------
procedure Initialize_Descriptor (Descriptor : in out Token_Descriptor);
--| Initializes an object of type Token_Descriptor
-----------------------------------------------------------------
procedure Free is new Unchecked_Deallocation (String, Pd.Source_Text);
-----------------------------------------------------------------
procedure Print_Token (Next_Token : in out Pd.Parsestackelement);
--| Prints Next_Token and updates column information
-----------------------------------------------------------------
function Token_Text (Token : in Pd.Parsestackelement) return String;
--| Returns the canonical "text" of a token (in extended character set)
-----------------------------------------------------------------
function Spaced_Token
(Current, Previous : in Pd.Parsestackelement) return String;
--| Returns the text of a token with appropriate spaces around it, in
--| accordance with SID.Spacing_Table and any extra spaces that are
--| necessary.
-----------------------------------------------------------------
procedure Print_New_Line;
--| Puts a newline in the output and updates column information.
-----------------------------------------------------------------
procedure Process_Increase_Requests;
--| Increases the indentation unless SID.RH_Margin is exceeded,
--| in which case Unperformed_Indents is incremented.
-----------------------------------------------------------------
procedure Process_Decrease_Requests;
--| Decreases the indentation unless there were unperformed indents,
--| in which case Unperformed_Indents is decremented.
-----------------------------------------------------------------
procedure Process_Change_Requests;
--| Changes the indentation to the current column
-----------------------------------------------------------------
procedure Process_Resume_Requests;
--| Resumes the indentation level before the call to
--| Process_Change_Requests.
-----------------------------------------------------------------
-- Local subprogram specifications for source instrumenting
-----------------------------------------------------------------
-----------------------------------------------------------------
procedure Print_Buffered_Tokens;
--| Prints any tokens that have been buffered due to an ambiguous
--| statement.
-----------------------------------------------------------------
function Match_Names (User_Name, Si_Name : in String) return Boolean;
--| Compares the fully qualified name of the variable the user
--| wants to trace with the fully qualified variable name found
--| in the program. The user requested variable name may have
--| selected or indexed components.
-----------------------------------------------------------------
procedure Check_Lists;
--| In each scope, compare the list of variables the user requested
--| to trace with the list of variables found in the program. If
--| the variable exists, trace it using the name the user gave to
--| allow selected and indexed components.
-----------------------------------------------------------------
function Get_Unit_Name (Type_Of_Scope : in Scope_Type) return String;
--| Returns a string that contains the specification of the current
--| unit. This string is printed to inform the user of the
--| current unit being processed.
-----------------------------------------------------------------
procedure Write_Body_Line (Line : in String);
--| The line of text is part of a procedure body being generated
--| for type tracing. It must be saved in one of the buffer files
--| until the end of the current scope's "later_declarative_part".
-----------------------------------------------------------------
procedure Write_Spec_Line (Line : in String);
--| The line of text is a procedure declaration or part of a
--| package specification being generated for type tracing.
--| Write it to either the instrumented source file or one
--| of the package specification tracing files.
-----------------------------------------------------------------
procedure Retrieve_Spec_With_List;
--| Get the names of any instrumented units that were named in
--| the context clause of the package specification and merge
--| the names into the with_list for the package body.
-----------------------------------------------------------------
procedure Generate_Tracevar_Call (Varname : in String);
--| Add the code to the appropriate buffer to call the tracing
--| procedure for the current variable. This procedure is called
--| by Generate_Putvars for each local variable.
-----------------------------------------------------------------
procedure Generate_Putvars;
--| Generate the body of the procedure which traces all of
--| the variables visible in the current scope.
-----------------------------------------------------------------
procedure Discard_List (Which_List : in out Name_Lists.List);
--| A general purpose procedure which flushes the string_type
--| field of a name_record before destroying the list.
-----------------------------------------------------------------
procedure Add_Withs_To_Body;
--| Add the necessary with and use clauses to a subprogram or
--| package body.
-----------------------------------------------------------------
procedure Add_Withs_To_Trace_Packages;
--| Add the necessary with and use clauses to the packages
--| generated to trace a package specification. This procedure
--| is called by Initialize_Trace_Packages.
-----------------------------------------------------------------
procedure Initialize_Trace_Packages;
--| Start the packages that are created by the instrumenter for
--| tracing package specifications.
-----------------------------------------------------------------
procedure Close_Trace_Packages;
--| Finish and save the packages that are created for tracing
--| package specificatiosn.
-----------------------------------------------------------------
procedure Set_Scope_Records (Type_Of_Scope : in Scope_Type);
--| This is called by Increment_Scope to set the various fields
--| of the Current_Scope and Current_Outer_Scope variables
--| according to the current type of scope.
-----------------------------------------------------------------
function Ask_User_About_Package return Boolean;
--| Ask the user if he really wants to recompile a library unit
--| that is a package specification. Doing so will require
--| recompilation of the corresponding body, which only the user
--| knows if he has access to.
--| If the answer is NO, then the text of the package specification
--| will not be included in the instrumented source.
-----------------------------------------------------------------
-- External Subprogram Bodies for pretty printing
-----------------------------------------------------------------
procedure Initialize is
begin
Identifier_Stack := Token_Stack_Pkg.Create;
Scope_Stack := Scope_Stack_Pkg.Create;
Beginning_Of_Line := True;
Current_Column := 1;
Current_Indent := 0;
Temporary_Indent := 0;
Unperformed_Indents := 0;
Empty_Token := (Gram_Sym_Val => Pt.Empty_Tokenvalue,
Lexed_Token => (Text => new String'(""),
Srcpos_Line => 0,
Srcpos_Column => 0));
Previous_Token := Empty_Token;
Saved_Token := Empty_Token;
Requests := (0, 0, 0, 0, 0);
Buffering_Colon_Declarations := False;
Buffering_Tokens := True;
Buffered_Tokens := Token_Lists.Create;
Initialize_Descriptor (Current_Buffered_Token);
Initialize_Descriptor (Token_To_Buffer);
if Current_Trace_Mode /= Mixed then
Current_Trace_Level := Current_Trace_Mode;
end if;
if Do_Type_Tracing then
Bfp.Initialize;
end if;
Output_Source := True;
With_List := String_Lists.Create;
Package_List := String_Lists.Create;
Vars_To_Trace := String_Lists.Create;
Param_List := Name_Lists.Create;
Visible_List := Name_Lists.Create;
Current_List := Name_Lists.Create;
Visible_List_Stack := List_Stack_Pkg.Create;
Vars_To_Trace_Stack := String_Stack_Pkg.Create;
Package_List_Stack := String_Stack_Pkg.Create;
end Initialize;
-----------------------------------------------------------------
procedure Put (Next_Token : in out Pd.Parsestackelement) is
Temp_Token : Token_Descriptor;
begin
-- if the Token_To_Buffer belonged in the colon Token_Buffer, attach
-- it there. (Values have been assigned to Token_To_Buffer but it
-- has not been attached to the buffer)
if Buffering_Colon_Declarations and
(Token_To_Buffer.Token.Gram_Sym_Val /= Pt.Comment_Tokenvalue) then
Token_Lists.Attach (Token_Buffer, Token_To_Buffer);
Initialize_Descriptor (Token_To_Buffer);
end if;
if Buffering_Tokens and (Current_Buffered_Token.Token.Gram_Sym_Val /=
Pt.Comment_Tokenvalue) and
not Buffering_Colon_Declarations then
Current_Buffered_Token.Requests := Requests;
Requests := (0, 0, 0, 0, 0);
Token_Lists.Attach (Buffered_Tokens, Current_Buffered_Token);
Initialize_Descriptor (Current_Buffered_Token);
end if;
-- function designator can be string literal or identifier, so save
-- both, so closing identifier/designator can be printed.
if (Next_Token.Gram_Sym_Val = Pt.Identifiertokenvalue) or
(Next_Token.Gram_Sym_Val = Pt.Stringtokenvalue) then
Saved_Token := Next_Token;
end if;
if Saving_Expanded_Name then
if Is_Empty (Expanded_Name) then
Expanded_Name := Create (Token_Text (Next_Token));
else
Expanded_Name := Expanded_Name & Token_Text (Next_Token);
end if;
end if;
if Buffering_Colon_Declarations then
Token_To_Buffer.Token := Next_Token;
Token_To_Buffer.Comments := Comment_Buffer;
elsif Buffering_Tokens then
Initialize_Descriptor (Current_Buffered_Token);
Current_Buffered_Token.Token := Next_Token;
Current_Buffered_Token.Comments := Comment_Buffer;
else
Print_Comments (Comment_Buffer);
Print_Token (Next_Token);
end if;
Create_Breakpoint.Breakpoint_Printed_Last := False;
end Put;
-----------------------------------------------------------------
procedure Put_Space (Spaces : in Natural := 1) is
Blank : constant String :=
" " &
" ";
begin
if Buffering_Colon_Declarations then
Token_Lists.Attach (Token_Buffer, Token_To_Buffer);
Initialize_Descriptor (Token_To_Buffer);
Token_To_Buffer.Token := Empty_Token;
Token_To_Buffer.Token.Lexed_Token.Text :=
new String'(Blank (1 .. Spaces));
elsif Buffering_Tokens then
if Current_Buffered_Token.Token.Gram_Sym_Val /=
Pt.Comment_Tokenvalue then
Token_Lists.Attach (Buffered_Tokens, Current_Buffered_Token);
Initialize_Descriptor (Current_Buffered_Token);
Current_Buffered_Token.Token := Empty_Token;
Current_Buffered_Token.Token.Lexed_Token.Text :=
new String'(Blank (1 .. Spaces));
else
null; --?????
end if;
else
if Current_Column + Spaces - 1 > Sid.Page_Width then
Print_New_Line;
Temporary_Indent := Sid.Indentation_Level;
Current_Column := Current_Indent + Temporary_Indent + 1;
end if;
if Beginning_Of_Line then
Po.Space (Sid.Listing_File, Current_Column - 1);
if Output_Source then
Po.Space (Sid.Instrumented_File, Current_Column - 1);
end if;
end if;
Po.Space (Sid.Listing_File, Spaces);
if Output_Source then
Po.Space (Sid.Instrumented_File, Spaces);
end if;
Current_Column := Current_Column + Spaces;
end if;
end Put_Space;
-----------------------------------------------------------------
procedure Print_Comments (Buffer : in out Comment_Lists.List) is
Iter : Comment_Lists.Listiter; --| Iterates down comment list
Comment_Token : Pd.Parsestackelement; --| Element in list of comments
New_Lines : Natural := 0; --| number of new_lines
--| between comments
Save_Output_Source : Boolean := Output_Source;
begin
Output_Source := False;
Iter := Comment_Lists.Makelistiter (Buffer);
if not Comment_Lists.Isempty (Buffer) and
(Comment_Context = Body_Part) then
-- process all "requests" dealing with indentation before printing
-- comments if comments are being formatted and the context is the
-- body part. Process these first, so that Print_New_Line takes
-- indentation into account.
Process_Increase_Requests;
Process_Decrease_Requests;
Process_Change_Requests;
Process_Resume_Requests;
if Requests.New_Lines > 0 then
Print_New_Line;
Requests.New_Lines := 0;
end if;
-- print extra new line if not at the beginning of the line,
-- to get to the beginning of a new line
if not Beginning_Of_Line then
Print_New_Line;
end if;
Print_New_Line;
end if;
while Comment_Lists.More (Iter) loop
Comment_Lists.Next (Iter, Comment_Token);
-- Print new lines between this comment token and
-- previous token in source, unless new lines were already printed
-- for comment formatting.
New_Lines := Comment_Token.Lexed_Token.Srcpos_Line -
Previous_Token.Lexed_Token.Srcpos_Line;
if (Comment_Context = Declarative_Part) or
(Previous_Token.Gram_Sym_Val = Pt.Comment_Tokenvalue) then
for I in 1 .. New_Lines loop
Print_New_Line;
end loop;
end if;
-- try to indent to level of source
if ((Sid.Page_Width - Current_Column) >=
Token_Text (Comment_Token)'Length) then
if Beginning_Of_Line then
Po.Space (Sid.Listing_File,
Current_Column - 1 +
Create_Breakpoint.
Breakpoint_Number_For_Printing'Length);
else
-- put extra space in so comment is separated from previous
-- token
Put_Space;
end if;
else
if New_Lines > 0 then
Current_Column := 1;
end if;
-- if comment can't go where it was in source, put it at same
-- column on next line.
if Comment_Token.Lexed_Token.Srcpos_Column < Current_Column then
Po.Skip_Line (Sid.Listing_File);
Po.Space (Sid.Listing_File,
Comment_Token.Lexed_Token.Srcpos_Column - 1 +
Create_Breakpoint.
Breakpoint_Number_For_Printing'Length);
else
Po.Space (Sid.Listing_File,
Comment_Token.Lexed_Token.Srcpos_Column -
Current_Column +
Create_Breakpoint.
Breakpoint_Number_For_Printing'Length);
end if;
end if;
Po.Put (Sid.Listing_File, Token_Text (Comment_Token));
Free (Comment_Token.Lexed_Token.Text);
Previous_Token := Comment_Token;
end loop;
-- process any requests not handled earlier
Process_Increase_Requests;
Process_Decrease_Requests;
Process_Change_Requests;
Process_Resume_Requests;
Output_Source := Save_Output_Source;
-- if there were some comments in buffer put new line after them
if (not Comment_Lists.Isempty (Buffer)) then
Print_New_Line;
else
for I in 1 .. Requests.New_Lines loop
Print_New_Line;
end loop;
end if;
Requests.New_Lines := 0;
Comment_Lists.Destroy (Buffer);
end Print_Comments;
-----------------------------------------------------------------
procedure New_Line is
--| Effects
--|
--| Requests a new_line for the output. The newline is not actually
--| printed here, in order that comments are put in the appropriate
--| place. The actual newline is printed in Print_New_Line.
begin
if Buffering_Colon_Declarations then
Token_To_Buffer.Requests.New_Lines :=
Token_To_Buffer.Requests.New_Lines + 1;
else
Requests.New_Lines := Requests.New_Lines + 1;
end if;
end New_Line;
-----------------------------------------------------------------
procedure Start_Buffering_Colon_Declarations is
begin
-- create new list if not already buffering tokens
if not Buffering_Colon_Declarations then
Buffering_Colon_Declarations := True;
Token_Lists.Destroy (Token_Buffer);
Token_Buffer := Token_Lists.Create;
end if;
end Start_Buffering_Colon_Declarations;
-----------------------------------------------------------------
procedure Print_Colon_Declarations_Buffer is
Iterator : Token_Lists.Listiter;
Buffered_Token : Token_Descriptor;
Second_Buffer : Token_Lists.List := Token_Lists.Create;
Current_Length : Natural := 0;
Max_Length : Natural := 0;
begin
if Current_Nesting_Level > 0 then
-- attach last token to list. Token would usually be attached
-- in the call to put for the token following Token_To_Buffer.
Token_Lists.Attach (Token_Buffer, Token_To_Buffer);
Buffering_Colon_Declarations := False;
-- get maximum identifier list length, updating tokens with length
-- information, and attach each token to Second_Buffer with this
-- new information.
Iterator := Token_Lists.Makelistiter (Token_Buffer);
while Token_Lists.More (Iterator) loop
Token_Lists.Next (Iterator, Buffered_Token);
-- This can't be a case statement because of non-static bound
-- of type for PT.xxxTokenValue
if (Buffered_Token.Token.Gram_Sym_Val =
Pt.Identifiertokenvalue) or
(Buffered_Token.Token.Gram_Sym_Val =
Pt.Comma_Tokenvalue) then
if not Comment_Lists.Isempty (Buffered_Token.Comments) then
if Current_Length > Max_Length then
Max_Length := Current_Length;
end if;
Current_Length := 0;
end if;
Current_Length :=
Current_Length +
Spaced_Token (Buffered_Token.Token, Previous_Token)'
Length;
Token_Lists.Attach (Second_Buffer, Buffered_Token);
elsif (Buffered_Token.Token.Gram_Sym_Val =
Pt.Colon_Tokenvalue) or
(Buffered_Token.Token.Gram_Sym_Val =
Pt.Nulltokenvalue) then
if Current_Length > Max_Length then
Max_Length := Current_Length;
end if;
if Comment_Lists.Isempty (Buffered_Token.Comments) then
Buffered_Token.Left_Side_Length := Current_Length;
end if;
Current_Length := 0;
Token_Lists.Attach (Second_Buffer, Buffered_Token);
-- skip to semicolon
while Token_Lists.More (Iterator) and
Buffered_Token.Token.Gram_Sym_Val /=
Pt.Semicolon_Tokenvalue loop
Token_Lists.Next (Iterator, Buffered_Token);
Token_Lists.Attach (Second_Buffer, Buffered_Token);
end loop;
elsif Buffered_Token.Token.Gram_Sym_Val in
Pt.Grammarsymbolrange then
Token_Lists.Attach (Second_Buffer, Buffered_Token);
end if;
end loop;
-- Print out Second_Buffer
Iterator := Token_Lists.Makelistiter (Second_Buffer);
while Token_Lists.More (Iterator) loop
Token_Lists.Next (Iterator, Buffered_Token);
Print_Comments (Buffered_Token.Comments);
if (Buffered_Token.Token.Gram_Sym_Val =
Pt.Colon_Tokenvalue) then
Put_Space (Max_Length - Buffered_Token.Left_Side_Length);
end if;
Print_Token (Buffered_Token.Token);
Requests := Buffered_Token.Requests;
Current_Change_Column := Buffered_Token.Current_Change_Column;
end loop;
Token_Lists.Destroy (Second_Buffer);
Initialize_Descriptor (Token_To_Buffer);
Buffering_Colon_Declarations := False;
end if;
end Print_Colon_Declarations_Buffer;
-----------------------------------------------------------------
procedure Increase_Indent is
--| Effects
--|
--| Requests an increase in indentation. The increase is not actually
--| processed here, in order that comments are put in the appropriate
--| place. The actual increase is processed in Process_Increase_Requests.
begin
if Buffering_Colon_Declarations then
Token_To_Buffer.Requests.Increases :=
Token_To_Buffer.Requests.Increases + 1;
else
Requests.Increases := Requests.Increases + 1;
end if;
end Increase_Indent;
-----------------------------------------------------------------
procedure Decrease_Indent is
--| Effects
--|
--| Requests a decrease in indentation. The decrease is not actually
--| processed here, in order that comments are put in the appropriate
--| place. The actual decrease is processed in Process_Decrease_Requests.
begin
if Buffering_Colon_Declarations then
Token_To_Buffer.Requests.Decreases :=
Token_To_Buffer.Requests.Decreases + 1;
else
Requests.Decreases := Requests.Decreases + 1;
end if;
end Decrease_Indent;
-----------------------------------------------------------------
procedure Change_Indent is
--| Effects
--|
--| Requests a change in indentation. The change is not actually
--| processed here, in order that comments are put in the appropriate
--| place. The actual change is processed in Process_Change_Requests.
begin
if Buffering_Colon_Declarations then
Token_To_Buffer.Requests.Changes :=
Token_To_Buffer.Requests.Changes + 1;
Token_To_Buffer.Current_Change_Column := Current_Column;
elsif Buffering_Tokens then
Current_Buffered_Token.Requests.Changes :=
Current_Buffered_Token.Requests.Changes + 1;
Current_Buffered_Token.Current_Change_Column :=
Current_Buffered_Token.Token.Lexed_Token.Srcpos_Column;
else
Requests.Changes := Requests.Changes + 1;
Current_Change_Column := Current_Column;
end if;
end Change_Indent;
-----------------------------------------------------------------
procedure Resume_Normal_Indentation is
--| Effects
--|
--| Requests a resume of the previous indentation. This is not actually
--| processed here, in order that comments are put in the appropriate
--| place. The actual resume is processed in Process_Resume_Requests.
begin
if Buffering_Colon_Declarations then
Token_To_Buffer.Requests.Resumes :=
Token_To_Buffer.Requests.Resumes + 1;
else
Requests.Resumes := Requests.Resumes + 1;
end if;
end Resume_Normal_Indentation;
-----------------------------------------------------------------
procedure Pop_Identifier (Where : in Pop_To_Where := To_Nowhere) is
Popped_Token : Pd.Parsestackelement; --| The token popped off stack
begin
if (Where = To_Nowhere) then
Token_Stack_Pkg.Pop (Identifier_Stack);
else
Token_Stack_Pkg.Pop (Identifier_Stack, Popped_Token);
Put (Popped_Token);
end if;
-- In case this was a subprogram declaration, then discard the
-- parameter list that was built.
Token_Lists.Destroy (Token_Buffer);
Discard_List (Param_List);
Saving_Expanded_Name := False;
end Pop_Identifier;
-----------------------------------------------------------------
procedure Push_Identifier is
begin
-- set source line and column to 0 so that new column and line may
-- be assigned when the pushed token is output as a closing designator
-- or identifier.
Saved_Token.Lexed_Token.Srcpos_Line := 0;
Saved_Token.Lexed_Token.Srcpos_Column := 0;
Current_Scope_Simple_Name := Create (Saved_Token.Lexed_Token.Text.all);
Token_Stack_Pkg.Push (Identifier_Stack, Saved_Token);
Token_Lists.Destroy (Token_Buffer);
end Push_Identifier;
-----------------------------------------------------------------
procedure Push_Empty_Token is
begin
Token_Stack_Pkg.Push (Identifier_Stack, Empty_Token);
end Push_Empty_Token;
-----------------------------------------------------------------
procedure Insert_In_Token is
In_Token : Pd.Parsestackelement :=
(Gram_Sym_Val => Pt.Intokenvalue,
Lexed_Token => (Text => new String'("in"),
Srcpos_Line => 0,
Srcpos_Column => 0));
--| "In" token with source line and column positions set to 0 so that
--| new line and column positions may be assigned the token when it
--| is output.
begin
Put (In_Token);
end Insert_In_Token;
-----------------------------------------------------------------
procedure Switch_Comment_Context is
begin
if Comment_Context = Declarative_Part then
Comment_Context := Body_Part;
else
Comment_Context := Declarative_Part;
end if;
end Switch_Comment_Context;
-----------------------------------------------------------------
-- Local subprogram bodies for pretty printing
-----------------------------------------------------------------
procedure Initialize_Descriptor (Descriptor : in out Token_Descriptor) is
begin
Descriptor.Token := Empty_Token;
-- Change grammar symbol to comment token value which it
-- can never be (since comments are buffered separately)
Descriptor.Token.Gram_Sym_Val := Pt.Comment_Tokenvalue;
Descriptor.Requests := (0, 0, 0, 0, 0);
Descriptor.Current_Change_Column := 0;
Descriptor.Left_Side_Length := 0;
end Initialize_Descriptor;
-----------------------------------------------------------------
procedure Print_Token (Next_Token : in out Pd.Parsestackelement) is
Token_Length : Natural := 0;
Blank_Lines : Integer := 0;
begin
-- give line and column position to tokens being inserted that weren't
-- in the source.
if Next_Token.Lexed_Token.Srcpos_Line = 0 then
Next_Token.Lexed_Token.Srcpos_Line :=
Previous_Token.Lexed_Token.Srcpos_Line;
Next_Token.Lexed_Token.Srcpos_Column :=
Previous_Token.Lexed_Token.Srcpos_Column;
end if;
if (Comment_Context = Declarative_Part) or
((Comment_Context = Body_Part) and
(Previous_Token.Gram_Sym_Val /= Pt.Comment_Tokenvalue)) then
-- print out any blank lines that appeared in source between the
-- previous token and this one.
Blank_Lines := Next_Token.Lexed_Token.Srcpos_Line -
Previous_Token.Lexed_Token.Srcpos_Line - 1;
-- print extra new line if not at beginning of line, so blank line
-- will be printed rather than just a new line
if not Beginning_Of_Line and (Blank_Lines > 0) then
Print_New_Line;
end if;
Po.Skip_Line (Sid.Listing_File, Blank_Lines);
if Output_Source then
Po.Skip_Line (Sid.Instrumented_File, Blank_Lines);
end if;
end if;
Token_Length := Spaced_Token (Next_Token, Previous_Token)'Length;
-- If adding this token will make the line longer than the
-- page width then go to the next line and indent.
if (Current_Column + Token_Length - 1) > Sid.Page_Width then
Print_New_Line;
Temporary_Indent := Sid.Indentation_Level;
Current_Column := Current_Indent + Temporary_Indent + 1;
end if;
-- output spaces if at the beginning of the line to get to the current
-- indentation level.
if Beginning_Of_Line then
Po.Put (Sid.Listing_File, Create_Breakpoint.
Breakpoint_Number_For_Printing);
Create_Breakpoint.Breakpoint_Number_For_Printing := " ";
Po.Space (Sid.Listing_File, Current_Column - 1);
if Output_Source then
Po.Space (Sid.Instrumented_File, Current_Column - 1);
end if;
end if;
-- Output token
Po.Put (Sid.Listing_File, Spaced_Token (Next_Token, Previous_Token));
if Output_Source then
Po.Put (Sid.Instrumented_File,
Spaced_Token (Next_Token, Previous_Token));
end if;
Beginning_Of_Line := False;
-- if the token was too big to fit even on the new line allocated it,
-- set the current_column to the next line
if Token_Length > Sid.Page_Width - Current_Indent then
Print_New_Line;
Temporary_Indent := Sid.Indentation_Level;
Current_Column := Current_Indent + Temporary_Indent + 1;
else
Current_Column := Current_Column + Token_Length;
end if;
if Next_Token.Gram_Sym_Val /= Pt.Empty_Tokenvalue then
Previous_Token := Next_Token;
end if;
end Print_Token;
-----------------------------------------------------------------
function Token_Text (Token : in Pd.Parsestackelement) return String is
begin
if (Token.Gram_Sym_Val in Pd.Singledelimiterrange) or
(Token.Gram_Sym_Val in Pd.Doubledelimiterrange) then
if Token.Gram_Sym_Val = Pt.Bar_Tokenvalue then
if Sid.Delimiters = Sid.Basic then
return ("!");
else
return ("|");
end if;
else
return Pt.Get_Grammar_Symbol (Token.Gram_Sym_Val);
end if;
elsif Token.Gram_Sym_Val = Pt.Stringtokenvalue then
return Ct.String_Value (Token.Lexed_Token.Text);
elsif Token.Gram_Sym_Val = Pt.Charactertokenvalue then
return (Token.Lexed_Token.Text.all & "'");
elsif Token.Gram_Sym_Val = Pt.Comment_Tokenvalue then
return ("--" & Token.Lexed_Token.Text.all);
elsif Token.Gram_Sym_Val in Pd.Reservedwordrange then
return Ct.Change_Case (Token.Lexed_Token.Text, Ct.Lowercase);
elsif Token.Gram_Sym_Val = Pt.Identifiertokenvalue then
return Ct.Change_Case (Token.Lexed_Token.Text, Ct.Uppercase);
elsif (Token.Gram_Sym_Val = Pt.Numerictokenvalue) and
(Sid.Delimiters = Sid.Basic) then
return Ct.Change_Sharp (Token.Lexed_Token.Text);
else
return Token.Lexed_Token.Text.all;
end if;
end Token_Text;
-----------------------------------------------------------------
function Spaced_Token
(Current, Previous : in Pd.Parsestackelement) return String is
Preceding_Space : Boolean := False;
begin
-- Given context of Current and Previous grammar symbols, determine
-- whether space should precede current token.
-- This can't be a case statement because of non-static bound of
-- GrammarSymbolRange, which is the type of all names of the
-- form PT.xxxTokenValue
if (Current.Gram_Sym_Val = Pt.Modtokenvalue) then
if Previous.Gram_Sym_Val /= Pt.Attokenvalue then
Preceding_Space := True;
end if;
elsif (Current.Gram_Sym_Val = Pt.Usetokenvalue) then
if Previous.Gram_Sym_Val /= Pt.Semicolon_Tokenvalue then
Preceding_Space := True;
end if;
elsif (Current.Gram_Sym_Val = Pt.Coloneq_Tokenvalue) then
if Previous.Gram_Sym_Val /= Pt.Constanttokenvalue then
Preceding_Space := True;
end if;
elsif (Current.Gram_Sym_Val = Pt.Thentokenvalue) then
if Previous.Gram_Sym_Val /= Pt.Andtokenvalue then
Preceding_Space := True;
end if;
elsif (Current.Gram_Sym_Val = Pt.Intokenvalue) or
(Current.Gram_Sym_Val = Pt.Looptokenvalue) then
if Previous.Gram_Sym_Val /= Pt.Colon_Tokenvalue then
Preceding_Space := True;
end if;
elsif (Current.Gram_Sym_Val = Pt.Plus_Tokenvalue) or
(Current.Gram_Sym_Val = Pt.Minus_Tokenvalue) then
if Previous.Gram_Sym_Val /= Pt.Leftparen_Tokenvalue then
Preceding_Space := True;
end if;
elsif (Current.Gram_Sym_Val = Pt.Whentokenvalue) then
if Previous.Gram_Sym_Val /= Pt.Semicolon_Tokenvalue then
Preceding_Space := True;
end if;
elsif (Current.Gram_Sym_Val = Pt.Rangetokenvalue) or
(Current.Gram_Sym_Val = Pt.Digitstokenvalue) or
(Current.Gram_Sym_Val = Pt.Deltatokenvalue) then
if (Previous.Gram_Sym_Val /= Pt.Apostrophe_Tokenvalue) and
(Previous.Gram_Sym_Val /= Pt.Istokenvalue) then
Preceding_Space := True;
end if;
elsif (Current.Gram_Sym_Val = Pt.Nottokenvalue) and
(Previous.Gram_Sym_Val = Pt.Identifiertokenvalue) then
Preceding_Space := True;
elsif (Previous.Gram_Sym_Val = Pt.Casetokenvalue) or
(Previous.Gram_Sym_Val = Pt.Deltatokenvalue) or
(Previous.Gram_Sym_Val = Pt.Digitstokenvalue) or
(Previous.Gram_Sym_Val = Pt.Endtokenvalue) or
(Previous.Gram_Sym_Val = Pt.Exittokenvalue) or
(Previous.Gram_Sym_Val = Pt.Iftokenvalue) or
(Previous.Gram_Sym_Val = Pt.Looptokenvalue) or
(Previous.Gram_Sym_Val = Pt.Returntokenvalue) or
(Previous.Gram_Sym_Val = Pt.Raisetokenvalue) or
(Previous.Gram_Sym_Val = Pt.Rangetokenvalue) or
(Previous.Gram_Sym_Val = Pt.Selecttokenvalue) then
if (Current.Gram_Sym_Val /= Pt.Semicolon_Tokenvalue) and
-- Empty Token handles pop of loop or block identifier.
(Current.Gram_Sym_Val /= Pt.Empty_Tokenvalue) then
Preceding_Space := True;
end if;
elsif (Previous.Gram_Sym_Val = Pt.Abstokenvalue) then
if Current.Gram_Sym_Val /= Pt.Leftparen_Tokenvalue then
Preceding_Space := True;
end if;
end if;
-- Return the spaced token
case Sid.Spacing_Table (Current.Gram_Sym_Val) is
when Sid.After =>
if Beginning_Of_Line or not Preceding_Space then
return Token_Text (Current) & " ";
else
return " " & Token_Text (Current) & " ";
end if;
when Sid.Before =>
if Beginning_Of_Line then
return Token_Text (Current);
else
return " " & Token_Text (Current);
end if;
when Sid.Around =>
if Beginning_Of_Line then
return Token_Text (Current) & " ";
else
return " " & Token_Text (Current) & " ";
end if;
when Sid.None =>
if Beginning_Of_Line or not Preceding_Space then
return Token_Text (Current);
else
return " " & Token_Text (Current);
end if;
end case;
end Spaced_Token;
-----------------------------------------------------------------
procedure Print_New_Line is
begin
Temporary_Indent := 0;
Current_Column := Current_Indent + 1;
if Output_Source then
Po.Skip_Line (Sid.Instrumented_File);
end if;
Po.Skip_Line (Sid.Listing_File);
Beginning_Of_Line := True;
end Print_New_Line;
-----------------------------------------------------------------
procedure Process_Increase_Requests is
begin
for I in 1 .. Requests.Increases loop
if Current_Indent + Sid.Indentation_Level < Sid.Rh_Margin then
Current_Indent := Current_Indent + Sid.Indentation_Level;
else
Unperformed_Indents := Unperformed_Indents + 1;
end if;
end loop;
Requests.Increases := 0;
end Process_Increase_Requests;
-----------------------------------------------------------------
procedure Process_Decrease_Requests is
begin
for I in 1 .. Requests.Decreases loop
if Unperformed_Indents = 0 then
Current_Indent := Current_Indent - Sid.Indentation_Level;
else
Unperformed_Indents := Unperformed_Indents - 1;
end if;
end loop;
Requests.Decreases := 0;
end Process_Decrease_Requests;
-----------------------------------------------------------------
procedure Process_Change_Requests is
begin
if Requests.Changes > 0 then
Previous_Indent := Current_Indent;
if Current_Change_Column < Sid.Rh_Margin then
Current_Indent := Current_Change_Column - 1;
end if;
-- Since new line does not always occur before change_indent,
-- need to update current column info.
Temporary_Indent := 0;
Current_Column := Current_Indent + 1;
end if;
Requests.Changes := 0;
end Process_Change_Requests;
-----------------------------------------------------------------
procedure Process_Resume_Requests is
begin
if Requests.Resumes > 0 then
Current_Indent := Previous_Indent;
end if;
Requests.Resumes := 0;
end Process_Resume_Requests;
-----------------------------------------------------------------
-- External Procedures for Source Instrumenter
-----------------------------------------------------------------
procedure Use_Package_Name is
--| Effects
--|
--| The current expanded name is the package name in the
--| use clause.
begin
Saving_Expanded_Name := False;
end Use_Package_Name;
-----------------------------------------------------------------
procedure With_Library_Unit is
--| Effects
--|
--| If the library unit is instrumented and type tracing is on,
--| then add the name to the "with_list". Its tracing package
--| will have to be added to the context clause in the instrumented
--| source.
Withed_Package : Name_Record;
begin
if Do_Type_Tracing and then
Bfp.Package_Files_Exist
(Saved_Token.Lexed_Token.Text.all, Public_Files) then
String_Lists.Attach (With_List,
Create (Saved_Token.Lexed_Token.Text.all));
end if;
end With_Library_Unit;
------------------------------------------------------------------
procedure Start_Saving_Expanded_Name is
--| Effects
--|
--| Start saving tokens for an expanded name.
begin
Flush (Expanded_Name);
Saving_Expanded_Name := True;
end Start_Saving_Expanded_Name;
-----------------------------------------------------------------
procedure Save_Separate_Name is
--| Effects
--|
--| The current expanded name is the name of the parent unit.
--| Use it to set the Current_Outer_Scope and turn off the
--| "Saving_Expanded_Name" flag.
begin
Saving_Expanded_Name := False;
Separate_Unit := True;
Current_Outer_Scope :=
(Create (Saved_Token.Lexed_Token.Text.all), Expanded_Name, A_Block,
Create (Saved_Token.Lexed_Token.Text.all), False, Entry_Exit);
end Save_Separate_Name;
-----------------------------------------------------------------
procedure Save_Generic_Name is
--| Effects
--|
--| The current expanded name is the generic unit name. The
--| instantiated name is in "Saved_Identifier". Turn off the
--| "Saving_Expanded_Name" flag. Tracing generics is currently
--| unimplemented.
begin
Saving_Expanded_Name := False;
end Save_Generic_Name;
------------------------------------------------------------------
procedure Subprogram_Type (Intype : in String) is
--| Effects
--|
--| Saves the type of the current subprogram. At increment scope
--| if the current unit is a subprogram then subprogram_unit_type
--| will be used to determine what kind of subprogram it is.
begin
if Intype = "procedure" then
Subprogram_Unit_Type := Procedure_Type;
else
Subprogram_Unit_Type := Function_Type;
Saving_Expanded_Name := False;
end if;
end Subprogram_Type;
------------------------------------------------------------------
procedure Start_Begin_End_Block is
--| Effects
--|
--| If this is a package body then add the call to UNIT_INFORMATION(we
--| are in the package body begin-end). If the current unit is not
--| an block then output an entering unit call and a breakpoint.
begin
if Current_Scope.Type_Of_Scope /= A_Block then
if Current_Scope.Type_Of_Scope = Package_Body and
Current_Nesting_Level = 1 then
Print_Comments (Comment_Buffer);
Create_Breakpoint.Create_Unit_Information;
end if;
Create_Breakpoint.Create_Entering_Unit;
Create_Breakpoint.Create_Breakpoint
(Other_Breakpoint, Current_Scope.Putvar_Name);
end if;
end Start_Begin_End_Block;
------------------------------------------------------------------
procedure End_Block_Sequence_Of_Statements is
--| Effects
--|
--| If we are not in a block then output an exiting unit call and
--| a breakpoint.
begin
if Current_Scope.Type_Of_Scope /= A_Block then
Create_Breakpoint.Create_Breakpoint
(Other_Breakpoint, Current_Scope.Putvar_Name);
Create_Breakpoint.Create_Exiting_Unit;
end if;
end End_Block_Sequence_Of_Statements;
-----------------------------------------------------------------
procedure End_Block_Statement is
--| Effects
--|
--| We are exiting a scope, so if there is an outer scope then pop
--| the information about that scope so that it becomes the current
--| unit.
begin
Scope_Stack_Pkg.Pop (Scope_Stack, Current_Scope);
if not Scope_Stack_Pkg.Is_Empty (Scope_Stack) then
Current_Outer_Scope := Scope_Stack_Pkg.Top (Scope_Stack);
else
Current_Outer_Scope := (Create (""), Create (""), A_Block,
Create (""), False, Entry_Exit);
end if;
Current_Scope_Qualified_Name := Current_Scope.Qualified_Name;
Current_Nesting_Level := Current_Nesting_Level - 1;
end End_Block_Statement;
-----------------------------------------------------------------
procedure Add_Breakpoint (Type_Of_Breakpoint : in Add_Breakpoint_Type) is
--| Effects
--|
--| This procedure is called before every statement within a begin-end.
--| Based on the current trace_level and the type of statement, a
--| decision is made whether to output a breakpoint. If we don't
--| know whether or not to output a breakpont yet, then start
--| buffering tokens until we know.
begin
case Type_Of_Breakpoint is
when Every_Statement =>
-- current statement is a simple(non decision point) statement, so
-- add a breakpoint only if trace level is every statement.
if Current_Scope.Scope_Trace_Level = All_Statements then
Create_Breakpoint.Create_Breakpoint
(Other_Breakpoint, Current_Scope.Putvar_Name);
end if;
when Decision_Point =>
-- Current statement is a decision point. Add a breakpoint if
-- we are not tracing entry/exit
if Current_Scope.Scope_Trace_Level /= Entry_Exit then
Create_Breakpoint.Create_Breakpoint
(Other_Breakpoint, Current_Scope.Putvar_Name);
end if;
when Always =>
-- Current statement is a return statement. Add a breakpoint and
-- an exiting unit.
Create_Breakpoint.Create_Breakpoint
(Other_Breakpoint, Current_Scope.Putvar_Name);
Create_Breakpoint.Create_Exiting_Unit;
when Ambiguous =>
-- Type of Current statement is unknown, so if trace level is
-- decision point start buffering tokens. If trace level is
-- every statement add a breakpoint. If trace level is entry/exit
-- then do nothing.
case Current_Scope.Scope_Trace_Level is
when All_Statements =>
Create_Breakpoint.Create_Breakpoint
(Other_Breakpoint, Current_Scope.Putvar_Name);
when Decision_Point =>
Buffering_Tokens := True;
--start buffer
Token_Lists.Destroy (Buffered_Tokens);
Buffered_Tokens := Token_Lists.Create;
Print_Comments (Comment_Buffer);
when Entry_Exit =>
null;
end case;
end case;
end Add_Breakpoint;
------------------------------------------------------------------
procedure Resolve_Breakpoint (Resolve_Type : in Resolve_Breakpoint_Type) is
--| Effects
--|
--| The type of an ambiguous statement is now known. If it was a decision
--| point then add a breakpoint. If it is a block statement, then
--| make the block the current scope. If the block had no name then
--| make up a unique name for it.
Current_Block_Number_String : String_Type;
begin
if Current_Scope.Scope_Trace_Level = Decision_Point then
if (Resolve_Type = Loop_No_Identifier) or
(Resolve_Type = Loop_With_Identifier) then
Create_Breakpoint.Create_Breakpoint
(Other_Breakpoint, Current_Scope.Putvar_Name);
end if;
Print_Buffered_Tokens;
end if;
-- The current statement is a block. Add it to the scope stack.
if (Resolve_Type = Block_No_Identifier) or
(Resolve_Type = Block_With_Identifier) then
Current_Nesting_Level := Current_Nesting_Level + 1;
Scope_Stack_Pkg.Push (Scope_Stack, Current_Scope);
Current_Outer_Scope := Current_Scope;
-- The block does not have a name, so make one for it.
if Resolve_Type = Block_No_Identifier then
Current_Block_Number := Current_Block_Number + 1;
Current_Block_Number_String :=
Create (Integer'Image (Current_Block_Number));
Current_Block_Number_String :=
"_" & Substr (Current_Block_Number_String, 2,
Length (Current_Block_Number_String) - 1);
Current_Scope_Simple_Name :=
Create (Prefix & "BLOCK" & Value
(Current_Block_Number_String));
Current_Scope_Qualified_Name :=
Current_Scope_Qualified_Name &
"." & Current_Scope_Simple_Name;
Current_Scope := (Current_Scope_Simple_Name,
Current_Scope_Qualified_Name, A_Block,
Current_Outer_Scope.Putvar_Name,
False, Current_Trace_Level);
if Do_Type_Tracing then
Identifier_Token.Lexed_Token.Text :=
new String'(Prefix & "BLOCK" &
Value (Current_Block_Number_String));
Identifier_Token.Lexed_Token.Srcpos_Line := 0;
Identifier_Token.Lexed_Token.Srcpos_Column := 0;
Token_Stack_Pkg.Push (Identifier_Stack, Identifier_Token);
Put (Identifier_Token);
Colon_Token.Lexed_Token.Srcpos_Line := 0;
Colon_Token.Lexed_Token.Srcpos_Column := 0;
Put (Colon_Token);
else
Push_Empty_Token;
end if;
else
-- block with identifier
Current_Scope_Qualified_Name :=
Current_Scope_Qualified_Name &
"." & Current_Scope_Simple_Name;
Current_Scope := (Current_Scope_Simple_Name,
Current_Scope_Qualified_Name, A_Block,
Current_Outer_Scope.Putvar_Name,
False, Current_Trace_Level);
end if;
end if;
end Resolve_Breakpoint;
------------------------------------------------------------------
procedure Start_Loop is
--| Effects
--|
--| If trace level is not entry/exit then add a breakpoint that
--| identifies this statement as a loop.
begin
if Current_Scope.Scope_Trace_Level /= Entry_Exit then
Create_Breakpoint.Create_Breakpoint
(Loop_Breakpoint, Current_Scope.Putvar_Name);
end if;
end Start_Loop;
-----------------------------------------------------------------
procedure Start_Delay_Expression is
--| Effects
--|
--| Convert the delay expresstion into a function call to
--| "Starting_Delay" which is a function that informs the profiler
--| that the currently executing unit is about to delay the
--| given amount of time.
begin
Po.Put (Sid.Instrumented_File,
"Starting_Delay (" &
Value (Create_Breakpoint.Get_Program_Unit) & ",");
end Start_Delay_Expression;
-----------------------------------------------------------------
procedure End_Delay_Expression is
--| Effects
--|
--| Finish the function call to "Starting_Delay".
begin
Po.Put (Sid.Instrumented_File, ")");
end End_Delay_Expression;
------------------------------------------------------------------
procedure Add_Package_Body_Begin is
--| Effects
--|
--| If a package body that is a compilation unit does not have a
--| begin end block then add one that makes a call to unit
--| information.
begin
if Current_Nesting_Level = 1 then
Print_Comments (Comment_Buffer);
Po.Put_Line (Sid.Instrumented_File, "begin");
Create_Breakpoint.Create_Unit_Information;
end if;
end Add_Package_Body_Begin;
------------------------------------------------------------------
procedure Start_Exception_Branch is
--| Effects
--|
--| We are starting an exception branch in the source. We must nest this
--| in a begin-end block so that we can handle any exceptions raised
--| during execution of the exception handler.
begin
if Current_Scope.Type_Of_Scope /= A_Block then
if not (Current_Scope.Type_Of_Scope = Package_Body and
Current_Nesting_Level > 1) then
Po.Put (Sid.Instrumented_File, "begin");
end if;
end if;
end Start_Exception_Branch;
------------------------------------------------------------------
procedure End_Exception_Sequence_Of_Statements is
--| Effects
--|
--| The block that contains the exception handler must now be finished.
--| Add an others hanler for the block that calls exiting unit and then
--| re raises the exception. This will inform the RTM that the unit
--| has exited, and then by reraising the exception will allow the
--| users code to execute normally.
begin
if Current_Scope.Type_Of_Scope /= A_Block then
if not (Current_Scope.Type_Of_Scope = Package_Body and
Current_Nesting_Level > 1) then
Create_Breakpoint.Create_Breakpoint
(Other_Breakpoint, Current_Scope.Putvar_Name);
Create_Breakpoint.Create_Exiting_Unit;
Po.Put_Line (Sid.Instrumented_File, "exception");
Add_Others_Handler;
Po.Space_Line (Sid.Instrumented_File, 1);
Po.Put (Sid.Instrumented_File, "end;");
end if;
end if;
end End_Exception_Sequence_Of_Statements;
------------------------------------------------------------------
procedure Add_Others_Handler is
--| The source did not have an others handler so add one. The others
--| handler that we add will call exiting unit and then reraise the
--| exception.
begin
if Current_Scope.Type_Of_Scope /= A_Block then
if not (Current_Scope.Type_Of_Scope = Package_Body and
Current_Nesting_Level > 1) then
Po.Space_Line (Sid.Instrumented_File, 1);
Po.Put (Sid.Instrumented_File, " when others =>");
Create_Breakpoint.Create_Exiting_Unit;
Po.Put (Sid.Instrumented_File, "raise;");
end if;
end if;
end Add_Others_Handler;
------------------------------------------------------------------
procedure Add_Exception_Handler is
--| Effects
--|
--| The source had no exception handler so add an exception handler
--| with an others branch. In the others branch call exiting
--| unit and then re-raise the exception.
begin
if Current_Scope.Type_Of_Scope /= A_Block then
if not (Current_Scope.Type_Of_Scope = Package_Body and
Current_Nesting_Level > 1) then
Po.Put (Sid.Instrumented_File, "exception");
Po.Put_Line (Sid.Instrumented_File, " when others =>");
Create_Breakpoint.Create_Exiting_Unit;
Po.Put (Sid.Instrumented_File, "raise;");
end if;
end if;
end Add_Exception_Handler;
-----------------------------------------------------------------
procedure End_Compilation_Unit is
--| Effects
--|
--| Print any buffered tokens, and reset buffering and lists
--| in case more compilation units follow.
begin
-- if the compilation unit was a subprogram declaration, then
-- print any buffered tokens, and discard the with_list if
-- there is one.
if Buffering_Tokens then
Print_Buffered_Tokens;
end if;
if Buffering_Colon_Declarations then
Print_Colon_Declarations_Buffer;
end if;
Process_Decrease_Requests;
String_Lists.Destroy (With_List);
-- The current version of the file which maps package names to
-- type tracing information files might have changed if there
-- were any package specs in the program, so update it.
Bfp.Save_External_File;
-- End the current compilation unit with a new line, and restart
-- buffering in case there are more compilation units to come.
Print_New_Line;
Output_Source := True;
Buffering_Tokens := True;
Token_Lists.Destroy (Buffered_Tokens);
Buffered_Tokens := Token_Lists.Create;
end End_Compilation_Unit;
----------------------------------------------------------------------------
procedure Increment_Scope (Type_Of_Scope : in Scope_Type) is
--|Effects
--|
--|We have entered a new unit, so we must set up to process it.
--|First determine the type of unit. Next call set_scope_records
--|to push any enclosing unit on the stack and to set up the current
--|unit. If we need instrumenting instructions(doing type tracing or
--|statement trace mode is mixed) then get the user input. Determine
--|if this is a nested unit or a compilation unit and inform the
--|create_breakpoint package.
Type_Of_Unit : Program_Unit_Type;
begin
case Type_Of_Scope is
when Package_Specification | Package_Body =>
Type_Of_Unit := Package_Type;
when Task_Body =>
Type_Of_Unit := Task_Type;
when Subprogram_Body =>
Type_Of_Unit := Subprogram_Unit_Type;
when others =>
null;
end case;
Set_Scope_Records (Type_Of_Scope);
if Do_Type_Tracing then
String_Stack_Pkg.Push (Vars_To_Trace_Stack, Vars_To_Trace);
Vars_To_Trace := String_Lists.Create;
end if;
if Do_Type_Tracing or (Current_Trace_Mode = Mixed) then
Get_Unit_Instructions
(Get_Unit_Name (Type_Of_Scope),
Type_Of_Scope = Package_Specification, Current_Trace_Level,
Value (Current_Scope.Qualified_Name), Vars_To_Trace);
end if;
Current_Scope.Scope_Trace_Level := Current_Trace_Level;
if Type_Of_Scope = Package_Specification then
-- Delete any old type tracing files. New ones will be made if
-- type tracing is on.
Bfp.Delete_Package_Files
(Value (Current_Scope.Qualified_Name), All_Files);
if Current_Nesting_Level = 0 then
-- ask user if he wants to recompile this package spec --
Output_Source := Ask_User_About_Package;
end if;
if Do_Type_Tracing then
Initialize_Trace_Packages;
end if;
end if; -- type of scope = package spec
if Current_Nesting_Level = 0 then
Create_Subunit := (Type_Of_Scope = Subprogram_Body);
if Type_Of_Scope = Subprogram_Body or
Type_Of_Scope = Package_Body then
Add_Withs_To_Body;
end if;
Create_Breakpoint.New_Compilation_Unit
(Current_Scope_Qualified_Name, Type_Of_Unit);
elsif Type_Of_Scope /= Package_Specification then
-- Current_Nesting_Level /= 0
Create_Breakpoint.Start_Program_Unit
(Current_Scope_Qualified_Name, Type_Of_Unit);
end if;
Current_Nesting_Level := Current_Nesting_Level + 1;
Saving_Expanded_Name := False;
Print_Buffered_Tokens;
if Buffering_Colon_Declarations then
Print_Colon_Declarations_Buffer;
end if;
Separate_Unit := False;
Scope_Stack_Pkg.Push (Scope_Stack, Current_Outer_Scope);
end Increment_Scope;
---------------------------------------------------------------
procedure Decrement_Scope is
--|Effects
--|
--|We are exiting a unit. Close trace packages if we are type tracing
--|a package spec. Pop the enclosing unit's list of user requested
--|variables to trace. Inform the create_breakpoint package that
--|we are exiting the current unit. Pop the information about
--|the outer scope(if any) and set up the scope descriptors for
--|current unit and current outer unit.
User_List_Iter : String_Lists.Listiter;
Next_User_List_Name : String_Type;
begin
if Do_Type_Tracing then
if Current_Scope.Type_Of_Scope = Package_Specification then
Close_Trace_Packages;
end if;
-- see if all requested variables were found
if not String_Lists.Isempty (Vars_To_Trace) then
User_List_Iter := String_Lists.Makelistiter (Vars_To_Trace);
String_Lists.Next (User_List_Iter, Next_User_List_Name);
if Match_S (Upper (Next_User_List_Name), "*ALL") /= 0 then
Flush (Next_User_List_Name);
else
-- if there are any names left in the user_list,
-- issue an error message.
loop
Text_Io.Put_Line
(Value (Next_User_List_Name) & " not found");
Flush (Next_User_List_Name);
exit when not String_Lists.More (User_List_Iter);
String_Lists.Next (User_List_Iter, Next_User_List_Name);
end loop;
end if; -- next_name /= *ALL
end if; -- vars_to_trace not empty
String_Stack_Pkg.Pop (Vars_To_Trace_Stack, Vars_To_Trace);
end if; -- if do_type_tracing
if Current_Scope.Type_Of_Scope /= Package_Specification or
Current_Nesting_Level = 1 then
Create_Breakpoint.End_Program_Unit;
end if;
Scope_Stack_Pkg.Pop (Scope_Stack, Current_Scope);
Current_Nesting_Level := Current_Nesting_Level - 1;
if Current_Nesting_Level /= 0 then
Current_Outer_Scope := Scope_Stack_Pkg.Top (Scope_Stack);
Current_Scope_Qualified_Name := Current_Scope.Qualified_Name;
-- Push_Identifer always resets Current_Scope_Simple_Name
end if;
Token_Lists.Destroy (Token_Buffer);
end Decrement_Scope;
-------------------------------------------------------------------
procedure Start_Declarative_Part is
--|Effects
--|
--|If we are in a subprogram that is a compilation unit, then define
--|a unique call_unit_info for that unit. For all units define a
--|task number used in calls to the RTM. If type tracing is on then
--|stack the outer scope's tracing information, re-initialize
--|everything for the current scope, and generate the putvar procedure
--|declaration.
Temp_Scope : Pd.Parsestackelement;
begin
if (Current_Nesting_Level = 1) and (Create_Subunit = True) then
Po.Space_Line (Sid.Instrumented_File, 1);
Po.Put (Sid.Instrumented_File,
"procedure " & Ct.Convert_Periods_To_Underscores
(Value (Current_Scope.Qualified_Name)) &
"_Call_Unit_Information;");
end if;
if Current_Scope.Type_Of_Scope /= A_Block then
Po.Space_Line (Sid.Instrumented_File, 1);
Po.Put (Sid.Instrumented_File,
Prefix & "Task_Number: natural := 1;");
else
Temp_Scope := Token_Stack_Pkg.Top (Identifier_Stack);
Current_Scope.Putvar_Name := Create
(Temp_Scope.Lexed_Token.Text.all);
end if;
-- Set up type tracing; the current declarative part is for
-- a body or a block.
if Do_Type_Tracing then
List_Stack_Pkg.Push (Visible_List_Stack, Visible_List);
String_Stack_Pkg.Push (Package_List_Stack, Package_List);
Visible_List := Name_Lists.Create;
Package_List := String_Lists.Create;
-- add procedure declaration for "putvars"
Write_Spec_Line ("");
Write_Spec_Line ("Procedure " & Value (Current_Scope.Scope_Name) &
"_" & Prefix & "Putvars;");
if Current_Scope.Type_Of_Scope = Package_Body then
Bfp.Copy_Package_Files (Private_Spec,
Value (Current_Scope.Qualified_Name),
Sid.Instrumented_File);
end if;
if not Name_Lists.Isempty (Param_List) then
Name_Lists.Attach (Visible_List, Name_Lists.Copy (Param_List));
Name_Lists.Destroy (Param_List);
end if;
Bfp.Start_New_Section;
end if;
end Start_Declarative_Part;
----------------------------------------------------------------
procedure End_Declarative_Part is
--|Effects
--|
--|If this is the declarative part of a compilation unit that is a procedure
--|then define the unique call_unit_information to be a subunit. If
--|we are doing type tracing 1) if it is a package body, then retieve
--|the instrumenting information file for the private part of the
--|corresponding package spec. 2) Finish generating th tracing procedures.
--|3) Copy the procedure bodies from the buffer file that were saved
--|until the end of the later declarative part. 4) If there were
--|any user requested variables to trace that weren't found then
--|issue an error message.
Iter : String_Lists.Listiter;
Next_Object : String_Type;
begin
if (Current_Nesting_Level = 1) and (Create_Subunit = True) then
Po.Space_Line (Sid.Instrumented_File, 1);
Po.Put (Sid.Instrumented_File,
"procedure " & Ct.Convert_Periods_To_Underscores
(Value (Current_Scope.Qualified_Name)) &
"_Call_Unit_Information is separate;");
end if;
-- Finish the type tracing for this declarative part; the
-- "begin ... end" part follows next.
if Do_Type_Tracing then
Generate_Putvars;
if Current_Scope.Type_Of_Scope = Package_Body then
Bfp.Copy_Package_Files (Private_Body,
Value (Current_Scope.Qualified_Name),
Sid.Instrumented_File);
end if;
Iter := String_Lists.Makelistiter (Package_List);
while String_Lists.More (Iter) loop
String_Lists.Next (Iter, Next_Object);
Bfp.Copy_Package_Files
(Public_Body, Value (Current_Scope.Qualified_Name &
"." & Next_Object),
Sid.Instrumented_File);
Flush (Next_Object);
end loop;
String_Lists.Destroy (Package_List);
Bfp.Save_Buffer_File (Sid.Instrumented_File);
Bfp.Release_Section;
List_Stack_Pkg.Pop (Visible_List_Stack, Visible_List);
String_Stack_Pkg.Pop (Package_List_Stack, Package_List);
end if;
end End_Declarative_Part;
-----------------------------------------------------------------
procedure Add_Identifier_To_List is
--| Effects
--|
--| If type tracing is on, add the current identifier to "current_list".
--| The current identifier's name is in Saved_Token.
Current_Name : Name_Record;
begin
if Do_Type_Tracing then
Current_Name.Object_Name := Make_Persistent
(Saved_Token.Lexed_Token.Text.all);
-- The mode will be set later...
Name_Lists.Attach (Current_List, Current_Name);
end if;
end Add_Identifier_To_List;
-----------------------------------------------------------------
procedure Set_Identifier_Mode (Mode : in Identifier_Mode) is
--| Effects
--|
--| Save the mode of the current identifier list.
begin
Current_Mode := Mode;
end Set_Identifier_Mode;
-----------------------------------------------------------------
procedure Process_Identifier_List (List_Type : in Identifier_List_Type) is
--| Effects
--|
--| This is called at the end of the current identifier list.
--| Update the mode and type for all identifiers in the list,
--| and save the list for later processing, depending on the
--| type of list this is.
Iter : Name_Lists.Listiter;
Next_Object : Name_Record;
begin
-- Note: anonymous array processing currently discards the
-- current_list
if Do_Type_Tracing then
case List_Type is
when Object_List | Parameter_List |
Discriminant_List | Record_Field_List =>
Iter := Name_Lists.Makelistiter (Current_List);
while Name_Lists.More (Iter) loop
Name_Lists.Next (Iter, Next_Object);
Next_Object.Object_Mode := Current_Mode;
case List_Type is
when Discriminant_List =>
-- TBD do tracevar things to handle discriminants --
Flush (Expanded_Name);
when Record_Field_List =>
-- TBD do tracevar things for record fields --
null;
when Object_List =>
Next_Object.Object_Name :=
Current_Scope.Qualified_Name &
"." & Next_Object.Object_Name;
Name_Lists.Attach (Visible_List, Next_Object);
when Parameter_List =>
if Current_Nesting_Level = 0 then
Next_Object.Object_Name :=
Current_Scope_Simple_Name & "." &
Next_Object.Object_Name;
else
Next_Object.Object_Name :=
Current_Scope.Qualified_Name & "." &
Current_Scope_Simple_Name &
"." & Next_Object.Object_Name;
end if;
Name_Lists.Attach (Param_List, Next_Object);
when others =>
null;
end case;
end loop;
when others =>
null;
end case;
Name_Lists.Destroy (Current_List);
end if;
Current_Mode := None;
end Process_Identifier_List;
-----------------------------------------------------------------
procedure Save_Type_Identifier is
--| Effects
--|
--| The current saved_token is a type identifier. If type tracing
--| is on, save the type identifier for use in generating the
--| "tracevar" procedures.
begin
if Do_Type_Tracing then
Flush (Current_Type_Identifier);
Current_Type_Identifier :=
Current_Scope.Qualified_Name & "." &
Create (Saved_Token.Lexed_Token.Text.all);
end if;
end Save_Type_Identifier;
-----------------------------------------------------------------
procedure Start_Trace_Procedure (Type_Kind : in Type_Class) is
--| Effects
--|
--| Generate the body of the tracing procedure for the current
--| type declaration.
begin
if Do_Type_Tracing then
Generate_Tracevar_Spec := True;
if Type_Kind = Task_Type then
Current_Type_Identifier :=
Current_Scope.Qualified_Name & "." &
Create (Saved_Token.Lexed_Token.Text.all);
end if;
-- write out the constant part of the header
for I in 1 .. Tracevar_Header'Last - 1 loop
Write_Body_Line (Value (Tracevar_Header (I)));
end loop;
-- write out the last line, filling in the type name
-- for "current_value"
Write_Body_Line (Value (Tracevar_Header (Tracevar_Header'Last)) &
" " & Value (Current_Type_Identifier) & ") is");
-- beware that records and arrays will need local vars --
Write_Body_Line ("begin");
case Type_Kind is
when Enumeration_Type =>
Write_Body_Line (" RTM.Put_Value");
Write_Body_Line (" (Current_Unit, Variable_Name, " &
Value (Current_Type_Identifier) &
"'image (Current_Value));");
when Integer_Type =>
Write_Body_Line (" RTM.Put_Value");
Write_Body_Line (" (Current_Unit, Variable_Name, " &
"Integer(Current_Value));");
when Float_Type | Fixed_Type =>
Write_Body_Line (" RTM.Put_Value");
Write_Body_Line (" (Current_Unit, Variable_Name, " &
"Float(Current_Value));");
when Derived_Type =>
-- expanded name is the parent type name --
Write_Body_Line (" Source_Instrumenter_Added_Tracevar");
Write_Body_Line (" (Current_Unit, Variable_Name, " &
Value (Expanded_Name) &
"(Current_Value));");
Flush (Expanded_Name);
when others =>
Write_Body_Line (" RTM.Put_Value");
Write_Body_Line (" (Current_Unit, Variable_Name, ");
Write_Body_Line (" ""Values of type " &
Value (Current_Type_Identifier) &
" cannot be displayed"");");
end case;
Write_Body_Line ("exception");
Write_Body_Line (" when others => null;");
Write_Body_Line ("end;");
end if;
end Start_Trace_Procedure;
-----------------------------------------------------------------
procedure End_Type_Declaration is
--| Effects
--|
--| Generate a procedure declaration for the current tracevar
--| procedure.
begin
if Do_Type_Tracing then
if Generate_Tracevar_Spec then
Write_Spec_Line ("");
-- write out the constant part of the header
for I in 1 .. Tracevar_Header'Last - 1 loop
Write_Spec_Line (Value (Tracevar_Header (I)));
end loop;
-- write out the last line, filling in the type name
-- for "current_value"
Write_Spec_Line (Value (Tracevar_Header
(Tracevar_Header'Last)) & " " &
Value (Current_Type_Identifier) & ");");
end if;
Generate_Tracevar_Spec := False;
Flush (Current_Type_Identifier);
end if;
Token_Lists.Destroy (Token_Buffer);
end End_Type_Declaration;
-----------------------------------------------------------------
procedure Start_Anonymous_Array_Definition is
--| Effects
--|
--| For now, the current identifier list is destroyed. When
--| implemented, this procedure will generate a type name for the
--| anonymous array definition so that a tracevar procedure can be
--| written for the type.
begin
if Do_Type_Tracing then
Name_Lists.Destroy (Current_List); -- temporary
end if;
-- stop buffering colon decls
-- attach current token_to_buffer to buffer
-- set current_type_identifier to a name we create (foo) and
-- create a new token_to_buffer for it
-- write "type foo is" to output files
-- call start_trace (array type) to generate tracevar proc
end Start_Anonymous_Array_Definition;
-----------------------------------------------------------------
procedure End_Typemark is
--| Effects
--|
--| The current expanded name is a typemark name, before any
--| constraints which may follow. Not all typemarks are saved
--| but in all cases turn off the "Saving_Expanded_Name" flag.
begin
Saving_Expanded_Name := False;
end End_Typemark;
-----------------------------------------------------------------
procedure Start_Private_Part is
--| Effects
--|
--| This procedure is called at the start of the private part
--| of a package specification. If type tracing is on, stack
--| the visible variables list from the public part and set the
--| "In_Private_Part" field of the current scope record so that
--| tracing information will be written to the private tracing
--| files.
begin
if Do_Type_Tracing then
List_Stack_Pkg.Push (Visible_List_Stack, Visible_List);
Visible_List := Name_Lists.Create;
Current_Scope.In_Private_Part := True;
Write_Spec_Line ("Procedure " & Value (Current_Scope.Scope_Name) &
"priv_" & Prefix & "Putvars;");
end if;
end Start_Private_Part;
--------------------------------------------------------------
-- Local Subprogram Bodies
--------------------------------------------------------------
procedure Print_Buffered_Tokens is
--|Effects
--|
--|If there were any tokens that were buffered then print them out now.
--|The last token that was buffered must first be added to the list
--|of buffered tokens from the place holder.
Iterator : Token_Lists.Listiter;
Current_Token : Token_Descriptor;
begin
if Current_Buffered_Token.Token.Gram_Sym_Val /=
Pt.Comment_Tokenvalue then
Requests.Changes := Requests.Changes +
Current_Buffered_Token.Requests.Changes;
Current_Buffered_Token.Requests := Requests;
Requests := (0, 0, 0, 0, 0);
Token_Lists.Attach (Buffered_Tokens, Current_Buffered_Token);
Initialize_Descriptor (Current_Buffered_Token);
end if;
Iterator := Token_Lists.Makelistiter (Buffered_Tokens);
while Token_Lists.More (Iterator) loop
Token_Lists.Next (Iterator, Current_Token);
Print_Comments (Current_Token.Comments);
Print_Token (Current_Token.Token);
Requests := Current_Token.Requests;
Current_Change_Column := Current_Token.Current_Change_Column;
end loop;
Token_Lists.Destroy (Buffered_Tokens);
Buffering_Tokens := False;
end Print_Buffered_Tokens;
-----------------------------------------------------------------
function Match_Names (User_Name, Si_Name : in String) return Boolean is
--| Effects
--|
--| USER_NAME is the name of the variable the user requested to
--| trace. SI_NAME is the name of a variable found in the
--| program. See if they match, not counting indexed and
--| selected components.
Ch : Character;
begin
if User_Name = Si_Name then
return True;
end if;
if User_Name'Length > Si_Name'Length and then
User_Name (1 .. Si_Name'Length) = Si_Name then
Ch := User_Name (Si_Name'Length + 1);
return (Ch = '.' or Ch = ' ' or Ch = '(');
end if;
return False;
end Match_Names;
-----------------------------------------------------------------
procedure Check_Lists is
--| Effects
--|
--| Compare the list of variables the user wants to trace
--| (VARS_TO_TRACE) with the list of visible variables
--| found by the instrumenter (VISIBLE_LIST). If there is a
--| match, then change the visible list's version of the name
--| to what the user requested, to allow for selected components.
--| At the end, the VISIBLE_LIST will be a new list which has the
--| revised variable names.
User_List_Iter : String_Lists.Listiter;
Next_User_List_Name : String_Type;
Vis_List_Iter : Name_Lists.Listiter;
Next_Vis_List_Name : Name_Record;
Temp_List : Name_Lists.List := Name_Lists.Create;
begin
if not String_Lists.Isempty (Vars_To_Trace) then
User_List_Iter := String_Lists.Makelistiter (Vars_To_Trace);
String_Lists.Next (User_List_Iter, Next_User_List_Name);
if String_Pkg.Match_S (Upper (Next_User_List_Name), "*ALL") /=
0 then
return;
end if;
-- loop through the list of user requested vars to trace
loop
-- see if the var is in the visible list
Vis_List_Iter := Name_Lists.Makelistiter (Visible_List);
while Name_Lists.More (Vis_List_Iter) loop
Name_Lists.Next (Vis_List_Iter, Next_Vis_List_Name);
if Match_Names (Value (Upper (Next_User_List_Name)),
Value (Upper (Next_Vis_List_Name.
Object_Name))) then
-- save this name, and delete it from user_list
Next_Vis_List_Name.Object_Name :=
Make_Persistent (Next_User_List_Name);
Name_Lists.Attach (Temp_List, Next_Vis_List_Name);
String_Lists.Deleteitem
(Vars_To_Trace, Next_User_List_Name);
exit;
end if; -- names match
end loop; -- while more in vis_list
exit when not String_Lists.More (User_List_Iter);
String_Lists.Next (User_List_Iter, Next_User_List_Name);
end loop; -- while more in users lilst
end if; -- not is empty (user's list)
-- save the temp list as the new visible list
Discard_List (Visible_List);
Name_Lists.Attach (Visible_List, Name_Lists.Copy (Temp_List));
Name_Lists.Destroy (Temp_List);
end Check_Lists;
-----------------------------------------------------------------
function Get_Unit_Name (Type_Of_Scope : in Scope_Type) return String is
--| Effects
--|
--| This function searches through the buffered tokens and forms a
--| string representation of the current unit specification. The
--| function will add spaces where neccesary but will not add and
--| carriage control.
-- Define an access to a string to hold the unit specification as it
-- is constructed
type Unit_Descriptor is access String;
Unit_Name : Unit_Descriptor;
Buffer_Iterator : Token_Lists.Listiter; -- Iterator to walk the lists
Current_Token : Token_Descriptor;
-- Holder for token currently being processed
begin
case Type_Of_Scope is
when Package_Specification =>
Unit_Name := new String'("package ");
when Package_Body =>
Unit_Name := new String'("package body ");
when Task_Body =>
Unit_Name := new String'("task body ");
when Subprogram_Body =>
if Subprogram_Unit_Type = Procedure_Type then
Unit_Name := new String'("procedure ");
else
Unit_Name := new String'("function ");
end if;
when others =>
Unit_Name := new String'("");
end case;
Unit_Name := new String'(Unit_Name.all &
Value (Current_Scope_Simple_Name));
if not Token_Lists.Isempty (Token_Buffer) then
Unit_Name := new String'(Unit_Name.all & '(');
-- process second buffer. This buffer will contain all of the parameter
-- specifications(if any). Add the tokens to the list, and put spaces
-- where appropriate
Buffer_Iterator := Token_Lists.Makelistiter (Token_Buffer);
while Token_Lists.More (Buffer_Iterator) loop
Token_Lists.Next (Buffer_Iterator, Current_Token);
exit when Current_Token.Token.Gram_Sym_Val =
Pt.Returntokenvalue;
if Current_Token.Token.Gram_Sym_Val /= Pt.Colon_Tokenvalue and
Current_Token.Token.Gram_Sym_Val /=
Pt.Rightparen_Tokenvalue then
Unit_Name := new String'(Unit_Name.all & ' ' &
Token_Text (Current_Token.Token));
else
Unit_Name := new String'(Unit_Name.all &
Token_Text (Current_Token.Token));
end if;
end loop;
end if;
if Type_Of_Scope = Subprogram_Body and
Subprogram_Unit_Type = Function_Type then
Unit_Name := new String'(Unit_Name.all & " return " &
Value (Expanded_Name));
end if;
if Current_Nesting_Level > 0 and not Buffering_Colon_Declarations then
Token_Lists.Destroy (Token_Buffer);
end if;
return Unit_Name.all; -- return the string
end Get_Unit_Name;
-----------------------------------------------------------------
procedure Write_Body_Line (Line : in String) is
--| Effects
--|
--| The line is part of a procedure body. Write it to the
--| appropriate buffer file.
begin
if Current_Scope.Type_Of_Scope = Package_Specification then
if Current_Scope.In_Private_Part then
Bfp.Writeln_To_Buffer (Private_Body_File, Line);
else
Bfp.Writeln_To_Buffer (Public_Body_File, Line);
end if;
else
Bfp.Writeln_To_Buffer (Buffer_File, Line);
end if;
end Write_Body_Line;
-----------------------------------------------------------------------
procedure Write_Spec_Line (Line : in String) is
--| Effects
--|
--| The current line is a declaration or part of a package spec.
--| If the current unit is a package specification, write the line
--| to the appropriate package tracing file. Otherwise write it
--| directly to the instrumented source file.
begin
if Current_Scope.Type_Of_Scope = Package_Specification then
if Current_Scope.In_Private_Part then
Bfp.Writeln_To_Buffer (Private_Spec_File, Line);
else
Bfp.Writeln_To_Buffer (Public_Spec_File, Line);
end if;
else
Po.Put_Line (Sid.Instrumented_File, Line);
end if;
end Write_Spec_Line;
---------------------------------------------------------------
procedure Retrieve_Spec_With_List is
--| Effects
--|
--| Get the with list that was saved for the package spec.
--| If it named any units that are not in the with list
--| for the body, then add those names to the current
--| with list. This is used to generate "Putvar" calls to
--| those units.
Temp_List : String_Lists.List;
Temp_List_Iterator : String_Lists.Listiter;
Temp_List_Object : String_Type;
Saved_List : String_Lists.List;
Saved_List_Iterator : String_Lists.Listiter;
Saved_List_Object : String_Type;
Matched : Boolean;
begin
Saved_List := Bfp.Get_Spec_With_List (Value (Current_Scope.Scope_Name));
if not String_Lists.Isempty (Saved_List) then
Temp_List := String_Lists.Copy (With_List);
Saved_List_Iterator := String_Lists.Makelistiter (Saved_List);
while String_Lists.More (Saved_List_Iterator) loop
String_Lists.Next (Saved_List_Iterator, Saved_List_Object);
Matched := False;
Temp_List_Iterator := String_Lists.Makelistiter (Temp_List);
while String_Lists.More (Temp_List_Iterator) and
not Matched loop
String_Lists.Next (Temp_List_Iterator, Temp_List_Object);
Matched := Equal (Upper (Temp_List_Object),
Upper (Saved_List_Object));
end loop;
if not Matched then
String_Lists.Attach (With_List, Saved_List_Object);
else
String_Lists.Deleteitem (Temp_List, Temp_List_Object);
end if; -- not matched
end loop; -- while more (saved_list)
end if; -- not empty (saved_list)
end Retrieve_Spec_With_List;
----------------------------------------------------------------------
procedure Generate_Tracevar_Call (Varname : in String) is
--| Effects
--|
--| Write the text for a call to Source_Instrumenter_Added_Tracevar
--| to the appropriate buffer file.
begin
Write_Body_Line (" begin");
Write_Body_Line (" Source_Instrumenter_Added_Tracevar ");
Write_Body_Line (" (" &
Value (Create_Breakpoint.Get_Program_Unit) & ",");
Write_Body_Line (" " & """" & Varname & """, ");
Write_Body_Line (" " & Varname & ");");
Write_Body_Line (" exception");
Write_Body_Line (" when others => null;");
Write_Body_Line (" end;");
end Generate_Tracevar_Call;
---------------------------------------------------------------
procedure Generate_Putvars is
--| Effects
--|
--| Generate the procedure "putvars" for the current scope.
--| "Putvars" first calls "Tracevar" for the variables being
--| traced in this scope, and then calls the "putvars" for
--| enclosing scopes.
--| It is only called if Do_Type_Tracing is True.
Name_List_Iterator : Name_Lists.Listiter;
Next_Variable : Name_Record;
String_List_Iterator : String_Lists.Listiter;
Next_Name : String_Type;
Wrote_Something : Boolean := False;
begin
-- write the procedure spec --
if Current_Scope.Type_Of_Scope = Package_Specification then
if Current_Scope.In_Private_Part then
Write_Body_Line
("Procedure " & Value (Current_Scope.Scope_Name) &
"priv_" & Prefix & "Putvars is");
else
Write_Body_Line
("Procedure " & Value (Current_Scope.Scope_Name) &
"spec_" & Prefix & "Putvars is");
if Current_Nesting_Level = 1 then
Write_Body_Line (" TBX7_Task_Number: Natural := 1;");
end if;
end if;
else
Write_Body_Line ("Procedure " & Value (Current_Scope.Scope_Name) &
"_" & Prefix & "Putvars is");
end if;
Write_Body_Line ("begin");
-- first, call tracevar for the variables being traced in this scope
-- and then destroy the list.
Check_Lists;
Name_List_Iterator := Name_Lists.Makelistiter (Visible_List);
while Name_Lists.More (Name_List_Iterator) loop
Name_Lists.Next (Name_List_Iterator, Next_Variable);
if Next_Variable.Object_Mode = Read_Only or
Next_Variable.Object_Mode = Read_Write then
Generate_Tracevar_Call (Value (Next_Variable.Object_Name));
Wrote_Something := True;
end if;
Flush (Next_Variable.Object_Name);
end loop;
Name_Lists.Destroy (Visible_List);
-- If the current unit is a package body, and if its spec was
-- instrumented for type tracing, then trace any variables
-- from the spec (public and private).
if Current_Scope.Type_Of_Scope = Package_Body then
-- trace the variables from the private part
if Bfp.Package_Files_Exist
(Value (Current_Scope.Qualified_Name), Private_Files) then
Write_Body_Line (" " & Value (Current_Scope.Scope_Name) &
"priv_" & Prefix & "Putvars;");
end if; -- private files exist
-- trace the variables from the public part
if Bfp.Package_Files_Exist
(Value (Current_Scope.Qualified_Name), Public_Files) then
Write_Body_Line (" " & "Trace_Public_" &
Value (Current_Scope.Scope_Name) & "." &
Value (Current_Scope.Scope_Name) &
"spec_" & Prefix & "Putvars;");
Wrote_Something := True;
end if; -- public_files exist
end if; -- current scope = package body
if Current_Scope.Type_Of_Scope /= Package_Specification then
-- Call putvars for package specs declared in this scope.
-- Package specs nested in other package specs are handled by
-- the package tracing files. The Package_List will still be
-- needed in "End_Declarative_Part" so leave it intact.
String_List_Iterator := String_Lists.Makelistiter (Package_List);
while String_Lists.More (String_List_Iterator) loop
String_Lists.Next (String_List_Iterator, Next_Name);
Write_Body_Line (" " & Value (Current_Scope.Qualified_Name) &
".Trace_Public_" & Value (Next_Name) &
"." & Value (Next_Name) &
"spec_" & Prefix & "Putvars;");
Wrote_Something := True;
end loop;
-- if this is the outer scope, then call putvars for packages
-- named in the context_clause
if Current_Nesting_Level = 1 then
String_List_Iterator := String_Lists.Makelistiter (With_List);
while String_Lists.More (String_List_Iterator) loop
String_Lists.Next (String_List_Iterator, Next_Name);
Write_Body_Line (" Trace_Public_" & Value (Next_Name) &
"." & Value (Next_Name) &
"spec_" & Prefix & "Putvars;");
Flush (Next_Name);
Wrote_Something := True;
end loop;
String_Lists.Destroy (With_List);
end if;
-- call putvars for the outer scope
if not Is_Empty (Current_Outer_Scope.Scope_Name) then
Write_Body_Line
(" " & Value (Current_Outer_Scope.Putvar_Name) &
"_" & Prefix & "Putvars;");
Wrote_Something := True;
end if;
end if;
-- current_scope /= package_spec
if not Wrote_Something then
Write_Body_Line (" null;");
end if;
Write_Body_Line ("end;");
end Generate_Putvars;
---------------------------------------------------------------
function Ask_User_About_Package return Boolean is
--| Effects
--|
--| Before instrumenting a package specification which is a
--| library unit, ask the user if the text of the package
--| spec should be included in the instrumented source which
--| will be compiled. The user ought not to recompile a package
--| specification if the body is not available for recompilation.
Answer : String (1 .. 80);
Index : Integer;
begin
Text_Io.New_Line (2);
Text_Io.Put_Line (Ascii.Bel & Ascii.Bel &
"Instrumenting the package specification for ");
Text_Io.Put_Line (Value (Current_Scope_Simple_Name));
Text_Io.Put_Line
("Do you want this package specification included in ");
Text_Io.Put_Line
("the instrumented source? Recompiling it will require ");
Text_Io.Put_Line ("recompiling its body and all dependent units.");
loop
Text_Io.Put ("Y/N ");
Text_Io.Get_Line (Text_Io.Standard_Input, Answer, Index);
Text_Io.Put_Line ("");
case Answer (1) is
when 'Y' | 'y' =>
return True;
when 'N' | 'n' =>
return False;
when others =>
null;
end case;
end loop;
end Ask_User_About_Package;
---------------------------------------------------------------
procedure Discard_List (Which_List : in out Name_Lists.List) is
--| Effects
--|
--| Before destroying a name_list, the string_type field
--| needs to be flushed.
Iter : Name_Lists.Listiter;
Next_Object : Name_Record;
begin
if not Name_Lists.Isempty (Which_List) then
Iter := Name_Lists.Makelistiter (Which_List);
while Name_Lists.More (Iter) loop
Name_Lists.Next (Iter, Next_Object);
Flush (Next_Object.Object_Name);
end loop;
Name_Lists.Destroy (Which_List);
end if;
end Discard_List;
--------------------------------------------------------------------
procedure Set_Scope_Records (Type_Of_Scope : in Scope_Type) is
--| Effects
--|
--| This is called by Increment_Scope to set the
--| Current_Scope and Current_Outer_Scope variables.
begin
if Current_Nesting_Level = 0 then
if not Separate_Unit then
Current_Scope_Qualified_Name := Current_Scope_Simple_Name;
Current_Outer_Scope := (Create (""), Create (""), A_Block,
Create (""), False, Entry_Exit);
else
Current_Scope_Qualified_Name :=
Expanded_Name & "." & Current_Scope_Simple_Name;
-- Current_Outer_Scope was set up in Save_Separate_Name
end if;
else
-- Current_Nesting_Level /= 0
Current_Scope_Qualified_Name := Current_Scope.Qualified_Name &
"." & Current_Scope_Simple_Name;
Current_Outer_Scope := Current_Scope;
end if;
Current_Scope := (Current_Scope_Simple_Name,
Current_Scope_Qualified_Name,
Type_Of_Scope, Create (""),
False, Current_Trace_Level);
if Do_Type_Tracing then
Current_Scope.Putvar_Name := Current_Scope_Simple_Name;
end if;
end Set_Scope_Records;
---------------------------------------------------------------
procedure Add_Withs_To_Body is
--| Effects
--|
--| This is called from Increment_Scope when the current
--| nesting level is 0, and the type of unit is either
--| a subprogram body or a package body. Add the with
--| and use clauses that will be needed by the instrumented
--| source and retrieve any with clauses that were given for
--| the specification.
Iterator : String_Lists.Listiter;
Next_Object : String_Type;
begin
if not Separate_Unit then
Po.Put_Line
(Sid.Instrumented_File,
"with Run_Time_Monitor, Type_Definitions, String_Pkg;");
Po.Put_Line (Sid.Instrumented_File,
"use Run_Time_Monitor, Type_Definitions, String_Pkg;");
if Do_Type_Tracing then
Po.Put_Line
(Sid.Instrumented_File,
"with Trace_Predefined_Types; use Trace_Predefined_Types;");
Retrieve_Spec_With_List;
end if; -- not separate and type tracing
end if; -- not separate
-- if the current unit is a package body and its spec was instrumented
-- then with and use its public trace package
if Current_Scope.Type_Of_Scope = Package_Body and then
Do_Type_Tracing and then
Bfp.Package_Files_Exist
(Value (Current_Scope.Qualified_Name), Public_Files) then
Po.Put_Line (Sid.Instrumented_File,
"with Trace_Public_" &
Value (Current_Scope_Simple_Name) & "; " &
"use Trace_Public_" &
Value (Current_Scope_Simple_Name) & ";");
end if; -- package_body and type_tracing
-- now add with and use for anything in the with list that
-- has been instrumented. Note that the with list won't have
-- anything in it if type_tracing is turned off.
Iterator := String_Lists.Makelistiter (With_List);
while String_Lists.More (Iterator) loop
String_Lists.Next (Iterator, Next_Object);
Po.Put_Line (Sid.Instrumented_File,
"with Trace_Public_" & Value (Next_Object) & "; " &
"use Trace_Public_" & Value (Next_Object) & ";");
end loop;
end Add_Withs_To_Body;
------------------------------------------------------------------
procedure Add_Withs_To_Trace_Packages is
--| Effects
--|
--| This is called by Initialize_Trace_Packages when the current
--| nesting level is 0. The tracing packages have to have visibility
--| of the package specification being traced, the public tracing
--| packages of any instrumented units in the context clause, and
--| other assorted utility packages.
Iterator : String_Lists.Listiter;
Next_Object : String_Type;
begin
-- with and use the package being traced
Bfp.Writeln_To_Buffer
(Public_Spec_File,
"with " & Value (Current_Scope_Simple_Name) & "; " &
"use " & Value (Current_Scope_Simple_Name) & ";");
-- with and use the support packages
Bfp.Writeln_To_Buffer (Public_Spec_File,
"with Run_Time_Monitor, Type_Definitions," &
" String_Pkg, Trace_Predefined_Types;");
Bfp.Writeln_To_Buffer (Public_Spec_File,
"use Run_Time_Monitor, Type_Definitions," &
" String_Pkg, Trace_Predefined_Types;");
-- with and use the public trace packages of anything
-- in the with list that was instrumented.
Iterator := String_Lists.Makelistiter (With_List);
while String_Lists.More (Iterator) loop
String_Lists.Next (Iterator, Next_Object);
Bfp.Writeln_To_Buffer (Public_Spec_File,
"with Trace_Public_" & Value (Next_Object) &
"; " & "use Trace_Public_" &
Value (Next_Object) & ";");
end loop;
end Add_Withs_To_Trace_Packages;
-----------------------------------------------------------------
procedure Initialize_Trace_Packages is
--| Effects
--|
--| This procedure is called by Increment_Scope when the
--| current scope is a package specification and type tracing
--| is on.
begin
if Current_Outer_Scope.Type_Of_Scope = Package_Specification then
-- close the private files for the outer package
-- and open new ones for the current package.
Bfp.Close_Package_Files (Private_Files);
Bfp.Create_Package_Files
(Value (Current_Scope.Qualified_Name), Private_Files);
else
Bfp.Create_Package_Files
(Value (Current_Scope.Qualified_Name), All_Files);
if Current_Nesting_Level = 0 then
if not String_Lists.Isempty (With_List) then
Bfp.Save_Spec_With_List
(Value (Current_Scope.Qualified_Name), With_List);
end if;
Add_Withs_To_Trace_Packages;
end if; -- Current_Nesting_Level = 0
-- Start the public trace packages
Bfp.Writeln_To_Buffer
(Public_Spec_File, "package Trace_Public_" &
Value (Current_Scope_Simple_Name) & " is");
Bfp.Writeln_To_Buffer
(Public_Body_File,
"package body Trace_Public_" &
Value (Current_Scope_Simple_Name) & " is ");
Bfp.Writeln_To_Buffer
(Public_Spec_File,
"Procedure " & Value (Current_Scope_Simple_Name) &
"spec_" & Prefix & "Putvars;");
-- start new visible variable list
List_Stack_Pkg.Push (Visible_List_Stack, Visible_List);
Visible_List := Name_Lists.Create;
end if; -- if current_outer_scope = package_spec
end Initialize_Trace_Packages;
-----------------------------------------------------------------
procedure Close_Trace_Packages is
--| Effects
--|
--| This procedure is called by Decrement_Scope when type
--| tracing is true and the current unit is a package
--| specification. Finish the tracing information packaages.
begin
-- Finish the private tracing packages
if Current_Scope.In_Private_Part then
Generate_Putvars; -- for variables declared in the private part
List_Stack_Pkg.Pop (Visible_List_Stack, Visible_List);
else
-- there was no private part
Current_Scope.In_Private_Part := True;
Bfp.Writeln_To_Buffer
(Private_Spec_File,
"Procedure " & Value (Current_Scope.Scope_Name) &
"priv_" & Prefix & "Putvars;");
Bfp.Writeln_To_Buffer
(Private_Body_File,
"Procedure " & Value (Current_Scope.Scope_Name) &
"priv_" & Prefix & "Putvars is");
Bfp.Writeln_To_Buffer (Private_Body_File, "begin");
Bfp.Writeln_To_Buffer (Private_Body_File, " null;");
Bfp.Writeln_To_Buffer (Private_Body_File, "end;");
end if;
Current_Scope.In_Private_Part := False;
-- finish the public tracing packages
if Current_Outer_Scope.Type_Of_Scope = Package_Specification then
-- reopen private files for outer scope and continue
Bfp.Close_Package_Files (Private_Files);
Bfp.Reopen_Private_Files (Value
(Current_Outer_Scope.Qualified_Name));
else
Generate_Putvars;
List_Stack_Pkg.Pop (Visible_List_Stack, Visible_List);
-- End the public trace packages
Bfp.Writeln_To_Buffer
(Public_Spec_File, "end Trace_Public_" &
Value (Current_Scope.Scope_Name) & ";");
Bfp.Writeln_To_Buffer
(Public_Body_File, "end Trace_Public_" &
Value (Current_Scope.Scope_Name) & ";");
Bfp.Close_Package_Files (All_Files);
Bfp.Copy_Package_Files (Public_Spec,
Value (Current_Scope.Qualified_Name),
Sid.Instrumented_File);
if Current_Nesting_Level = 1 then
Bfp.Copy_Package_Files (Public_Body,
Value (Current_Scope.Qualified_Name),
Sid.Instrumented_File);
else
Po.Put_Line (Sid.Instrumented_File,
"use Trace_Public_" &
Value (Current_Scope.Scope_Name) & ";");
String_Lists.Attach
(Package_List, Make_Persistent (Current_Scope.Scope_Name));
end if; -- if current nesting level = 1
end if; -- if outer_scope = package_spec
end Close_Trace_Packages;
-----------------------------------------------------------------
end Source_Instrumenter_Utilities;